| Chess game
| RxChess
| A small chess game for RetroForth 
| Written by Charles Childers and Ray St. Marie.
 
| chess                open the vocabulary
| play                 starts the game
| new                  resets the board
| e2e4 mv              moves a list of 0 or more pieces
| **** Now mv does everything  ****
| This is a version of crc's awesome chess game.
| This bashes base to include the natural board coordinate
| input language as a subset of the Chess Algebra Notation, 
| where moves are base 18 numbers or 'characters followed
| followed by the 'mv' command. 
| Soon, the enter key will do all of this.
| 

| teh code
include modules\help.data  | create a self documenting menu system using help

voc: chess
chess
: play vector ; | play a game | in the war games voice
: new  vector ; | new board in the first position
: mov  vector ; | move a piece does en passant automatically
: pp   vector ; | pawn promote
: mvs  vector ; | does either mov or pp depending on the stack value
: mv   vector ; | moves a list of pieces
: oo   vector ; | kingside castle white or black
: ooo  vector ; | queenside castle white or black
: ds   vector ; | depth stack
variable ds-on  | use 'dsa' to turn on or off the ds
                | displayed with the board

| Turn some RetroForth functions into numbers
13 constant d    | this redefines the editor line delete
14 constant e    | this redefines the editor on-switch
15 constant f    | this redefines the f false
64 constant #sqs | this because of base 18 conversion

| extend the numbers to include the 
| Chess Algebra board co-ords subset
| 0 thru H
: b-18 18 !base ; 
b-18

| globals ...basically
variable whose-move | 0 white -1 black
variable ep-target
variable last-move

| game logic

  | depth
  loc:
    : sp@ dup [ $f089 2, ] ;
    reset sp@ 4 / constant base
    here ] base sp@ 4 / - 1- ;
  ;loc 
alias depth ( empty stack || n's -- n's and || count )

  | development helper tool
  :: depth . cr .s ; | depth-stack dip-stick
is ds 

loc:
  '+ constant sq
  create first-position
  |    A     B     C     D     E     F     G     H
    'r 1, 'n 1, 'b 1, 'q 1, 'k 1, 'b 1, 'n 1, 'r 1, | 8
    'p 1, 'p 1, 'p 1, 'p 1, 'p 1, 'p 1, 'p 1, 'p 1, | 7
    sq 1, sq 1, sq 1, sq 1, sq 1, sq 1, sq 1, sq 1, | 6
    sq 1, sq 1, sq 1, sq 1, sq 1, sq 1, sq 1, sq 1, | 5
    sq 1, sq 1, sq 1, sq 1, sq 1, sq 1, sq 1, sq 1, | 4
    sq 1, sq 1, sq 1, sq 1, sq 1, sq 1, sq 1, sq 1, | 3
    'P 1, 'P 1, 'P 1, 'P 1, 'P 1, 'P 1, 'P 1, 'P 1, | 2
    'R 1, 'N 1, 'B 1, 'Q 1, 'K 1, 'B 1, 'N 1, 'R 1, | 1
  | board
  create board #sqs allot
  here is new ] first-position board #sqs move ;
new ( -- )
docstring: new ." new -- sets the board in the first position" cr ;

  | functions
  | game math
  : abs dup 0 <if negate then ; 
  | positioning
  : pos ( rank file -- board-adr ) 
      a - swap 8 swap - 8 * board + + ; | base18 a = decimal 10

  | unpacking moves
  : unroll 3 for 10 /mod next ;   | makes e2e4 into 4 e 2 e
  : unroll-dest 100 mod 10 /mod ; | makes e2e4 into 4 e

  | common move mechanics
  : take-piece sq swap c! ;
  : start-move pos dup c@ ;
  : end-move >r take-piece pos r> swap c! ;

  | test pawn moves and ep
  | en passant-ing
  loc:
     : offend-sq swap 3 / 3 + swap pos ;  | black 4 white 5
    :: @last-move unroll-dest offend-sq take-piece ; 
  ;loc 
is take-pawn 

  loc:
     : correct-for-side swap 4 -  3 *  3 +  swap ;
     : ep-target-set @last-move unroll-dest correct-for-side 10 * + 
!ep-target ;
    :: @last-move unroll drop swap drop - abs 2
                =if ep-target-set -1 ;then 0 ;
  ;loc
is moving-two?

  :: dup 'P and 48 =if moving-two? if;
     @last-move unroll-dest 10 * + @ep-target 0 !ep-target
     =if take-pawn ;then then ;
is test-pawn

  | test King moves
  | castles
  loc:
     : end-castle start-move end-move ;
     : oow 1 f 1 h end-castle ; 
     : ooow  1 d 1 a end-castle ; 
     : oob  8 f 8 h end-castle ;
     : ooob  8 d 8 a end-castle ;
     : wCastle 2 =if oow ;then ooow ;
     : bCastle 2 =if oob ;then ooob ;
    :: dup 'K and 43 =if 
       @last-move unroll swap drop - swap 1
       =if wCastle ;then bCastle 
       then ;
  ;loc
