\ reversi 17/12/98 10:30 am vassilii
include graphics
include tap
include reversi-board
include reversi-turn

: center->XY
[ cell-width 2 / cx ] 2literal @ +
currentX ! 
cy @ [ cell-width 3 8 */ ]  literal - 
currentY ! ;
: board page
cell-width side * ( grid-width )
grid a-h 1-8 ( grid-width ) drop 
side 0 do
 side 0 do
	i j 2dup field@ place
loop loop
[ 9 2 ] 2literal black place
center->XY black-stones ?
[ 9 5 ] 2literal white place
center->XY white-stones ? 
mark-last ;
here \ dx dy
	-1 -1 2,	 0 -1 2,	1 -1 2,
	-1  0 2,	 		1 0 2,
	-1  1 2,	 0  1 2,	1  1 2,
here over - 4 / constant nDeltas
constant Deltas

: pos+delta ( c l dx dy -- c' l' )
rot + -rot + swap ;

: out-board? ( c l -- ? )
2dup 0< swap 0< or
-rot side >= swap side >= or
or ;
variable ray-flips
: ray-bounded? ( c l dx dy -- ? )
ray-flips 0!
turn @ other >r 2swap
begin 	\ r: other-color
	\ delta. prev-pos.
	2over pos+delta 
	\ delta. cur-pos.
	2dup out-board? if
		r> 5drop false exit
	then
	2dup field@ r@ = while
		ray-flips 1+! repeat
2swap 2drop field@ r> other = ;
variable move-flips variable no-flip
: ray-process ( col lin dx dy -- col lin )
4dup ray-bounded? invert 
if 2drop exit then
ray-flips @ move-flips +!
no-flip @ if 2drop exit then
2over turn @ >r
begin 
\ orig-pos. delta. prev-pos.
\ r: my-color
	2over pos+delta
	2dup field@ r@ <> while
		2dup r@ -rot field!
	repeat
r> drop 4drop ;
: move-record@ ( a -- col lin b/w )
dup 2@ rot 4 + @ ;
: move-record! ( col lin b/w a -- )
tuck 4 + ! 2! ;
: move-records 6 * ;
here side dup * 4 - 1+
move-records allot
\ 1 extra for invalid last attempts
constant protocol
variable next-record
: 8rays \ col lin -- col lin flips
move-flips 0!
Deltas \ col lin a
[ nDeltas 0 ] 2literal do
	>r r@ 2@ ( col lin dx dy )
	ray-process
	r> 4 +
loop drop
move-flips @ ;
: ply (  col lin b/w -- valid?)
3dup next-record @ move-record!
\ do not advance until known valid
>r 2dup r> -rot
2dup out-board? if
	5drop false exit then
2dup field@ none <> if
	5drop false exit then
field! [ false no-flip ] 2literal !
8rays
0= if none -rot field! false
else black-stones white-stones
	2swap field@
	white = if swap then
	move-flips @ tuck
	swap -!
	1+ 
	swap +! true
	[ 1 move-records next-record ]
	2literal +!
then ;
: count-moves \ -- #moves ; needs turn set
0
[ true no-flip ] 2literal !
[ side 0 ] 2literal do
	[ side 0 ] 2literal do ( n )
		j i field@ none = if
			j i 8rays ( n j i flips )
			if legal 1+
			else 2drop then
		then loop loop ;
: no-moves? count-moves 0= ;
: prompt board cr [ 124 currentY ]
2literal ! ." Tap: move; Other: break" 
cr ;
: pass turn @ other turn ! ;
: new [ protocol next-record ]
2literal !	2x2 prompt ;
: pt>cell ( y x -- c l )
cell-width / swap cell-width / ;
: declare-result
black-stones @ white-stones @ -
?dup if
	0< if white else black then
	.color ."  wins!"
else ." draw..." then
abort ;
: go begin
  begin
    no-moves? if
      pass no-moves? if declare-result
      else turn @ other 
	cr .color ."  passes" then
      then
    tap 0= if exit then \ Move canceled
    pt>cell 2swap pt>cell ( cell1 cell2 )
    2over 2<> while 2drop repeat
\ tap until press cell == release c.
  2dup 
  turn @ ply 
  if 
    last-lin ! last-col ! 
    pass prompt
  else \ invalid move
    2drop beep
  then again ;
: plyed  black-stones @
white-stones @ + 4 - ;
: replay-next-record
next-record  @ move-record@
>r 2dup last2! r@
ply 0= abort" junk ply recorded"
r> other turn ! ;
: same-start ( #plys -- #plys #todo)
dup begin ( #plys #todo)
  dup while
	cr [ 124 currentY ] 2literal !
	plyed . [char] / emit over .
	." DOWN: next, other: replay now!"
	key 12 <> if exit then
	no-moves? if pass
	else 
		replay-next-record
		1-
	then board repeat ;
: replay plyed new
same-start ( #plys #todo)
2drop prompt ." O.K., now move!" go ;
new go