minesweeper autoreveal, code cleanup

This commit is contained in:
Jeremy Penner 2023-09-24 18:32:02 -04:00
parent ecddfc5b1a
commit 66dcbbdbd7
3 changed files with 81 additions and 43 deletions

View file

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

BIN
mines.com

Binary file not shown.

116
mines.jrt
View file

@ -6,8 +6,9 @@ import random.jrt
: b!+ ( v p -- ) dup b@ <rot + swap b! ; : b!+ ( v p -- ) dup b@ <rot + swap b! ;
: b!| ( f p -- ) dup b@ <rot | swap b! ; : b!| ( f 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 array board maxw maxh * allot
10 var, boardw 10 var, boardw
@ -36,12 +37,14 @@ array board maxw maxh * allot
board begin dup board-lim < while 0 over b! 1+ repeat drop ; board begin dup board-lim < while 0 over b! 1+ repeat drop ;
: populate-board : populate-board
minecount @ begin rand-mine 1- dup not until drop ; 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 -- ) : 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 >r over 1- over 1- r@ do-at
over 1- over r@ do-at over 1- over r@ do-at
over 1- over 1+ 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 over 1+ over r@ do-at
swap 1+ swap 1+ <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 : analyze-board
board begin dup board-lim < while board begin dup board-lim < while
dup square-pos analyze-pos over b@ | over b! 1+ repeat drop ; 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 -- ) : init-board ( w h minecount -- )
minecount ! boardh ! boardw ! minecount ! boardh ! boardw !
reset-board populate-board analyze-board ; 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, array countcolors white b, lblue b, lgreen b, red b, blue b,
brown b, cyan b, black b, gray 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 ; 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 -- ) : 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 -- ) : draw-hidden ( b -- )
FFLAG & if draw-flag else draw-block then ; FFLAG & if draw-flag else draw-block then ;
: draw-square ( p -- ) : 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 ) : pos>screen ( x y -- x y )
swap pagew boardw @ - 2/ + swap pagew boardw @ - 2/ +
@ -96,50 +123,61 @@ array countcolors white b, lblue b, lgreen b, red b, blue b,
: draw-row ( p -- p ) : draw-row ( p -- p )
.| begin dup draw-square .| 1+ dup square-pos drop not until next-row ; .| begin dup draw-square .| 1+ dup square-pos drop not until next-row ;
: draw-board ( -- ) : 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 board begin draw-row dup square-pos valid-pos? while draw-rowborder repeat
drop draw-board-bottom ; 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 0 const IN-PROGRESS
1 const WON 1 const WON
2 const LOST 2 const LOST
3 const QUIT 3 const QUIT
IN-PROGRESS bvar, game-state IN-PROGRESS bvar, game-state
: 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 ( -- ) : check-win ( -- )
game-state b@ IN-PROGRESS = if
0 board begin dup board-lim < while 0 board begin dup board-lim < while
dup b@ dup FMINE & swap FREVEALED & or not if swap 1+ swap then dup b@ dup FMINE & swap FREVEALED & or not if swap 1+ swap then
1+ repeat drop not if WON game-state b! then ; 1+ repeat drop not if WON game-state b! then then ;
: on-reveal ( p -- )
b@ FMINE & if LOST game-state b! else check-win then ; : reveal-unflagged-neighbours? ( p -- )
: autoreveal begin reveal-pass not until ; dup square-pos count-surrounding-flags over squarecount =
: reveal-at square-at dup reveal autoreveal on-reveal ; if square-pos ' reveal do-neighbour-squares else drop then ;
: flag-at square-at FFLAG swap b!^ ; : 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 0 bvar, cursx 0 bvar, cursy
: draw-cursor ( -- ) : draw-cursor ( -- )
1 boxstyle! blue fg! 1 boxstyle! col-curs
cursx b@ 2* boardx + textx! cursx b@ 2* boardx + textx!
cursy b@ 2* boardy + texty! cursy b@ 2* boardy + texty!
textx tl .- tr nextline textx! textx tl .- tr nextline textx!
textx .| dup 2 + textx! .| nextline textx! textx .| dup 2 + textx! .| nextline textx!
bl .- br bl .- br
0 boxstyle! white fg! ; 0 boxstyle! ;
: move-cursor ( dx dy -- ) : move-cursor ( dx dy -- )
cursy b@ + swap cursx b@ + swap 2dup valid-pos? 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 %f = if curs@ flag-at then
dup %enter = swap %space = or if curs@ reveal-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 begin game-state b@ IN-PROGRESS = while
draw-board draw-cursor await-command repeat draw-board ; draw-board draw-cursor await-command repeat draw-board ;