Upload files to ''

main
mian 2 years ago
parent 079d9d2fe9
commit 23c9956080
  1. 203
      minesweeper.fs

@ -0,0 +1,203 @@
\ A minesweeper clone for the terminal
10 constant nmines
10 constant field-width
10 constant field-height
field-width field-height * constant nplaces
42 constant mine
48 constant empty
256 constant hidden
create mfield nplaces cells allot
variable cursorx
variable cursory
variable digs-left
variable rstate
utime drop 65521 mod rstate !
: rand0 \ -- rn
rstate @ 33285 * 65521 mod dup rstate !
;
: nr-place \ -- rn
rand0 nplaces mod
;
: not invert ;
: empty-field \ --
empty hidden or
nplaces 0 do
dup mfield i cells + !
loop
drop
;
: put-mine \ np --
mine hidden or mfield rot cells + ! ;
: vrange \ n nmax -- mnax1 nmin1
dup 2 + field-height min
swap 1- 0 max
;
: hrange \ n nmax -- mnax1 nmin1
dup 2 + field-width min
swap 1- 0 max
;
: mark-mine \ nplace --
dup field-width /
vrange do
dup field-width mod
hrange do
mfield j field-width * i + cells + dup @
hidden not and mine =
not if 1 swap +! else drop then
loop
loop
drop
;
: check-mine \ np -- f
cells mfield + @ hidden not and mine =
;
: mine-field \ --
empty-field
nmines
begin
nr-place dup
check-mine
if drop
else dup put-mine mark-mine 1-
then
dup 0=
until
drop
nplaces nmines - digs-left !
;
: field-header \ --
page 2 spaces
field-width 0
do space i 10 mod 48 + emit
loop
cr
;
: first-col \ i --
dup field-width mod 0=
if field-width / 10 mod .
else drop
then
;
: space-cursor \ i --
field-width /mod
cursory @ = if
dup cursorx @ = if ." (" else
dup cursorx @ 1+ = if ." )" else
space
then then drop
else space drop
then
;
: cr-cursor \ i --
field-width /mod
cursory @ = swap
cursorx @ = and
if ." )"
then
cr
;
: end-line \ i --
dup 1+ field-width mod 0 =
if cr-cursor
else drop
then
;
: show-field \ freveal --
field-header
nplaces 0 do
i first-col
i space-cursor
mfield i cells + @
over if hidden not and emit
else dup hidden and
if drop ." ." else emit then
then
i end-line
loop
drop
;
: field-adr \ nx ny -- af
field-width * + cells mfield + ;
: current-adr \ -- af
cursorx @ cursory @ field-adr ;
: dig \ --
current-adr @ dup
hidden and
if
hidden not and current-adr !
-1 digs-left +!
else drop
then
;
: move-up \ --
cursory @ 1- 0 max cursory ! ;
: move-left \ --
cursorx @ 1- 0 max cursorx ! ;
: move-down \ --
cursory @ 1+ field-height 1- min cursory ! ;
: move-right \ --
cursorx @ 1+ field-width 1- min cursorx ! ;
: on-mine? \ -- f
current-adr @ mine = ;
: play \ --
." Press any key!"
key rstate !
mine-field
field-width 1- 2 / cursorx !
field-height 1- 2 / cursory !
begin
false show-field
." " digs-left @ . ." places left to dig" cr
." Use H(left),J(down), K(up), L(right) to move,"
." D to dig and Q to quit."
false
key dup emit
dup [char] k = if move-up else
dup [char] h = if move-left else
dup [char] j = if move-down else
dup [char] l = if move-right else
dup [char] d = if dig else
dup [char] q = if nip true swap then
then then then then then drop
on-mine?
if true show-field ." You lose!" cr
drop true
else
digs-left @ 0 =
if true show-field ." You win!" cr drop true
then
then
until
;
play
Loading…
Cancel
Save