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