dbg" start" : digit ( n -- ) [ key 0 lit ] + draw-char ; : meep 2000 5 -80 slide ; : meeeep 2000 16 -50 slide ; : moop 1600 5 80 slide ; : boom 40 noise ; : click 2000 3 boop 4000 3 boop ; 0 const IN-PROGRESS 1 const CANCEL 2 const WON 3 const LOST 4 const QUIT IN-PROGRESS bvar, game-state : leave CANCEL game-state b! ; : enter IN-PROGRESS game-state b! ; : in-progress? game-state b@ IN-PROGRESS = ; : cancelled? game-state b@ CANCEL = ; : uncancel cancelled? if enter then ; ( minesweeper board model ) dbg" minesweeper board model" 30 const maxw 12 const maxh array board maxw maxh * allot 20 var, boardw 12 var, boardh 30 var, minecount : board-lim boardw @ boardh @ * board + ; : square-at ( x y -- p ) boardw @ * + board + ; : square-pos ( p -- x y ) board - boardw @ /mod swap ; : valid-pos? ( x y -- f ) dup 0 >= swap boardh @ < and swap dup 0 >= swap boardw @ < and and ; 0x80 const FMINE 0x40 const FREVEALED 0x20 const FFLAG 0x0F const NEIGHBOUR-MASK : place-mine ( x y -- f ) square-at dup b@ FMINE & not if FMINE swap b! 0 then not ; : rand-mine ( -- ) begin rand boardw @ % rand boardh @ % place-mine until ; : iterboard board board-lim for ; : iterrows board board-lim boardw @ for+ ; : lastrow? ( p -- f ) board-lim boardw @ - >= ; : reset-board iterboard each 0 i b! next ; : populate-board minecount @ times each rand-mine next ; : mine? ( p -- f ) b@ FMINE & ; : flag? ( p -- f ) b@ FFLAG & ; : revealed? ( p -- f ) b@ FREVEALED & ; : squarecount ( p -- c ) b@ NEIGHBOUR-MASK & ; :yield yield2 >i >i :| idrop idrop ' noop _resume |; _suspend ; : 8-neighbours ( x y -- ) >arg >arg (( over 1- over 1- yield2 over 1- over yield2 over 1- over 1+ yield2 over over 1- yield2 over over 1+ yield2 over 1+ over 1- yield2 over 1+ over yield2 -arg -arg swap 1+ swap 1+ yield2 )) ; : neighbours ( p -- ) square-pos 8-neighbours (( each i j valid-pos? if i j square-at map then next )) ; : count-neighbours ( p cp -- n ) >r neighbours 0 each i r@ execute if 1+ then next rdrop ; : analyze-square ( p -- n ) ' mine? count-neighbours ; : analyze-board iterboard each i analyze-square i b!| next ; : count-surrounding-flags ( p -- n ) ' flag? count-neighbours ; : init-board ( -- ) reset-board populate-board analyze-board ; : lose LOST game-state b! iterboard each FREVEALED i b!| next ; : reveal ( p -- ) dup flag? not if dup mine? if lose then FREVEALED swap b!| else drop then ; : visibly-empty? dup revealed? swap squarecount not and ; : backtrack-square ( p -- p ) boardw @ - 1- dup board < if drop board then ; : backtrack? ( p -- f ) dup revealed? over 1+ revealed? and swap 2 + revealed? and not ; : autoreveal-backtrack ( -- ) i visibly-empty? i backtrack-square backtrack? and if i backtrack-square 1- idrop >i then ; : autoreveal ( -- ) iterboard each i revealed? not if i ' visibly-empty? count-neighbours if i reveal autoreveal-backtrack then then next ; : won? ( -- f ) 1 iterboard each i b@ FMINE FREVEALED | & not if not break then next ; : check-win ( -- ) in-progress? if won? if WON game-state b! then then ; : reveal-unflagged-neighbours? ( p -- ) dup count-surrounding-flags over squarecount = if click neighbours each i reveal next else drop then ; : reveal-at square-at dup revealed? if reveal-unflagged-neighbours? else reveal click then autoreveal check-win ; : flag-noise ( p -- ) b@ FFLAG & if moop else meep then ; : flag-at square-at dup revealed? not if FFLAG swap dup flag-noise b!^ else drop then ; ( theming ) dbg" theming" array countcolors white b, lblue b, lgreen b, red b, blue b, brown b, cyan b, black b, gray b, var theme : colvar theme @ + b@ ; : col-bg 0 colvar bg! ; : col-flag 1 colvar fg! ; : col-mine 2 colvar fg! ; : col-block 3 colvar fg! ; : col-grid 4 colvar fg! ; : col-curs 5 colvar fg! ; : col-count ( c -- ) countcolors + b@ dup 0 colvar = if drop col-grid else fg! then ; { :timm deftheme CREATE >t >t >t >t >t >t DOES} theme !save ; ( cursor grid block mine flag bg ) blue white black magenta red lgray deftheme win31 white yellow black lmagenta yellow red deftheme hotdog yellow lgray cyan lmagenta yellow blue deftheme borland magenta lgray magenta magenta magenta cyan deftheme cga4 win31 ( minesweeper board drawing ) dbg" board drawing" : draw-neighbour-count ( b -- ) NEIGHBOUR-MASK & dup col-count dup if digit else drop [ key lit ] draw-char then ; : draw-flag ( -- ) col-flag 0x0d draw-char ; : draw-mine ( -- ) col-mine 0xec draw-char ; : draw-block ( -- ) col-block 0xb1 draw-char ; : draw-revealed ( b -- ) dup FMINE & if draw-mine drop else draw-neighbour-count then ; : draw-hidden ( b -- ) FFLAG & if draw-flag else draw-block then ; : draw-square ( p -- ) b@ dup FREVEALED & if draw-revealed else draw-hidden then col-grid ; : boardx ( -- x ) pagew boardw @ 2* 1+ - 2/ ; : boardy ( -- y ) pageh boardh @ 2* 1+ - 2/ ; : boardx! ( -- ) boardx textx! ; : boardy! ( -- ) boardy texty! ; : next-row ( -- ) nextline boardx! ; : draw-border ( end mid -- ) boardw @ times each .- i if dup execute then next drop execute next-row ; : draw-board-top tl ' tr ' dT draw-border ; : draw-board-bottom bl ' br ' uT draw-border ; : draw-rowborder rT ' lT ' .+ draw-border ; : draw-row ( p -- ) .| boardw @ times each dup draw-square 1+ .| next drop next-row ; : draw-board ( -- ) 0 boxstyle! col-grid col-bg boardx! boardy! draw-board-top iterrows each i draw-row i lastrow? not if draw-rowborder then next draw-board-bottom ; ( general-purpose drawing ) dbg" general-purpose drawing" : clear [ key lit ] fill-page ; : emptych? ( ch -- f ) dup 32 = swap 0 = or ; : drawdot? ( st -- f ) dup b@ emptych? swap 1+ b@ emptych? or not ; : dot 7 draw-char ; : sp 32 draw-char ; : spacer ( st -- ) sp drawdot? if dot else sp then sp ; : draw-spaced-text ( st -- ) pchars each i b@ draw-char i spacer next ; ( menu subsystem ) dbg" menu" 2 cells const menu-optsize var current-menu : menu-options current-menu @ cell + 1+ ; : menu-size current-menu @ cell + b@ ; : init-menu current-menu @ @ execute ; : menu-option ( iopt -- p ) menu-optsize * menu-options + ; 0 var, menu-selected : menu-activate menu-selected @ menu-option cell + @ execute ; : menu-selected! ( i -- ) dup 0 >= over menu-size < and if menu-selected ! else drop then ; : menu-selected+! ( di -- ) menu-selected @ + menu-selected! ; : draw-selection ( iopt -- ) menu-selected @ = if draw-mine else sp then sp ; : draw-option ( iopt -- ) white fg! menu-option @ draw-text ; : draw-menu 30 9 textxy! textx 0 menu-size for each i draw-selection i draw-option nextline dup textx! next ; : await-menu wait-key key>scan dup %esc = if leave then dup %up = if -1 menu-selected+! then dup %down = if 1 menu-selected+! then %enter = if menu-activate init-menu then ; : run-menu enter init-menu begin draw-menu await-menu in-progress? not until uncancel ; { :timm defmenu ( itemcount cpinit -- ) CREATE target current-menu !t w>t dup >t menu-optsize * ALLOT DOES} menu-selected @ >r current-menu @ >r current-menu ! 0 menu-selected! run-menu rot !t cell + !t ; } ( minesweeper game UI ) dbg" game ui" 0 bvar, cursx 0 bvar, cursy : draw-cursor ( -- ) 1 boxstyle! col-curs cursx b@ 2* boardx + textx! cursy b@ 2* boardy + texty! textx tl .- tr nextline textx! textx .| dup 2 + textx! .| nextline textx! bl .- br ; : move-cursor ( dx dy -- ) cursy b@ + swap cursx b@ + swap 2dup valid-pos? if cursy b! cursx b! else drop drop then ; : curs@ cursx b@ cursy b@ ; 0x21 const %f : await-command wait-key key>scan dup %esc = if leave then dup %left = if -1 0 move-cursor then dup %right = if 1 0 move-cursor then dup %up = if 0 -1 move-cursor then dup %down = if 0 1 move-cursor then dup %f = if curs@ flag-at then dup %enter = swap %space = or if curs@ reveal-at then ; : popupbox ( h -- ) 20 8 textxy! 0 hstyle! 1 vstyle! 39 swap filled draw-box ; : result-message ( st x -- ) 5 popupbox ( x ) 10 textxy! draw-spaced-text wait-key drop ; : beat 10 sleep-csec ; : fanfare meep beat moop beat meep beat moop beat meep beat meep beat meeeep ; : display-result game-state b@ dup WON = if fanfare green bg! lcyan fg! s" YOU WON" 26 result-message then LOST = if boom red bg! yellow fg! s" YOU LOST" 25 result-message then ; 2 :noname blue bg! lgray fg! 4 popupbox ; defmenu quitmenu ' leave s" Return to game" 0 defitem :noname QUIT game-state b! ; s" Quit to title" 1 defitem : confirm-quit cancelled? if quitmenu col-bg clear then ; : draw-game draw-board draw-cursor ; : play enter col-bg clear begin draw-game await-command confirm-quit in-progress? not until draw-board display-result enter ; : start init-board boardw @ 2/ cursx b! boardh @ 2/ cursy b! play ; ( title menu ) dbg" title" array title-text t", SWINE MEEPER" 5 :noname col-bg clear ; defmenu theme-menu ' win31 s" 3.11 for Worksties" 0 defitem ' hotdog s" Pork Sausage Stand" 1 defitem ' borland s" Boarland Turbohog" 2 defitem ' cga4 s" Sowlo Jazz" 3 defitem ' leave s" Done" 4 defitem 20 12 30 minecount ! boardh ! boardw ! : config-game ( boardw boardh minecount -- ) minecount !save boardh !save boardw !save leave ; 3 :noname red bg! clear ; defmenu difficulty-menu :noname 10 10 10 config-game ; s" Easy ( 10x10, 10 truffles )" 0 defitem :noname 20 12 30 config-game ; s" Moderate ( 20x12, 30 truffles )" 1 defitem :noname 30 12 60 config-game ; s" Hard ( 30x12, 60 truffles )" 2 defitem : draw-title blue bg! yellow fg! clear 17 3 textxy! title-text draw-spaced-text ; 4 ' draw-title defmenu title-menu ' start s" Start Game" 0 defitem ' difficulty-menu s" Difficulty" 1 defitem ' theme-menu s" Themes" 2 defitem ' leave s" Quit" 3 defitem ' main :chain textmode reseed! hidecursor title-menu textmode ; dbg" saving" { s" swine.com" writecom }