is test-king

  :: test-king test-pawn  ;
is test-piece
  
  | moving
  :: dup !last-move unroll start-move test-piece end-move ;
is mov 
docstring: mov ." mov ( base18n -- ) makes one peice move" cr
               ." from source to destination."  cr
               ." For pawns this automatically handles en passant." cr
               ." example: e2e4 mov" cr ;
  | promoting
  :: swap dup mov unroll-dest pos c! ;
is pp 
docstring: pp ." pp ( base18n 'character -- )" cr 
              ." move and promote to 'character" cr 
              ." example: e7d8 'Q pp" cr 
              ." Can also be used to place a piece" cr
              ." anywhere on the board" cr
              ." example: e5e5 'Q pp puts a Queen at E5" cr 
              ." note: you must give both source and destination" cr
              ."       even if they are both the same: e2e2 'P pp" cr ;

  | merge pp and mov making mvs and mv able to promote as well
  :: dup a1 <if pp ;then mov ;
is mvs
docstring: mvs ." mvs does either mov or pp." cr
               ." See both commands for more" cr 
               ." depending on whether a move" cr
               ." or a pawn promote is required" cr ;

  | moving a list of moves
  loc:
     : pick [ $86048b 3, ] ; | choose the stack item at the given depth
     : pre-move dup 0 =if whose-move toggle then
       dup a1 <if swap dup h9 <if dup 100 * + then swap then
       dup a0 >if whose-move toggle then ; | think this thru ****
   :: pre-move depth 0; 
      for r 1- pick dup a1 <if @last-move swap then mvs next reset ; 
  ;loc 
is mv 
docstring: mv ." mv ( list of 0 or more moves -- ) multiple mv" cr
              ." example: e2e4 e7e5 g1f3 g8f6 mv" cr 
              ." toggles whose-move" cr
              ." to promote pawn or..." cr
              ." to place a piece on the board..." cr
              ." ...give the 'char ( example: 'Q for white Queen )" cr
              ." example: e4 'Q mv" cr ;

   | Castleing commands
   : calc-rank @whose-move 7 * abs 1+ dup 100 * + ;
  :: calc-rank e0g0 + mv ;  | e1g1 e8g8
is oo
docstring: oo ." oo does a castle Kingside" cr
              ." white or black depends on whose move" cr ;
  :: calc-rank e0c0 + mv ; | e1c1 e8c8
is ooo 
docstring: ooo ." ooo does a castle Queenside" cr
               ." white or black depends on whose move" cr ;

  | displaying
  loc:
    8 variable: line
    variable endNum
    : .line @line dup dup !endNum 1- !line . ;
    : #|...| .line '| emit space later '| emit space @endNum . ;
    : ### ."      a  b  c  d  e  f  g  h"   cr ;
    : --- ."   +-------------------------+" cr ;
    : .whose-move @whose-move if ." Black's move" space 
                           ;then ." White's move" space ;
    : row #|...| 8 for space dup c@ emit space 1+ next ;
    : show 8 for row cr cr next drop ;
   :: b-18 clear ### --- cr board show --- ### .whose-move cr 8 !line 
      @ds-on 0; drop ds ; | dip-stick dsa turns on or off
  ;loc is display
 :: ~display { is ui } display ; 
is play ( -- )
docstring: play ." type play to start the board" cr
                ." then use the move commands to play" cr
                ." type menu to see the move commands" cr
                ." type exit to quit and ^ to close the chess 
vocabulary" cr ;
;loc

: dsa ds-on toggle ; | dip-stick actuator
: ex-it exit ;
: exit decimal ex-it ;
: eds exit ds ;
: edsc exit clear ds ;
^ | end the chess vocabulary

| current testing, type new to play,
| type exit ^ clear to quit 
chess play              | open vocab, call display
e2e4 mov                | test mov
e7e5 g1f3 g8f6 mv       | test mvs
b2b5 c7c5 b5c6 mv       | test ep white
g7g4 h2h4 g4h3 mv       | test ep black
f1b5 f8b4 mv oo oo      | test castles
e5d1 'q mv              | test pawn promote
a5 'K mv                | test placing a piece

| menu
: help-text 
  ." menu to get this menu" cr
  ." play to start or continue a game" cr 
  ." new to play on a new board" cr
  ." for chess help type help or menu plus one of:" cr
  ." mov pp mvs mv oo ooo menu play new" cr ;

:: exit help-text help ; 
is menu
docstring: menu ." type menu -- calls exit. See a menu of game commands" 
cr ;
menu menu