Chess player/PicoLisp
< Chess player(Redirected from Chess/PicoLisp)
This implementation supports all chess rules (including castling, pawn promotion and en passant), switching sides, unlimited undo/redo, and the setup, saving and loading of board positions to/from files. <lang PicoLisp># *Board a1 .. h8
- *White *Black *WKPos *BKPos *Pinned
- *Depth *Moved *Undo *Redo *Me *You
(load "@lib/simul.l")
- Fields/Board ###
- x y color piece whAtt blAtt
(setq *Board (grid 8 8))
(for (X . Lst) *Board
(for (Y . This) Lst
(=: x X)
(=: y Y)
(=: color (not (bit? 1 (+ X Y)))) ) )
(de *Straight `west `east `south `north)
(de *Diagonal
((This) (: 0 1 1 0 -1 1)) # Southwest ((This) (: 0 1 1 0 -1 -1)) # Northwest ((This) (: 0 1 -1 0 -1 1)) # Southeast ((This) (: 0 1 -1 0 -1 -1)) ) # Northeast
(de *DiaStraight
((This) (: 0 1 1 0 -1 1 0 -1 1)) # South Southwest ((This) (: 0 1 1 0 -1 1 0 1 1)) # West Southwest ((This) (: 0 1 1 0 -1 -1 0 1 1)) # West Northwest ((This) (: 0 1 1 0 -1 -1 0 -1 -1)) # North Northwest ((This) (: 0 1 -1 0 -1 -1 0 -1 -1)) # North Northeast ((This) (: 0 1 -1 0 -1 -1 0 1 -1)) # East Northeast ((This) (: 0 1 -1 0 -1 1 0 1 -1)) # East Southeast ((This) (: 0 1 -1 0 -1 1 0 -1 1)) ) # South Southeast
- Pieces ###
(de piece (Typ Cnt Fld)
(prog1
(def
(pack (mapcar '((Cls) (cdr (chop Cls))) Typ))
Typ )
(init> @ Cnt Fld) ) )
(class +White)
- color ahead
(dm init> (Cnt Fld)
(=: ahead north) (extra Cnt Fld) )
(dm name> ()
(pack " " (extra) " ") )
(dm move> (Fld)
(adjMove '*White '*WKPos whAtt- whAtt+) )
(class +Black)
- color ahead
(dm init> (Cnt Fld)
(=: color T) (=: ahead south) (extra Cnt Fld) )
(dm name> ()
(pack '< (extra) '>) )
(dm move> (Fld)
(adjMove '*Black '*BKPos blAtt- blAtt+) )
(class +piece)
- cnt field attacks
(dm init> (Cnt Fld)
(=: cnt Cnt) (move> This Fld) )
(dm ctl> ())
(class +King +piece)
(dm name> () 'K)
(dm val> () 120)
(dm ctl> ()
(unless (=0 (: cnt)) -10) )
(dm moves> ()
(make
(unless
(or
(n0 (: cnt))
(get (: field) (if (: color) 'whAtt 'blAtt)) )
(tryCastle west T)
(tryCastle east) )
(try1Move *Straight)
(try1Move *Diagonal) ) )
(dm attacks> ()
(make
(try1Attack *Straight)
(try1Attack *Diagonal) ) )
(class +Castled)
(dm ctl> () 30)
(class +Queen +piece)
(dm name> () 'Q)
(dm val> () 90)
(dm moves> ()
(make
(tryMoves *Straight)
(tryMoves *Diagonal) ) )
(dm attacks> ()
(make
(tryAttacks *Straight)
(tryAttacks *Diagonal T) ) )
(class +Rook +piece)
(dm name> () 'R)
(dm val> () 47)
(dm moves> ()
(make (tryMoves *Straight)) )
(dm attacks> ()
(make (tryAttacks *Straight)) )
(class +Bishop +piece)
(dm name> () 'B)
(dm val> () 33)
(dm ctl> ()
(when (=0 (: cnt)) -10) )
(dm moves> ()
(make (tryMoves *Diagonal)) )
(dm attacks> ()
(make (tryAttacks *Diagonal T)) )
(class +Knight +piece)
(dm name> () 'N)
(dm val> () 28)
(dm ctl> ()
(when (=0 (: cnt)) -10) )
(dm moves> ()
(make (try1Move *DiaStraight)) )
(dm attacks> ()
(make (try1Attack *DiaStraight)) )
(class +Pawn +piece)
(dm name> () 'P)
(dm val> () 10)
(dm moves> ()
(let (Fld1 ((: ahead) (: field)) Fld2 ((: ahead) Fld1))
(make
(and
(tryPawnMove Fld1 Fld2)
(=0 (: cnt))
(tryPawnMove Fld2 T) )
(tryPawnCapt (west Fld1) Fld2 (west (: field)))
(tryPawnCapt (east Fld1) Fld2 (east (: field))) ) ) )
(dm attacks> ()
(let Fld ((: ahead) (: field))
(make
(and (west Fld) (link @))
(and (east Fld) (link @)) ) ) )
- Move Logic ###
(de inCheck (Color)
(if Color (get *BKPos 'whAtt) (get *WKPos 'blAtt)) )
(de whAtt+ (This Pce)
(=: whAtt (cons Pce (: whAtt))) )
(de whAtt- (This Pce)
(=: whAtt (delq Pce (: whAtt))) )
(de blAtt+ (This Pce)
(=: blAtt (cons Pce (: blAtt))) )
(de blAtt- (This Pce)
(=: blAtt (delq Pce (: blAtt))) )
(de adjMove (Var KPos Att- Att+)
(let (W (: field whAtt) B (: field blAtt))
(when (: field)
(put @ 'piece NIL)
(for F (: attacks) (Att- F This)) )
(nond
(Fld (set Var (delq This (val Var))))
((: field) (push Var This)) )
(ifn (=: field Fld)
(=: attacks)
(put Fld 'piece This)
(and (isa '+King This) (set KPos Fld))
(for F (=: attacks (attacks> This)) (Att+ F This)) )
(reAtttack W (: field whAtt) B (: field blAtt)) ) )
(de reAtttack (W W2 B B2)
(for This W
(unless (memq This W2)
(for F (: attacks) (whAtt- F This))
(for F (=: attacks (attacks> This)) (whAtt+ F This)) ) )
(for This W2
(for F (: attacks) (whAtt- F This))
(for F (=: attacks (attacks> This)) (whAtt+ F This)) )
(for This B
(unless (memq This B2)
(for F (: attacks) (blAtt- F This))
(for F (=: attacks (attacks> This)) (blAtt+ F This)) ) )
(for This B2
(for F (: attacks) (blAtt- F This))
(for F (=: attacks (attacks> This)) (blAtt+ F This)) ) )
(de try1Move (Lst)
(for Dir Lst
(let? Fld (Dir (: field))
(ifn (get Fld 'piece)
(link (list This (cons This Fld)))
(unless (== (: color) (get @ 'color))
(link
(list This
(cons (get Fld 'piece))
(cons This Fld) ) ) ) ) ) ) )
(de try1Attack (Lst)
(for Dir Lst
(and (Dir (: field)) (link @)) ) )
(de tryMoves (Lst)
(for Dir Lst
(let Fld (: field)
(loop
(NIL (setq Fld (Dir Fld)))
(T (get Fld 'piece)
(unless (== (: color) (get @ 'color))
(link
(list This
(cons (get Fld 'piece))
(cons This Fld) ) ) ) )
(link (list This (cons This Fld))) ) ) ) )
(de tryAttacks (Lst Diag)
(use (Pce Cls Fld2)
(for Dir Lst
(let Fld (: field)
(loop
(NIL (setq Fld (Dir Fld)))
(link Fld)
(T
(and
(setq Pce (get Fld 'piece))
(<> (: color) (get Pce 'color)) ) )
(T (== '+Pawn (setq Cls (last (type Pce))))
(and
Diag
(setq Fld2 (Dir Fld))
(= (get Fld2 'y) (get ((get Pce 'ahead) Fld) 'y))
(link Fld2) ) )
(T (memq Cls '(+Knight +Queen +King)))
(T (and Pce (xor Diag (== Cls '+Bishop)))) ) ) ) ) )
(de tryPawnMove (Fld Flg)
(unless (get Fld 'piece)
(if Flg
(link (list This (cons This Fld)))
(for Cls '(+Queen +Knight +Rook +Bishop)
(link
(list This
(cons This)
(cons
(piece (list (car (type This)) Cls) (: cnt))
Fld ) ) ) ) ) ) )
(de tryPawnCapt (Fld1 Flg Fld2)
(if (get Fld1 'piece)
(unless (== (: color) (get @ 'color))
(if Flg
(link
(list This
(cons (get Fld1 'piece))
(cons This Fld1) ) )
(for Cls '(+Queen +Knight +Rook +Bishop)
(link
(list This
(cons (get Fld1 'piece))
(cons This)
(cons
(piece (list (car (type This)) Cls) (: cnt))
Fld1 ) ) ) ) ) )
(let? Pce (get Fld2 'piece)
(and
(== Pce (car *Moved))
(= 1 (get Pce 'cnt))
(isa '+Pawn Pce)
(n== (: color) (get Pce 'color))
(link (list This (cons Pce) (cons This Fld1))) ) ) ) )
(de tryCastle (Dir Long)
(use (Fld1 Fld2 Fld Pce)
(or
(get (setq Fld1 (Dir (: field))) 'piece)
(get Fld1 (if (: color) 'whAtt 'blAtt))
(get (setq Fld2 (Dir Fld1) Fld Fld2) 'piece)
(when Long
(or
(get (setq Fld (Dir Fld)) 'piece)
(get Fld (if (: color) 'whAtt 'blAtt)) ) )
(and
(== '+Rook (last (type (setq Pce (get (Dir Fld) 'piece)))))
(=0 (get Pce 'cnt))
(link
(list This
(cons This)
(cons
(piece (cons (car (type This)) '(+Castled +King)) 1)
Fld2 )
(cons Pce Fld1) ) ) ) ) ) )
(de pinned (Fld Lst Color)
(use (Pce L P)
(and
(loop
(NIL (setq Fld (Dir Fld)))
(T (setq Pce (get Fld 'piece))
(and
(= Color (get Pce 'color))
(setq L
(make
(loop
(NIL (setq Fld (Dir Fld)))
(link Fld)
(T (setq P (get Fld 'piece))) ) ) )
(<> Color (get P 'color))
(memq (last (type P)) Lst)
(cons Pce L) ) ) )
(link @) ) ) )
- Moves ###
- Move ((p1 (p1 . f2)) . ((p1 . f1)))
- Capture ((p1 (p2) (p1 . f2)) . ((p1 . f1) (p2 . f2)))
- Castle ((K (K) (C . f2) (R . f4)) . ((R . f3) (K . f1)))
- Promote ((P (P) (Q . f2)) . ((Q) (P . f1)))
- Capt/Prom ((P (p1) (P) (Q . f2)) . ((Q) (P . f1) (p1 . f2)))
(de moves (Color)
(filter
'((Lst)
(prog2
(move (car Lst))
(not (inCheck Color))
(move (cdr Lst)) ) )
(mapcan
'((Pce)
(mapcar
'((Lst)
(cons Lst
(flip
(mapcar
'((Mov) (cons (car Mov) (get Mov 1 'field)))
(cdr Lst) ) ) ) )
(moves> Pce) ) )
(if Color *Black *White) ) ) )
(de move (Lst)
(if (atom (car Lst))
(inc (prop (push '*Moved (pop 'Lst)) 'cnt))
(dec (prop (pop '*Moved) 'cnt)) )
(for Mov Lst
(move> (car Mov) (cdr Mov)) ) )
- Evaluation ###
(de mate (Color)
(and (inCheck Color) (not (moves Color))) )
(de battle (Fld Prey Attacker Defender)
(use Pce
(loop
(NIL (setq Pce (mini 'val> Attacker)) 0)
(setq Attacker (delq Pce Attacker))
(NIL (and (asoq Pce *Pinned) (not (memq Fld @)))
(max 0 (- Prey (battle Fld (val> Pce) Defender Attacker))) ) ) ) )
- Ref. Sargon, Dan and Kate Spracklen, Hayden 1978
(de cost (Color)
(if (mate (not Color))
-9999
(setq *Pinned
(make
(for Dir *Straight
(pinned *WKPos '(+Rook +Queen))
(pinned *BKPos '(+Rook +Queen) T) )
(for Dir *Diagonal
(pinned *WKPos '(+Bishop +Queen))
(pinned *BKPos '(+Bishop +Queen) T) ) ) )
(let (Ctl 0 Mat 0 Lose 0 Win1 NIL Win2 NIL Flg NIL)
(use (White Black Col Same B)
(for Lst *Board
(for This Lst
(setq White (: whAtt) Black (: blAtt))
((if Color inc dec) 'Ctl (- (length White) (length Black)))
(let? Val (and (: piece) (val> @))
(setq Col (: piece color) Same (== Col Color))
((if Same dec inc) 'Ctl (ctl> (: piece)))
(unless
(=0
(setq B
(if Col
(battle This Val White Black)
(battle This Val Black White) ) ) )
(dec 'Val 5)
(if Same
(setq
Lose (max Lose B)
Flg (or Flg (== (: piece) (car *Moved))) )
(when (> B Win1)
(xchg 'B 'Win1)
(setq Win2 (max Win2 B)) ) ) )
((if Same dec inc) 'Mat Val) ) ) ) )
(unless (=0 Lose) (dec 'Lose 5))
(if Flg
(* 4 (+ Mat Lose))
(when Win2
(dec 'Lose (>> 1 (- Win2 5))) )
(+ Ctl (* 4 (+ Mat Lose))) ) ) ) )
- Game ###
(de display (Res)
(when Res
(disp *Board T
'((This)
(cond
((: piece) (name> @))
((: color) " - ")
(T " ") ) ) ) )
(and (inCheck *You) (prinl "(+)"))
Res )
(de moved? (Lst)
(or
(> 16 (length Lst))
(find '((This) (n0 (: cnt))) Lst) ) )
(de bookMove (From To)
(let Pce (get From 'piece)
(list 0 (list (list Pce (cons Pce To)) (cons Pce From))) ) )
(de myMove ()
(let? M
(cadr
(cond
((moved? (if *Me *Black *White))
(game *Me *Depth moves move cost) )
(*Me
(if (member (get *Moved 1 'field 'x) (1 2 3 5))
(bookMove 'e7 'e5)
(bookMove 'd7 'd5) ) )
((rand T) (bookMove 'e2 'e4))
(T (bookMove 'd2 'd4)) ) )
(move (car (push '*Undo M)))
(off *Redo)
(cons
(caar M)
(cdr (asoq (caar M) (cdr M)))
(pick cdr (cdar M)) ) ) )
(de yourMove (From To Cls)
(when
(find
'((Mov)
(and
(== (caar Mov) (get From 'piece))
(== To (pick cdr (cdar Mov)))
(or
(not Cls)
(isa Cls (car (last (car Mov)))) ) ) )
(moves *You) )
(prog1 (car (push '*Undo @))
(off *Redo)
(move @) ) ) )
(de undo ()
(move (cdr (push '*Redo (pop '*Undo)))) )
(de redo ()
(move (car (push '*Undo (pop '*Redo)))) )
(de setup (Depth You Init)
(setq *Depth (or Depth 5) *You You *Me (not You))
(off *White *Black *Moved *Undo *Redo)
(for Lst *Board
(for This Lst (=: piece) (=: whAtt) (=: blAtt)) )
(if Init
(for L Init
(with (piece (cadr L) 0 (car L))
(unless (caddr L)
(=: cnt 1)
(push '*Moved This) ) ) )
(mapc
'((Cls Lst)
(piece (list '+White Cls) 0 (car Lst))
(piece '(+White +Pawn) 0 (cadr Lst))
(piece '(+Black +Pawn) 0 (get Lst 7))
(piece (list '+Black Cls) 0 (get Lst 8)) )
'(+Rook +Knight +Bishop +Queen +King +Bishop +Knight +Rook)
*Board ) ) )
(de main (Depth You Init)
(setup Depth You Init) (display T) )
(de go Args
(display
(cond
((not Args) (xchg '*Me '*You) (myMove))
((== '- (car Args)) (and *Undo (undo)))
((== '+ (car Args)) (and *Redo (redo)))
((apply yourMove Args) (display T) (myMove)) ) ) )
- Print position to file
(de ppos (File)
(out File
(println
(list 'main *Depth *You
(lit
(mapcar
'((This)
(list
(: field)
(val This)
(not (memq This *Moved)) ) )
(append *White *Black) ) ) ) ) ) )</lang>
Start:
$ pil chess.l -main +
+---+---+---+---+---+---+---+---+
8 |<R>|<N>|<B>|<Q>|<K>|<B>|<N>|<R>|
+---+---+---+---+---+---+---+---+
7 |<P>|<P>|<P>|<P>|<P>|<P>|<P>|<P>|
+---+---+---+---+---+---+---+---+
6 | | - | | - | | - | | - |
+---+---+---+---+---+---+---+---+
5 | - | | - | | - | | - | |
+---+---+---+---+---+---+---+---+
4 | | - | | - | | - | | - |
+---+---+---+---+---+---+---+---+
3 | - | | - | | - | | - | |
+---+---+---+---+---+---+---+---+
2 | P | P | P | P | P | P | P | P |
+---+---+---+---+---+---+---+---+
1 | R | N | B | Q | K | B | N | R |
+---+---+---+---+---+---+---+---+
a b c d e f g h
Entering moves: <lang PicoLisp>: (go e2 e4)</lang> Undo moves: <lang PicoLisp>: (go -)</lang> Redo: <lang PicoLisp>: (go +)</lang> Switch sides: <lang PicoLisp>: (go)</lang> Save position to a file: <lang PicoLisp>: (ppos "file")</lang> Load position from file: <lang PicoLisp>: (load "file")</lang>