\ Rock/Paper/Scissors

.( Set victory conditions for a match:) cr
.( 	# play-to \ default 10.) cr
.( 	# win-by \ default 0) cr
.( 	# best-of \ alternative to play-to) cr
.( Optionally set player names:) cr
.( 	1 player-name" Jim") cr
.( 	2 player-name" Richard P. Detwiler III") cr
.( Then play the game:) cr
.( 	rock scissors play) cr
.( 	scissors paper play) cr
.( 	...) cr
.( 	bye \ exit) cr
.( 	forth \ go back to forth) cr cr

marker remove-rps

\ Uncomment to run the tests (somewhat gforth-specific)
\ include test/ttester.fs
\ : => -> ;  \ I find this more readable.


( Miscellany )

: lstring, ( c-addr u -- )
	chars here  over cell+ allot
	2dup !  cell+ swap move ;

: add-wordlist ( wid -- )  >r get-order r> swap 1+ set-order ;

\ this holds the game interface words
wordlist constant *rps  *rps add-wordlist


( Basic Game Logic )

get-current *rps set-current
	0 constant rock
	1 constant paper
	2 constant scissors
set-current
3 constant #choices

\ does choice1 beat choice2?
: beats? ( choice1 choice2 -- flag )  1+ #choices mod = ;

[defined] testing [if]
	testing that paper covers rock smashes scissors cuts paper.
	T{ paper rock beats? => true }T
	T{ rock scissors beats? => true }T
	T{ scissors paper beats? => true }T

	testing ties.
	T{ rock rock beats? => false }T
	T{ paper paper beats? => false }T
	T{ scissors scissors beats? => false }T

	testing losing combinations.
	T{ rock paper beats? => false }T
	T{ scissors rock beats? => false }T
	T{ paper scissors beats? => false }T
[then]


( Player numbering )

\ 0 = nobody
\ 1 = player 1
\ 2 = player 2

: other-player ( player -- player' )  2 swap - 1+ ;

[defined] testing [if]
	testing player numbering.
	T{ 1 other-player => 2 }T
	T{ 2 other-player => 1 }T
[then]

: winner ( choice1 choice2 -- winner )
	2dup beats? 1 and >r
	swap beats? 2 and r> or ;

[defined] testing [if]
	testing choice of winner.

	T{ rock rock winner => 0 }T
	T{ rock paper winner => 2 }T
	T{ rock scissors winner => 1 }T

	T{ paper rock winner => 1 }T
	T{ paper paper winner => 0 }T
	T{ paper scissors winner => 2 }T

	T{ scissors rock winner => 2 }T
	T{ scissors paper winner => 1 }T
	T{ scissors scissors winner => 0 }T
[then]


( Player Names )

create player-names 4 cells allot  \ pointers to cell-counted strings
: player-name ( u -- addr )  cells player-names + ;
: .player ( u -- )  player-name @ dup cell+ swap @ type space ;
: player-name" ( u "...<quote>" -- )
	[char] " parse align here >r lstring, r> swap player-name ! ;

\ defaults
0 player-name" Nobody"
1 player-name" Player 1"
2 player-name" Player 2"
3 player-name" Both players"


( Scoring )


create scores here 3 cells dup allot erase  \ ties, player 1, player 2
: score ( u -- addr )  cells scores + ;
: update-scores ( winner -- )  score 1 swap +! ;
: clear-scores ( -- )  scores 3 cells erase ;


( Victory Conditions )

variable limit  10 limit !
variable margin  0 margin !

: lead ( player -- n )  dup score @ swap other-player score @ - ;

: reached-limit? ( player -- flag )  score @ limit @ >= ;
: ahead-by-margin? ( player -- flag )  lead margin @ >= ;
: won? ( player -- flag )
	dup reached-limit? swap ahead-by-margin? and ;

: match-winner ( -- winner )
	1 won? 1 and
	2 won? 2 and or ; 

get-current *rps set-current
	: play-to ( u -- )  limit !  0 margin ! ;
	: best-of ( u -- )  1+ 2/ play-to ;
	: win-by ( u -- )  margin ! ;
set-current


( Play the Game )

: .round ( winner -- )
	cr ?dup if
		.player ." wins this round!"
	else
		." No winner this round."
	then cr ;
: .match ( player -- )  cr .player ." won the match!" cr ;

get-current *rps set-current
	: play ( choice1 choice2 -- )
		winner dup .round update-scores
		match-winner ?dup if .match clear-scores then ;
	\ Quit (or go back to forth).
	: bye bye ;
	: forth forth-wordlist dup *rps 2 set-order set-current ;
set-current

*rps 1 set-order