chess.scm

;(import (gui))
(import (pos))

(require 'list-lib)

(define *board*
  (make-array (shape 0 8 0 8) '()))

(define *board-status*
  (list (list 'turn 'white)
        (list 'selected-pos '())
        (list 'white-krook #f)
        (list 'white-qrook #f)
        (list 'white-king #f)
        (list 'black-krook #f)
        (list 'black-qrook #f)
        (list 'black-king #f)
        (list 'en-passant-col -1)))

(define (starting-color i j)
  (case i
    ((0 1) 'black)
    ((6 7) 'white)
    (else '())))

(define (starting-piece i j)
  (case i
    ((1 6) 'pawn)
    ((0 7) (case j
             ((0 7) 'rook)
             ((1 6) 'knight)
             ((2 5) 'bishop)
             ((3) 'queen)
             ((4) 'king)))
    (else '())))

(define (starting-status i j)
  (let ((col (starting-color i j))
        (pie (starting-piece i j)))
    (if (or (null? col) (null? pie))
        '()
        (list col pie))))

(define (initialize-board)
  (do-board (pos '())
            (let ((col (apply starting-color pos))
                  (pie (apply starting-piece pos)))
              (array-set! *board* (yvalue pos) (xvalue pos)
                          (apply starting-status pos)))))

(define (color-of val)
  (car val))

(define (piece-of val)
  (car (cdr val)))

(define (get-at i j)
  (array-ref *board* i j))

(define (get-piece i j)
  (and (not (null? (get-at i j)))
       (piece-of (get-at i j))))

(define (get-color i j)
  (and (not (null? (get-at i j)))
       (color-of (get-at i j))))

(define (next-turn!)
  (let ((turn-cell (cdr (assoc 'turn *board-status*))))
    (set-car! turn-cell (other-color (car turn-cell))))
  (beginning-of-turn))

(define (other-color col)
  (case col
    ((black) 'white)
    ((white) 'black)))

(define (whose-turn)
  (car (cdr (assoc 'turn *board-status*))))

(define (selected)
  (car (cdr (assoc 'selected-pos *board-status*))))

(define (set-selected! pos)
  (let ((sel-cell (cdr (assoc 'selected-pos *board-status*))))
    (set-car! sel-cell pos)))

(define-syntax preserve-board
  (syntax-rules ()
    ((_ body ...)
     (let ((board (make-array (shape 0 8 0 8) '()))
           (board-status (map (lambda (x) (map (lambda (y) y) x)) *board-status*)))
       (do-board (pos '())
                 (array-set! board (yvalue pos) (xvalue pos) (apply get-at pos)))
       (fluid-let ((*board* board)
                   (*board-status* board-status))
         body ...)))))

(define-syntax do-board
  (syntax-rules ()
    ((_ (var final) body ...)
     (do ((i 0 (+ i 1)))
         ((>= i 8) final)
       (do ((j 0 (+ j 1)))
           ((>= j 8))
         (let ((var (position i j)))
           body ...))))))

(define (color-string col)
  (case col
    ((black) "Black")
    ((white) "White")))

(define (can-move-to? pos0 pos1)
  (if (or (null? pos0) (null? pos1))
      #f
      (let ((val (apply get-at pos0)))
        (if (null? val)
            #f
            (case (piece-of val)
              ((pawn) (can-move-pawn? val pos0 pos1))
              ((bishop) (can-move-bishop? val pos0 pos1))
              ((knight) (can-move-knight? val pos0 pos1))
              ((rook) (can-move-rook? val pos0 pos1))
              ((queen) (can-move-queen? val pos0 pos1))
              ((king) (can-move-king? val pos0 pos1))
              (else #f))))))

(define (can-legally-move? pos0 pos1)
  (if (or (null? pos0) (null? pos1))
      #f
      (let ((col (apply get-color pos0)))
        (and (can-move-to? pos0 pos1)
             (not (would-be-in-check? col pos0 pos1))))))

(define (move-to! pos0 pos1)
  (let ((value (apply get-at pos0)))
    (array-set! *board* (yvalue pos0) (xvalue pos0) '())
    (array-set! *board* (yvalue pos1) (xvalue pos1) value))
  (cond
   ((and (eq? (apply get-piece pos1) 'king)
         (= (abs (xvalue (-- pos1 pos0))) 2))
    ; Castle
    (case (xvalue pos1)
      ((2) (move-to! (position (yvalue pos1) 0)
                     (position (yvalue pos1) 3)))
      ((6) (move-to! (position (yvalue pos1) 7)
                     (position (yvalue pos1) 5)))))
   ((and (eq? (apply get-piece pos1) 'pawn)
         (= (abs (xvalue (-- pos1 pos0))) 1)
         (= (abs (yvalue (-- pos1 pos0))) 1)
         (= (xvalue pos1) (en-passant-column)))
    ; En Passant
    (case (apply get-color pos1)
      ((white) (array-set! *board* (+ (yvalue pos1) 1) (xvalue pos1) '()))
      ((black) (array-set! *board* (- (yvalue pos1) 1) (xvalue pos1) '()))))))

(define (full-move! pos0 pos1)
  (move-to! pos0 pos1)
  (update-castle! pos0)
  (update-castle! pos1)
  (update-en-passant! pos0 pos1)
  (promote-pawn! pos1))

(define (in-check? col)
  (let* ((king-piece `(,col king))
         (king-pos (let ((loc #f))
                     (do-board (pos loc)
                               (if (equal? (apply get-at pos) king-piece)
                                   (set! loc (or loc pos))
                                   '())))))
    (let ((check #f))
      (do-board (pos check)
                (if (and (equal? (apply get-color pos) (other-color col))
                         (can-move-to? pos king-pos))
            (set! check #t)
            '())))))

(define (would-be-in-check? col pos0 pos1)
  (if (not (can-move-to? pos0 pos1))
      #f
      (preserve-board
       (move-to! pos0 pos1)
       (in-check? col))))

(define (can-move-from? pos0)
  (let ((found-move #f))
    (do-board (pos1 found-move)
              (if (can-legally-move? pos0 pos1)
                  (set! found-move #t)
                  '()))))

(define (has-legal-move? col)
  (let ((found-move #f))
    (do-board (pos0 found-move)
              (if (and (eq? (apply get-color pos0) col)
                       (can-move-from? pos0))
                  (set! found-move #t)
                  '()))))

(define (checkmate? col)
  (and (in-check? col)
       (not (has-legal-move? col))))

(define (stalemate? col)
  (and (not (in-check? col))
       (not (has-legal-move? col))))

(define (beginning-of-turn)
  (cond
   ((checkmate? (whose-turn))
    (show-message (string-append (color-string (other-color (whose-turn)))
                                 " wins!"))
    (exit-game))
   ((stalemate? (whose-turn))
    (show-message "Stalemate!")
    (exit-game))))

(define (update-en-passant! pos0 pos1)
  (let ((passant-cell (cdr (assoc 'en-passant-col *board-status*))))
    (set-car! passant-cell
              (if (and (eq? (apply get-piece pos1) 'pawn)
                       (= (abs (yvalue (-- pos1 pos0))) 2))
                  (xvalue pos1)
                  -1))))

(define (promote-pawn! pos1)
  (if (and (eq? (apply get-piece pos1) 'pawn)
           (or (= (yvalue pos1) 0)
               (= (yvalue pos1) 7)))
      (let ((new-piece (promotion-dialogue)))
        (array-set! *board* (yvalue pos1) (xvalue pos1) (list (apply get-color pos1) new-piece)))
      '()))

(define (update-castle! pos)
  (cond
   ((equal? pos (position 0 0))
    (set-car! (cdr (assoc 'black-qrook *board-status*)) #t))
   ((equal? pos (position 7 0))
    (set-car! (cdr (assoc 'white-qrook *board-status*)) #t))
   ((equal? pos (position 0 7))
    (set-car! (cdr (assoc 'black-krook *board-status*)) #t))
   ((equal? pos (position 7 7))
    (set-car! (cdr (assoc 'white-krook *board-status*)) #t))
   ((equal? pos (position 0 4))
    (set-car! (cdr (assoc 'black-king *board-status*)) #t))
   ((equal? pos (position 7 4))
    (set-car! (cdr (assoc 'white-king *board-status*)) #t))
   (else '())))

(define (can-castle-queenside? col)
  (case col
    ((black) (not (or (car (cdr (assoc 'black-qrook *board-status*)))
                      (car (cdr (assoc 'black-king  *board-status*))))))
    ((white) (not (or (car (cdr (assoc 'white-qrook *board-status*)))
                      (car (cdr (assoc 'white-king  *board-status*))))))))

(define (can-castle-kingside? col)
  (case col
    ((black) (not (or (car (cdr (assoc 'black-krook *board-status*)))
                      (car (cdr (assoc 'black-king  *board-status*))))))
    ((white) (not (or (car (cdr (assoc 'white-krook *board-status*)))
                      (car (cdr (assoc 'white-king  *board-status*))))))))

(define (en-passant-column)
  (car (cdr (assoc 'en-passant-col *board-status*))))

(define (can-move-pawn? val pos0 pos1)
  (let ((diff (-- pos1 pos0))
        (col (apply get-color pos0))
        (at-pos (apply get-at pos1)))
    (cond
     ((and (eq? col 'white)
           (null? at-pos)
           (equal? diff (position -1 0)))
      #t)
     ((and (eq? col 'black)
           (null? at-pos)
           (equal? diff (position 1 0)))
      #t)
     ((and (eq? col 'white)
           (null? at-pos)
           (= (yvalue pos0) 6)
           (null? (apply get-at (++ pos0 (position -1 0))))
           (equal? diff (position -2 0)))
      #t)
     ((and (eq? col 'black)
           (null? at-pos)
           (= (yvalue pos0) 1)
           (null? (apply get-at (++ pos0 (position 1 0))))
           (equal? diff (position 2 0)))
      #t)
     ((and (eq? col 'white)
           (not (null? at-pos))
           (eq? (color-of at-pos) (other-color col))
           (or (equal? diff (position -1 -1))
               (equal? diff (position -1  1))))
      #t)
     ((and (eq? col 'black)
           (not (null? at-pos))
           (eq? (color-of at-pos) (other-color col))
           (or (equal? diff (position  1 -1))
               (equal? diff (position  1  1))))
      #t)
     ((and (eq? col 'black)
           (null? at-pos)
           (equal? diff (position  1 -1))
           (equal? (apply get-at (++ pos0 (position 0 -1))) '(white pawn))
           (= (en-passant-column) (xvalue pos1)))
      #t)
     ((and (eq? col 'black)
           (null? at-pos)
           (equal? diff (position  1  1))
           (equal? (apply get-at (++ pos0 (position 0  1))) '(white pawn))
           (= (en-passant-column) (xvalue pos1)))
      #t)
     ((and (eq? col 'white)
           (null? at-pos)
           (equal? diff (position -1  1))
           (equal? (apply get-at (++ pos0 (position 0  1))) '(black pawn))
           (= (en-passant-column) (xvalue pos1)))
      #t)
     ((and (eq? col 'white)
           (null? at-pos)
           (equal? diff (position -1 -1))
           (equal? (apply get-at (++ pos0 (position 0 -1))) '(black pawn))
           (= (en-passant-column) (xvalue pos1)))
      #t)
     (else #f))))

(define (can-move-bishop? val pos0 pos1)
  (let ((diff (-- pos1 pos0)))
    (cond
     ((eq? (apply get-color pos0) (apply get-color pos1))
      #f)
     ((= (abs (xvalue diff)) (abs (yvalue diff)))
      (let ((xdir (sgn (xvalue diff)))
            (ydir (sgn (yvalue diff))))
        (do ((okay #t)
             (y1 (+ (yvalue pos0) ydir) (+ y1 ydir))
             (x1 (+ (xvalue pos0) xdir) (+ x1 xdir)))
            ((or (= x1 (xvalue pos1))
                 (= y1 (yvalue pos1))) okay)
          (if (not (null? (get-at y1 x1)))
              (set! okay #f)
              '()))))
     (else #f))))

(define (can-move-knight? val pos0 pos1)
  (let ((diff (-- pos1 pos0)))
    (cond
     ((eq? (apply get-color pos0) (apply get-color pos1)) #f)
     ((= (abs (xvalue diff)) 3) #f)
     ((= (abs (yvalue diff)) 3) #f)
     ((= (+ (abs (xvalue diff)) (abs (yvalue diff))) 3) #t)
     (else #f))))

(define (can-move-rook? val pos0 pos1)
  (cond
   ((eq? (apply get-color pos0) (apply get-color pos1))
    #f)
   ((eq? (xvalue pos0) (xvalue pos1))
    (let ((dir (sgn (- (yvalue pos1) (yvalue pos0)))))
      (do ((okay #t)
           (i (+ (yvalue pos0) dir) (+ i dir)))
          ((eq? i (yvalue pos1)) okay)
        (if (not (null? (get-at i (xvalue pos0))))
            (set! okay #f)
            '()))))
   ((eq? (yvalue pos0) (yvalue pos1))
    (let ((dir (sgn (- (xvalue pos1) (xvalue pos0)))))
      (do ((okay #t)
           (i (+ (xvalue pos0) dir) (+ i dir)))
          ((eq? i (xvalue pos1)) okay)
        (if (not (null? (get-at (yvalue pos0) i)))
            (set! okay #f)
            '()))))
   (else #f)))

(define (can-move-queen? val pos0 pos1)
  (or (can-move-bishop? val pos0 pos1)
      (can-move-rook? val pos0 pos1)))

(define (can-move-king? val pos0 pos1)
  (let ((diff (-- pos1 pos0)))
    (cond
     ((eq? (apply get-color pos0) (apply get-color pos1)) #f)
     ((and (<= (abs (xvalue diff)) 1)
           (<= (abs (yvalue diff)) 1)) #t)
     ((and (null? (apply get-at pos1))
           (= (yvalue diff) 0)
           (= (xvalue diff) 2)
           (null? (apply get-at (++ pos0 (position 0 1))))
           (not (in-check? (color-of val)))
           (not (would-be-in-check? (color-of val) pos0 (++ pos0 (position 0 1))))
           (can-castle-kingside? (color-of val)))
      #t)
     ((and (null? (apply get-at pos1))
           (= (yvalue diff) 0)
           (= (xvalue diff) -2)
           (null? (apply get-at (++ pos0 (position 0 -1))))
           (null? (apply get-at (++ pos0 (position 0 -3))))
           (not (in-check? (color-of val)))
           (not (would-be-in-check? (color-of val) pos0 (++ pos0 (position 0 -1))))
           (can-castle-queenside? (color-of val)))
      #t)
     (else #f))))