dialer/mines.jrt

import text.jrt
import random.jrt

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 curr-mine-count @ 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! ( -- ) pagew boardw @ 2* 1+ - 2/ textx! ;
: boardy! ( -- ) pageh boardh @ 2* 1+ - 2/ texty! ;
: next-row ( -- ) nextline boardx! ;

: draw-board-top tl boardw @ begin .- 1- dup while dT repeat tr drop next-row ;
: draw-board-bottom bl boardw @ begin .- 1- dup while uT repeat br drop next-row ;
: draw-rowborder rT boardw @ begin .- 1- dup while .+ repeat lT drop next-row ;
: 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 -- ) dup b@ 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
IN-PROGRESS var, 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 ! then ;

: on-reveal ( p -- )
  b@ FMINE & if LOST game-state ! else check-win then ;
: autoreveal begin reveal-pass not until ;
: reveal-at square-at dup reveal autoreveal on-reveal draw-board ;
: flag-at square-at dup b@ FFLAG | swap b! draw-board ;

: start
  textmode
  reseed!
  15 10 15 init-board
  draw-board ;

' start ' main redefine

{ s" mines.com" writecom }