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