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