From 2505a8cad55dda8a066258cb50ac2f64989fb9f3 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Tue, 9 Aug 2022 22:08:01 -0400
Subject: chapter-2: Finish section 2.4.

---
 chapter-2/2.4-abstracting-a-domain.scm | 409 ++++++++++++++++++++++++++++++++-
 1 file changed, 401 insertions(+), 8 deletions(-)

diff --git a/chapter-2/2.4-abstracting-a-domain.scm b/chapter-2/2.4-abstracting-a-domain.scm
index 3b86024..93bc787 100644
--- a/chapter-2/2.4-abstracting-a-domain.scm
+++ b/chapter-2/2.4-abstracting-a-domain.scm
@@ -100,6 +100,12 @@
           (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
@@ -127,7 +133,7 @@
   (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))))))
+  (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)
@@ -167,13 +173,6 @@
                 (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)))
@@ -186,6 +185,13 @@
                       (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)
@@ -260,3 +266,390 @@
 
 
 ;; 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!
-- 
cgit v1.2.3