extra/minesweeper/minesweeper.factor

   1 ! Copyright (C) 2017 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors arrays assocs calendar circular colors
   5 combinators combinators.short-circuit combinators.smart
   6 destructors formatting images.loader kernel math math.order
   7 math.parser namespaces opengl opengl.textures random sequences
   8 timers ui ui.commands ui.gadgets ui.gadgets.toolbar
   9 ui.gadgets.tracks ui.gadgets.worlds ui.gestures ui.pens.solid
  10 ui.render ui.tools.browser words ;
  11
  12 IN: minesweeper
  13
  14 CONSTANT: neighbors {
  15     { -1 -1 } { -1  0 } { -1  1 }
  16     {  0 -1 }           {  0  1 }
  17     {  1 -1 } {  1  0 } {  1  1 }
  18 }
  19
  20 SYMBOLS: +flagged+ +question+ +clicked+ ;
  21
  22 TUPLE: cell #adjacent mined? state ;
  23
  24 : make-cells ( rows cols -- cells )
  25     '[ _ [ cell new ] replicate ] replicate ;
  26
  27 :: cell-at ( cells row col -- cell/f )
  28     row cells ?nth [ col swap ?nth ] [ f ] if* ;
  29
  30 : cells-dim ( cells -- rows cols )
  31     [ length ] [ first length ] bi ;
  32
  33 : #mines ( cells -- n )
  34     [ [ mined?>> ] count ] map-sum ;
  35
  36 : #flagged ( cells -- n )
  37     [ [ state>> +flagged+ = ] count ] map-sum ;
  38
  39 : #mines-remaining ( cells -- n )
  40     [ #mines ] [ #flagged ] bi - ;
  41
  42 : unmined-cell ( cells -- cell )
  43     '[ _ random random dup mined?>> ] smart-loop ;
  44
  45 : place-mines ( cells n -- cells )
  46     [ dup unmined-cell t >>mined? drop ] times ;
  47
  48 :: count-neighbors ( cells row col quot: ( cell -- ? ) -- n )
  49     cells neighbors [
  50         first2 [ row + ] [ col + ] bi* cell-at quot [ f ] if*
  51     ] with count ; inline
  52
  53 : adjacent-mines ( cells row col -- #mines )
  54     [ mined?>> ] count-neighbors ;
  55
  56 : adjacent-flags ( cells row col -- #flags )
  57     [ state>> +flagged+ = ] count-neighbors ;
  58
  59 :: each-cell ( ... cells quot: ( ... row col cell -- ... ) -- ... )
  60     cells [| row |
  61         [| cell col | row col cell quot call ] each-index
  62     ] each-index ; inline
  63
  64 :: update-counts ( cells -- cells )
  65     cells [| row col cell |
  66         cells row col adjacent-mines cell #adjacent<<
  67     ] each-cell cells ;
  68
  69 : reset-cells ( cells -- cells )
  70     [ cells-dim make-cells ] [ #mines place-mines ] bi update-counts ;
  71
  72 : won? ( cells -- ? )
  73     [ [ { [ state>> +clicked+ = ] [ mined?>> ] } 1|| ] all? ] all? ;
  74
  75 : lost? ( cells -- ? )
  76     [ [ { [ state>> +clicked+ = ] [ mined?>> ] } 1&& ] any? ] any? ;
  77
  78 : game-over? ( cells -- ? )
  79     { [ lost? ] [ won? ] } 1|| ;
  80
  81 : new-game? ( cells -- ? )
  82     [ [ state>> +clicked+ = ] any? ] none? ;
  83
  84 DEFER: click-cell-at
  85
  86 :: click-cells-around ( cells row col -- )
  87     neighbors [
  88         first2 [ row + ] [ col + ] bi* :> ( row' col' )
  89         cells row' col' cell-at [
  90             cells row' col' click-cell-at drop
  91         ] when
  92     ] each ;
  93
  94 :: click-cell-at ( cells row col -- ? )
  95     cells row col cell-at [
  96         cells new-game? [
  97             ! first click shouldn't be a mine
  98             dup mined?>> [
  99                 cells unmined-cell t >>mined? drop f >>mined?
 100                 cells update-counts drop
 101             ] when
 102         ] when
 103         dup state>> { +clicked+ +flagged+ } member? [ drop f ] [
 104             +clicked+ >>state
 105             { [ mined?>> not ] [ #adjacent>> 0 = ] } 1&& [
 106                 cells row col click-cells-around
 107             ] when t
 108         ] if
 109     ] [ f ] if* ;
 110
 111 :: mark-cell-at ( cells row col -- ? )
 112     cells row col cell-at [
 113         dup state>> {
 114             { +clicked+ [ +clicked+ ] }
 115             { +flagged+ [ +question+ ] }
 116             { +question+ [ f ] }
 117             { f [ +flagged+ ] }
 118         } case >>state drop t
 119     ] [ f ] if* ;
 120
 121 :: open-cell-at ( cells row col -- ? )
 122     cells row col cell-at [
 123         state>> +clicked+ = [
 124             cells row col [ adjacent-flags ] [ adjacent-mines ] 3bi = [
 125                 cells row col click-cells-around
 126             ] when
 127         ] when t
 128     ] [ f ] if* ;
 129
 130 TUPLE: grid-gadget < gadget cells timer textures start end hint? ;
 131
 132 :: <grid-gadget> ( rows cols mines -- gadget )
 133     grid-gadget new
 134         rows cols make-cells
 135         mines place-mines update-counts >>cells
 136         H{ } clone >>textures
 137         dup '[ _ relayout-1 ] f 1 seconds <timer> >>timer
 138         COLOR: gray <solid> >>interior
 139         "12345" <circular> >>hint? ;
 140
 141 M: grid-gadget graft*
 142     [ timer>> start-timer ] [ call-next-method ] bi ;
 143
 144 M: grid-gadget ungraft*
 145     [
 146         dup find-gl-context
 147         [ values dispose-each H{ } clone ] change-textures
 148         timer>> stop-timer
 149     ] [ call-next-method ] bi ;
 150
 151 M: grid-gadget pref-dim*
 152     cells>> cells-dim [ 32 * ] bi@ swap 58 + 2array ;
 153
 154 :: cell-image-path ( cell won? lost? -- image-path )
 155     won? lost? or cell mined?>> and [
 156         cell state>> {
 157             { +flagged+ [ "flagged.gif" ] }
 158             { +clicked+ [ "mineclicked.gif" ] }
 159             [ drop won? "flagged.gif" "mine.gif" ? ]
 160         } case
 161     ] [
 162         cell state>> {
 163             { +question+ [ "question.gif" ] }
 164             { +flagged+ [ lost? "misflagged.gif" "flagged.gif" ? ] }
 165             { +clicked+ [
 166                 cell #adjacent>> 0 or number>string
 167                 "open" ".gif" surround ] }
 168             { f [ "blank.gif" ] }
 169         } case
 170     ] if "vocab:minesweeper/_resources/" prepend ;
 171
 172 : digit-image-path ( ch -- image-path )
 173     "vocab:minesweeper/_resources/digit%c.gif" sprintf ;
 174
 175 :: smiley-image-path ( won? lost? clicking? -- image-path )
 176     {
 177         { [ lost? ] [ "vocab:minesweeper/_resources/smileylost.gif" ] }
 178         { [ won? ] [ "vocab:minesweeper/_resources/smileywon.gif" ] }
 179         { [ clicking? ] [ "vocab:minesweeper/_resources/smileyuhoh.gif" ] }
 180         [ "vocab:minesweeper/_resources/smiley.gif" ]
 181     } cond ;
 182
 183 : draw-cached-texture ( path gadget -- )
 184     textures>> [ load-image { 0 0 } <texture> ] cache
 185     [ dim>> [ 2 /i ] map ] [ draw-scaled-texture ] bi ;
 186
 187 :: draw-hint ( gadget -- )
 188     gadget hint?>> "xyzzy" sequence= [
 189         gadget hand-rel first2 :> ( w h )
 190         h 58 >= [
 191             h 58 - w [ 32 /i ] bi@ :> ( row col )
 192             gadget cells>> row col cell-at [
 193                 mined?>> COLOR: black COLOR: white ? gl-color
 194                 { 0 0 } { 1 1 } gl-fill-rect
 195             ] when*
 196         ] when
 197     ] when ;
 198
 199 :: draw-mines ( n gadget -- )
 200     gadget cells>> won? 0 n ? "%03d" sprintf [
 201         26 * 3 + 6 2array [
 202             digit-image-path gadget draw-cached-texture
 203         ] with-translation
 204     ] each-index ;
 205
 206 :: draw-smiley ( gadget -- )
 207     gadget pref-dim first :> width
 208     width 2/ 26 - 3 2array [
 209         gadget cells>> [ won? ] [ lost? ] bi
 210         hand-buttons get-global empty? not
 211         gadget hand-click-rel [ second 58 >= ] [ f ] if* and
 212         smiley-image-path gadget draw-cached-texture
 213     ] with-translation ;
 214
 215 :: draw-timer ( n gadget -- )
 216     gadget pref-dim first :> width
 217     n 999 min "%03d" sprintf [
 218         3 swap - 26 * width swap - 3 - 6 2array [
 219             digit-image-path gadget draw-cached-texture
 220         ] with-translation
 221     ] each-index ;
 222
 223 :: draw-cells ( gadget -- )
 224     gadget cells>> [ won? ] [ lost? ] bi :> ( won? lost? )
 225     gadget cells>> [| row col cell |
 226         col row [ 32 * ] bi@ 58 + 2array [
 227             cell won? lost? cell-image-path
 228             gadget draw-cached-texture
 229         ] with-translation
 230     ] each-cell ;
 231
 232 :: elapsed-time ( gadget -- n )
 233     gadget start>> [
 234         gadget end>> now or swap time- duration>seconds
 235     ] [ 0 ] if* ;
 236
 237 M: grid-gadget handle-gesture
 238     over {
 239         [ key-down? ] [ sym>> length 1 = ] [ sym>> " " = not ]
 240     } 1&& [
 241         2dup [ sym>> first ] [ hint?>> ] bi* circular-push
 242     ] when call-next-method ;
 243
 244 M: grid-gadget draw-gadget*
 245     {
 246         [ draw-hint ]
 247         [ cells>> #mines-remaining ]
 248         [ draw-mines ]
 249         [ draw-smiley ]
 250         [ elapsed-time ]
 251         [ draw-timer ]
 252         [ draw-cells ]
 253     } cleave ;
 254
 255 :: on-grid ( gadget quot: ( cells row col -- ? ) -- )
 256     gadget hand-rel first2 :> ( w h )
 257     h 58 >= [
 258         h 58 - w [ 32 /i ] bi@ :> ( row col )
 259         gadget cells>> :> cells
 260         cells game-over? [
 261             cells row col quot call [
 262                 gadget start>> [ now gadget start<< ] unless
 263                 cells game-over? [ now gadget end<< ] when
 264             ] when
 265         ] unless
 266     ] when gadget relayout-1 ; inline
 267
 268 :: on-click ( gadget -- )
 269     gadget hand-rel first2 :> ( w h )
 270     h 58 < [
 271         h 3 55 between?
 272         gadget pref-dim first 2/ w - abs 26 < and [
 273             gadget [ reset-cells ] change-cells
 274             f >>start f >>end drop
 275         ] when
 276     ] when gadget [ click-cell-at ] on-grid ;
 277
 278 : on-mark ( gadget -- ) [ mark-cell-at ] on-grid ;
 279
 280 : on-open ( gadget -- ) [ open-cell-at ] on-grid ;
 281
 282 : new-game ( gadget rows cols mines -- )
 283     [ make-cells ] dip place-mines update-counts >>cells
 284     f >>start f >>end relayout-window ;
 285
 286 : com-easy ( gadget -- ) 8 8 10 new-game ;
 287
 288 : com-medium ( gadget -- ) 16 16 40 new-game ;
 289
 290 : com-hard ( gadget -- ) 16 30 99 new-game ;
 291
 292 : com-help ( gadget -- ) drop "minesweeper" com-browse ;
 293
 294 grid-gadget "toolbar" f {
 295     { T{ key-down { sym "1" } } com-easy }
 296     { T{ key-down { sym "2" } } com-medium }
 297     { T{ key-down { sym "3" } } com-hard }
 298     { T{ key-down { sym "?" } } com-help }
 299 } define-command-map
 300
 301 grid-gadget "gestures" [
 302     {
 303         { T{ button-down { # 1 } } [ relayout-1 ] }
 304         { T{ button-up { # 1 } } [ on-click ] }
 305         { T{ button-up { # 3 } } [ on-mark ] }
 306         { T{ button-up { # 2 } } [ on-open ] }
 307         { T{ key-down { sym " " } } [ on-mark ] }
 308         { motion [ relayout-1 ] }
 309     } assoc-union
 310 ] change-word-prop
 311
 312 TUPLE: minesweeper-gadget < track ;
 313
 314 : <minesweeper-gadget> ( -- gadget )
 315     vertical minesweeper-gadget new-track
 316     8 8 10 <grid-gadget>
 317     [ <toolbar> format-toolbar f track-add ]
 318     [ 1 track-add ] bi ;
 319
 320 M: minesweeper-gadget focusable-child* children>> second ;
 321
 322 MAIN-WINDOW: run-minesweeper {
 323         { title "Minesweeper" }
 324         { window-controls
 325             { normal-title-bar close-button minimize-button } }
 326     } <minesweeper-gadget> >>gadgets ;