Permalink
Fetching contributors…
Cannot retrieve contributors at this time
327 lines (266 sloc) 9.74 KB
! Copyright (C) 2017 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
USING: accessors arrays assocs calendar circular
colors.constants combinators combinators.short-circuit
destructors formatting fry images.loader kernel locals math
math.order math.parser namespaces opengl opengl.textures random
sequences timers ui ui.commands ui.gadgets ui.gadgets.toolbar
ui.gadgets.tracks ui.gadgets.worlds ui.gestures ui.pens.solid
ui.render ui.tools.browser words ;
IN: minesweeper
CONSTANT: neighbors {
{ -1 -1 } { -1 0 } { -1 1 }
{ 0 -1 } { 0 1 }
{ 1 -1 } { 1 0 } { 1 1 }
}
SYMBOLS: +flagged+ +question+ +clicked+ ;
TUPLE: cell #adjacent mined? state ;
: make-cells ( rows cols -- cells )
'[ _ [ cell new ] replicate ] replicate ;
:: cell-at ( cells row col -- cell/f )
row cells ?nth [ col swap ?nth ] [ f ] if* ;
: cells-dim ( cells -- rows cols )
[ length ] [ first length ] bi ;
: #mines ( cells -- n )
[ [ mined?>> ] count ] map-sum ;
: #flagged ( cells -- n )
[ [ state>> +flagged+ = ] count ] map-sum ;
: #mines-remaining ( cells -- n )
[ #mines ] [ #flagged ] bi - ;
: unmined-cell ( cells -- cell )
f [ dup mined?>> ] [ drop dup random random ] do while nip ;
: place-mines ( cells n -- cells )
[ dup unmined-cell t >>mined? drop ] times ;
:: count-neighbors ( cells row col quot: ( cell -- ? ) -- n )
cells neighbors [
first2 [ row + ] [ col + ] bi* cell-at quot [ f ] if*
] with count ; inline
: adjacent-mines ( cells row col -- #mines )
[ mined?>> ] count-neighbors ;
: adjacent-flags ( cells row col -- #flags )
[ state>> +flagged+ = ] count-neighbors ;
:: each-cell ( ... cells quot: ( ... row col cell -- ... ) -- ... )
cells [| row |
[| cell col | row col cell quot call ] each-index
] each-index ; inline
:: update-counts ( cells -- cells )
cells [| row col cell |
cells row col adjacent-mines cell #adjacent<<
] each-cell cells ;
: reset-cells ( cells -- cells )
[ cells-dim make-cells ] [ #mines place-mines ] bi update-counts ;
: won? ( cells -- ? )
[ [ { [ state>> +clicked+ = ] [ mined?>> ] } 1|| ] all? ] all? ;
: lost? ( cells -- ? )
[ [ { [ state>> +clicked+ = ] [ mined?>> ] } 1&& ] any? ] any? ;
: game-over? ( cells -- ? )
{ [ lost? ] [ won? ] } 1|| ;
: new-game? ( cells -- ? )
[ [ state>> +clicked+ = ] any? ] none? ;
DEFER: click-cell-at
:: click-cells-around ( cells row col -- )
neighbors [
first2 [ row + ] [ col + ] bi* :> ( row' col' )
cells row' col' cell-at [
cells row' col' click-cell-at drop
] when
] each ;
:: click-cell-at ( cells row col -- ? )
cells row col cell-at [
cells new-game? [
! first click shouldn't be a mine
dup mined?>> [
cells unmined-cell t >>mined? drop f >>mined?
cells update-counts drop
] when
] when
dup state>> { +clicked+ +flagged+ } member? [ drop f ] [
+clicked+ >>state
{ [ mined?>> not ] [ #adjacent>> 0 = ] } 1&& [
cells row col click-cells-around
] when t
] if
] [ f ] if* ;
:: mark-cell-at ( cells row col -- ? )
cells row col cell-at [
dup state>> {
{ +clicked+ [ +clicked+ ] }
{ +flagged+ [ +question+ ] }
{ +question+ [ f ] }
{ f [ +flagged+ ] }
} case >>state drop t
] [ f ] if* ;
:: open-cell-at ( cells row col -- ? )
cells row col cell-at [
state>> +clicked+ = [
cells row col [ adjacent-flags ] [ adjacent-mines ] 3bi = [
cells row col click-cells-around
] when
] when t
] [ f ] if* ;
TUPLE: grid-gadget < gadget cells timer textures start end hint? ;
:: <grid-gadget> ( rows cols mines -- gadget )
grid-gadget new
rows cols make-cells
mines place-mines update-counts >>cells
H{ } clone >>textures
dup '[ _ relayout-1 ] f 1 seconds <timer> >>timer
COLOR: gray <solid> >>interior
"12345" <circular> >>hint? ;
M: grid-gadget graft*
[ timer>> start-timer ] [ call-next-method ] bi ;
M: grid-gadget ungraft*
[
dup find-gl-context
[ values dispose-each H{ } clone ] change-textures
timer>> stop-timer
] [ call-next-method ] bi ;
M: grid-gadget pref-dim*
cells>> cells-dim [ 32 * ] bi@ swap 58 + 2array ;
:: cell-image-path ( cell won? lost? -- image-path )
won? lost? or cell mined?>> and [
cell state>> {
{ +flagged+ [ "flagged.gif" ] }
{ +clicked+ [ "mineclicked.gif" ] }
[ drop won? "flagged.gif" "mine.gif" ? ]
} case
] [
cell state>> {
{ +question+ [ "question.gif" ] }
{ +flagged+ [ lost? "misflagged.gif" "flagged.gif" ? ] }
{ +clicked+ [
cell #adjacent>> 0 or number>string
"open" ".gif" surround ] }
{ f [ "blank.gif" ] }
} case
] if "vocab:minesweeper/_resources/" prepend ;
: digit-image-path ( ch -- image-path )
"vocab:minesweeper/_resources/digit%c.gif" sprintf ;
:: smiley-image-path ( won? lost? clicking? -- image-path )
{
{ [ lost? ] [ "vocab:minesweeper/_resources/smileylost.gif" ] }
{ [ won? ] [ "vocab:minesweeper/_resources/smileywon.gif" ] }
{ [ clicking? ] [ "vocab:minesweeper/_resources/smileyuhoh.gif" ] }
[ "vocab:minesweeper/_resources/smiley.gif" ]
} cond ;
: draw-cached-texture ( path gadget -- )
textures>> [ load-image { 0 0 } <texture> ] cache
[ dim>> [ 2 /i ] map ] [ draw-scaled-texture ] bi ;
:: draw-hint ( gadget -- )
gadget hint?>> "xyzzy" sequence= [
gadget hand-rel first2 :> ( w h )
h 58 >= [
h 58 - w [ 32 /i ] bi@ :> ( row col )
gadget cells>> row col cell-at [
mined?>> COLOR: black COLOR: white ? gl-color
{ 0 0 } { 1 1 } gl-fill-rect
] when*
] when
] when ;
:: draw-mines ( n gadget -- )
gadget cells>> won? 0 n ? "%03d" sprintf [
26 * 3 + 6 2array [
digit-image-path gadget draw-cached-texture
] with-translation
] each-index ;
:: draw-smiley ( gadget -- )
gadget pref-dim first :> width
width 2/ 26 - 3 2array [
gadget cells>> [ won? ] [ lost? ] bi
hand-buttons get-global empty? not
gadget hand-click-rel [ second 58 >= ] [ f ] if* and
smiley-image-path gadget draw-cached-texture
] with-translation ;
:: draw-timer ( n gadget -- )
gadget pref-dim first :> width
n 999 min "%03d" sprintf [
3 swap - 26 * width swap - 3 - 6 2array [
digit-image-path gadget draw-cached-texture
] with-translation
] each-index ;
:: draw-cells ( gadget -- )
gadget cells>> [ won? ] [ lost? ] bi :> ( won? lost? )
gadget cells>> [| row col cell |
col row [ 32 * ] bi@ 58 + 2array [
cell won? lost? cell-image-path
gadget draw-cached-texture
] with-translation
] each-cell ;
:: elapsed-time ( gadget -- n )
gadget start>> [
gadget end>> now or swap time- duration>seconds
] [ 0 ] if* ;
M: grid-gadget handle-gesture
over {
[ key-down? ] [ sym>> length 1 = ] [ sym>> " " = not ]
} 1&& [
2dup [ sym>> first ] [ hint?>> ] bi* circular-push
] when call-next-method ;
M: grid-gadget draw-gadget*
{
[ draw-hint ]
[ cells>> #mines-remaining ]
[ draw-mines ]
[ draw-smiley ]
[ elapsed-time ]
[ draw-timer ]
[ draw-cells ]
} cleave ;
:: on-grid ( gadget quot: ( cells row col -- ? ) -- )
gadget hand-rel first2 :> ( w h )
h 58 >= [
h 58 - w [ 32 /i ] bi@ :> ( row col )
gadget cells>> :> cells
cells game-over? [
cells row col quot call [
gadget start>> [ now gadget start<< ] unless
cells game-over? [ now gadget end<< ] when
] when
] unless
] when gadget relayout-1 ; inline
:: on-click ( gadget -- )
gadget hand-rel first2 :> ( w h )
h 58 < [
h 3 55 between?
gadget pref-dim first 2/ w - abs 26 < and [
gadget [ reset-cells ] change-cells
f >>start f >>end drop
] when
] when gadget [ click-cell-at ] on-grid ;
: on-mark ( gadget -- ) [ mark-cell-at ] on-grid ;
: on-open ( gadget -- ) [ open-cell-at ] on-grid ;
: new-game ( gadget rows cols mines -- )
[ make-cells ] dip place-mines update-counts >>cells
f >>start f >>end relayout-window ;
: com-easy ( gadget -- ) 8 8 10 new-game ;
: com-medium ( gadget -- ) 16 16 40 new-game ;
: com-hard ( gadget -- ) 16 30 99 new-game ;
: com-help ( gadget -- ) drop "minesweeper" com-browse ;
grid-gadget "toolbar" f {
{ T{ key-down { sym "1" } } com-easy }
{ T{ key-down { sym "2" } } com-medium }
{ T{ key-down { sym "3" } } com-hard }
{ T{ key-down { sym "?" } } com-help }
} define-command-map
grid-gadget "gestures" [
{
{ T{ button-down { # 1 } } [ relayout-1 ] }
{ T{ button-up { # 1 } } [ on-click ] }
{ T{ button-up { # 3 } } [ on-mark ] }
{ T{ button-up { # 2 } } [ on-open ] }
{ T{ key-down { sym " " } } [ on-mark ] }
{ motion [ relayout-1 ] }
} assoc-union
] change-word-prop
TUPLE: minesweeper-gadget < track ;
: <minesweeper-gadget> ( -- gadget )
vertical minesweeper-gadget new-track
8 8 10 <grid-gadget>
[ <toolbar> format-toolbar f track-add ]
[ 1 track-add ] bi ;
M: minesweeper-gadget focusable-child* children>> second ;
MAIN-WINDOW: run-minesweeper {
{ title "Minesweeper" }
{ window-controls
{ normal-title-bar close-button minimize-button } }
} <minesweeper-gadget> >>gadgets ;