better board drawing, more minesweeper

mines.jrt

@@ -58,26 +58,39 @@ array board maxw maxh * allot
   minecount ! boardh ! boardw !
   reset-board populate-board analyze-board ;
 
+array countcolors white b, lblue b, lgreen b, red b, blue b, 
+  brown b, cyan b, black b, gray b,
+
 : draw-neighbours ( b -- )
-  NEIGHBOUR-MASK & [ key 0 lit ] + draw-char ;
+  NEIGHBOUR-MASK & dup countcolors + b@ fg! 
-: draw-flag ( -- ) [ key ! lit ] draw-char ;
+  dup if [ key 0 lit ] + else drop [ key   lit ] then draw-char ;
-: draw-mine ( -- ) 0x0f draw-char ;
+: draw-flag ( -- ) red fg! 0xb2 draw-char ;
-: draw-block ( -- ) 0xb1 draw-char ;
+: draw-mine ( -- ) black fg! 0x0f draw-char ;
+: draw-block ( -- ) black fg! 0xb1 draw-char ;
 : draw-revealed ( b -- )
   dup FMINE & if draw-mine drop else draw-neighbours 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 ;
+  b@ dup FREVEALED & if draw-revealed else draw-hidden then white fg! ;
 
 : pos>screen ( x y -- x y )
   swap pagew boardw @ - 2/ +
   swap pageh boardh @ - 2/ + ;
 
+: boardx! ( -- ) pagew boardw @ 2* 1+ - 2/ textx! ;
+: boardy! ( -- ) pageh boardh @ 2* 1+ - 2/ texty! ;
+: next-row ( -- ) nextline boardx! ;
+
+: draw-board-top tl boardw @ begin .- 1- dup while dT repeat tr drop next-row ;
+: draw-board-bottom bl boardw @ begin .- 1- dup while uT repeat br drop next-row ;
+: draw-rowborder rT boardw @ begin .- 1- dup while .+ repeat lT drop next-row ;
+: draw-row ( p -- p )
+  .| begin dup draw-square .| 1+ dup square-pos drop not until next-row ;
 : draw-board ( -- )
-  board begin dup board-lim < while 
+  white fg! lgray bg! boardx! boardy! draw-board-top
-    dup square-pos pos>screen textxy!
+  board begin draw-row dup square-pos valid-pos? while draw-rowborder repeat
-    dup draw-square 1+ repeat drop ;
+  drop draw-board-bottom ;
 
 0 var, reveal-state
 : reveal ( p -- ) dup b@ FREVEALED | swap b! ;
@@ -92,8 +105,21 @@ array board maxw maxh * allot
       reveal-state b@ if dup reveal then then
     1+ repeat drop reveal-state @ ;
 
-: reveal-all begin reveal-pass not until ;
+0 const IN-PROGRESS
-: reveal-at square-at reveal ( reveal-all ) draw-board ;
+1 const WON
+2 const LOST
+IN-PROGRESS var, game-state
+
+: check-win ( -- )
+  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 ! then ;
+
+: on-reveal ( p -- )
+  b@ FMINE & if LOST game-state ! else check-win then ;
+: autoreveal begin reveal-pass not until ;
+: reveal-at square-at dup reveal autoreveal on-reveal draw-board ;
+: flag-at square-at dup b@ FFLAG | swap b! draw-board ;
 
 : start
   textmode
@@ -101,3 +127,6 @@ array board maxw maxh * allot
   15 10 15 init-board
   draw-board ;
 
+' start ' main redefine
+
+{ s" mines.com" writecom }

text.jrt

@@ -137,12 +137,19 @@ var boxstyle
 : vchar vstyle if 0xba else 0xb3 then ;
 : hline ( count -- ) hchar draw-hrepeat ;
 : vline ( count -- ) vchar draw-vrepeat ;
+: .- hchar draw-char ;
+: .| vchar draw-char ;
 
 { : :corner CREATE >t >t >t >t DOES} boxstyle @ 0x03 & + b@ draw-char ;
 0xc9 0xd6 0xd5 0xda :corner tl
 0xbb 0xb7 0xb8 0xbf :corner tr
 0xc8 0xd3 0xd4 0xc0 :corner bl
 0xbc 0xbd 0xbe 0xd9 :corner br
+0xb9 0xb6 0xb5 0xb4 :corner lT
+0xcc 0xc7 0xc6 0xc3 :corner rT
+0xca 0xd0 0xcf 0xc1 :corner uT
+0xcb 0xd2 0xd1 0xc2 :corner dT
+0xce 0xd7 0xd8 0xc5 :corner .+
 
 : boxtop ( w -- ) textx swap tl 2 - hline tr nextline textx! ;
 : boxbottom ( w -- ) bl 2 - hline br ;