diff --git a/collects/games/mines/gen-tiles.ss b/collects/games/mines/gen-tiles.ss new file mode 100644 index 0000000000..c5996cd8ca --- /dev/null +++ b/collects/games/mines/gen-tiles.ss @@ -0,0 +1,182 @@ + +(module gen-tiles mzscheme + (require (lib "class.ss") + (lib "mred.ss" "mred") + (lib "math.ss")) + + (define SIZE 24) + + (define bm (make-object bitmap% SIZE SIZE)) + (define dc (make-object bitmap-dc% bm)) + + (define dir (build-path (collection-path "games" "mines") + "images")) + + ;; Bomb ---------------------------------------- + + (define (draw-bomb color fuse?) + (send dc set-smoothing 'smoothed) + (send dc set-pen (make-object pen% color 1 'solid)) + (send dc set-brush (make-object brush% color 'solid)) + (send dc draw-ellipse 5 7 14 14) + (when fuse? + (send dc set-pen (make-object pen% (make-object color% 100 100 100) 1 'solid)) + (send dc set-brush (make-object brush% "BLACK" 'transparent)) + (send dc draw-arc 12 2 24 14 (* 2/3 pi) pi))) + + (send dc clear) + (draw-bomb "BLACK" #t) + (send dc set-pen (make-object pen% "RED" 1 'solid)) + (send dc set-smoothing 'aligned) + (send dc draw-line 14 0 16 2) + (send dc draw-line 18 4 20 6) + (send dc draw-line 18 2 20 0) + (send bm save-file (build-path dir "bomb.png") 'png) + + (let ([path (make-object dc-path%)]) + (send path move-to 4 0) + (send path line-to 12 4) + (send path line-to 22 0) + (send path line-to 20 12) + (send path line-to 24 20) + (send path line-to 20 20) + (send path line-to 20 24) + (send path line-to 12 20) + (send path line-to 0 24) + (send path line-to 4 18) + (send path line-to 0 10) + (send path line-to 6 6) + (send path close) + (send path translate -12 -12) + + (send dc clear) + (send dc set-pen (make-object pen% "RED" 1 'solid)) + (send dc set-brush (make-object brush% "RED" 'solid)) + (send dc draw-path path 12 12) + + (send path scale 2/3 2/3) + (send dc set-pen (make-object pen% "ORANGE" 1 'solid)) + (send dc set-brush (make-object brush% "ORANGE" 'solid)) + (send dc draw-path path 12 12) + + (send path scale 1/2 1/2) + (send dc set-pen (make-object pen% "YELLOW" 1 'solid)) + (send dc set-brush (make-object brush% "YELLOW" 'solid)) + (send dc draw-path path 12 12) + + (void)) + + (send bm save-file (build-path dir "explode.png") 'png) + + ;; Tiles ---------------------------------------- + + (define bg (make-object bitmap% (build-path dir "bg.png"))) + + (define (lighter n q) + (- 255 (floor (* (if (zero? q) 3/4 4/5) (- 255 n))))) + (define (darker n q) + (floor (* (if (zero? q) 1/2 4/5) n))) + + (send dc draw-bitmap bg 0 0) + (let ([c (make-object color%)]) + (let loop ([q 0]) + (unless (= q 2) + (let loop ([i 0]) + (unless (= i SIZE) + (let ([adjust + (lambda (adj x y) + (send dc get-pixel x y c) + (send c set + (adj (send c red) q) + (adj (send c green) q) + (adj (send c blue) q)) + (send dc set-pixel x y c))]) + (when (<= q i (- SIZE q)) + (adjust lighter q i) + (unless (zero? i) + (adjust lighter i q)) + (adjust darker (- SIZE 1 q) i) + (unless (= i (- SIZE q)) + (adjust darker i (- SIZE 1 q))))) + (loop (add1 i)))) + (loop (add1 q))))) + + (send bm save-file (build-path dir "tile.png") 'png) + + (define (bright r g b) + (min + (inexact->exact + (floor + (sqrt (+ (sqr r) (sqr g) (sqr g))))) + 255)) + + (define (xform red green blue) + (let ([c (make-object color%)]) + (let loop ([i 0]) + (unless (= i SIZE) + (let loop ([j 0]) + (unless (= j SIZE) + (send dc get-pixel i j c) + (let ([r (send c red)] + [g (send c green)] + [b (send c blue)]) + (send c set + (red r g b) + (green r g b) + (blue r g b)) + (send dc set-pixel i j c) + (loop (add1 j))))) + (loop (add1 i)))))) + + (xform (lambda (r g b) r) (lambda (r g b) g) bright) + + (define tile-bm (make-object bitmap% (build-path dir "tile.png"))) + + (send bm save-file (build-path dir "lclick-tile.png") 'png) + + (send dc draw-bitmap tile-bm 0 0) + (xform bright (lambda (r g b) g) (lambda (r g b) b)) + (send bm save-file (build-path dir "rclick-tile.png") 'png) + + (define (semi-bright r g b) + (floor (- 255 (* 2/3 (- 255 r))))) + + (send dc draw-bitmap tile-bm 0 0) + (xform semi-bright semi-bright semi-bright) + (send bm save-file (build-path dir "local-tile.png") 'png) + + (define (semi-dim r g b) + (floor (* 4/5 r))) + + (send dc draw-bitmap tile-bm 0 0) + (xform semi-dim semi-dim semi-dim) + (send bm save-file (build-path dir "near-tile.png") 'png) + + ;; Flag ----------------------------------------- + + (define (draw-flag dc color field?) + (send dc clear) + (send dc set-smoothing 'aligned) + (send dc set-pen (make-object pen% "BLACK" 1 'solid)) + (send dc set-brush (make-object brush% "BLACK" 'solid)) + (send dc draw-rectangle 5 9 2 12) + (send dc set-pen (make-object pen% color 1 'solid)) + (send dc set-brush (make-object brush% color 'solid)) + (send dc draw-polygon + (list (make-object point% 5 4) + (make-object point% 19 9) + (make-object point% 5 14))) + (when field? + (send dc draw-rectangle 7 3 12 7))) + + (let* ([bm2 (make-object bitmap% SIZE SIZE)] + [dc2 (make-object bitmap-dc% bm2)]) + (draw-flag dc2 "BLACK" #f) + (send dc2 set-bitmap #f) + (send bm set-loaded-mask bm2)) + + (draw-flag dc "RED" #t) + + (send bm save-file (build-path dir "flag.png") 'png) + + ) diff --git a/collects/games/mines/images/bg.png b/collects/games/mines/images/bg.png new file mode 100644 index 0000000000..275cdf4945 Binary files /dev/null and b/collects/games/mines/images/bg.png differ diff --git a/collects/games/mines/images/bomb.png b/collects/games/mines/images/bomb.png new file mode 100644 index 0000000000..11748f05d7 Binary files /dev/null and b/collects/games/mines/images/bomb.png differ diff --git a/collects/games/mines/images/explode.png b/collects/games/mines/images/explode.png new file mode 100644 index 0000000000..97fc60e642 Binary files /dev/null and b/collects/games/mines/images/explode.png differ diff --git a/collects/games/mines/images/flag.png b/collects/games/mines/images/flag.png new file mode 100644 index 0000000000..fa7aab9535 Binary files /dev/null and b/collects/games/mines/images/flag.png differ diff --git a/collects/games/mines/images/hilite-tile.png b/collects/games/mines/images/hilite-tile.png new file mode 100644 index 0000000000..e617ee3e89 Binary files /dev/null and b/collects/games/mines/images/hilite-tile.png differ diff --git a/collects/games/mines/images/lclick-tile.png b/collects/games/mines/images/lclick-tile.png new file mode 100644 index 0000000000..e617ee3e89 Binary files /dev/null and b/collects/games/mines/images/lclick-tile.png differ diff --git a/collects/games/mines/images/local-tile.png b/collects/games/mines/images/local-tile.png new file mode 100644 index 0000000000..9f8c7bbe80 Binary files /dev/null and b/collects/games/mines/images/local-tile.png differ diff --git a/collects/games/mines/images/near-tile.png b/collects/games/mines/images/near-tile.png new file mode 100644 index 0000000000..b0ff06fa82 Binary files /dev/null and b/collects/games/mines/images/near-tile.png differ diff --git a/collects/games/mines/images/rclick-tile.png b/collects/games/mines/images/rclick-tile.png new file mode 100644 index 0000000000..5447004278 Binary files /dev/null and b/collects/games/mines/images/rclick-tile.png differ diff --git a/collects/games/mines/images/tile.png b/collects/games/mines/images/tile.png new file mode 100644 index 0000000000..fd0eb95190 Binary files /dev/null and b/collects/games/mines/images/tile.png differ diff --git a/collects/games/mines/mines.ss b/collects/games/mines/mines.ss index 3d853bab6b..27717ff4cd 100644 --- a/collects/games/mines/mines.ss +++ b/collects/games/mines/mines.ss @@ -13,16 +13,26 @@ (require (lib "etc.ss") ; defines build-vector (lib "class.ss") (lib "unit200.ss") - (lib "mred.ss" "mred")) + (lib "mred.ss" "mred") + (lib "include-bitmap.ss" "mrlib")) (provide game-unit) + + (define tile-bm (include-bitmap "images/tile.png")) + (define lclick-bm (include-bitmap "images/lclick-tile.png")) + (define rclick-bm (include-bitmap "images/rclick-tile.png")) + (define local-bm (include-bitmap "images/local-tile.png")) + (define near-bm (include-bitmap "images/near-tile.png")) + (define bomb-bm (include-bitmap "images/bomb.png")) + (define explode-bm (include-bitmap "images/explode.png")) + (define flag-bm (include-bitmap "images/flag.png")) ;; The game is implemented in a unit so it can be started multiple times (define game-unit (unit (import) (export) - + (define TILE-HW 24) ; height/width of a tile (define B-WIDTH 16) ; number of tiles across (define B-HEIGHT 16) ; number of tiles down @@ -30,7 +40,7 @@ (define DIGIT-COLOR-NAMES ;; 0th is background; 8th is foreground - (vector "LIGHT GRAY" "BLUE" "GREEN" "RED" "PURPLE" + (vector "WHITE" "BLUE" "FORESTGREEN" "RED" "PURPLE" "ORANGE" "YELLOW" "BROWN" "BLACK")) (define DIGIT-COLORS @@ -40,7 +50,8 @@ (define BG-COLOR (vector-ref DIGIT-COLORS 0)) (define FG-COLOR (vector-ref DIGIT-COLORS 8)) - (define EXPLODE-COLOR (send the-color-database find-color "RED")) + + (define BLACK-COLOR (send the-color-database find-color "BLACK")) (define BG-PEN (make-object pen% BG-COLOR 1 'solid)) (define FG-PEN (make-object pen% FG-COLOR 1 'solid)) @@ -57,8 +68,9 @@ ;; Class for a tile object (define tile:plain% (class object% - (define state 'covered) ; 'covered, 'flagged, 'semi-flagged, or 'uncovered + (define state 'covered) ; 'covered, 'flagged, 'semi-flagged, or 'uncovered (define neighbor-bomb-count 0) ; 0 to 8 + (define area-hilite 'none) ; 'none, 'local, 'near (public* [set-state @@ -73,29 +85,42 @@ [get-neighbor-bomb-count (lambda () neighbor-bomb-count)] + [set-area-hilite + (lambda (mode) + (set! area-hilite mode))] [draw-text-tile - (lambda (dc x y w h hilite? border? str color) + (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))) + (send dc draw-bitmap + (case hilite + [(left) lclick-bm] + [(right) rclick-bm] + [else (case area-hilite + [(near) near-bm] + [(local) local-bm] + [else tile-bm])]) + x y) + (begin + (send dc set-pen BG-PEN) + (send dc draw-rectangle x y w h))) (when str - (send dc set-text-foreground (or color FG-COLOR)) - ;; Draw text centered in the tile's box: - (let-values ([(tw th d a) (send dc get-text-extent str)]) - (send dc draw-text str - (+ x (/ (- w tw) 2)) - (+ y (/ (- h th) 2))))))] + (cond + [(string? str) + (send dc set-text-foreground (or color FG-COLOR)) + ;; Draw text centered in the tile's box: + (let-values ([(tw th d a) (send dc get-text-extent str)]) + (send dc draw-text str + (+ x (/ (- w tw) 2)) + (+ y (/ (- h (- th d)) 2))))] + [else + (send dc draw-bitmap str x y 'solid BLACK-COLOR + (send str get-loaded-mask))])))] [draw - (lambda (dc x y w h hilite?) + (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)] + [(covered) (draw-text-tile dc x y w h hilite #t #f #f)] + [(flagged) (draw-text-tile dc x y w h hilite #t flag-bm #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) @@ -118,11 +143,11 @@ (override* [draw - (lambda (dc x y w h hilite?) + (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?)))]) + (draw-text-tile dc x y w h #f #f + (if explode-source? explode-bm bomb-bm) #f) + (super draw dc x y w h hilite)))]) (super-instantiate ()))) @@ -208,7 +233,7 @@ (inner () on-close))]) (super-instantiate ())) ("Minesweeper") - [style '(no-resize-border)])) + [style '(no-resize-border metal)])) ;; Make the row of controls at the top of the frame: (define panel (make-object horizontal-panel% frame)) @@ -236,13 +261,16 @@ (inherit get-dc min-client-width min-client-height stretchable-width stretchable-height) - (define clicking #f) ; #t => click in progress - (define clicking-x 0) ; x position of click in progress - (define clicking-y 0) ; y position of click in progress - (define ready? #t) ; #t => accept clicks - (define start-time #f) ; time of first click - (define elapsed-time 0) ; seconds since first click - (define timer #f) ; a timer that updates elapsed-time + (define clicking #f) ; #t => click in progress + (define clicking-x 0) ; x position of click in progress + (define clicking-y 0) ; y position of click in progress + (define clicking-right? #f) ; #t => right-click in progress + (define area-hilite #f) ; tile with mouse pointer over it + (define area-hilites null) ; tiles+locs hilited due to mouse-over + (define ready? #t) ; #t => accept clicks + (define start-time #f) ; time of first click + (define elapsed-time 0) ; seconds since first click + (define timer #f) ; a timer that updates elapsed-time (define bomb-count THE-BOMB-COUNT) ; number of bombs minus the number of flags (define cover-count (* B-HEIGHT B-WIDTH)) ; number of uncovered tiles @@ -354,8 +382,9 @@ (if bomb? (explode) (begin - (when (zero? nc) - (autoclick-surrounding x y)))) + (if (zero? nc) + (autoclick-surrounding x y) + (set-near-hilite t x y)))) (when (and ready? (= cover-count THE-BOMB-COUNT)) (win)))))] [paint-one ; draw one tile @@ -363,8 +392,32 @@ (let ([xloc (* x TILE-HW)] [yloc (* y TILE-HW)]) (send t draw dc xloc yloc TILE-HW TILE-HW - (eq? t clicking))))]) - + (and (eq? t clicking) + (if clicking-right? 'right 'left)))))] + [set-near-hilite + (lambda (t x y) + (set! area-hilite t) + (set! area-hilites + (do-surrounding x y append null null + (lambda (dx dy) + (let* ([x (+ x dx)] + [y (+ y dy)] + [t (get-tile x y)]) + (if (not (eq? (send t get-state) 'uncovered)) + (begin + (send t set-area-hilite 'near) + (paint-one t x y) + (list (list t x y))) + null))))))] + [clear-area-hilite + (lambda () + (when area-hilite + (set! area-hilite #f) + (for-each (lambda (p) + (send (car p) set-area-hilite 'none) + (paint-one (car p) (cadr p) (caddr p))) + area-hilites) + (set! area-hilites null)))]) (override* [on-event ; handle a click (lambda (e) @@ -398,18 +451,39 @@ (= x clicking-x) (= y clicking-y)))) ;; Start a click on a covered tile + (clear-area-hilite) (set! clicking t) (set! clicking-x x) (set! clicking-y y) + (when (send e button-down?) + (set! clicking-right? (or (send e button-down? 'right) + (send e get-control-down) + (send e get-alt-down) + (send e get-meta-down)))) (paint-one t x y)] - [(send e button-down?) - ;; fallthough to here => clicking, but not on a tile - (set! clicking-x -1)] [(and clicking (send e button-up?)) ;; User released the button (set! clicking #f) - (do-select x y (send e button-up? 'right))] - [else 'ok]))))] + (do-select x y clicking-right?)] + [(and (not (send e leaving?)) + t + (eq? (send t get-state) 'uncovered) + (positive? (send t get-neighbor-bomb-count))) + ;; Moving over uncovered number + (unless (eq? t area-hilite) + (clear-area-hilite) + (set-near-hilite t x y))] + [(and (not (send e leaving?)) + t + (not (eq? (send t get-state) 'uncovered))) + ;; Moving over tile + (unless (eq? t area-hilite) + (clear-area-hilite) + (set! area-hilite t) + (set! area-hilites (list (list t x y))) + (send t set-area-hilite 'local) + (paint-one t x y))] + [else (clear-area-hilite)]))))] [on-paint ; refresh the board (lambda () (for-each-tile (lambda (tile x y) (paint-one tile x y))))]) @@ -425,6 +499,7 @@ (define dc (get-dc)) (reset) ; initialize the game + (send dc set-font (make-object font% 16 'swiss 'normal 'bold #f 'default #t)) (send dc set-text-background BG-COLOR) (send dc set-brush (send the-brush-list find-or-create-brush BG-COLOR 'solid))))