154 lines
6.7 KiB
Scheme
154 lines
6.7 KiB
Scheme
;; tile game by Dave Tucker
|
|
#lang frtime
|
|
(require frtime/animation
|
|
frtime/gui
|
|
mzlib/class)
|
|
|
|
(define-struct tile (row col num color))
|
|
(define-struct state (tiles blank-row blank-col))
|
|
|
|
(define hue (list-ref '(0 1 4 5) (make-choice "Color: " '("Black" "Blue" "Red" "Magenta"))))
|
|
(define reverse-keys? (make-check-box "Reverse keys? "))
|
|
(define animate? (make-check-box "Animate? " #t))
|
|
(define animation-speed (list-ref '(250 500 750) (make-choice "Animation speed: " '("Fast" "Medium" "Slow"))))
|
|
(define smoothness (list-ref '(10 20 50) (make-choice "Animation smoothness: " '("Smooth" "Normal" "Coarse"))))
|
|
|
|
(set-cell! fine-timer-granularity smoothness)
|
|
|
|
(define ((component i) bit)
|
|
(if (not (zero? (bitwise-and hue bit)))
|
|
1
|
|
(/ i 16)))
|
|
|
|
(define initial-tiles
|
|
(build-list 15
|
|
(lambda (i)
|
|
(make-tile (quotient i 4)
|
|
(remainder i 4)
|
|
i
|
|
(apply make-rgb (map (component i) '(4 2 1)))))))
|
|
|
|
(define config
|
|
(accum-b (merge-e
|
|
(left-clicks
|
|
. ==> .
|
|
(lambda (ev)
|
|
(lambda (st)
|
|
(let* ([r (quotient (send ev get-y) 100)]
|
|
[c (quotient (send ev get-x) 100)]
|
|
[st1 (caar st)]
|
|
[br (state-blank-row st1)]
|
|
[bc (state-blank-col st1)])
|
|
(cond
|
|
[(and (= r br) (not (= c bc)))
|
|
`((,(make-state
|
|
(let ([dir (quotient (- c bc) (abs (- c bc)))])
|
|
(map (lambda (t)
|
|
(if (and (= (tile-row t) r)
|
|
(or (<= (+ bc dir) (tile-col t) c)
|
|
(<= c (tile-col t) (+ bc dir))))
|
|
(make-tile (tile-row t)
|
|
(- (tile-col t) dir)
|
|
(tile-num t)
|
|
(tile-color t))
|
|
t))
|
|
(state-tiles st1)))
|
|
r
|
|
c)
|
|
,(value-now milliseconds))
|
|
,(first st))]
|
|
[(and (not (= r br)) (= c bc))
|
|
`((,(make-state
|
|
(let ([dir (quotient (- r br) (abs (- r br)))])
|
|
(map (lambda (t)
|
|
(if (and (= (tile-col t) c)
|
|
(or (<= (+ dir br) (tile-row t) r)
|
|
(<= r (tile-row t) (+ dir br))))
|
|
(make-tile (- (tile-row t) dir)
|
|
(tile-col t)
|
|
(tile-num t)
|
|
(tile-color t))
|
|
t))
|
|
(state-tiles st1)))
|
|
r
|
|
c)
|
|
,(value-now milliseconds))
|
|
,(first st))]
|
|
[#t st])))))
|
|
(key-strokes
|
|
. ==> .
|
|
(lambda (ev)
|
|
(lambda (st)
|
|
(let/ec k
|
|
(let*-values ([(st1) (caar st)]
|
|
[(br) (state-blank-row st1)]
|
|
[(bc) (state-blank-col st1)]
|
|
[(r c)
|
|
(let ([ev (if (value-now reverse-keys?)
|
|
(case ev
|
|
[(left) 'right]
|
|
[(right) 'left]
|
|
[(up) 'down]
|
|
[(down) 'up])
|
|
ev)])
|
|
(case ev
|
|
[(left) (if (< bc 3)
|
|
(values br (add1 bc))
|
|
(k st))]
|
|
[(right) (if (> bc 0)
|
|
(values br (sub1 bc))
|
|
(k st))]
|
|
[(up) (if (< br 3)
|
|
(values (add1 br) bc)
|
|
(k st))]
|
|
[(down) (if (> br 0)
|
|
(values (sub1 br) bc)
|
|
(k st))]
|
|
[else (k st)]))])
|
|
`((,(make-state (map (lambda (t)
|
|
(if (and (= (tile-row t) r) (= (tile-col t) c))
|
|
(make-tile br bc (tile-num t) (tile-color t))
|
|
t))
|
|
(state-tiles st1))
|
|
r
|
|
c)
|
|
,(value-now milliseconds))
|
|
,(first st))))))))
|
|
(let ([init-state (make-state initial-tiles 3 3)]
|
|
[init-time (- (value-now milliseconds) 1000)])
|
|
(list (list init-state init-time)
|
|
(list init-state init-time)))))
|
|
|
|
(define (tile->shape t)
|
|
(make-rect (make-posn (+ 1 (* (tile-col t) 100))
|
|
(+ 1 (* (tile-row t) 100)))
|
|
98
|
|
98
|
|
(tile-color t)))
|
|
|
|
(define (tile-pos t)
|
|
(make-posn (+ 1 (* (tile-col t) 100))
|
|
(+ 1 (* (tile-row t) 100))))
|
|
|
|
(define (linear-comb x1 x2 frac)
|
|
(+ (* frac x1) (* (- 1 frac) x2)))
|
|
|
|
(define (blend-posns p1 p2 frac)
|
|
(make-posn (linear-comb (posn-x p1) (posn-x p2) frac)
|
|
(linear-comb (posn-y p1) (posn-y p2) frac)))
|
|
|
|
(define (tiles->shape t0 t1 frac)
|
|
(make-rect (blend-posns (tile-pos t0) (tile-pos t1) frac)
|
|
98
|
|
98
|
|
(tile-color t0)))
|
|
|
|
(display-shapes
|
|
(if animate?
|
|
(map (lambda (t1 t2)
|
|
(tiles->shape t1 t2 (min 1 (/ (- milliseconds (cadar config))
|
|
animation-speed))))
|
|
(state-tiles (caar config))
|
|
(state-tiles (caadr config)))
|
|
(map tile->shape (state-tiles (caar config)))))
|