314 lines
12 KiB
Racket
314 lines
12 KiB
Racket
#lang mzscheme
|
|
(require mzlib/etc
|
|
mzlib/class
|
|
mzlib/unit
|
|
mred)
|
|
|
|
(provide game@)
|
|
|
|
(define game@ (unit (import) (export)
|
|
|
|
(define (get-bitmap bitmap)
|
|
(define f (make-object dialog% "Choose Size" #f #f #f #f #f '(resize-border)))
|
|
(define bm-panel (make-object vertical-panel% f))
|
|
(define bm-message (make-object message% bitmap bm-panel))
|
|
(define size-message
|
|
(make-object message% (format "Image size: ~a x ~a pixels"
|
|
(send bitmap get-width)
|
|
(send bitmap get-height))
|
|
bm-panel))
|
|
(define wide-panel (make-object vertical-panel% f '(border)))
|
|
(define sw (make-object slider% "Tiles (width)" 2 30 wide-panel
|
|
(lambda (_1 _2) (update-horizontal-cutoff))))
|
|
(define tall-panel (make-object vertical-panel% f '(border)))
|
|
(define sh (make-object slider% "Tiles (height)" 2 30 tall-panel
|
|
(lambda (_1 _2) (update-vertical-cutoff))))
|
|
(define button-panel (make-object horizontal-panel% f))
|
|
|
|
(define cancelled? #t)
|
|
|
|
(define cancel (make-object button% "Cancel" button-panel
|
|
(lambda (_1 _2) (send f show #f))))
|
|
(define ok (make-object button% "OK" button-panel
|
|
(lambda (_1 _2)
|
|
(set! cancelled? #f)
|
|
(send f show #f)) '(border)))
|
|
|
|
(define vertical-cutoff 0)
|
|
(define vertical-cutoff-message (make-object message% "" tall-panel))
|
|
|
|
(define horizontal-cutoff 0)
|
|
(define horizontal-cutoff-message (make-object message% "" wide-panel))
|
|
|
|
(define (update-vertical-cutoff)
|
|
(set! vertical-cutoff (modulo (send bitmap get-height) (send sh get-value)))
|
|
(send vertical-cutoff-message set-label
|
|
(if (= 0 vertical-cutoff)
|
|
""
|
|
(format "Vertical cutoff ~a pixels" vertical-cutoff))))
|
|
(define (update-horizontal-cutoff)
|
|
(set! horizontal-cutoff (modulo (send bitmap get-width) (send sw get-value)))
|
|
(send horizontal-cutoff-message set-label
|
|
(if (= 0 horizontal-cutoff)
|
|
""
|
|
(format "Horizontal cutoff ~a pixels" horizontal-cutoff))))
|
|
|
|
(send horizontal-cutoff-message stretchable-width #t)
|
|
(send vertical-cutoff-message stretchable-width #t)
|
|
(update-vertical-cutoff)
|
|
(update-horizontal-cutoff)
|
|
(send button-panel set-alignment 'right 'center)
|
|
(send button-panel stretchable-height #f)
|
|
(send bm-panel set-alignment 'center 'center)
|
|
(send wide-panel stretchable-height #f)
|
|
(send tall-panel stretchable-height #f)
|
|
(make-object grow-box-spacer-pane% button-panel)
|
|
(send f show #t)
|
|
|
|
(if cancelled?
|
|
(values #f #f #f)
|
|
(let* ([nb (make-object bitmap%
|
|
(- (send bitmap get-width) horizontal-cutoff)
|
|
(- (send bitmap get-height) vertical-cutoff))]
|
|
[bdc (make-object bitmap-dc% nb)])
|
|
(send bdc draw-bitmap-section bitmap 0 0 0 0
|
|
(- (send bitmap get-width) horizontal-cutoff)
|
|
(- (send bitmap get-height) vertical-cutoff))
|
|
(send bdc set-bitmap #f)
|
|
(values nb (send sw get-value) (send sh get-value)))))
|
|
|
|
(define-struct loc (x y))
|
|
;; board = (vector-of (vector-of (union #f (make-loc n1 n2))))
|
|
|
|
(define (board-for-each board f)
|
|
(let loop ([i (vector-length board)])
|
|
(unless (zero? i)
|
|
(let ([row (vector-ref board (- i 1))])
|
|
(let loop ([j (vector-length row)])
|
|
(unless (zero? j)
|
|
(f (- i 1) (- j 1) (vector-ref row (- j 1)))
|
|
(loop (- j 1)))))
|
|
(loop (- i 1)))))
|
|
|
|
(define (move-one board from-i from-j to-i to-j)
|
|
(let ([from-save (board-ref board from-i from-j)]
|
|
[to-save (board-ref board to-i to-j)])
|
|
(board-set! board from-i from-j to-save)
|
|
(board-set! board to-i to-j from-save)))
|
|
|
|
(define (board-set! board i j v)
|
|
(vector-set! (vector-ref board i) j v))
|
|
(define (board-ref board i j)
|
|
(vector-ref (vector-ref board i) j))
|
|
|
|
(define (get-board-width board)
|
|
(vector-length board))
|
|
(define (get-board-height board)
|
|
(vector-length (vector-ref board 0)))
|
|
|
|
(define (randomize-board board hole-i hole-j)
|
|
(let ([board-width (get-board-width board)]
|
|
[board-height (get-board-height board)])
|
|
(let loop ([no-good #f]
|
|
[i (* 10 board-width board-height)]
|
|
[m-hole-i hole-i]
|
|
[m-hole-j hole-j])
|
|
(cond
|
|
[(zero? i) ;; move hole back to last spot
|
|
(let ([i-diff (abs (- m-hole-i hole-i))])
|
|
(let loop ([i 0])
|
|
(unless (= i i-diff)
|
|
(move-one board (+ m-hole-i i)
|
|
m-hole-j (+ m-hole-i i (if (< m-hole-i hole-i) +1 -1))
|
|
m-hole-j)
|
|
(loop (+ i 1)))))
|
|
(let ([j-diff (abs (- m-hole-j hole-j))])
|
|
(let loop ([j 0])
|
|
(unless (= j j-diff)
|
|
(move-one board hole-i (+ m-hole-j j)
|
|
hole-i (+ m-hole-j j (if (< m-hole-j hole-j) +1 -1)))
|
|
(loop (+ j 1)))))]
|
|
[else
|
|
(let ([this-dir (get-random-number 4 no-good)])
|
|
(let-values ([(new-i new-j)
|
|
(case this-dir
|
|
;; up
|
|
[(0) (values (- m-hole-i 1) m-hole-j)]
|
|
[(1) (values (+ m-hole-i 1) m-hole-j)]
|
|
[(2) (values m-hole-i (- m-hole-j 1))]
|
|
[(3) (values m-hole-i (+ m-hole-j 1))])])
|
|
(if (and (<= 0 new-i)
|
|
(< new-i board-width)
|
|
(<= 0 new-j)
|
|
(< new-j board-height))
|
|
(let ([next-no-good
|
|
(case this-dir [(0) 1] [(1) 0] [(2) 3] [(3) 2])])
|
|
(move-one board new-i new-j m-hole-i m-hole-j)
|
|
(loop next-no-good (- i 1) new-i new-j))
|
|
(loop no-good (- i 1) m-hole-i m-hole-j))))]))))
|
|
|
|
(define (get-random-number bound no-good)
|
|
(let ([raw (random (- bound 1))])
|
|
(cond [(not no-good) raw]
|
|
[(< raw no-good) raw]
|
|
[else (+ raw 1)])))
|
|
|
|
(define line-brush
|
|
(send the-brush-list find-or-create-brush "black" 'transparent))
|
|
(define line-pen (send the-pen-list find-or-create-pen "white" 1 'solid))
|
|
(define mistake-brush
|
|
(send the-brush-list find-or-create-brush "black" 'transparent))
|
|
(define mistake-pen (send the-pen-list find-or-create-pen "red" 1 'solid))
|
|
(define pict-brush (send the-brush-list find-or-create-brush "black" 'solid))
|
|
(define pict-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
|
(define white-brush (send the-brush-list find-or-create-brush "white" 'solid))
|
|
(define white-pen (send the-pen-list find-or-create-pen "white" 1 'solid))
|
|
|
|
(define slidey-canvas%
|
|
(class canvas%
|
|
(init-field bitmap board-width board-height)
|
|
|
|
(define show-mistakes? #f)
|
|
(define/public (show-mistakes nv)
|
|
(set! show-mistakes? nv)
|
|
(unless solved? (on-paint)))
|
|
|
|
(define solved? #f)
|
|
|
|
(define board
|
|
(build-vector
|
|
board-width
|
|
(lambda (i) (build-vector board-height (lambda (j) (make-loc i j))))))
|
|
(define hole-i (- board-width 1))
|
|
(define hole-j (- board-height 1))
|
|
(board-set! board hole-i hole-j #f)
|
|
|
|
(define/override (on-paint)
|
|
(if solved?
|
|
(send (get-dc) draw-bitmap bitmap 0 0)
|
|
(board-for-each board (lambda (i j v) (draw-cell i j)))))
|
|
|
|
(define/override (on-event evt)
|
|
(unless solved?
|
|
(when (send evt button-down? 'left)
|
|
(let-values ([(i j) (xy->ij (send evt get-x) (send evt get-y))])
|
|
(slide i j)))))
|
|
(inherit get-client-size get-dc)
|
|
|
|
(define/private (check-end-condition)
|
|
(let ([answer #t])
|
|
(board-for-each
|
|
board
|
|
(lambda (i j v)
|
|
(when v
|
|
(unless (and (= i (loc-x v)) (= j (loc-y v)))
|
|
(set! answer #f)))))
|
|
(when answer (set! solved? #t))))
|
|
|
|
(define/private (slide i j)
|
|
(cond
|
|
[(= j hole-j)
|
|
(let loop ([new-hole-i hole-i])
|
|
(unless (= new-hole-i i)
|
|
(let ([next (if (< i hole-i) sub1 add1)])
|
|
(move-one board (next new-hole-i) hole-j new-hole-i hole-j)
|
|
(draw-cell new-hole-i hole-j)
|
|
(draw-cell (next new-hole-i) hole-j)
|
|
(loop (next new-hole-i)))))
|
|
(set! hole-i i)
|
|
(check-end-condition)
|
|
(when solved? (on-paint))]
|
|
[(= i hole-i)
|
|
(let loop ([new-hole-j hole-j])
|
|
(unless (= new-hole-j j)
|
|
(let ([next (if (< j hole-j)
|
|
sub1
|
|
add1)])
|
|
(move-one board hole-i (next new-hole-j) hole-i new-hole-j)
|
|
(draw-cell hole-i new-hole-j)
|
|
(draw-cell hole-i (next new-hole-j))
|
|
(loop (next new-hole-j)))))
|
|
(set! hole-j j)
|
|
(check-end-condition)
|
|
(when solved?
|
|
(on-paint))]
|
|
[else (void)]))
|
|
|
|
(define/private (xy->ij x y)
|
|
(let-values ([(w h) (get-client-size)])
|
|
(values (inexact->exact (floor (* board-width (/ x w))))
|
|
(inexact->exact (floor (* board-height (/ y h)))))))
|
|
|
|
(define/private (ij->xywh i j)
|
|
(let-values ([(w h) (get-client-size)])
|
|
(let ([cell-w (/ w board-width)]
|
|
[cell-h (/ h board-height)])
|
|
(values (* i cell-w) (* j cell-h) cell-w cell-h))))
|
|
(define/private (draw-cell draw-i draw-j)
|
|
(let-values ([(xd yd wd hd) (ij->xywh draw-i draw-j)])
|
|
(let* ([dc (get-dc)]
|
|
[indices (board-ref board draw-i draw-j)])
|
|
(if indices
|
|
(let ([bm-i (loc-x indices)]
|
|
[bm-j (loc-y indices)])
|
|
(let-values ([(xs ys ws hs) (ij->xywh bm-i bm-j)])
|
|
(send dc set-pen pict-pen)
|
|
(send dc set-brush pict-brush)
|
|
(send dc draw-bitmap-section bitmap xd yd xs ys wd hd)
|
|
(if (and show-mistakes?
|
|
(or (not (= draw-i bm-i))
|
|
(not (= draw-j bm-j))))
|
|
(begin (send dc set-pen mistake-pen)
|
|
(send dc set-brush mistake-brush))
|
|
(begin (send dc set-pen line-pen)
|
|
(send dc set-brush line-brush)))
|
|
(send dc draw-rectangle xd yd wd hd)))
|
|
(begin (send dc set-pen white-pen)
|
|
(send dc set-brush white-brush)
|
|
(send dc draw-rectangle xd yd wd hd))))))
|
|
|
|
(inherit stretchable-width stretchable-height
|
|
min-client-width min-client-height)
|
|
(super-instantiate ())
|
|
(randomize-board board hole-i hole-j)
|
|
(stretchable-width #f)
|
|
(stretchable-height #f)
|
|
(min-client-width (send bitmap get-width))
|
|
(min-client-height (send bitmap get-height))))
|
|
|
|
(define f (make-object frame% "Slidey"))
|
|
(define p (make-object horizontal-panel% f))
|
|
(send p set-alignment 'center 'center)
|
|
(define slidey-canvas
|
|
(make-object slidey-canvas%
|
|
(make-object bitmap%
|
|
(build-path (collection-file-path "11.jpg" "games" "slidey")))
|
|
6 6 p))
|
|
(define bp (make-object horizontal-panel% f))
|
|
(send bp stretchable-height #f)
|
|
(define show-mistakes
|
|
(make-object check-box% "Show misplaced pieces" bp
|
|
(lambda ___ (send slidey-canvas show-mistakes (send show-mistakes get-value)))))
|
|
(make-object grow-box-spacer-pane% bp)
|
|
|
|
(define (change-bitmap)
|
|
(let ([fn (get-file)])
|
|
(when fn
|
|
(let ([bm (make-object bitmap% fn)])
|
|
(cond
|
|
[(send bm ok?)
|
|
(let-values ([(bitmap w h) (get-bitmap bm)])
|
|
(when bitmap
|
|
(send p change-children (lambda (l) null))
|
|
(set! slidey-canvas (make-object slidey-canvas% bitmap w h p))))]
|
|
[else (message-box "Slidey" (format "Unrecognized image format: ~a" fn))])))))
|
|
|
|
(define mb (make-object menu-bar% f))
|
|
(define file-menu (make-object menu% "File" mb))
|
|
(make-object menu-item% "Open Image" file-menu (lambda (_1 _2) (change-bitmap)) #\o)
|
|
(make-object menu-item% "Close Window" file-menu (lambda (_1 _2) (send f show #f)) #\w)
|
|
|
|
(send f show #t)
|
|
|
|
))
|