;;; Copyright © 2021 Gerald Sussman and Chris Hanson
;;; Copyright © 2022 David Thompson <dthompson2@worcester.edu>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.


;; 2.4.1 A monolithic implementation

(use-modules (srfi srfi-1)
             (srfi srfi-9))

;; A checkers domain model

(define %checkers-board-width 8)
(define %checkers-board-height 8)

(define-record-type <coords>
  (coords x y)
  coords?
  (x coords-x)
  (y coords-y))

(define (coords+ a b)
  (coords (+ (coords-x a) (coords-x b))
          (+ (coords-y a) (coords-y b))))

(define-record-type <piece>
  (make-piece coords owner king?)
  piece?
  (coords piece-coords)
  (owner piece-owner)
  (king? piece-king?))

(define (player-piece? piece)
  (eq? (piece-owner piece) 'player))

(define (opponent-piece? piece)
  (eq? (piece-owner piece) 'opponent))

(define (should-be-crowned? piece)
  (and (not (piece-king? piece))
       (= (coords-y (piece-coords piece))
          (if (player-piece? piece)
              (- %checkers-board-height 1)
              0))))

(define (crown-piece piece)
  (make-piece (piece-coords piece)
              (piece-owner piece)
              #t))

(define (possible-directions piece)
  (cond
   ((piece-king? piece)
    (list (coords 1 1)
          (coords -1 1)
          (coords -1 -1)
          (coords 1 -1)))
   ((player-piece? piece)
    (list (coords 1 1)
          (coords -1 1)))
   (else
    (list (coords 1 -1)
          (coords -1 -1)))))

(define (move-piece piece new-coords)
  (make-piece new-coords
              (piece-owner piece)
              (piece-king? piece)))

(define-record-type <board>
  (make-board pieces)
  board?
  (pieces board-pieces))

(define (current-pieces board)
  (filter player-piece?
          (board-pieces board)))

(define (is-position-on-board? coords board)
  (and (>= (coords-x coords) 0)
       (< (coords-x coords) %checkers-board-width)
       (>= (coords-y coords) 0)
       (< (coords-y coords) %checkers-board-height)))

(define (board-get coords board)
  (find (lambda (piece)
          (equal? coords (piece-coords piece)))
        (board-pieces board)))

(define (position-info coords board)
  (let ((piece (board-get coords board)))
    (cond
     ((not piece) 'unoccupied)
     ((player-piece? piece) 'occupied-by-self)
     ((opponent-piece? piece) 'occupied-by-opponent))))

(define (is-position-unoccupied? coords board)
  (eq? (position-info coords board) 'unoccupied))

(define (is-position-occupied-by-self? coords board)
  (eq? (position-info coords board) 'occupied-by-self))

(define (is-position-occupied-by-opponent? coords board)
  (eq? (position-info coords board) 'occupied-by-opponent))

;; A checkers referee

(define-record-type <step>
  (make-step from to board jump?)
  step?
  (from step-from)
  (to step-to)
  (board step-board)
  (jump? step-jump?))

(define (replace-piece new-piece old-piece board)
  (let ((new-board (make-board (cons new-piece (delq old-piece (board-pieces board))))))
    (make-step old-piece new-piece new-board #f)))

(define (make-simple-move new-coords piece board)
  (replace-piece (move-piece piece new-coords) piece board))

(define (make-jump new-coords jumped-coords piece board)
  (let* ((new-piece (move-piece piece new-coords))
         (new-board (make-board (remove (lambda (piece)
                                          (equal? (piece-coords piece)
                                                  jumped-coords))
                                        (board-pieces board)))))
    (make-step piece new-piece new-board #t)))

(define (path-contains-jumps? path)
  (any step-jump? path))

(define (try-step piece board direction path)
  (let ((new-coords
         (coords+ (piece-coords piece) direction)))
    (and (is-position-on-board? new-coords board)
         (case (position-info new-coords board)
           ((unoccupied)
            (and (not (path-contains-jumps? path))
                 (cons (make-simple-move new-coords piece board)
                       path)))
           ((occupied-by-opponent)
            (let ((landing (coords+ new-coords direction)))
              (and (is-position-on-board? landing board)
                   (is-position-unoccupied? landing board)
                   (cons (make-jump landing new-coords piece board)
                         path))))
           ((occupied-by-self) #f)
           (else (error "Unknown position info"))))))

(define (compute-next-steps piece board path)
  (filter-map (lambda (direction)
                (try-step piece board direction path))
              (possible-directions piece)))

(define (evolve-paths piece board)
  (let* ((paths (compute-next-steps piece board '()))
         (jumps (filter path-contains-jumps? paths)))
    (if (null? jumps)
        paths
        (evolve-jumps jumps))))

(define (evolve-jumps paths)
  (append-map (lambda (path)
                (let ((paths (let ((step (car path)))
                               (compute-next-steps (step-to step)
                                                   (step-board step)
                                                   path))))
                  (if (null? paths)
                      (list path)
                      ;; continue jumping if possible
                      (evolve-jumps paths))))
              paths))

(define (mandate-jumps paths)
  (let ((jumps (filter path-contains-jumps? paths)))
    (if (null? jumps)
        paths
        jumps)))

(define (crown-kings paths)
  (map (lambda (path)
         (let ((piece (step-to (car path))))
           (if (should-be-crowned? piece)
               (cons (replace-piece (crown-piece piece)
                                    piece
                                    (step-board (car path)))
                     path)
               path)))
       paths))

(define (generate-moves board)
  (crown-kings
   (mandate-jumps
    (append-map (lambda (piece)
                  (evolve-paths piece board))
                (current-pieces board)))))

;; A quick thing I made up to make verifying that the paths are what I
;; expect a little easier.
(define (describe-path path)
  (display (length path))
  (display " steps:")
  (newline)
  (for-each (lambda (step)
              (let ((from (step-from step))
                    (to (step-to step)))
                (unless (eq? (piece-coords from) (piece-coords to))
                  (display "piece moved from (")
                  (display (coords-x (piece-coords from)))
                  (display ", ")
                  (display (coords-y (piece-coords from)))
                  (display ") to (")
                  (display (coords-x (piece-coords to)))
                  (display ", ")
                  (display (coords-y (piece-coords to)))
                  (display "); "))
                (when (and (not (piece-king? from)) (piece-king? to))
                  (display "king; "))
                (when (step-jump? step)
                  (display "jump; "))
                (newline)))
            (reverse path)))

;; Example:
;;
;; $: player piece
;; o: opponent piece
;;
;; ______o_
;; ___o_o__
;; ____$___
;; ________
;; ________
;; ________
;; ________
;; ________
;;
;; Should result in 1 path of 2 steps: a jump and then a king.
(for-each describe-path
          (generate-moves
           (make-board (list (make-piece (coords 4 5) 'player #f)
                             (make-piece (coords 6 7) 'opponent #f)
                             (make-piece (coords 3 6) 'opponent #f)
                             (make-piece (coords 5 6) 'opponent #f)))))


;; 2.4.2 Factoring out the domain