\ reversi-board 17/12/98 10:30 am vassilii
\ Some common FORTH idioms
\ board drawing words (no field memo)
\ field array and accessors
: beep ; \ signal invalid move
: page 1001 ShowForm ;
: 3drop drop 2drop ;
: 3dup dup 2over rot ;
: 4dup 2over 2over ;
: 4drop 2drop 2drop ;
: 5drop 3drop 2drop ;
: ? @ . ;
: >= < invert ;
: 1+! 1 swap +! ;
: -! swap negate swap +! ;
: 0! 0 swap ! ;
: 2= >r rot = swap r> = and ;
: 2<> 2= invert ;
: 2, , , ;

14 constant cell-width
8 constant side
: grid \ grid-width -- grid-width
dup 1+ 0 do
	i over  i 0  line
	dup i  0 i  line
	cell-width +loop ;
: 1-8 \ grid-width -- grid-width
dup 2 +  3 \ grid-width x y
[ char 1 dup side + swap ] 2literal do
	dup currentY !
	over currentX !
	i emit
	cell-width + 
loop 2drop ;
: a-h \ grid-width -- grid-width
 dup 1+ currentY !  6
[ char a dup side + swap ] 2literal do
	dup currentX !
	i emit
	cell-width + 
loop drop ;

0 constant none
1 constant black
2 constant white
: other [ black white + ] literal swap - ;
: .color ( b/w -- )
black = if ." black" else ." white" then ;
: place ( col lin color -- )
dup none = if 3drop exit then
>r [ cell-width 2/ ] literal >r
cell-width * r@ +
swap cell-width * r> +
[ cell-width 3 8 */ ] literal -rot
r> black = if pcircle else circle then ;

: board-cells ; inline
here side dup * board-cells allot constant field
: pos> ( col lin -- a ) side * +
board-cells field + ;
: field@ ( col lin -- color ) pos> c@ ;
: field! ( color col lin -- ) pos> c! ;

: legal \ col lin -- ; mark legal ply poss.
cell-width *
[ cell-width 2/ ] literal +
swap cell-width * 
[ cell-width 2/ ] literal +
1 -rot circle ;