211 lines
6.5 KiB
Plaintext
Executable file
211 lines
6.5 KiB
Plaintext
Executable file
import text.jrt
|
|
import keys.jrt
|
|
import random.jrt
|
|
|
|
: !+ ( v p -- ) dup @ <rot + swap ! ;
|
|
: 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 12 const maxh
|
|
array board maxw maxh * allot
|
|
|
|
10 var, boardw
|
|
10 var, boardh
|
|
15 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 -- ) 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 ;
|
|
|
|
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 ! ;
|
|
( 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 ( -- ) 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-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 ;
|
|
|
|
: pos>screen ( x y -- x y )
|
|
swap pagew boardw @ - 2/ +
|
|
swap pageh boardh @ - 2/ + ;
|
|
: 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 ( -- )
|
|
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 const IN-PROGRESS
|
|
1 const WON
|
|
2 const LOST
|
|
3 const QUIT
|
|
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 ( -- )
|
|
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! 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! ;
|
|
|
|
: 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 QUIT game-state b! 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 ;
|
|
|
|
: play IN-PROGRESS game-state b!
|
|
begin game-state b@ IN-PROGRESS = while
|
|
draw-board draw-cursor await-command repeat draw-board ;
|
|
|
|
: start
|
|
textmode
|
|
reseed!
|
|
20 12 30 init-board
|
|
play ;
|
|
|
|
' start ' main redefine
|
|
|
|
{ s" mines.com" writecom }
|