diff --git a/collects/games/chat-noir/README b/collects/games/chat-noir/README index 5a36221639..e1f9b96c67 100644 --- a/collects/games/chat-noir/README +++ b/collects/games/chat-noir/README @@ -30,8 +30,6 @@ Problems: build the documentation, ie, this file should eventually be merged together with ../scribblings/chat-noir.scrbl. - - @chunks in the TOC - hyperlink bound top-level identifiers to their bindings? - diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index b80a3a2e04..1fe156a9b6 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -7,8 +7,6 @@ Chat Noir. What a game. -@schememodname[htdp/world] - @chunk[
@@ -16,8 +14,8 @@ Chat Noir. What a game. ] @section{The World} - -The main data structure for Chat Noir is @tt{world}. + +The main data structure for Chat Noir is @tt{world}. @chunk[ (define-struct world (board cat state size mouse-posn h-down?) @@ -26,23 +24,30 @@ The main data structure for Chat Noir is @tt{world}. It consists of a structure with six fields: @itemize[ -@item{@tt{board}: representing the state of the board as a list of @tt{cell}s, one for each circle on the game. } -@item{@tt{cat}: -a @scheme[posn] indicating the position of the cat (interpreting the @scheme[posn] in the way -that they are interpreted for the @tt{board} field),} + +@item{@tt{board}: representing the state of the board as a list of + @tt{cell}s, one for each circle on the game. } + +@item{@tt{cat}: a @scheme[posn] indicating the position of the cat + (interpreting the @scheme[posn] in the way that they are interpreted + for the @tt{board} field),} + @item{@tt{state}: the state of the game, which can be one of -@itemize{ -@item{@scheme['playing], indicating that the game is still going; this is the initial state. - } -@item{@scheme['cat-won], indicating that the game is over and the cat won, or} -@item{@scheme['cat-lost], indicating that the game is over and the cat lost.}} - } + @itemize[ + @item{@scheme['playing], indicating that the game is still going; this is the + initial state.} + @item{@scheme['cat-won], indicating that the game is over and the + cat won, or} + @item{@scheme['cat-lost], indicating that the game is over and the + cat lost.}]} + @item{@tt{size}: an odd natural number indicating the size of the board} -@item{@tt{mouse-posn}: -a @scheme[posn] for the location of the mouse (or @scheme[#f] if the -mouse is not in the window), and} -@item{@tt{h-down?}: a boolean indicating if the @tt{h} -key is being pushed down.} + +@item{@tt{mouse-posn}: a @scheme[posn] for the location of the + mouse (or @scheme[#f] if the mouse is not in the window), and} + +@item{@tt{h-down?}: a boolean indicating if the @tt{h} key is being + pushed down.} ] A @tt{cell} is a structure with two fields: @@ -50,50 +55,42 @@ A @tt{cell} is a structure with two fields: @chunk[ (define-struct cell (p blocked?) #:transparent)] -The first field contains a @scheme[posn] struct. -The coordinates of the posn indicate a position on the -hexagonal grid. -The @tt{y} field of the @scheme[posn] -refers to the row of the cell, and the -@tt{x} coordinate the position in the row. -This means that, for example, -@scheme[(make-posn 0 1)] -is centered above -@scheme[(make-posn 1 0)] and -@scheme[(make-posn 1 1)]. See @scheme[cell-center-x] -and @scheme[cell-center-y] below for the conversion -of those positions to screen coordinates. +The first field contains a @scheme[posn] struct. The coordinates of +the posn indicate a position on the hexagonal grid. The @tt{y} field +of the @scheme[posn] refers to the row of the cell, and the @tt{x} +coordinate the position in the row. This means that, for example, +@scheme[(make-posn 0 1)] is centered above @scheme[(make-posn 1 0)] +and @scheme[(make-posn 1 1)]. See @scheme[cell-center-x] and +@scheme[cell-center-y] below for the conversion of those positions to +screen coordinates. -The @tt{blocked?} field is a boolean indicating if -the cell has been clicked on, thus blocking the cat -from stepping there. +The @tt{blocked?} field is a boolean indicating if the cell has been +clicked on, thus blocking the cat from stepping there. @section{Graph} -The cat's move decision is based on a breadth-first -search of a graph. The graph's nodes are the cells -on the board, and there are edges between each pair -of adjacent cells, unless one of the cells is blocked, -in which case there are no edges. +The cat's move decision is based on a breadth-first search of a graph. +The graph's nodes are the cells on the board, and there are edges +between each pair of adjacent cells, unless one of the cells is +blocked, in which case there are no edges. -The breadth-first function constructs a @scheme[distance-map], -which is a list of @scheme[dist-cell] structs: +The breadth-first function constructs a @scheme[distance-map], which +is a list of @scheme[dist-cell] structs: @chunk[ (define-struct dist-cell (p n) #:transparent)] Each @tt{p} field in the @scheme[dist-cell] is a position on the board and the @tt{n} field is a natural number or @scheme['∞], indicating -the distance of the shortest path from the node to some fixed point -on the board. The fixed point is not represented in the @scheme[distance-map], but -is required when constructing one. +the distance of the shortest path from the node to some fixed point on +the board. The fixed point is not represented in the +@scheme[distance-map], but is required when constructing one. The core of the breadth-first search is this function, @scheme[bst]. It accepts a @scheme[queue] and a @chunk[ - (define (bfs queue dist-table) (cond [(empty? queue) dist-table] @@ -103,8 +100,8 @@ The core of the breadth-first search is this function, [(boolean? (hash-ref dist-table (queue-ent-posn hd) #f)) (local [(define dist (queue-ent-dist hd)) (define p (queue-ent-posn hd))] - (bfs - (append (rest queue) + (bfs + (append (rest queue) (map (lambda (p) (make-queue-ent p (+ dist 1))) (neighbors/w p))) (hash-set dist-table p dist)))] @@ -113,7 +110,7 @@ The core of the breadth-first search is this function, @chunk[ -;; a distance-map is +;; a distance-map is ;; (listof dist-cells) ;; a dist-cell is @@ -126,12 +123,12 @@ The core of the breadth-first search is this function, (local [;; posn : posn ;; dist : number (define-struct queue-ent (posn dist) #:transparent) - + (define neighbors/w (neighbors world)) - + ] - - (hash-map + + (hash-map (bfs (list (make-queue-ent init-point 0)) (make-immutable-hash/list-init)) make-dist-cell))) @@ -149,41 +146,43 @@ The core of the breadth-first search is this function, ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(check-expect (same-sets? - (build-bfs-table (make-world (empty-board 3) (make-posn 1 1) 'playing 3 (make-posn 0 0) false) +(check-expect (same-sets? + (build-bfs-table (make-world (empty-board 3) (make-posn 1 1) + 'playing 3 (make-posn 0 0) false) 'boundary) (list (make-dist-cell 'boundary 0) - + (make-dist-cell (make-posn 1 0) 1) (make-dist-cell (make-posn 2 0) 1) - + (make-dist-cell (make-posn 0 1) 1) (make-dist-cell (make-posn 1 1) 2) (make-dist-cell (make-posn 2 1) 1) - + (make-dist-cell (make-posn 1 2) 1) (make-dist-cell (make-posn 2 2) 1))) true) -(check-expect (same-sets? - (build-bfs-table (make-world (empty-board 3) (make-posn 1 1) 'playing 3 (make-posn 0 0) false) +(check-expect (same-sets? + (build-bfs-table (make-world (empty-board 3) (make-posn 1 1) + 'playing 3 (make-posn 0 0) false) (make-posn 1 1)) (list (make-dist-cell 'boundary 2) (make-dist-cell (make-posn 1 0) 1) (make-dist-cell (make-posn 2 0) 1) - + (make-dist-cell (make-posn 0 1) 1) (make-dist-cell (make-posn 1 1) 0) (make-dist-cell (make-posn 2 1) 1) - + (make-dist-cell (make-posn 1 2) 1) (make-dist-cell (make-posn 2 2) 1))) true) -(check-expect (same-sets? +(check-expect (same-sets? (build-bfs-table (make-world (list (make-cell (make-posn 0 1) true) (make-cell (make-posn 1 0) true) @@ -202,7 +201,7 @@ The core of the breadth-first search is this function, (make-dist-cell 'boundary 0))) true) -(check-expect (same-sets? +(check-expect (same-sets? (build-bfs-table (make-world (empty-board 5) (make-posn 2 2) 'playing @@ -217,13 +216,13 @@ The core of the breadth-first search is this function, (make-dist-cell (make-posn 2 0) 1) (make-dist-cell (make-posn 3 0) 1) (make-dist-cell (make-posn 4 0) 1) - + (make-dist-cell (make-posn 0 1) 1) (make-dist-cell (make-posn 1 1) 2) (make-dist-cell (make-posn 2 1) 2) (make-dist-cell (make-posn 3 1) 2) (make-dist-cell (make-posn 4 1) 1) - + (make-dist-cell (make-posn 0 2) 1) (make-dist-cell (make-posn 1 2) 2) (make-dist-cell (make-posn 2 2) 3) @@ -236,14 +235,13 @@ The core of the breadth-first search is this function, (make-dist-cell (make-posn 3 3) 2) (make-dist-cell (make-posn 4 3) 1) - (make-dist-cell (make-posn 1 4) 1) (make-dist-cell (make-posn 2 4) 1) (make-dist-cell (make-posn 3 4) 1) (make-dist-cell (make-posn 4 4) 1))) true) -(check-expect (same-sets? +(check-expect (same-sets? (build-bfs-table (make-world (block-cell (make-posn 4 2) (empty-board 5)) @@ -260,13 +258,13 @@ The core of the breadth-first search is this function, (make-dist-cell (make-posn 2 0) 1) (make-dist-cell (make-posn 3 0) 1) (make-dist-cell (make-posn 4 0) 1) - + (make-dist-cell (make-posn 0 1) 1) (make-dist-cell (make-posn 1 1) 2) (make-dist-cell (make-posn 2 1) 2) (make-dist-cell (make-posn 3 1) 2) (make-dist-cell (make-posn 4 1) 1) - + (make-dist-cell (make-posn 0 2) 1) (make-dist-cell (make-posn 1 2) 2) (make-dist-cell (make-posn 2 2) 3) @@ -278,14 +276,13 @@ The core of the breadth-first search is this function, (make-dist-cell (make-posn 3 3) 2) (make-dist-cell (make-posn 4 3) 1) - (make-dist-cell (make-posn 1 4) 1) (make-dist-cell (make-posn 2 4) 1) (make-dist-cell (make-posn 3 4) 1) (make-dist-cell (make-posn 4 4) 1))) true) -(check-expect (same-sets? +(check-expect (same-sets? (build-bfs-table (make-world (empty-board 5) (make-posn 2 2) 'playing @@ -295,18 +292,18 @@ The core of the breadth-first search is this function, (make-posn 2 2)) (list (make-dist-cell 'boundary 3) - + (make-dist-cell (make-posn 1 0) 2) (make-dist-cell (make-posn 2 0) 2) (make-dist-cell (make-posn 3 0) 2) (make-dist-cell (make-posn 4 0) 3) - + (make-dist-cell (make-posn 0 1) 2) (make-dist-cell (make-posn 1 1) 1) (make-dist-cell (make-posn 2 1) 1) (make-dist-cell (make-posn 3 1) 2) (make-dist-cell (make-posn 4 1) 3) - + (make-dist-cell (make-posn 0 2) 2) (make-dist-cell (make-posn 1 2) 1) (make-dist-cell (make-posn 2 2) 0) @@ -319,7 +316,6 @@ The core of the breadth-first search is this function, (make-dist-cell (make-posn 3 3) 2) (make-dist-cell (make-posn 4 3) 3) - (make-dist-cell (make-posn 1 4) 2) (make-dist-cell (make-posn 2 4) 2) (make-dist-cell (make-posn 3 4) 2) @@ -339,7 +335,7 @@ The core of the breadth-first search is this function, ;; lookup-in-table : distance-map posn -> number or '∞ -;; looks for the distance as recorded in the table t, +;; looks for the distance as recorded in the table t, ;; if not found returns a distance of '∞ (define (lookup-in-table t p) (cond @@ -360,14 +356,14 @@ The core of the breadth-first search is this function, ;; p : world -> posn -> boolean -;; returns true when the posn is on the shortest path +;; returns true when the posn is on the shortest path ;; from the cat to the edge of the board, in the given world (define (on-cats-path? w) (cond [(world-h-down? w) (local [(define edge-distance-map (build-bfs-table w 'boundary)) (define cat-distance-map (build-bfs-table w (world-cat w))) - (define cat-distance (lookup-in-table edge-distance-map + (define cat-distance (lookup-in-table edge-distance-map (world-cat w)))] (cond [(equal? cat-distance '∞) @@ -380,13 +376,16 @@ The core of the breadth-first search is this function, [else (lambda (p) false)])) -(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) 'playing 5 (make-posn 0 0) true)) +(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) + 'playing 5 (make-posn 0 0) true)) (make-posn 1 0)) true) -(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) 'playing 5 (make-posn 0 0) false)) +(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) + 'playing 5 (make-posn 0 0) false)) (make-posn 1 0)) false) -(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) 'playing 5 (make-posn 0 0) true)) +(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) + 'playing 5 (make-posn 0 0) true)) (make-posn 2 1)) false) (check-expect ((on-cats-path? @@ -409,18 +408,19 @@ The core of the breadth-first search is this function, ;; neighbors : world -> (or/c 'boundary posn) -> (listof (or/c 'boundary posn)) ;; computes the neighbors of a posn, for a given board size (define (neighbors w) - (local [(define blocked + (local [(define blocked (map cell-p - (filter (lambda (c) + (filter (lambda (c) (or (cell-blocked? c) (equal? (cell-p c) (world-mouse-posn w)))) (world-board w)))) - (define boundary-cells (filter (lambda (p) - (and (not (member p blocked)) - (on-boundary? p (world-size w)))) - (map cell-p (world-board w))))] + (define boundary-cells + (filter (lambda (p) + (and (not (member p blocked)) + (on-boundary? p (world-size w)))) + (map cell-p (world-board w))))] (lambda (p) - (cond + (cond [(member p blocked) '()] [(equal? p 'boundary) @@ -445,14 +445,14 @@ The core of the breadth-first search is this function, (check-expect ((neighbors (empty-world 11)) (make-posn 2 2)) (adjacent (make-posn 2 2) 11)) (check-expect ((neighbors (empty-world 3)) 'boundary) - (list (make-posn 0 1) - (make-posn 1 0) - (make-posn 1 2) - (make-posn 2 0) - (make-posn 2 1) + (list (make-posn 0 1) + (make-posn 1 0) + (make-posn 1 2) + (make-posn 2 0) + (make-posn 2 1) (make-posn 2 2))) (check-expect ((neighbors (empty-world 11)) (make-posn 1 0)) - (list 'boundary + (list 'boundary (make-posn 2 0) (make-posn 0 1) (make-posn 1 1))) @@ -489,7 +489,7 @@ The core of the breadth-first search is this function, ;; adjacent : posn number -> (listof posn) -;; returns a list of the posns that are adjacent to +;; returns a list of the posns that are adjacent to ;; `p' on an infinite hex grid (define (adjacent p board-size) (local [(define x (posn-x p)) @@ -575,7 +575,7 @@ The core of the breadth-first search is this function, (cond [(or (equal? x '∞) (equal? y '∞)) '∞] - [else + [else (+ x y)])) (check-expect (+/f '∞ '∞) '∞) @@ -588,7 +588,7 @@ The core of the breadth-first search is this function, @chunk[ (require htdp/world lang/posn) -(define-syntax (check-expect stx) +(define-syntax (check-expect stx) (syntax-case stx () [(_ actual expected) (with-syntax ([line (syntax-line stx)]) @@ -615,7 +615,7 @@ The core of the breadth-first search is this function, check-expects))) (define (run-check-expects) - (for-each (λ (t) (t)) + (for-each (λ (t) (t)) (reverse check-expects))) (define (make-immutable-hash/list-init [init '()]) @@ -665,7 +665,7 @@ The core of the breadth-first search is this function, ;; render-world : world -> image (define (render-world w) (chop-whiskers - (overlay (board->image (world-board w) + (overlay (board->image (world-board w) (world-size w) (on-cats-path? w) (world-mouse-posn w)) @@ -690,7 +690,7 @@ The core of the breadth-first search is this function, 2 (lambda (x) true) false) - (move-pinhole thinking-cat + (move-pinhole thinking-cat (- (cell-center-x (make-posn 0 1))) (- (cell-center-y (make-posn 0 1)))))) @@ -707,7 +707,7 @@ The core of the breadth-first search is this function, 2 (lambda (x) true) false) - (move-pinhole happy-cat + (move-pinhole happy-cat (- (cell-center-x (make-posn 0 1))) (- (cell-center-y (make-posn 0 1)))))) @@ -724,7 +724,7 @@ The core of the breadth-first search is this function, 2 (lambda (x) true) false) - (move-pinhole sad-cat + (move-pinhole sad-cat (- (cell-center-x (make-posn 0 1))) (- (cell-center-y (make-posn 0 1)))))) @@ -755,7 +755,7 @@ The core of the breadth-first search is this function, 3 (lambda (x) false) false) - (move-pinhole sad-cat + (move-pinhole sad-cat (- (cell-center-x (make-posn 1 1))) (- (cell-center-y (make-posn 1 1)))))) @@ -775,7 +775,7 @@ The core of the breadth-first search is this function, (make-posn (cell-center-x (make-posn 0 1)) (cell-center-y (make-posn 0 1))) true)) - + (overlay (board->image (list (make-cell (make-posn 0 1) false) @@ -789,17 +789,17 @@ The core of the breadth-first search is this function, (lambda (x) true) (make-posn (cell-center-x (make-posn 0 1)) (cell-center-y (make-posn 0 1)))) - (move-pinhole sad-cat + (move-pinhole sad-cat (- (cell-center-x (make-posn 1 1))) (- (cell-center-y (make-posn 1 1)))))) ;; chop-whiskers : image -> image ;; crops the image so that anything above or to the left of the pinhole is gone (define (chop-whiskers img) - (shrink img - 0 + (shrink img 0 - (- (image-width img) (pinhole-x img) 1) + 0 + (- (image-width img) (pinhole-x img) 1) (- (image-height img) (pinhole-y img) 1))) (check-expect (chop-whiskers (rectangle 5 5 'solid 'black)) @@ -809,7 +809,7 @@ The core of the breadth-first search is this function, (check-expect (pinhole-x - (render-world + (render-world (make-world (empty-board 3) (make-posn 0 0) @@ -838,15 +838,16 @@ The core of the breadth-first search is this function, (world-height world-size) 'solid 'white) - (map (lambda (c) (cell->image c - (on-cat-path? (cell-p c)) - (and (posn? mouse) - (equal? mouse (cell-p c))) - #; - (and (posn? mouse) - (point-in-this-circle? (cell-p c) - (posn-x mouse) - (posn-y mouse))))) + (map (lambda (c) + (cell->image c + (on-cat-path? (cell-p c)) + (and (posn? mouse) + (equal? mouse (cell-p c))) + #; + (and (posn? mouse) + (point-in-this-circle? (cell-p c) + (posn-x mouse) + (posn-y mouse))))) cs))) (check-expect (board->image (list (make-cell (make-posn 0 0) false)) @@ -927,20 +928,21 @@ The core of the breadth-first search is this function, (define (cell->image c on-short-path? under-mouse?) (local [(define x (cell-center-x (cell-p c))) (define y (cell-center-y (cell-p c))) - (define main-circle + (define main-circle (cond [(cell-blocked? c) (circle circle-radius 'solid blocked-color)] [else (circle circle-radius 'solid normal-color)]))] - (move-pinhole + (move-pinhole (cond [under-mouse? (overlay main-circle (circle (quotient circle-radius 2) 'solid under-mouse-color))] [on-short-path? (overlay main-circle - (circle (quotient circle-radius 2) 'solid on-shortest-path-color))] + (circle (quotient circle-radius 2) 'solid + on-shortest-path-color))] [else main-circle]) (- x) @@ -956,19 +958,21 @@ The core of the breadth-first search is this function, (- circle-radius))) (check-expect (cell->image (make-cell (make-posn 0 0) false) true false) (move-pinhole (overlay (circle circle-radius 'solid normal-color) - (circle (quotient circle-radius 2) 'solid on-shortest-path-color)) + (circle (quotient circle-radius 2) 'solid + on-shortest-path-color)) (- circle-radius) (- circle-radius))) (check-expect (cell->image (make-cell (make-posn 0 0) false) true true) (move-pinhole (overlay (circle circle-radius 'solid normal-color) - (circle (quotient circle-radius 2) 'solid under-mouse-color)) + (circle (quotient circle-radius 2) 'solid + under-mouse-color)) (- circle-radius) (- circle-radius))) ;; world-width : number -> number ;; computes the width of the drawn world in terms of its size (define (world-width board-size) - (local [(define rightmost-posn + (local [(define rightmost-posn (make-posn (- board-size 1) (- board-size 2)))] (+ (cell-center-x rightmost-posn) circle-radius))) @@ -1006,7 +1010,7 @@ The core of the breadth-first search is this function, (define (cell-center-y p) (local [(define y (posn-y p))] (+ circle-radius - (* y circle-spacing 2 + (* y circle-spacing 2 .866 ;; .866 is an exact approximate to sin(pi/3) )))) @@ -1043,8 +1047,8 @@ The core of the breadth-first search is this function, (cond [(and (equal? 'playing (world-state world)) (point-in-a-circle? (world-board world) x y)) - (move-cat - (update-world-posn + (move-cat + (update-world-posn (make-world (add-obstacle (world-board world) x y) (world-cat world) (world-state world) @@ -1099,11 +1103,13 @@ The core of the breadth-first search is this function, 1 (make-posn 0 0) false)) -(check-expect (clack (make-world '() (make-posn 0 0) 'playing 1 (make-posn 0 0) false) +(check-expect (clack (make-world '() (make-posn 0 0) + 'playing 1 (make-posn 0 0) false) 1 1 'leave) (make-world '() (make-posn 0 0) 'playing 1 false false)) -(check-expect (clack (make-world '() (make-posn 0 0) 'playing 1 (make-posn 0 0) false) +(check-expect (clack (make-world '() (make-posn 0 0) + 'playing 1 (make-posn 0 0) false) 10 10 'button-down) @@ -1116,7 +1122,7 @@ The core of the breadth-first search is this function, 3 (make-posn 0 0) false) - (cell-center-x (make-posn 0 0)) + (cell-center-x (make-posn 0 0)) (cell-center-y (make-posn 0 0)) 'button-up) (make-world (list (make-cell (make-posn 0 0) true) @@ -1128,12 +1134,14 @@ The core of the breadth-first search is this function, false)) -(check-expect (clack (make-world '() (make-posn 0 0) 'cat-lost 1 (make-posn 0 0) false) +(check-expect (clack (make-world '() (make-posn 0 0) + 'cat-lost 1 (make-posn 0 0) false) 10 10 'button-up) - (make-world '() (make-posn 0 0) 'cat-lost 1 (make-posn 0 0) false)) -(check-expect (clack + (make-world '() (make-posn 0 0) + 'cat-lost 1 (make-posn 0 0) false)) +(check-expect (clack (make-world (list (make-cell (make-posn 1 0) false) (make-cell (make-posn 2 0) true) @@ -1150,7 +1158,7 @@ The core of the breadth-first search is this function, (cell-center-x (make-posn 1 0)) (cell-center-y (make-posn 1 0)) 'button-up) - (make-world + (make-world (list (make-cell (make-posn 1 0) true) (make-cell (make-posn 2 0) true) (make-cell (make-posn 0 1) true) @@ -1164,7 +1172,7 @@ The core of the breadth-first search is this function, (make-posn 1 0) false)) -(check-expect (clack +(check-expect (clack (make-world (list (make-cell (make-posn 1 0) false) (make-cell (make-posn 2 0) false) @@ -1181,7 +1189,7 @@ The core of the breadth-first search is this function, (cell-center-x (make-posn 1 0)) (cell-center-y (make-posn 1 0)) 'button-up) - (make-world + (make-world (list (make-cell (make-posn 1 0) true) (make-cell (make-posn 2 0) false) (make-cell (make-posn 0 1) true) @@ -1201,8 +1209,8 @@ The core of the breadth-first search is this function, [(equal? (world-state w) 'playing) (cond [(posn? p) - (local [(define mouse-spot - (circle-at-point (world-board w) + (local [(define mouse-spot + (circle-at-point (world-board w) (posn-x p) (posn-y p)))] (make-world (world-board w) @@ -1224,32 +1232,42 @@ The core of the breadth-first search is this function, (world-h-down? w))])] [else w])) -(check-expect (update-world-posn - (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'playing 1 false false) +(check-expect (update-world-posn + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) 'playing 1 false false) (make-posn (cell-center-x (make-posn 0 0)) (cell-center-y (make-posn 0 0)))) - (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'playing 1 (make-posn 0 0) false)) + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) 'playing 1 (make-posn 0 0) false)) -(check-expect (update-world-posn - (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 0) 'playing 1 false false) +(check-expect (update-world-posn + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 0) 'playing 1 false false) (make-posn (cell-center-x (make-posn 0 0)) (cell-center-y (make-posn 0 0)))) - (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 0) 'playing 1 false false)) + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 0) 'playing 1 false false)) -(check-expect (update-world-posn - (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'playing 1 (make-posn 0 0) false) +(check-expect (update-world-posn + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) 'playing 1 (make-posn 0 0) false) (make-posn 0 0)) - (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'playing 1 false false)) -(check-expect (update-world-posn - (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'cat-won 1 false false) + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) 'playing 1 false false)) +(check-expect (update-world-posn + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) 'cat-won 1 false false) (make-posn (cell-center-x (make-posn 0 0)) (cell-center-y (make-posn 0 0)))) - (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'cat-won 1 false false)) -(check-expect (update-world-posn - (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'cat-lost 1 false false) + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) 'cat-won 1 false false)) +(check-expect (update-world-posn + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) 'cat-lost 1 false false) (make-posn (cell-center-x (make-posn 0 0)) (cell-center-y (make-posn 0 0)))) - (make-world (list (make-cell (make-posn 0 0) false)) (make-posn 0 1) 'cat-lost 1 false false)) + (make-world (list (make-cell (make-posn 0 0) false)) + (make-posn 0 1) 'cat-lost 1 false false)) ;; move-cat : world -> world (define (move-cat world) @@ -1267,7 +1285,7 @@ The core of the breadth-first search is this function, (list-ref next-cat-positions (random (length next-cat-positions)))]))] (make-world (world-board world) - (cond + (cond [(boolean? next-cat-position) cat-position] [else next-cat-position]) @@ -1288,25 +1306,25 @@ The core of the breadth-first search is this function, (make-cell (make-posn 2 0) false) (make-cell (make-posn 3 0) false) (make-cell (make-posn 4 0) false) - + (make-cell (make-posn 0 1) false) (make-cell (make-posn 1 1) true) (make-cell (make-posn 2 1) true) (make-cell (make-posn 3 1) false) (make-cell (make-posn 4 1) false) - + (make-cell (make-posn 0 2) false) (make-cell (make-posn 1 2) true) (make-cell (make-posn 2 2) false) (make-cell (make-posn 3 2) true) (make-cell (make-posn 4 2) false) - + (make-cell (make-posn 0 3) false) (make-cell (make-posn 1 3) true) (make-cell (make-posn 2 3) false) (make-cell (make-posn 3 3) false) (make-cell (make-posn 4 3) false) - + (make-cell (make-posn 1 4) false) (make-cell (make-posn 2 4) false) (make-cell (make-posn 3 4) false) @@ -1320,25 +1338,25 @@ The core of the breadth-first search is this function, (make-cell (make-posn 2 0) false) (make-cell (make-posn 3 0) false) (make-cell (make-posn 4 0) false) - + (make-cell (make-posn 0 1) false) (make-cell (make-posn 1 1) true) (make-cell (make-posn 2 1) true) (make-cell (make-posn 3 1) false) (make-cell (make-posn 4 1) false) - + (make-cell (make-posn 0 2) false) (make-cell (make-posn 1 2) true) (make-cell (make-posn 2 2) false) (make-cell (make-posn 3 2) true) (make-cell (make-posn 4 2) false) - + (make-cell (make-posn 0 3) false) (make-cell (make-posn 1 3) true) (make-cell (make-posn 2 3) false) (make-cell (make-posn 3 3) false) (make-cell (make-posn 4 3) false) - + (make-cell (make-posn 1 4) false) (make-cell (make-posn 2 4) false) (make-cell (make-posn 3 4) false) @@ -1349,7 +1367,8 @@ The core of the breadth-first search is this function, (make-posn 0 0) false)) -;; find-best-positions : (nelistof posn) (nelistof number or '∞) -> (nelistof posn) or false +;; find-best-positions : (nelistof posn) (nelistof number or '∞) +;; -> (nelistof posn) or false (define (find-best-positions posns scores) (local [(define best-score (foldl (lambda (x sofar) (if (<=/f x sofar) @@ -1390,7 +1409,7 @@ The core of the breadth-first search is this function, (define (add-obstacle board x y) (cond [(empty? board) board] - [else + [else (local [(define cell (first board)) (define cx (cell-center-x (cell-p cell))) (define cy (cell-center-y (cell-p cell)))] @@ -1418,7 +1437,7 @@ The core of the breadth-first search is this function, (define (circle-at-point board x y) (cond [(empty? board) false] - [else + [else (cond [(point-in-this-circle? (cell-p (first board)) x y) (cell-p (first board))] @@ -1433,7 +1452,7 @@ The core of the breadth-first search is this function, 0 0) false) - + ;; point-in-a-circle? : board number number -> boolean (define (point-in-a-circle? board x y) (posn? (circle-at-point board x y))) @@ -1459,7 +1478,7 @@ The core of the breadth-first search is this function, true) (check-expect (point-in-this-circle? (make-posn 0 0) 0 0) false) - + ;; change : world key-event -> world (define (change w ke) (make-world (world-board w) @@ -1469,10 +1488,13 @@ The core of the breadth-first search is this function, (world-mouse-posn w) (key=? ke #\h))) -(check-expect (change (make-world '() (make-posn 1 1) 'playing 1 (make-posn 0 0) false) +(check-expect (change (make-world '() (make-posn 1 1) + 'playing 1 (make-posn 0 0) false) #\h) - (make-world '() (make-posn 1 1) 'playing 1 (make-posn 0 0) true)) -(check-expect (change (make-world '() (make-posn 1 1) 'playing 1 (make-posn 0 0) true) + (make-world '() (make-posn 1 1) + 'playing 1 (make-posn 0 0) true)) +(check-expect (change (make-world '() (make-posn 1 1) + 'playing 1 (make-posn 0 0) true) 'release) (make-world '() (make-posn 1 1) 'playing 1 (make-posn 0 0) false)) @@ -1502,24 +1524,24 @@ The core of the breadth-first search is this function, ;; cat : symbol -> image (define (cat mode) - (local [(define face-color + (local [(define face-color (cond [(symbol=? mode 'sad) 'pink] [else 'lightgray])) - + (define left-ear (regular-polygon 3 8 'solid 'black (/ pi -3))) (define right-ear (regular-polygon 3 8 'solid 'black 0)) (define ear-x-offset 14) (define ear-y-offset 9) - + (define eye (overlay (ellipse 12 8 'solid 'black) (ellipse 6 4 'solid 'limegreen))) (define eye-x-offset 8) (define eye-y-offset 3) - + (define nose (regular-polygon 3 5 'solid 'black (/ pi 2))) - - (define mouth-happy + + (define mouth-happy (overlay (ellipse 8 8 'solid face-color) (ellipse 8 8 'outline 'black) (move-pinhole @@ -1530,14 +1552,14 @@ The core of the breadth-first search is this function, (overlay (ellipse 8 8 'solid face-color) (ellipse 8 8 'outline face-color) (rectangle 10 5 'solid face-color))) - - (define mouth + + (define mouth (cond [(symbol=? mode 'happy) mouth-happy] [else mouth-no-expression])) (define mouth-x-offset 4) (define mouth-y-offset -5)] - + (add-line (add-line (add-line @@ -1618,15 +1640,17 @@ The core of the breadth-first search is this function, (cond [(zero? n) all-cells] [else - (local [(define unblocked-cells - (filter (lambda (x) - (let ([cat-cell? (and (= (posn-x (cell-p x)) (quotient board-size 2)) - (= (posn-y (cell-p x)) (quotient board-size 2)))]) - + (local [(define unblocked-cells + (filter (lambda (x) + (let ([cat-cell? (and (= (posn-x (cell-p x)) + (quotient board-size 2)) + (= (posn-y (cell-p x)) + (quotient board-size 2)))]) + (and (not (cell-blocked? x)) (not cat-cell?)))) all-cells)) - (define to-block (list-ref unblocked-cells + (define to-block (list-ref unblocked-cells (random (length unblocked-cells))))] (add-n-random-blocked-cells (sub1 n) @@ -1647,9 +1671,13 @@ The core of the breadth-first search is this function, (make-cell (make-posn 1 1) true) (make-cell (make-posn 2 2) false))) -(check-expect (add-n-random-blocked-cells 0 (list (make-cell (make-posn 0 0) true)) 10) +(check-expect (add-n-random-blocked-cells 0 (list (make-cell (make-posn 0 0) + true)) + 10) (list (make-cell (make-posn 0 0) true))) -(check-expect (add-n-random-blocked-cells 1 (list (make-cell (make-posn 0 0) false)) 10) +(check-expect (add-n-random-blocked-cells 1 (list (make-cell (make-posn 0 0) + false)) + 10) (list (make-cell (make-posn 0 0) true))) ;; empty-board : number -> (listof cell) @@ -1666,8 +1694,8 @@ The core of the breadth-first search is this function, (lambda (i) (build-list board-size - (lambda (j) - (make-cell (make-posn i j) + (lambda (j) + (make-cell (make-posn i j) false)))))))) (check-expect (empty-board 3) @@ -1721,11 +1749,11 @@ The core of the breadth-first search is this function, board-size false false))] - - (and + + (and (big-bang (world-width board-size) (world-height board-size) - 1 + 1 initial-world) (on-redraw render-world) (on-key-event change) diff --git a/collects/games/chat-noir/literate-lang.ss b/collects/games/chat-noir/literate-lang.ss index fee0227da7..cfe9697183 100644 --- a/collects/games/chat-noir/literate-lang.ss +++ b/collects/games/chat-noir/literate-lang.ss @@ -11,19 +11,19 @@ (define (mapping-get mapping id) (free-identifier-mapping-get mapping id (lambda () '()))) ;; maps a block identifier to its collected expressions - (define code-blocks (make-free-identifier-mapping)) + (define chunks (make-free-identifier-mapping)) ;; maps a block identifier to all identifiers that are used to define it (define block-groups (make-free-identifier-mapping)) (define (get-block id) - (map syntax-local-introduce (mapping-get code-blocks id))) + (map syntax-local-introduce (mapping-get chunks id))) (define (add-to-block! id exprs) (unless main-id (set! main-id id)) (free-identifier-mapping-put! block-groups id (cons (syntax-local-introduce id) (mapping-get block-groups id))) (free-identifier-mapping-put! - code-blocks id - `(,@(mapping-get code-blocks id) ,@(map syntax-local-introduce exprs))))) + chunks id + `(,@(mapping-get chunks id) ,@(map syntax-local-introduce exprs))))) (define-syntax (chunk stx) (syntax-case stx () @@ -35,7 +35,7 @@ #f "chunk names must begin and end with angle brackets, <...>" stx #'name)] [else (add-to-block! #'name (syntax->list #'(expr ...))) - #`(void)])])) + #'(void)])])) (define-syntax (tangle stx) (define block-mentions '()) @@ -44,15 +44,15 @@ (append-map (lambda (expr) (if (identifier? expr) - (let ([subs (get-block expr)]) - (if (pair? subs) - (begin (set! block-mentions (cons expr block-mentions)) - (loop subs)) - (list expr))) - (let ([subs (syntax->list expr)]) - (if subs - (list (loop subs)) - (list expr))))) + (let ([subs (get-block expr)]) + (if (pair? subs) + (begin (set! block-mentions (cons expr block-mentions)) + (loop subs)) + (list expr))) + (let ([subs (syntax->list expr)]) + (if subs + (list (loop subs)) + (list expr))))) block))) (with-syntax ([(body ...) body] ;; construct arrows manually @@ -67,34 +67,33 @@ (define-syntax (module-begin stx) (syntax-case stx () [(module-begin expr ...) - (let ([body-code - (let loop ([exprs (syntax->list #'(expr ...))]) - (cond - [(null? exprs) null] - [else - (let ([expanded - (local-expand (car exprs) - 'module - (append (kernel-form-identifier-list) - (syntax->list #'(provide - require - #%provide - #%require))))]) - (syntax-case expanded (begin) - [(begin rest ...) - (append (loop (syntax->list #'(rest ...))) - (loop (cdr exprs)))] - [(id . rest) - (ormap (lambda (kw) (free-identifier=? #'id kw)) - (syntax->list #'(require - provide - chunk - #%require - #%provide))) - (cons expanded (loop (cdr exprs)))] - [else (loop (cdr exprs))]))]))]) - - (with-syntax ([(body-code ...) body-code]) - #'(#%module-begin - body-code ... - (tangle))))])) + (with-syntax + ([(body-code ...) + (let loop ([exprs (syntax->list #'(expr ...))]) + (cond + [(null? exprs) null] + [else + (let ([expanded + (local-expand (car exprs) + 'module + (append (kernel-form-identifier-list) + (syntax->list #'(provide + require + #%provide + #%require))))]) + (syntax-case expanded (begin) + [(begin rest ...) + (append (loop (syntax->list #'(rest ...))) + (loop (cdr exprs)))] + [(id . rest) + (ormap (lambda (kw) (free-identifier=? #'id kw)) + (syntax->list #'(require + provide + chunk + #%require + #%provide))) + (cons expanded (loop (cdr exprs)))] + [else (loop (cdr exprs))]))]))]) + #'(#%module-begin + body-code ... + (tangle)))]))