: cons ( L R -- T ) 2 cells allocate throw tuck cell+ ! tuck ! ;
: both ( T -- L R ) dup @ swap cell+ @ ;
: .pop ( T -- L R ) dup both rot free throw ;
: ll.show ( T -- ) ." T: " BEGIN dup WHILE both . REPEAT drop ;

\ Single instance of a FIFO: ( dummy at front, L=data, R=next )
0 0 cons ( dummy ) dup value (Q value Q]
: q.nonempty ( -- f ) (Q Q] <> ;
: q.push ( n -- ) 0 cons ( T ) dup Q] cell+ ! to Q] ;
: q.pop ( -- n ) (Q .pop nip to (Q (Q @ ;

\ p,q: game tree node; n: piece index; a: address
: parent   ( p -- a ) ;
: children ( p -- a ) cell+ ;
: c#unk    ( p -- a ) cell+ cell+ ;
: cbest    ( p -- a ) 1+  cell+ cell+ ;
    0 constant loss     1 constant draw
    2 constant win      3 constant unexpanded
: c#ply    ( p -- a ) 2 + cell+ cell+ ;
: cflag    ( p -- a ) 3 + cell+ cell+ ;
: cpiece ( p n -- a ) 2* + 4 + cell+ cell+ ;
: cplace ( p n -- a ) 2* + 5 + cell+ cell+ ;
    64 constant captured

\ c: color 0=white, 1=black; dx: castle -1=Qside, 1=Kside; v=0|1
: castl@ ( p c dx -- f ) 5 + + 1 swap lshift swap cflag c@ and ;
: castl! ( v p c dx -- ) 5 + + 1 swap lshift { f }
    cflag { v a } a c@ dup f and xor f v * or a c! ;
: ep@ ( p -- 0 | x 1 ) \ pawn eligible for capture e.p.? 1=yes
    cflag c@ dup 8 and IF 7 and 1 ELSE drop 0 THEN ;   \ x=file
: ep! { x p -- } p cflag c@ -16 and x or 8 or p cflag c! ;
: 0ep! { p -- }  p cflag c@ -16 and           p cflag c! ;

create c**    64 0 [DO] 0 c, [LOOP]
create board0 64 0 [DO] -1 , [LOOP]
: put { a u -- }
    u 3 < IF cr ." Error: need 3 chars, e.g. Pe4" cr bye THEN
    a     c@ { m }
    a 1+  c@ [Char] a - { x }
    a 2 + c@ [Char] 1 - { y }
    x y 8 * + { t } m board0 t cells + !
    u 3 > IF a 3 + c@ [Char] * = IF 1 c** t + c! THEN THEN ;
0 value Z  \ Game tree root, the initial position
0 value #pieces
: occupant { p t -- n } -1 #pieces 0 DO
    p i cplace c@ t = IF drop i LEAVE THEN LOOP ;
: (empty) { p t0 t1 -- f } -1 #pieces 0 DO p i cplace c@ { t }
    t t0 - t t1 - * 0< IF 1+ LEAVE THEN LOOP ;
: showBoard { p -- }
    cr 8 0 DO cr ."    " [Char] 1 7 i - + emit ."   "
        8 0 DO i 7 j - 8 * + { t } p t occupant { n } space
        n -1 = IF i j + 1 and IF ."  " ELSE ." -" THEN ELSE
        p n cpiece c@ emit THEN LOOP LOOP
    cr cr ."        " 8 0 DO [Char] a i + emit space LOOP ;
: t.show { p -- }
    cr p c#ply c@ . ." node " p . ." ( best = " p cbest c@ .
    ." , #unk = " p c#unk c@ . ." , castle{"
    p 0 1 castl@ IF ." K" THEN p 0 -1 castl@ IF ." Q" THEN
    p 1 1 castl@ IF ." k" THEN p 1 -1 castl@ IF ." q" THEN
    ." } " p ep@ IF ." , epx = " . THEN ." ) son of "
    p parent @ . ." , children " p children @ ll.show
    p showBoard ;
create cn 0 c, 0 c, \ save n of white king, black king
0 value bytes/record
: piece+ { n m t -- n+1 }
    m Z n cpiece c! t Z n cplace c!
    m toupper [Char] P = IF c** t + c@ IF
        t 8 /mod { x y } x Z ep! THEN THEN
    m [Char] K = IF n cn    c! THEN
    m [Char] k = IF n cn 1+ c! THEN n 1+ ;
: pure { x y m -- f }
    x y 8 * + { t } c** t + c@ IF 0 ELSE
        Z t occupant { n } Z n cpiece c@ m = THEN ;
: t.init ( c -- )
    0 64 0 DO board0 i cells + @ 0>= IF 1+ THEN LOOP to #pieces
    #pieces 2* 4 + cell+ cell+ to bytes/record
    \ cr ." t.init BEG #pieces b/r = " #pieces . bytes/record .
    bytes/record allocate throw to Z
    Z c#ply c! unexpanded Z cbest c! 0 Z c#unk c! Z 0ep!
    0 64 0 DO board0 i cells + @ dup 0< IF drop ELSE
        i piece+ THEN LOOP drop
    0 Z parent !  0 Z children !    0 Z cflag c!
    0 0 [Char] R pure 4 0 [Char] K pure * Z 0 -1 castl!
    7 0 [Char] R pure 4 0 [Char] K pure * Z 0  1 castl!
    0 7 [Char] r pure 4 7 [Char] k pure * Z 1 -1 castl!
    7 7 [Char] r pure 4 7 [Char] k pure * Z 1  1 castl! ;
: t.beget { p -- q }
    bytes/record allocate throw { q }
    p q bytes/record move   0 q children !   p q parent !
    p children @ q cons p children !
    p c#unk c@ 1+ p c#unk c!
    q c#ply c@ 1+ q c#ply c!    unexpanded q cbest c!
    0 q c#unk c!   q q.push     q 0ep!    q ;
create hit 8 allot
: hit| { x y -- } hit x + c@ 1 y lshift or hit x + c! ;
: hit& { x y -- f } hit x + c@ 1 y lshift and ;
: hit0 ( -- ) 8 0 DO 0 hit i + c! LOOP ;
: showHit ( -- ) 8 0 DO cr 8 0 DO
    i 7 j - hit& IF ." +" ELSE ." -" THEN LOOP LOOP cr ;
Defer kingOk
Defer moveOk
: color ( p n -- 0|1 ) cpiece c@ 5 rshift 1 and ; ( ascii )
: mvto { p n o t -- q }
    p n cpiece c@ toupper { m } p c#ply c@ 1 and { c } 
    m [Char] R <> IF 0 ELSE p n cplace c@ 8 /mod { x y }
        y c 7 * =  \ -1 if R on its starting rank, 0 else
        x 7 mod 0= \ -1 if R on file 0 or 7,       0 else
        x 0= 2* 1+ \ -1 if R on file 0,            1 else
        * * THEN { dx }
    p t.beget { q } t q n cplace c!
    o 0>= IF captured q o cplace c! THEN
    m [Char] K = dx  1 = or IF 0 q c  1 castl! THEN
    m [Char] K = dx -1 = or IF 0 q c -1 castl! THEN q ;
: pmvto { p n o t e -- }
    p n o t moveOk IF p n color { c } t 8 /mod { x y }
        7 c * y + 7 - IF p n o t mvto { q } e IF x q ep! THEN
        ELSE ( prom ) 4 0 DO s" QRBN" drop i + c@ 32 c * + { m }
            p n o t mvto { q } m q n cpiece c!
            \ cr ." =============>>>>>>>>>> ENQUEUED" q t.show
        LOOP THEN THEN ;
: mvdir { dx dy p n h -- }
    p n cpiece c@ toupper { m }
    p n cplace c@ 8 /mod { x y }
    m [Char] K = m [Char] N = or IF 2 ELSE 8 THEN 1 DO
        x dx i * + y dy i * + { x' y' }
        x' -8 and y' -8 and or IF LEAVE THEN
        x' y' 8 * + { t } p t occupant { o }
        o 0< IF -1 ELSE p n color p o color <> THEN IF
            h IF x' y' hit| ELSE
                p n o t moveOk IF p n o t mvto { q }
                \ cr ." ===========>>>>>>>>> ENQUEUED" q t.show
            THEN THEN THEN
        o 0>= IF LEAVE THEN LOOP ;
: unmoved { p n -- f } p n cplace c@ 8 /mod { x y }
    p n color { c } y 1- c 5 * = ;
: mpawn { p n h -- } p n cplace c@ 8 /mod { x y }
    p n color -2 * 1+ { dy }
    2 0 DO x i 2* 1- + { x' }
        -8 x' and 0= IF y dy + { y' }
            h IF x' y' hit| ELSE x' y' 8 * + { t }
                p t occupant { o }
                o 0>= IF p n color p o color <> IF
                    p n o t 0 pmvto THEN THEN THEN THEN LOOP
    h 0= IF 
        y dy + -8 and 0= IF x y dy + 8 * + { t1 }
            p t1 occupant 0< IF
                p n -1 t1 0 pmvto
                p n unmoved IF x y dy + dy + 8 * + { t2 }
                    p t2 occupant 0< IF
                        p n -1 t2 -1 pmvto THEN THEN THEN THEN
        p ep@ IF { epx } 4 p n color - { epy }
            x epx - abs 1 = IF y epy = IF epx epy 8 * + { t }
                p t occupant { o } p n o t 0 pmvto
                    THEN THEN THEN THEN ;
: +mvs -1  0   0 -1   0  1   1  0 ;
: xmvs -1 -1  -1  1   1 -1   1  1 ;
: Lmvs -2 -1  -2  1  -1 -2  -1  2   1 -2   1  2   2 -1   2  1 ;
: mvpiece { p n h -- } p n cpiece c@ toupper { m }
    m [Char] P = IF p n h mpawn ELSE
    m [Char] N = IF Lmvs 8 0 DO p n h mvdir LOOP ELSE
    m [Char] B <> IF +mvs 4 0 DO p n h mvdir LOOP THEN
    m [Char] R <> IF xmvs 4 0 DO p n h mvdir LOOP THEN
    THEN THEN ;
: mvcastle { p c dx -- }
    p c dx castl@ IF c 7 * { y }
        4 y 8 * + { t0 } dx 1+ 2/ 7 * y 8 * + { tR }
        p t0 tR (empty) IF
            p kingOk IF t0 dx + { t1 } cn c + c@ { nK }
                t1 p nK cplace c!
                p kingOk IF t1 dx + { t2 }
                    t2 p nK cplace c!
                    p kingOk IF
                        p tR occupant { n }
                        t1 p n cplace c!
                        p t.beget { q }
                        0 q c  1 castl!
                        0 q c -1 castl!
                        \ cr ." =======>>>>> ENQUEUED" q t.show
                        tR p n cplace c! THEN THEN
                t0 p nK cplace c! THEN THEN THEN ;
\ h=0: add successors to tree; h=1: check moveOk (turn +1)
: successors { p h -- } p c#ply c@ h + 1 and { c }
    #pieces 0 DO p i color c = IF p i cplace c@ captured <> IF
        p i h mvpiece THEN THEN LOOP
    h 0= IF p c -1 mvcastle p c 1 mvcastle THEN ;
:noname { p -- f } hit0     p 1 successors
    p c#ply c@ 1 and { c } cn c + c@ { nK }
    p nK cplace c@ 8 /mod hit& 0= ;
IS kingOk
:noname { p n o t -- f } p n cplace c@ { s }
    t p n cplace c!     o 0>= IF captured p o cplace c! THEN
    p kingOk
    s p n cplace c!     o 0>= IF t        p o cplace c! THEN ;
IS moveOk
: decided { p -- f } p cbest c@ { b } p c#unk c@ { u }
    b win =     u 0=   or   b unexpanded <> and ;
: isBest { q -- f } q decided
    q parent @ cbest c@ q cbest c@ + 2 = and ;
: showSquare ( t -- ) 8 /mod { x y } 
    x [Char] a + emit y [Char] 1 + emit ;
: moved { t0 t1 -- f } t0 t1 <> t1 captured <> and ;
: whoMoved { q -- n } q parent @ { p }
    -1 #pieces 0 DO p i cplace c@ q i cplace c@ moved IF
        drop i THEN LOOP ;
: #men { p n -- # } p n cpiece c@ { m } 0 #pieces 0 DO
    p i cpiece c@ m = p i cplace c@ captured <> * + LOOP ;
: showMove { q -- } q whoMoved { n } q n cplace c@ { t }
    q n cpiece c@ toupper { m } q parent @ { p }
    p n cpiece c@ toupper { m0 } p n cplace c@ { t0 }
    cr p c#ply c@ 7 * 0 ?DO space LOOP
    t0 8 /mod drop t 8 /mod drop - { dx }
    m [Char] K = dx  2 = and IF ."   o-o  " ELSE
    m [Char] K = dx -2 = and IF ."  o-o-o " ELSE
    m0 [Char] P <> IF m0 emit
        p n #men 1 > IF t0 showSquare THEN THEN
    p t occupant { o } o 0>= n o <> and IF
        m0 [Char] P = IF t0 8 /mod drop
        [Char] a + emit THEN ." x" THEN t showSquare
    m0 [Char] P = IF m [Char] P <> IF ." =" m emit THEN THEN
        space THEN THEN ;
: showLine { p -- } p children @
    BEGIN dup WHILE both ( L q ) dup isBest IF
        dup showMove recurse ELSE drop THEN REPEAT drop ;
0 value max#ply
: announce { -- } Z cbest c@ { b }
    b 0< 2 b < or IF cr ." Error: out of range" cr bye THEN
    cr cr ." >>> " b loss = IF ." LOSS" ELSE b draw = IF
        ." DRAW" ELSE b win = IF ." WIN" THEN THEN THEN
    ."  <<< " cr max#ply 0 ?DO i 2 mod IF ." ...    " ELSE
        space i 2/ 1 + 0 <# # #> type ." .    " THEN LOOP
    Z showLine
    cr bye ;
: tell { p v -- }
    p 0= IF announce ELSE
    p decided IF ELSE
    p c#unk c@ 1- p c#unk c!
    p cbest c@ 2 v - max p cbest c!
    p decided IF p parent @ p cbest c@ recurse THEN THEN THEN ;
: expand ( q -- f ) parent @ { p }
    p IF p decided 0= ELSE -1 THEN ;
0 value #pop    10000 constant nodes/.
: solve ( c -- ) t.init Z t.show
    cr cr ." Ply # reported every " nodes/. . ." nodes"
    cr ." Computing " Z q.push BEGIN q.nonempty WHILE
        q.pop { p } #pop nodes/. mod 0= IF p c#ply c@ . THEN
        #pop 1+ to #pop     max#ply p c#ply c@ max to max#ply
        p expand IF
            loss p cbest c!
            p 0 successors
            p decided IF \ could just test #unk == 0
                p children @ 0= IF p kingOk -1 * p cbest c! THEN
                p parent @ p cbest c@ tell THEN THEN REPEAT ;
: whiteToMove 0 solve ;
: blackToMove 1 solve ;

\ USAGE EXAMPLE:
\ s" ke5" put
\ s" Kd3" put
\ s" Qf7" put
\ s" Nc7" put
\ whiteToMove ( or blackToMove )
\
\ File must be lowercase. Lowercase piece: black. Uppercase
\ piece: white. There must be exactly one king of each color.
\
\ En passant: pawns in the given position are assumed
\ ineligible to be captured en passant. You can declare a
\ pawn eligible to be captured en passant by adding "*" to
\ the square name. For example, s" Pd4*" is a white pawn on
\ d4 eligible to be captured en passant.
\
\ Castling: if a king-rook pair are on their original squares
\ in the initial position, they are assumed to be eligible to
\ castle. If they are not on their original squares, they are
\ assumed ineligible to castle. If a rook happens to be on its
\ original square, but is ineligible to castle, you can
\ indicate this by adding "*" to the square name. Adding "*"
\ to a king's square name means the king is uneligible to
\ castle to either side.