minesweeper autoreveal, code cleanup

keys.jrt

@@ -27,7 +27,7 @@
 0x39 const %space
 0x3a const %capslock
 0x3b const %f1
-: %f %f1 + ;
+: %func %f1 1- + ;
 0x47 const %home
 0x49 const %pgup
 0x4f const %end

mines.jrt

@@ -6,8 +6,9 @@ import random.jrt
 : b!+ ( v p -- ) dup b@ <rot + swap b! ;
 : b!| ( f p -- ) dup b@ <rot | swap b! ;
 : b!^ ( f p -- ) dup b@ <rot ^ swap b! ;
+: ~ 0xffff ^ ;
 
-30 const maxw 16 const maxh
+30 const maxw 12 const maxh
 array board maxw maxh * allot
 
 10 var, boardw 
@@ -36,12 +37,14 @@ array board maxw maxh * allot
   board begin dup board-lim < while 0 over b! 1+ repeat drop ;
 : populate-board
   minecount @ begin rand-mine 1- dup not until drop ;
-: mine-at? ( x y -- f ) 
+: mine? ( p -- f )       b@ FMINE & ;
-  square-at 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 <rot execute else drop drop drop then ;
+  >rot 2dup valid-pos? if square-at swap execute else drop drop drop then ;
-: do-at-neighbours ( x y cp -- )
+: 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
@@ -51,14 +54,20 @@ array board maxw maxh * allot
      over 1+ over    r@ do-at
      swap 1+ swap 1+ <r do-at ;
 
-0 var, curr-mine-count
+var neighbour-count
-: count-mine-at ( x y -- ) mine-at? if 1 curr-mine-count !+ then ;
+var neighbour-check
-: analyze-pos ( x y -- n )
+
-  0 curr-mine-count ! ' count-mine-at do-at-neighbours curr-mine-count @ ;
+: count-neighbour neighbour-check @ execute if 1 neighbour-count !+ then ;
+: count-neighbours ( x y cp -- ) 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 ( w h minecount -- )
   minecount ! boardh ! boardw !
   reset-board populate-board analyze-board ;
@@ -66,18 +75,36 @@ array board maxw maxh * allot
 array countcolors white b, lblue b, lgreen b, red b, blue b, 
   brown b, cyan b, black b, gray b,
 
-: draw-neighbours ( b -- )
+var theme
-  NEIGHBOUR-MASK & dup countcolors + b@ fg! 
+: 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 ! ;
+( cursor   grid  block   mine   flag     bg )
+    blue  white  black  black    red  lgray deftheme win31
+   white yellow  black  black yellow    red deftheme hotdog
+
+win31
+
+: draw-neighbour-count ( b -- )
+  NEIGHBOUR-MASK & dup col-count 
   dup if [ key 0 lit ] + else drop [ key   lit ] then draw-char ;
-: draw-flag ( -- ) red fg! 0xb2 draw-char ;
+: draw-flag ( -- ) col-flag 0x0d draw-char ;
-: draw-mine ( -- ) black fg! 0x0f draw-char ;
+: draw-mine ( -- ) col-mine 0x0f draw-char ;
-: draw-block ( -- ) black fg! 0xb1 draw-char ;
+: draw-block ( -- ) col-block 0xb1 draw-char ;
 : draw-revealed ( b -- )
-  dup FMINE & if draw-mine drop else draw-neighbours then ;
+  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 white fg! ;
+  b@ dup FREVEALED & if draw-revealed else draw-hidden then col-grid ;
 
 : pos>screen ( x y -- x y )
   swap pagew boardw @ - 2/ +
@@ -96,50 +123,61 @@ array countcolors white b, lblue b, lgreen b, red b, blue b,
 : draw-row ( p -- p )
   .| begin dup draw-square .| 1+ dup square-pos drop not until next-row ;
 : draw-board ( -- )
-  white fg! lgray bg! boardx! boardy! draw-board-top
+  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 ;
 
-0 var, reveal-state
-: reveal ( p -- ) FREVEALED swap b!| ;
-: reveal-square? ( x y -- )
-  square-at b@ FREVEALED = if -1 reveal-state ! then ;
-: reveal-pass ( -- f )
-  0 reveal-state !
-  board begin dup board-lim < while
-    dup b@ FREVEALED & not if
-      0 reveal-state b!
-      dup square-pos ' reveal-square? do-at-neighbours 
-      reveal-state b@ if dup reveal then then
-    1+ repeat drop reveal-state @ ;
-
 0 const IN-PROGRESS
 1 const WON
 2 const LOST
 3 const QUIT
 IN-PROGRESS bvar, game-state
 
-: check-win ( -- )
+: lose LOST game-state b!
-  0 board begin dup board-lim < while
+  board begin dup board-lim < while FREVEALED over b!| 1+ repeat drop ;
-    dup b@ dup FMINE & swap FREVEALED & or not if swap 1+ swap then
-    1+ repeat drop not if WON game-state b! then ;
 
-: on-reveal ( p -- )
+: reveal ( p -- ) dup flag? not if 
-  b@ FMINE & if LOST game-state b! else check-win then ;
+    dup mine? if lose then FREVEALED swap b!| 
-: autoreveal begin reveal-pass not until ;
+  else drop then  ;
-: reveal-at square-at dup reveal autoreveal on-reveal ;
+
-: flag-at square-at FFLAG swap b!^ ;
+: 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 ( -- )
+  game-state b@ 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 square-pos ' reveal do-neighbour-squares else drop then ;
+: reveal-at square-at dup revealed? 
+  if reveal-unflagged-neighbours? else reveal then autoreveal check-win ;
+: flag-at square-at dup revealed? not if FFLAG swap b!^ else drop then ;
 
 0 bvar, cursx 0 bvar, cursy
 
 : draw-cursor ( -- )
-  1 boxstyle! blue fg!
+  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
-  0 boxstyle! white fg! ;
+  0 boxstyle! ;
 
 : move-cursor ( dx dy -- )
   cursy b@ + swap cursx b@ + swap 2dup valid-pos? 
@@ -157,7 +195,7 @@ IN-PROGRESS bvar, game-state
   dup %f     = if curs@ flag-at then
   dup %enter = swap %space = or if curs@ reveal-at then ;
 
-: play
+: play IN-PROGRESS game-state b!
   begin game-state b@ IN-PROGRESS = while 
   draw-board draw-cursor await-command repeat draw-board ;