chess.l (15153B)
1 # 24apr12abu 2 # (c) Software Lab. Alexander Burger 3 4 # *Board a1 .. h8 5 # *White *Black *WKPos *BKPos *Pinned 6 # *Depth *Moved *Undo *Redo *Me *You 7 8 (load "@lib/simul.l") 9 10 ### Fields/Board ### 11 # x y color piece whAtt blAtt 12 13 (setq *Board (grid 8 8)) 14 15 (for (X . Lst) *Board 16 (for (Y . This) Lst 17 (=: x X) 18 (=: y Y) 19 (=: color (not (bit? 1 (+ X Y)))) ) ) 20 21 (de *Straight `west `east `south `north) 22 23 (de *Diagonal 24 ((This) (: 0 1 1 0 -1 1)) # Southwest 25 ((This) (: 0 1 1 0 -1 -1)) # Northwest 26 ((This) (: 0 1 -1 0 -1 1)) # Southeast 27 ((This) (: 0 1 -1 0 -1 -1)) ) # Northeast 28 29 (de *DiaStraight 30 ((This) (: 0 1 1 0 -1 1 0 -1 1)) # South Southwest 31 ((This) (: 0 1 1 0 -1 1 0 1 1)) # West Southwest 32 ((This) (: 0 1 1 0 -1 -1 0 1 1)) # West Northwest 33 ((This) (: 0 1 1 0 -1 -1 0 -1 -1)) # North Northwest 34 ((This) (: 0 1 -1 0 -1 -1 0 -1 -1)) # North Northeast 35 ((This) (: 0 1 -1 0 -1 -1 0 1 -1)) # East Northeast 36 ((This) (: 0 1 -1 0 -1 1 0 1 -1)) # East Southeast 37 ((This) (: 0 1 -1 0 -1 1 0 -1 1)) ) # South Southeast 38 39 40 ### Pieces ### 41 (de piece (Typ Cnt Fld) 42 (prog1 43 (def 44 (pack (mapcar '((Cls) (cdr (chop Cls))) Typ)) 45 Typ ) 46 (init> @ Cnt Fld) ) ) 47 48 49 (class +White) 50 # color ahead 51 52 (dm init> (Cnt Fld) 53 (=: ahead north) 54 (extra Cnt Fld) ) 55 56 (dm name> () 57 (pack " " (extra) " ") ) 58 59 (dm move> (Fld) 60 (adjMove '*White '*WKPos whAtt- whAtt+) ) 61 62 63 (class +Black) 64 # color ahead 65 66 (dm init> (Cnt Fld) 67 (=: color T) 68 (=: ahead south) 69 (extra Cnt Fld) ) 70 71 (dm name> () 72 (pack '< (extra) '>) ) 73 74 (dm move> (Fld) 75 (adjMove '*Black '*BKPos blAtt- blAtt+) ) 76 77 78 (class +piece) 79 # cnt field attacks 80 81 (dm init> (Cnt Fld) 82 (=: cnt Cnt) 83 (move> This Fld) ) 84 85 (dm ctl> ()) 86 87 88 (class +King +piece) 89 90 (dm name> () 'K) 91 92 (dm val> () 120) 93 94 (dm ctl> () 95 (unless (=0 (: cnt)) -10) ) 96 97 (dm moves> () 98 (make 99 (unless 100 (or 101 (n0 (: cnt)) 102 (get (: field) (if (: color) 'whAtt 'blAtt)) ) 103 (tryCastle west T) 104 (tryCastle east) ) 105 (try1Move *Straight) 106 (try1Move *Diagonal) ) ) 107 108 (dm attacks> () 109 (make 110 (try1Attack *Straight) 111 (try1Attack *Diagonal) ) ) 112 113 114 (class +Castled) 115 116 (dm ctl> () 30) 117 118 119 (class +Queen +piece) 120 121 (dm name> () 'Q) 122 123 (dm val> () 90) 124 125 (dm moves> () 126 (make 127 (tryMoves *Straight) 128 (tryMoves *Diagonal) ) ) 129 130 (dm attacks> () 131 (make 132 (tryAttacks *Straight) 133 (tryAttacks *Diagonal T) ) ) 134 135 136 (class +Rook +piece) 137 138 (dm name> () 'R) 139 140 (dm val> () 47) 141 142 (dm moves> () 143 (make (tryMoves *Straight)) ) 144 145 (dm attacks> () 146 (make (tryAttacks *Straight)) ) 147 148 149 (class +Bishop +piece) 150 151 (dm name> () 'B) 152 153 (dm val> () 33) 154 155 (dm ctl> () 156 (when (=0 (: cnt)) -10) ) 157 158 (dm moves> () 159 (make (tryMoves *Diagonal)) ) 160 161 (dm attacks> () 162 (make (tryAttacks *Diagonal T)) ) 163 164 165 (class +Knight +piece) 166 167 (dm name> () 'N) 168 169 (dm val> () 28) 170 171 (dm ctl> () 172 (when (=0 (: cnt)) -10) ) 173 174 (dm moves> () 175 (make (try1Move *DiaStraight)) ) 176 177 (dm attacks> () 178 (make (try1Attack *DiaStraight)) ) 179 180 181 (class +Pawn +piece) 182 183 (dm name> () 'P) 184 185 (dm val> () 10) 186 187 (dm moves> () 188 (let (Fld1 ((: ahead) (: field)) Fld2 ((: ahead) Fld1)) 189 (make 190 (and 191 (tryPawnMove Fld1 Fld2) 192 (=0 (: cnt)) 193 (tryPawnMove Fld2 T) ) 194 (tryPawnCapt (west Fld1) Fld2 (west (: field))) 195 (tryPawnCapt (east Fld1) Fld2 (east (: field))) ) ) ) 196 197 (dm attacks> () 198 (let Fld ((: ahead) (: field)) 199 (make 200 (and (west Fld) (link @)) 201 (and (east Fld) (link @)) ) ) ) 202 203 204 ### Move Logic ### 205 (de inCheck (Color) 206 (if Color (get *BKPos 'whAtt) (get *WKPos 'blAtt)) ) 207 208 (de whAtt+ (This Pce) 209 (=: whAtt (cons Pce (: whAtt))) ) 210 211 (de whAtt- (This Pce) 212 (=: whAtt (delq Pce (: whAtt))) ) 213 214 (de blAtt+ (This Pce) 215 (=: blAtt (cons Pce (: blAtt))) ) 216 217 (de blAtt- (This Pce) 218 (=: blAtt (delq Pce (: blAtt))) ) 219 220 (de adjMove (Var KPos Att- Att+) 221 (let (W (: field whAtt) B (: field blAtt)) 222 (when (: field) 223 (put @ 'piece NIL) 224 (for F (: attacks) (Att- F This)) ) 225 (nond 226 (Fld (set Var (delq This (val Var)))) 227 ((: field) (push Var This)) ) 228 (ifn (=: field Fld) 229 (=: attacks) 230 (put Fld 'piece This) 231 (and (isa '+King This) (set KPos Fld)) 232 (for F (=: attacks (attacks> This)) (Att+ F This)) ) 233 (reAtttack W (: field whAtt) B (: field blAtt)) ) ) 234 235 (de reAtttack (W W2 B B2) 236 (for This W 237 (unless (memq This W2) 238 (for F (: attacks) (whAtt- F This)) 239 (for F (=: attacks (attacks> This)) (whAtt+ F This)) ) ) 240 (for This W2 241 (for F (: attacks) (whAtt- F This)) 242 (for F (=: attacks (attacks> This)) (whAtt+ F This)) ) 243 (for This B 244 (unless (memq This B2) 245 (for F (: attacks) (blAtt- F This)) 246 (for F (=: attacks (attacks> This)) (blAtt+ F This)) ) ) 247 (for This B2 248 (for F (: attacks) (blAtt- F This)) 249 (for F (=: attacks (attacks> This)) (blAtt+ F This)) ) ) 250 251 (de try1Move (Lst) 252 (for Dir Lst 253 (let? Fld (Dir (: field)) 254 (ifn (get Fld 'piece) 255 (link (list This (cons This Fld))) 256 (unless (== (: color) (get @ 'color)) 257 (link 258 (list This 259 (cons (get Fld 'piece)) 260 (cons This Fld) ) ) ) ) ) ) ) 261 262 (de try1Attack (Lst) 263 (for Dir Lst 264 (and (Dir (: field)) (link @)) ) ) 265 266 (de tryMoves (Lst) 267 (for Dir Lst 268 (let Fld (: field) 269 (loop 270 (NIL (setq Fld (Dir Fld))) 271 (T (get Fld 'piece) 272 (unless (== (: color) (get @ 'color)) 273 (link 274 (list This 275 (cons (get Fld 'piece)) 276 (cons This Fld) ) ) ) ) 277 (link (list This (cons This Fld))) ) ) ) ) 278 279 (de tryAttacks (Lst Diag) 280 (use (Pce Cls Fld2) 281 (for Dir Lst 282 (let Fld (: field) 283 (loop 284 (NIL (setq Fld (Dir Fld))) 285 (link Fld) 286 (T 287 (and 288 (setq Pce (get Fld 'piece)) 289 (<> (: color) (get Pce 'color)) ) ) 290 (T (== '+Pawn (setq Cls (last (type Pce)))) 291 (and 292 Diag 293 (setq Fld2 (Dir Fld)) 294 (= (get Fld2 'y) (get ((get Pce 'ahead) Fld) 'y)) 295 (link Fld2) ) ) 296 (T (memq Cls '(+Knight +Queen +King))) 297 (T (and Pce (xor Diag (== Cls '+Bishop)))) ) ) ) ) ) 298 299 (de tryPawnMove (Fld Flg) 300 (unless (get Fld 'piece) 301 (if Flg 302 (link (list This (cons This Fld))) 303 (for Cls '(+Queen +Knight +Rook +Bishop) 304 (link 305 (list This 306 (cons This) 307 (cons 308 (piece (list (car (type This)) Cls) (: cnt)) 309 Fld ) ) ) ) ) ) ) 310 311 (de tryPawnCapt (Fld1 Flg Fld2) 312 (if (get Fld1 'piece) 313 (unless (== (: color) (get @ 'color)) 314 (if Flg 315 (link 316 (list This 317 (cons (get Fld1 'piece)) 318 (cons This Fld1) ) ) 319 (for Cls '(+Queen +Knight +Rook +Bishop) 320 (link 321 (list This 322 (cons (get Fld1 'piece)) 323 (cons This) 324 (cons 325 (piece (list (car (type This)) Cls) (: cnt)) 326 Fld1 ) ) ) ) ) ) 327 (let? Pce (get Fld2 'piece) 328 (and 329 (== Pce (car *Moved)) 330 (= 1 (get Pce 'cnt)) 331 (isa '+Pawn Pce) 332 (n== (: color) (get Pce 'color)) 333 (link (list This (cons Pce) (cons This Fld1))) ) ) ) ) 334 335 (de tryCastle (Dir Long) 336 (use (Fld1 Fld2 Fld Pce) 337 (or 338 (get (setq Fld1 (Dir (: field))) 'piece) 339 (get Fld1 (if (: color) 'whAtt 'blAtt)) 340 (get (setq Fld2 (Dir Fld1) Fld Fld2) 'piece) 341 (when Long 342 (or 343 (get (setq Fld (Dir Fld)) 'piece) 344 (get Fld (if (: color) 'whAtt 'blAtt)) ) ) 345 (and 346 (== '+Rook (last (type (setq Pce (get (Dir Fld) 'piece))))) 347 (=0 (get Pce 'cnt)) 348 (link 349 (list This 350 (cons This) 351 (cons 352 (piece (cons (car (type This)) '(+Castled +King)) 1) 353 Fld2 ) 354 (cons Pce Fld1) ) ) ) ) ) ) 355 356 (de pinned (Fld Lst Color) 357 (use (Pce L P) 358 (and 359 (loop 360 (NIL (setq Fld (Dir Fld))) 361 (T (setq Pce (get Fld 'piece)) 362 (and 363 (= Color (get Pce 'color)) 364 (setq L 365 (make 366 (loop 367 (NIL (setq Fld (Dir Fld))) 368 (link Fld) 369 (T (setq P (get Fld 'piece))) ) ) ) 370 (<> Color (get P 'color)) 371 (memq (last (type P)) Lst) 372 (cons Pce L) ) ) ) 373 (link @) ) ) ) 374 375 376 ### Moves ### 377 # Move ((p1 (p1 . f2)) . ((p1 . f1))) 378 # Capture ((p1 (p2) (p1 . f2)) . ((p1 . f1) (p2 . f2))) 379 # Castle ((K (K) (C . f2) (R . f4)) . ((R . f3) (K . f1))) 380 # Promote ((P (P) (Q . f2)) . ((Q) (P . f1))) 381 # Capt/Prom ((P (p1) (P) (Q . f2)) . ((Q) (P . f1) (p1 . f2))) 382 (de moves (Color) 383 (filter 384 '((Lst) 385 (prog2 386 (move (car Lst)) 387 (not (inCheck Color)) 388 (move (cdr Lst)) ) ) 389 (mapcan 390 '((Pce) 391 (mapcar 392 '((Lst) 393 (cons Lst 394 (flip 395 (mapcar 396 '((Mov) (cons (car Mov) (get Mov 1 'field))) 397 (cdr Lst) ) ) ) ) 398 (moves> Pce) ) ) 399 (if Color *Black *White) ) ) ) 400 401 (de move (Lst) 402 (if (atom (car Lst)) 403 (inc (prop (push '*Moved (pop 'Lst)) 'cnt)) 404 (dec (prop (pop '*Moved) 'cnt)) ) 405 (for Mov Lst 406 (move> (car Mov) (cdr Mov)) ) ) 407 408 409 ### Evaluation ### 410 (de mate (Color) 411 (and (inCheck Color) (not (moves Color))) ) 412 413 (de battle (Fld Prey Attacker Defender) 414 (use Pce 415 (loop 416 (NIL (setq Pce (mini 'val> Attacker)) 0) 417 (setq Attacker (delq Pce Attacker)) 418 (NIL (and (asoq Pce *Pinned) (not (memq Fld @))) 419 (max 0 (- Prey (battle Fld (val> Pce) Defender Attacker))) ) ) ) ) 420 421 # Ref. Sargon, Dan and Kate Spracklen, Hayden 1978 422 (de cost (Color) 423 (if (mate (not Color)) 424 -9999 425 (setq *Pinned 426 (make 427 (for Dir *Straight 428 (pinned *WKPos '(+Rook +Queen)) 429 (pinned *BKPos '(+Rook +Queen) T) ) 430 (for Dir *Diagonal 431 (pinned *WKPos '(+Bishop +Queen)) 432 (pinned *BKPos '(+Bishop +Queen) T) ) ) ) 433 (let (Ctl 0 Mat 0 Lose 0 Win1 NIL Win2 NIL Flg NIL) 434 (use (White Black Col Same B) 435 (for Lst *Board 436 (for This Lst 437 (setq White (: whAtt) Black (: blAtt)) 438 ((if Color inc dec) 'Ctl (- (length White) (length Black))) 439 (let? Val (and (: piece) (val> @)) 440 (setq Col (: piece color) Same (== Col Color)) 441 ((if Same dec inc) 'Ctl (ctl> (: piece))) 442 (unless 443 (=0 444 (setq B 445 (if Col 446 (battle This Val White Black) 447 (battle This Val Black White) ) ) ) 448 (dec 'Val 5) 449 (if Same 450 (setq 451 Lose (max Lose B) 452 Flg (or Flg (== (: piece) (car *Moved))) ) 453 (when (> B Win1) 454 (xchg 'B 'Win1) 455 (setq Win2 (max Win2 B)) ) ) ) 456 ((if Same dec inc) 'Mat Val) ) ) ) ) 457 (unless (=0 Lose) (dec 'Lose 5)) 458 (if Flg 459 (* 4 (+ Mat Lose)) 460 (when Win2 461 (dec 'Lose (>> 1 (- Win2 5))) ) 462 (+ Ctl (* 4 (+ Mat Lose))) ) ) ) ) 463 464 465 ### Game ### 466 (de display (Res) 467 (when Res 468 (disp *Board T 469 '((This) 470 (cond 471 ((: piece) (name> @)) 472 ((: color) " - ") 473 (T " ") ) ) ) ) 474 (and (inCheck *You) (prinl "(+)")) 475 Res ) 476 477 (de moved? (Lst) 478 (or 479 (> 16 (length Lst)) 480 (find '((This) (n0 (: cnt))) Lst) ) ) 481 482 (de bookMove (From To) 483 (let Pce (get From 'piece) 484 (list 0 (list (list Pce (cons Pce To)) (cons Pce From))) ) ) 485 486 (de myMove () 487 (let? M 488 (cadr 489 (cond 490 ((moved? (if *Me *Black *White)) 491 (game *Me *Depth moves move cost) ) 492 (*Me 493 (if (member (get *Moved 1 'field 'x) (1 2 3 5)) 494 (bookMove 'e7 'e5) 495 (bookMove 'd7 'd5) ) ) 496 ((rand T) (bookMove 'e2 'e4)) 497 (T (bookMove 'd2 'd4)) ) ) 498 (move (car (push '*Undo M))) 499 (off *Redo) 500 (cons 501 (caar M) 502 (cdr (asoq (caar M) (cdr M))) 503 (pick cdr (cdar M)) ) ) ) 504 505 (de yourMove (From To Cls) 506 (when 507 (find 508 '((Mov) 509 (and 510 (== (caar Mov) (get From 'piece)) 511 (== To (pick cdr (cdar Mov))) 512 (or 513 (not Cls) 514 (isa Cls (car (last (car Mov)))) ) ) ) 515 (moves *You) ) 516 (prog1 (car (push '*Undo @)) 517 (off *Redo) 518 (move @) ) ) ) 519 520 (de undo () 521 (move (cdr (push '*Redo (pop '*Undo)))) ) 522 523 (de redo () 524 (move (car (push '*Undo (pop '*Redo)))) ) 525 526 (de setup (Depth You Init) 527 (setq *Depth (or Depth 5) *You You *Me (not You)) 528 (off *White *Black *Moved *Undo *Redo) 529 (for Lst *Board 530 (for This Lst (=: piece) (=: whAtt) (=: blAtt)) ) 531 (if Init 532 (for L Init 533 (with (piece (cadr L) 0 (car L)) 534 (unless (caddr L) 535 (=: cnt 1) 536 (push '*Moved This) ) ) ) 537 (mapc 538 '((Cls Lst) 539 (piece (list '+White Cls) 0 (car Lst)) 540 (piece '(+White +Pawn) 0 (cadr Lst)) 541 (piece '(+Black +Pawn) 0 (get Lst 7)) 542 (piece (list '+Black Cls) 0 (get Lst 8)) ) 543 '(+Rook +Knight +Bishop +Queen +King +Bishop +Knight +Rook) 544 *Board ) ) ) 545 546 (de main (Depth You Init) 547 (setup Depth You Init) 548 (display T) ) 549 550 (de go Args 551 (display 552 (cond 553 ((not Args) (xchg '*Me '*You) (myMove)) 554 ((== '- (car Args)) (and *Undo (undo))) 555 ((== '+ (car Args)) (and *Redo (redo))) 556 ((apply yourMove Args) (display T) (myMove)) ) ) ) 557 558 # Print position to file 559 (de ppos (File) 560 (out File 561 (println 562 (list 'main *Depth *You 563 (lit 564 (mapcar 565 '((This) 566 (list 567 (: field) 568 (val This) 569 (not (memq This *Moved)) ) ) 570 (append *White *Black) ) ) ) ) ) ) 571 572 # vi:et:ts=3:sw=3