chapter-2: Add start of section 2.4.

1 files changed, 262 insertions, 0 deletions

diff --git a/chapter-2/2.4-abstracting-a-domain.scm b/chapter-2/2.4-abstracting-a-domain.scm
new file mode 100644
index 0000000..3b86024
--- /dev/null
+++ b/chapter-2/2.4-abstracting-a-domain.scm
@@ -0,0 +1,262 @@
+;;; 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