| RxChess0.0.2
| A small chess game for RetroForth.
| Written by Charles Childers and Ray St. Marie.

| chess   Open the game vocabulary.
| play    Starts the game.
| new     Resets the board pieces to first positions.
| cb      Clears the board to set one up using mv.
| mv      Moves a list of 0 or more pieces.
| oo      Castle Kingside.
| ooo     Castle Queenside.

| This is a version of crc's awesome
| RetroForth chess game.
| The number base is changed to 18 to include
| the traditional board coordinate tokens:
| Files: A thru H
| Ranks: 1 thru 8
| as an input language, being a subset of the
| Chess Algebra Notation,
| where moves are base 18 numbers...
| or base 18 numbers followed by 'chars
| ( pronounced tic-characters -- they return the
| ASCII value of the character on the stack )
| ...followed by the mv command.

| mv handles setting the en passant target square
| when pawns move into jeopardy.
| Moving a pawn into the ep-target executes en passant.
| mv handles en passant pawn taking automatically.

| mv recognizes when kings move two squares to mean a castle
| to that direction the king is moving in.
| The board moves the complimentary rook automatically.
| Or use the normal castle commands:
| oo (kingside)
| ooo (queenside).

| Soon, the enter key will do mv. ( 0.0.4 goal i think )
| Other commands are available, be sure to read the help section.

| *** RxChess ***
voc: chess
chess

| These vectors expose commands to the console user interface.
: play vector ; | "Would you like to play a game?" -- War Games voice
: new  vector ; | New board in the first position.
: cb   vector ; | Clear the board to set it up.
: mov  vector ; | Move a piece. Source*100+dest ( like: e2e4 ) on stack.
                | Does en passant and castles.
: pp   vector ; | Pawn promote/piece placement. Source*100+dest or dest
                | and in both cases a 'char on stack.
: mvs  vector ; | Does mov or does pp if stack value is a 'char.
: mv   vector ; | Moves a list of 0 or more pieces on the stack.
                | Toggles whose-move text displayed.
: oo   vector ; | Kingside castle white or black.
: ooo  vector ; | Queenside castle white or black.
: ds   vector ; | Depth of stack.
: dsa  vector ; | Turn on the dip-stick.
: help-text vector ; | Need a little help?

| Turn some RetroForth functions into numbers
13 constant d    | redefines the block editor line delete
14 constant e    | redefines the block editor on-switch
15 constant f    | redefines the false token
| convenience constants
64 constant #sqs | this because of base 18 conversion
'+ constant sq   | value of an empty square

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

| globals
variable whose-move | 0 white -1 black
variable ep-target  | sq moving pawn leaped over on first move
variable last-move  | for handleing two token moves like pawn promote
variable ds-on      | use 'dsa' to toggle on or off the
                    | depth/stack displayed with the board
                    | in the display code below

| depth of stack
  loc:
    : sp@ dup [ $f089 2, ] ;
    reset sp@ 4 / constant base
    here ] base sp@ 4 / - 1- ;
  ;loc
alias depth

| development helper tool
  :: depth . space space .s ; | depth-stack dip-stick
is ds
: dsa ds-on toggle ; | dip-stick actuator


| Create the local namespace to hide some dictionary words
| from the user and to fill those vectors above, creating
| the user interface to the board displayed on the screen.
loc:
  | this could have been mechanical but this is prettier.
  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 reset 0 whose-move ! ;
new 
docstring: new ." new sets the board in the first position" cr ;

  | functions
  | game math
  : abs dup 0 <if negate then ; | getta betta abs
  | unpacking moves
  : unroll 3 for 10 /mod next ;   | makes e2e4 into 4 e 2 e
  : unroll-dest unroll 2drop ;    | makes e2e4 into 4 e
  | positioning
  : pos a - swap 8 swap - 8 * board + + ; | board address

  | common move mechanics. storeing and fetching from board.
  : take-piece sq swap c! ;
  : start-move pos dup c@ ;
  : end-move >r take-piece pos r> swap c! ;
  : place for dup r 1- board + c! next drop ;

  | clear the board for pre-setting pieces using mv
  :: sq #sqs place ;
is cb
docstring: cb ." cb clears the board." cr
              ." use cb to clear the board and" cr
              ." use mv to set up pieces:" cr
              ." cb a8 'r b8 'n mv" cr
              ." this would do like you think" cr ;

  | test for pawn moves and en passant
  loc:
     : offend-sq swap 3 / 3 + swap pos ;
    :: last-move @ unroll-dest offend-sq take-piece ;
  ;loc is take-pawn
  | ep target
  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 'P =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 ;
     : oob     8 f 8 h end-castle ;
     : ooow    1 d 1 a end-castle ; 
     : ooob    8 d 8 a end-castle ;
     : wCastle 2 =if oow ;then ooow ;
     : bCastle 2 =if oob ;then ooob ;
    :: dup 'K and 'K =if
                last-move @ unroll swap drop - dup
                0 =if drop drop ;then
                swap dup
                1 =if drop wCastle ;then
                8 =if bCastle ;then
                drop then ;
  ;loc is test-king

  :: test-pawn test-king  ; is test-piece

   | moving
   | filter incomplete moves
   : dest-only? dup h9 <if dup 100 * + then ;
  :: dest-only? 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 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 ;

   | merge pp and mov making mvs and mv able to promote as well
  :: dup a0 <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:
     | choose the stack item at the given depth
     : pick [ $86048b 3, ] ;
     : tog-whose?
       dup 0 =if whose-move toggle ;then
       dup a0 >if whose-move toggle then ; | think this thru ****
     : tic-char? dup a0 <if last-move @ swap then ;
   :: tog-whose? depth 0;
      for r 1- pick tic-char? mvs next reset 0 last-move ! ;
  ;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 ..." cr
              ." or to place a piece on the board..." cr
              ." ...give the 'char" cr
              ." ( 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 ;
   :: clear b-18 ### --- 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
                ." this will test the board first" cr
                ." so use new to reset to first position" cr
                ." then use the move commands to play" cr
                ." type menu to see the move commands" cr
                ." type exit to quit and" cr
                ." ^ to close the chess vocabulary" cr
                ." type dsa to toggle the depth/stack display" cr ;
;loc

: sg { include save-game.txt }  ;
: ex-it exit ;
: exit decimal ex-it ;
: eds exit ds ;
: edsc exit clear ds ;
: help-text
  ." menu to get this menu" cr
  ." play to start or continue a game" cr
  ." new to play on a new board" cr cr
  ." for chess help type help or menu plus one of:" cr
  ." play new cb mv mvs pp mov oo ooo menu" cr ;
: he-lp cr exit help ;
: help he-lp help-text ;
^ | 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
| create a self documenting menu system using
| the RetroForth help system.
:: exit help ;
is menu
docstring: menu ." type menu -- calls exit." cr
                ." See a menu of game commands" cr ;
menu menu

|
| Got an idea on how to handle the empty square displayed
| on the board.
| there is a point in take-piece where the taken square is set.
| sq becomes a funtion that stores 0 or -1 to an empty square
| depending on position in the array. the a8 sq is 0 white.
| the display will show 0 as a white square |||||
| and -1 is a blank square or 5 spaces.
| the occupied square will use sq to determine how to boarder
| the peice character. Either | P | or   p  .