diff options
| -rw-r--r-- | chapter-2/2.4-abstracting-a-domain.scm | 262 |
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 |