cheeplay.scm (2697B) [raw]
1 #!/usr/local/bin/chicken-csi -ss 2 (import (chicken io) 3 (chicken format) 4 (chicken irregex) 5 (chicken string)) 6 7 ; TODO: use a vector! 8 (define (newboard) 9 '(BR BN BB BQ BK BB BN BR 10 BP BP BP BP BP BP BP BP 11 x x x x x x x x 12 x x x x x x x x 13 x x x x x x x x 14 x x x x x x x x 15 WP WP WP WP WP WP WP WP 16 WR WN WB WQ WK WB WN WR)) 17 18 (define (prpiece x i) 19 ; Print the unicode version of the piece 20 (display (format "~A " 21 (cond 22 ((eq? 'x x) (if (= 0 (modulo (+ i (floor (/ i 8))) 2)) "■" "□")) 23 ((eq? 'BK x) "♔") 24 ((eq? 'BQ x) "♕") 25 ((eq? 'BR x) "♖") 26 ((eq? 'BB x) "♗") 27 ((eq? 'BN x) "♘") 28 ((eq? 'BP x) "♙") 29 ((eq? 'WK x) "♚") 30 ((eq? 'WQ x) "♛") 31 ((eq? 'WR x) "♜") 32 ((eq? 'WB x) "♝") 33 ((eq? 'WN x) "♞") 34 ((eq? 'WP x) "♟") 35 (else (error "bad piece!")))))) 36 37 (define (prboard board) 38 (let loop ((b board) (i 0)) 39 (if (not (null? b)) 40 (begin 41 (if (and (> i 0) (= (modulo i 8) 0)) (newline)) 42 (prpiece (car b) i) 43 (loop (cdr b) (+ i 1))))) 44 (newline)) 45 46 (define (findpiece name m) 47 ; given a name 'BQ' and a next move, return coord pair of piece 48 (newline) 49 ) 50 51 52 (define (move board m) 53 ; deciphers move m and returns a new board w updates 54 (cond 55 ; turn counts have no effect on the board 56 ((irregex-match "^[0-9]+\\.$" m) board) 57 ; Regular move 58 ((irregex-match "^[QKNBR]?[a-h]?[1-8]?x?[a-h][1-8][+#]?$" m) board) 59 ; Castle 60 ((irregex-match "^O-O$" m) board) 61 ; TODO: queen's side castle 62 ; ((irregex-match "^O-O-O$" m) board) 63 ; TODO: Promotion of a pawn 64 ; ((irregex-match "^[a-h][1-8]=[QNBR][+#]?$" m) board) 65 ; End game 66 ; TODO: return state of game for display 67 ((irregex-match "^0-1$" m) board) 68 ((irregex-match "^1-0$" m) board) 69 ((irregex-match "^1/2-1/2$" m) board) 70 (else (error (format "bad move! ~A\n" m))))) 71 72 73 (define (replay file) 74 (call-with-input-file file (lambda (p) 75 (define (parse section board) 76 (let ((l (read-line p))) 77 (if (not (eof-object? l)) 78 (if (eq? section 'tag) 79 (begin (print l) 80 (if (equal? l "") 81 (parse 'movetext board) 82 (parse 'tag board))) 83 (let loop ((tokens (string-split l " "))) 84 (if (not (null? tokens)) 85 (begin 86 (print (car tokens)) 87 (move board (car tokens)) 88 (loop (cdr tokens))) 89 (parse 'movetext board))))))) 90 (parse 'tag (newboard))))) 91 92 (define (main args) 93 (if (null? args) 94 (display "usage: cheeplay FILE.pgn\n") 95 (replay (car args))))