#lang scheme

(define vector-map
  (lambda (f v1)
    (let ([n (vector-length v1)])
      (let ([v2 (make-vector n)])
        (let loop ([i 0])
          (if (= i n)
              v2
              (begin
                (vector-set! v2 i (f (vector-ref v1 i)))
                (loop (+ i 1)))))))))

(define copy-board
  (lambda (b)
    (vector-map (lambda (x) (vector-map values x)) b)))

(define board-ref
  (lambda (b i j)
    (vector-ref (vector-ref b i) j)))

(define board-set!
  (lambda (b i j v)
    (vector-set! (vector-ref b i) j v)))

(define initial-board
  (let ([b (copy-board (make-vector 8 (make-vector 8 '_)))])
    (board-set! b 3 3 'W)
    (board-set! b 4 4 'W)
    (board-set! b 3 4 'B)
    (board-set! b 4 3 'B)
    b))

(define print-board
  (lambda (b)
    (printf "*")
    (let f ([col 0])
      (unless (= col 8)
        (printf " ~s" col)
        (f (+ col 1))))
    (printf "\n")
    (let f ([row 0])
      (unless (= row 8)
        (printf "~s" row)
        (let f ([col 0])
          (unless (= col 8)
            (printf " ~s" (board-ref b row col))
            (f (+ col 1))))
        (printf "\n")
        (f (+ row 1))))))

(define in-range?
  (lambda (row col) 
    (and (<= 0 row 7) (<= 0 col 7))))

(define can-move?
  (lambda (b player row col)
    (define capturing?
      (lambda (row col drow dcol seen-opponent?)
        (let ([row (+ row drow)] [col (+ col dcol)])
          (cond
            [(not (in-range? row col)) #f]
            [(eq? (board-ref b row col) player) seen-opponent?]
            [(eq? (board-ref b row col) '_) #f]
            [else (capturing? row col drow dcol #t)]))))
    (and (eq? (board-ref b row col) '_)
         (or (capturing? row col 1 1 #f)
             (capturing? row col 1 -1 #f)
             (capturing? row col -1 1 #f)
             (capturing? row col -1 -1 #f)
             (capturing? row col 1 0 #f)
             (capturing? row col -1 0 #f)
             (capturing? row col 0 1 #f)
             (capturing? row col 0 -1 #f)))))

(define apply-move
  (lambda (b player move)
    (define apply-dir!
      (lambda (b row col drow dcol)
        (let ([row (+ row drow)] [col (+ col dcol)])
          (cond
            [(not (in-range? row col)) #f]
            [(eq? (board-ref b row col) player) #t]
            [(eq? (board-ref b row col) '_) #f]
            [else
             (if (apply-dir! b row col drow dcol)
                 (begin (board-set! b row col player) #t)
                 #f)]))))
    (let ([b (copy-board b)] [row (car move)] [col (cdr move)])
      (board-set! b row col player)
      (apply-dir! b row col 1 1)
      (apply-dir! b row col -1 1)
      (apply-dir! b row col 1 -1)
      (apply-dir! b row col -1 -1)
      (apply-dir! b row col 1 0)
      (apply-dir! b row col -1 0)
      (apply-dir! b row col 0 1)
      (apply-dir! b row col 0 -1)
      b)))

(define possible-moves
  (lambda (b player)
    (let f ([row 0])
      (if (= row 8)
          '()
          (let g ([col 0])
            (if (= col 8)
                (f (+ row 1))
                (if (can-move? b player row col)
                    (cons (cons row col) (g (+ col 1)))
                    (g (+ col 1)))))))))

(define piece-worth
  (lambda (x)
    (if (eq? x 'W) 1 (if (eq? x 'B) -1 0))))

(define game-count
  (lambda (b)
    (let f ([row 0] [count 0])
      (if (= row 8)
          count
          (let g ([col 0] [count count])
            (if (= col 8)
                (f (+ row 1) count)
                (let ([x (board-ref b row col)])
                  (g (+ col 1)
                     (+ count (piece-worth x))))))))))

(define winner 
  (lambda (b)
    (let ([count (game-count b)])
      (cond
        [(= count 0) "nobody"]
        [(> count 0) "white"]
        [else        "black"]))))

(define opponent
  (lambda (p)
    (if (eq? p 'W) 'B 'W)))

(define game-driver
  (lambda (white-player black-player)
    (define select-move
      (lambda (b player moves)
        (if (= (length moves) 1)
            (car moves)
            (if (eq? player 'W)
                (white-player b 'W moves)
                (black-player b 'B moves)))))
    (define loop
      (lambda (b player skipped?)
        (printf "=================\nPlayer ~s's turn\n" player)
        (print-board b)
        (let ([moves (possible-moves b player)])
          (if (null? moves)
              (if skipped?
                  (printf "GAME OVER: ~a wins\n" (winner b))
                  (loop b (opponent player) #t))
              (let ([move (select-move b player moves)])
                (printf "~s plays ~s\n" player move)
                (let ([b (apply-move b player move)])
                  (loop b (opponent player) #f)))))))
    (loop initial-board 'W #f)))

(define first-move-player
  (lambda (b player moves)
    (car moves)))

(define random-move-player
  (lambda (b player moves)
    (list-ref moves (random (length moves)))))

(define human-player
  (lambda (b player moves)
    (printf "Options for ~s:\n" player)
    (let f ([i 0] [moves moves])
      (unless (null? moves)
        (printf "~s. ~s\n" i (car moves))
        (f (+ i 1) (cdr moves))))
    (printf "Enter a number:\n")
    (let ([x (read)])
      (if (and (integer? x) (exact? x) (< -1 x (length moves)))
          (list-ref moves x)
          (begin
            (printf "Invalid selection!\n")
            (human-player b player moves))))))

(define minimax
  (lambda (b player moves max-depth heuristic-function)
    (define max/min 
      (lambda (player)
        (if (eq? player 'W) max min)))
    (define minimax-move
      (lambda (b player max-depth move)
        (minimax/depth 
          (apply-move b player move)
          (opponent player)
          (- max-depth 1))))
    (define minimax/depth
      (lambda (b player max-depth)
        (if (= max-depth 0)
            (heuristic-function b)
            (let ([moves (possible-moves b player)])
              (if (null? moves) 
                  (minimax/depth b (opponent player) (- max-depth 1))
                  (let ([scores 
                         (map (lambda (move)
                                (minimax-move b player max-depth move))
                              moves)])
                    (apply (max/min player) scores)))))))
    (let ([scores 
           (map (lambda (move) (minimax-move b player max-depth move)) 
                moves)])
      (let ([best (apply (max/min player) scores)])
        (let loop ([moves moves] [scores scores])
          (if (= (car scores) best)
              (car moves)
              (loop (cdr moves) (cdr scores))))))))

(define minimax-player/count-4
  (lambda (b player moves)
    (minimax b player moves 4 game-count)))

(define minimax-player/count-5
  (lambda (b player moves)
    (minimax b player moves 5 game-count)))

(define minimax-player/count-6
  (lambda (b player moves)
    (minimax b player moves 6 game-count)))

;(game-driver minimax-player/count-6 minimax-player/count-5)
;(game-driver minimax-player/count-5 minimax-player/count-6)
;(game-driver random-move-player minimax-player/count-6)
;(game-driver human-player random-move-player)