path: root/chapter-2/2.4-abstracting-a-domain.scm

;;; 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 (board-replace-piece new-piece old-piece board)
  (make-board (cons new-piece (delq old-piece (board-pieces board)))))

(define (board-remove-piece piece board)
  (make-board (delq 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 (board-replace-piece new-piece old-piece 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-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 (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 (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

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

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

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

(define (move-piece piece new-coords)
  (make-piece (piece-type piece)
              new-coords
              (piece-owner piece)))

(define (piece-new-type piece type)
  (make-piece type (piece-coords piece) (piece-owner piece)))

(define (piece-king? piece)
  (eq? (piece-type piece) 'king))

(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 (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 (crown-piece piece)
  (piece-new-type piece 'king))

(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-record-type <change>
  (make-change board piece flags)
  change?
  (board get-board)
  (piece get-piece)
  (flags get-flags))

(define-record-type <pmove>
  (make-pmove initial-board initial-piece changes)
  pmove?
  (initial-board initial-board)
  (initial-piece initial-piece)
  (changes pmove-changes))

(define (initial-pmove board piece)
  (make-pmove board piece '()))

(define (is-pmove-empty? pmove)
  (null? (pmove-changes pmove)))

(define (is-pmove-finished? pmove)
  (and (not (is-pmove-empty? pmove))
       (pair? (memq 'finish (get-flags (car (pmove-changes pmove)))))))

(define (most-recent-change pmove)
  (car (pmove-changes pmove)))

(define (current-board pmove)
  (if (is-pmove-empty? pmove)
      (initial-board pmove)
      (get-board (most-recent-change pmove))))

(define (current-piece pmove)
  (if (is-pmove-empty? pmove)
      (initial-piece pmove)
      (get-piece (most-recent-change pmove))))

(define (add-change change pmove)
  (make-pmove (initial-board pmove)
              (initial-piece pmove)
              (cons change (pmove-changes pmove))))

(define (update-piece procedure pmove)
  (let* ((new-piece (procedure (current-piece pmove)))
         (new-board (board-replace-piece new-piece
                                         (current-piece pmove)
                                         (current-board pmove))))
    (add-change (make-change new-board new-piece '(update))
                pmove)))

(define (new-piece-position coords pmove)
  (update-piece (lambda (piece) (move-piece piece coords)) pmove))

(define (finish-move pmove)
  (add-change (make-change (current-board pmove)
                           (current-piece pmove)
                           '(finish))
              pmove))

(define (captures-pieces? pmove)
  (any (lambda (change)
         (memq 'capture (get-flags change)))
       (pmove-changes pmove)))

(define (capture-piece-at coords pmove)
  (let ((board (current-board pmove)))
    (add-change (make-change (board-remove-piece (board-get coords board) board)
                             (current-piece pmove)
                             '(capture))
                pmove)))

(define (evolve-pmove pmove evolution-rules)
  (append-map (lambda (new-pmove)
                (if (is-pmove-finished? new-pmove)
                    (list new-pmove)
                    (evolve-pmove new-pmove evolution-rules)))
              (append-map (lambda (evolution-rule)
                            (evolution-rule pmove))
                          evolution-rules)))

(define (execute-rules initial-pmoves evolution-rules aggregate-rules)
  ((reduce compose identity aggregate-rules)
   (append-map (lambda (pmove)
                 (evolve-pmove pmove evolution-rules))
               initial-pmoves)))

;; Rules of checkers

(define *evolution-rules* '())

(define-syntax-rule (define-evolution-rule name game procedure)
  (set! *evolution-rules*
        (cons (list name 'game procedure)
              *evolution-rules*)))

(define (evolution-rules-for-game game)
  (filter-map (lambda (rule)
                (and (eq? (second rule) game)
                     (third rule)))
              *evolution-rules*))

(define *aggregate-rules* '())

(define-syntax-rule (define-aggregate-rule name game procedure)
  (set! *aggregate-rules*
        (cons (list name 'game procedure)
              *aggregate-rules*)))

(define (aggregate-rules-for-game game)
  (filter-map (lambda (rule)
                (and (eq? (second rule) game)
                     (third rule)))
              *aggregate-rules*))

(define (offset* offset scale)
  (coords (* (coords-x offset) scale)
          (* (coords-y offset) scale)))

(define (compute-new-position direction distance pmove)
  (coords+ (piece-coords (current-piece pmove))
           (offset* direction distance)))

(define (get-simple-moves pmove)
  (filter-map
   (lambda (direction)
     (let ((landing (compute-new-position direction 1 pmove))
           (board (current-board pmove)))
       (and (is-position-on-board? landing board)
            (is-position-unoccupied? landing board)
            (finish-move (new-piece-position landing pmove)))))
   (possible-directions (current-piece pmove))))

(define-evolution-rule 'simple-move checkers
  (lambda (pmove)
    (if (is-pmove-empty? pmove)
        (get-simple-moves pmove)
        '())))

(define (get-jumps pmove)
  (filter-map
   (lambda (direction)
     (let ((possible-jump (compute-new-position direction 1 pmove))
           (landing (compute-new-position direction 2 pmove))
           (board (current-board pmove)))
       (and (is-position-on-board? landing board)
            (is-position-unoccupied? landing board)
            (is-position-occupied-by-opponent? possible-jump board)
            (capture-piece-at possible-jump
                              (new-piece-position landing pmove)))))
   (possible-directions (current-piece pmove))))

(define-evolution-rule 'jump checkers
  (lambda (pmove)
    (let ((jumps (get-jumps pmove)))
      (cond
       ((not (null? jumps))
        jumps)
       ((is-pmove-empty? pmove)
        '()) ; abandon this pmove
       (else
        (list (finish-move pmove)))))))

(define-aggregate-rule 'coronation checkers
  (lambda (pmoves)
    (map (lambda (pmove)
           (let ((piece (current-piece pmove)))
             (if (should-be-crowned? piece)
                 (update-piece crown-piece pmove)
                 pmove)))
         pmoves)))

(define-aggregate-rule 'require-jumps checkers
  (lambda (pmoves)
    (let ((jumps (filter captures-pieces? pmoves)))
      (if (null? jumps)
          pmoves
          jumps))))

(define (describe-pmove pmove)
  (display "initial piece coords: (")
  (display (coords-x (piece-coords (initial-piece pmove))))
  (display ", ")
  (display (coords-y (piece-coords (initial-piece pmove))))
  (display ")")
  (newline)
  (display (length (pmove-changes pmove)))
  (display " changes:")
  (newline)
  (let loop ((prev-piece (initial-piece pmove))
             (changes (reverse (pmove-changes pmove))))
    (unless (null? changes)
      (let* ((change (car changes))
             (piece (get-piece change)))
        (case (first (get-flags change))
          ((update)
           (cond
            ((not (equal? (piece-coords prev-piece)
                          (piece-coords piece)))
             (display "move to (")
             (display (coords-x (piece-coords piece)))
             (display ", ")
             (display (coords-y (piece-coords piece)))
             (display ")"))
            ((not (eq? (piece-type prev-piece)
                       (piece-type piece)))
             (display "type changed to ")
             (display (piece-type piece)))))
          ((capture)
           (display "capture"))
          ((finish)
           (display "finish")))
        (newline)
        (loop piece (cdr changes))))))

;; Re-using the same scenario that I did with the previous
;; implementation.
(let* ((p (make-piece 'regular (coords 4 5) 'player))
       (o0 (make-piece 'regular (coords 6 7) 'opponent))
       (o1 (make-piece 'regular (coords 3 6) 'opponent))
       (o2 (make-piece 'regular (coords 5 6) 'opponent))
       (board (make-board (list p o0 o1 o2))))
  (for-each describe-pmove
            (execute-rules (list (initial-pmove board p))
                           (evolution-rules-for-game 'checkers)
                           (aggregate-rules-for-game 'checkers))))

;; Exercise 2.12: A bit of chess

;; a. Construct an analogous referee to generate the legal moves for a
;; rook.  Don't try to implement the castling rule.

(define (piece-rook? piece)
  (eq? (piece-type piece) 'rook))

(define (get-moves/rook pmove)
  (if (piece-rook? (initial-piece pmove))
      (append-map
       (lambda (direction)
         (let loop ((distance 1))
           (let ((landing (compute-new-position direction distance pmove))
                 (board (current-board pmove)))
             (if (is-position-on-board? landing board)
                 (cond
                  ((is-position-unoccupied? landing board)
                   (cons (finish-move (new-piece-position landing pmove))
                         (loop (+ distance 1))))
                  ((is-position-occupied-by-opponent? landing board)
                   (list (finish-move
                          (new-piece-position landing
                                              (capture-piece-at landing pmove)))))
                  ((is-position-occupied-by-self? landing board)
                   (loop (+ distance 1))))
                 '()))))
       (list (coords 1 0)
             (coords -1 0)
             (coords 0 1)
             (coords 0 -1)))
      '()))

(define-evolution-rule 'move-rook chess
  (lambda (pmove)
    (if (is-pmove-empty? pmove)
        (get-moves/rook pmove)
        '())))

(let* ((prook (make-piece 'rook (coords 4 4) 'player))
       (orook (make-piece 'rook (coords 6 4) 'opponent))
       (board (make-board (list prook orook))))
  (for-each describe-pmove
            (execute-rules (list (initial-pmove board prook))
                           (evolution-rules-for-game 'chess)
                           (aggregate-rules-for-game 'chess))))

;; b. Augment your referee to model the behavior of a knight

(define (piece-knight? piece)
  (eq? (piece-type piece) 'knight))

(define (get-moves/knight pmove)
  (if (piece-knight? (initial-piece pmove))
      (filter-map
       (lambda (direction)
         (let ((landing (compute-new-position direction 1 pmove))
               (board (current-board pmove)))
           (and (is-position-on-board? landing board)
                (cond
                 ((is-position-unoccupied? landing board)
                  (finish-move (new-piece-position landing pmove)))
                 ((is-position-occupied-by-opponent? landing board)
                  (finish-move
                   (new-piece-position landing
                                       (capture-piece-at landing pmove))))
                 ((is-position-occupied-by-self? landing board)
                  #f)))))
       (list (coords 1 2)
             (coords 1 -2)
             (coords -1 -2)
             (coords -1 2)
             (coords 2 1)
             (coords 2 -1)
             (coords -2 -1)
             (coords -2 1)))
      '()))

(define-evolution-rule 'move-knight chess
  (lambda (pmove)
    (if (is-pmove-empty? pmove)
        (get-moves/knight pmove)
        '())))

(let* ((pknight (make-piece 'knight (coords 4 4) 'player))
       (oknight (make-piece 'knight (coords 6 5) 'opponent))
       (board (make-board (list pknight oknight))))
  (for-each describe-pmove
            (execute-rules (list (initial-pmove board pknight))
                           (evolution-rules-for-game 'chess)
                           (aggregate-rules-for-game 'chess))))

;; Exercise 2:13: More chess

;; I get the idea.  No one is grading me and I don't feel like making
;; a full chess implementation. ^_^

;; Exercise 2.14: An advanced project

;; I want to move on, sorry!