#! /usr/local/bin/csi -quiet

(cond-expand
 (compiling
  (declare
   (block)
   (fixnum)
   (lambda-lift)
   (unsafe)
   (disable-interrupts)))
 (else))

(require-extension srfi-4 srfi-1 srfi-13 lolevel regex posix)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; compatibility

(include "let-args.scm")

(define-macro (push! ls val)
  `(set! ,ls (cons ,val ,ls)))

(define-macro (inc! var . o)
  (let ((amount (if (pair? o) (car o) 1)))
    `(set! ,var (+ ,var ,amount))))

(define-macro (dec! var . o)
  (let ((amount (if (pair? o) (car o) 1)))
    `(set! ,var (- ,var ,amount))))

(define-macro (dotimes var+times . body)
  (let ((var (car var+times))
        (times (cadr var+times)))
    `(do ((,var 0 (+ ,var 1)))
         ((= ,var ,times))
       ,@body)))

(define (warn fmt . args)
  (apply fprintf (current-error-port) fmt args))

(define (u8vector-copy vec)
  (let ((res (make-u8vector (u8vector-length vec))))
    (move-memory! vec res)
    res))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-constant piece-none   0) ; 000
(define-constant piece-pawn   1) ; 001
(define-constant piece-knight 2) ; 010
(define-constant piece-king   3) ; 011
(define-constant piece-bishop 5) ; 101
(define-constant piece-rook   6) ; 110
(define-constant piece-queen  7) ; 111

(define-constant *white-piece-values*
  '#(0  100  300  12800 0  300  500  900
     0 -100 -300 -12800 0 -300 -500 -900))

