SpindleyQ/dialer
1
1
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

minesweeper autoreveal, code cleanup

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

2
keys.jrt
View file

@ -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

BIN
mines.com
View file

Binary file not shown.

122
mines.jrt
View file

@ -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 )
square-at b@ FMINE & ;
: 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 <rot execute else drop drop drop then ;
: do-at-neighbours ( 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
@ -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
: count-mine-at ( x y -- ) mine-at? if 1 curr-mine-count !+ then ;
: analyze-pos ( x y -- n )
0 curr-mine-count ! ' count-mine-at do-at-neighbours curr-mine-count @ ;
var neighbour-count
var neighbour-check
: 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 -- )
NEIGHBOUR-MASK & dup countcolors + b@ fg!
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 ! ;
( 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-mine ( -- ) black fg! 0x0f draw-char ;
: draw-block ( -- ) black fg! 0xb1 draw-char ;
: draw-flag ( -- ) col-flag 0x0d draw-char ;
: draw-mine ( -- ) col-mine 0x0f 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 ( -- )
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 ;
: lose LOST game-state b!
board begin dup board-lim < while FREVEALED over b!| 1+ repeat drop ;
: on-reveal ( p -- )
b@ FMINE & if LOST game-state b! else check-win then ;
: autoreveal begin reveal-pass not until ;
: reveal-at square-at dup reveal autoreveal on-reveal ;
: flag-at square-at FFLAG swap b!^ ;
: 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 ( -- )
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 ;