dbg" start"

: 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 ;

: reset-board
  board begin dup board-lim < while 0 over b! 1+ repeat drop ;
: populate-board
  minecount @ begin rand-mine 1- dup not until drop ;
: mine? ( p -- f )       b@ FMINE & ;
: flag? ( p -- f )       b@ FFLAG & ;
: revealed? ( p -- f )   b@ FREVEALED & ;
: squarecount ( p -- c ) b@ NEIGHBOUR-MASK & ;

: do-at ( x y cp -- )
  >rot 2dup valid-pos? if square-at swap execute else drop drop drop then ;
: do-neighbour-squares ( x y cp -- )
  >r over 1- over 1- r@ do-at
     over 1- over    r@ do-at
     over 1- over 1+ r@ do-at
     over    over 1- r@ do-at
     over    over 1+ r@ do-at
     over 1+ over 1- r@ do-at
     over 1+ over    r@ do-at
     swap 1+ swap 1+ <r do-at ;

var neighbour-count
var neighbour-check

: count-neighbour neighbour-check @ execute if 1 neighbour-count !+ then ;
: count-neighbours ( x y cp -- c ) neighbour-check ! 0 neighbour-count ! 
  ' count-neighbour do-neighbour-squares neighbour-count @ ;

: analyze-pos ( x y -- n ) ' mine? count-neighbours ;
: analyze-board
  board begin dup board-lim < while 
    dup square-pos analyze-pos over b@ | over b! 1+ repeat drop ;

: count-surrounding-flags ( x y -- n ) ' flag? count-neighbours ;

: init-board ( -- )
  reset-board populate-board analyze-board ;

: lose LOST game-state b!
  board begin dup board-lim < while FREVEALED over b!| 1+ repeat drop ;

: 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 ( p -- p )
  dup visibly-empty? over backtrack-square backtrack? and
  if backtrack-square 1- then ;
: autoreveal ( -- )
  board begin dup board-lim < while
    dup revealed? not if
      dup square-pos ' visibly-empty? count-neighbours
      if dup reveal autoreveal-backtrack then then
    1+ repeat drop ;

: check-win ( -- )
  in-progress? if
    0 board begin dup board-lim < while
      dup b@ dup FMINE & swap FREVEALED & or not if swap 1+ swap then
      1+ repeat drop not if WON game-state b! then then ;

: reveal-unflagged-neighbours? ( p -- )
  dup square-pos count-surrounding-flags over squarecount =
  if click square-pos ' reveal do-neighbour-squares 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 [ key 0 lit ] + else drop [ key   lit ] then draw-char ;
: 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 @ begin .- 1- dup while over execute repeat drop 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 -- p )
  .| begin dup draw-square .| 1+ dup square-pos drop not until next-row ;
: draw-board ( -- ) 0 boxstyle!
  col-grid col-bg boardx! boardy! draw-board-top
  board begin draw-row dup square-pos valid-pos? while draw-rowborder repeat
  drop 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 -- )
  begin dup b@ dup while draw-char dup spacer 1+ repeat drop drop ;

( 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 begin dup menu-size < while
    dup draw-selection dup draw-option 1+ nextline over textx! repeat 
  drop drop ;

: 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
  <r current-menu ! <r menu-selected! ;

{ :timm defitem ( cp name iopt -- ) menu-option dup >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 }