(eval-when (compile eval load)

(define-inline (bit-set? index n)
  (not (zero? (bitwise-and n (arithmetic-shift 1 index)))))

(define-inline (piece-white? piece) (not (bit-set? 3 piece)))
(define-inline (piece-black? piece) (bit-set? 3 piece))
(define-inline (piece-white piece) (bitwise-and piece #b111))
(define-inline (piece-black piece) (bitwise-ior piece #b1000))
(define-inline (piece-player piece) (bitwise-and piece #b1000))
(define-inline (piece-base piece) (bitwise-and piece #b111))
(define-inline (piece-complement piece) (bitwise-xor piece #b1000))
(define-inline (piece-slider? piece) (bit-set? 2 piece))
(define-inline (piece-orthogonal? piece) (bit-set? 1 piece))
(define-inline (piece-diagonal? piece) (odd? piece))
(define-inline (piece-orthogonal-slider? piece)
  (= #b110 (bitwise-and piece #b110)))
(define-inline (piece-diagonal-slider? piece)
  (= #b101 (bitwise-and piece #b101)))

(define-inline (white-piece-value x)
  (vector-ref *white-piece-values* x))

(define-inline (black-piece-value x) (- (white-piece-value x)))

(define-inline (piece-value x)
  (abs (white-piece-value x)))

(define-inline (player-complement player) (bitwise-xor player #b1000))
(define-inline (player-white? x) (= x player-white))
(define-inline (player-black? x) (= x player-black))

)

(define-constant black-pawn   (piece-complement piece-pawn))
(define-constant black-knight (piece-complement piece-knight))
(define-constant black-king   (piece-complement piece-king))
(define-constant black-bishop (piece-complement piece-bishop))
(define-constant black-rook   (piece-complement piece-rook))
(define-constant black-queen  (piece-complement piece-queen))

;; players

(define-constant player-white 0)
(define-constant player-black (player-complement player-white))

(define player-piece bitwise-ior)

(define (piece->ascii n)
  (case n
    ((1)  #\P)  ((2)  #\N)  ((3)  #\K)  ((5)  #\B)  ((6)  #\R)  ((7)  #\Q)
    ((9)  #\p)  ((10) #\n)  ((11) #\k)  ((13) #\b)  ((14) #\r)  ((15) #\q)
    (else #\.)))

(define (piece->unicode n)
  (case n
    ((3)  "\u2654") ((7)  "\u2655") ((6)  "\u2656")
    ((5)  "\u2657") ((2)  "\u2658") ((1)  "\u2659")
    ((11) "\u265A") ((15) "\u265B") ((14) "\u265C")
    ((13) "\u265D") ((10) "\u265E") ((9)  "\u265F")
    (else #\.)))

(define (x->base-piece x)
  (cond ((string? x)
         (and (= 1 (string-length x)) (x->base-piece (string-ref x 0))))
        ((char? x)
         (case x
           ((#\k #\K) 3) ((#\q #\Q) 7) ((#\r #\R) 6)
           ((#\b #\B) 5) ((#\n #\N) 2) ((#\p #\P) 1)
           (else #f)))
        ((symbol? x) (x->base-piece (symbol->string x)))
        ((number? x) x)
        (else #f)))

(define (x->piece x . opt)
  (if (and (pair? opt) (player-black? (car opt)))
    (piece-black (x->base-piece x))
    (x->base-piece x)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; board representation, using u8vector, u4vector fits but would be slow

(define (make-chess-board)
  (make-u8vector 128 0))

(define (rank+file->index rank file)
  (+ (arithmetic-shift rank 4) file))

(define (index->rank index)
  (quotient index 16))

(define (index->rank+file index)
  (values (quotient index 16) (remainder index 16)))

(define-inline (valid-index? index)
  (and (<= 0 index 128)
       (zero? (bitwise-and index #x88))))

(define (valid-rank+file? rank file)
  (and (<= 0 rank 7) (<= 0 file 7)))

(define (board-ref bd rank file)
  (u8vector-ref bd (rank+file->index rank file)))

(define (board-set! bd rank file piece)
  (u8vector-set! bd (rank+file->index rank file) piece))

(define initial-chess-board
  (let ((bd (make-chess-board)))
    (dotimes (i 8) (board-set! bd 1 i piece-pawn))
    (dotimes (i 8) (board-set! bd 6 i (piece-black piece-pawn)))
    (for-each
     (lambda (rank color)
       (board-set! bd rank 0 (color piece-rook))
       (board-set! bd rank 1 (color piece-knight))
       (board-set! bd rank 2 (color piece-bishop))
       (board-set! bd rank 3 (color piece-queen))
       (board-set! bd rank 4 (color piece-king))
       (board-set! bd rank 5 (color piece-bishop))
       (board-set! bd rank 6 (color piece-knight))
       (board-set! bd rank 7 (color piece-rook)))
     '(0 7) (list piece-white piece-black))
    (lambda () (u8vector-copy bd))))

(define (print-chess-board bd . opt)
  (define (print port
                 #!key
                 (unicode? #f)
                 (reverse-video? #f)
                 (black? #f)
                 (ansi? #f)
                 (empty-square (if ansi? " " "."))
                 (left #f)
                 (center-col #f)
                 (right #f)
                 (top #f)
                 (middle-row #f)
                 (bottom #f))
    (if top (display top port))
    (do ((rank (if black? 0 7) ((if black? + -) rank 1)))
        ((if black? (> rank 7) (< rank 0)))
      (if (and middle-row (if black? (> rank 0) (< rank 7)))
        (display middle-row port))
      (if left (display left port))
      (do ((file (if black? 7 0) ((if black? - +) file 1)))
          ((if black? (< file 0) (> file 7)))
        (if (and center-col (if black? (< file 7) (not (zero? file))))
          (display center-col port))
        (if ansi?
          (display
           (string-append
            "\x1b[" (if (odd? (+ file rank)) "47" "42") "m") port))
        (let ((piece (board-ref bd rank file)))
          (display (or (and (= piece piece-none) empty-square)
                       ((if unicode? piece->unicode piece->ascii) piece))
                   port)))
      (if ansi? (display " \x1b[0m"))
      (if right (display right port))
      (newline port)) 
    (if bottom (display bottom port)))
  (if (pair? opt)
    (let ((x (car opt)))
      (cond ((port? x) (apply print x (cdr opt)))
            ((eq? x #t) (apply print (current-output-port) (cdr opt)))
            ((not x) (call-with-output-string (cut apply print <> (cdr opt))))
            (else (apply print (current-output-port) opt))))
    (print (current-output-port))))

(define position vector)

(define-inline (position-board pos) (vector-ref pos 0))
(define-inline (position-last-move pos) (vector-ref pos 1))
(define-inline (position-material pos) (vector-ref pos 2))
(define-inline (position-heuristic pos) (vector-ref pos 3))

(define-inline (set-position-board! pos x) (vector-set! pos 0 x))
(define-inline (set-position-last-move! pos x) (vector-set! pos 1 x))
(define-inline (set-position-material! pos x) (vector-set! pos 2 x))
(define-inline (set-position-heuristic! pos x) (vector-set! pos 3 x))

(define (make-chess-position . opt)
  (let ((bd (if (pair? opt) (car opt) (initial-chess-board))))
    (position bd #f (chess-material-heuristic bd) (chess-full-heuristic bd))))

(define (set-initial-chess-position! pos)
  (let ((bd (position-board pos)))
    (set-position-board! pos bd)
    (set-position-last-move! pos #f)
    (set-position-material! pos (chess-material-heuristic bd))
    (set-position-heuristic! pos (chess-full-heuristic bd))
    pos))

(define (chess-next-simple-position pos move)
  (let* ((bd (chess-simple-move (position-board pos) (car move) (cdr move)))
         (p-h (chess-positional-heuristic bd))
         (m-h (- (position-material pos)
                 (white-piece-value
                  (u8vector-ref (position-board pos) (cdr move))))))
    (position bd move m-h (+ m-h p-h))))

(define (chess-next-position pos move)
  (let* ((bd (chess-move (position-board pos) (car move) (cdr move)))
         (m-h (chess-material-heuristic bd))
         (p-h (chess-positional-heuristic bd)))
    (position bd move m-h (+ m-h p-h))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; describing movement & notation

(define (chess-parse-rank x) ; a number or string representation of a number
  (cond ((number? x) (- x 1))
        ((string? x) (cond ((string->number x) => chess-parse-rank) (else #f)))
        ((char? x)   (chess-parse-rank (string x)))
        ((symbol? x) (chess-parse-rank (symbol->string x)))
        (else #f)))

(define (chess-parse-file x) ; a letter or raw (non-string) number
  (cond ((number? x) (- x 1))
        ((char? x) (- (char->integer (char-downcase x)) (char->integer #\a)))
        ((and (string? x) (= 1 (string-length x)))
         (chess-parse-file (string-ref x 0)))
        ((symbol? x) (x->rank (symbol->string x)))
        (else #f)))

(define (chess-parse-destination x player)
  (cond ((pair? x)
         (let ((rank (chess-parse-rank (cdr x)))
               (file (chess-parse-file (car x))))
           (and rank file (rank+file->index rank file))))
        ((and (string? x) (= (string-length x) 2))
         (chess-parse-destination
          (cons (string-ref x 0) (string-ref x 1)) player))
        (else #f)))

(define (chess-parse-source x pos dest player)
  (cond
    ((chess-parse-destination x player))
    ((string? x)
     (let ((len (string-length x)))
       (case len
         ((1)
          (let ((ls (chess-reverse-moves-by-piece
                     pos dest player (x->piece x player))))
            (and (= 1 (length ls)) (car ls))))
         ((2)
          (let* ((ch (string-ref x 1))
                 (file (chess-parse-file ch))
                 (rank (chess-parse-rank ch))
                 (ls (filter (if file
                               (lambda (sq) (= file (cdr sq)))
                               (lambda (sq) (= rank (cdr sq))))
                             (chess-reverse-moves-by-piece
                              pos dest player (x->piece x player)))))
            (and (= 1 (length ls)) (car ls))))
         ((3) (chess-parse-destination (substring x 1 3) player))
         (else #f))))
    (else #f)))

(define (chess-parse-move pos move player)
  (let ((bd (position-board pos)))
    (cond
      ((pair? move)
       (let* ((dest (chess-parse-destination (cdr move) player))
              (src (chess-parse-source (car move) pos dest player)))
         (and src dest (cons src dest))))
      ((string? move)
       (let* ((str move)
              (len (string-length str)))
         (cond ((string=? str "O-O")
                (let ((ok (filter (lambda (m) (= (+ 2 (car m)) (cdr m)))
                                  (chess-castle-moves pos player))))
                  (and (= 1 (length ok)) (car ok))))
               ((string=? str "O-O-O")
                (let ((ok (filter (lambda (m) (= (- 2 (car m)) (cdr m)))
                                  (chess-castle-moves pos player))))
                  (and (= 1 (length ok)) (car ok))))
               ((or (string-index str #\-)
                    (string-index str #\x))
                => (lambda (i)
                     (and (<= 1 i (- len 1))
                          (chess-parse-move
                           pos (cons (substring str 0 i)
                                     (substring str (+ i 1) len)) player))))
               ((and (= len 2)
                     (string-index "abcdefgh" (string-ref str 0))
                     (char-numeric? (string-ref str 1)))
                (chess-parse-move pos (cons "P" str) player))
;                ((and-let* (((= len 2))
;                            (p1 (string-ref str 0))
;                            (p2 (string-ref str 1))
;                            (string-index "abcdefgh" p1)
;                            (string-index "abcdefgh" p2)
;                            (or (= (char->integer p1) (+ 1 (char->integer p2)))
;                                (= (char->integer p2) (+ 1 (char->integer p1)))))
;                   #t)
;                 (chess-parse-move pos (cons "P" str) player))
               ((= len 3)
                (chess-parse-move pos (cons (substring str 0 1) (substring str 1 3)) player))
               ((= (string-length str) 4)
                (chess-parse-move pos (cons (substring str 0 2) (substring str 2 4))
                                  player))
               (else #f))))
      (else #f))))

(define (get-rank i)
  (receive (rank file) (index->rank+file i)
    (+ rank 1)))
(define (get-file i)
  (receive (rank file) (index->rank+file i)
    (integer->char (+ file (char->integer #\a)))))

(define (chess-format-move bd move)
  (let* ((src (car move))
         (dest (cdr move))
         (rank (get-rank dest))
         (file (get-file dest))
         (piece (piece-base (u8vector-ref bd src)))
         (capture? (not (zero? (u8vector-ref bd dest)))))
    (if capture?
      (sprintf "~Ax~A~A" (if (= piece piece-pawn) (get-file src)
                             (piece->ascii piece)) file rank)
      (sprintf "~A~A~A" (if (= piece piece-pawn) "" (piece->ascii piece))
               file rank))))

(define (chess-format-move-xboard bd move)
  (let ((src (car move))
        (dest (cdr move)))
    (sprintf "~A~A~A~A" (get-file src) (get-rank src) (get-file dest) (get-rank dest))))

(define (chess-format-last-move pos)
  (chess-format-move (position-board pos) (position-last-move pos)))

(define chess-notation-valid?
  (let ((rx (regexp "^(O-O(-O)?)|([KQRBNP][a-h][1-8]?[-x]?)?[a-h][1-8]$")))
    (lambda (str)
      (string-match-positions rx str))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; movement

(define (chess-simple-move! bd from to)
  (u8vector-set! bd to (u8vector-ref bd from))
  (u8vector-set! bd from piece-none)
  bd)

(define (chess-simple-move bd from to)
  (chess-simple-move! (u8vector-copy bd) from to))

(define (chess-move! bd from to)
  (cond
    ((chess-en-passant? bd from to)
     (chess-simple-move! bd from to)
     (u8vector-set! bd ((if (< from to) - +) to 1) piece-none))
    ((chess-castle? bd from to)
     (chess-simple-move! bd from to)
     (let ((rook
            (player-piece (piece-player (u8vector-ref bd to)) piece-rook)))
       (case to
         ((6 118)
          (u8vector-set! bd (- to 1) rook)
          (u8vector-set! bd (+ to 1) piece-none))
         ((2 114)
          (u8vector-set! bd (+ to 1) rook)
          (u8vector-set! bd (- to 2) piece-none)))))
    (else (chess-simple-move! bd from to)))
  bd)

(define (chess-move bd from to)
  (chess-move! (u8vector-copy bd) from to))

;; slide along a rank, file or diagonal
(define-inline (for-each-slide bd index off proc)
  (let loop ((i (+ index off)))
    (when (valid-index? i)
      (proc i (u8vector-ref bd i))
      (loop (+ i off)))))

;; slide w/o moving through pieces (can capture)
(define-inline (for-each-slide* bd player index off proc)
  (let loop ((i (+ index off)))
    (when (valid-index? i)
      (let ((p (u8vector-ref bd i)))
        (cond ((zero? p) (proc i p) (loop (+ i off)))
              ((not (= player (piece-player p))) (proc i p)))))))

;; explicit list of offsets
(define-inline (for-each-offset bd index ls proc)
  (for-each
   (lambda (off)
     (let ((i (+ index off)))
       (when (valid-index? i)
         (proc i (u8vector-ref bd i)))))
   ls))

(define-inline (for-each-orthogonal-1 bd index proc)
  (for-each-offset bd index '(-1 1 -16 16) proc))

(define-inline (for-each-diagonal-1 bd index proc)
  (for-each-offset bd index '(-15 -17 15 17) proc))

(define-inline (for-each-knight bd index proc)
  (for-each-offset
   bd index
   '(-31 -33 -14 -18 31 33 14 18)
   proc))

(define-inline (for-each-rank bd index proc)
  (for-each-slide bd index -16 proc)
  (for-each-slide bd index 16 proc))

(define-inline (for-each-file bd index proc)
  (for-each-slide bd index -1 proc)
  (for-each-slide bd index 1 proc))

(define-inline (for-each-rank* bd player index proc)
  (for-each-slide* bd player index -16 proc)
  (for-each-slide* bd player index 16 proc))

(define-inline (for-each-file* bd player index proc)
  (for-each-slide* bd player index -1 proc)
  (for-each-slide* bd player index 1 proc))

(define-inline (for-each-orthogonal* bd player index proc)
  (for-each-rank* bd player index proc)
  (for-each-file* bd player index proc))

(define-inline (for-each-diagonal* bd player index proc)
  (for-each-slide* bd player index -15 proc)
  (for-each-slide* bd player index -17 proc)
  (for-each-slide* bd player index 15 proc)
  (for-each-slide* bd player index 17 proc))

(define (board-for-each bd proc) ; ugly semi-unrolled loop
  (do ((i 0   (+ i 1))) ((= i 8))   (proc i (u8vector-ref bd i)))
  (do ((i 16  (+ i 1))) ((= i 24))  (proc i (u8vector-ref bd i)))
  (do ((i 32  (+ i 1))) ((= i 40))  (proc i (u8vector-ref bd i)))
  (do ((i 48  (+ i 1))) ((= i 56))  (proc i (u8vector-ref bd i)))
  (do ((i 64  (+ i 1))) ((= i 72))  (proc i (u8vector-ref bd i)))
  (do ((i 80  (+ i 1))) ((= i 88))  (proc i (u8vector-ref bd i)))
  (do ((i 96  (+ i 1))) ((= i 104)) (proc i (u8vector-ref bd i)))
  (do ((i 112 (+ i 1))) ((= i 120)) (proc i (u8vector-ref bd i))))

;; pieces that can move to a given square
(define (chess-reverse-moves pos index player)
  (let* ((bd (position-board pos))
         (dest-piece (u8vector-ref bd index))
         (opponent (player-complement player))
         (white? (player-white? player)))
    (if (and (not (= piece-none dest-piece))
             (= player (piece-player dest-piece)))
      '() ; can't capture our own piece
      (let ((res '())
            (my-pawn (x->piece piece-pawn player))
            (my-knight (x->piece piece-knight player))
            (my-king (x->piece piece-king player)))
        ;; pawns
        (when (if white? (>= index 32) (<= index 87))
          (let ((shift (if white? - +)))
            (cond
              ((eq? piece-none dest-piece) ; pawn moves
               (let* ((i (shift index 16)) (p (u8vector-ref bd i)))
                 (if (= my-pawn p)
                   (push! res i)
                   (if (and (zero? p)
                            (if white? (<= 48 index 55) (<= 64 index 71))
                            (= my-pawn (u8vector-ref bd (shift index 32))))
                     (push! res (shift index 32)))))
               ;; en passant
               (let ((rank (index->rank index))
                     (other-pawn (x->piece piece-pawn opponent)))
                 (cond
                   ((and (or (= rank 2) (= rank 5))
                         (eq? my-pawn (u8vector-ref bd (shift index 16)))
                         (eq? index (car (position-last-move pos)))
                         (eq? (shift index 16) (cdr (position-last-move pos))))
                    (if (eq? other-pawn (u8vector-ref bd (shift index 15)))
                      (push! res (shift index 15)))
                    (if (eq? other-pawn (u8vector-ref bd (shift index 17)))
                      (push! res (shift index 17)))))))
              (else ; pawn captures
               (when (not (= player (piece-player dest-piece)))
                 (let ((i (shift index 15)))
                   (if (= my-pawn (u8vector-ref bd i)) (push! res i)))
                 (let ((i (shift index 17)))
                   (if (= my-pawn (u8vector-ref bd i)) (push! res i))))))))
        ;; 1-adjacent (king)
        (for-each-orthogonal-1 bd index
         (lambda (i p) (when (= p my-king) (push! res i))))
        (for-each-diagonal-1 bd index
         (lambda (i p) (when (= p my-king) (push! res i))))
        ;; orthogonal (rook, queen)
        (for-each-orthogonal* bd opponent index
         (lambda (i p)
           (when (and (piece-orthogonal-slider? p) (= player (piece-player p)))
             (push! res i))))
        ;; diagonal (bishop, queen)
        (for-each-diagonal* bd opponent index
         (lambda (i p)
           (when (and (piece-diagonal-slider? p) (= player (piece-player p)))
             (push! res i))))
        ;; knight moves
        (for-each-knight bd index
         (lambda (i p) (when (= p my-knight) (push! res i))))
        ;; return
        res))))

(define (chess-reverse-moves-by-piece pos index player piece)
  (filter (lambda (i) (= piece (u8vector-ref (position-board pos) i)))
          (chess-reverse-moves pos index player)))

(define (chess-piece-moves pos index)
  (let* ((bd (position-board pos))
         (piece (u8vector-ref bd index))
         (player (piece-player piece))
         (base (piece-base piece))
         (res '()))
    (define (add! i p) (push! res i))
    (define (safe-add! i p)
      (if (or (zero? p) (not (= player (piece-player p))))
        (push! res i)))
    (switch (piece-base piece)
     (piece-queen
      (for-each-orthogonal* bd player index add!)
      (for-each-diagonal* bd player index add!))
     (piece-rook (for-each-orthogonal* bd player index add!))
     (piece-bishop (for-each-diagonal* bd player index add!))
     (piece-knight (for-each-knight bd index safe-add!))
     (piece-king
      (for-each-orthogonal-1 bd index safe-add!)
      (for-each-diagonal-1 bd index safe-add!))
     (piece-pawn
      (let* ((shift (if (piece-white? piece) + -))
             (i (shift index 16)))
        ;; movement
        (when (zero? (u8vector-ref bd i))
          (push! res i)
          (when (and (if (piece-white? piece)
                       (<= 16 index 23)
                       (<= 96 index 103))
                     (zero? (u8vector-ref bd (shift index 32))))
            (push! res (shift index 32))))
        ;; capture
        (let ((p (u8vector-ref bd (shift index 15))))
          (when (and (not (zero? p)) (not (= player (piece-player p))))
            (push! res (shift index 15))))
        (let ((p (u8vector-ref bd (shift index 17))))
          (when (and (not (zero? p)) (not (= player (piece-player p))))
            (push! res (shift index 17)))))))
    res))

(define (chess-en-passant? bd src dest)
  (let ((offset (abs (- dest src))))
    (and (not (or (= 16 offset) (= 32 offset)))
         (= piece-pawn (piece-base (u8vector-ref bd src)))
         (= piece-none (u8vector-ref bd dest)))))

(define (chess-en-passant-moves pos player)
  (let* ((bd (position-board pos))
         (prev (position-last-move pos))
         (index (cdr prev))
         (piece (u8vector-ref bd index)))
    (if (player-white? player)
      (if (and (= black-pawn piece)
               (<= 64 index 71) (<= 96 (car prev) 103))
        (append (if (= piece-pawn (- index 1))
                  (list (- index 1) (+ index 16)) '())
                (if (= piece-pawn (+ index 1))
                  (list (+ index 1) (+ index 16)) '()))
        '())
      (if (and (= piece-pawn piece)
               (<= 48 index 55) (<= 16 (car prev) 23))
        (append (if (= black-pawn (- index 1))
                  (list (- index 1) (- index 16)) '())
                (if (= black-pawn (+ index 1))
                  (list (+ index 1) (- index 16)) '()))
        '()))))

(define (chess-en-passant-positions pos player)
  (map (cut chess-next-position pos <>)
       (chess-en-passant-moves pos player)))

(define (chess-castle? bd src dest)
  (and (= 2 (abs (- dest src)))
       (= piece-king (piece-base (u8vector-ref bd src)))))

(define (chess-castle-moves pos player)
  (let ((bd (position-board pos)))
    (if (player-white? player)
      (if (= piece-king (u8vector-ref bd 4))
        (append
         (if (and (zero? (u8vector-ref bd 6))
                  (zero? (u8vector-ref bd 5))
                  (= piece-rook (u8vector-ref bd 7))
;                   (not (any (lambda (m) (memv (car m) '(4 7)))
;                             (position-history pos)))
                  )
           (list (cons 4 6)) '())
         (if (and (zero? (u8vector-ref bd 1))
                  (zero? (u8vector-ref bd 2))
                  (zero? (u8vector-ref bd 3))
                  (= piece-rook (u8vector-ref bd 0))
;                   (not (any (lambda (m) (memv (car m) '(4 0)))
;                             (position-history pos)))
                  )
           (list (cons 4 2)) '()))
        '())
      (if (= black-king (u8vector-ref bd 116))
        (append
         (if (and (zero? (u8vector-ref bd 118))
                  (zero? (u8vector-ref bd 117))
                  (= black-rook (u8vector-ref bd 119))
;                   (not (any (lambda (m) (memv (car m) '(116 119)))
;                             (position-history pos)))
                  )
           (list (cons 116 118)) '())
         (if (and (zero? (u8vector-ref bd 113))
                  (zero? (u8vector-ref bd 114))
                  (zero? (u8vector-ref bd 115))
                  (= black-rook (u8vector-ref bd 112))
;                   (not (any (lambda (m) (memv (car m) '(116 112)))
;                             (position-history pos)))
                  )
           (list (cons 116 114)) '()))
        '()))))

(define (chess-castle-positions pos player)
  (map (cut chess-next-position pos <>)
       (chess-castle-moves pos player)))

(define (chess-board-moves pos player)
  (let ((bd (position-board pos))
        (res '()))
    (board-for-each bd
     (lambda (i p)
       (when (and (not (eq? piece-none p)) (= player (piece-player p)))
         (push! res (map (cut cons i <>) (chess-piece-moves pos i))))))
     (append (chess-en-passant-positions pos player)
             (chess-castle-positions pos player)
             (map (cut chess-next-simple-position pos <>)
                  (apply append res)))))

(define (chess-find-king bd player)
  (let ((my-king (player-piece player piece-king)))
    (call-with-current-continuation
     (lambda (return)
       (board-for-each bd (lambda (i p) (if (= p my-king) (return i))))))))

(define (chess-check? pos)
  (let* ((bd (position-board pos))
         (player (piece-player (u8vector-ref bd (cdr (position-last-move pos)))))
         (index (chess-find-king bd (player-complement player))))
    (pair? (chess-reverse-moves pos index player))))

(define (chess-mate? pos)
  (let* ((bd (position-board pos))
         (player (piece-player (u8vector-ref bd (cdr (position-last-move pos)))))
         (index (chess-find-king bd (player-complement player)))
         (attackers
          (chess-reverse-moves pos index player)))
    (and (pair? attackers)
         (not
          (or (and (null? (cdr attackers)) ; 1 attacker, try capture
                   (pair? (filter
                           (lambda (from)
                             (null? (chess-reverse-moves
                                     (chess-next-position
                                      pos (cons from (car attackers)))
                                     (if (= from index) (car attackers) index)
                                     player)))
                           (chess-reverse-moves pos (car attackers) player))))
              (any (lambda (move) ; run away!!!
                     (null? (chess-reverse-moves
                             (chess-next-simple-position
                              pos (cons index move))
                             move player)))
                   (chess-piece-moves pos index)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; searching

(define-constant min-h -200000)
(define-constant max-h  200000)

(define (no-pawns? bd i off)
  (let lp ((i (+ i off)))
    (or (> i 103) ; 7-8th rank
        (< i 16)  ; 1-2nd rank
        (and (not (eq? piece-pawn (piece-base (u8vector-ref bd i))))
             (lp (+ i off))))))

(define (passed-white-pawn? bd i)
  (and (no-pawns? bd i 16)
       (no-pawns? bd (- i 1) 16)
       (no-pawns? bd (+ i 1) 16)))

(define (passed-black-pawn? bd i)
  (and (no-pawns? bd i -16)
       (no-pawns? bd (- i 1) -16)
       (no-pawns? bd (+ i 1) -16)))

(define (chess-positional-heuristic bd)
  (letrec ((res 0)
           (add! (lambda (i p) (inc! res)))
           (sub! (lambda (i p) (dec! res))))
    ;; count mobility & passed pawns
    (board-for-each
     bd
     (lambda (i p)
       (switch p
        ;; white
;         (piece-queen
;          (for-each-orthogonal* bd player-white i add!)
;          (for-each-diagonal* bd player-white i add!))
        (piece-rook (for-each-orthogonal* bd player-white i add!))
        (piece-bishop (for-each-diagonal* bd player-white i add!))
        (piece-knight (for-each-knight bd i add!))
        (piece-pawn (if (passed-white-pawn? bd i) (set! res (+ res 10))))
        ;; black
;         (black-queen
;          (for-each-orthogonal* bd player-black i sub!)
;          (for-each-diagonal* bd player-black i sub!))
        (black-rook (for-each-orthogonal* bd player-black i sub!))
        (black-bishop (for-each-diagonal* bd player-black i sub!))
        (black-knight (for-each-knight bd i sub!))
        (black-pawn (if (passed-black-pawn? bd i) (set! res (- res 10))))
        )))
    ;; count control of center
    ;; count holes
    ;; count king safety
    res))

(define (chess-material-heuristic bd)
  (let ((res 0))
    (board-for-each bd (lambda (i p) (inc! res (white-piece-value p))))
    res))

(define (chess-full-heuristic bd)
  (+ (chess-material-heuristic bd) (chess-positional-heuristic bd)))

(define-inline (position-better? a b)
  (> (position-heuristic a) (position-heuristic b)))

(define (best-position ls)
  (let lp ((ls (cdr ls)) (best (car ls)))
    (cond
      ((null? ls) best)
      ((position-better? (car ls) best) (lp (cdr ls) (car ls)))
      (else (lp (cdr ls) best)))))

(define (max-value pos player depth alpha beta)
  (and-let* ((moves (chess-board-moves pos player)))
    (if (zero? depth)
      (let ((move (best-position moves)))
        (values move (position-heuristic move)))
      (let ((opponent (player-complement player))
            (depth2 (- depth 1)))
        (let loop ((m moves) (best (car moves)) (alpha alpha))
          (if (null? m)
            (values best alpha)
            (receive (riposte h)
                (min-value (car m) opponent depth2 alpha beta)
              (cond
                ((> h alpha)
                 (if (>= h beta)
                   (values (car m) beta)
                   (loop (cdr m) (car m) h)))
                (else
                 (loop (cdr m) best alpha))))))))))

(define-inline (position-worse? a b)
  (< (position-heuristic a) (position-heuristic b)))

(define (worst-position ls)
  (let lp ((ls (cdr ls)) (best (car ls)))
    (cond
      ((null? ls) best)
      ((position-worse? (car ls) best) (lp (cdr ls) (car ls)))
      (else (lp (cdr ls) best)))))

(define (min-value pos player depth alpha beta)
  (and-let* ((moves (chess-board-moves pos player)))
    (if (zero? depth)
      (let ((move (worst-position moves)))
        (values move (position-heuristic move)))
      (let ((opponent (player-complement player))
            (depth2 (- depth 1)))
        (let loop ((m moves) (worst (car moves)) (beta beta))
          (if (null? m)
            (values worst beta)
            (receive (riposte h)
                (max-value (car m) opponent depth2 alpha beta)
              (cond
                ((< h beta)
                 (if (<= h alpha)
                   (values (car m) alpha)
                   (loop (cdr m) (car m) h)))
                (else
                 (loop (cdr m) worst beta))))))))))

(define (alpha-beta-search pos player depth)
  (receive (move score)
      ((if (player-white? player) max-value min-value)
       pos player depth min-h max-h)
    move))

(define *invalid-move-syntax*
  "  Invalid move: ~A\n  I only understand algebraic notation (e.g. e4, Nf3, etc.)\n\n")
(define *illegal-move*
  "  Illegal move: ~A\n\n")

(define (load-position file)
  (with-input-from-file file
    (lambda ()
      (and-let* ((line (read-line))
                 ((not (eof-object? line)))
                 (str (car (string-split line " ")))
                 (ls (string-split str "/"))
                 ((= 8 (length ls)))
                 (bd (make-chess-board)))
        (let lp ((ls ls) (rank 7))
          (if (null? ls)
            (make-chess-position bd)
            (let lp2 ((ls2 (string->list (car ls))) (file 0))
              (if (null? ls2)
                (lp (cdr ls) (- rank 1))
                (let ((c (car ls2)))
                  (case c
                    ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8)
                     (lp2 (cdr ls2) (+ file (- (char->integer c)
                                               (char->integer #\0)))))
                    (else
                     (let ((piece (x->piece c (if (char-upper-case? c)
                                                player-white
                                                player-black))))
                       (if piece
                         (board-set! bd rank file piece))
                       (lp2 (cdr ls2) (+ file 1))))))))))))))

(define (main args)
  (let-args (cdr args)
      ((help? "help|h")
       (reverse-video? "reverse-video|rv")
       (black? "black|b")
       (xboard? "xboard|x")
       (no-display? "n|no-display")
       (verbose? "v|verbose")
       (depth "depth|d=i" 4)
       (position "position|p=s" #f)
       (ansi? "ansi|a" (member (getenv "TERM") '("xterm" "cxterm" "linux")))
       (unicode? "unicode|u")
       (else (option args continue)
             (warn "ignoring unknown option: ~S" option)
             (continue args))
       . rest)
    (set-signal-handler! signal/int #f)
    (set-signal-handler! signal/hup #f)
    (let* ((player (if black? player-black player-white))
           (computer (player-complement player)))
      (define (player-move pos i)
        (let loop ()
          (unless xboard? ; show prompt
            (printf "~A(~A): " (if (player-white? player) "White" "Black") i))
          (flush-output)
          (let ((resp (read-line)))
            (cond
              ((or (eof-object? resp) (member resp '("quit" "exit")))
               (exit 0))
              ((string=? resp "xboard")
               (set! xboard? #t)
               (newline)
               (loop))
              ((string-prefix? "protover" resp)
               (display "feature myname=kishi draw=0 done=1\n")
               (loop))
              ((string=? "new" resp)
               (set-initial-chess-position! pos)
               (loop))
              ((string=? "white" resp)
               (set! black? #f)
               (loop))
              ((string=? "black" resp)
               (set! black? #t)
               (loop))
              ((string-prefix? "level " resp) (loop))
              ((string-prefix? "st " resp) (loop))
              ((string-prefix? "sd " resp) (loop))
              ((string-prefix? "time " resp) (loop))
              ((string-prefix? "otim " resp) (loop))
              ((string-prefix? "ping " resp) (loop))
              ((string-prefix? "result " resp) (loop))
              ((string-prefix? "setboard " resp) (loop))
              ((string-prefix? "name " resp) (loop))
              ((string-prefix? "ics " resp) (loop))
              ((string-prefix? "accepted " resp) (loop))
              ((string-prefix? "rejected " resp) (loop))
              ((string-prefix? "variant " resp) (loop))
              ((string=? resp "edit")
               (let lp ((player player-white))
                 (let ((line (read-line)))
                   (if (eof-object? line)
                     (exit 0)
                     (cond
                       ((string=? line ".")
                        (let* ((bd (position-board pos))
                               (m-h (chess-material-heuristic bd))
                               (p-h (chess-positional-heuristic bd)))
                          (set-position-material! pos m-h)
                          (set-position-heuristic! pos (+ m-h p-h))))
                       ((string=? line "c")
                        (lp (player-complement player)))
                       ((string=? line "#")
                        (set-position-board! pos (make-chess-board))
                        (lp player))
                       ((= 3 (string-length line))
                        (let ((i (rank+file->index
                                  (chess-parse-rank (string-ref line 2))
                                  (chess-parse-file (string-ref line 1))))
                              (c (x->piece (string-ref line 0) player)))
                          (if (eqv? c #\x)
                            (u8vector-set! (position-board pos) i piece-none)
                            (and-let* ((p (x->piece c player)))
                              (u8vector-set! (position-board pos) i p))))
                        (lp player))
                       (else (lp player))))))
               (loop))
              ((string=? resp "bk")
               (newline)
               (loop))
              ((member resp '("random"
                              "force" "go" "playother" "?" "draw" "hint"
                              "undo" "remove" "hard" "easy" "post" "nonpost"
                              "analyze" "rating" "computer" "pause" "resume"))
               ;; do nothing
               (loop))
              (else ; assume a move
               (let ((move (chess-parse-move pos resp player)))
                 (cond
                   (move (chess-next-position pos move))
                   (else (printf (if (chess-notation-valid? resp)
                                   *illegal-move* *invalid-move-syntax*)
                                 resp)
                         (loop)))))))))
      (define (computer-move pos i)
        (let ((new (if verbose?
                     (time (alpha-beta-search pos computer depth))
                     (alpha-beta-search pos computer depth))))
          (cond
            (new
             (if xboard?
               (printf "move ~A\n"
                       (chess-format-move-xboard (position-board pos)
                                                 (position-last-move new)))
               (printf "~A(~A): ~A\n"
                       (if (player-white? computer) "White" "Black") i
                       (chess-format-move (position-board pos)
                                          (position-last-move new))))
             new)
            (else
             (display "Stalemate.  It's a draw.\n")
             (exit 0)))))
      (define (redisplay pos)
        (unless (or xboard? no-display?)
          (print-chess-board
           (position-board pos)
           center-col: " " top: "\n" bottom: "\n" left: "  " unicode?: unicode?
           ansi?: ansi? black?: black? reverse-video?: reverse-video?))
        (when verbose?
          (printf "heuristic: ~A\n" (position-heuristic pos))))
      (let ((order (if (player-white? player)
                     (list player-move computer-move)
                     (list computer-move player-move)))
            (start (if position
                     (load-position position)
                     (make-chess-position))))
        (unless black? (redisplay start))
        (let turn ((pos start) (i 1) (o order))
          (if (null? o)
            (turn pos (+ i 1) order)
            (let ((new ((car o) pos i)))
              (redisplay new)
              (if (chess-mate? new)
                (cond
                  (xboard?
                   (if (if (eq? (car o) player-move) (not black?) black?)
                     (print "1-0 {White mates}")
                     (print "0-1 {Black mates}"))
                   (turn new i (cdr o)))
                  (else
                   (printf "Checkmate!  ~A win!\n"
                           (if (eq? (car o) player-move) "You" "I"))
                   (exit 0)))
                (turn new i (cdr o)))))))
      0)))

(cond-expand
 (compiling
  (main (cons "kishi" (command-line-arguments))))
 (shared
  )
 (else
  (require-extension debug)
  (main (cons "kishi" (cddr (command-line-arguments))))))