summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chapter-2/2.4-abstracting-a-domain.scm262
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