summaryrefslogtreecommitdiff
path: root/chapter-2
diff options
context:
space:
mode:
Diffstat (limited to 'chapter-2')
-rw-r--r--chapter-2/2.4-abstracting-a-domain.scm409
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!