diff --git a/keys.jrt b/keys.jrt index ecf62f0..615b01b 100755 --- a/keys.jrt +++ b/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 diff --git a/mines.com b/mines.com index bf79fb2..4f94445 100755 Binary files a/mines.com and b/mines.com differ diff --git a/mines.jrt b/mines.jrt index 821d466..757253e 100755 --- a/mines.jrt +++ b/mines.jrt @@ -6,8 +6,9 @@ import random.jrt : b!+ ( v p -- ) dup b@ rot 2dup valid-pos? if 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+ 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 ;