From 8ee09f09d87eeecbe1a6cef2f7c873d67b24c963 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 11 Dec 2006 11:49:20 +0000 Subject: [PATCH] minesweeper face-lift svn: r5080 --- collects/games/mines/gen-tiles.ss | 182 ++++++++++++++++++++ collects/games/mines/images/bg.png | Bin 0 -> 411 bytes collects/games/mines/images/bomb.png | Bin 0 -> 446 bytes collects/games/mines/images/explode.png | Bin 0 -> 806 bytes collects/games/mines/images/flag.png | Bin 0 -> 349 bytes collects/games/mines/images/hilite-tile.png | Bin 0 -> 454 bytes collects/games/mines/images/lclick-tile.png | Bin 0 -> 454 bytes collects/games/mines/images/local-tile.png | Bin 0 -> 398 bytes collects/games/mines/images/near-tile.png | Bin 0 -> 422 bytes collects/games/mines/images/rclick-tile.png | Bin 0 -> 454 bytes collects/games/mines/images/tile.png | Bin 0 -> 455 bytes collects/games/mines/mines.ss | 163 +++++++++++++----- 12 files changed, 301 insertions(+), 44 deletions(-) create mode 100644 collects/games/mines/gen-tiles.ss create mode 100644 collects/games/mines/images/bg.png create mode 100644 collects/games/mines/images/bomb.png create mode 100644 collects/games/mines/images/explode.png create mode 100644 collects/games/mines/images/flag.png create mode 100644 collects/games/mines/images/hilite-tile.png create mode 100644 collects/games/mines/images/lclick-tile.png create mode 100644 collects/games/mines/images/local-tile.png create mode 100644 collects/games/mines/images/near-tile.png create mode 100644 collects/games/mines/images/rclick-tile.png create mode 100644 collects/games/mines/images/tile.png 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 0000000000000000000000000000000000000000..275cdf4945a5fa2911eae32446b4bb4716f733d7 GIT binary patch literal 411 zcmV;M0c8G(P)#No)cQ$^yp(>$*P3 zwrvqM*ERdUWm)K&*izYvtqk_`KUGk2N^g%Lp20bjOZWbrz{=-Jq^0CK2s_7mz&ugp zJkQ5t-}evNO*qbafNf~;jAQ}5Z%Hti?PV4uNEd#CWayXmL}hc^)bm9Xq#6R(MKvu! zt38e*=?~&oU^QnR6n$u@Z_2ook!;WHqMXSrVCth3)hg&}K`n8PM7d)3m;})>``k?g~T5vY++( z8z9{6Aj_cNuYym2E|<%8zyH$u^Kb~~^Lp5^EMv@Ku~;sb=kvLtUyePJQqE?x)oRt; zug)H6t>ZX8oleK&aWEK6CX-sfV6%ZRY%5JE#W^R01VO+Un@*=e5D-E*=R%0aD-9qi zB>*6V%9n=2;b=4}*BE0;sg$xCB!r-pcK)DJssqG1#~8O$5JH^uHjq+^5Ym|r01!fI zNxff(lO*vx&jsXpUL42QCpVy?D2y>KAY)8X6c0iF(G7?(=KH?OHQ)CcV>d^yYIei- zSEKky7~_ubFO%v_hf;cPlxB-iN*l+rOxDRFrGyZbX%RvQp~|%P<|y@Mt$kF2);dX& oa$Xo?1KIqEP)19&i(KL^3)^mUV%sSOX;7g~B+2pP z=mbT0_|SLZT`H|4j`2A=X{QIQCCSEy!NE?@y?ZWPu(YJUYk|?EY3aMHucVLuep!ZM z+sN#!TFsq1>UFPifQ$>g#{gvpIKxL22>$G-3uRBAI&;R-lFdyyA9E^Y-{%-7d50!F z{6nzC6HqKVc`|_p2Gr}CP57Eps;EqfLi#PyOh$J38}#+5)mosUu`%V;fJaG&^BirL z-i}6UO^Ma+(u!th6$y$bhT;|{OQ3sowjvPs#{(j@*t?{@C8(+Mi_ zKCgo>Qje}&**oOw)wZck?k3q^sjgj`ASg3RnL%o7Z=0L5yqrM$O)aGAh6r}~gP&za;X@wr8_z&5W87jRS>ECn-;?L=-%lV+PP%c! zC)+RHbSs{vcd*yKpmjalTqMhkkM9FLc;Kx!Oz+4*gI!knfnS;AP4dM0wDTVFJb@yd zIN|Nzjj%(L1%Bf3zU&&8sgS<}%Ca<%W@e(VFRqIzQA@L?wW`(jNFqw&12Ly#wzVco zM8wikR4UzPE&b?d%+JT_YD`Q-p0{!PR|?T=#?Vj{iyivYr(=FT*4I0R=kjt)PIlv7 kfTpJ-%U-4LiY{D==Orvi3Hxea(EtDd07*qoM6N<$f@4jEI{*Lx literal 0 HcmV?d00001 diff --git a/collects/games/mines/images/flag.png b/collects/games/mines/images/flag.png new file mode 100644 index 0000000000000000000000000000000000000000..fa7aab9535670dec6efa659ae7c1219cc7eea123 GIT binary patch literal 349 zcmV-j0iyniP)b;@5JlgjfRSaVpd|$dpyB}3wDfd2Ktz|EfQ}Q;(NoiMfTW>M8Yn4@<-|sUpCXB5 z#g2`MiG-AqezUv!Z+CWPj3mw(m9x741>h=k*O+2%Dd|psfn`PXdUK!;)QV9OP$l(o z7YRJUt6(bV3XFgsmEx5L_|jgm6>J1!LAz`~TsuJ^cosYeZpsG4^(F`fkAhoy-t~7c zliFy;oYH*(jw5{EjW7PL59;+0%Zli9o|sJTSg)IjGlf%Bt?p#ofm*E>jYjuct(vJG zh5n#Y*~@W!H5wZYhhr_5?JU#d0j|51Z3h|*rdlkzIvmWg#+iT+GzV!m>nn%TLieOB?wqVR(@m00000NkvXXu0mjfd102} literal 0 HcmV?d00001 diff --git a/collects/games/mines/images/hilite-tile.png b/collects/games/mines/images/hilite-tile.png new file mode 100644 index 0000000000000000000000000000000000000000..e617ee3e89ad880a4d4a0f4ddcbf28bd3faf0e60 GIT binary patch literal 454 zcmV;%0XhDOP)p=_OS z>Y1ZIi8ltu*g>PJdb+6-CSoU~0El2M{X?TEu>+>~F`k{|NaPWqOJ;_Mqd2dcC7V3a zB?4<6AmqT1scdB<0i15&w?q6TdK2~-UP^h^m(maXj z%OX#a&Z&V+G|~dk&yn}PbHog0IF}M-*T`6-=o!{X*Jae1CyIDjBXtdCG|i+sGtVEa zsz6jz-@`fF?~^}wvUA7ydPUb=sIEaY{A=TOG-l3Ef776z9w8!Tp=_OS z>Y1ZIi8ltu*g>PJdb+6-CSoU~0El2M{X?TEu>+>~F`k{|NaPWqOJ;_Mqd2dcC7V3a zB?4<6AmqT1scdB<0i15&w?q6TdK2~-UP^h^m(maXj z%OX#a&Z&V+G|~dk&yn}PbHog0IF}M-*T`6-=o!{X*Jae1CyIDjBXtdCG|i+sGtVEa zsz6jz-@`fF?~^}wvUA7ydPUb=sIEaY{A=TOG-l3Ef776z9w8!Tg(0;wOv|KVnkMHQeMg=tMl2i0k%_45 zI<0k5QRFHnmu1mfGZAU6uj?WrAw&c`&;D0U=6Rm$x-tL&*4l(9QSm}#i~+z>N+ME9 z#UDk?3lTF*DcO$$K(XklsFw6tuHkEp&$Ivf;js8b5s<@jbsipO#LPJ|=^~+vp_CFr zlxNhmXnqsdkk2}As~qeDfOC$ECaz&(JjWDfB!rMs`bpIk(d+XorGk(A`_+hEbj9%l z_@7bH0l&LE_{g_bb4mhE=X zYozPCxQ||XDL#MD!mN~H&v)N<&4kUJtF<=91Vv3B5fOmm3hn!znHj)5&-=bNTdT=j s*VQ@4!!X?Uy(~*jd2?qU$FXhOANoR#{5=gS)&Kwi07*qoM6N<$f}o$b1poj5 literal 0 HcmV?d00001 diff --git a/collects/games/mines/images/near-tile.png b/collects/games/mines/images/near-tile.png new file mode 100644 index 0000000000000000000000000000000000000000..b0ff06fa824e1be832fdd2c21cd19e17e7549314 GIT binary patch literal 422 zcmV;X0a^ZuP)Q2Xn(vt8k@Wa?p#<%FCA^$w$_WOM)1-_v*Rd&t|%#Oz+ z0YHrL^?Lmh$i@PIX_`_>1OO?e=kr;uo3oa;Dyn!q9+%67m{~+}&Z|IOpKi%HXAvPp zbj}e`JLo1KR76DHdn%=fh=^<@Y^_;?suYn@3c=5?(d+je$o-@1u%*=Y)twL#073}b zPItPxHJj!=WM(dRz(2d zz2D*lA|hg+M;5Cg>TuPa^c1@7{K)dJ*1F@c&h?^ou^&RNW@IZ`@kj^y@Q9f$kGgBb zu7{?fx&)SG(H6f1YVv!H#2DK?>SA#H6(Iyfq?|J|&-1LE?OTIw_NSDVWuX{jn~`lt z%le7v_psaTLI}jnr_R literal 0 HcmV?d00001 diff --git a/collects/games/mines/images/rclick-tile.png b/collects/games/mines/images/rclick-tile.png new file mode 100644 index 0000000000000000000000000000000000000000..54470042789ca586bd87b8bd0de77ff6bc16e166 GIT binary patch literal 454 zcmV;%0XhDOP)e?541G!6mhS)m6fXRP9VSg2c0&WiX#xo$K}#DuJM_yWZMFIIn%K|wi)-VzTX>Ja z^ht}2S#bN=YzP2WD?A>d#}KB8VlDuO!>y_a#-J>5zjxk4u*Pvk+TnWrI35Ykff-E` z5-qo;ansby1R@xNG#xJ{lP?gZX_h1e5r}{})F`efc4!Zo#e2fvO|y$=>_n(5TPK`* z=HWc>H^v&%Ym{X#kvd@@c0dY%h^+mOMss3&4}ivxcy@v-k-uH9F3}!eN5>2j=Sfl==Un6xrq0TbVfV(x4=U_%r%&N2S{HosO|f5`8=I|0mso^>-{c*RR91007*qoM6N<$f;9Eay8r+H literal 0 HcmV?d00001 diff --git a/collects/games/mines/images/tile.png b/collects/games/mines/images/tile.png new file mode 100644 index 0000000000000000000000000000000000000000..fd0eb951904efe73f9166f5c2bd7fee1e8c71a47 GIT binary patch literal 455 zcmV;&0XY7NP)YS@t<+7MG+=WV@x!D-#hjBloLRX&zqq zl7TTsYmJ1AF=``{kTGVfCjeM$5o1g?)teJ9ySr8U`uvF@>zA9GkJX$6NO!i@s#XU{ zQ}QY^OJ)e+ry&cEq`~`r6k}Zbh=_tz z<<8FYr*O^zfcHLx@cn+be(qxC)_9txWm(YoJ%IGD)#XS`M9uCWhQT=pBD!2IkH@1f xr}n5x7{`&BaXcR9dA?q+e-e`Md_M2@`#& 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))))