dialer/mines.jrt

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! ;

30 const maxw 16 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-at? ( x y -- f ) 
  square-at b@ FMINE & ;

: do-at ( x y cp -- )
  >rot 2dup valid-pos? if <rot execute else drop drop drop then ;
: do-at-neighbours ( 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 ;

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 @ ;
: analyze-board
  board begin dup board-lim < while 
    dup square-pos analyze-pos over b@ | over b! 1+ repeat drop ;

: 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,

: draw-neighbours ( b -- )
  NEIGHBOUR-MASK & dup countcolors + b@ fg! 
  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-revealed ( b -- )
  dup FMINE & if draw-mine drop else draw-neighbours 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! ;

: 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 ( -- )
  white fg! lgray 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 ;

: 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!^ ;

0 bvar, cursx 0 bvar, cursy

: draw-cursor ( -- )
  1 boxstyle! blue fg!
  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! ;

: 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
  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 }