You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
380 lines
10 KiB
Scheme
380 lines
10 KiB
Scheme
|
|
(require-library "macro.ss")
|
|
|
|
(define TILE-HW 24)
|
|
(define WIDTH 16)
|
|
(define HEIGHT 16)
|
|
(define BOMB-COUNT 30)
|
|
|
|
; Temporary
|
|
(define FRDW 12)
|
|
(define FRDH 39)
|
|
(define PANEL-HEIGHT 50)
|
|
(define TIME-WIDTH 600)
|
|
(define COUNT-WIDTH 600)
|
|
|
|
(define DIGIT-COLOR-NAMES
|
|
; 0th is background; 8th is foreground
|
|
(vector "LIGHT GREY" "BLUE" "GREEN" "RED" "PURPLE" "ORANGE" "YELLOW" "BROWN" "BLACK"))
|
|
|
|
(define DIGIT-COLORS
|
|
(build-vector 9 (lambda (i)
|
|
(send wx:the-colour-database find-colour
|
|
(vector-ref DIGIT-COLOR-NAMES i)))))
|
|
|
|
(define BG-COLOR (vector-ref DIGIT-COLORS 0))
|
|
(define FG-COLOR (vector-ref DIGIT-COLORS 8))
|
|
(define EXPLODE-COLOR (send wx:the-colour-database find-colour "RED"))
|
|
|
|
(define BG-PEN (send wx:the-pen-list find-or-create-pen BG-COLOR 1 wx:const-solid))
|
|
(define FG-PEN (send wx:the-pen-list find-or-create-pen FG-COLOR 1 wx:const-solid))
|
|
|
|
(define step-while
|
|
(opt-lambda (first test until step f [accum void] [init (void)])
|
|
(let loop ([n first][a init])
|
|
(if (test n until)
|
|
(loop (step n) (accum a (f n)))
|
|
a))))
|
|
|
|
(define tile:plain%
|
|
(class null ()
|
|
(private
|
|
[state 'covered]
|
|
[neighbor-bomb-count 0])
|
|
(public
|
|
[set-state
|
|
(lambda (newstate)
|
|
(set! state newstate))]
|
|
[get-state
|
|
(lambda ()
|
|
state)]
|
|
[set-neighbor-bomb-count
|
|
(lambda (c)
|
|
(set! neighbor-bomb-count c))]
|
|
[get-neighbor-bomb-count
|
|
(lambda ()
|
|
neighbor-bomb-count)]
|
|
[draw-text-tile
|
|
(lambda (dc x y w h hilite? border? str color)
|
|
(if border?
|
|
(send dc set-pen FG-PEN)
|
|
(send dc set-pen BG-PEN))
|
|
(send dc draw-rectangle x y w h)
|
|
(when hilite?
|
|
(send dc draw-rectangle
|
|
(add1 x) (add1 y)
|
|
(- w 2) (- h 2)))
|
|
(when str
|
|
(if color
|
|
(send dc set-text-foreground color)
|
|
(send dc set-text-foreground FG-COLOR))
|
|
(let ([tw (box 0)][th (box 0)])
|
|
(send dc get-text-extent str tw th)
|
|
(send dc draw-text str
|
|
(+ x (/ (- w (unbox tw)) 2))
|
|
(+ y (/ (- h (unbox th)) 2))))))]
|
|
[draw
|
|
(lambda (dc x y w h hilite?)
|
|
(case state
|
|
[(covered) (draw-text-tile dc x y w h hilite? #t #f #f)]
|
|
[(flagged) (draw-text-tile dc x y w h hilite? #t "X" #f)]
|
|
[(semi-flagged) (draw-text-tile dc x y w h hilite? #t "?" #f)]
|
|
[(uncovered) (draw-text-tile
|
|
dc x y w h #f #f
|
|
(if (zero? neighbor-bomb-count)
|
|
#f
|
|
(number->string neighbor-bomb-count))
|
|
(vector-ref DIGIT-COLORS neighbor-bomb-count))]))])))
|
|
|
|
(define tile:bomb%
|
|
(class tile:plain% ()
|
|
(inherit get-state draw-text-tile)
|
|
(rename [super-draw draw])
|
|
(private
|
|
[explode-source? #f])
|
|
(public
|
|
[set-explode-source
|
|
(lambda (s?)
|
|
(set! explode-source? s?))]
|
|
[draw
|
|
(lambda (dc x y w h hilite?)
|
|
(if (eq? (get-state) 'uncovered)
|
|
(draw-text-tile dc x y w h #f #f "*"
|
|
(and explode-source? EXPLODE-COLOR))
|
|
(super-draw dc x y w h hilite?)))])
|
|
(sequence
|
|
(super-init))))
|
|
|
|
(define (get-tile b x y)
|
|
(vector-ref (vector-ref b x) y))
|
|
|
|
(define (set-tile! b x y t)
|
|
(vector-set! (vector-ref b x) y t))
|
|
|
|
(define (do-surrounding b x y accum start default f)
|
|
(step-while -1 <= 1 add1
|
|
(lambda (dx)
|
|
(step-while -1 <= 1 add1
|
|
(lambda (dy)
|
|
(if (and (not (and (zero? dx) (zero? dy)))
|
|
(< -1 (+ x dx) WIDTH)
|
|
(< -1 (+ y dy) HEIGHT))
|
|
(f dx dy)
|
|
default))
|
|
accum start))
|
|
accum start))
|
|
|
|
(define (is-bomb? x)
|
|
(is-a? x tile:bomb%))
|
|
|
|
(define (count-surrounding-bombs b x y)
|
|
(do-surrounding
|
|
b x y + 0 0
|
|
(lambda (dx dy)
|
|
(if (is-bomb? (get-tile b (+ x dx) (+ y dy)))
|
|
1
|
|
0))))
|
|
|
|
(define (for-each-tile b f)
|
|
(step-while 0 < WIDTH add1
|
|
(lambda (x)
|
|
(step-while 0 < HEIGHT add1
|
|
(lambda (y)
|
|
(f (get-tile b x y) x y))))))
|
|
|
|
(define (make-board)
|
|
(let ([b (build-vector WIDTH
|
|
(lambda (i)
|
|
(build-vector HEIGHT
|
|
(lambda (j)
|
|
(make-object tile:plain%)))))])
|
|
(let loop ([n BOMB-COUNT])
|
|
(unless (zero? n)
|
|
(let rloop ()
|
|
(let* ([x (random WIDTH)]
|
|
[y (random HEIGHT)]
|
|
[t (get-tile b x y)])
|
|
(if (is-a? t tile:bomb%)
|
|
(rloop)
|
|
(begin
|
|
(set-tile! b x y (make-object tile:bomb%))
|
|
(loop (sub1 n))))))))
|
|
(for-each-tile b (lambda (t x y)
|
|
(send t
|
|
set-neighbor-bomb-count
|
|
(count-surrounding-bombs b x y))))
|
|
b))
|
|
|
|
(define f (make-object mred:frame% null "Minesweeper"))
|
|
(define vpanel (make-object mred:vertical-panel% f))
|
|
|
|
(define ms:canvas%
|
|
(class mred:canvas% args
|
|
(inherit get-dc clear
|
|
set-min-width set-min-height
|
|
stretchable-in-x stretchable-in-y)
|
|
(private
|
|
[panel (make-object mred:horizontal-panel% vpanel)])
|
|
(sequence
|
|
(send panel stretchable-in-y #f))
|
|
(private
|
|
[lspace (make-object mred:vertical-panel% panel)]
|
|
[time (make-object mred:message% panel "Time: 00000")]
|
|
[lmspace (make-object mred:vertical-panel% panel)]
|
|
[button (make-object mred:button% panel (lambda (b e) (reset)) "Reset")]
|
|
[rmspace (make-object mred:vertical-panel% panel)]
|
|
[count (make-object mred:message% panel "Count: 000")]
|
|
[rspace (make-object mred:vertical-panel% panel)]
|
|
|
|
[set-time
|
|
(lambda (t)
|
|
(send time set-label (string-append "Time: " (number->string t))))]
|
|
[set-count
|
|
(lambda (c)
|
|
(send count set-label (string-append "Bombs: " (number->string c))))]
|
|
|
|
[clicking #f]
|
|
[clicking-x 0]
|
|
[clicking-y 0]
|
|
[ready? #t]
|
|
[start-time #f]
|
|
[elapsed-time 0]
|
|
[timer #f]
|
|
[bomb-count BOMB-COUNT]
|
|
[cover-count (* HEIGHT WIDTH)]
|
|
[board null])
|
|
(public
|
|
(stop-timer
|
|
(lambda ()
|
|
(when timer
|
|
(send timer stop)
|
|
(set! timer #f))))
|
|
(start-timer
|
|
(lambda ()
|
|
(set! start-time (current-seconds))
|
|
(set! timer
|
|
(make-object
|
|
(class-asi wx:timer%
|
|
(public
|
|
[notify
|
|
(lambda ()
|
|
(let ([e (- (current-seconds) start-time)])
|
|
(when (> e elapsed-time)
|
|
(set! elapsed-time e)
|
|
(set-time e))))]))))
|
|
(send timer start 100 #f)))
|
|
(end-of-game
|
|
(lambda (win?)
|
|
(stop-timer)
|
|
(set! ready? #f)
|
|
(set! start-time #f)
|
|
(unless win?
|
|
(show-all-bombs))
|
|
(set-count BOMB-COUNT)))
|
|
(explode
|
|
(lambda ()
|
|
(end-of-game #f)))
|
|
(win
|
|
(lambda ()
|
|
(end-of-game #t)))
|
|
(reset
|
|
(lambda ()
|
|
(stop-timer)
|
|
(set! ready? #t)
|
|
(set! start-time #f)
|
|
(set! elapsed-time 0)
|
|
(set! cover-count (* HEIGHT WIDTH))
|
|
(clear)
|
|
(set-time 0)
|
|
(set! bomb-count BOMB-COUNT)
|
|
(set-count BOMB-COUNT)
|
|
(set! board (make-board))
|
|
(on-paint)))
|
|
(show-all-bombs
|
|
(lambda ()
|
|
(for-each-tile board
|
|
(lambda (t x y)
|
|
(when (is-bomb? t)
|
|
(change-state t (send t get-state) 'uncovered #f)
|
|
(paint-one t x y))))))
|
|
(autoclick-surrounding
|
|
(lambda (x y)
|
|
(do-surrounding
|
|
board x y void (void) (void)
|
|
(lambda (dx dy)
|
|
(let* ([x2 (+ x dx)]
|
|
[y2 (+ y dy)]
|
|
[t (get-tile board x2 y2)]
|
|
[state (send t get-state)]
|
|
[nc (send t get-neighbor-bomb-count)])
|
|
(unless (eq? state 'uncovered)
|
|
(change-state t state 'uncovered #t)
|
|
(paint-one t x2 y2)
|
|
(when (zero? nc)
|
|
(autoclick-surrounding x2 y2))))))))
|
|
(change-state
|
|
(lambda (t old-state new-state update-count?)
|
|
(send t set-state new-state)
|
|
(when (and update-count? (not (eq? new-state old-state)))
|
|
(when (eq? new-state 'uncovered)
|
|
(set! cover-count (sub1 cover-count)))
|
|
(when (eq? old-state 'uncovered)
|
|
(set! cover-count (add1 cover-count)))
|
|
(when (eq? new-state 'flagged)
|
|
(set! bomb-count (sub1 bomb-count))
|
|
(set-count bomb-count))
|
|
(when (eq? old-state 'flagged)
|
|
(set! bomb-count (add1 bomb-count))
|
|
(set-count bomb-count)))))
|
|
(do-select
|
|
(lambda (x y flag?)
|
|
(let* ([t (get-tile board x y)]
|
|
[state (send t get-state)]
|
|
[new-state
|
|
(case state
|
|
[(covered)
|
|
(if flag? 'flagged 'uncovered)]
|
|
[(flagged)
|
|
(if flag? 'semi-flagged state)]
|
|
[(semi-flagged)
|
|
(if flag? 'covered 'uncovered)]
|
|
[else state])]
|
|
[nc (send t get-neighbor-bomb-count)]
|
|
[new-uncover? (and (eq? new-state 'uncovered)
|
|
(not (eq? state 'uncovered)))]
|
|
[bomb? (is-bomb? t)])
|
|
(change-state t state new-state #t)
|
|
(when (and new-uncover? bomb?)
|
|
(send t set-explode-source #t))
|
|
(paint-one t x y)
|
|
(when new-uncover?
|
|
(if bomb?
|
|
(explode)
|
|
(begin
|
|
(when (zero? nc)
|
|
(autoclick-surrounding x y))))
|
|
(when (and ready? (= cover-count BOMB-COUNT))
|
|
(win))))))
|
|
(on-event
|
|
(lambda (e)
|
|
(when ready?
|
|
(unless start-time
|
|
(when (send e button-down?)
|
|
(start-timer)))
|
|
(let* ([x (quotient (inexact->exact (floor (send e get-x))) TILE-HW)]
|
|
[y (quotient (inexact->exact (floor (send e get-y))) TILE-HW)]
|
|
[t (if (and (< -1 x WIDTH)
|
|
(< -1 y HEIGHT))
|
|
(get-tile board x y)
|
|
#f)])
|
|
(cond
|
|
[(and clicking (or (not (eq? t clicking))
|
|
(not (or (send e button-up?)
|
|
(send e dragging?)))))
|
|
(let ([old clicking])
|
|
(set! clicking #f)
|
|
(paint-one old clicking-x clicking-y))]
|
|
[(and t
|
|
(not (eq? (send t get-state) 'uncovered))
|
|
(or (send e button-down?)
|
|
(and (send e dragging?)
|
|
(= x clicking-x)
|
|
(= y clicking-y))))
|
|
(set! clicking t)
|
|
(set! clicking-x x)
|
|
(set! clicking-y y)
|
|
(paint-one t x y)]
|
|
[(send e button-down?) ; click not on a tile
|
|
(set! clicking-x -1)]
|
|
[(and clicking (send e button-up?))
|
|
(set! clicking #f)
|
|
(do-select x y (send e button-up? 3))]
|
|
[else 'ok])))))
|
|
(paint-one
|
|
(lambda (t x y)
|
|
(let ([xloc (* x TILE-HW)]
|
|
[yloc (* y TILE-HW)])
|
|
(send t draw dc xloc yloc TILE-HW TILE-HW
|
|
(eq? t clicking)))))
|
|
(on-paint
|
|
(lambda ()
|
|
(for-each-tile board (lambda (t x y)
|
|
(paint-one t x y))))))
|
|
(sequence
|
|
(apply super-init args)
|
|
(set-min-width (* TILE-HW WIDTH))
|
|
(set-min-height (* TILE-HW HEIGHT))
|
|
(stretchable-in-x #f)
|
|
(stretchable-in-y #f))
|
|
(private
|
|
[dc (get-dc)])
|
|
(sequence
|
|
(reset)
|
|
(send dc set-text-background BG-COLOR)
|
|
(send dc set-brush (send wx:the-brush-list find-or-create-brush
|
|
BG-COLOR wx:const-solid)))))
|
|
|
|
(define c (make-object ms:canvas% vpanel))
|
|
|
|
(send f show #t)
|