improved same game
- new drawing algorithm (makes the connected regions easier to see) - different scoring mechanism (give points for having few pieces left) - make the window resizable - general cleanup of the code
This commit is contained in:
Robby Findler
parent
f1e13a7921
commit
2553553f09
|
|
@ -1,388 +1,426 @@
|
||||||
(module same mzscheme
|
#lang racket/base
|
||||||
(require mzlib/etc
|
(require racket/class
|
||||||
mzlib/class
|
racket/unit
|
||||||
mzlib/unit
|
racket/list
|
||||||
mred
|
racket/gui/base
|
||||||
mzlib/list
|
"../show-scribbling.ss")
|
||||||
"../show-scribbling.ss")
|
|
||||||
|
|
||||||
(provide game@)
|
|
||||||
|
|
||||||
(define game@
|
|
||||||
(unit
|
|
||||||
(import)
|
|
||||||
(export)
|
|
||||||
|
|
||||||
(define board-width 20)
|
|
||||||
(define board-height 10)
|
|
||||||
(define cell-size 30)
|
|
||||||
(define colors (map (lambda (x) (make-object color% x)) (list "blue" "red" "magenta" "yellow" "cyan")))
|
|
||||||
(define pens (map (lambda (x) (make-object pen% x 1 'solid)) colors))
|
|
||||||
(define brushes (map (lambda (x) (make-object brush% x 'solid)) colors))
|
|
||||||
(define white-pen (make-object pen% "white" 1 'solid))
|
|
||||||
(define white-brush (make-object brush% "white" 'solid))
|
|
||||||
|
|
||||||
;; build-board : (-> (vectorof (vectorof (vector (union num #f) boolean))))
|
|
||||||
; this represents the board. Each entry is the color index of
|
|
||||||
; the piece and a node to mark for the depth-first traversal.
|
|
||||||
; #f for the color index indicates an eliminated piece.
|
|
||||||
(define (build-board)
|
|
||||||
(build-vector
|
|
||||||
board-width
|
|
||||||
(lambda (i)
|
|
||||||
(build-vector
|
|
||||||
board-height
|
|
||||||
(lambda (j)
|
|
||||||
(vector
|
|
||||||
(begin
|
|
||||||
(if (= j (- board-height 1))
|
|
||||||
(- (length colors) 1)
|
|
||||||
(modulo i (- (length colors) 1)))
|
|
||||||
(random (length colors)))
|
|
||||||
#f))))))
|
|
||||||
|
|
||||||
(define board (build-board))
|
|
||||||
|
|
||||||
(define game-over? #f)
|
|
||||||
|
|
||||||
(define score 0)
|
|
||||||
(define (calc-score n)
|
|
||||||
(cond
|
|
||||||
[(= n 2) 2]
|
|
||||||
[else (- (* (- n 1) (- n 1)) (- n 3))]))
|
|
||||||
|
|
||||||
(define same-canvas%
|
|
||||||
(class canvas%
|
|
||||||
(inherit get-dc get-client-size)
|
|
||||||
(define/private (get-width) (let-values ([(w h) (get-client-size)]) w))
|
|
||||||
(define/private (get-height) (let-values ([(w h) (get-client-size)]) h))
|
|
||||||
(define/private (get-x-step) (/ (get-width) board-width))
|
|
||||||
(define/private (get-y-step) (/ (get-height) board-height))
|
|
||||||
[define/public draw-cell
|
|
||||||
(lambda (dc highlight? i j)
|
|
||||||
(let ([index (vector-ref (vector-ref (vector-ref board i) j) 0)]
|
|
||||||
[x (* i (get-x-step))]
|
|
||||||
[y (* j (get-y-step))])
|
|
||||||
(send dc set-brush white-brush)
|
|
||||||
(send dc set-pen white-pen)
|
|
||||||
(send dc draw-rectangle x y (get-x-step) (get-y-step))
|
|
||||||
(when index
|
|
||||||
(send dc set-brush (list-ref brushes index))
|
|
||||||
(send dc set-pen (list-ref pens index))
|
|
||||||
(cond
|
|
||||||
[highlight?
|
|
||||||
(send dc draw-ellipse
|
|
||||||
(floor (+ x (/ (get-x-step) 4)))
|
|
||||||
(floor (+ y (/ (get-y-step) 4)))
|
|
||||||
(floor (/ (get-x-step) 2))
|
|
||||||
(floor (/ (get-y-step) 2)))]
|
|
||||||
[else
|
|
||||||
(send dc draw-ellipse x y (get-x-step) (get-y-step))]))))]
|
|
||||||
|
|
||||||
[define/public draw-line
|
|
||||||
(lambda (dc i)
|
|
||||||
(let ([show-turned? (> (length turned) 1)])
|
|
||||||
(let loop ([j board-height])
|
|
||||||
(cond
|
|
||||||
[(zero? j) (void)]
|
|
||||||
[else
|
|
||||||
(draw-cell dc (and show-turned? (member (list i (- j 1)) turned)) i (- j 1))
|
|
||||||
(loop (- j 1))]))))]
|
|
||||||
|
|
||||||
[define/public find-same-colors
|
|
||||||
(lambda (i j)
|
|
||||||
(let* ([index (vector-ref (vector-ref (vector-ref board i) j) 0)]
|
|
||||||
[ans
|
|
||||||
(let loop ([i i]
|
|
||||||
[j j]
|
|
||||||
[ps null])
|
|
||||||
(cond
|
|
||||||
[(not (and (<= 0 i) (< i board-width)
|
|
||||||
(<= 0 j) (< j board-height)))
|
|
||||||
ps]
|
|
||||||
[(vector-ref (vector-ref (vector-ref board i) j) 1) ps]
|
|
||||||
[(not (vector-ref (vector-ref (vector-ref board i) j) 0)) ps]
|
|
||||||
[(= index (vector-ref (vector-ref (vector-ref board i) j) 0))
|
|
||||||
(let ([v (vector-ref (vector-ref board i) j)])
|
|
||||||
(vector-set! v 1 #t)
|
|
||||||
(loop (+ i 1)
|
|
||||||
j
|
|
||||||
(loop (- i 1)
|
|
||||||
j
|
|
||||||
(loop i
|
|
||||||
(- j 1)
|
|
||||||
(loop i
|
|
||||||
(+ j 1)
|
|
||||||
(cons (list v i j) ps))))))]
|
|
||||||
[else ps]))])
|
|
||||||
(for-each (lambda (p) (vector-set! (first p) 1 #f)) ans)
|
|
||||||
ans))]
|
|
||||||
|
|
||||||
[define/public get-game-over-size
|
|
||||||
(lambda (dc)
|
|
||||||
(let ([border 5])
|
|
||||||
(let-values ([(text-width text-height d l) (send dc get-text-extent game-over)])
|
|
||||||
(let ([x (- (/ (get-width) 2) (/ text-width 2))]
|
|
||||||
[y (- (/ (get-height) 2) (/ text-height 2))])
|
|
||||||
(values x y text-width text-height border)))))]
|
|
||||||
|
|
||||||
[define/public paint-game-over
|
|
||||||
(lambda (dc)
|
|
||||||
(send dc set-font font)
|
|
||||||
(let-values ([(x y text-width text-height border) (get-game-over-size dc)])
|
|
||||||
(send dc set-pen white-pen)
|
|
||||||
(send dc set-brush white-brush)
|
|
||||||
(send dc draw-rectangle
|
|
||||||
(- x border) (- y border)
|
|
||||||
(+ text-width border border)
|
|
||||||
(+ text-height border border))
|
|
||||||
(send dc draw-text game-over x y)))]
|
|
||||||
|
|
||||||
|
|
||||||
(field
|
|
||||||
[game-over "Game Over"]
|
|
||||||
[font (make-object font% 24 'decorative 'normal 'normal #f)]
|
|
||||||
[turned null])
|
|
||||||
|
|
||||||
[define/public (call-with-dc proc)
|
(provide game@)
|
||||||
;; Since we're not in `on-paint', need to manually
|
|
||||||
;; suspend and resume flushing, so that intermediate
|
|
||||||
;; states are not flushed to the screen.
|
|
||||||
(let ([dc (get-dc)])
|
|
||||||
(send dc suspend-flush)
|
|
||||||
(proc dc)
|
|
||||||
(send dc resume-flush))]
|
|
||||||
|
|
||||||
[define/private recalc/draw-turned
|
|
||||||
(lambda (i j)
|
|
||||||
(set! turned (map (lambda (xx) (list (second xx) (third xx))) (find-same-colors i j)))
|
|
||||||
(cond
|
|
||||||
[(> (length turned) 1)
|
|
||||||
(send this-message set-label (number->string (calc-score (length turned))))
|
|
||||||
(call-with-dc
|
|
||||||
(lambda (dc)
|
|
||||||
(for-each (lambda (p) (draw-cell dc #t (first p) (second p))) turned)))]
|
|
||||||
[else
|
|
||||||
(send this-message set-label "")]))]
|
|
||||||
|
|
||||||
[define/override on-event
|
|
||||||
(lambda (evt)
|
|
||||||
(let+ ([val x (send evt get-x)]
|
|
||||||
[val y (send evt get-y)]
|
|
||||||
[val i (inexact->exact (floor (* (/ x (get-width)) board-width)))]
|
|
||||||
[val j (inexact->exact (floor (* (/ y (get-height)) board-height)))])
|
|
||||||
(cond
|
|
||||||
[(or (send evt moving?)
|
|
||||||
(send evt entering?)
|
|
||||||
(send evt leaving?))
|
|
||||||
(cond
|
|
||||||
[(and (<= 0 i) (< i board-width)
|
|
||||||
(<= 0 j) (< j board-height))
|
|
||||||
(unless (member (list i j) turned)
|
|
||||||
(when (> (length turned) 1)
|
|
||||||
(call-with-dc
|
|
||||||
(lambda (dc)
|
|
||||||
(for-each (lambda (p) (draw-cell dc #f (first p) (second p))) turned))))
|
|
||||||
(recalc/draw-turned i j))]
|
|
||||||
[else
|
|
||||||
(when (> (length turned) 1)
|
|
||||||
(call-with-dc
|
|
||||||
(lambda (dc)
|
|
||||||
(for-each (lambda (p) (draw-cell dc #f (first p) (second p))) turned))))
|
|
||||||
(set! turned null)
|
|
||||||
(send this-message set-label "")])]
|
|
||||||
[(send evt button-up?)
|
|
||||||
(when (and (<= 0 i) (< i board-width)
|
|
||||||
(<= 0 j) (< j board-height))
|
|
||||||
(when (> (length turned) 1)
|
|
||||||
(call-with-dc
|
|
||||||
(lambda (dc)
|
|
||||||
(for-each (lambda (p) (draw-cell dc #f (first p) (second p))) turned))))
|
|
||||||
(set! turned null)
|
|
||||||
(send this-message set-label "")
|
|
||||||
(let ([same-colors (find-same-colors i j)])
|
|
||||||
|
|
||||||
;; reset back the marks for the next depth-first traversal
|
|
||||||
|
|
||||||
(when (>= (length same-colors) 2)
|
|
||||||
|
|
||||||
;; update score
|
|
||||||
(set! score (+ score (calc-score (length same-colors))))
|
|
||||||
(send message set-label (number->string score))
|
|
||||||
|
|
||||||
;; slide down empty pieces
|
|
||||||
(let ([is null])
|
|
||||||
(for-each
|
|
||||||
(lambda (p)
|
|
||||||
(let ([i (second p)]
|
|
||||||
[j (third p)])
|
|
||||||
(unless (member i is)
|
|
||||||
(set! is (cons i is)))
|
|
||||||
(let loop ([x j])
|
|
||||||
(cond
|
|
||||||
[(<= 1 x)
|
|
||||||
(let ([next (vector-ref (vector-ref board i) (- x 1))]
|
|
||||||
[this (vector-ref (vector-ref board i) x)])
|
|
||||||
(vector-set! this 0 (vector-ref next 0))
|
|
||||||
(loop (- x 1)))]
|
|
||||||
[else
|
|
||||||
(vector-set! (vector-ref (vector-ref board i) x) 0 #f)]))))
|
|
||||||
(sort same-colors
|
|
||||||
(lambda (x y) (<= (third x) (third y)))))
|
|
||||||
|
|
||||||
;; slide empty over empty rows
|
(define game@
|
||||||
(set! is (sort is >))
|
(unit
|
||||||
(let ([empty-is (filter (lambda (i)
|
(import)
|
||||||
(not (vector-ref (vector-ref (vector-ref board i) (- board-height 1)) 0)))
|
(export)
|
||||||
is)])
|
|
||||||
(let ([is (if (null? empty-is)
|
|
||||||
is
|
|
||||||
(filter (lambda (x) (< x (car empty-is)))
|
|
||||||
is))])
|
|
||||||
(for-each (lambda (empty-i)
|
|
||||||
(let loop ([i empty-i])
|
|
||||||
(cond
|
|
||||||
[(<= i (- board-width 2))
|
|
||||||
(vector-set! board i (vector-ref board (+ i 1)))
|
|
||||||
(loop (+ i 1))]
|
|
||||||
[(= i (- board-width 1))
|
|
||||||
(vector-set! board i (build-vector board-height
|
|
||||||
(lambda (i) (vector #f #f))))])))
|
|
||||||
empty-is)
|
|
||||||
|
|
||||||
;; draw changed lines
|
|
||||||
(call-with-dc
|
|
||||||
(lambda (dc)
|
|
||||||
(for-each (lambda (i) (draw-line dc i)) is)
|
|
||||||
(unless (null? empty-is)
|
|
||||||
(let loop ([i (car (last-pair empty-is))])
|
|
||||||
(cond
|
|
||||||
[(= i board-width) (void)]
|
|
||||||
[else (draw-line dc i)
|
|
||||||
(loop (+ i 1))])))))
|
|
||||||
|
|
||||||
;; update `small' balls
|
|
||||||
(recalc/draw-turned i j)
|
|
||||||
)))
|
|
||||||
|
|
||||||
(set! game-over?
|
|
||||||
(not
|
|
||||||
(let loop ([i board-width]
|
|
||||||
[continue? #f])
|
|
||||||
(cond
|
|
||||||
[(zero? i) continue?]
|
|
||||||
[else
|
|
||||||
(or continue?
|
|
||||||
(loop
|
|
||||||
(sub1 i)
|
|
||||||
(let loop ([j board-height]
|
|
||||||
[continue? continue?])
|
|
||||||
(cond
|
|
||||||
[(zero? j) continue?]
|
|
||||||
[else
|
|
||||||
(or continue?
|
|
||||||
(loop
|
|
||||||
(sub1 j)
|
|
||||||
(> (length (find-same-colors (sub1 i) (sub1 j))) 1)))]))))]))))
|
|
||||||
(when game-over?
|
|
||||||
(call-with-dc (lambda (dc) (paint-game-over dc)))))))]
|
|
||||||
|
|
||||||
[else (void)])))]
|
|
||||||
|
|
||||||
[define/override on-paint
|
|
||||||
(lambda ()
|
|
||||||
(let ([dc (get-dc)])
|
|
||||||
(send dc set-pen white-pen)
|
|
||||||
(send dc set-brush white-brush)
|
|
||||||
(let loop ([i board-width])
|
|
||||||
(cond
|
|
||||||
[(zero? i) (void)]
|
|
||||||
[else (draw-line dc (- i 1))
|
|
||||||
(loop (- i 1))]))
|
|
||||||
(when game-over?
|
|
||||||
(paint-game-over dc))))]
|
|
||||||
|
|
||||||
(super-new)
|
|
||||||
|
|
||||||
(send (get-dc) set-smoothing 'aligned)))
|
|
||||||
|
|
||||||
(define semaphore (make-semaphore 0))
|
|
||||||
(define same-frame%
|
|
||||||
(class frame%
|
|
||||||
[define/augment on-close
|
|
||||||
(lambda ()
|
|
||||||
(semaphore-post semaphore)
|
|
||||||
(inner (void) on-close))]
|
|
||||||
(super-new [style '(metal)])))
|
|
||||||
|
|
||||||
(define find-largest-connected-region
|
|
||||||
(let ([biggest-so-far 0]
|
|
||||||
[tests 0])
|
|
||||||
(lambda ()
|
|
||||||
(let ([answer 0])
|
|
||||||
(let loop ([i 20])
|
|
||||||
(cond
|
|
||||||
[(zero? i) (void)]
|
|
||||||
[else
|
|
||||||
(let loop ([j 10])
|
|
||||||
(cond
|
|
||||||
[(zero? j) (void)]
|
|
||||||
[else (set! answer
|
|
||||||
(max
|
|
||||||
answer
|
|
||||||
(length
|
|
||||||
(send canvas find-same-colors
|
|
||||||
(- i 1) (- j 1)))))
|
|
||||||
(loop (- j 1))]))
|
|
||||||
(loop (- i 1))]))
|
|
||||||
(set! biggest-so-far (max biggest-so-far (calc-score answer)))
|
|
||||||
(set! tests (+ tests 1))
|
|
||||||
(printf "tests: ~a sofar: ~a largest connected region: ~a score ~a\n"
|
|
||||||
tests
|
|
||||||
biggest-so-far
|
|
||||||
answer
|
|
||||||
(calc-score answer))))))
|
|
||||||
|
|
||||||
(define (new-game-callback redraw?)
|
|
||||||
(set! game-over? #f)
|
|
||||||
(set! board (build-board))
|
|
||||||
(unless (= score 0)
|
|
||||||
(set! score 0)
|
|
||||||
(send message set-label "0"))
|
|
||||||
(send this-message set-label "")
|
|
||||||
(when redraw?
|
|
||||||
(send canvas on-paint)))
|
|
||||||
|
|
||||||
(define frame (make-object same-frame% "Same"))
|
|
||||||
(define panel (make-object vertical-panel% frame))
|
|
||||||
(define canvas (make-object same-canvas% panel))
|
|
||||||
(define hp (make-object horizontal-panel% panel))
|
|
||||||
(make-object message% "Total Score: " hp)
|
|
||||||
(define message (make-object message% "0" hp))
|
|
||||||
(make-object message% "This Score: " hp)
|
|
||||||
(define this-message (make-object message% "0" hp))
|
|
||||||
(define button (make-object button% "New Game" hp (lambda x (new-game-callback #t))))
|
|
||||||
'(make-object button% "Run Scores" hp (lambda x
|
|
||||||
(let loop ()
|
|
||||||
(new-game-callback #f)
|
|
||||||
(find-largest-connected-region)
|
|
||||||
(loop))))
|
|
||||||
|
|
||||||
(define help-button (make-object button% "Help"
|
|
||||||
hp
|
|
||||||
(let ([show-help
|
|
||||||
(show-scribbling
|
|
||||||
'(lib "games/scribblings/games.scrbl")
|
|
||||||
"same")])
|
|
||||||
(lambda (_1 _2)
|
|
||||||
(show-help)))))
|
|
||||||
|
|
||||||
(send message stretchable-width #t)
|
|
||||||
(send this-message stretchable-width #t)
|
|
||||||
(send hp stretchable-height #f)
|
|
||||||
(send canvas min-width (* board-width cell-size))
|
|
||||||
(send canvas min-height (* board-height cell-size))
|
|
||||||
|
|
||||||
(send frame show #t)
|
|
||||||
(yield semaphore))))
|
|
||||||
|
|
||||||
|
(define board-width 20)
|
||||||
|
(define board-height 10)
|
||||||
|
(define colors (map (lambda (x) (make-object color% x))
|
||||||
|
(list "blue" "red" "brown" "forestgreen" "darkviolet")))
|
||||||
|
(define pale-colors (map (λ (x)
|
||||||
|
(define (paleize x) (- 255 (floor (/ (- 255 x) 2))))
|
||||||
|
(make-object color%
|
||||||
|
(paleize (send x red))
|
||||||
|
(paleize (send x green))
|
||||||
|
(paleize (send x blue))))
|
||||||
|
colors))
|
||||||
|
|
||||||
|
;; these are the sizes that the on-paint callback draws at;
|
||||||
|
;; a scaling factor is applied to make the board fit the window
|
||||||
|
(define cell-w 11)
|
||||||
|
(define cell-h 11)
|
||||||
|
(define pen-size 10)
|
||||||
|
|
||||||
|
(define (blob-sel-x b) (vector-ref b 1))
|
||||||
|
(define (blob-sel-y b) (vector-ref b 2))
|
||||||
|
|
||||||
|
;; build-board : (-> (vectorof (vectorof (vector (union num #f) boolean))))
|
||||||
|
; this represents the board. Each entry is the color index of
|
||||||
|
; the piece and a node to mark for the depth-first traversal.
|
||||||
|
; #f for the color index indicates an eliminated piece.
|
||||||
|
(define (build-board)
|
||||||
|
(build-vector
|
||||||
|
board-width
|
||||||
|
(lambda (i)
|
||||||
|
(build-vector
|
||||||
|
board-height
|
||||||
|
(lambda (j)
|
||||||
|
(vector
|
||||||
|
(begin
|
||||||
|
(if (zero? (modulo (+ j i) 4))
|
||||||
|
0
|
||||||
|
1)
|
||||||
|
#;
|
||||||
|
(if (zero? (modulo (+ j i) 2))
|
||||||
|
0
|
||||||
|
1)
|
||||||
|
#;
|
||||||
|
(if (= j (- board-height 1))
|
||||||
|
(- (length colors) 1)
|
||||||
|
(modulo i (- (length colors) 1)))
|
||||||
|
;0
|
||||||
|
#;(random (length colors)))
|
||||||
|
#f))))))
|
||||||
|
|
||||||
|
(define board (build-board))
|
||||||
|
|
||||||
|
(define game-over? #f)
|
||||||
|
|
||||||
|
;; adds up as the user clicks
|
||||||
|
(define clicked-score 0)
|
||||||
|
(define (calc-score n) (* n n))
|
||||||
|
(define (reset-score)
|
||||||
|
(set! clicked-score 0)
|
||||||
|
(set-score-label))
|
||||||
|
(define (update-score balls-going-away)
|
||||||
|
(set! clicked-score (+ clicked-score (* balls-going-away balls-going-away)))
|
||||||
|
(set-score-label))
|
||||||
|
(define (set-score-label)
|
||||||
|
(define penalty 0)
|
||||||
|
(for ([v (in-vector board)])
|
||||||
|
(for ([v (in-vector v)])
|
||||||
|
(when (vector-ref v 0)
|
||||||
|
(set! penalty (+ penalty 10)))))
|
||||||
|
(send score-message set-label
|
||||||
|
(format "~a - ~a = ~a"
|
||||||
|
clicked-score
|
||||||
|
penalty
|
||||||
|
(- clicked-score penalty))))
|
||||||
|
|
||||||
|
|
||||||
|
(define same-canvas%
|
||||||
|
(class canvas%
|
||||||
|
(inherit get-dc get-client-size)
|
||||||
|
(define/private (get-width) (let-values ([(w h) (get-client-size)]) w))
|
||||||
|
(define/private (get-height) (let-values ([(w h) (get-client-size)]) h))
|
||||||
|
(define/private (get-x-step) (/ (get-width) board-width))
|
||||||
|
(define/private (get-y-step) (/ (get-height) board-height))
|
||||||
|
|
||||||
|
(define mouse-current-x #f)
|
||||||
|
(define mouse-current-y #f)
|
||||||
|
(define mouse-clicked-x #f)
|
||||||
|
(define mouse-clicked-y #f)
|
||||||
|
(define mouse-over-chosen? #t)
|
||||||
|
|
||||||
|
(define/override (on-paint)
|
||||||
|
(define dc (get-dc))
|
||||||
|
(send dc erase)
|
||||||
|
(define-values (cw ch) (get-client-size))
|
||||||
|
(define pen-size (- (floor (min cell-w cell-h)) 2))
|
||||||
|
(send dc set-brush "black" 'transparent)
|
||||||
|
(send dc set-smoothing 'smoothed)
|
||||||
|
(send dc set-scale
|
||||||
|
(/ cw (* board-width cell-w))
|
||||||
|
(/ ch (* board-height cell-h)))
|
||||||
|
(define painted (make-hash))
|
||||||
|
(for* ([i (in-range 0 board-width)]
|
||||||
|
[j (in-range 0 board-height)])
|
||||||
|
(unless (hash-ref painted (xy->key i j) #f)
|
||||||
|
(define color (vector-ref (vector-ref (vector-ref board i) j) 0))
|
||||||
|
(when color
|
||||||
|
(define blob (find-same-colors i j))
|
||||||
|
(for ([x (in-list blob)])
|
||||||
|
(hash-set! painted (xy->key (blob-sel-x x) (blob-sel-y x)) #t))
|
||||||
|
(update-pen/draw-blob blob dc color cell-w cell-h i j))))
|
||||||
|
(when game-over?
|
||||||
|
(paint-game-over)))
|
||||||
|
|
||||||
|
(define/private (update-pen/draw-blob blob dc color cell-w cell-h i j)
|
||||||
|
(define mouse-over? #f)
|
||||||
|
(define mouse-clicked-over? #f)
|
||||||
|
(define multiple-cells? #f)
|
||||||
|
|
||||||
|
(when (or (number? mouse-current-x)
|
||||||
|
(number? mouse-clicked-x))
|
||||||
|
(for ([obj (in-list blob)])
|
||||||
|
(define x (blob-sel-x obj))
|
||||||
|
(define y (blob-sel-y obj))
|
||||||
|
(when (or (not (equal? x i))
|
||||||
|
(not (equal? y j)))
|
||||||
|
(set! multiple-cells? #t))
|
||||||
|
(when (and (equal? x mouse-current-x)
|
||||||
|
(equal? y mouse-current-y))
|
||||||
|
(set! mouse-over? #t))
|
||||||
|
(when (and (equal? x mouse-clicked-x)
|
||||||
|
(equal? y mouse-clicked-y))
|
||||||
|
(set! mouse-clicked-over? #t))))
|
||||||
|
|
||||||
|
(cond
|
||||||
|
[mouse-clicked-x ;; has the mouse been clicked in a clickable place?
|
||||||
|
(cond
|
||||||
|
[(and mouse-over? mouse-clicked-over? multiple-cells?)
|
||||||
|
(send dc set-pen
|
||||||
|
(list-ref colors color)
|
||||||
|
(* pen-size 2/3)
|
||||||
|
'solid)
|
||||||
|
(draw-blob blob i j)
|
||||||
|
(send dc set-pen
|
||||||
|
(list-ref pale-colors color)
|
||||||
|
(* pen-size 2/3 1/2)
|
||||||
|
'solid)
|
||||||
|
(draw-blob blob i j)]
|
||||||
|
[(and mouse-over? mouse-clicked-over?)
|
||||||
|
(send dc set-pen
|
||||||
|
(list-ref colors color)
|
||||||
|
pen-size
|
||||||
|
'solid)
|
||||||
|
(draw-blob blob i j)]
|
||||||
|
[else
|
||||||
|
(send dc set-pen
|
||||||
|
(list-ref colors color)
|
||||||
|
pen-size
|
||||||
|
'solid)
|
||||||
|
(draw-blob blob i j)])]
|
||||||
|
[else
|
||||||
|
(send dc set-pen (list-ref colors color) pen-size 'solid)
|
||||||
|
(draw-blob blob i j)
|
||||||
|
(when mouse-over?
|
||||||
|
(send dc set-pen
|
||||||
|
(list-ref pale-colors color)
|
||||||
|
(* pen-size 2/3)
|
||||||
|
'solid)
|
||||||
|
(draw-blob blob i j))]))
|
||||||
|
|
||||||
|
(define (draw-blob blob i j)
|
||||||
|
(define dc (get-dc))
|
||||||
|
(define (connect x1 y1 x2 y2)
|
||||||
|
(send dc draw-line
|
||||||
|
(+ (/ cell-w 2) (* x1 cell-w))
|
||||||
|
(+ (/ cell-h 2) (* y1 cell-h))
|
||||||
|
(+ (/ cell-w 2) (* x2 cell-w))
|
||||||
|
(+ (/ cell-h 2) (* y2 cell-h))))
|
||||||
|
(cond
|
||||||
|
[(null? (cdr blob))
|
||||||
|
(define pt (car blob))
|
||||||
|
(connect (blob-sel-x pt) (blob-sel-y pt) (blob-sel-x pt) (blob-sel-y pt))]
|
||||||
|
[else
|
||||||
|
(for* ([b1 (in-list blob)]
|
||||||
|
[b2 (in-list blob)])
|
||||||
|
(when (= (+ (abs (- (blob-sel-x b1) (blob-sel-x b2)))
|
||||||
|
(abs (- (blob-sel-y b1) (blob-sel-y b2))))
|
||||||
|
1)
|
||||||
|
(connect (blob-sel-x b1) (blob-sel-y b1) (blob-sel-x b2) (blob-sel-y b2))))]))
|
||||||
|
|
||||||
|
(define/private (xy->key x y) (+ (* board-width y) x))
|
||||||
|
|
||||||
|
(define/public (find-same-colors i j)
|
||||||
|
(let* ([index (vector-ref (vector-ref (vector-ref board i) j) 0)]
|
||||||
|
[ans
|
||||||
|
(let loop ([i i]
|
||||||
|
[j j]
|
||||||
|
[ps null])
|
||||||
|
(cond
|
||||||
|
[(not (and (<= 0 i) (< i board-width)
|
||||||
|
(<= 0 j) (< j board-height)))
|
||||||
|
ps]
|
||||||
|
[(vector-ref (vector-ref (vector-ref board i) j) 1) ps]
|
||||||
|
[(not (vector-ref (vector-ref (vector-ref board i) j) 0)) ps]
|
||||||
|
[(= index (vector-ref (vector-ref (vector-ref board i) j) 0))
|
||||||
|
(let ([v (vector-ref (vector-ref board i) j)])
|
||||||
|
(vector-set! v 1 #t)
|
||||||
|
(loop (+ i 1)
|
||||||
|
j
|
||||||
|
(loop (- i 1)
|
||||||
|
j
|
||||||
|
(loop i
|
||||||
|
(- j 1)
|
||||||
|
(loop i
|
||||||
|
(+ j 1)
|
||||||
|
(cons (vector v i j)
|
||||||
|
ps))))))]
|
||||||
|
[else ps]))])
|
||||||
|
(for-each (lambda (p) (vector-set! (vector-ref p 0) 1 #f)) ans)
|
||||||
|
ans))
|
||||||
|
|
||||||
|
(define/public (paint-game-over)
|
||||||
|
(define dc (get-dc))
|
||||||
|
(send dc set-font font)
|
||||||
|
(define border 5)
|
||||||
|
(define-values (text-width text-height d l)
|
||||||
|
(send dc get-text-extent game-over))
|
||||||
|
(define x (- (/ (* cell-w board-width) 2) (/ text-width 2)))
|
||||||
|
(define y (- (/ (* cell-h board-height) 2) (/ text-height 2)))
|
||||||
|
(send dc set-pen "white" 1' transparent)
|
||||||
|
(send dc set-brush "white" 'solid)
|
||||||
|
(send dc set-alpha .8)
|
||||||
|
(send dc draw-rectangle
|
||||||
|
(- x border border) (- y border)
|
||||||
|
(+ text-width border border border border)
|
||||||
|
(+ text-height border border))
|
||||||
|
(send dc set-alpha 1)
|
||||||
|
(send dc draw-text game-over x y))
|
||||||
|
|
||||||
|
|
||||||
|
[define game-over "Game Over"]
|
||||||
|
[define font (make-object font% 24 'decorative 'normal 'normal #f)]
|
||||||
|
[define turned null]
|
||||||
|
|
||||||
|
[define/public (call-with-dc proc)
|
||||||
|
;; Since we're not in `on-paint', need to manually
|
||||||
|
;; suspend and resume flushing, so that intermediate
|
||||||
|
;; states are not flushed to the screen.
|
||||||
|
(let ([dc (get-dc)])
|
||||||
|
(send dc suspend-flush)
|
||||||
|
(proc dc)
|
||||||
|
(send dc resume-flush))]
|
||||||
|
|
||||||
|
(inherit refresh)
|
||||||
|
(define/override (on-event evt)
|
||||||
|
(define x (send evt get-x))
|
||||||
|
(define y (send evt get-y))
|
||||||
|
(define-values (cw ch) (get-client-size))
|
||||||
|
(define bx (floor (* (/ x cw) board-width)))
|
||||||
|
(define by (floor (* (/ y ch) board-height)))
|
||||||
|
(unless (<= 0 bx (- board-width 1)) (set! bx #f))
|
||||||
|
(unless (<= 0 by (- board-height 1)) (set! by #f))
|
||||||
|
(when (send evt leaving?)
|
||||||
|
(set! bx #f)
|
||||||
|
(set! by #f))
|
||||||
|
|
||||||
|
(when (send evt button-up?)
|
||||||
|
(when (and (equal? mouse-clicked-x bx)
|
||||||
|
(equal? mouse-clicked-y by))
|
||||||
|
(make-a-move)
|
||||||
|
(update-game-over)
|
||||||
|
(refresh)))
|
||||||
|
|
||||||
|
(define-values (new-mouse-clicked-x new-mouse-clicked-y)
|
||||||
|
(cond
|
||||||
|
[(send evt button-down?) (values bx by)]
|
||||||
|
[(send evt button-up?) (values #f #f)]
|
||||||
|
[else (values mouse-clicked-x mouse-clicked-y)]))
|
||||||
|
(unless (and (equal? mouse-clicked-x new-mouse-clicked-x)
|
||||||
|
(equal? mouse-clicked-y new-mouse-clicked-y))
|
||||||
|
(set! mouse-clicked-x new-mouse-clicked-x)
|
||||||
|
(set! mouse-clicked-y new-mouse-clicked-y)
|
||||||
|
(refresh))
|
||||||
|
|
||||||
|
(unless (and (equal? bx mouse-current-x)
|
||||||
|
(equal? by mouse-current-y))
|
||||||
|
(set! mouse-current-x bx)
|
||||||
|
(set! mouse-current-y by)
|
||||||
|
(refresh)))
|
||||||
|
|
||||||
|
(define/private (make-a-move)
|
||||||
|
(define i mouse-clicked-x)
|
||||||
|
(define j mouse-clicked-y)
|
||||||
|
(let ([same-colors (find-same-colors i j)])
|
||||||
|
|
||||||
|
(when (>= (length same-colors) 2)
|
||||||
|
|
||||||
|
;; slide down empty pieces
|
||||||
|
(let ([is null])
|
||||||
|
(for-each
|
||||||
|
(lambda (p)
|
||||||
|
(let ([i (blob-sel-x p)]
|
||||||
|
[j (blob-sel-y p)])
|
||||||
|
(unless (member i is)
|
||||||
|
(set! is (cons i is)))
|
||||||
|
(let loop ([x j])
|
||||||
|
(cond
|
||||||
|
[(<= 1 x)
|
||||||
|
(let ([next (vector-ref (vector-ref board i) (- x 1))]
|
||||||
|
[this (vector-ref (vector-ref board i) x)])
|
||||||
|
(vector-set! this 0 (vector-ref next 0))
|
||||||
|
(loop (- x 1)))]
|
||||||
|
[else
|
||||||
|
(vector-set! (vector-ref (vector-ref board i) x) 0 #f)]))))
|
||||||
|
(sort same-colors
|
||||||
|
(lambda (x y) (<= (blob-sel-y x) (blob-sel-y y)))))
|
||||||
|
|
||||||
|
;; slide empty over empty rows
|
||||||
|
(set! is (sort is >))
|
||||||
|
(let ([empty-is
|
||||||
|
(filter (lambda (i)
|
||||||
|
(not (vector-ref
|
||||||
|
(vector-ref (vector-ref board i) (- board-height 1))
|
||||||
|
0)))
|
||||||
|
is)])
|
||||||
|
(let ([is (if (null? empty-is)
|
||||||
|
is
|
||||||
|
(filter (lambda (x) (< x (car empty-is)))
|
||||||
|
is))])
|
||||||
|
(for-each (lambda (empty-i)
|
||||||
|
(let loop ([i empty-i])
|
||||||
|
(cond
|
||||||
|
[(<= i (- board-width 2))
|
||||||
|
(vector-set! board i (vector-ref board (+ i 1)))
|
||||||
|
(loop (+ i 1))]
|
||||||
|
[(= i (- board-width 1))
|
||||||
|
(vector-set!
|
||||||
|
board
|
||||||
|
i
|
||||||
|
(build-vector board-height
|
||||||
|
(λ (i) (vector #f #f))))])))
|
||||||
|
empty-is))))
|
||||||
|
|
||||||
|
|
||||||
|
;; tally disappearing balls
|
||||||
|
(update-score (length same-colors)))))
|
||||||
|
|
||||||
|
(define/public-final (update-game-over)
|
||||||
|
(set! game-over?
|
||||||
|
(not
|
||||||
|
(let loop ([i board-width]
|
||||||
|
[continue? #f])
|
||||||
|
(cond
|
||||||
|
[(zero? i) continue?]
|
||||||
|
[else
|
||||||
|
(or continue?
|
||||||
|
(loop
|
||||||
|
(sub1 i)
|
||||||
|
(let loop ([j board-height]
|
||||||
|
[continue? continue?])
|
||||||
|
(cond
|
||||||
|
[(zero? j) continue?]
|
||||||
|
[else
|
||||||
|
(or continue?
|
||||||
|
(loop
|
||||||
|
(sub1 j)
|
||||||
|
(> (length (find-same-colors (sub1 i) (sub1 j))) 1)))]))))])))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(super-new)))
|
||||||
|
|
||||||
|
(define semaphore (make-semaphore 0))
|
||||||
|
(define same-frame%
|
||||||
|
(class frame%
|
||||||
|
[define/augment on-close
|
||||||
|
(lambda ()
|
||||||
|
(semaphore-post semaphore)
|
||||||
|
(inner (void) on-close))]
|
||||||
|
(super-new [style '(metal)])))
|
||||||
|
|
||||||
|
(define (new-game-callback redraw?)
|
||||||
|
(set! game-over? #f)
|
||||||
|
(set! board (build-board))
|
||||||
|
(reset-score)
|
||||||
|
(send canvas update-game-over)
|
||||||
|
(when redraw?
|
||||||
|
(send canvas refresh)))
|
||||||
|
|
||||||
|
(define frame (make-object same-frame% "Same"))
|
||||||
|
(define panel (make-object vertical-panel% frame))
|
||||||
|
(define canvas (make-object same-canvas% panel))
|
||||||
|
(define hp (new horizontal-panel% [parent panel] [stretchable-height #f]))
|
||||||
|
(new message% [label "Total Score: "] [parent hp])
|
||||||
|
(define score-message (new message% [label ""] [parent hp] [stretchable-width #t]))
|
||||||
|
(define button (make-object button% "New Game" hp (lambda x (new-game-callback #t))))
|
||||||
|
|
||||||
|
(define help-button (make-object button% "Help"
|
||||||
|
hp
|
||||||
|
(let ([show-help
|
||||||
|
(show-scribbling
|
||||||
|
'(lib "games/scribblings/games.scrbl")
|
||||||
|
"same")])
|
||||||
|
(lambda (_1 _2)
|
||||||
|
(show-help)))))
|
||||||
|
|
||||||
|
(send canvas update-game-over)
|
||||||
|
(reset-score)
|
||||||
|
(send canvas min-width (* board-width cell-w 2))
|
||||||
|
(send canvas min-height (* board-height cell-h 2))
|
||||||
|
(send frame show #t)
|
||||||
|
(yield semaphore)))
|
||||||
|
|
||||||
|
(invoke-unit game@)
|
||||||
|
|
|
||||||
|
|
@ -3,19 +3,18 @@
|
||||||
|
|
||||||
@gametitle["Same" "same" "Dot-Removing Game"]
|
@gametitle["Same" "same" "Dot-Removing Game"]
|
||||||
|
|
||||||
The object of @game{Same} is to score points by removing dots from the
|
The object of @game{Same} is to score points by removing blobs from the
|
||||||
board. To remove a dot, click on it. As long as there is another dot
|
board. To remove a blob, click on it. As long the blob is not just
|
||||||
of the same color next to the clicked dot, it will disappear along
|
a simple circle, it will disappear. After the blob disappears,
|
||||||
with all adjacent dots of the same color. After the dots disappear,
|
the remaining pieces of the board shift around, breaking up blobs into
|
||||||
dots in the rows above the deleted dots will fall into the vacated
|
new blobs as pieces of the old blobs fall down to fill in the empty space.
|
||||||
spaces. If an entire column is wiped out, all of the dots from the
|
If an entire column is wiped out, all of the blobs from the
|
||||||
right will slide left to take up the empty column's space.
|
right will slide left to take up the empty column's space.
|
||||||
|
|
||||||
Your score increases for each ball removed from the board. The score
|
Your score increases for each ball removed from the board. In general,
|
||||||
for each click is a function of the number of balls that disappeared.
|
when you remove a blob, you get as many points as the square of the number
|
||||||
The @onscreen{This Click} label shows how many points you would score
|
of cells the blob occupied, so removing bigger blobs is better. Also,
|
||||||
for clicking the dots underneath the mouse pointer. The score varies
|
there is a penalty of 10 points for each colored cell left behind on the board,
|
||||||
quadratically with the number of balls, so eliminating many balls with
|
so try to clear out the entire board.
|
||||||
one click is advantageous.
|
|
||||||
|
|
||||||
Click the @onscreen{New Game} button to play again.
|
Click the @onscreen{New Game} button to play again.
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user