├── .gitignore ├── LICENSE.txt ├── chapter10 ├── graphics │ ├── dice1.png │ ├── dice2.png │ ├── dice3.png │ └── dice4.png ├── readme.txt └── source.rkt ├── chapter12 ├── readme.txt └── source.rkt ├── chapter13 ├── client.rkt ├── readme.txt ├── run.rkt ├── server.rkt └── shared.rkt ├── chapter14 ├── client.rkt ├── graphics │ ├── cupcake.gif │ └── hungry-henry.gif ├── readme.txt ├── run.rkt ├── server.rkt └── shared.rkt ├── chapter2 ├── readme.txt └── source.rkt ├── chapter5 ├── info.rkt ├── new-ufo-source.rkt ├── readme.txt ├── source.rkt └── ufo-source.rkt ├── chapter6 ├── graphics │ ├── body.gif │ ├── goo.gif │ ├── head.gif │ └── tail.gif ├── readme.txt └── source.rkt ├── chapter8 ├── graphics │ ├── brigand.bmp │ ├── hydra.png │ ├── orc.gif │ ├── orc.png │ ├── orcSprite.png │ ├── player.bmp │ └── slime.bmp ├── readme.txt └── source.rkt ├── info.rkt ├── readme.txt └── todo.txt /.gitignore: -------------------------------------------------------------------------------- 1 | # Racket compiled files 2 | compiled/ 3 | 4 | # common backups, autosaves, lock files, OS meta-files 5 | *~ 6 | \#* 7 | .#* 8 | .DS_Store 9 | *.bak 10 | TAGS 11 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | realm 2 | Copyright (c) 2010-2014 PLT Design Inc. 3 | 4 | This package is distributed under the GNU Lesser General Public 5 | License (LGPL). This means that you can link this package into proprietary 6 | applications, provided you follow the rules stated in the LGPL. You 7 | can also modify this package; if you distribute a modified version, 8 | you must distribute it under the terms of the LGPL, which in 9 | particular means that you must release the source code for the 10 | modified software. See http://www.gnu.org/copyleft/lesser.html 11 | for more information. 12 | -------------------------------------------------------------------------------- /chapter10/graphics/dice1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/realm/d4509a0c42171f4ffbdd67b9acb0b774957be02b/chapter10/graphics/dice1.png -------------------------------------------------------------------------------- /chapter10/graphics/dice2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/realm/d4509a0c42171f4ffbdd67b9acb0b774957be02b/chapter10/graphics/dice2.png -------------------------------------------------------------------------------- /chapter10/graphics/dice3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/realm/d4509a0c42171f4ffbdd67b9acb0b774957be02b/chapter10/graphics/dice3.png -------------------------------------------------------------------------------- /chapter10/graphics/dice4.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/realm/d4509a0c42171f4ffbdd67b9acb0b774957be02b/chapter10/graphics/dice4.png -------------------------------------------------------------------------------- /chapter10/readme.txt: -------------------------------------------------------------------------------- 1 | 2 | This chapter implements a GUI version of the "dice of doom" game from 3 | Barski's "Land of Lisp". To play or to experiment, open the file 4 | 5 | source.rkt 6 | 7 | in DrRacket. The instructions for playing are at the top of the file. 8 | Our tests are at the bottom of the file in a separate 'test' submodule. 9 | 10 | -------------------------------------------------------------------------------- /chapter12/readme.txt: -------------------------------------------------------------------------------- 1 | 2 | This chapter implements a GUI version of the "dice of doom" game from 3 | Barski's "Land of Lisp". This implementation uses a lazy game tree and 4 | adds an AI player. 5 | 6 | To play or to experiment, open the file 7 | 8 | source.rkt 9 | 10 | in DrRacket. The instructions for playing are at the top of the file. 11 | Our tests are at the bottom of the file in a separate 'test' submodule. 12 | 13 | 14 | -------------------------------------------------------------------------------- /chapter13/client.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; the client for distributed Guess my Number 4 | (require 2htdp/image 2htdp/universe "shared.rkt") 5 | 6 | (provide launch-guess-client) 7 | 8 | ; 9 | ; 10 | ; 11 | ; 12 | ; 13 | ; ;;;;;; ; 14 | ; ; ; ; 15 | ; ; ; ;;;; ;;;;;; ;;;; 16 | ; ; ; ; ; ; ; ; 17 | ; ; ; ; ; ; 18 | ; ; ; ;;;;;; ; ;;;;;; 19 | ; ; ; ; ; ; ; ; 20 | ; ; ; ; ;; ; ; ; ;; 21 | ; ;;;;;; ;;;; ;; ;;;; ;;;; ;; 22 | ; 23 | ; 24 | ; 25 | ; 26 | 27 | ;; ClientState = String 28 | (define ClientState0 "no guess available") 29 | 30 | ;; Constants 31 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 32 | (define TEXT-SIZE 11) 33 | (define HELP-TEXT 34 | (text "↑ for larger numbers, ↓ for smaller ones" 35 | TEXT-SIZE 36 | "blue")) 37 | (define HELP-TEXT2 38 | (text "Press = when your number is guessed; q to quit." 39 | TEXT-SIZE 40 | "blue")) 41 | (define WIDTH (+ (image-width HELP-TEXT2) 10)) 42 | (define HEIGHT 150) 43 | (define COLOR "red") 44 | (define SIZE 72) 45 | (define TEXT-X 3) 46 | (define TEXT-UPPER-Y 10) 47 | (define TEXT-LOWER-Y 135) 48 | (define MT-SC 49 | (place-image/align 50 | HELP-TEXT TEXT-X TEXT-UPPER-Y 51 | "left" "top" 52 | (place-image/align 53 | HELP-TEXT2 54 | TEXT-X TEXT-LOWER-Y "left" "bottom" 55 | (empty-scene WIDTH HEIGHT)))) 56 | 57 | 58 | ; 59 | ; 60 | ; 61 | ; ; 62 | ; ; 63 | ; ;;; ;;; 64 | ; ;; ;; 65 | ; ; ; ; ; ;;;; ;;; ;; ;;; 66 | ; ; ; ; ; ; ; ; ;; ; 67 | ; ; ; ; ; ; ; ; ; 68 | ; ; ; ; ;;;;;; ; ; ; 69 | ; ; ; ; ; ; ; ; 70 | ; ; ; ; ;; ; ; ; 71 | ; ;;; ;;; ;;;; ;; ;;;;;;; ;;; ;;; 72 | ; 73 | ; 74 | ; 75 | ; 76 | 77 | 78 | ;; String -> ClientState 79 | ;; Launch the Client. 80 | (define (launch-guess-client n host) 81 | (big-bang ClientState0 82 | (on-draw draw-guess) 83 | (on-key handle-keys) 84 | (name n) 85 | (register host) 86 | (on-receive handle-msg))) 87 | 88 | ;; handle-keys: ClientState Key -> [Package ClientState CtoSMessage] or ClientState 89 | ;; if the key is "up" or "down", ask the server for a different guess 90 | (define (handle-keys w key) 91 | (cond [(key=? key "up") (make-package w "up")] 92 | [(key=? key "down") (make-package w "down")] 93 | [(key=? key "q") (stop-with w)] 94 | [(key=? key "=") (stop-with w)] 95 | [else w])) 96 | 97 | ;; handle-msg: ClientState StoCMessage -> ClientState 98 | ;; if the message is a number, you got a new guess 99 | (define (handle-msg c msg) 100 | (number->string msg)) 101 | 102 | ;; draw-guess: ClientState -> Scene 103 | ;; renders the state as an image 104 | (define (draw-guess c) 105 | (overlay (text c SIZE COLOR) MT-SC)) 106 | 107 | ; 108 | ; 109 | ; 110 | ; 111 | ; 112 | ; ;;;;;;; ; 113 | ; ; ; ; ; 114 | ; ; ; ; ;;; ;;;; ; ;;;;;; ;;;; ; 115 | ; ; ; ; ; ; ; ;; ; ; ;; 116 | ; ; ; ; ; ; ; 117 | ; ; ;;;;;;; ;;;;; ; ;;;;; 118 | ; ; ; ; ; ; 119 | ; ; ; ; ; ; ; ; ; ; 120 | ; ;;;;; ;;;; ;;;;;; ;;;; ;;;;;; 121 | ; 122 | ; 123 | ; 124 | ; 125 | 126 | (module+ test 127 | 128 | (require rackunit rackunit/text-ui) 129 | 130 | ;; testing the client's key-handling 131 | 132 | (check-equal? (handle-keys "55" "up") (make-package "55" "up")) 133 | (check-equal? (handle-keys "47" "down") (make-package "47" "down")) 134 | (check-equal? (handle-keys "10" "=") (stop-with "10")) 135 | (check-equal? (handle-keys "66" "k") "66") 136 | 137 | ;; testing the client's message handling 138 | 139 | (check-equal? (handle-msg "100" 99) "99") 140 | (check-equal? (handle-msg "30" -34) "-34") 141 | 142 | ;; testing the client's rendering function 143 | 144 | (check-equal? (draw-guess ClientState0) (overlay (text ClientState0 SIZE COLOR) MT-SC)) 145 | (check-equal? (draw-guess "50") (overlay (text "50" SIZE COLOR) MT-SC)) 146 | (check-equal? (draw-guess "25") (overlay (text "25" SIZE COLOR) MT-SC)) 147 | 148 | "client: all tests run") 149 | -------------------------------------------------------------------------------- /chapter13/readme.txt: -------------------------------------------------------------------------------- 1 | 2 | This chapter implements a distributed version of the "guess my number" game. 3 | 4 | TO PLAY, open the file 5 | 6 | run.rkt 7 | 8 | in DrRacket. The instructions for playing are at the top of the file. 9 | 10 | TO EXPERIMENT, open the files 11 | 12 | -- run.rkt 13 | -- server.rkt 14 | -- client.rkt 15 | -- shared.rkt 16 | 17 | in four different tabs or windows in DrRacket. Switch to the 'run.rkt' 18 | tab and select 19 | 20 | View | Show Module browser 21 | 22 | to see how these files are related. To switch to one of these four files, 23 | you may click the boxes in the module browsers. Alternatively click the 24 | tab you wish to work on. It is also possible to select tabs via key 25 | strokes. 26 | 27 | Each file except for 'run.rkt' comes with test submodules at the bottom of 28 | the file. 29 | 30 | 31 | -------------------------------------------------------------------------------- /chapter13/run.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | The Guess My Number game, a distributed version with a GUI 5 | ----------------------------------------------------------- 6 | 7 | You pick a number. The program guesses the nunber, 8 | by asking you questions. Your responses are "too 9 | small" "too large" or "you guessed it". 10 | 11 | In the Distributed Guess My Number game a player uses a client to connect 12 | to the server. The Server attempts to guess what number the client is thinking 13 | of. Each time the server guesses, the client must use the arrow keys to tell 14 | the server if it is right, too small, or too large. 15 | 16 | Play 17 | ---- 18 | 19 | Click Run. Pick a number X between and . 20 | Evaluate 21 | (run) 22 | This will pop up three windows: 23 | 24 | -- Adam: with instructions for interacting with the program 25 | 26 | -- Universe: the console for the central server 27 | it displays the messages that it receives and sends 28 | 29 | -- your server's state: a window that displays the server's internal state. 30 | 31 | Play and watch the two latter window to understand how the server and client 32 | interact in response to your actions. 33 | 34 | To run the game on two distinct computers: 35 | 36 | -- copy this folder to another computer, determine its IP number "12.345.67.98" 37 | -- open run.rkt 38 | -- evaluate 39 | (launch-guess-server) 40 | 41 | -- on your own computer, open run.rkt and run 42 | -- evaluate 43 | (launch-guess-client "12.345.67.98") 44 | |# 45 | 46 | (require 2htdp/universe "client.rkt" "server.rkt") 47 | 48 | ;; play the game as "Adam" 49 | (define (run) 50 | (launch-many-worlds (launch-guess-client "Adam" LOCALHOST) 51 | (launch-guess-server))) 52 | 53 | ;; what happens if two players sign up with the server simultaneously 54 | (define (bad) 55 | (launch-many-worlds (launch-guess-client "Adam" LOCALHOST) 56 | (launch-guess-server) 57 | (launch-guess-client "Beatrice" LOCALHOST))) 58 | -------------------------------------------------------------------------------- /chapter13/server.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; the server for distributed Guess my Number 4 | 5 | (provide 6 | ;; starts the distributed guess my number game 7 | ;; -> GmNState 8 | launch-guess-server) 9 | 10 | (require 2htdp/image 2htdp/universe "shared.rkt") 11 | 12 | ; 13 | ; 14 | ; 15 | ; 16 | ; 17 | ; ;;;;;; ; 18 | ; ; ; ; 19 | ; ; ; ;;;; ;;;;;; ;;;; 20 | ; ; ; ; ; ; ; ; 21 | ; ; ; ; ; ; 22 | ; ; ; ;;;;;; ; ;;;;;; 23 | ; ; ; ; ; ; ; ; 24 | ; ; ; ; ;; ; ; ; ;; 25 | ; ;;;;;; ;;;; ;; ;;;; ;;;; ;; 26 | ; 27 | ; 28 | ; 29 | ; 30 | 31 | ;; A GmNState is one of: 32 | ;; -- #f 33 | ;; -- GuessRange 34 | 35 | (struct interval (small big) #:transparent) 36 | ;; A GuessRange is (interval Number Number) 37 | ;; always true: (interval l u) means (<= l u) 38 | 39 | (define u0 (interval LOWER UPPER)) 40 | 41 | ; 42 | ; 43 | ; 44 | ; ; 45 | ; ; 46 | ; ;;; ;;; 47 | ; ;; ;; 48 | ; ; ; ; ; ;;;; ;;; ;; ;;; 49 | ; ; ; ; ; ; ; ; ;; ; 50 | ; ; ; ; ; ; ; ; ; 51 | ; ; ; ; ;;;;;; ; ; ; 52 | ; ; ; ; ; ; ; ; 53 | ; ; ; ; ;; ; ; ; 54 | ; ;;; ;;; ;;;; ;; ;;;;;;; ;;; ;;; 55 | ; 56 | ; 57 | ; 58 | ; 59 | 60 | (define (launch-guess-server) 61 | (universe #f 62 | (state #t) 63 | (on-new connect) 64 | (on-msg handle-msg))) 65 | 66 | ;; GmNState IWorld -> [Bundle GmNState [Listof [Mail IWorld Nat]] [Listof IWorld]] 67 | ;; handles all new connections. It only accepts one connection. 68 | (define (connect u client) 69 | (if (false? u) 70 | (make-bundle u0 (list (make-mail client (guess u0))) '()) 71 | (make-bundle u empty (list client)))) 72 | 73 | ;; GmNState IWorld CtoSMessage -> [Bundle GmNState [List [Mail IWorld Nat]] Empty] 74 | ;; handles a message from the client. 75 | (define (handle-msg u client msg) 76 | (define w (next-interval u msg)) 77 | (make-bundle w (list (make-mail client (guess w))) '())) 78 | 79 | ;; GmNState CtoSMessage -> GmNState 80 | ;; creates the new universe for a responce 81 | (define (next-interval u msg) 82 | (cond [(not (string? msg)) u] 83 | [(string=? "up" msg) (bigger u)] 84 | [(string=? "down" msg) (smaller u)] 85 | [else u])) 86 | 87 | ; 88 | ; 89 | ; 90 | ; 91 | ; ;; ; 92 | ; ; ;; 93 | ; ; ;; ;; ;;;; ;;;;; ;;;;; 94 | ; ; ; ; ; ; ; ; ; ; 95 | ; ; ;;;; ; ; ;;;;;; ;;;; ;;;; 96 | ; ; ; ; ; ; ; ; 97 | ; ; ; ; ;; ; ; ; ; ; 98 | ; ;;; ;; ;; ;;;;; ;;;;; ;;;;; 99 | ; 100 | ; 101 | ; 102 | ; 103 | 104 | ;; GuessRange -> Boolean 105 | ;; Does the interval represent a single number? 106 | ;; > (single? (interval 1 1)) 107 | ;; #t 108 | (define (single? w) 109 | (= (interval-small w) (interval-big w))) 110 | 111 | ;; GuessRange -> Number 112 | ;; Calculates a guess based on the given interval 113 | ;; > (guess (interval 0 100)) 114 | ;; 50 115 | (define (guess w) 116 | (quotient (+ (interval-small w) (interval-big w)) 2)) 117 | 118 | ;; GuessRange -> GuessRange 119 | ;; Recreates a GuessRange that lowers the upper bound 120 | ;; > (smaller (interval 0 100)) 121 | ;; (interval 0 50) 122 | (define (smaller w) 123 | (interval (interval-small w) (max (interval-small w) (sub1 (guess w))))) 124 | 125 | ;; GuessRange -> GuessRange 126 | ;; Recreates a interval that raises the lower bound 127 | ;; > (bigger (0 100) 128 | ;; (interval 51 100) 129 | (define (bigger w) 130 | (interval (min (interval-big w) (add1 (guess w))) (interval-big w))) 131 | 132 | 133 | ; 134 | ; 135 | ; 136 | ; 137 | ; ; ; 138 | ; ;;;;; ;;; ;;;; ;;;;; ;;;; 139 | ; ; ; ; ; ; ; 140 | ; ; ;;;;; ;; ; ;; 141 | ; ; ; ; ; ; 142 | ; ; ; ; ; ; 143 | ; ;;; ;;;; ;;;; ;;; ;;;; 144 | ; 145 | ; 146 | 147 | (module+ test 148 | 149 | (require rackunit rackunit/text-ui) 150 | 151 | (define 51-100 (interval 51 100)) 152 | 153 | ;; testing the server's main function 154 | (check-equal? (connect #f iworld1) 155 | (make-bundle (interval 0 100) `(,(make-mail iworld1 50)) '())) 156 | (check-equal? (handle-msg (interval 0 100) iworld1 "up") 157 | (make-bundle 51-100 `(,(make-mail iworld1 (guess 51-100))) '())) 158 | 159 | 160 | ;; testing the server's handlers 161 | 162 | (check-true (single? (interval 50 50))) 163 | (check-false (single? (interval 50 51))) 164 | 165 | (check-equal? (guess (interval 0 100)) 50) 166 | (check-equal? (guess (interval 50 100)) 75) 167 | (check-equal? (guess (interval 0 50)) 25) 168 | 169 | (check-equal? (smaller (interval 0 100)) (interval 0 49)) 170 | (check-equal? (smaller (interval 0 000)) (interval 0 0)) 171 | (check-equal? (smaller (interval 0 50)) (interval 0 24)) 172 | (check-equal? (smaller (interval 50 100)) (interval 50 74)) 173 | (check-equal? (smaller (bigger (bigger (interval 0 100)))) 174 | (interval 76 87)) 175 | 176 | (check-equal? (bigger (interval 0 100)) (interval 51 100)) 177 | (check-equal? (bigger (interval 0 000)) (interval 0 0)) 178 | (check-equal? (bigger (interval 0 100)) (interval 51 100)) 179 | (check-equal? (bigger (interval 51 100)) (interval 76 100)) 180 | (check-equal? (bigger (interval 0 50)) (interval 26 50)) 181 | 182 | "server: all tests run") 183 | -------------------------------------------------------------------------------- /chapter13/shared.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; This module describes the shared vocabulary and knowledge for the server 4 | ;; and client modules of the distributed Guess My Number game. 5 | 6 | #| 7 | Message Formats 8 | --------------- 9 | 10 | StoCMessage is the set of numbers between LOWER and UPPER (inclusive). 11 | The numbers represent the guess. 12 | 13 | CtoSMessage is one of the following two strings: 14 | -- "up" 15 | -- "down" 16 | with the obvious meaning. 17 | 18 | 19 | Message Exchanges 20 | ----------------- 21 | 22 | server client 23 | | | 24 | | register | 25 | |<------------| 26 | | | 27 | | | <----- guess ("up", "down") 28 | | CtoSMessage | 29 | |<------------| 30 | | | 31 | | StoCMessage | 32 | |------------>| 33 | | | 34 | | | 35 | |# 36 | 37 | 38 | (provide 39 | ;; the to-be-guessed number must be in [LOWER,UPPER] 40 | UPPER 41 | LOWER) 42 | 43 | ; 44 | ; 45 | ; 46 | ; 47 | ; 48 | ; ;;;;;; ; 49 | ; ; ; ; 50 | ; ; ; ;;;; ;;;;;; ;;;; 51 | ; ; ; ; ; ; ; ; 52 | ; ; ; ; ; ; 53 | ; ; ; ;;;;;; ; ;;;;;; 54 | ; ; ; ; ; ; ; ; 55 | ; ; ; ; ;; ; ; ; ;; 56 | ; ;;;;;; ;;;; ;; ;;;; ;;;; ;; 57 | ; 58 | ; 59 | ; 60 | ; 61 | 62 | ;; prefined upper and lower limits for a game. 63 | (define UPPER 100) 64 | (define LOWER 0) 65 | -------------------------------------------------------------------------------- /chapter14/client.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; This module implements the client for the Hungry Henry game 4 | 5 | (provide 6 | lets-eat ;; String String[IP Address] -> Meal 7 | ;; launch single client and register at specified host 8 | ) 9 | 10 | (require "shared.rkt" 2htdp/universe 2htdp/image) 11 | 12 | ; 13 | ; 14 | ; 15 | ; ; ; 16 | ; ; ; 17 | ; ; ; ;;; ; ;; ; ;;; ; ; 18 | ; ; ; ; ; ;; ; ;; ; ; ; 19 | ; ;;;;; ; ; ; ; ; ; ; 20 | ; ; ; ;;;;; ; ; ; ; ; 21 | ; ; ; ; ; ; ; ; ; 22 | ; ; ; ; ; ; ; ; 23 | ; ; ; ;;;; ; ; ; ; 24 | ; ; 25 | ; ;; 26 | ; 27 | 28 | 29 | ;; Image Constants 30 | (define FOOD-IMG (bitmap "graphics/cupcake.gif")) 31 | (define PLAYER-IMG (bitmap "graphics/hungry-henry.gif")) 32 | (define BASE (empty-scene WIDTH HEIGHT)) 33 | (define WAYPOINT-NODE (circle 3 'solid 'black)) 34 | ;; Color Constants 35 | (define PLAYER-COLOR "red") 36 | (define MY-COLOR "blue") 37 | (define WAYPOINT-COLOR "green") 38 | ;; Text Constants 39 | (define LOADING... "Waiting For Server") 40 | (define TEXT-SIZE 20) 41 | (define SCORE-SIZE 20) 42 | (define TEXT-COLOR "black") 43 | (define END-OPEN-TEXT "your score was: ") 44 | (define END-CLOSE-TEXT ", the winner was player ") 45 | (define LOADING-OPEN-TEXT "\nYou are ") 46 | (define SEPERATOR ": ") 47 | ;; PBAR constants 48 | (define PBAR-HEIGHT 35) 49 | (define PBAR-LOC (- HEIGHT PBAR-HEIGHT)) 50 | (define PBAR-COLOR "red") 51 | (define PBAR-TEXT (text "loading..." 20 "black")) 52 | ;; Message ID Constants 53 | (define UPDATE-LENGTH 3) 54 | (define SPLAYER-LENGTH 3) 55 | (define SBODY-LENGTH 2) 56 | (define END-LENGTH 2) 57 | (define SCORE-LIST-LENGTH 2) 58 | ;; Init Constants 59 | (define ZERO% 0) 60 | (define LOADING (text LOADING... 20 "black")) 61 | 62 | ;; ----------------------------------------------------------------------------- 63 | ;; State of Client 64 | 65 | (struct app (id img countdown) #:transparent) 66 | (struct entree (id players food) #:transparent) 67 | 68 | ;; Meal is one of 69 | ;; - Appetizer 70 | ;; - Entree 71 | ;; Appetizer = (app [or Id #f] Image Number∈[0,1]) 72 | ;; interpretation: 73 | ;; -- the first field is this players id, #f if it hasnt been sent yet 74 | ;; -- the second is the loading image 75 | ;; -- the third is the %%% of loading time passed, represents the loading state 76 | ;; Entree = (entree Id [Listof Feaster] [Listof Food]) 77 | ;; interpretation: 78 | ;; -- the first field is this player's id 79 | ;; -- the second field represents complete information about all players 80 | ;; -- the third field specifies the location of the cupcakes 81 | 82 | (define INITIAL (app #f LOADING ZERO%)) 83 | 84 | ; 85 | ; 86 | ; 87 | ; ; 88 | ; ; 89 | ; ;;; ;;; 90 | ; ;; ;; 91 | ; ; ; ; ; ;;;; ;;; ;; ;;; 92 | ; ; ; ; ; ; ; ; ;; ; 93 | ; ; ; ; ; ; ; ; ; 94 | ; ; ;; ; ;;;;;; ; ; ; 95 | ; ; ;; ; ; ; ; ; ; 96 | ; ; ; ; ; ; ; ; 97 | ; ; ; ; ;; ; ; ; 98 | ; ;;; ;;; ;;;; ;; ;;;;;;; ;;; ;;; 99 | ; 100 | ; 101 | ; 102 | ; 103 | ; 104 | 105 | (define (lets-eat label server) 106 | (big-bang INITIAL 107 | (to-draw render-the-meal) 108 | (on-mouse set-waypoint) 109 | (on-receive handle-server-messages) 110 | (register server) 111 | (name label))) 112 | 113 | ;; Meal Message -> Meal 114 | ;; handles incomming messages 115 | (define (handle-server-messages meal msg) 116 | (cond [(app? meal) (handle-appetizer-message meal msg)] 117 | [(entree? meal) (handle-entree-message meal msg)])) 118 | 119 | ;; Meal Number Number MouseEvent -> Meal 120 | ;; handles what happends on a click 121 | (define (set-waypoint meal x y event) 122 | (if (and (entree? meal) (string=? event "button-down")) 123 | (make-package meal (list GOTO x y)) 124 | meal)) 125 | 126 | ;; Meal -> Image 127 | ;; deals with draw some kind of meal 128 | (define (render-the-meal meal) 129 | (cond [(app? meal) (render-appetizer meal)] 130 | [(entree? meal) (render-entree meal)])) 131 | 132 | ; 133 | ; 134 | ; 135 | ; ;;;; ; 136 | ; ; ; 137 | ; ; ; ;;; ;;;; ;;; ;;; ; ; ;;; 138 | ; ; ; ; ; ; ; ; ; ; ; ; ; 139 | ; ;;;; ; ; ; ; ; ; ; ; ; ; 140 | ; ; ; ;;;;; ; ;;;;; ; ;; ;; ;;;;; 141 | ; ; ; ; ; ; ; ; ; ; 142 | ; ; ; ; ; ; ; ; ; ; 143 | ; ; ; ;;;; ;;;; ;;;; ; ; ;;;; 144 | ; 145 | ; 146 | ; 147 | 148 | ;; ----------------------------------------------------------------------------- 149 | ;; Appetizer 150 | 151 | ;; Appetizer Message -> Meal 152 | ;; starts the game if the message is valid 153 | (define (handle-appetizer-message s msg) 154 | (cond [(id? msg) (app msg (app-img s) (app-countdown s))] 155 | [(time? msg) (app (app-id s) (app-img s) msg)] 156 | [(state? msg) (switch-to-entree s msg)] 157 | ;; fault tolerant 158 | [else s])) 159 | 160 | ;; Appetizer State -> Meal 161 | (define (switch-to-entree s m) 162 | (apply entree (app-id s) (rest m))) 163 | 164 | ;; ----------------------------------------------------------------------------- 165 | ;; Appetizer 166 | 167 | ;; Entree Message -> Meal 168 | ;; either updates the world or ends the game 169 | (define (handle-entree-message s msg) 170 | (cond [(state? msg) (update-entree s msg)] 171 | [(score? msg) (restart s msg)] 172 | [else s])) 173 | 174 | ;; Entree State -> Entree 175 | ;; creates a new entree based on the update mesg 176 | (define (update-entree s state-msg) 177 | (apply entree (entree-id s) (rest state-msg))) 178 | 179 | ;; Entree EndMessage -> Appetizer 180 | ;; Tranistion to start state 181 | (define (restart s end-msg) 182 | (define score-image (render-scores end-msg)) 183 | (app (entree-id s) (above LOADING score-image) ZERO%)) 184 | 185 | ;; ----------------------------------------------------------------------------- 186 | ;; predicates for recognizing network messages 187 | 188 | ;; Message -> Boolean 189 | ;; checks if message is a valid update message 190 | (define (state? msg) 191 | (and (list? msg) 192 | (= UPDATE-LENGTH (length msg)) 193 | (symbol? (first msg)) 194 | (list? (second msg)) 195 | (list? (third msg)) 196 | (symbol=? SERIALIZE (first msg)) 197 | (andmap player? (second msg)) 198 | (andmap body? (third msg)))) 199 | 200 | ;; Message -> Boolean 201 | ;; checks if message is a valid time message 202 | (define (time? msg) 203 | (and (real? msg) (<= 0 msg 1))) 204 | 205 | ;; Message -> Boolean 206 | ;; checks if is end game message 207 | (define (score? msg) 208 | (and (list? msg) 209 | (= END-LENGTH (length msg)) 210 | (symbol? (first msg)) 211 | (list? (second msg)) 212 | (symbol=? SCORE (first msg)) 213 | (score-list? (second msg)))) 214 | 215 | ;; List -> Boolean 216 | ;; is this a list binding names to scores? 217 | (define (score-list? l) 218 | (for/and ([s l]) 219 | (and (list? s) 220 | (= SCORE-LIST-LENGTH (length s)) 221 | (id? (first s)) 222 | (number? (second s))))) 223 | 224 | ; 225 | ; 226 | ; 227 | ; ; 228 | ; ; 229 | ; ;;;;;; 230 | ; ; ; 231 | ; ; ; ;; ;; ;;;; ;;; ;; ;;; ;; ;;; ;;; ;; 232 | ; ; ; ;;; ; ; ; ; ; ; ;; ; ; ;; 233 | ; ; ; ; ; ; ; ; ; ; ; ; ; 234 | ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; 235 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 236 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 237 | ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; 238 | ; ;;;;;; ;;;;;; ;;;; ;; ; ; ;;;;;;; ;;; ;;; ;;; ; 239 | ; ; 240 | ; ;; 241 | ; ;;;; 242 | ; 243 | ; 244 | 245 | ;; ----------------------------------------------------------------------------- 246 | ;; Appetizer Drawing 247 | 248 | ;; Appetizer -> Image 249 | ;; tells the player that we're waiting for the server. shows id 250 | (define (render-appetizer app) 251 | (add-progress-bar (render-id+image app) (app-countdown app))) 252 | 253 | ;; Image Number∈[0,1] -> Image 254 | ;; draws the progress bar 255 | (define (add-progress-bar base count) 256 | (place-image (render-progress count) (/ WIDTH 2) PBAR-LOC base)) 257 | 258 | ;; Number∈[0,1] -> Image 259 | ;; draw a progress bar that is count percent complete 260 | (define (render-progress count) 261 | (overlay PBAR-TEXT (rectangle (* count WIDTH) PBAR-HEIGHT "solid" PBAR-COLOR))) 262 | 263 | ;; Appetizer -> Image 264 | ;; gets the text to display on the loading screen 265 | (define (render-id+image app) 266 | (define id (app-id app)) 267 | (define base-image (app-img app)) 268 | (overlay 269 | (cond 270 | [(boolean? id) base-image] 271 | [else (define s (string-append LOADING-OPEN-TEXT id)) 272 | (above base-image (text s TEXT-SIZE TEXT-COLOR))]) 273 | BASE)) 274 | 275 | ;; ----------------------------------------------------------------------------- 276 | ;; Entree Drawing 277 | 278 | ;; Entree -> Image 279 | ;; draws a Entree 280 | (define (render-entree entree) 281 | (define id (entree-id entree)) 282 | (define pl (entree-players entree)) 283 | (define fd (entree-food entree)) 284 | (add-path id pl (add-players id pl (add-food fd BASE)))) 285 | 286 | ;; [Listof Food] Image -> Image 287 | ;; draws all the food 288 | (define (add-food foods base-scene) 289 | (for/fold ([scn base-scene]) ([f foods]) 290 | (place-image FOOD-IMG (body-x f) (body-y f) scn))) 291 | 292 | ;; Id [Listof Feaster] Image -> Image 293 | ;; draws all players 294 | (define (add-players id lof base-scene) 295 | (for/fold ([scn base-scene]) ([feaster lof]) 296 | (place-image (render-avatar id feaster) 297 | (feaster-x feaster) (feaster-y feaster) 298 | scn))) 299 | 300 | ;; Id Feaster -> Image 301 | ;; gets an image for the player 302 | (define (render-avatar id player) 303 | (define size (body-size (player-body player))) 304 | (define color 305 | (if (id=? id (player-id player)) MY-COLOR PLAYER-COLOR)) 306 | (above 307 | (render-text (player-id player)) 308 | (overlay (render-player-score player) 309 | PLAYER-IMG 310 | (circle size 'outline color)))) 311 | 312 | ;; Feaster -> Image 313 | ;; Draw the players score 314 | (define (render-player-score player) 315 | (render-text (number->string (get-score (body-size (player-body player)))))) 316 | 317 | ;; Id [Listof Feaster] Image -> Image 318 | ;; draws the path of the player whose id is passed in 319 | (define (add-path id players base-scene) 320 | (define player 321 | (findf (lambda (x) (id=? id (player-id x))) players)) 322 | (if (boolean? player) 323 | base-scene 324 | (add-waypoint* player base-scene))) 325 | 326 | ;; Feaster Image -> Image 327 | ;; draws the list of way points to the scene 328 | (define (add-waypoint* player base-scene) 329 | (define loc (body-loc (player-body player))) 330 | (define ways (player-waypoints player)) 331 | (define-values (resulting-scene _) 332 | (for/fold ([scn base-scene][from loc]) ([to ways]) 333 | (values (add-waypoint from to scn) to))) 334 | resulting-scene) 335 | 336 | ;; Complex Complex Image -> Image 337 | ;; Add a waypoint to the scene at those coordinates 338 | (define (add-waypoint from to s) 339 | (define x-from (real-part from)) 340 | (define y-from (imag-part from)) 341 | (define x-to (real-part to)) 342 | (define y-to (imag-part to)) 343 | (define with-line (add-line s x-to y-to x-from y-from WAYPOINT-COLOR)) 344 | (place-image WAYPOINT-NODE x-to y-to with-line)) 345 | 346 | ;; ----------------------------------------------------------------------------- 347 | ;; render the end 348 | 349 | ;; Score -> Image 350 | ;; draws the end of the game 351 | (define (render-scores msg) 352 | (define scores (sort (second msg) < #:key second)) 353 | (for/fold ([img empty-image]) ([name-score scores]) 354 | (define txt (get-text name-score)) 355 | (above (render-text txt) img))) 356 | 357 | ;; (list ID Natural) -> string 358 | ;; builds a string for that winning pair 359 | (define (get-text name-score) 360 | (define-values (name score) (apply values name-score)) 361 | (string-append name SEPERATOR (number->string score))) 362 | 363 | 364 | ; 365 | ; 366 | ; 367 | ; 368 | ; 369 | ; ;;;;; 370 | ; ;; 371 | ; ; ; ;; ;; ;;; ;;; 372 | ; ; ; ; ; ; ; 373 | ; ; ; ; ; ; ; 374 | ; ; ; ; ; ;; 375 | ; ;;;;;; ; ; ;; 376 | ; ; ; ; ; ; ; 377 | ; ; ; ; ;; ; ; 378 | ; ;;; ;;; ;;; ;; ;;; ;;; 379 | ; 380 | ; 381 | ; 382 | ; 383 | ; 384 | 385 | ;; String -> Image 386 | ;; draws the text 387 | (define (render-text txt) 388 | (text txt TEXT-SIZE TEXT-COLOR)) 389 | 390 | ;; player -> Number 391 | ;; Gets the X coord of a entrees 392 | (define (feaster-x feaster) 393 | (body-x (player-body feaster))) 394 | 395 | ;; player -> Number 396 | ;; Gets the Y coord of a entrees 397 | (define (feaster-y feaster) 398 | (body-y (player-body feaster))) 399 | 400 | ;; body -> Number 401 | ;; gets the X coord of a body 402 | (define (body-x body) 403 | (real-part (body-loc body))) 404 | 405 | ;; body -> Number 406 | ;; gets the Y coord of a body 407 | (define (body-y body) 408 | (imag-part (body-loc body))) 409 | 410 | ; 411 | ; 412 | ; 413 | ; 414 | ; 415 | ; ;;;;;;;;; ; 416 | ; ; ; ; ; 417 | ; ; ; ; ;;;; ;;;; ; ;;;;;;; ;;;; ; 418 | ; ; ; ; ; ; ; ;; ; ; ;; 419 | ; ; ; ; ; ; ; 420 | ; ; ;;;;;;;; ;;;;; ; ;;;;; 421 | ; ; ; ; ; ; 422 | ; ; ; ; ; ; 423 | ; ; ; ; ; ; ; ; ; ; 424 | ; ;;;;; ;;;;; ;;;;;; ;;;; ;;;;;; 425 | ; 426 | ; 427 | ; 428 | ; 429 | ; 430 | 431 | (module+ test 432 | 433 | (require rackunit rackunit/text-ui) 434 | 435 | ;; testing main client 436 | (check-equal? (switch-to-entree (app "foo" 'blah 1) '(STATE () ())) 437 | (entree "foo" '()'())) 438 | (check-equal? (handle-server-messages (app #f 'ksajfhsdkjhfr 1) .5) 439 | (handle-appetizer-message (app #f 'ksajfhsdkjhfr 1) .5)) 440 | ;;dispatch-mouse 441 | (check-equal? (set-waypoint (app 1 LOADING 0) 1 1 "button-down") 442 | (app 1 LOADING 0)) 443 | (check-equal? (set-waypoint (app 1 LOADING 0) 1 1 "button-up") 444 | (app 1 LOADING 0)) 445 | (check-equal? (set-waypoint (app #f LOADING 0) 1 1 "button-down") 446 | (app #f LOADING 0)) 447 | (check-equal? (set-waypoint (app #f LOADING 0) 1 1 "button-up") 448 | (app #f LOADING 0)) 449 | (check-equal? (set-waypoint (entree "player1" (list (player "player1" (body 1 1+1i) empty)) empty) 1 1 "button-up") 450 | (entree "player1" (list (player "player1" (body 1 1+1i) empty)) empty)) 451 | (check-equal? (set-waypoint (entree "player1" (list (player "player1" (body 1 1+1i) empty)) empty) 452 | 1 1 "button-down") 453 | (make-package (entree "player1" (list (player "player1" (body 1 1+1i) empty)) empty) 454 | (list 'goto 1 1))) 455 | ;;render-the-meal 456 | 457 | ;; testing message receipt 458 | ;; app-may-start 459 | ;; entree-msg 460 | ;; update-msg? 461 | 462 | (check-true (state? `(,SERIALIZE (,(player "player1" (body 1+4i 234) `()) ,(player "player1" (body 3 3) `())) 463 | (,(body 1+i 2) ,(body 2 2))))) 464 | (check-true (state? `(,SERIALIZE (,(player "player1" (body 1+4i 234) `())) 465 | (,(body 1+i 2) ,(body 2 2))))) 466 | (check-true (state? `(,SERIALIZE () 467 | (,(body 1+i 2) ,(body 2 2))))) 468 | (check-true (state? `(,SERIALIZE (,(player "player1" (body 1+4i 234) `()) ,(player "player1" (body 3 3) `())) 469 | ()))) 470 | 471 | (check-false (state? `(,SERIALIZE (("player1" (1+4i 234) ()) ("player1" (3 3) ())) 472 | ((1+i 2) (2 2))))) 473 | (check-false (state? `(,SERIALIZE (("player1" (1+4i 234) ())) 474 | ((1+i 2) (2 2))))) 475 | (check-false (state? `(,SERIALIZE () 476 | ((1+i 2) (2 2))))) 477 | (check-false (state? `(,SERIALIZE (("player1" (1+4i 234) ()) ("player1" (3 3) ())) 478 | ()))) 479 | (check-true (state? `(,SERIALIZE () 480 | ()))) 481 | (check-false (state? `(,SERIALIZE (("player1" (1+4i 234) ()) ("player1" (3 3) ())) 482 | ((1+i 2) (2 2))))) 483 | (check-false (state? `(,SERIALIZE (("player1" (1+4i 234) ())) 484 | ((1+i 2) (2 2))))) 485 | (check-false (state? `(,SERIALIZE () 486 | ((1+i 2) (2 2))))) 487 | (check-false (state? `(,SERIALIZE (("player1" (1+4i 234) ()) ("player1" (3 3) ())) 488 | ()))) 489 | 490 | (check-false (state? '(u ((1 1+4i 234)) 491 | ((1+i 2) (2 2))))) 492 | (check-false (state? '(((1 1+4i 234)) 493 | ((1+i 2) (2 2))))) 494 | (check-false (state? '(u ((1 1+4i)) 495 | ((1+i 2) (2 2))))) 496 | (check-false (state? '(u ((1 1+4i 234)) 497 | ((1+i 2) (2 b))))) 498 | (check-false (state? '(u ((1 1+4i 234))))) 499 | (check-false (state? '(u ((1+i 2) (2 2))))) 500 | (check-false (state? '(((1+i 2) (2 2))))) 501 | (check-false (state? 4)) 502 | (check-false (state? 'f)) 503 | ;; score-list? 504 | (check-true (score-list? '(("s" 0) ("l" 0) ("sdf" 0)))) 505 | (check-true (score-list? empty)) 506 | (check-true (score-list? '(("s" 0) ("l" 0)))) 507 | (check-false (score-list? '(('s 0) ('l 0) ('sdf 0)))) 508 | (check-false (score-list? '((s 0) (l 0)))) 509 | (check-false (score-list? '((s) (l)))) 510 | (check-false (score-list? '((s 0) (l 0)))) 511 | ;; update-entree 512 | (check-equal? (update-entree (entree "player10" '() '()) 513 | `(s (,(player "player1" (body 10 10) `(3 4+9i)) 514 | ,(player "player10" (body 103 10+4i) `(3 5+78i))) 515 | (,(body 5 10) ,(body 30 30)))) 516 | (entree "player10" (list (player "player1" (body 10 10) (list 3 4+9i)) 517 | (player "player10" (body 103 10+4i) (list 3 5+78i))) 518 | (list (body 5 10) (body 30 30)))) 519 | 520 | 521 | ;; testing rendering the client 522 | 523 | ;; draw-app 524 | (check-equal? (render-appetizer (app #f LOADING 0)) 525 | (add-progress-bar (overlay LOADING 526 | BASE) 527 | 0)) 528 | ;; draw-entree 529 | 530 | 531 | ;; draw-players 532 | 533 | (check-equal? (add-players "player0" 534 | (list (player "player1" (body 40 23+34i) empty) 535 | (player "player0" (body 50 1+3i) empty)) 536 | BASE) 537 | (place-image (render-avatar "player0" (player "player0" (body 50 1+3i) empty)) 538 | 1 3 539 | (place-image (render-avatar "player0" (player "player1" (body 40 23+34i) empty)) 540 | 23 34 541 | BASE))) 542 | (check-equal? (add-players "player0" 543 | (list (player "player1" (body 40 23+34i) empty)) 544 | BASE) 545 | (place-image (render-avatar "player0" (player "player1" (body 40 23+34i) empty)) 546 | 23 34 547 | BASE)) 548 | 549 | ;; draw-player 550 | 551 | ;; get-player-image 552 | (check-equal? (render-avatar "player0" (player "player0" (body 30 1+3i) empty)) 553 | (above (render-text "player0") 554 | (overlay (text (number->string (get-score 30)) 20 'black) 555 | PLAYER-IMG (circle 30 "outline" MY-COLOR)))) 556 | (check-equal? (render-avatar "player0" (player "player1" (body 30 1+3i) empty)) 557 | (above (render-text "player1") 558 | (overlay (text (number->string (get-score 30)) 20 'black) 559 | PLAYER-IMG (circle 30 "outline" PLAYER-COLOR)))) 560 | 561 | ;; draw-food 562 | (check-equal? (add-food (list (body 34 54+3i) 563 | (body 9 45+23i)) 564 | BASE) 565 | (place-image FOOD-IMG 566 | 45 23 567 | (place-image 568 | FOOD-IMG 569 | 54 3 570 | BASE))) 571 | (check-equal? (add-food (list (body 34 54+3i)) 572 | BASE) 573 | (place-image 574 | FOOD-IMG 575 | 54 3 576 | BASE)) 577 | 578 | 579 | ;; testing auxiliary functions 580 | ;; player-x 581 | (check-equal? (feaster-x (player 20 (body 3 1+3i) empty)) 582 | 1) 583 | (check-equal? (feaster-x (player 20 (body 3 4+3i) empty)) 584 | 4) 585 | (check-equal? (feaster-x (player 20 (body 3 4+67i) empty)) 586 | 4) 587 | ;; player-y 588 | (check-equal? (feaster-y (player 20 (body 3 1+3i) empty)) 589 | 3) 590 | (check-equal? (feaster-y (player 20 (body 3 4+3i) empty)) 591 | 3) 592 | (check-equal? (feaster-y (player 20 (body 3 4+67i) empty)) 593 | 67) 594 | 595 | ;; body-x 596 | (check-equal? (body-x (body 20 1+2i)) 597 | 1) 598 | (check-equal? (body-x (body 20 4+2i)) 599 | 4) 600 | (check-equal? (body-x (body 20 3+2i)) 601 | 3) 602 | ;; body-y 603 | (check-equal? (body-y (body 20 4+1i)) 604 | 1) 605 | (check-equal? (body-y (body 20 1+4i)) 606 | 4) 607 | (check-equal? (body-y (body 20 3)) 608 | 0) 609 | 610 | "client: all tests run") 611 | 612 | -------------------------------------------------------------------------------- /chapter14/graphics/cupcake.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/realm/d4509a0c42171f4ffbdd67b9acb0b774957be02b/chapter14/graphics/cupcake.gif -------------------------------------------------------------------------------- /chapter14/graphics/hungry-henry.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/realm/d4509a0c42171f4ffbdd67b9acb0b774957be02b/chapter14/graphics/hungry-henry.gif -------------------------------------------------------------------------------- /chapter14/readme.txt: -------------------------------------------------------------------------------- 1 | This chapter implements a distributed game, dubbed "Hungry Henry." 2 | 3 | TO PLAY, open the file 4 | 5 | run.rkt 6 | 7 | in DrRacket. The instructions for playing are at the top of the file. 8 | 9 | TO EXPERIMENT, open the files 10 | 11 | -- run.rkt 12 | -- server.rkt 13 | -- client.rkt 14 | -- shared.rkt 15 | 16 | in four different tabs or windows in DrRacket. Switch to the 'run.rkt' 17 | tab and select 18 | 19 | View | Show Module browser 20 | 21 | to see how these files are related. To switch to one of these four files, 22 | you may click the boxes in the module browsers. Alternatively click the 23 | tab you wish to work on. It is also possible to select tabs via key 24 | strokes. 25 | 26 | Each file except for 'run.rkt' comes with test submodules at the bottom of 27 | the file. 28 | 29 | 30 | -------------------------------------------------------------------------------- /chapter14/run.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | Hungry Henry, a multi-player, distributed game 5 | ----------------------------------------------- 6 | 7 | This game is a multi-player competition for cupcakes. Each player owns an 8 | avatar, called a "Henry", and competes for a limited number of cupcakes, 9 | distributed over a rectangular space. A player launches her Henry via 10 | a series of mouse clicks, so-called waypoints. Her Henry moves from waypoint 11 | to waypoint. If it gets close enough to a cupcake, he eats the cupcake and 12 | fattens up. As a Henry fattens up, he slows down. When all cupcakes are 13 | consumed, the fattest Henry wins. 14 | 15 | Notes: 16 | 1. The cupcakes remain in place until they are eaten. 17 | 2. Once a waypoiny is recorded, it cannot be removed. 18 | 3. Waypoints are visited in a first-come, first-serve order. 19 | 20 | Play 21 | ---- 22 | 23 | Click Run. Evaluate 24 | 25 | (serve-dinner) 26 | 27 | in the Interactions Panel. This will pop up three windows: 28 | -- Matthias, a game window 29 | -- David, another game window 30 | -- Universe, the game server's console 31 | 32 | Play. You can play the part of both participants. Alternatively, click 33 | the David or Matthias window (to obtain focus) and click again to choose 34 | a way point for David's or Matthias's "hungry henry". Watch the hungry 35 | henries go for the cup cake and eat them up. You can make either one of them 36 | win or you can force a tie. 37 | 38 | To run the game on two distinct computers: 39 | 40 | -- copy this folder to another computer, determine its IP number "12.345.67.98" 41 | -- open run.rkt 42 | -- evaluate 43 | (bon-appetit) 44 | 45 | -- on your own computer, open run.rkt and run 46 | -- evaluate 47 | (lets-eat SomeNameAsAString "12.345.67.98") 48 | |# 49 | 50 | (require (only-in "server.rkt" bon-appetit) 51 | (only-in "client.rkt" lets-eat) 52 | 2htdp/universe) 53 | 54 | ;; launch server worlds for playtesting 55 | (define (serve-dinner) 56 | (launch-many-worlds 57 | (bon-appetit) 58 | (lets-eat "Matthias" LOCALHOST) 59 | (lets-eat "David" LOCALHOST))) 60 | -------------------------------------------------------------------------------- /chapter14/server.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; This module implements the server for the Hungry Henry game 4 | 5 | (provide 6 | bon-appetit ;; -> Void 7 | ;; launch the server for Hungry Henry 8 | ) 9 | 10 | (require "shared.rkt" 2htdp/universe) 11 | 12 | #| ----------------------------------------------------------------------------- 13 | The server is responsible for: 14 | -- starting the game 15 | -- moving Henrys 16 | -- have Henrys eat, remove food on collision 17 | -- collecting and broadcasting information about the movement of players 18 | -- ending games 19 | |# 20 | 21 | ; 22 | ; 23 | ; 24 | ; ; ; ; ; 25 | ; ; ; ; ; 26 | ; ; ; ; ; ; ;; ;; ; ; ;;; ; ; ; ; ;;; ; ;; ; ;;; ; ; 27 | ; ; ; ; ; ;; ; ; ;; ;; ; ; ; ; ; ; ; ;; ; ;; ; ; ; 28 | ; ;;;;; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ; ; 29 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; 30 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 31 | ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ; 32 | ; ; ; ;; ; ; ; ;; ; ; ; ; ; ;;;; ; ; ; ; 33 | ; ; ; ; 34 | ; ;;; ;; ;; 35 | ; 36 | 37 | 38 | ;; Init Constants 39 | (define TICK .1) 40 | (define PLAYER-LIMIT 2) 41 | (define START-TIME 0) 42 | (define WAIT-TIME 250) 43 | 44 | (define FOOD*PLAYERS 5) 45 | 46 | (define WEIGHT-FACTOR 2.1) 47 | (define BASE-SPEED (/ (expt PLAYER-SIZE 2) WEIGHT-FACTOR)) 48 | 49 | ;; Data Definitions 50 | (struct join (clients [time #:mutable]) #:transparent) 51 | (struct play (players food spectators) #:transparent #:mutable) 52 | 53 | ;; plus some update primitives: 54 | 55 | ;; JoinUniverse Player -> JoinUniverse 56 | (define (join-add-player j new-p) 57 | (join (cons new-p (join-clients j)) (join-time j))) 58 | 59 | ;; PlayUniverse IP -> PlayUniverse 60 | (define (play-add-spectator pu new-s) 61 | (define players (play-players pu)) 62 | (define spectators (play-spectators pu)) 63 | (play players (play-food pu) (cons new-s spectators))) 64 | 65 | ;; PlayUniverse IWorld -> PlayUniverse 66 | ;; removes player that uses iworld 67 | (define (play-remove p iw) 68 | (define players (play-players p)) 69 | (define spectators (play-spectators p)) 70 | (play (rip iw players) (play-food p) (rip iw spectators))) 71 | 72 | ;; JoinUniverse IWorld -> JoinUniverse 73 | ;; removes players and spectators that use iw from this world 74 | (define (join-remove j iw) 75 | (join (rip iw (join-clients j)) (join-time j))) 76 | 77 | ;; IWorld [Listof Player] -> [Listof Player] 78 | ;; remove player that contains the given IWorld 79 | (define (rip iw players) 80 | (remove iw players (lambda (iw p) (iworld=? iw (ip-iw p))))) 81 | 82 | ;; LIKE: 83 | ;; (struct ip ip? ip-id ip-iw ip-body ip-waypoints ip-player) 84 | (define-values 85 | (ip ip? ip-id ip-iw ip-body ip-waypoints ip-player) 86 | (let () 87 | (struct ip (id iw body waypoints player) #:transparent) 88 | (define (create iw id body waypoints) 89 | (ip id iw body waypoints (player id body waypoints))) 90 | (values 91 | create ip? ip-id ip-iw ip-body ip-waypoints ip-player))) 92 | 93 | ;; ServerState is one of 94 | ;; -- JoinUniverse 95 | ;; -- PlayUniverse 96 | ;; JoinUniververse = (join [Listof IPs] Nat) 97 | ;; interpretation: 98 | ;; -- the first field lists the currently connected client-player 99 | ;; -- the second field is the number of ticks since the server started 100 | ;; PlayUniverse = (play [Listof IPs] [Listof Food] [Listof IP]) 101 | ;; interpretation: 102 | ;; -- the first field lists all participating players 103 | ;; -- the second field lists the cupcakes 104 | ;; --- the third field enumerates the spectating players 105 | ;; IP = (ip Id IWorld Body [Listof Complex] Feaster) 106 | ;; interpretation: 107 | ;; the struct represents the Universe's perspective of a connected player 108 | ;; -- the first field is the assigned unique Id 109 | ;; -- the second field is the IWorld representing the remote connection to the client 110 | ;; -- the third field is the Body of the player 111 | ;; -- the fourth field is the list of player-chosen Waypoints, 112 | ;; ordered from oldest click to most-recent 113 | ;; meaning the first one has to be visited first by the Henry 114 | ;; -- the fifth field is the serialized representation of the first four fields 115 | 116 | (define JOIN0 (join empty START-TIME)) 117 | 118 | ; 119 | ; 120 | ; 121 | ; 122 | ; ;;; ;;; ; 123 | ; ;; ;; 124 | ; ;; ;; ;;;; ;;; ;; ;; 125 | ; ; ; ; ; ; ; ;; ; 126 | ; ; ; ; ;;;;; ; ; ; 127 | ; ; ; ; ; ; ; ; 128 | ; ; ; ; ;; ; ; ; 129 | ; ;;; ;;; ;;; ;; ;;;;; ;;; ;;; 130 | ; 131 | ; 132 | ; 133 | ; 134 | 135 | (define (bon-appetit) 136 | (universe JOIN0 137 | (on-new connect) 138 | (on-msg handle-goto-message) 139 | (on-tick tick-tock TICK) 140 | (on-disconnect disconnect))) 141 | 142 | ;; ServerState IWorld -> Bundle 143 | ;; adds a new connection to a JoinUniverse and ticks. Ignores otherwise 144 | (define (connect s iw) 145 | (cond [(join? s) (add-player s iw)] 146 | [(play? s) (add-spectator s iw)])) 147 | 148 | ;; ServerState IWorld Sexpr -> Bundle 149 | ;; accepts goto messages from clients 150 | (define (handle-goto-message s iw msg) 151 | (cond [(and (play? s) (goto? msg)) (goto s iw msg)] 152 | [else (empty-bundle s)])) 153 | 154 | ;; ServerState -> Bundle 155 | ;; handle a tick event 156 | (define (tick-tock s) 157 | (cond [(join? s) (wait-or-play s)] 158 | [(play? s) (move-and-eat s)])) 159 | 160 | ;; ServerState IWorld -> Bundle 161 | ;; handles loss of a client 162 | (define (disconnect s iw) 163 | (cond [(join? s) (drop-client s iw)] 164 | [(play? s) (drop-player s iw)])) 165 | 166 | ; 167 | ; 168 | ; 169 | ; ; ; ; ; 170 | ; ; ; ; 171 | ; ; ; ;;;; ;;; ;;;;; ;;; ; ;; ;; ; 172 | ; ; ; ; ; ; ; ; ;; ; ; ;; 173 | ; ; ; ; ; ; ; ; ; ; ; ; 174 | ; ;; ;; ;;;; ; ; ; ; ; ; ; 175 | ; ;; ;; ; ; ; ; ; ; ; ; ; 176 | ; ; ; ; ;; ; ; ; ; ; ; ;; 177 | ; ; ; ;; ; ; ;;; ; ; ; ;; ; 178 | ; ; 179 | ; ;;; 180 | ; 181 | 182 | ;; JoinUniverse -> Bundle 183 | ;; count down and might transition 184 | (define (wait-or-play j) 185 | (cond [(keep-waiting? j) (keep-waiting j)] 186 | [else (start-game j)])) 187 | 188 | ;; JoinUniverse -> Boolean 189 | ;; is it time to start? 190 | (define (keep-waiting? j) 191 | (or (> PLAYER-LIMIT (length (join-clients j))) 192 | (> WAIT-TIME (join-time j)))) 193 | 194 | ;; JoinUniverse -> [Bundle JoinUniverse] 195 | (define (keep-waiting j) 196 | (set-join-time! j (+ (join-time j) 1)) 197 | (time-broadcast j)) 198 | 199 | ;; JoinUniverse -> [Bundle JoinUniverse] 200 | ;; broadcasts the new load time fraction to the players 201 | (define (time-broadcast j) 202 | (define iworlds (map ip-iw (join-clients j))) 203 | (define load% (min 1 (/ (join-time j) WAIT-TIME))) 204 | (make-bundle j (broadcast iworlds load%) empty)) 205 | 206 | ;; JoinUniverse -> [Bundle PlayUniverse] 207 | ;; starts the game 208 | (define (start-game j) 209 | (define clients (join-clients j)) 210 | (define cupcakes (bake-cupcakes (length clients))) 211 | (broadcast-universe (play clients cupcakes empty))) 212 | 213 | ;; Number -> [Listof Food] 214 | ;; creates the amount of food for that number of players 215 | (define (bake-cupcakes player#) 216 | (for/list ([i (in-range (* player# FOOD*PLAYERS))]) 217 | (create-a-body CUPCAKE))) 218 | 219 | ; 220 | ; 221 | ; ;;; 222 | ; ;;;; ; ; 223 | ; ; ; ; 224 | ; ; ; ; ;;;; ; ; ;;; ; ;; ;; ; 225 | ; ; ; ; ; ; ; ; ;; ; ; ;; 226 | ; ;;; ; ; ; ; ; ; ; ; ; 227 | ; ; ; ;;;; ; ; ; ; ; ; ; 228 | ; ; ; ; ; ; ; ; ; ; ; ; 229 | ; ; ; ; ;; ; ; ; ; ; ;; 230 | ; ; ; ;; ; ; ; ; ; ;; ; 231 | ; ; ; 232 | ; ;; ;;; 233 | ; 234 | 235 | ;; PlayUniverse -> Bundle 236 | ;; moves everything. eats. may end game 237 | (define (move-and-eat pu) 238 | (define nplayers (move-player* (play-players pu))) 239 | (define nfood (feed-em-all nplayers (play-food pu))) 240 | (progress nplayers nfood (play-spectators pu))) 241 | 242 | ;; [Listof IP] -> [Listof IP] 243 | ;; moves all players 244 | (define (move-player* players) 245 | (for/list ([p players]) 246 | (define waypoints (ip-waypoints p)) 247 | (cond [(empty? waypoints) p] 248 | [else (define body (ip-body p)) 249 | (define nwpts 250 | (move-toward-waypoint body waypoints)) 251 | (ip (ip-iw p) (ip-id p) body nwpts)]))) 252 | 253 | ;; Body [Listof Complex] -> [Listof Complex] 254 | ;; effect: set body's location 255 | ;; determine new waypoints for player 256 | ;; pre: (cons? waypoints) 257 | (define (move-toward-waypoint body waypoints) 258 | (define goal (first waypoints)) 259 | (define bloc (body-loc body)) 260 | (define line (- goal bloc)) 261 | (define dist (magnitude line)) 262 | (define speed (/ BASE-SPEED (body-size body))) 263 | (cond 264 | [(<= dist speed) 265 | (set-body-loc! body goal) 266 | (rest waypoints)] 267 | [else ; (> distance speed 0) 268 | (set-body-loc! body (+ bloc (* (/ line dist) speed))) 269 | waypoints])) 270 | 271 | ;; [Listof Player] [Listof Food] -> [Listof Food] 272 | ;; feeds all players and removes food 273 | (define (feed-em-all players foods) 274 | (for/fold ([foods foods]) ([p players]) 275 | (eat-all-the-things p foods))) 276 | 277 | ;; IP [Listof Food] -> [Listof Food] 278 | ;; effect: fatten player as he eats 279 | ;; determine left-over foods 280 | (define (eat-all-the-things player foods) 281 | (define b (ip-body player)) 282 | (for/fold ([foods '()]) ([f foods]) 283 | (cond 284 | [(body-collide? f b) 285 | (set-body-size! b (+ PLAYER-FATTEN-DELTA (body-size b))) 286 | foods] 287 | [else (cons f foods)]))) 288 | 289 | ;; body body -> Boolean 290 | ;; Have two bodys collided? 291 | (define (body-collide? s1 s2) 292 | (<= (magnitude (- (body-loc s1) (body-loc s2))) 293 | (+ (body-size s1) (body-size s2)))) 294 | 295 | ;; [Listof Ip] [Listof Food] [Listof IP] -> Bundle 296 | ;; moves all objects. may end game 297 | (define (progress pls foods spectators) 298 | (define p (play pls foods spectators)) 299 | (cond [(empty? foods) (end-game-broadcast p)] 300 | [else (broadcast-universe p)])) 301 | 302 | ;; PlayUniverse -> [Bundle JoinUniverse] 303 | ;; ends the game, and restarts it 304 | (define (end-game-broadcast p) 305 | (define iws (get-iws p)) 306 | (define msg (list SCORE (score (play-players p)))) 307 | (define mls (broadcast iws msg)) 308 | (make-bundle (remake-join p) mls empty)) 309 | 310 | ;; Play-Universe -> JoinUniverse 311 | ;; Readies the ServerState for a new game 312 | (define (remake-join p) 313 | (define players (refresh (play-players p))) 314 | (define spectators (play-spectators p)) 315 | (join (append players spectators) START-TIME)) 316 | 317 | ;; [Listof Players] -> [Listof Players] 318 | ;; creates new players for new game 319 | (define (refresh players) 320 | (for/list ([p players]) 321 | (create-player (ip-iw p) (ip-id p)))) 322 | 323 | ;; [Listof IP] -> [Listof (list Id Score)] 324 | ;; makes the endgame message informing clients of all the size 325 | (define (score ps) 326 | (for/list ([p ps]) 327 | (list (ip-id p) (get-score (body-size (ip-body p)))))) 328 | 329 | ; 330 | ; 331 | ; 332 | ; 333 | ; ;;; ;;; 334 | ; ;; ;; 335 | ; ;; ;; ;;;; ;;;;; ;;;;; ;;;; ;;; ;; ;;;; ;;;;; 336 | ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; 337 | ; ; ; ; ;;;;;; ;;;; ;;;; ;;;;; ; ; ;;;;;; ;;;; 338 | ; ; ; ; ; ; ; ; ; ; ; ; 339 | ; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ; 340 | ; ;;; ;;; ;;;;; ;;;;; ;;;;; ;;; ;; ;;; ; ;;;;; ;;;;; 341 | ; ; 342 | ; ;;;; 343 | ; 344 | ; 345 | 346 | ;; ----------------------------------------------------------------------------- 347 | ;; Play Universe 348 | 349 | ;; Message -> Boolean 350 | ;; checks if message is a drag 351 | (define (goto? msg) 352 | (and (list? msg) 353 | (= GOTO-LENGTH (length msg)) 354 | (symbol? (first msg)) 355 | (number? (second msg)) 356 | (number? (third msg)) 357 | (symbol=? GOTO (first msg)) 358 | (<= 0 (second msg) WIDTH) 359 | (<= 0 (third msg) HEIGHT))) 360 | 361 | ;; PlayUniverse IWorld GotoMessage -> PlayUniverse 362 | ;; handles a player clicking. checks for collisions, updates score, removes food 363 | ;; Effect: changes a player's waypoints 364 | (define (goto p iw msg) 365 | (define c (make-rectangular (second msg) (third msg))) 366 | (set-play-players! p (add-waypoint (play-players p) c iw)) 367 | (broadcast-universe p)) 368 | 369 | ;; [Listof IPs] Complex IWorld -> [Listof IPs] 370 | ;; adds that complex to the waypoints of the given players 371 | (define (add-waypoint ps c iw) 372 | (for/list ([p ps]) 373 | (cond [(iworld=? (ip-iw p) iw) 374 | (ip (ip-iw p) 375 | (ip-id p) 376 | (ip-body p) 377 | (append (ip-waypoints p) (list c)))] 378 | [else p]))) 379 | 380 | ; 381 | ; 382 | ; 383 | ; 384 | ; ;;;; ; 385 | ; ; ; ; 386 | ; ; ;;;; ;; ;; ;; ;; ;;;; ;;; ; ;;;;; ;;; ;;;; ;; ;; 387 | ; ; ; ; ;; ; ;; ; ; ; ; ;; ; ; ; ; ;; ; 388 | ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; 389 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 390 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 391 | ; ;;; ;;;; ;;; ;;; ;;; ;;; ;;;;; ;;;; ;;; ;;;;; ;;;; ;;; ;;; 392 | ; 393 | ; 394 | ; 395 | ; 396 | 397 | 398 | ;; ----------------------------------------------------------------------------- 399 | ;; Join Universe 400 | 401 | ;; [Universe Player -> Universe] -> [Universe IWorld -> [Bundle Universe]] 402 | ;; creates a function that deals with a new connection during join or play phase 403 | (define (make-connection adder) 404 | (lambda (u iw) 405 | (define player (named-player iw)) 406 | (define mails (list (make-mail iw (ip-id player)))) 407 | (make-bundle (adder u player) mails empty))) 408 | 409 | ;; JoinUniverse IWorld ID -> [Bundle JoinUniverse] 410 | ;; creates an internal player for the IWorld, adds it to Universe as waiting player 411 | (define add-player (make-connection join-add-player)) 412 | 413 | ;; PlayUniverse IWorld -> [Bundle PlayUniverse] 414 | ;; creates an internal player for the IWorld, adds it to Universe as spectator 415 | (define add-spectator (make-connection play-add-spectator)) 416 | 417 | ;; [Listof IP] IWorld ->* Player 418 | (define (named-player iw) 419 | (create-player iw (symbol->string (gensym (iworld-name iw))))) 420 | 421 | ; 422 | ; 423 | ; 424 | ; 425 | ; ;;; ; ; ;; ; 426 | ; ; ;; ; 427 | ; ; ;;;; ;; ;;; ;;; ;;;; ; ;;; ;;;;; ;;;; 428 | ; ;;;; ; ; ;; ; ; ; ; ; ; ; ; ; 429 | ; ; ;;;;;; ; ; ;;;;; ; ; ; ;;;;;; 430 | ; ; ; ; ; ; ; ; ; ; ; 431 | ; ;; ; ; ; ; ; ;; ; ; ; ; ; 432 | ; ; ;;; ;;;;; ;;;;; ;;;;; ;;; ;; ;;;;; ;;;;; ;;;;; ;;;;; 433 | ; 434 | ; 435 | ; 436 | ; 437 | 438 | ;; PlayUniverse -> [Bundle PlayUniverse [Listof [Mail StateMessage]]] 439 | ;; bundle this universe, serialize it, broadcast it, and drop noone 440 | (define (broadcast-universe p) 441 | (define mails (broadcast (get-iws p) (serialize-universe p))) 442 | (make-bundle p mails empty)) 443 | 444 | ;; [Listof IWorlds] Message -> [Listof Mail] 445 | ;; sends mail to all clients 446 | (define (broadcast iws msgs) 447 | (map (lambda (iw) (make-mail iw msgs)) iws)) 448 | 449 | ;; PlayUniverse -> (list s [Listof SerializedPlayer] [Listof SerializedFood]) 450 | ;; prepairs a message for an update world/ServerState state 451 | (define (serialize-universe p) 452 | (define serialized-players (map ip-player (play-players p))) 453 | (list SERIALIZE serialized-players (play-food p))) 454 | 455 | ; 456 | ; 457 | ; 458 | ; 459 | ; ;;;; ; 460 | ; ; ; ; 461 | ; ; ; ;;; ;;;;; ;;; ; ;;;; ;; ;; ;; ;; ;;;; ;;; ; ;;;;; 462 | ; ; ; ; ; ; ; ;; ; ; ;; ; ;; ; ; ; ; ;; ; 463 | ; ; ; ; ;;;; ; ; ; ; ; ; ; ;;;;;; ; ; 464 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 465 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 466 | ; ;;;; ;;;;; ;;;;; ;;;; ;;;; ;;; ;;; ;;; ;;; ;;;;; ;;;; ;;; 467 | ; 468 | ; 469 | ; 470 | ; 471 | 472 | ;; JoinUniverse IWorld -> Bundle 473 | ;; remove that iworld from list of clients 474 | (define (drop-client j iw) 475 | (empty-bundle (join-remove j iw))) 476 | 477 | ;; PlayUniverse IWorld -> Bundle 478 | ;; removes a player from the ServerState and tells the players 479 | (define (drop-player p iw) 480 | (broadcast-universe (play-remove p iw))) 481 | 482 | ; 483 | ; 484 | ; 485 | ; 486 | ; ;; 487 | ; ; 488 | ; ; ; ;; ;; ;; ;; 489 | ; ; ; ; ; ; ; 490 | ; ; ; ; ; ;; 491 | ; ;;; ; ; ;; 492 | ; ; ; ; ;; ; ; 493 | ; ;;; ;;; ;; ;; ;; ;; 494 | ; 495 | ; 496 | ; 497 | ; 498 | 499 | ;; Number -> Body 500 | ;; creates a random body, that does not touch the edge 501 | (define (create-a-body size) 502 | (define x (+ size (random (- WIDTH size)))) 503 | (define y (+ size (random (- HEIGHT size)))) 504 | (body size (make-rectangular x y))) 505 | 506 | ;; PlayUniverse -> [Listof IWorlds] 507 | ;; gets the iworlds of all players 508 | (define (get-iws p) 509 | (map ip-iw (append (play-players p) (play-spectators p)))) 510 | 511 | ;; ServerState -> Bundle 512 | ;; makes a bundle that sends no messages and disconnects noone 513 | (define (empty-bundle s) 514 | (make-bundle s empty empty)) 515 | 516 | ;; IWorld Id -> IP 517 | ;; creates a player with that idnumber 518 | (define (create-player iw n) 519 | (ip iw n (create-a-body PLAYER-SIZE) empty)) 520 | 521 | ; 522 | ; 523 | ; 524 | ; 525 | ; ;;;;;;; 526 | ; ; ; ; ; 527 | ; ; ;;;; ;;;;; ;;;;; ;;;;; 528 | ; ; ; ; ; ; ; ; ; 529 | ; ; ;;;;;; ;;;; ; ;;;; 530 | ; ; ; ; ; ; 531 | ; ; ; ; ; ; ; ; ; 532 | ; ;;; ;;;;; ;;;;; ;;; ;;;;; 533 | ; 534 | ; 535 | ; 536 | ; 537 | 538 | (module+ test 539 | (require rackunit rackunit/text-ui) 540 | 541 | (define PROP-NUM 500) 542 | (define do-prop (make-parameter #t)) 543 | (do-prop #f) 544 | 545 | ;; thunk -> void 546 | ;; runs the thunk PROP-NUM times 547 | (define (check-property t) 548 | (when (do-prop) (test-begin (doo PROP-NUM t)))) 549 | 550 | ;; doo : number thunk -> 551 | ;; does the thunk n times 552 | (define (doo n l) 553 | (l) 554 | (unless (zero? n) 555 | (doo (sub1 n) l))) 556 | 557 | ;; testing main server 558 | 559 | ;; new-connection 560 | 561 | ;; drop-client 562 | (check-equal? (drop-client (join (list (ip iworld1 "player1" (body 10 1+10i) empty) 563 | (ip iworld2 "player2" (body 10 1+10i) empty) 564 | (ip iworld3 "player3" (body 10 1+10i) empty)) 100) 565 | iworld1) 566 | (empty-bundle (join (list (ip iworld2 "player2" (body 10 1+10i) empty) 567 | (ip iworld3 "player3" (body 10 1+10i) empty)) 568 | 100))) 569 | (check-equal? (drop-client (join (list (ip iworld1 "player1" (body 10 1+10i) empty) 570 | (ip iworld2 "player2" (body 10 1+10i) empty) 571 | (ip iworld3 "player3" (body 10 1+10i) empty)) 100) 572 | iworld2) 573 | (empty-bundle (join (list (ip iworld1 "player1" (body 10 1+10i) empty) 574 | (ip iworld3 "player3" (body 10 1+10i) empty)) 100))) 575 | (check-equal? (drop-client (join (list (ip iworld1 "player1" (body 10 1+10i) empty) 576 | (ip iworld2 "player2" (body 10 1+10i) empty) 577 | (ip iworld3 "player3" (body 10 1+10i) empty)) 100) 578 | iworld3) 579 | (empty-bundle (join (list (ip iworld1 "player1" (body 10 1+10i) empty) 580 | (ip iworld2 "player2" (body 10 1+10i) empty)) 100))) 581 | 582 | ;; remove-player 583 | (check-equal? (drop-player 584 | (play (list (ip iworld1 "player10" (body 10 1+10i) empty) 585 | (ip iworld2 "player345" (body 56 3+45i) empty)) 586 | (list (body 87 67+23i) 587 | (body 5 3+4i)) 588 | empty) 589 | iworld1) 590 | (let ([remd (play-remove 591 | (play (list (ip iworld1 "player10" (body 10 1+10i) empty) 592 | (ip iworld2 "player345" (body 56 3+45i) empty)) 593 | (list (body 87 67+23i) 594 | (body 5 3+4i)) 595 | empty) 596 | iworld1)]) 597 | (broadcast-universe remd) 598 | #; 599 | (make-bundle remd (serial/broadcast-univ remd) empty))) 600 | 601 | (check-equal? (drop-player 602 | (play (list (ip iworld2 "player345" (body 56 3+45i) empty)) 603 | (list (body 87 67+23i) 604 | (body 5 3+4i)) 605 | (list (ip iworld1 "player10" (body 10 1+10i) empty))) 606 | iworld1) 607 | (let ([remd (play-remove 608 | (play (list (ip iworld1 "player10" (body 10 1+10i) empty) 609 | (ip iworld2 "player345" (body 56 3+45i) empty)) 610 | (list (body 87 67+23i) 611 | (body 5 3+4i)) 612 | empty) 613 | iworld1)]) 614 | (broadcast-universe remd) 615 | #; 616 | (make-bundle remd (serial/broadcast-univ remd) empty))) 617 | 618 | ;; ready-to-go 619 | (check-false (keep-waiting? (join (list (create-player iworld1 "player") 620 | (create-player iworld2 "player")) 621 | 250))) 622 | (check-false (keep-waiting? (join (list (create-player iworld1 "player") 623 | (create-player iworld1 "player") 624 | (create-player iworld2 "player")) 625 | 456345132135213))) 626 | (check-true (keep-waiting? (join (list (create-player iworld2 "player")) -234))) 627 | (check-true (keep-waiting? (join (list (create-player iworld2 "player")) 10))) 628 | 629 | 630 | 631 | ;; handle-join 632 | ;; name 633 | ;; update-player 634 | 635 | ;; remove-player-by-iworld 636 | (check-equal? (play-remove 637 | (play (list (ip iworld1 "player10" (body 10 1+10i) empty) 638 | (ip iworld2 "player324" (body 56 3+45i) empty)) 639 | (list (body 87 67+23i) 640 | (body 5 3+4i)) 641 | empty) 642 | iworld1) 643 | (play (list (ip iworld2 "player324" (body 56 3+45i) empty)) 644 | (list (body 87 67+23i) 645 | (body 5 3+4i)) 646 | empty) 647 | "play-remove: test 1") 648 | (check-equal? (play-remove 649 | (play (list (ip iworld2 "player324" (body 56 3+45i) empty)) 650 | (list (body 87 67+23i) 651 | (body 5 3+4i)) 652 | empty) 653 | iworld2) 654 | (play (list) 655 | (list (body 87 67+23i) 656 | (body 5 3+4i)) 657 | empty) 658 | "play-remove: test 1") 659 | 660 | ;; testing messaging 661 | 662 | ;; goto? 663 | 664 | (check-true (goto? '(goto 3 2))) 665 | (check-true (goto? '(goto 3 2))) 666 | (check-true (goto? '(goto 0 2))) 667 | (check-true (goto? '(goto 6 2))) 668 | (check-false (goto? `(goto ,(add1 WIDTH) 0))) 669 | (check-false (goto? `(goto 0 ,(add1 HEIGHT)))) 670 | (check-false (goto? '(goto -1 0))) 671 | (check-false (goto? '(goto 0 -1))) 672 | (check-false (goto? '(goto 1))) 673 | (check-false (goto? '(drag 6+2i))) 674 | (check-false (goto? '(drag 1))) 675 | (check-false (goto? '(6+1i))) 676 | (check-false (goto? '(1 2))) 677 | (check-false (goto? '(goto 6+2i))) 678 | (check-false (goto? '(drag 1 2))) 679 | (check-false (goto? 'click)) 680 | (check-false (goto? "click")) 681 | (check-false (goto? #t)) 682 | 683 | ;;add-waypoint 684 | 685 | (check-equal? (add-waypoint `(,(ip iworld1 "player10" (body 10 1+10i) empty)) 8+9i iworld1) 686 | (list (ip iworld1 "player10" (body 10 1+10i) '(8+9i)))) 687 | (check-equal? (add-waypoint `(,(ip iworld1 "player10" (body 10 1+10i) '(23+45i))) 8+9i iworld1) 688 | (list (ip iworld1 "player10" (body 10 1+10i) '(23+45i 8+9i)))) 689 | 690 | ;; goto 691 | 692 | (check-equal? (goto (play (list (ip iworld1 "player10" (body 10 1+10i) empty) 693 | (ip iworld2 "player345" (body 56 3+45i) empty)) 694 | (list (body 87 67+23i) 695 | (body 5 3+4i)) 696 | empty) 697 | iworld1 '(goto 1 1)) 698 | (let ([state (play (list (ip iworld1 "player10" (body 10 1+10i)'(1+1i)) 699 | (ip iworld2 "player345" (body 56 3+45i) empty)) 700 | (list (body 87 67+23i) 701 | (body 5 3+4i)) 702 | empty)]) 703 | (broadcast-universe state) 704 | #; 705 | (make-bundle state (serial/broadcast-univ state) empty))) 706 | 707 | (check-equal? (goto (play (list (ip iworld1 "player10" (body 10 1+10i) '(1+4i)) 708 | (ip iworld2 "player345" (body 56 3+45i) empty)) 709 | (list (body 87 67+23i) 710 | (body 5 3+4i)) 711 | empty) 712 | iworld1 '(goto 1 1)) 713 | (let ([state (play (list (ip iworld1 "player10" (body 10 1+10i) '(1+4i 1+1i)) 714 | (ip iworld2 "player345" (body 56 3+45i) empty)) 715 | (list (body 87 67+23i) 716 | (body 5 3+4i)) 717 | empty)]) 718 | (broadcast-universe state) 719 | #; 720 | (make-bundle state (serial/broadcast-univ state) empty))) 721 | 722 | ;; eat-all-the-things 723 | (check-equal? (eat-all-the-things (ip iworld1 "player10" (body 11 0) '(1+10i)) (list (body 10 0))) 724 | empty) 725 | (check-equal? (eat-all-the-things (ip iworld1 "player10" (body 10 0) '(1+10i)) (list (body 10 40+5i))) 726 | (list (body 10 40+5i))) 727 | 728 | ;; testing initialization 729 | 730 | ;; property of no motion to same point in move-body 731 | ;; also checks for divide by zero error in move-player* 732 | (define (property:no-same-point) 733 | (define (random-near n) 734 | (define ε 1/1000000) 735 | (+ n (* (random 10) ε (sub1 (* 2 (random 2)))))) 736 | 737 | (define test-body (create-a-body 1)) 738 | 739 | (define waypoints 740 | (for/list ([r (in-range (add1 (random 100)))]) 741 | (define x (real-part (body-loc test-body))) 742 | (define y (imag-part (body-loc test-body))) 743 | (make-rectangular (random-near x) (random-near y)))) 744 | 745 | (define random-p (ip iworld1 "nope" test-body waypoints)) 746 | 747 | (define (test p) 748 | (cond [(empty? (ip-waypoints p)) 749 | #t] 750 | [(= (first (ip-waypoints p)) 751 | (body-loc (ip-body p))) 752 | #f] 753 | [else (test (move-player* (list p)))])) 754 | 755 | (check-true (test random-p))) 756 | 757 | ;; does spawn food create the nessecary amount of food? 758 | (define (property:player/food-number-correct) 759 | (define players (random 50)) 760 | (check-equal? (length (bake-cupcakes players)) 761 | (* FOOD*PLAYERS players))) 762 | 763 | ;; is random-body on the board? 764 | (define (test-body-in-bounds) 765 | (define size 10) 766 | (define body (create-a-body size)) 767 | (check-true (and (< size (real-part (body-loc body)) (- WIDTH size)) 768 | (< size (imag-part (body-loc body)) (- HEIGHT size))) 769 | "body out of bounds")) 770 | 771 | 772 | 773 | 774 | ;;create-name 775 | ;; (check-equal? (create-name empty "john") "john") 776 | ;; (check-equal? (create-name (list (ip iworld1 "player10" (body 10 0) '(1+10i))) "player10") "player10*") 777 | #; 778 | (check-equal? (create-name (list (ip iworld1 "player10" (body 10 0) '(1+10i)) 779 | (ip iworld1 "player10*" (body 10 0) '(1+10i))) 780 | "player10") 781 | "player10**") 782 | #; 783 | (check-property property:unique-name) 784 | 785 | ;; spawn-food 786 | (check-property property:player/food-number-correct) 787 | 788 | ;; random-body 789 | (check-property test-body-in-bounds) 790 | 791 | ;; testing clock tick handling 792 | 793 | (define tbody1 (body 100 1+3i)) 794 | (define tbody2 (body 100 1)) 795 | (define tbody3 (body 100 0+3i)) 796 | (define tbody4 (body 100 101)) 797 | 798 | (define waypoints1 '(1+3i 1 0+3i 10+10i)) 799 | (define waypoints2 '(100)) 800 | 801 | ;; move-player* 802 | (check-equal? (move-player* 803 | (list (ip iworld1 "player10" (body 10 1+10i) '(1+10.01i)))) 804 | (list (ip iworld1 "player10" (body 10 1+10.01i) empty))) 805 | (check-property property:no-same-point) 806 | ;; move-twards-waypoint 807 | 808 | 809 | (test-begin 810 | (check-equal? (move-toward-waypoint tbody1 waypoints1) 811 | (rest waypoints1) 812 | "waypoint removal failed") 813 | (check-equal? tbody1 (body 100 1+3i) "movement failed") 814 | (set! tbody1 (body 100 1+3i))) 815 | 816 | (test-begin 817 | ;; test dependent on (< BASE-SPEED 100) 818 | (check-equal? (move-toward-waypoint tbody2 waypoints2) 819 | waypoints2 820 | "waypoint removal failed") 821 | (check-equal? tbody2 (body 100 (+ 1 (make-rectangular (/ BASE-SPEED 100) 0))) 822 | "movement failed") 823 | (set! tbody2 (body 100 1))) 824 | 825 | (test-begin 826 | (check-equal? (move-toward-waypoint tbody4 waypoints2) 827 | '()) 828 | (check-equal? tbody4 (body 100 100)) 829 | (set! tbody4 (body 100 101))) 830 | 831 | ;; countdown 832 | (check-equal? (wait-or-play (join (list (ip iworld1 "player10" (body 10 1+10i) empty)) 0)) 833 | (make-bundle 834 | (join (list (ip iworld1 "player10" (body 10 1+10i) empty)) 1) 835 | (broadcast (list iworld1) (/ 1 WAIT-TIME)) 836 | empty)) 837 | (check-equal? (wait-or-play (join empty 0)) 838 | (empty-bundle (join empty 1))) 839 | 840 | ;;countdown 841 | (check-equal? (wait-or-play (join (list (ip iworld1 "player10" (body 10 1+10i) empty) 842 | (ip iworld1 "player345" (body 56 3+45i) empty)) 843 | 100)) 844 | (make-bundle (join (list (ip iworld1 "player10" (body 10 1+10i) empty) 845 | (ip iworld1 "player345" (body 56 3+45i) empty)) 846 | 101) 847 | (broadcast (list iworld1 iworld1) (/ 101 WAIT-TIME)) 848 | empty)) 849 | (check-equal? (wait-or-play (join (list (ip iworld1 "player10" (body 10 1+10i) empty) 850 | (ip iworld1 "player345" (body 56 3+45i) empty)) 851 | 1)) 852 | (make-bundle (join (list (ip iworld1 "player10" (body 10 1+10i) empty) 853 | (ip iworld1 "player345" (body 56 3+45i) empty)) 854 | 2) 855 | (broadcast (list iworld1 iworld1) (/ 2 WAIT-TIME)) 856 | empty)) 857 | ;; progress 858 | (check-equal? (progress 859 | (list (ip iworld1 "player10" (body 10 1+10i) empty) 860 | (ip iworld1 "player345" (body 56 3+45i) empty)) 861 | (list (body 87 67+23i) 862 | (body 5 3+4i)) 863 | empty) 864 | (broadcast-universe 865 | (play (list (ip iworld1 "player10" (body 10 1+10i) empty) 866 | (ip iworld1 "player345" (body 56 3+45i) empty)) 867 | (list (body 87 67+23i) 868 | (body 5 3+4i)) 869 | empty)) 870 | #; 871 | (make-bundle 872 | (play (list (ip iworld1 "player10" (body 10 1+10i) empty) 873 | (ip iworld1 "player345" (body 56 3+45i) empty)) 874 | (list (body 87 67+23i) 875 | (body 5 3+4i)) 876 | empty) 877 | (serial/broadcast-univ (play (list (ip iworld1 "player10" (body 10 1+10i) empty) 878 | (ip iworld1 "player345" (body 56 3+45i) empty)) 879 | (list (body 87 67+23i) 880 | (body 5 3+4i)) 881 | empty)) 882 | empty)) 883 | 884 | ;; body-collide? 885 | (check-true (body-collide? (body 10 10+10i) (body 10 10+10i))) 886 | (check-true (body-collide? (body 10 10+10i) (body 10 0+10i))) 887 | (check-true (body-collide? (body 10 10+10i) (body 10 10))) 888 | (check-true (body-collide? (body 10 10+10i) (body 10 20))) 889 | (check-true (body-collide? (body 10 10+10i) (body 10 0+20i))) 890 | 891 | (check-false (body-collide? (body 1 10+10i) (body 1 10+13i))) 892 | (check-false (body-collide? (body 1 10+10i) (body 1 0+10i))) 893 | (check-false (body-collide? (body 1 10+10i) (body 1 10))) 894 | (check-false (body-collide? (body 1 10+10i) (body 1 20))) 895 | (check-false (body-collide? (body 1 10+10i) (body 1 0+20i))) 896 | 897 | ;; serial/broadcast-univ 898 | #; 899 | (check-equal? (serial/broadcast-univ 900 | (play (list (ip iworld1 "player10" (body 10 1+10i) empty) 901 | (ip iworld2 "player345" (body 56 3+45i) empty)) 902 | (list (body 87 67+23i) 903 | (body 5 3+4i)) 904 | empty)) 905 | (let ([serialized (serialize-universe (play (list (ip iworld1 "player10" (body 10 1+10i) empty) 906 | (ip iworld2 "player345" (body 56 3+45i) empty)) 907 | (list (body 87 67+23i) 908 | (body 5 3+4i)) 909 | empty))]) 910 | (list (make-mail iworld1 serialized) 911 | (make-mail iworld2 serialized)))) 912 | 913 | ;; time-broadcast 914 | (let ([j (join '() 100)]) 915 | (check-equal? (time-broadcast j) 916 | (make-bundle j '() '()))) 917 | (let ([j (join `(,(ip iworld1 "sallyjoe" (body 0 0+0i) '())) 100)]) 918 | (check-equal? (time-broadcast j) 919 | (make-bundle j `(,(make-mail iworld1 (/ 100 WAIT-TIME))) '()))) 920 | 921 | ;; testing auxiliary functions 922 | (check-equal? (score `(,(ip iworld1 "foo" (body 1000 +inf.0) '()) 923 | ,(ip iworld1 "bar" (body 0 +inf.0) '()))) 924 | `(("foo" ,(get-score 1000)) 925 | ("bar" ,(get-score 0)))) 926 | ;; get-iws 927 | ;; empty-bundle 928 | (check-equal? (empty-bundle (join (list (ip iworld1 "player10" (body 10 1+10i) empty) 929 | (ip iworld2 "player345" (body 56 3+45i) empty)) 132)) 930 | (make-bundle (join (list (ip iworld1 "player10" (body 10 1+10i) empty) 931 | (ip iworld2 "player345" (body 56 3+45i) empty)) 132) empty empty)) 932 | (check-equal? (empty-bundle (join (list (ip iworld1 "player10" (body 10 1+10i) empty) 933 | (ip iworld2 "player345" (body 56 3+45i) empty)) 345)) 934 | (make-bundle (join (list (ip iworld1 "player10" (body 10 1+10i) empty) 935 | (ip iworld2 "player345" (body 56 3+45i) empty)) 345) empty empty)) 936 | (check-equal? (empty-bundle (play (list (ip iworld1 "player1" (body 87 67+23i) empty)) 937 | (list (body 87 67+23i) 938 | (body 89 32+345i)) 939 | empty)) 940 | (make-bundle 941 | (play (list (ip iworld1 "player1" (body 87 67+23i) empty)) 942 | (list (body 87 67+23i) 943 | (body 89 32+345i)) 944 | empty) 945 | empty 946 | empty)) 947 | 948 | ;; get-iws 949 | (check-equal? (get-iws (play (list (ip iworld1 "player10" (body 10 1+10i) empty) 950 | (ip iworld2 "player345" (body 56 3+45i) empty)) 951 | (list (body 87 67+23i) 952 | (body 5 3+4i)) 953 | empty)) 954 | (list iworld1 iworld2)) 955 | (check-equal? (get-iws (play (list (ip iworld1 "player10" (body 10 1+10i) empty)) 956 | empty 957 | empty)) 958 | (list iworld1)) 959 | ;; broadcast 960 | (check-equal? (broadcast (list iworld1 iworld3 iworld2) 961 | '(testing testing 1 2 3)) 962 | (let ([message '(testing testing 1 2 3)]) 963 | (list (make-mail iworld1 964 | message) 965 | (make-mail iworld3 966 | message) 967 | (make-mail iworld2 968 | message)))) 969 | (check-equal? (broadcast (list iworld1) 970 | '(testing testing 1 2 3)) 971 | (let ([message '(testing testing 1 2 3)]) 972 | (list (make-mail iworld1 973 | message)))) 974 | (check-equal? (broadcast (list iworld1 iworld3) 975 | 9) 976 | (let ([message 9]) 977 | (list (make-mail iworld1 978 | message) 979 | (make-mail iworld3 980 | message)))) 981 | 982 | ;; broadcast-state 983 | (let ([state (play (list (ip iworld1 "player10" (body 10 1+10i) empty) 984 | (ip iworld2 "player345" (body 56 3+45i) empty)) 985 | (list (body 87 67+23i) 986 | (body 5 3+4i)) 987 | empty)]) 988 | (check-equal? (broadcast-universe state) 989 | (broadcast-universe state))) 990 | 991 | "server: all tests run") 992 | -------------------------------------------------------------------------------- /chapter14/shared.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; This module describes the shared vocabulary and knowledge for the server 4 | ;; and client modules of the Hungry Henry game. 5 | 6 | (provide ;; type Id 7 | id? ;; Any -> Boolean : Id 8 | id=? ;; Id Id -> Boolean 9 | ;; type GOTO 10 | ;; type SOTO = Time | Ackn | State | Score 11 | ;; type Food 12 | ;; type Feaster 13 | ;; type Body 14 | (struct-out player) ;; 15 | (struct-out body) ;; 16 | get-score ;; Nat -> Nat 17 | PLAYER-FATTEN-DELTA 18 | WIDTH HEIGHT CUPCAKE PLAYER-SIZE 19 | SCORE GOTO SERIALIZE 20 | GOTO-LENGTH) 21 | 22 | #| ----------------------------------------------------------------------------- 23 | 24 | ;; --- Tasks -------------------------------------------------------------------- 25 | 26 | The game server keeps track of the entire game state [to avoid cheating by 27 | lients]. It collects waypoints, moves the avatars on behalf of the clients, 28 | detects collisions with cupcakes, has avatars eat and grow, and discovers the 29 | end of the game. As events occur, it informs all clients about all actions and, 30 | at the end of the game, tallies the scores. 31 | 32 | Each client displays the current state of the game as broadcast by the server. 33 | It also records and sends all mouse clicks to the server. 34 | 35 | ;; --- Messages and Protocol --------------------------------------------------- 36 | 37 | The server and the client exchange messages to inform each other about 38 | the events in the game. 39 | 40 | Client To Server Message: 41 | ------------------------ 42 | 43 | GOTO = (list GOTO PositiveNumber PositiveNumber) 44 | represents the coordinates of player's latest waypoint, 45 | obtained via a mouse click. 46 | Constraint: in (list GOTO x y), (and (<= 0 x WIDTH) (<= 0 y HEIGHT)) 47 | 48 | Server to Client Message: 49 | ------------------------- 50 | 51 | SOTO is one of: 52 | -- Number ∈ [0,1] 53 | called a Time message 54 | repreents the percentage of loading time left 55 | -- ID 56 | called an Ackn message 57 | represents the unique id that the server assigns to the client, 58 | based on the client's name 59 | -- (list SERIALIZE [Listof Feaster] [Listof Food]) 60 | called a State message 61 | represents the complete current state of the game 62 | -- (list SCORE [Listof (list Id Natural)]) 63 | called a Score message 64 | informs clients that the game is over and the sizes of each player. 65 | |# 66 | ;; Shared Data Definitions for Messages 67 | 68 | (struct player (id body waypoints) #:prefab) 69 | (struct body (size loc) #:prefab #:mutable) 70 | ;; Food = Body 71 | ;; Feaster = (player Id Body [Listof Complex]) 72 | ;; interpretation: 73 | ;; -- id is the player's id 74 | ;; -- body is the player's size and location 75 | ;; -- loc are the player's waypoints, ordered from first to last 76 | ;; Body = (body PositiveNumber Complex) 77 | ;; interpretation: any 'body' on the playing field, both players and cupcakes 78 | ;; -- the postive number specifies the body's size 79 | ;; -- the complex number represents the body's location 80 | ;; PlayerId = String 81 | (define id? string?) 82 | (define id=? string=?) 83 | 84 | ;; Message ID Constants 85 | (define SCORE 'score) 86 | (define SERIALIZE 'state) 87 | (define GOTO 'goto) 88 | (define GOTO-LENGTH 3) 89 | 90 | #| --- Protocol ---------------------------------------------------------------- 91 | 92 | Client1 Client2 Server 93 | | | | 94 | | register(name1) | [universe protocol] 95 | |----------------------------->| 96 | | | | 97 | | | ID | an identifier message 98 | |<-----------------------------| 99 | | | t | percentage of wait time 100 | |<-----------------------------| 101 | |<-----------------------------| 102 | |<-----------------------------| 103 | | | | 104 | | | register(name2) 105 | | |------------->| 106 | | | | 107 | | | ID | 108 | | |<-------------| 109 | | | t | percentage of wait time 110 | |<-----------------------------| 111 | | |<-------------| 112 | |<-----------------------------| 113 | | |<-------------| 114 | | | | <==== end of wait time [clock, players] 115 | | state msg | 116 | |<-----------------------------| `(state (,feaster1 ,feaster2) ,foods) 117 | | |<-------------| 118 | | | | 119 | click | GOTO | | `(goto ,x ,y) 120 | ====> |----------------------------->| new state 121 | | | | 122 | | state msg | 123 | |<-----------------------------| `(state (,feaster1 ,feaster2) ,foods) 124 | | |<-------------| 125 | | | | 126 | | | | move, eat: 127 | |<-----------------------------| `(state (,feaster1 ,feaster2) ,foods) 128 | | |<-------------| 129 | | | | 130 | | click | GOTO | `(goto ,x ,y) 131 | | ====> |------------->| 132 | | | | 133 | | state msg | 134 | |<-----------------------------| `(state (,feaster1 ,feaster2) ,foods) 135 | | |<-------------| 136 | | | | 137 | | score msg | all food is eaten: 138 | |<-----------------------------| `(score ((,id ,score) ...)) 139 | | |<-------------| 140 | | | | 141 | --- --- --- 142 | 143 | |# 144 | 145 | ;; Shared Logical Constants 146 | (define WIDTH 1000) 147 | (define HEIGHT 700) 148 | (define CUPCAKE 15) 149 | (define PLAYER-SIZE (* 3 CUPCAKE)) 150 | (define PLAYER-FATTEN-DELTA 5) 151 | 152 | ;; Number -> Number ;; move to serer 153 | ;; gets aplayers score given its fatness 154 | (define (get-score f) 155 | (/ (- f PLAYER-SIZE) PLAYER-FATTEN-DELTA)) 156 | 157 | -------------------------------------------------------------------------------- /chapter2/readme.txt: -------------------------------------------------------------------------------- 1 | 2 | This chapter implements a primitive, Lisp-style version of the "guess my 3 | numbers" game. Open the file 4 | 5 | source.rkt 6 | 7 | in DrRacket. The instructions for playing are at the top of the file. 8 | Our tests are at the bottom of the file in a separate 'test' submodule. 9 | 10 | -------------------------------------------------------------------------------- /chapter2/source.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | The Guess My Number game, played at DrRacket's REPL 5 | --------------------------------------------------- 6 | 7 | You pick a number. The program guesses the nunber, 8 | by asking you questions. Your responses are "too 9 | small" "too large" or "you guessed it". 10 | 11 | Play 12 | ---- 13 | 14 | Click Run. Pick a number X between and . 15 | Evaluate 16 | (start ) 17 | The program will respond with a number. 18 | Use 19 | (bigger) 20 | and 21 | (smaller) 22 | to let it know what you think of its guess. 23 | |# 24 | 25 | ; 26 | ; 27 | ; 28 | ; ; 29 | ; ; 30 | ; ;;; ;;; 31 | ; ;; ;; 32 | ; ; ; ; ; ;;;; ;;; ;; ;;; 33 | ; ; ; ; ; ; ; ; ;; ; 34 | ; ; ; ; ; ; ; ; ; 35 | ; ; ; ; ;;;;;; ; ; ; 36 | ; ; ; ; ; ; ; ; 37 | ; ; ; ; ;; ; ; ; 38 | ; ;;; ;;; ;;;; ;; ;;;;;;; ;;; ;;; 39 | ; 40 | ; 41 | ; 42 | ; 43 | 44 | ;; Example: 45 | ;; > (start 0 100) ; [0,100] 46 | ;; 50 47 | ;; > (bigger) ; [51,100] 48 | ;; 75 49 | ;; > (bigger) ; [76,100] 50 | ;; 88 51 | ;; > (smaller) ; [76,87] 52 | ;; 82 53 | 54 | ;; Number Number -> Number 55 | ;; Start a new game in [n,m] and make a guess. 56 | ;; > (start 0 100) 57 | ;; 50 58 | (define (start n m) 59 | (set! lower (min n m)) 60 | (set! upper (max n m)) 61 | (guess)) 62 | 63 | ;; Lower and upper bounds on the number 64 | (define lower 1) 65 | (define upper 100) 66 | 67 | ;; -> Number Number 68 | ;; Guess half-way between lower and upper bounds. 69 | ;; > (begin (start 0 100) (guess)) 70 | ;; 50 71 | (define (guess) 72 | (quotient (+ lower upper) 2)) 73 | 74 | ;; -> Number 75 | ;; Lower the upper bound and guess again. 76 | ;; > (begin (start 0 100) (smaller)) 77 | ;; 24 78 | (define (smaller) 79 | (set! upper (max lower (sub1 (guess)))) 80 | (guess)) 81 | 82 | ;; -> Number 83 | ;; Raise the lower bound and guess again. 84 | ;; > (begin (start 0 100) (bigger)) 85 | ;; 75 86 | (define (bigger) 87 | (set! lower (min upper (add1 (guess)))) 88 | (guess)) 89 | 90 | ; 91 | ; 92 | ; 93 | ; 94 | ; 95 | ; ;;;;;;; ; 96 | ; ; ; ; ; 97 | ; ; ; ; ;;; ;;;; ; ;;;;;;; ;;;; ; 98 | ; ; ; ; ; ; ; ;; ; ; ;; 99 | ; ; ; ; ; ; ; 100 | ; ; ;;;;;;; ;;;;; ; ;;;;; 101 | ; ; ; ; ; ; 102 | ; ; ; ; ; ; ; ; ; ; 103 | ; ;;;;; ;;;; ;;;;;; ;;;; ;;;;;; 104 | ; 105 | ; 106 | ; 107 | ; 108 | 109 | 110 | (module+ test 111 | 112 | (require rackunit rackunit/text-ui) 113 | 114 | ;; basic guesses 115 | 116 | (check-equal? (guess) 50) 117 | 118 | (check-equal? (start 0 100) 50) 119 | 120 | (check-equal? (begin (start 0 100) lower) 0) 121 | (check-equal? (begin (start 0 100) upper) 100) 122 | (check-equal? (begin (start 0 100) (smaller)) 24) 123 | (check-equal? (begin (start 0 000) (smaller)) 0) 124 | (check-equal? (begin (start 0 100) (smaller) lower) 0) 125 | (check-equal? (begin (start 0 100) (smaller) upper) 49) 126 | (check-equal? (begin (start 0 100) (bigger)) 75) 127 | (check-equal? (begin (start 0 000) (bigger)) 0) 128 | 129 | ;; testing a sequence of interactions with expected intermediate states 130 | 131 | (test-begin (start 0 100) 132 | (bigger) 133 | (check-equal? lower 51) 134 | (check-equal? upper 100) 135 | (bigger) 136 | (check-equal? lower 76) 137 | (check-equal? upper 100) 138 | (smaller) 139 | (check-equal? lower 76) 140 | (check-equal? upper 87)) 141 | 142 | ;; doing it all over for negative numbers 143 | 144 | (check-equal? (start -100 0) -50) 145 | 146 | (check-equal? (begin (start -100 0) lower) -100) 147 | (check-equal? (begin (start -100 0) upper) 0) 148 | (check-equal? (begin (start -100 0) (smaller)) -75) 149 | (check-equal? (begin (start -100 0) (smaller)) -75) 150 | (check-equal? (begin (start -100 0) (smaller) lower) -100) 151 | (check-equal? (begin (start -100 0) (smaller) upper) -51) 152 | (check-equal? (begin (start -100 0) (bigger)) -24) 153 | (check-equal? (begin (start -100 0) (bigger)) -24) 154 | 155 | (test-begin (start -100 0) 156 | (bigger) 157 | (check-equal? lower -49) 158 | (check-equal? upper 0) 159 | (bigger) 160 | (check-equal? lower -23) 161 | (check-equal? upper 0) 162 | (smaller) 163 | (check-equal? lower -23) 164 | (check-equal? upper -12)) 165 | 166 | 167 | ;; --------------------------------------------------------------------------- 168 | ;; testing random properties of our functions 169 | 170 | ;; Property: 171 | ;; For all games starting in [n,m] after any number of moves, 172 | ;; lower <= upper. 173 | (define (prop:ordered n m i) 174 | (check-true 175 | (begin (start n m) 176 | (random-moves i) 177 | (<= lower upper)))) 178 | 179 | ;; Property: 180 | ;; For all games starting in [n,m], for any number of moves, 181 | ;; lower grows up, upper grows down, or they are equal. 182 | (define (prop:monotonic n m i) 183 | (check-true 184 | (begin (start n m) 185 | (for/and ([i (in-range i)]) 186 | (define l lower) 187 | (define u upper) 188 | (random-move) 189 | (or (and (< l lower) (= u upper)) 190 | (and (= l lower) (> u upper)) 191 | (and (= l lower) (= u upper))))))) 192 | 193 | ;; Number -> Void 194 | ;; Move randomly n times. 195 | (define (random-moves i) 196 | (unless (zero? i) 197 | (random-move) 198 | (random-moves (sub1 i)))) 199 | 200 | ;; -> Void 201 | ;; Move randomly once. 202 | (define (random-move) 203 | (if (zero? (random 2)) 204 | (smaller) 205 | (bigger))) 206 | 207 | ;; property tests 208 | (for ([i (in-range 1000)]) 209 | (prop:ordered (random 1000) (random 1000) (random 100)) 210 | (prop:monotonic (random 1000) (random 1000) (random 100))) 211 | 212 | ;; reset the boundaries to defaults 213 | (start 1 100) 214 | 215 | "all tests run") 216 | -------------------------------------------------------------------------------- /chapter5/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define compile-omit-paths '("ufo-source.rkt" "new-ufo-source.rkt")) 4 | -------------------------------------------------------------------------------- /chapter5/readme.txt: -------------------------------------------------------------------------------- 1 | 2 | This chapter implements an interactive, graphical version of the "guess my 3 | numbers" game. Open the file 4 | 5 | source.rkt 6 | 7 | in DrRacket. The instructions for starting are at the top of the file. 8 | Our tests are at the bottom of the file in a separate 'test' submodule. 9 | 10 | ;; ----------------------------------------------------------------------------- 11 | 12 | If you wish to experiment with a small world program, open 13 | 14 | ufo-source.rkt 15 | 16 | The file runs a UFO from the top of the screen to the bottom. 17 | 18 | 19 | -------------------------------------------------------------------------------- /chapter5/source.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | The Guess My Number game, with a simple graphical user interface (GUI) 5 | ---------------------------------------------------------------------- 6 | 7 | You pick a number. The program guesses the nunber, 8 | by asking you questions. Your responses are "too 9 | small" "too large" or "you guessed it". 10 | 11 | Play 12 | ---- 13 | 14 | Click Run. Pick a number X between and . 15 | Evaluate 16 | (start ) 17 | This will pop up a window with instructions for interacting with the program. 18 | |# 19 | 20 | (require 2htdp/image 2htdp/universe) 21 | 22 | ; 23 | ; 24 | ; 25 | ; ; 26 | ; 27 | ; ; ;; ;; ;;;; ;;; ; ;; 28 | ; ;; ;; ; ; ; ;; ; 29 | ; ; ; ; ;;;; ; ; ; 30 | ; ; ; ; ; ; ; ; ; 31 | ; ; ; ; ; ;; ; ; ; 32 | ; ; ; ; ;; ; ; ; ; 33 | ; 34 | ; 35 | 36 | ;; Number Number -> GuessRange 37 | ;; Start playing a new game in [n,m] 38 | ;; > (start 0 100) ; Press up, up, down, q. 39 | ;; (interval 76 87) 40 | (define (start lower upper) 41 | (big-bang (interval lower upper) 42 | (on-key deal-with-guess) 43 | (to-draw render) 44 | (stop-when single? render))) 45 | 46 | ; 47 | ; 48 | ; 49 | ; 50 | ; ; ; 51 | ; ;;;; ;;;;; ;;;; ;;;;; ;;; 52 | ; ; ; ; ; ; ; 53 | ; ;; ; ;;;; ; ;;;;; 54 | ; ; ; ; ; ; ; 55 | ; ; ; ; ;; ; ; 56 | ; ;;;; ;;; ;; ; ;;; ;;;; 57 | ; 58 | ; 59 | 60 | (struct interval (small big) #:transparent) 61 | ;; A GuessRange is a (interval Number Number) 62 | ;; Always true: (interval l u) means (<= l u). 63 | 64 | ; 65 | ; 66 | ; 67 | ; 68 | ; ; ; 69 | ; ;;;; ;;; ; ;; ;;;; ;;;;; ;;;; ; ;; ;;;;; ;;;; 70 | ; ; ; ; ;; ; ; ; ; ;; ; ; ; 71 | ; ; ; ; ; ; ;; ; ;;;; ; ; ; ;; 72 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; 73 | ; ; ; ; ; ; ; ; ; ;; ; ; ; ; 74 | ; ;;;; ;;; ; ; ;;;; ;;; ;; ; ; ; ;;; ;;;; 75 | ; 76 | ; 77 | 78 | (define TEXT-SIZE 11) 79 | (define HELP-TEXT 80 | (text "↑ for larger numbers, ↓ for smaller ones" 81 | TEXT-SIZE 82 | "blue")) 83 | (define HELP-TEXT2 84 | (text "Press = when your number is guessed; q to quit." 85 | TEXT-SIZE 86 | "blue")) 87 | (define WIDTH (+ (image-width HELP-TEXT2) 10)) 88 | (define HEIGHT 150) 89 | (define COLOR "red") 90 | (define SIZE 72) 91 | (define TEXT-X 3) 92 | (define TEXT-UPPER-Y 10) 93 | (define TEXT-LOWER-Y 135) 94 | (define MT-SC 95 | (place-image/align 96 | HELP-TEXT TEXT-X TEXT-UPPER-Y 97 | "left" "top" 98 | (place-image/align 99 | HELP-TEXT2 100 | TEXT-X TEXT-LOWER-Y "left" "bottom" 101 | (empty-scene WIDTH HEIGHT)))) 102 | 103 | ; 104 | ; 105 | ; ; ; ;;; 106 | ; ; ; ; 107 | ; ; ; ; 108 | ; ; ;; ;;;; ; ;; ;; ; ; ;;; ; ;;; ;;;; 109 | ; ;; ; ; ;; ; ; ;; ; ; ; ;; ; ; 110 | ; ; ; ;;;; ; ; ; ; ; ;;;;; ; ;; 111 | ; ; ; ; ; ; ; ; ; ; ; ; ; 112 | ; ; ; ; ;; ; ; ; ;; ; ; ; ; 113 | ; ; ; ;; ; ; ; ;; ; ; ;;;; ; ;;;; 114 | ; 115 | ; 116 | 117 | ;; GuessRange -> Boolean 118 | ;; Does the interval represent a single number? 119 | ;; > (single? (interval 1 1)) 120 | ;; #t 121 | (define (single? w) 122 | (= (interval-small w) (interval-big w))) 123 | 124 | ;; GuessRange -> Number 125 | ;; Calculates a guess based on the given interval 126 | ;; > (guess (interval 0 100)) 127 | ;; 50 128 | (define (guess w) 129 | (quotient (+ (interval-small w) (interval-big w)) 2)) 130 | 131 | ;; GuessRange -> GuessRange 132 | ;; Recreates a GuessRange that lowers the upper bound 133 | ;; > (smaller (interval 0 100)) 134 | ;; (interval 0 50) 135 | (define (smaller w) 136 | (interval (interval-small w) 137 | (max (interval-small w) 138 | (sub1 (guess w))))) 139 | 140 | ;; GuessRange -> GuessRange 141 | ;; Recreates a interval that raises the lower bound 142 | ;; > (bigger (0 100) 143 | ;; (interval 51 100) 144 | (define (bigger w) 145 | (interval (min (interval-big w) 146 | (add1 (guess w))) 147 | (interval-big w))) 148 | 149 | ;; GuessRange Key -> GuessRange 150 | ;; Handles key input 151 | ;; > (key-handler (interval 0 100) "up") 152 | ;; (interval 51 100) 153 | ;; > (key-handler (interval 0 100) "q") 154 | ;; (stop-with (interval 0 100)) 155 | (define (deal-with-guess w key) 156 | (cond [(key=? key "up") (bigger w)] 157 | [(key=? key "down") (smaller w)] 158 | [(key=? key "q") (stop-with w)] 159 | [(key=? key "=") (stop-with w)] 160 | [else w])) 161 | 162 | ; 163 | ; 164 | ; ; 165 | ; ; ; 166 | ; ; 167 | ; ; ;;; ;;; ; ;; ;; ; ;;; ; ;;; ;;; ; ;; ;; ; 168 | ; ;; ; ; ; ;; ; ; ;; ; ; ;; ; ; ;; ; ; ;; 169 | ; ; ;;;;; ; ; ; ; ;;;;; ; ; ; ; ; ; 170 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; 171 | ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; 172 | ; ; ;;;; ; ; ;; ; ;;;; ; ; ; ; ;; ; 173 | ; ; 174 | ; ;;;; 175 | 176 | ;; GuessRange -> Scene 177 | ;; Visualize given interval as a scene 178 | ;; > (render (interval 0 100)) 179 | ;; (overlay (text "50" 72 "red") MT-SC) 180 | (define (render w) 181 | (overlay (text (number->string (guess w)) SIZE COLOR) MT-SC)) 182 | 183 | ; 184 | ; 185 | ; 186 | ; 187 | ; ; ; 188 | ; ;;;;; ;;; ;;;; ;;;;; ;;;; 189 | ; ; ; ; ; ; ; 190 | ; ; ;;;;; ;; ; ;; 191 | ; ; ; ; ; ; 192 | ; ; ; ; ; ; 193 | ; ;;; ;;;; ;;;; ;;; ;;;; 194 | ; 195 | ; 196 | 197 | (module+ test 198 | 199 | (require rackunit rackunit/text-ui) 200 | 201 | ;; testing the 'model' functions for basic guesses 202 | 203 | (check-true (single? (interval 50 50))) 204 | (check-false (single? (interval 50 51))) 205 | 206 | (check-equal? (guess (interval 0 100)) 50) 207 | (check-equal? (guess (interval 50 100)) 75) 208 | (check-equal? (guess (interval 0 50)) 25) 209 | 210 | (check-equal? (smaller (interval 0 100)) (interval 0 49)) 211 | (check-equal? (smaller (interval 0 000)) (interval 0 0)) 212 | (check-equal? (smaller (interval 0 50)) (interval 0 24)) 213 | (check-equal? (smaller (interval 50 100)) (interval 50 74)) 214 | (check-equal? (smaller (bigger (bigger (interval 0 100)))) 215 | (interval 76 87)) 216 | 217 | (check-equal? (bigger (interval 0 100)) (interval 51 100)) 218 | (check-equal? (bigger (interval 0 000)) (interval 0 0)) 219 | (check-equal? (bigger (interval 0 100)) (interval 51 100)) 220 | (check-equal? (bigger (interval 51 100)) (interval 76 100)) 221 | (check-equal? (bigger (interval 0 50)) (interval 26 50)) 222 | 223 | (check-equal? (deal-with-guess (interval 0 100) "up") (interval 51 100)) 224 | (check-equal? (deal-with-guess (interval 0 100) "down") (interval 0 49)) 225 | (check-equal? (deal-with-guess (interval 0 100) "=") 226 | (stop-with (interval 0 100))) 227 | (check-equal? (deal-with-guess (interval 0 100) "q") 228 | (stop-with (interval 0 100))) 229 | (check-equal? (deal-with-guess (interval 0 100) "up") 230 | (interval 51 100)) 231 | (check-equal? (deal-with-guess (interval 50 100) "up") 232 | (interval 76 100)) 233 | (check-equal? (deal-with-guess (interval 0 100) "down") 234 | (interval 0 49)) 235 | (check-equal? (deal-with-guess (interval 0 50) "down") 236 | (interval 0 24)) 237 | (check-equal? (deal-with-guess (interval 50 100) "e") 238 | (interval 50 100)) 239 | (check-equal? (deal-with-guess (interval 0 100) "f") 240 | (interval 0 100)) 241 | (check-equal? (deal-with-guess (deal-with-guess (interval 1 10) "up") 242 | "down") 243 | (interval 6 7)) 244 | 245 | ;; testing the view functions 246 | 247 | (check-equal? (render (interval 0 100)) 248 | (overlay (text "50" 72 "red") MT-SC)) 249 | (check-equal? (render (interval 0 100)) 250 | (overlay (text "50" SIZE COLOR) MT-SC)) 251 | (check-equal? (render (interval 0 50)) 252 | (overlay (text "25" SIZE COLOR) MT-SC)) 253 | (check-equal? (render (interval 50 100)) 254 | (overlay (text "75" SIZE COLOR) MT-SC)) 255 | 256 | "all tests run") 257 | 258 | -------------------------------------------------------------------------------- /chapter5/ufo-source.rkt: -------------------------------------------------------------------------------- 1 | #reader(lib"read.ss""wxme")WXME0108 ## 2 | #| 3 | This file uses the GRacket editor format. 4 | Open this file in DrRacket version 5.3.4.12 or later to read it. 5 | 6 | Most likely, it was created by saving a program in DrRacket, 7 | and it probably contains a program with non-text elements 8 | (such as images or comment boxes). 9 | 10 | http://racket-lang.org/ 11 | |# 12 | 30 7 #"wxtext\0" 13 | 3 1 6 #"wxtab\0" 14 | 1 1 8 #"wximage\0" 15 | 2 0 8 #"wxmedia\0" 16 | 4 1 34 #"(lib \"syntax-browser.ss\" \"mrlib\")\0" 17 | 1 0 16 #"drscheme:number\0" 18 | 3 0 44 #"(lib \"number-snip.ss\" \"drscheme\" \"private\")\0" 19 | 1 0 36 #"(lib \"comment-snip.ss\" \"framework\")\0" 20 | 1 0 93 21 | ( 22 | #"((lib \"collapsed-snipclass.ss\" \"framework\") (lib \"collapsed-sni" 23 | #"pclass-wxme.ss\" \"framework\"))\0" 24 | ) 0 0 43 #"(lib \"collapsed-snipclass.ss\" \"framework\")\0" 25 | 0 0 19 #"drscheme:sexp-snip\0" 26 | 0 0 36 #"(lib \"cache-image-snip.ss\" \"mrlib\")\0" 27 | 1 0 68 28 | ( 29 | #"((lib \"image-core.ss\" \"mrlib\") (lib \"image-core-wxme.rkt\" \"mr" 30 | #"lib\"))\0" 31 | ) 1 0 29 #"drscheme:bindings-snipclass%\0" 32 | 1 0 88 33 | ( 34 | #"((lib \"pict-snip.rkt\" \"drracket\" \"private\") (lib \"pict-snip.r" 35 | #"kt\" \"drracket\" \"private\"))\0" 36 | ) 0 0 33 #"(lib \"bullet-snip.ss\" \"browser\")\0" 37 | 0 0 25 #"(lib \"matrix.ss\" \"htdp\")\0" 38 | 1 0 22 #"drscheme:lambda-snip%\0" 39 | 1 0 26 #"drracket:spacer-snipclass\0" 40 | 0 0 57 41 | #"(lib \"hrule-snip.rkt\" \"macro-debugger\" \"syntax-browser\")\0" 42 | 1 0 26 #"drscheme:pict-value-snip%\0" 43 | 0 0 45 #"(lib \"image-snipr.ss\" \"slideshow\" \"private\")\0" 44 | 1 0 38 #"(lib \"pict-snipclass.ss\" \"slideshow\")\0" 45 | 2 0 55 #"(lib \"vertical-separator-snip.ss\" \"stepper\" \"private\")\0" 46 | 1 0 18 #"drscheme:xml-snip\0" 47 | 1 0 31 #"(lib \"xml-snipclass.ss\" \"xml\")\0" 48 | 1 0 21 #"drscheme:scheme-snip\0" 49 | 2 0 34 #"(lib \"scheme-snipclass.ss\" \"xml\")\0" 50 | 1 0 10 #"text-box%\0" 51 | 1 0 32 #"(lib \"text-snipclass.ss\" \"xml\")\0" 52 | 1 0 1 6 #"wxloc\0" 53 | 0 0 67 0 1 #"\0" 54 | 0 75 1 #"\0" 55 | 0 12 90 -1 90 -1 3 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 0 9 56 | #"Standard\0" 57 | 0 75 23 #"Lucida Sans Typewriter\0" 58 | 0 12 90 -1 90 -1 1 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 2 1 59 | #"\0" 60 | 0 -1 1 #"\0" 61 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 24 62 | #"framework:default-color\0" 63 | 0 -1 1 #"\0" 64 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 65 | #"\0" 66 | 0 -1 1 #"\0" 67 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 150 0 150 0 0 0 -1 -1 2 15 68 | #"text:ports out\0" 69 | 0 -1 1 #"\0" 70 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 150 0 150 0 0 0 -1 -1 2 1 71 | #"\0" 72 | 0 -1 1 #"\0" 73 | 1.0 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1.0 1.0 1.0 255 0 0 0 0 0 -1 74 | -1 2 15 #"text:ports err\0" 75 | 0 -1 1 #"\0" 76 | 1.0 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1.0 1.0 1.0 255 0 0 0 0 0 -1 77 | -1 2 1 #"\0" 78 | 0 -1 1 #"\0" 79 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 175 0 0 0 -1 -1 2 17 80 | #"text:ports value\0" 81 | 0 -1 1 #"\0" 82 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 175 0 0 0 -1 -1 2 1 83 | #"\0" 84 | 0 -1 1 #"\0" 85 | 1.0 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1.0 1.0 1.0 34 139 34 0 0 0 -1 86 | -1 2 27 #"Matching Parenthesis Style\0" 87 | 0 -1 1 #"\0" 88 | 1.0 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1.0 1.0 1.0 34 139 34 0 0 0 -1 89 | -1 2 1 #"\0" 90 | 0 -1 1 #"\0" 91 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 37 92 | #"framework:syntax-color:scheme:symbol\0" 93 | 0 -1 1 #"\0" 94 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 38 95 | #"framework:syntax-color:scheme:keyword\0" 96 | 0 -1 1 #"\0" 97 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 1 98 | #"\0" 99 | 0 -1 1 #"\0" 100 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 101 | 38 #"framework:syntax-color:scheme:comment\0" 102 | 0 -1 1 #"\0" 103 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 1 104 | #"\0" 105 | 0 -1 1 #"\0" 106 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 41 128 38 0 0 0 -1 -1 2 37 107 | #"framework:syntax-color:scheme:string\0" 108 | 0 -1 1 #"\0" 109 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 41 128 38 0 0 0 -1 -1 2 39 110 | #"framework:syntax-color:scheme:constant\0" 111 | 0 -1 1 #"\0" 112 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 41 128 38 0 0 0 -1 -1 2 1 113 | #"\0" 114 | 0 -1 1 #"\0" 115 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 49 116 | #"framework:syntax-color:scheme:hash-colon-keyword\0" 117 | 0 -1 1 #"\0" 118 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 42 119 | #"framework:syntax-color:scheme:parenthesis\0" 120 | 0 -1 1 #"\0" 121 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 1 122 | #"\0" 123 | 0 -1 1 #"\0" 124 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 36 125 | #"framework:syntax-color:scheme:error\0" 126 | 0 -1 1 #"\0" 127 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 128 | #"\0" 129 | 0 -1 1 #"\0" 130 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 36 131 | #"framework:syntax-color:scheme:other\0" 132 | 0 -1 1 #"\0" 133 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 16 134 | #"Misspelled Text\0" 135 | 0 -1 1 #"\0" 136 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 137 | #"\0" 138 | 0 -1 1 #"\0" 139 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 81 112 203 0 0 0 -1 -1 2 140 | 38 #"drracket:check-syntax:lexically-bound\0" 141 | 0 -1 1 #"\0" 142 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 81 112 203 0 0 0 -1 -1 2 1 143 | #"\0" 144 | 0 -1 1 #"\0" 145 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 2 28 146 | #"drracket:check-syntax:set!d\0" 147 | 0 -1 1 #"\0" 148 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 2 37 149 | #"drracket:check-syntax:unused-require\0" 150 | 0 -1 1 #"\0" 151 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 36 152 | #"drracket:check-syntax:free-variable\0" 153 | 0 -1 1 #"\0" 154 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 155 | #"\0" 156 | 0 -1 1 #"\0" 157 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 68 0 203 0 0 0 -1 -1 2 31 158 | #"drracket:check-syntax:imported\0" 159 | 0 -1 1 #"\0" 160 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 68 0 203 0 0 0 -1 -1 2 47 161 | #"drracket:check-syntax:my-obligation-style-pref\0" 162 | 0 -1 1 #"\0" 163 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 2 1 164 | #"\0" 165 | 0 -1 1 #"\0" 166 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 116 0 0 0 0 -1 -1 2 50 167 | #"drracket:check-syntax:their-obligation-style-pref\0" 168 | 0 -1 1 #"\0" 169 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 116 0 0 0 0 -1 -1 2 48 170 | #"drracket:check-syntax:unk-obligation-style-pref\0" 171 | 0 -1 1 #"\0" 172 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 173 | #"\0" 174 | 0 -1 1 #"\0" 175 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 139 142 28 0 0 0 -1 -1 2 176 | 49 #"drracket:check-syntax:both-obligation-style-pref\0" 177 | 0 -1 1 #"\0" 178 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 139 142 28 0 0 0 -1 -1 2 179 | 26 #"plt:htdp:test-coverage-on\0" 180 | 0 -1 1 #"\0" 181 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 182 | #"\0" 183 | 0 -1 1 #"\0" 184 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 255 56 81 0 0 0 -1 -1 2 27 185 | #"plt:htdp:test-coverage-off\0" 186 | 0 -1 1 #"\0" 187 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 255 56 81 0 0 0 -1 -1 4 1 188 | #"\0" 189 | 0 70 1 #"\0" 190 | 1.0 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1.0 1.0 1.0 1.0 1.0 1.0 0 0 0 0 0 0 191 | -1 -1 4 4 #"XML\0" 192 | 0 70 1 #"\0" 193 | 1.0 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1.0 1.0 1.0 1.0 1.0 1.0 0 0 0 0 0 0 194 | -1 -1 2 1 #"\0" 195 | 0 -1 1 #"\0" 196 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 37 197 | #"plt:module-language:test-coverage-on\0" 198 | 0 -1 1 #"\0" 199 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 1 200 | #"\0" 201 | 0 -1 1 #"\0" 202 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 176 48 96 0 0 0 -1 -1 2 38 203 | #"plt:module-language:test-coverage-off\0" 204 | 0 -1 1 #"\0" 205 | 1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 176 48 96 0 0 0 -1 -1 0 1 206 | #"\0" 207 | 0 75 23 #"Lucida Sans Typewriter\0" 208 | 0.0 12 90 -1 90 -1 1 -1 0 1 0 1 0 0 0.0 0.0 0.0 0.0 0.0 0.0 0 0 0 255 209 | 255 255 1 -1 2 1 #"\0" 210 | 0 -1 1 #"\0" 211 | 1.0 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0.0 0.0 0.0 0.0 0.0 0.0 255 165 0 0 212 | 0 0 -1 -1 4 1 #"\0" 213 | 0 71 1 #"\0" 214 | 1.0 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1.0 1.0 1.0 1.0 1.0 1.0 0 0 0 0 0 0 215 | -1 -1 4 1 #"\0" 216 | 0 -1 1 #"\0" 217 | 1.0 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0.0 0.0 0.0 1.0 1.0 1.0 0 0 255 0 0 218 | 0 -1 -1 4 1 #"\0" 219 | 0 71 1 #"\0" 220 | 1.0 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0.0 0.0 0.0 1.0 1.0 1.0 0 0 255 0 0 221 | 0 -1 -1 4 1 #"\0" 222 | 0 71 1 #"\0" 223 | 1.0 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0.0 0.0 0.0 1.0 1.0 1.0 0 100 0 0 0 224 | 0 -1 -1 0 1 #"\0" 225 | 0 -1 1 #"\0" 226 | 0.0 13 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1.0 1.0 1.0 1.0 1.0 1.0 0 0 0 0 0 0 227 | -1 -1 2 1 #"\0" 228 | 0 -1 1 #"\0" 229 | 0.0 13 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1.0 1.0 1.0 1.0 1.0 1.0 0 0 0 0 0 0 230 | -1 -1 0 1 #"\0" 231 | 0 75 1 #"\0" 232 | 0.0 10 90 -1 90 -1 3 -1 0 1 0 1 0 0 0.0 0.0 0.0 0.0 0.0 0.0 0 0 0 255 233 | 255 255 1 -1 0 1 #"\0" 234 | 0 75 12 #"Courier New\0" 235 | 0.0 10 90 -1 90 -1 3 -1 0 1 0 1 0 0 0.0 0.0 0.0 0.0 0.0 0.0 0 0 0 255 236 | 255 255 1 -1 4 1 #"\0" 237 | 0 71 1 #"\0" 238 | 1.0 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0.0 0.0 0.0 1.0 1.0 1.0 255 0 0 0 0 239 | 0 -1 -1 2 1 #"\0" 240 | 0 70 1 #"\0" 241 | 1.0 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0.0 0.0 0.0 1.0 1.0 1.0 148 0 211 0 242 | 0 0 -1 -1 2 1 #"\0" 243 | 0 70 1 #"\0" 244 | 1.0 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0.0 0.0 0.0 1.0 1.0 1.0 0 0 255 0 0 245 | 0 -1 -1 0 1 #"\0" 246 | 0 -1 1 #"\0" 247 | 0.0 12 -1 -1 -1 -1 -1 -1 0 0 1 0 0 0 1.0 1.0 1.0 1.0 1.0 1.0 0 0 0 0 0 0 248 | -1 -1 2 1 #"\0" 249 | 0 -1 1 #"\0" 250 | 0.0 12 -1 -1 -1 -1 -1 -1 0 0 1 0 0 0 1.0 1.0 1.0 1.0 1.0 1.0 0 0 0 0 0 0 251 | -1 -1 0 147 0 27 3 12 #"#lang racket" 252 | 0 0 23 29 1 #"\n" 253 | 0 0 23 29 1 #"\n" 254 | 0 0 23 3 1 #"(" 255 | 0 0 14 3 7 #"require" 256 | 0 0 23 3 1 #" " 257 | 0 0 14 3 14 #"2htdp/universe" 258 | 0 0 23 3 1 #" " 259 | 0 0 14 3 11 #"2htdp/image" 260 | 0 0 23 3 1 #")" 261 | 0 0 23 29 1 #"\n" 262 | 0 0 23 29 1 #"\n" 263 | 0 0 23 3 1 #"(" 264 | 0 0 15 3 6 #"define" 265 | 0 0 23 3 1 #" " 266 | 0 0 14 3 5 #"WIDTH" 267 | 0 0 23 3 1 #" " 268 | 0 0 20 3 3 #"200" 269 | 0 0 23 3 1 #")" 270 | 0 0 23 29 1 #"\n" 271 | 0 0 23 3 1 #"(" 272 | 0 0 15 3 6 #"define" 273 | 0 0 23 3 1 #" " 274 | 0 0 14 3 6 #"HEIGHT" 275 | 0 0 23 3 1 #" " 276 | 0 0 20 3 3 #"300" 277 | 0 0 23 3 1 #")" 278 | 0 0 23 29 1 #"\n" 279 | 0 0 23 29 1 #"\n" 280 | 0 0 17 3 86 281 | ( 282 | #";; depending on your settings, drracket may claim that the image cau" 283 | #"ses a syntax error" 284 | ) 0 0 23 29 1 #"\n" 285 | 0 0 17 3 50 #";; please ignore this warning and click RUN anyway" 286 | 0 0 23 29 1 #"\n" 287 | 0 0 23 3 1 #"(" 288 | 0 0 15 3 6 #"define" 289 | 0 0 23 3 1 #" " 290 | 0 0 14 3 12 #"IMAGE-of-UFO" 291 | 0 0 23 3 1 #" " 292 | 0 2 23 4 1 #"\0" 293 | 2 -1.0 -1.0 0.0 0.0 0 6 500 294 | ( 295 | #"\211PNG\r\n\32\n\0\0\0\rIHDR\0\0\0Q\0\0\0F\b" 296 | #"\6\0\0\0\264\\x\25\0\0\nvIDATx\234\355\\\353q\333\274\22" 297 | #"=\360\334\377\202R@L7\20Q\5d\fU *\r\210j \246\322\0\351" 298 | #"\n(7`\321\25P\223\2L\272\201\220J\1\241\234\2>\322.@{\177\330" 299 | #"@\370\322\233\262\235\214\317\f\306\326\203" 300 | #"\300\362`\261\330\a(FD\204W\4" 301 | #"\21\2011\246\376\376\215`\257M\342\277" 302 | #"\200\223\327\34\374_\231\277W!Q\222" 303 | #"\367\267.\3372^\205\304\177\205<\211" 304 | #"\377\275\304 D\204\307\307GDQT\371L\327up\316_B\214\343\201\216\210" 305 | #"(\212\3104M\3224\215\0\20c\214\0T\232\246id\232&\371\276\177Lq" 306 | #"\216\206\243\220\30\4\1\t!j\t\253kyr[\255\26\331\266Mi\232\36C" 307 | #"\264\243\240q\27g<\36c2\231\0" 308 | #"\200\362\377\6\203\1:\235\16\204\20R\373\1\0wwwX,\26\b\303\20\213" 309 | #"\305\242\320\17\347\34\266m\303\262\254&" 310 | #"\305;\16\232\232\2154M\3110\214\212v\t!\266\272^.}\2244\3230\f" 311 | #"\312\262\254\366\232\345r\331\224\370\a\241" 312 | #"1\22%\1\0\250\333\355\252\377\267%Qb\261X\320p8,\220\251\353\372\233" 313 | #"^\336\215\220h\333\266\272i\3030\210" 314 | #"s\256Ht\34g\355\265\253\264)\212\"\3224\355\257 \362`\22\223$)," 315 | #"=\271\241\350\272N\0\310u]\"\372" 316 | #"C\326.K\260l\"\272\335\356\241\342\36\5\a\223(\2271\347\234|\337WK" 317 | #"\330q\34\2@A\20\250\357\356k\303" 318 | #"\206\303\241\322H\333\266\337\214-\224\330" 319 | #"H\342:\201\363Z\350y\36\365\373}b\214Q\24E\324\353\365\b\0%I\322" 320 | #"\210\240y\227i\261X4\322gS\330J\23W" 321 | #"\219\231L\224\26\246iZ\330H\344\r7\2054" 322 | ) 500 323 | ( 324 | #"M\225\323n\232fc\3756\201\203\356Rj\207i\232\24\4\201\322\3104M\325" 325 | #"\362k\22r\214\267\246\215\a% \3020\4\0\364\373}DQ\4\306\30NO" 326 | #"O\245\377\t]\327\17\351\276\2!\4" 327 | #"\204\20`\214\301\367\375F\373>\4{" 328 | #"\223\230\2170t]\307\343\343#\210\b" 329 | #"\275^\17\343\361\30\0\320n\267\17\26" 330 | #"\260\f\333\266AD\270\271\271i\274\357" 331 | #"\275\261\257\n\347\227\26\21\221\3438\265" 332 | #"\t\206c@\332\306\267\202\275Sa2'\250i\32\0\340\342\342\2\235N\a?" 333 | #"\177\376\4\21\325\306\303M\3010\fL" 334 | #"&\23\204a\250\342q\340O\275\346\245" 335 | #"\2617\211\364\234D\2206\260\325j\301" 336 | #"0\f\30\206\1\340i\331\35\v\253l\355k%{\17\316lK\301\217y\3T" 337 | #"J4\311\211{+vq/\22\211H-\325\207\207\207&\345\251Ey\202\244\t" 338 | #"\361<\17wwwG\37\177#v1\240y\247;\37\323\266\333m2M\223f" 339 | #"\263Y\223\366\272\2028\216\3114\315B" 340 | #"\202C:\372\257\211\275\2668\231\265\221" 341 | #"\255\274+\313\3309\b\202\203n\360\376" 342 | #"\376\236<\317+\224\30\352\332kgx" 343 | #"v\316l{\236\207\321h\264\263\306\313]T\b\261r\27e\214!\212\"dY" 344 | #"\246\34\371:0\306\320j\265\360\360\360" 345 | #"\240\372\32\16\207\230N\247;\313\325\b" 346 | #"va<\212\242\302R\3224\215\204\20" 347 | #"*\355\205\32\255\224\257W\25\251\266i\362ZM\323h0\30P\267\333-\310!" 348 | #"\333k\305\324[\2738Y\226a4\32" 349 | #"!\3132\365\236\334\\\204\20\30\16\207\350\365z\350t:\210\343X}/o\370" 350 | #"\3030Tu\227,\313\20\307qe\34\316\271ra4M\203\246i\350t:\340" 351 | #"\234\343\356\356\16\223\311\244 \3\0X\226\205,\313\340y\36\0`:\235" 352 | #"\276\254\317\270-\333\371\364\177\273\335" 353 | #"^\2531B\b\262,\213\\\327=\310" 354 | ) 500 355 | ( 356 | #".\6A@\216\343\0244=\337\316\317" 357 | #"\317U\276\362\277\377\376S\337{i\215\334\312&\316f3\f\6\3\0O\2322" 358 | #"\36\217\361\361\343G0\306\20\3071\302" 359 | #"0\254\325\2522d\241\2361\206\363\363" 360 | #"\363\312\347R\203\27\213\205\322r\251\271" 361 | #"r\354^\257\207\317\237?\343\313\227/" 362 | #"\205d\207\224\245\327\353!\3132X\226" 363 | #"\5\327u7\312\324\b6\261\234\246i\305\245\360}\237|\337'M\323T\r%" 364 | #"MS\362}\237\34\307\241\363\363\363\225" 365 | #"\332Zn\333\330J\327u)\212\"%\323\272D\361t:U\327M\247\323\303T" 366 | #"lKl$\261\337\357\27n(\fCJ\222\204\242(R\2\327-\237\321h\244" 367 | #"\352.\216\343\220a\30+\227e\236L" 368 | #"!\4\231\246I\236\347\25\222\30\273\324" 369 | #"h,\313R\375\275\4\221\25\22\363B\6AP\2709M\323\210\210T\25N\326" 370 | #"T\312\n}}}M\214\261\332J\37\347\234\6\203\301v\302m\231\t\252#6" 371 | #"?a777[\215\267/\na\37\225v\264\361x\254\222\253\375~\37\246i" 372 | #"\2x\262MD\244\302/\371>=\333\256\337\277\177\203\2100\34\16\341y\36." 373 | #"//\225\337\327n\267\221\246ia\314" 374 | #"U(\357\256i\232\242\327\353\2011\6\306X\301n\226\341\373\276:(uqq" 375 | #"\241l\366\272\361\366\306*v\363\266%\212\"r]\227\272\335.EQDY\226" 376 | #"Q\232\246\224$\tq\316+'\24\344\265D\244\nV\262t\212\347\bc\e\240" 377 | #"\244\211\262\202(\333\252\232\266\324\314\374" 378 | #"Ji\267\333\312Kh\272Z\250$,w,\227\254\0244\212\"%\220\264s\246" 379 | #"i\256\254\346\351\272NA\20\220\353\272$\204\240$IT\"\267|*b\325M" 380 | #"\225\3534\345CR\206al\274A\313\262\n\341\3411P\253\211r" 381 | #"\6\363\301\375r\271\244\351tJB\b\352\365z\25\203]&\"\216c" 382 | ) 500 383 | ( 384 | #"2\f\203\202 \240 \bh6\233Q\253\325\"\306\30Y\226\265\235p%M\314" 385 | #"\23X7\31u\310W\t\1l=\366.\250%q0\30\324.\227]\227A\222" 386 | #"$J{\244V\265\333\355\255k\321e\22\313}I\23\261\t\371R\6P|@\253\325B\222$\215\234b\215\343\30\337\277\177\307r\271\304h4RN" 389 | #"\362&H\271(\267\31\204a\2100\fqrr\202\257_\277n-\337\267o\337" 390 | #"\224\363}vv\206_\277~\355x\27kPfUn\nuj\177\250A\336\344" 391 | #"\353\225\337\307\226.\316\246~\210\236\226" 392 | #"u>\0h\322\177\254H(c\344|\204p(\366%\177_\22W\215-ww" 393 | #"\306\230\362y\233@EB]\327\211s\336\330\0\207\240\t\22\363(\207\260Me" 394 | #"\342+5\226\371|\16\3169<\317\253" 395 | #"\244\234\3362\350\331nR\2153\375\360" 396 | #"\360\0\317\3630\30\f\n\367\264.\361\273\v*Y\34\31\r\310\267;\235\16z" 397 | #"\275\36t]\307\247O\237\320\355v\e" 398 | #"\31x\e\234\234\234\200\236V\313\316\327" 399 | #"\206a\210\273\273;\4A\260\262\230%\204@\20\4\207\212Y_w\316\v=\237" 400 | #"\3171\237\317\325k\231\306\322u\35\247" 401 | #"\247\247\350v\2738==U!`\271\237}\23\243Y\226mE\236L\233\311C" 402 | #"\364q\34o\225\226k\22\265$Z\226" 403 | #"\5\3169\34\307Q\357I\355\244\347\323" 404 | #"\rr)\224\265\266\335n\253\274\241\314" 405 | #"R\23Q!c\275\16\222\370\374\203CR\253\200\3659\307\362_M\323\260X," 406 | #"\320j\265\20\3071F\243QcK\270,t\1x\16\217\362!\232\357\373j\327" 407 | #"\326u\235|\337/\224L\367mB\210\225m]\332,\337\362N\274m\333*:" 408 | #"\271\275\275\255\204\231\371\335\31\rF/\265$\2" 409 | #"P'\370\245\0\223\311\204\30c\364\343\307\17\"" 410 | ) 500 411 | ( 412 | #"\372S6\235\315f\344\272.u:\35\25\345\f\6\203\332BR\23\244\313~M" 413 | #"\323,\220\26\4\1-\227K\25\325\4A@\213\305B]\233$I\345\311\256\246" 414 | #"\334\270\n\211\345 \377\354\354\214\202 " 415 | #"P\232'C6\333\266\2111\246\234V" 416 | #"y\203\371~\344\347I\222\220\353\272J" 417 | #"\233e\342u\25Y\234\363\312\1\322\262" 418 | #"|R\16\371\272\374\271\357\373\24\4\301" 419 | #"\312\311<\252\237\350\272na\251\224\323" 420 | #"\367ggg4\34\16\25\t\266m\257\275\231|\234\\>\f/\307\220\310gm" 421 | #"\344R,\307\357\345q\344\344\372\276_ylc\335\362?j\304\222?\314\276m" 422 | #"\343\234\253\31\17\202\200\242(RI\214<\362$.\227Ku\275\22&\367Z\206" 423 | #"\237\345t\227\324\360\262\335\344\234\257$" 424 | #"\217s^\260\341M\247\304@T\r\313\362K\3154M\262,\253\326\340\357R\220" 425 | #"\3274\255pp=\257\3612/)\373t]\227\306\343q\201\204:mZ7\276" 426 | #"\264\231\262d\233O27\235\305\251\255" 427 | #"\261$I\242\226\262\256\353*<\212\242\210\f\303(=" 518 | 0 0 23 3 1 #" " 519 | 0 0 14 3 13 #"current-state" 520 | 0 0 23 3 1 #" " 521 | 0 0 20 3 3 #"300" 522 | 0 0 23 3 2 #"))" 523 | 0 0 23 29 1 #"\n" 524 | 0 0 23 29 1 #"\n" 525 | 0 0 23 3 1 #"(" 526 | 0 0 15 3 6 #"define" 527 | 0 0 23 3 2 #" (" 528 | 0 0 14 3 4 #"main" 529 | 0 0 23 3 1 #")" 530 | 0 0 23 29 1 #"\n" 531 | 0 0 23 3 3 #" (" 532 | 0 0 14 3 8 #"big-bang" 533 | 0 0 23 3 1 #" " 534 | 0 0 20 3 1 #"0" 535 | 0 0 23 3 40 #" " 536 | 0 0 17 3 17 #";; initial state " 537 | 0 0 23 29 1 #"\n" 538 | 0 0 23 3 13 #" (" 539 | 0 0 14 3 7 #"on-tick" 540 | 0 0 23 3 1 #" " 541 | 0 0 14 3 14 #"add-3-to-state" 542 | 0 0 23 3 18 #") " 543 | 0 0 17 3 32 #";; when the clock ticks, add ..." 544 | 0 0 23 29 1 #"\n" 545 | 0 0 23 3 13 #" (" 546 | 0 0 14 3 7 #"to-draw" 547 | 0 0 23 3 1 #" " 548 | 0 0 14 3 30 #"draw-a-ufo-onto-an-empty-scene" 549 | 0 0 23 3 2 #") " 550 | 0 0 17 3 36 #";; when the state changes, draw ... " 551 | 0 0 23 29 1 #"\n" 552 | 0 0 23 3 13 #" (" 553 | 0 0 14 3 9 #"stop-when" 554 | 0 0 23 3 1 #" " 555 | 0 0 14 3 12 #"state-is-300" 556 | 0 0 23 3 18 #"))) " 557 | 0 0 17 3 45 #";; when the UFO's y coordinate is 300, stop. " 558 | 0 0 23 29 1 #"\n" 559 | 0 0 23 29 1 #"\n" 560 | 0 0 17 3 43 #";; to run the program, click run and enter " 561 | 0 0 23 29 1 #"\n" 562 | 0 0 17 3 14 #";; > (main) " 563 | 0 0 23 29 1 #"\n" 564 | 0 0 17 3 18 #";; at the prompt. " 565 | 0 0 566 | -------------------------------------------------------------------------------- /chapter6/graphics/body.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/realm/d4509a0c42171f4ffbdd67b9acb0b774957be02b/chapter6/graphics/body.gif -------------------------------------------------------------------------------- /chapter6/graphics/goo.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/realm/d4509a0c42171f4ffbdd67b9acb0b774957be02b/chapter6/graphics/goo.gif -------------------------------------------------------------------------------- /chapter6/graphics/head.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/realm/d4509a0c42171f4ffbdd67b9acb0b774957be02b/chapter6/graphics/head.gif -------------------------------------------------------------------------------- /chapter6/graphics/tail.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/realm/d4509a0c42171f4ffbdd67b9acb0b774957be02b/chapter6/graphics/tail.gif -------------------------------------------------------------------------------- /chapter6/readme.txt: -------------------------------------------------------------------------------- 1 | 2 | This chapter implements the old "snake" game with a small twist. 3 | 4 | To play or to experiment, open the file 5 | 6 | source.rkt 7 | 8 | in DrRacket. The instructions for playing are at the top of the file. 9 | Our tests are at the bottom of the file in a separate 'test' submodule. 10 | 11 | -------------------------------------------------------------------------------- /chapter6/source.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | The Snake game 5 | -------------- 6 | 7 | The Snake game revolves around a room filled with pieces of radioactive goo 8 | and a snake that can remove this goo. 9 | 10 | When the snake eats the goo, it grows and new goo appears. Like all 11 | radioactive material, goo decays over time. Eventually it expires, but 12 | fortunately for the snake, a new piece of goo appears elsewhere. 13 | 14 | The player is in control of a snake, and the objective is to grow the snake as 15 | large as possible. She may change the direction of the snake by pressing one of 16 | the four arrow keys. When the snake gets close to a piece of goo, it eats the 17 | goo and grows a new segment. If the snake runs into itself or one of the four 18 | walls, the game is over. The length of the snake is the player's score. 19 | 20 | Play 21 | ---- 22 | 23 | Run and evaluate 24 | (start-snake) 25 | This will pop up a window with instructions for interacting with the program. 26 | |# 27 | 28 | ; 29 | ; 30 | ; 31 | ; 32 | ; ;; 33 | ; ;;; ; ; 34 | ; ; ;; ; 35 | ; ; ; ;; ;;; ;;;; ; ;;; ;;; 36 | ; ; ;; ; ; ; ; ; ; ; 37 | ; ;;;; ; ; ; ; ; ; ; 38 | ; ; ; ; ;;;;;; ;;; ;;;;;;; 39 | ; ; ; ; ; ; ; ; ; ; 40 | ; ;; ; ; ; ; ;; ; ; ; ; 41 | ; ; ;;; ;;; ;;; ;;;; ;; ;; ;;;; ;;;; 42 | ; 43 | ; 44 | ; 45 | ; 46 | 47 | (require 2htdp/image 2htdp/universe) 48 | ;; ----------------------------------------------------------------------------- 49 | ;; Data Definitions 50 | 51 | ;; A Pit is a (pit Snake (Listof Goo)) 52 | (struct pit (snake goos) #:transparent) 53 | 54 | ;; A Snake is a (make-snake Direction (cons Seg [Listof Seg])) 55 | (struct snake (dir segs) #:transparent) 56 | ;; The head of the snake is the first element in the list of segs. 57 | ;; Each segment of a snake is located with: 58 | ;; - x in (0,SIZE), 59 | ;; - y in (0,SIZE). 60 | ;; And is SEG-SIZE aligned (x and y are multiples of SEG-SIZE). 61 | 62 | ;; A Seg is a (posn Number Number) 63 | 64 | ;; A Goo is a (goo Posn Number) 65 | (struct goo (loc expire) #:transparent) 66 | ;; The expire field is a Natural Number that represents the number 67 | ;; of ticks until the goo expires. A goo is expired when this field is 1 68 | 69 | ;; A Direction is one of "up" "down" "left" "right" 70 | 71 | ;; A Posn is (posn number number) 72 | (struct posn (x y) #:transparent) 73 | ;; Represents a two dimensional point. 74 | 75 | ;; ----------------------------------------------------------------------------- 76 | ;; Constants 77 | 78 | ;; Tick Rate 79 | (define TICK-RATE 1/10) 80 | 81 | ;; Board Size Constants 82 | (define SIZE 30) 83 | 84 | ;; Snake Constants 85 | (define SEG-SIZE 15) 86 | 87 | ;; Goo Constants 88 | (define MAX-GOO 5) 89 | (define EXPIRATION-TIME 150) 90 | 91 | ;; GRAPHICAL BOARD 92 | (define WIDTH-PX (* SEG-SIZE SIZE)) 93 | (define HEIGHT-PX (* SEG-SIZE SIZE)) 94 | 95 | ;; Visual constants 96 | (define MT-SCENE (empty-scene WIDTH-PX HEIGHT-PX)) 97 | (define GOO-IMG (bitmap "graphics/goo.gif")) 98 | (define SEG-IMG (bitmap "graphics/body.gif")) 99 | (define HEAD-IMG (bitmap "graphics/head.gif")) 100 | 101 | (define HEAD-LEFT-IMG HEAD-IMG) 102 | (define HEAD-DOWN-IMG (rotate 90 HEAD-LEFT-IMG)) 103 | (define HEAD-RIGHT-IMG (flip-horizontal HEAD-LEFT-IMG)) 104 | (define HEAD-UP-IMG (flip-vertical HEAD-DOWN-IMG)) 105 | 106 | (define ENDGAME-TEXT-SIZE 15) 107 | 108 | 109 | ; 110 | ; 111 | ; 112 | ; ; 113 | ; ; 114 | ; ;;; ;;; 115 | ; ;; ;; 116 | ; ; ; ; ; ;;;; ;;; ;; ;;; 117 | ; ; ; ; ; ; ; ; ;; ; 118 | ; ; ; ; ; ; ; ; ; 119 | ; ; ; ; ;;;;;; ; ; ; 120 | ; ; ; ; ; ; ; ; 121 | ; ; ; ; ;; ; ; ; 122 | ; ;;; ;;; ;;;; ;; ;;;;;;; ;;; ;;; 123 | ; 124 | ; 125 | ; 126 | ; 127 | ;; ----------------------------------------------------------------------------- 128 | 129 | ;; Start the Game 130 | (define (start-snake) 131 | (big-bang (pit (snake "right" (list (posn 1 1))) 132 | (list (fresh-goo) 133 | (fresh-goo) 134 | (fresh-goo) 135 | (fresh-goo) 136 | (fresh-goo) 137 | (fresh-goo))) 138 | (on-tick next-pit TICK-RATE) 139 | (on-key direct-snake) 140 | (to-draw render-pit) 141 | (stop-when dead? render-end))) 142 | 143 | ;; Pit -> Pit 144 | ;; Take one step: eat or slither 145 | (define (next-pit w) 146 | (define snake (pit-snake w)) 147 | (define goos (pit-goos w)) 148 | (define goo-to-eat (can-eat snake goos)) 149 | (if goo-to-eat 150 | (pit (grow snake) (age-goo (eat goos goo-to-eat))) 151 | (pit (slither snake) (age-goo goos)))) 152 | 153 | ;; Pit KeyEvent -> Pit 154 | ;; Handle a key event 155 | (define (direct-snake w ke) 156 | (cond [(dir? ke) (world-change-dir w ke)] 157 | [else w])) 158 | 159 | ;; Pit -> Scene 160 | ;; Render the world as a scene 161 | (define (render-pit w) 162 | (snake+scene (pit-snake w) 163 | (goo-list+scene (pit-goos w) MT-SCENE))) 164 | 165 | ;; Pit -> Boolean 166 | ;; Is the snake dead? 167 | (define (dead? w) 168 | (define snake (pit-snake w)) 169 | (or (self-colliding? snake) (wall-colliding? snake))) 170 | 171 | ;; Pit -> Scene 172 | ;; produces a gameover image 173 | (define (render-end w) 174 | (overlay (text "Game over" ENDGAME-TEXT-SIZE "black") 175 | (render-pit w))) 176 | 177 | ; 178 | ; 179 | ; 180 | ; ;;;; ;; ;; ;;;;;; ; ;; 181 | ; ; ; ; ; ; ; ; 182 | ; ; ; ;;;; ;;; ; ; ;;;; ; ;;; ;;; ; ; ;;;; ;;;;; 183 | ; ; ; ; ; ;; ;; ; ; ; ; ;; ;; ; ; ; ; 184 | ; ; ; ; ; ; ;;; ; ; ; ;;; ;;;; 185 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; 186 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 187 | ; ;;; ;;;;; ;;;; ;;;; ;; ;;; ;;; ;;;;; ;;;; ;; ;;; ;;;;; 188 | ; 189 | ; 190 | ; 191 | ; 192 | 193 | ;; ----------------------------------------------------------------------------- 194 | ;; Movement and Eating 195 | 196 | ;; ----------------------------------------------------------------------------- 197 | ;; Eating and Growth 198 | 199 | ;; Snake [Listof Goo] -> Goo or #f 200 | ;; Can the snake eat any of the goos? 201 | ;; > (can-eat (snake "right" `(,(posn 3 3))) `(,(goo (posn 3 3) 130))) 202 | ;; (goo (posn 3 3) 130) 203 | (define (can-eat snake goos) 204 | (cond [(empty? goos) #f] 205 | [else (if (close? (snake-head snake) (first goos)) 206 | (first goos) 207 | (can-eat snake (rest goos)))])) 208 | 209 | ;; [Listof Goo] Goo -> [Listof Goo] 210 | ;; Eat and replenish a goo. 211 | ;; > (eat (list (goo (posn 5 5) 5)) (goo (posn 5 5) 5)) 212 | ;; (list (new-goo)) 213 | (define (eat goos goo-to-eat) 214 | (cons (fresh-goo) (remove goo-to-eat goos))) 215 | 216 | ;; Seg Goo -> Boolean 217 | ;; Is the segment close to the goo? 218 | ;; > (close? (posn 1 2) (goo (posn 1 2) 4)) 219 | ;; #t 220 | (define (close? s g) 221 | (posn=? s (goo-loc g))) 222 | 223 | ;; Grow the snake one segment. 224 | ;; Snake -> Snake 225 | ;; > (grow snake0) 226 | ;; (snake "right" `(,(posn 2 1) ,(posn 1 1))) 227 | (define (grow sn) 228 | (snake (snake-dir sn) (cons (next-head sn) (snake-segs sn)))) 229 | 230 | ;; ----------------------------------------------------------------------------- 231 | ;; Movement 232 | 233 | ;; Snake -> Snake 234 | ;; Slither the snake forward one segment. 235 | ;; > (slither snake0) 236 | ;; (snake "right" (posn 2 1)) 237 | (define (slither sn) 238 | (snake (snake-dir sn) 239 | (cons (next-head sn) (all-but-last (snake-segs sn))))) 240 | 241 | ;; Snake -> Seg 242 | ;; Compute the next head position of the snake. 243 | ;; > (next-head snake0) 244 | ;; (snake "right" (list (posn 2 1))) 245 | (define (next-head sn) 246 | (define head (snake-head sn)) 247 | (define dir (snake-dir sn)) 248 | (cond [(string=? dir "up") (posn-move head 0 -1)] 249 | [(string=? dir "down") (posn-move head 0 1)] 250 | [(string=? dir "left") (posn-move head -1 0)] 251 | [(string=? dir "right") (posn-move head 1 0)])) 252 | 253 | ;; Posn Number Number -> Posn 254 | ;; Move the position by dx, dy. 255 | ;; > (posn-move (posn 1 1) 2 3) 256 | ;; (posn 3 4) 257 | (define (posn-move p dx dy) 258 | (posn (+ (posn-x p) dx) 259 | (+ (posn-y p) dy))) 260 | 261 | ;; (cons X [Listof X]) -> [Listof X] 262 | ;; Returns a List that is does not contain the last element of the given list. 263 | ;; > (all-but-last '(1 2 3 4)) 264 | ;; '(1 2 3) 265 | (define (all-but-last segs) 266 | (cond [(empty? (rest segs)) empty] 267 | [else (cons (first segs) 268 | (all-but-last (rest segs)))])) 269 | 270 | ;; ----------------------------------------------------------------------------- 271 | ;; Rotting Goo 272 | 273 | ;; [Listof Goo] -> [Listof Goo] 274 | ;; Renew and rot goos. 275 | (define (age-goo goos) 276 | (rot (renew goos))) 277 | 278 | ;; [Listof Goo] -> [Listof Goo] 279 | ;; Renew any rotten goos. 280 | (define (renew goos) 281 | (cond [(empty? goos) empty] 282 | [(rotten? (first goos)) 283 | (cons (fresh-goo) (renew (rest goos)))] 284 | [else 285 | (cons (first goos) (renew (rest goos)))])) 286 | 287 | ;; [Listof Goo] -> [Listof Goo] 288 | ;; Rot all of the goos. 289 | (define (rot goos) 290 | (cond [(empty? goos) empty] 291 | [else (cons (decay (first goos)) 292 | (rot (rest goos)))])) 293 | 294 | ;; Goo -> Boolean 295 | ;; has the goo expired? 296 | ;; > (rotten? (goo 1 2) 0) 297 | ;; #t 298 | (define (rotten? g) 299 | (zero? (goo-expire g))) 300 | 301 | ;; Goo -> Goo 302 | ;; decreases the expire field of goo by one 303 | ;; > (decay (goo (posn 1 2) 2)) 304 | ;; (goo (posn 1 2) 1) 305 | (define (decay g) 306 | (goo (goo-loc g) (sub1 (goo-expire g)))) 307 | 308 | ;; -> Goo 309 | ;; Create random goo with fresh expiration. 310 | ;; Property: The position of the goo is: 311 | ;; - x in (0,WIDTH), 312 | ;; - y in (0,HEIGHT). 313 | (define (fresh-goo) 314 | (goo (posn (add1 (random (sub1 SIZE))) 315 | (add1 (random (sub1 SIZE)))) 316 | EXPIRATION-TIME)) 317 | 318 | ; 319 | ; 320 | ; 321 | ; 322 | ; 323 | ; ;;; ;;;; 324 | ; ; ; 325 | ; ; ; ;;; ;;; ;;; ;;;; ; 326 | ; ; ; ; ; ; ; ; ;; 327 | ; ;;;; ; ; ; ; ; 328 | ; ; ; ;;;;;;; ; ; ;;;;; 329 | ; ; ; ; ; ; ; 330 | ; ; ; ; ; ; ; ; ; 331 | ; ;;; ;; ;;;; ; ;;;;;; 332 | ; ; 333 | ; ; 334 | ; ;;;;; 335 | ; 336 | ;; ----------------------------------------------------------------------------- 337 | 338 | ;; String -> Boolean 339 | ;; Is the given value a direction? 340 | ;; > (dir? "up") 341 | ;; #t 342 | (define (dir? x) 343 | (or (string=? x "up") 344 | (string=? x "down") 345 | (string=? x "left") 346 | (string=? x "right"))) 347 | 348 | ;; Pit Direction-> Pit 349 | ;; Change the direction (if not opposite current snake dir) 350 | ;; > (world-change-dir world0 "up") 351 | ;; (pit snake1 (list goo0)) 352 | (define (world-change-dir w d) 353 | (define the-snake (pit-snake w)) 354 | (cond [(and (opposite-dir? (snake-dir the-snake) d) 355 | ;; consists of the head and at least one segment: 356 | (cons? (rest (snake-segs the-snake)))) 357 | (stop-with w)] 358 | [else 359 | (pit (snake-change-dir the-snake d) 360 | (pit-goos w))])) 361 | 362 | ;; Direction Direction -> Boolean 363 | ;; Are d1 and d2 opposites? 364 | ;; > (opposite-dir? "up" "down") 365 | ;; #t 366 | (define (opposite-dir? d1 d2) 367 | (cond [(string=? d1 "up") (string=? d2 "down")] 368 | [(string=? d1 "down") (string=? d2 "up")] 369 | [(string=? d1 "left") (string=? d2 "right")] 370 | [(string=? d1 "right") (string=? d2 "left")])) 371 | 372 | 373 | ; 374 | ; 375 | ; 376 | ; 377 | ; ;; 378 | ; ;;;;;; ; 379 | ; ; ; ; 380 | ; ; ; ;;; ;; ;;; ;;; ; ;;; ;; ;;; 381 | ; ; ; ; ; ;; ; ; ;; ; ; ;;; 382 | ; ;;;;; ; ; ; ; ; ; ; ; ; 383 | ; ; ; ;;;;;;; ; ; ; ; ;;;;;;; ; 384 | ; ; ; ; ; ; ; ; ; ; 385 | ; ; ; ; ; ; ; ; ;; ; ; ; 386 | ; ;;; ;; ;;;; ;;; ;;; ;;; ;; ;;;; ;;;;; 387 | ; 388 | ; 389 | ; 390 | ; 391 | ;; ----------------------------------------------------------------------------- 392 | 393 | ;; Snake Scene -> Scene 394 | ;; Draws the snake onto the scene 395 | ;; > (snake+scene snake0 MT-SCENE) 396 | ;; (place-image SEG-IMG 8 8 MT-SCENE) 397 | (define (snake+scene snake scene) 398 | (define snake-body-scene 399 | (img-list+scene (snake-body snake) SEG-IMG scene)) 400 | (define dir (snake-dir snake)) 401 | (img+scene (snake-head snake) 402 | (cond [(string=? "up" dir) HEAD-UP-IMG] 403 | [(string=? "down" dir) HEAD-DOWN-IMG] 404 | [(string=? "left" dir) HEAD-LEFT-IMG] 405 | [(string=? "right" dir) HEAD-RIGHT-IMG]) 406 | snake-body-scene)) 407 | 408 | ;; [Listof Goo] Scene -> Scene 409 | ;; draws all of the goo to a scene 410 | ;; > (goo-list+scene (list goo0) MT-SCENE) 411 | ;; (place-image GOO-IMG 32 32 MT-SCENE) 412 | (define (goo-list+scene goos scene) 413 | ;; [Listof Goo] -> [Listof Posn] 414 | ;; gets the posns of all the goo 415 | ;; > (get-posns-from-goo (list (goo (posn 2 2) 1) (goo (posn 3 3) 1)) 416 | ;; (list (posn 2 2) (posn 3 3)) 417 | (define (get-posns-from-goo goos) 418 | (cond [(empty? goos) empty] 419 | [else (cons (goo-loc (first goos)) 420 | (get-posns-from-goo (rest goos)))])) 421 | (img-list+scene (get-posns-from-goo goos) GOO-IMG scene)) 422 | 423 | ;; [Listof Posn] Image Scene -> Scene 424 | ;; Draws a the image to each posn in the list 425 | ;; > (img-list+scene (list (posn 1 1)) GOO-IMG MT-SCENE) 426 | ;; (place-image GOO-IMG 8 8 427 | ;; (img-list+scene empty GOO-IMG MT-SCENE)) 428 | (define (img-list+scene posns img scene) 429 | (cond [(empty? posns) scene] 430 | [else (img+scene (first posns) 431 | img 432 | (img-list+scene (rest posns) img scene))])) 433 | 434 | ;; Posn Image Scene -> Scene 435 | ;; Draws a the given image onto the scene at the posn. 436 | ;; > (img+scene (posn 2 2) GOO-IMG MT-SCENE) 437 | ;; (place-image GOO-IMG 32 32 MT-SCENE) 438 | (define (img+scene posn img scene) 439 | (place-image img 440 | (* (posn-x posn) SEG-SIZE) 441 | (* (posn-y posn) SEG-SIZE) 442 | scene)) 443 | 444 | ; 445 | ; 446 | ; 447 | ; 448 | ; ;; 449 | ; ;;;;;;; ; ;;;; ; 450 | ; ; ; ; ; ;; 451 | ; ; ; ;; ;;; ;;; ; ; ;;;; ;; ; ; ;;; 452 | ; ; ; ;; ; ; ;; ; ; ; ;; ;; ; ; ; 453 | ; ;;;; ; ; ; ; ; ; ; ; ; ; ; 454 | ; ; ; ; ; ; ; ; ;;;;; ;;;;;; ; ; ; ;;;;;;; 455 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 456 | ; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; 457 | ; ;;;;;;; ;;; ;;; ;;; ;; ;;;;; ;;;; ;; ;;; ;; ;; ;;;; 458 | ; 459 | ; 460 | ; 461 | ; 462 | ;; ----------------------------------------------------------------------------- 463 | 464 | ;; Snake -> Boolean 465 | ;; Determine if the snake is colliding with itself. 466 | ;; > (self-colliding? (snake "up" (list (posn 1 1) (posn 2 1) 467 | ;; (posn 2 2) (posn 1 2) 468 | ;; (posn 1 1)))) 469 | ;; #t 470 | (define (self-colliding? sn) 471 | (cons? (member (snake-head sn) (snake-body sn)))) 472 | 473 | ;; Snake -> Boolean 474 | ;; Determine if the snake is colliding with any of the walls. 475 | ;; > (wall-colliding? (snake "up" (list (posn 0 1)))) 476 | ;; #t 477 | (define (wall-colliding? sn) 478 | (define x (posn-x (snake-head sn))) 479 | (define y (posn-y (snake-head sn))) 480 | (or (= 0 x) (= x SIZE) 481 | (= 0 y) (= y SIZE))) 482 | 483 | 484 | 485 | ; 486 | ; 487 | ; 488 | ; 489 | ; 490 | ; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;;;; ;;;;;;; ;;; ;;;;;; ;;; ;;; 491 | ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; 492 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 493 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 494 | ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; 495 | ; ;;;;;; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; 496 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 497 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 498 | ; ;;; ;;; ;;;; ;;; ;;; ;;;;;;; ;;;;;;;; ;;;;;;; ;;; ;;; ;;; ;; ;;;;; 499 | ; 500 | ; 501 | ; 502 | ; 503 | ;; ----------------------------------------------------------------------------- 504 | ;; Posn Posn -> Boolean 505 | ;; Are the two posns are equal? 506 | ;; > (posn=? (posn 1 1) (posn 1 1)) 507 | ;; true 508 | (define (posn=? p1 p2) 509 | (and (= (posn-x p1) (posn-x p2)) 510 | (= (posn-y p1) (posn-y p2)))) 511 | 512 | ;; Access the head position of the snake. 513 | ;; snake-head : Snake -> Seg 514 | ;; > (snake-head (snake "right" (list (posn 1 1) (posn 2 1))) 515 | ;; (posn 1 1) 516 | (define (snake-head sn) 517 | (first (snake-segs sn))) 518 | 519 | ;; Snake -> [Listof Segs] 520 | ;; returns the snake's body. 521 | ;; That is everyting that isn't the snake's head. 522 | (define (snake-body sn) 523 | (rest (snake-segs sn))) 524 | 525 | ;; Snake Direction -> Snake 526 | (define (snake-change-dir sn d) 527 | (snake d (snake-segs sn))) 528 | 529 | 530 | ; 531 | ; 532 | ; 533 | ; 534 | ; 535 | ; ;;;;;;; ; 536 | ; ; ; ; ; 537 | ; ; ; ; ;;; ;;;; ; ;;;;;;; ;;;; ; 538 | ; ; ; ; ; ; ; ;; ; ; ;; 539 | ; ; ; ; ; ; ; 540 | ; ; ;;;;;;; ;;;;; ; ;;;;; 541 | ; ; ; ; ; ; 542 | ; ; ; ; ; ; ; ; ; ; 543 | ; ;;;;; ;;;; ;;;;;; ;;;; ;;;;;; 544 | ; 545 | ; 546 | ; 547 | ; 548 | ;; ----------------------------------------------------------------------------- 549 | 550 | ;; Initial Structures 551 | 552 | (define goo-list (build-list MAX-GOO (lambda (x) (fresh-goo)))) 553 | (define snake0 (snake "right" (list (posn 1 1)))) ;; BUG? << -- moving this define into the test module blows up 554 | (define world0 (pit snake0 goo-list)) 555 | 556 | (define left-snake0 (snake "left" (list (posn 1 1)))) 557 | (define left-world0 (pit left-snake0 goo-list)) 558 | 559 | ;; Test Constants 560 | 561 | (define snake1 (snake "left" (list (posn 5 5)))) 562 | (define snake2 (snake "up" (list (posn 2 2) (posn 2 3) (posn 2 4)))) 563 | (define wall-snake (snake "right" (list (posn 0 1) (posn 1 1)))) 564 | (define self-eating-snake (snake "up" (list 565 | (posn 19 3) 566 | (posn 19 4) 567 | (posn 20 4) 568 | (posn 21 4) 569 | (posn 22 4) 570 | (posn 22 3) 571 | (posn 21 3) 572 | (posn 20 3) 573 | (posn 19 3) 574 | (posn 18 3)))) 575 | (define goo1 (goo (posn 5 5) 45)) 576 | (define goo2 (goo (posn 4 8) 1)) 577 | (define goo3 (goo (posn 6 9) 40)) 578 | (define goo4 (goo (posn 1 1) 120)) 579 | (define goo5 (goo (posn 1 9) 58)) 580 | (define goo-list1 (list goo1 goo2 goo3 goo4 goo5)) 581 | (define world1 (pit snake1 goo-list1)) 582 | (define world2 (pit snake2 goo-list1)) 583 | 584 | (define right-snake1 (snake "right" (list (posn 5 5)))) 585 | (define right-world1 (pit right-snake1 goo-list1)) 586 | 587 | (module+ test 588 | 589 | (require rackunit rackunit/text-ui) 590 | 591 | ;; test the major basic snake functions 592 | (check-equal? (pit-snake (next-pit world2)) 593 | (snake "up" (list (posn 2 1) (posn 2 2) (posn 2 3)))) 594 | (check-equal? (pit-snake (next-pit world1)) 595 | (snake "left" (list (posn 4 5) (posn 5 5)))) 596 | (check-true (let ([f (pit-goos (next-pit world1))]) 597 | (= (length f) MAX-GOO))) 598 | (check-equal? (pit-snake (next-pit (pit snake0 (list (goo (posn SIZE SIZE) 100))))) 599 | (snake "right" (list (posn 2 1)))) 600 | (check-equal? (pit-snake (next-pit (pit snake0 (list (goo (posn 1 1) 130))))) 601 | (snake "right" (list (posn 2 1) (posn 1 1)))) 602 | 603 | (check-equal? (direct-snake world0 "down") 604 | (world-change-dir world0 "down")) 605 | (check-equal? (direct-snake world0 "a") 606 | world0) 607 | 608 | (check-equal? (render-pit world0) 609 | (snake+scene snake0 610 | (goo-list+scene goo-list MT-SCENE))) 611 | (check-equal? (render-pit world1) 612 | (snake+scene snake1 (goo-list+scene goo-list1 MT-SCENE))) 613 | (check-equal? (render-pit world2) 614 | (snake+scene snake2 (goo-list+scene goo-list1 MT-SCENE))) 615 | 616 | (check-true (dead? (pit wall-snake '()))) 617 | (check-true (dead? (pit self-eating-snake '()))) 618 | (check-false (dead? (pit snake1 '()))) 619 | (check-false (dead? (pit snake2 '()))) 620 | (check-false (dead? world0)) 621 | 622 | (check-equal? (render-end world1) 623 | (overlay (text "Game over" 15 "black") 624 | (render-pit world1))) 625 | (check-equal? (render-end world2) 626 | (overlay (text "Game over" 15 "black") 627 | (render-pit world2))) 628 | 629 | ;; Properties 630 | ;; ----------------------------------------------------------------------------- 631 | 632 | ;; Property: each goo in the list has its 'expire' field decremented by 1 633 | (define (prop:goo-rot-- i) 634 | (test-begin 635 | (for ([i (in-range i)]) 636 | (define goos (list-of-n-goo MAX-GOO)) 637 | (define goo-initial-expire (map goo-expire goos)) 638 | (check-equal? (map sub1 goo-initial-expire) 639 | (map goo-expire (age-goo goos)))))) 640 | 641 | ;; Property: The position of the goo is: 642 | ;; - x in (0,WIDTH-SEGS), 643 | ;; - y in (0,HEIGHT-SEGS). 644 | (define (prop:new-goo-range i) 645 | (test-begin 646 | (for ([i (in-range i)]) 647 | (define f (fresh-goo)) 648 | (check-true (and (< 0 (posn-x (goo-loc f)) SIZE) 649 | (< 0 (posn-y (goo-loc f)) SIZE)))))) 650 | 651 | ;; Number -> [Listof Goo] 652 | ;; creates a list of randomly selected goo that is n long. 653 | (define (list-of-n-goo n) 654 | (cond [(zero? n) empty] 655 | [else (define rand (random 5)) 656 | (cons (list-ref goo-list1 rand) (list-of-n-goo (sub1 n)))])) 657 | 658 | ;; testing pit-snake event handling 659 | 660 | (check-equal? (pit-snake (world-change-dir (pit snake1 "foobar") "down")) 661 | (snake "down" (list (posn 5 5)))) 662 | (check-equal? (pit-snake (world-change-dir (pit snake2 "left") "left")) 663 | (snake "left" (list (posn 2 2) (posn 2 3) (posn 2 4)))) 664 | 665 | (prop:goo-rot-- 1000) 666 | 667 | (check-equal? (grow snake0) 668 | (snake "right" (list (posn 2 1) (posn 1 1)))) 669 | (check-equal? (grow snake1) 670 | (snake "left" (list (posn 4 5) (posn 5 5)))) 671 | (check-equal? (grow snake0) 672 | (snake "right" (list (posn 2 1) 673 | (posn 1 1)))) 674 | 675 | (prop:new-goo-range 1000) 676 | 677 | (check-equal? (can-eat (snake "right" `(,(posn 3 3))) `(,(goo (posn 3 3) 130))) 678 | (goo (posn 3 3) 130)) 679 | (check-false (can-eat (snake "right" `(,(posn 3 3))) `(,(goo (posn 3 4) 130) 680 | ,(goo (posn 2 2) 0)))) 681 | (check-equal? (can-eat snake0 (list (goo (posn 1 1) 1))) 682 | (goo (posn 1 1) 1)) 683 | (check-false (can-eat snake0 (list (goo (posn 2 1) 1)))) 684 | 685 | (check-equal? (slither snake0) (snake "right" (list (posn 2 1)))) 686 | (check-equal? (slither (snake "right" (list (posn 4 4) 687 | (posn 4 5) 688 | (posn 4 6)))) 689 | (snake "right" (list (posn 5 4) (posn 4 4) (posn 4 5)))) 690 | (check-equal? (slither snake0) 691 | (snake "right" (list (posn 2 1)))) 692 | 693 | (check-equal? (length (eat (list (goo (posn 1 1) 130)) (goo (posn 1 1) 130))) 694 | 1) 695 | (check-equal? (grow (snake "left" (list (posn 1 1)))) 696 | (snake "left" (list (posn 0 1) (posn 1 1)))) 697 | 698 | (check-equal? (next-head snake0) (posn 2 1)) 699 | (check-equal? (next-head (snake "left" (list (posn 1 1)))) 700 | (posn 0 1)) 701 | (check-equal? (next-head (snake "up" (list (posn 1 1)))) 702 | (posn 1 0)) 703 | (check-equal? (next-head (snake "down" (list (posn 1 1)))) 704 | (posn 1 2)) 705 | (check-equal? (next-head snake0) (posn 2 1)) 706 | 707 | (check-equal? (posn-move (posn 1 1) 2 3) (posn 3 4)) 708 | (check-equal? (posn-move (posn 3 4) 6 0) (posn 9 4)) 709 | (check-equal? (posn-move (posn 2 8) 0 5) (posn 2 13)) 710 | (check-equal? (posn-move (posn 2 3) 0 0) (posn 2 3)) 711 | 712 | (check-equal? (all-but-last '(1 2 3 4 5 6)) 713 | '(1 2 3 4 5)) 714 | (check-equal? (all-but-last (snake-segs snake2)) 715 | `(,(posn 2 2) ,(posn 2 3))) 716 | (check-equal? (all-but-last (list 0)) empty) 717 | (check-equal? (all-but-last (list 0 1 2)) (list 0 1)) 718 | 719 | ;; testing snake-key-handling 720 | 721 | (check-true (dir? "up")) 722 | (check-true (dir? "down")) 723 | (check-true (dir? "left")) 724 | (check-true (dir? "right")) 725 | (check-false (dir? "f")) 726 | (check-true (dir? "right")) 727 | 728 | (check-equal? (world-change-dir world1 "left") world1) 729 | (check-equal? (world-change-dir world1 "right") right-world1) 730 | (check-equal? (world-change-dir world0 "left") left-world0) 731 | (check-equal? (world-change-dir world0 "right") 732 | (pit (snake "right" (snake-segs (pit-snake world0))) 733 | (pit-goos world0))) 734 | (check-equal? (world-change-dir world0 "down") 735 | (pit (snake "down" (snake-segs (pit-snake world0))) 736 | (pit-goos world0))) 737 | 738 | (check-true (opposite-dir? "up" "down")) 739 | (check-true (opposite-dir? "left" "right")) 740 | (check-true (opposite-dir? "right" "left")) 741 | (check-true (opposite-dir? "down" "up")) 742 | (check-false (opposite-dir? "left" "down")) 743 | (check-false (opposite-dir? "right" "down")) 744 | (check-false (opposite-dir? "down" "left")) 745 | (check-false (opposite-dir? "up" "right")) 746 | (check-true (opposite-dir? "up" "down")) 747 | (check-true (opposite-dir? "down" "up")) 748 | (check-false (opposite-dir? "up" "up") false) 749 | (check-equal? (opposite-dir? "right" "left") true) 750 | (check-equal? (opposite-dir? "left" "right") true) 751 | 752 | ;; testing snake rendering 753 | 754 | (check-equal? (snake+scene snake1 MT-SCENE) 755 | (place-image HEAD-LEFT-IMG (* 5 SEG-SIZE) 756 | (* 5 SEG-SIZE) MT-SCENE)) 757 | (check-equal? (snake+scene snake2 MT-SCENE) 758 | (img+scene (posn 2 2) HEAD-UP-IMG 759 | (img+scene (posn 2 3) SEG-IMG 760 | (img+scene (posn 2 4) SEG-IMG MT-SCENE)))) 761 | (check-equal? (snake+scene (snake "up" (list (posn 1 1))) MT-SCENE) 762 | (img+scene (posn 1 1) HEAD-UP-IMG MT-SCENE)) 763 | 764 | (check-equal? (goo-list+scene (list goo1) MT-SCENE) 765 | (place-image GOO-IMG (* 5 SEG-SIZE) 766 | (* 5 SEG-SIZE) MT-SCENE)) 767 | (check-equal? (goo-list+scene goo-list1 MT-SCENE) 768 | (img-list+scene (list (posn 5 5) (posn 4 8) (posn 6 9) (posn 1 1) (posn 1 9)) 769 | GOO-IMG MT-SCENE)) 770 | 771 | (check-equal? (img-list+scene (list (posn 3 3) (posn 4 4)) SEG-IMG MT-SCENE) 772 | (place-image SEG-IMG (* 3 SEG-SIZE) (* 3 SEG-SIZE) 773 | (place-image SEG-IMG (* 4 SEG-SIZE) (* 4 SEG-SIZE) MT-SCENE))) 774 | (check-equal? (img-list+scene (list (posn 1 1) (posn 10 10)) SEG-IMG MT-SCENE) 775 | (place-image SEG-IMG (* 1 SEG-SIZE) (* 1 SEG-SIZE) 776 | (place-image SEG-IMG (* 10 SEG-SIZE) (* 10 SEG-SIZE) MT-SCENE))) 777 | (check-equal? (img-list+scene (list (posn 1 1)) GOO-IMG MT-SCENE) 778 | (place-image GOO-IMG SEG-SIZE SEG-SIZE 779 | (img-list+scene empty GOO-IMG MT-SCENE))) 780 | 781 | (check-equal? (img+scene (posn 4 3) SEG-IMG MT-SCENE) 782 | (place-image SEG-IMG (* 4 SEG-SIZE) (* 3 SEG-SIZE) MT-SCENE)) 783 | (check-equal? (img+scene (posn 5 2) GOO-IMG MT-SCENE) 784 | (place-image GOO-IMG (* 5 SEG-SIZE) (* 2 SEG-SIZE) MT-SCENE)) 785 | (check-equal? (img+scene (posn 1 1) SEG-IMG MT-SCENE) 786 | (place-image SEG-IMG SEG-SIZE SEG-SIZE MT-SCENE)) 787 | 788 | ;; testing the endgame 789 | (check-false (self-colliding? snake1)) 790 | (check-false (self-colliding? snake2)) 791 | (check-false (self-colliding? wall-snake)) 792 | (check-true (self-colliding? self-eating-snake)) 793 | (check-false (self-colliding? snake0)) 794 | (check-true (self-colliding? (snake (snake-dir snake0) 795 | (cons (posn 1 1) 796 | (snake-segs snake0))))) 797 | 798 | (check-false (wall-colliding? snake1)) 799 | (check-false (wall-colliding? snake2)) 800 | (check-false (wall-colliding? self-eating-snake)) 801 | (check-true (wall-colliding? wall-snake)) 802 | (check-true 803 | (wall-colliding? (snake "right" (list (posn (/ WIDTH-PX SEG-SIZE) 0))))) 804 | (check-true 805 | (wall-colliding? (snake "down" (list (posn 0 (/ HEIGHT-PX SEG-SIZE)))))) 806 | (check-true 807 | (wall-colliding? (snake "up" (list (posn 1 0))))) 808 | (check-equal? (wall-colliding? (snake "right" 809 | (list (posn 0 1)))) 810 | true) 811 | (check-equal? (wall-colliding? (snake "right" 812 | (list (posn 1 0)))) 813 | true) 814 | (check-equal? (wall-colliding? (snake "right" 815 | (list (posn 1 1)))) 816 | false) 817 | (check-true (wall-colliding? (snake "right" (list (posn 1 SIZE))))) 818 | 819 | 820 | ;; testing utilities functions 821 | 822 | (check-false (posn=? (posn 1 1) (posn 2 2))) 823 | (check-false (posn=? (posn 1 2) (posn 2 1))) 824 | (check-true (posn=? (posn 3 4) (posn 3 4))) 825 | (check-true (posn=? (posn 2 2) (posn 2 2))) 826 | (check-equal? (posn=? (posn 1 2) (posn 1 1)) false) 827 | (check-equal? (posn=? (posn 1 2) (posn 1 2)) true) 828 | (check-equal? (posn-move (posn 0 0) 2 3) (posn 2 3)) 829 | 830 | (check-equal? (snake-head snake1) (posn 5 5)) 831 | (check-equal? (snake-head snake2) (posn 2 2)) 832 | (check-equal? (snake-head snake0) (posn 1 1)) 833 | 834 | (check-equal? (snake-body snake1) empty) 835 | (check-equal? (snake-body snake0) empty) 836 | (check-equal? (snake-body snake2) (list (posn 2 3) (posn 2 4))) 837 | 838 | (check-equal? (snake-change-dir snake0 "up") 839 | (snake "up" (list (posn 1 1)))) 840 | (check-equal? (snake-change-dir snake1 "down") 841 | (snake "down" (list (posn 5 5)))) 842 | (check-equal? (snake-change-dir snake2 "left") 843 | (snake "left" (list (posn 2 2) (posn 2 3) (posn 2 4)))) 844 | 845 | (check-true (rotten? (goo (posn 1 2) 0))) 846 | (check-true (rotten? (goo (posn 6 9) 0))) 847 | (check-true (rotten? (goo (posn 23 2) 0))) 848 | 849 | (check-false (rotten? (goo (posn 1 2) 2))) 850 | (check-false (rotten? (goo (posn 3 45) 45334534))) 851 | (check-false (rotten? (goo (posn 2 4) 9))) 852 | 853 | (check-equal? (decay (goo (posn 1 2) 2)) 854 | (goo (posn 1 2) 1)) 855 | (check-equal? (decay (goo (posn 132 0) 2)) 856 | (goo (posn 132 0) 1)) 857 | (check-equal? (decay (goo (posn 1 2) 10)) 858 | (goo (posn 1 2) 9)) 859 | (check-equal? (decay (goo (posn 3 5) 8)) 860 | (goo (posn 3 5) 7)) 861 | 862 | "all tests run") 863 | -------------------------------------------------------------------------------- /chapter8/graphics/brigand.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/realm/d4509a0c42171f4ffbdd67b9acb0b774957be02b/chapter8/graphics/brigand.bmp -------------------------------------------------------------------------------- /chapter8/graphics/hydra.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/realm/d4509a0c42171f4ffbdd67b9acb0b774957be02b/chapter8/graphics/hydra.png -------------------------------------------------------------------------------- /chapter8/graphics/orc.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/realm/d4509a0c42171f4ffbdd67b9acb0b774957be02b/chapter8/graphics/orc.gif -------------------------------------------------------------------------------- /chapter8/graphics/orc.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/realm/d4509a0c42171f4ffbdd67b9acb0b774957be02b/chapter8/graphics/orc.png -------------------------------------------------------------------------------- /chapter8/graphics/orcSprite.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/realm/d4509a0c42171f4ffbdd67b9acb0b774957be02b/chapter8/graphics/orcSprite.png -------------------------------------------------------------------------------- /chapter8/graphics/player.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/realm/d4509a0c42171f4ffbdd67b9acb0b774957be02b/chapter8/graphics/player.bmp -------------------------------------------------------------------------------- /chapter8/graphics/slime.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/realm/d4509a0c42171f4ffbdd67b9acb0b774957be02b/chapter8/graphics/slime.bmp -------------------------------------------------------------------------------- /chapter8/readme.txt: -------------------------------------------------------------------------------- 1 | 2 | This chapter implements a graphical version of the "orc" game from Barski's 3 | "Land of Lisp". To play or to experiment, open the file 4 | 5 | source.rkt 6 | 7 | in DrRacket. The instructions for playing are at the top of the file. 8 | Our tests are at the bottom of the file in a separate 'test' submodule. 9 | 10 | -------------------------------------------------------------------------------- /chapter8/source.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | The Orc game 5 | ------------- 6 | 7 | The Orc game is a turn-based battle game between monsters and the player. 8 | 9 | The player encounters a room full of monsters of all kinds, including 10 | orcs, hydras, slimes, and brigands. They are ready to attack. It is 11 | the player's task to get rid of the monsters. 12 | 13 | When the game starts up, it is the player's turn, meaning she is given 14 | permission to attack a (randomly chosen number) of times. The player uses 15 | nine keys to play 16 | -- With the four arrow keys the player navigates among the twelve monsters. 17 | -- With "s", "f", and "h", 18 | -- the player can 's'tab a specific monster, 19 | -- the player may 'f'lail at several monsters; 20 | -- the player may 'h'eal herself. 21 | When the player runs out of attacks, all live monsters attack the player. 22 | After that, it is the player's turn again. 23 | 24 | Just in case, the player can end a turn prematurely with "e". 25 | 26 | Play 27 | ---- 28 | 29 | Run and evaluate 30 | (start-game) 31 | This will pop up a window that displays the player's vitals, the orcs and 32 | their basic state, and the game instructions. 33 | |# 34 | 35 | 36 | (require 2htdp/image 2htdp/universe) 37 | 38 | ; 39 | ; 40 | ; 41 | ; ;;; ;;; ;;; ;; ;; 42 | ; ; ; ; ; ; ; 43 | ; ; ; ;; ;;; ;;; ; ; ; ;;;; ;; ;;; ; ;;; ; 44 | ; ; ; ;; ;; ;; ; ; ; ; ; ;; ; ; ;; 45 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; 46 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; 47 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; 48 | ; ;;; ;;;;; ;;;; ; ; ;;;; ;;;;; ;;;;; ;;; ;; 49 | ; 50 | ; 51 | ; 52 | ; 53 | 54 | ;; The OrcWorld as Data: 55 | (struct orc-world (player lom attack# target) #:transparent #:mutable) 56 | ;; A OrcWorld is a (orc-world Player [listof Monster] Nat Nat) 57 | ;; The third field of the world refers to the number of attacks left. 58 | ;; The fourth field refers to the position of the next attack target. 59 | 60 | (struct player (health agility strength) #:transparent #:mutable) 61 | ;; A Player is a (player Nat Nat Nat) 62 | ;; The player's fields correspond to hit points, strength, agility. 63 | 64 | (struct monster (image [health #:mutable]) #:transparent) 65 | (struct orc monster (club) #:transparent) 66 | (struct hydra monster () #:transparent) 67 | (struct slime monster (sliminess) #:transparent) 68 | (struct brigand monster () #:transparent) 69 | ;; A Monster is a (monster Image Nat) 70 | ;; (moster i h) is a monster at position i in the list with health h 71 | ;; Each monster is equipped with the index number, 72 | ;; which is used to identify the current target. 73 | ;; 74 | ;; An Orc is an (orc Nat Nat Nat) 75 | ;; A Slime is a (slime Nat Nat Nat) 76 | ;; A Brigrand is a (brigand Nat Nat) 77 | ;; A Hydra is a (hydra Nat Nat) 78 | ;; 79 | ;; The four monster types all inherit the id and health fields from monster. 80 | ;; Two have additional attributes: 81 | ;; -- (orc i h c) means the orc's club has strength c 82 | ;; -- (slime i h a) means the slime can reduce the player's agility by a 83 | 84 | ;; ----------------------------------------------------------------------------- 85 | ;; THE CONSTANTS IN THE WORLD 86 | 87 | ;; player attributes 88 | (define MAX-HEALTH 35) 89 | (define MAX-AGILITY 35) 90 | (define MAX-STRENGTH 35) 91 | 92 | ;; depending on other player attributes, 93 | ;; the game picks the number of attacks, flailing and stabbing damage 94 | (define ATTACKS# 4) 95 | (define STAB-DAMAGE 2) 96 | (define FLAIL-DAMAGE 3) 97 | (define HEALING 8) 98 | 99 | ;; monster attributes 100 | (define MONSTER# 12) 101 | (define PER-ROW 4) 102 | (unless (zero? (remainder MONSTER# PER-ROW)) 103 | (error 'constraint "PER-ROW must divide MONSTER# evenly into rows")) 104 | 105 | (define MONSTER-HEALTH0 9) 106 | (define CLUB-STRENGTH 8) 107 | (define SLIMINESS 5) 108 | 109 | (define HEALTH-DAMAGE -2) 110 | (define AGILITY-DAMAGE -3) 111 | (define STRENGTH-DAMAGE -4) 112 | 113 | ;; string constants 114 | (define STRENGTH "strength") 115 | (define AGILITY "agility") 116 | (define HEALTH "health") 117 | (define LOSE "YOU LOSE") 118 | (define WIN "YOU WIN") 119 | (define DEAD "DEAD") 120 | (define REMAINING "Remaining attacks ") 121 | (define INSTRUCTIONS-2 "Select a monster using the arrow keys") 122 | (define INSTRUCTIONS-1 123 | "Press S to stab a monster | Press F to Flail wildly | Press H to Heal") 124 | 125 | ;; graphical constants 126 | (define HEALTH-BAR-HEIGHT 12) 127 | (define HEALTH-BAR-WIDTH 50) 128 | 129 | ;; compute constants for image frames 130 | (define ORC (bitmap "graphics/orc.png")) 131 | (define HYDRA (bitmap "graphics/hydra.png")) 132 | (define SLIME (bitmap "graphics/slime.bmp")) 133 | (define BRIGAND (bitmap "graphics/brigand.bmp")) 134 | 135 | (define PIC-LIST (list ORC HYDRA SLIME BRIGAND)) 136 | (define w (apply max (map image-width PIC-LIST))) 137 | (define h (apply max (map image-height PIC-LIST))) 138 | 139 | ;; images: player, monsters, constant texts 140 | (define PLAYER-IMAGE (bitmap "graphics/player.bmp")) 141 | 142 | (define FRAME (rectangle w h 'outline 'white)) 143 | (define TARGET (circle (- (/ w 2) 2) 'outline 'blue)) 144 | 145 | (define ORC-IMAGE (overlay ORC FRAME)) 146 | (define HYDRA-IMAGE (overlay HYDRA FRAME)) 147 | (define SLIME-IMAGE (overlay SLIME FRAME)) 148 | (define BRIGAND-IMAGE (overlay BRIGAND FRAME)) 149 | 150 | (define V-SPACER (rectangle 0 10 "solid" "white")) 151 | (define H-SPACER (rectangle 10 0 "solid" "white")) 152 | 153 | ;; fonts & texts & colors 154 | (define AGILITY-COLOR "blue") 155 | (define HEALTH-COLOR "crimson") 156 | (define STRENGTH-COLOR "forest green") 157 | (define MONSTER-COLOR "crimson") 158 | (define MESSAGE-COLOR "black") 159 | (define ATTACK-COLOR "crimson") 160 | 161 | (define HEALTH-SIZE (- HEALTH-BAR-HEIGHT 4)) 162 | (define DEAD-TEXT-SIZE (- HEALTH-BAR-HEIGHT 2)) 163 | (define INSTRUCTION-TEXT-SIZE 16) 164 | (define MESSAGES-SIZE 40) 165 | 166 | (define INSTRUCTION-TEXT 167 | (above 168 | (text INSTRUCTIONS-2 (- INSTRUCTION-TEXT-SIZE 2) "blue") 169 | (text INSTRUCTIONS-1 (- INSTRUCTION-TEXT-SIZE 4) "blue"))) 170 | 171 | (define DEAD-TEXT (text DEAD DEAD-TEXT-SIZE "crimson")) 172 | 173 | ; 174 | ; 175 | ; 176 | ; ;;; ;;; ; 177 | ; ;; ;; 178 | ; ;; ;; ;;;; ;;; ;; ;; 179 | ; ; ; ; ; ; ; ;; ; 180 | ; ; ; ; ;;;;; ; ; ; 181 | ; ; ; ; ; ; ; ; 182 | ; ; ; ; ;; ; ; ; 183 | ; ;;; ;;; ;;; ;; ;;;;; ;;; ;;; 184 | ; 185 | ; 186 | ; 187 | ; 188 | 189 | ;; Start the game 190 | (define (start-game) 191 | (big-bang (initialize-orc-world) 192 | (on-key player-acts-on-monsters) 193 | (to-draw render-orc-battle) 194 | (stop-when end-of-orc-battle? render-the-end))) 195 | 196 | ;; -> OrcWorld 197 | ;; creates an orc-world ready for battling orcs 198 | (define (initialize-orc-world) 199 | (define player0 (initialize-player)) 200 | (define lom0 (initialize-monsters)) 201 | (orc-world player0 lom0 (random-number-of-attacks player0) 0)) 202 | 203 | ;; OrcWorld Key-Event -> OrcWorld 204 | ;; act on key events by the player, if the player has attacks left 205 | (define (player-acts-on-monsters w k) 206 | (cond 207 | [(zero? (orc-world-attack# w)) w] 208 | 209 | [(key=? "s" k) (stab w)] 210 | [(key=? "h" k) (heal w)] 211 | [(key=? "f" k) (flail w)] 212 | 213 | [(key=? "right" k) (move-target w +1)] 214 | [(key=? "left" k) (move-target w -1)] 215 | [(key=? "down" k) (move-target w (+ PER-ROW))] 216 | [(key=? "up" k) (move-target w (- PER-ROW))] 217 | 218 | [(key=? "e" k) (end-turn w)] 219 | ;; [(key=? "n" k) (initialize-orc-world)] 220 | 221 | [else w]) 222 | (give-monster-turn-if-attack#=0 w) 223 | w) 224 | 225 | ;; OrcWorld -> Image 226 | ;; renders the orc world 227 | (define (render-orc-battle w) 228 | (render-orc-world w (orc-world-target w) (instructions w))) 229 | 230 | ;; OrcWorld -> Boolean 231 | ;; is the battle over? i.e., the player lost or all monsters are dead 232 | (define (end-of-orc-battle? w) 233 | (or (win? w) (lose? w))) 234 | 235 | ;; OrcWorld -> Image 236 | ;; render the final orc world 237 | (define (render-the-end w) 238 | (render-orc-world w #f (message (if (lose? w) LOSE WIN)))) 239 | 240 | ;; ----------------------------------------------------------------------------- 241 | 242 | ;; WORLD MANAGEMENT 243 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 244 | 245 | ; 246 | ; 247 | ; 248 | ; ;;;;; ; 249 | ; ; ; 250 | ; ; ;; ;; ;;; ;;;;; 251 | ; ; ;; ; ; ; 252 | ; ; ; ; ; ; 253 | ; ; ; ; ; ; 254 | ; ; ; ; ; ; ; 255 | ; ;;;;; ;;; ;;; ;;;;; ;;; 256 | ; 257 | ; 258 | ; 259 | ; 260 | 261 | ;; -> Player 262 | ;; create a player with maximal capabilities 263 | (define (initialize-player) 264 | (player MAX-HEALTH MAX-AGILITY MAX-STRENGTH)) 265 | 266 | ;; -> [Listof Monster] 267 | ;; create a list of random monsters of length MONSTER-NUM, 268 | (define (initialize-monsters) 269 | ;; Nat -> Monster 270 | ;; makes a random monster 271 | (define (create-monster _) 272 | (define health (random+ MONSTER-HEALTH0)) 273 | (case (random 4) 274 | [(0) (orc ORC-IMAGE health (random+ CLUB-STRENGTH))] 275 | [(1) (hydra HYDRA-IMAGE health)] 276 | [(2) (slime SLIME-IMAGE health (random+ SLIMINESS))] 277 | [(3) (brigand BRIGAND-IMAGE health)] 278 | [else (error "can't happen")])) 279 | (build-list MONSTER# create-monster)) 280 | 281 | ;; Player -> Nat 282 | ;; compute a feasible number of attacks the player may execute 283 | (define (random-number-of-attacks p) 284 | (random-quotient (player-agility p) 285 | ATTACKS#)) 286 | 287 | ; 288 | ; 289 | ; 290 | ; ;;; ;;; ;;;;;; 291 | ; ; ; ; ; ; 292 | ; ; ; ;;;; ;;; ;;; ; ; ;;; ;;; ;;;; ;; ;; ;;;;; ;;;;; 293 | ; ; ; ; ; ; ; ;;; ; ; ; ; ;; ; ; ; ; 294 | ; ;;; ;;;;;; ; ; ; ; ; ; ;;;;;; ; ; ; ;;;; 295 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; 296 | ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; 297 | ; ;;; ;; ;;;;; ; ;;;;;; ;; ;;;;; ;;; ;;; ;;; ;;;;; 298 | ; ; 299 | ; ;;; 300 | ; 301 | ; 302 | 303 | ;; ----------------------------------------------------------------------------- 304 | ;; player actions 305 | 306 | ;; OrcWorld Nat -> Void 307 | ;; Effect: reduces the target by a given amount 308 | ;; > (move-target 309 | ;; (orc-world (player 5 5 5) (list (monster 0 2) (monster 1 3)) 1 0) 310 | ;; 1) 311 | ;; (orc-world (player 5 5 5) (list (monster 0 2) (monster 1 3)) 1 1) 312 | (define (move-target w n) 313 | (set-orc-world-target! w (modulo (+ n (orc-world-target w)) MONSTER#))) 314 | 315 | ;; OrcWorld -> Void 316 | ;; Effect: ends the player's turn by setting the number of attacks to 0 317 | (define (end-turn w) 318 | (set-orc-world-attack#! w 0)) 319 | 320 | ;; OrcWorld -> Void 321 | ;; Effect: reduces the number of remaining attacks for this turn 322 | ;; and increases the player's health level 323 | (define (heal w) 324 | (decrease-attack# w) 325 | (player-health+ (orc-world-player w) HEALING)) 326 | 327 | ;; OrcWorld -> Void 328 | ;; Effect: reduces a targeted monster's health 329 | (define (stab w) 330 | (decrease-attack# w) 331 | (define target (current-target w)) 332 | (define damage 333 | (random-quotient (player-strength (orc-world-player w)) 334 | STAB-DAMAGE)) 335 | (damage-monster target damage)) 336 | 337 | ;; OrcWorld -> Void 338 | ;; Effect: damages a random number of live monsters, 339 | ;; determined by strength of the player 340 | ;; starting with the currently targeted monster 341 | (define (flail w) 342 | (decrease-attack# w) 343 | (define target (current-target w)) 344 | (define alive (filter monster-alive? (orc-world-lom w))) 345 | (define pick# 346 | (min 347 | (random-quotient (player-strength (orc-world-player w)) 348 | FLAIL-DAMAGE) 349 | (length alive))) 350 | (define getem (cons target (take alive pick#))) 351 | (for-each (lambda (m) (damage-monster m 1)) getem)) 352 | 353 | ;; OrcWorld -> Void 354 | ;; Effect: decrease number of remaining attacks 355 | (define (decrease-attack# w) 356 | (set-orc-world-attack#! w (sub1 (orc-world-attack# w)))) 357 | 358 | ;; Monster Nat -> Void 359 | ;; Effect: reduces the hit-strength of a monster 360 | (define (damage-monster m delta) 361 | (set-monster-health! m (interval- (monster-health m) delta))) 362 | 363 | ;; World -> Monster 364 | (define (current-target w) 365 | (list-ref (orc-world-lom w) (orc-world-target w))) 366 | 367 | ;; ----------------------------------------------------------------------------- 368 | ;; monster action 369 | 370 | ;; OrcWorld -> Void 371 | ;; if it is the monsters turn, they attack 372 | ;; > (orc-world (player 4 4 4) empty 3 3) 373 | ;; (orc-world (player 4 4 4) empty 3 3) 374 | (define (give-monster-turn-if-attack#=0 w) 375 | (when (zero? (orc-world-attack# w)) 376 | (define player (orc-world-player w)) 377 | (all-monsters-attack-player player (orc-world-lom w)) 378 | (set-orc-world-attack#! w (random-number-of-attacks player)))) 379 | 380 | ;; Player [Listof Monster] -> Void 381 | ;; Each monster attacks the player 382 | (define (all-monsters-attack-player player lom) 383 | ;; Monster -> Void 384 | (define (one-monster-attacks-player monster) 385 | (cond 386 | [(orc? monster) 387 | (player-health+ player (random- (orc-club monster)))] 388 | [(hydra? monster) 389 | (player-health+ player (random- (monster-health monster)))] 390 | [(slime? monster) 391 | (player-health+ player -1) 392 | (player-agility+ player (random- (slime-sliminess monster)))] 393 | [(brigand? monster) 394 | (case (random 3) 395 | [(0) (player-health+ player HEALTH-DAMAGE)] 396 | [(1) (player-agility+ player AGILITY-DAMAGE)] 397 | [(2) (player-strength+ player STRENGTH-DAMAGE)])])) 398 | ;; -- IN -- 399 | (for-each one-monster-attacks-player (filter monster-alive? lom))) 400 | 401 | ;; ----------------------------------------------------------------------------- 402 | ;; actions on player 403 | 404 | ;; [Player -> Nat] [Player Nat -> Void] Nat -> Player Nat -> Void 405 | ;; effect: change player's selector attribute by adding delta, but max out 406 | (define (player-update! setter selector max-value) 407 | (lambda (player delta) 408 | (setter player 409 | (interval+ (selector player) delta max-value)))) 410 | 411 | ;; Player Nat -> Void 412 | (define player-health+ 413 | (player-update! set-player-health! player-health MAX-HEALTH)) 414 | 415 | ;; Player Nat -> Void 416 | (define player-agility+ 417 | (player-update! set-player-agility! player-agility MAX-AGILITY)) 418 | 419 | ;; Player Nat -> Void 420 | (define player-strength+ 421 | (player-update! set-player-strength! player-strength MAX-STRENGTH)) 422 | 423 | ; 424 | ; 425 | ; 426 | ; ;;;;; ;; ; 427 | ; ; ; ; 428 | ; ; ; ;;;; ;; ;; ;;; ; ;;;; ;; ;;; ;;; ;; ;; ;;; ;; 429 | ; ; ; ; ; ;; ; ; ;; ; ; ;; ; ;; ; ; ;; 430 | ; ;;;; ;;;;;; ; ; ; ; ;;;;;; ; ; ; ; ; ; 431 | ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; 432 | ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; 433 | ; ;;; ; ;;;;; ;;; ;;; ;;; ;; ;;;;; ;;;;; ;;;;; ;;; ;;; ;;; ; 434 | ; ; 435 | ; ;;;; 436 | ; 437 | ; 438 | 439 | ;; OrcWorld Boolean Image -> Image 440 | ;; draws all the monsters and the player, then adds message 441 | (define (render-orc-world w with-target additional-text) 442 | (define i-player (render-player (orc-world-player w))) 443 | (define i-monster (render-monsters (orc-world-lom w) with-target)) 444 | (above V-SPACER 445 | (beside H-SPACER 446 | i-player 447 | H-SPACER H-SPACER H-SPACER 448 | (above i-monster 449 | V-SPACER V-SPACER V-SPACER 450 | additional-text) 451 | H-SPACER) 452 | V-SPACER)) 453 | 454 | ;; Player -> Image 455 | ;; render player with three status bars 456 | (define (render-player p) 457 | (above/align 458 | "left" 459 | (status-bar (player-strength p) MAX-STRENGTH STRENGTH-COLOR STRENGTH) 460 | V-SPACER 461 | (status-bar (player-agility p) MAX-AGILITY AGILITY-COLOR AGILITY) 462 | V-SPACER 463 | (status-bar (player-health p) MAX-HEALTH HEALTH-COLOR HEALTH) 464 | V-SPACER V-SPACER V-SPACER 465 | PLAYER-IMAGE)) 466 | 467 | ;; Nat Nat Color String -> Image 468 | ;; creates a labeled rectangle of width/max proportions 469 | ;; assume: (<= width max) 470 | (define (status-bar v-current v-max color label) 471 | (define w (* (/ v-current v-max) HEALTH-BAR-WIDTH)) 472 | (define f (rectangle w HEALTH-BAR-HEIGHT 'solid color)) 473 | (define b (rectangle HEALTH-BAR-WIDTH HEALTH-BAR-HEIGHT 'outline color)) 474 | (define bar (overlay/align 'left 'top f b)) 475 | (beside bar H-SPACER (text label HEALTH-SIZE color))) 476 | 477 | ;; String -> Image 478 | (define (message str) 479 | (text str MESSAGES-SIZE MESSAGE-COLOR)) 480 | 481 | ;; OrcWorld -> Image 482 | (define (instructions w) 483 | (define na (number->string (orc-world-attack# w))) 484 | (define ra (string-append REMAINING na)) 485 | (above (text ra INSTRUCTION-TEXT-SIZE ATTACK-COLOR) INSTRUCTION-TEXT)) 486 | 487 | ;; [Listof Monster] [Opt Nat] -> Image 488 | ;; add all monsters on lom, including status bar 489 | ;; label the target unless it isn't called for 490 | (define (render-monsters lom with-target) 491 | ;; the currently targeted monster (if needed) 492 | (define target 493 | (if (number? with-target) 494 | (list-ref lom with-target) 495 | 'a-silly-symbol-that-cannot-be-eq-to-an-orc)) 496 | 497 | ;; Monster -> Image 498 | (define (render-one-monster m) 499 | (define image 500 | (if (eq? m target) 501 | (overlay TARGET (monster-image m)) 502 | (monster-image m))) 503 | (define health (monster-health m)) 504 | (define health-bar 505 | (if (= health 0) 506 | (overlay DEAD-TEXT (status-bar 0 1 'white "")) 507 | (status-bar health MONSTER-HEALTH0 MONSTER-COLOR ""))) 508 | (above health-bar image)) 509 | 510 | (arrange (map render-one-monster lom))) 511 | 512 | ;; [Listof Image] -> Image 513 | ;; break a list of images into rows of PER-ROW 514 | (define (arrange lom) 515 | (cond 516 | [(empty? lom) empty-image] 517 | [else (define row-image (apply beside (take lom PER-ROW))) 518 | (above row-image (arrange (drop lom PER-ROW)))])) 519 | 520 | 521 | ; 522 | ; 523 | ; 524 | ; ;;;;;; ;; ;;; 525 | ; ; ; ; ; ; 526 | ; ; ; ;; ;; ;;; ; ; 527 | ; ;;; ;; ; ; ;; ; 528 | ; ; ; ; ; ; ; ; 529 | ; ; ; ; ; ; ; 530 | ; ; ; ; ; ; ;; 531 | ; ;;;;;; ;;; ;;; ;;; ;; ;; 532 | ; 533 | ; 534 | ; 535 | ; 536 | 537 | ;; OrcWorld -> Boolean 538 | ;; Has the player won? 539 | ;; > (orc-world (player 1 1 1) (list (monster 0 0)) 0 0) 540 | ;; #t 541 | (define (win? w) 542 | (all-dead? (orc-world-lom w))) 543 | 544 | ;; OrcWorld -> Boolean 545 | ;; Has the player lost? 546 | ;; > (lose? (orc-world (player 0 2 2) empty 0 0)) 547 | ;; #t 548 | (define (lose? w) 549 | (player-dead? (orc-world-player w))) 550 | 551 | ;; Player -> Boolean 552 | ;; Is the player dead? 553 | ;; > (orc-world (player 1 0 1) empty 0 0) 554 | ;; #t 555 | (define (player-dead? p) 556 | (or (= (player-health p) 0) 557 | (= (player-agility p) 0) 558 | (= (player-strength p) 0))) 559 | 560 | ;; [Listof Monster] -> Boolean 561 | ;; Are all the monsters in the list dead?s 562 | ;; > (all-dead? (orc-world (player 5 5 5) (list (monster 1 0)) 0 1)) 563 | ;; #t 564 | (define (all-dead? lom) 565 | (not (ormap monster-alive? lom))) 566 | 567 | ;; Monster -> Boolean 568 | ;; Is the monster alive? 569 | (define (monster-alive? m) 570 | (> (monster-health m) 0)) 571 | 572 | 573 | ; 574 | ; 575 | ; 576 | ; ;; 577 | ; ; 578 | ; ; ; ;; ;; ;; ;; ;;;;; 579 | ; ; ; ; ; ; ; ; ; 580 | ; ; ; ; ; ;; ;;;; 581 | ; ;;; ; ; ;; ; 582 | ; ; ; ; ;; ; ; ; ; 583 | ; ;;; ;;; ;; ;; ;; ;; ;;;;; 584 | ; 585 | ; 586 | ; 587 | ; 588 | 589 | ;; Nat Nat -> Nat 590 | ;; a random number between 1 and the (quotient x y) 591 | (define (random-quotient x y) 592 | (define div (quotient x y)) 593 | (if (> 0 div) 0 (random+ (add1 div)))) 594 | 595 | ;; Nat -> Nat 596 | ;; (random+ n) creates a random number in [1,n] 597 | (define (random+ n) 598 | (add1 (random n))) 599 | 600 | ;; Nat -> Nat 601 | ;; (random+ n) creates a random number in [-n,-1] 602 | (define (random- n) 603 | (- (add1 (random n)))) 604 | 605 | ;; Nat Nat [Nat] -> Nat 606 | ;; subtract n from m but stay in [0,max-value] 607 | (define (interval- n m (max-value 100)) 608 | (min (max 0 (- n m)) max-value)) 609 | 610 | ;; Nat Nat [Nat] -> Nat 611 | ;; subtract n from m but stay in [0,max-value] 612 | (define (interval+ n m (max-value 100)) 613 | (interval- n (- m) max-value)) 614 | 615 | ; 616 | ; 617 | ; 618 | ; ;;;;;; 619 | ; ; ; ; 620 | ; ; ;;;; ;;;;; ;;;;; ;;;;; 621 | ; ; ; ; ; ; ; ; ; 622 | ; ; ;;;;;; ;;;; ; ;;;; 623 | ; ; ; ; ; ; 624 | ; ; ; ; ; ; ; ; ; 625 | ; ;;; ;;;;; ;;;;; ;;; ;;;;; 626 | ; 627 | ; 628 | ; 629 | ; 630 | 631 | (module+ test 632 | 633 | (require rackunit rackunit/text-ui) 634 | 635 | ;; Test structs 636 | (define WORLD0 (orc-world (initialize-player) empty 0 0)) 637 | (define WORLD1 (struct-copy orc-world (initialize-orc-world) [attack# 5])) 638 | (define (WORLD2) (struct-copy orc-world (initialize-orc-world) [attack# 0])) 639 | ;; these are random worlds 640 | (define AN-ORC (orc 'image 0 5)) 641 | (define A-SLIME (slime 'image 1 6)) 642 | (define A-HYDRA (hydra 'image 2)) 643 | (define A-BRIGAND (brigand 'image 3)) 644 | 645 | ;; testing move-target 646 | 647 | (check-equal? (let ([w (orc-world 'dummy 'dummy 'dummy 0)]) 648 | (move-target w +1) 649 | w) 650 | (orc-world 'dummy 'dummy 'dummy 1)) 651 | (check-equal? (let ([w (orc-world 'dummy 'dummy 'dummy 0)]) 652 | (move-target w -1) 653 | w) 654 | (orc-world 'dummy 'dummy 'dummy (- MONSTER# 1))) 655 | (check-equal? (let ([w (orc-world 'dummy 'dummy 'dummy 0)]) 656 | (move-target w (- PER-ROW)) 657 | w) 658 | (orc-world 'dummy 'dummy 'dummy (- MONSTER# PER-ROW))) 659 | (check-equal? (let ([w (orc-world 'dummy 'dummy 'dummy 1)]) 660 | (move-target w (+ PER-ROW)) 661 | w) 662 | (orc-world 'dummy 'dummy 'dummy (+ PER-ROW 1))) 663 | (check-equal? (begin 664 | (move-target WORLD1 0) 665 | WORLD1) 666 | WORLD1) 667 | (check-equal? (let () 668 | (define w (struct-copy orc-world WORLD1)) 669 | (move-target w 4) 670 | w) 671 | (struct-copy orc-world WORLD1 [target (+ 4 (orc-world-target WORLD1))])) 672 | (check-equal? (current-target WORLD1) 673 | (first (orc-world-lom WORLD1))) 674 | 675 | ;; testing basic player manipulations 676 | 677 | (check-equal? (let ([p (player 1 0 0)]) 678 | (player-health+ p 5) 679 | p) 680 | (player 6 0 0)) 681 | (check-equal? (let ([p (player 0 1 0)]) 682 | (player-agility+ p 5) 683 | p) 684 | (player 0 6 0)) 685 | 686 | (check-equal? (let ([p (player 0 0 1)]) 687 | (player-strength+ p 5) 688 | p) 689 | (player 0 0 6)) 690 | 691 | (check-equal? (let ([p (player 5 5 5)]) 692 | (all-monsters-attack-player p (list (orc 'image 1 1))) 693 | p) 694 | (player 4 5 5)) 695 | 696 | (check-equal? (let ([p (player 5 5 5)]) 697 | (all-monsters-attack-player p (list (hydra 'image 1))) 698 | p) 699 | (player 4 5 5)) 700 | 701 | (check-equal? (let ([p (player 5 5 5)]) 702 | (all-monsters-attack-player p (list (slime 'image 1 1))) 703 | p) 704 | (player 4 4 5)) 705 | 706 | (check member 707 | (let ([p (player 5 5 5)]) 708 | (all-monsters-attack-player p (list (brigand 'image 1))) 709 | p) 710 | (list (player 3 5 5) 711 | (player 5 2 5) 712 | (player 5 5 1))) 713 | 714 | ;; Properties 715 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 716 | 717 | ;; Property: 718 | ;; the output will always be in [1, (/ X Y)] 719 | (define (prop:rand-frac-range i) 720 | (test-begin 721 | (for ([i (in-range i)]) 722 | (define x (random 4294967087)) 723 | (define y (random 4294967087)) 724 | (check-true (<= 1 (random-quotient x y) (add1 (/ x y))))))) 725 | 726 | ;; Property: 727 | ;; The number of the monsters in the list is equal to 728 | ;; MONSTER-NUM 729 | (define (prop:monster-init-length i) 730 | (test-begin 731 | (for ([i (in-range i)]) 732 | (check-true (= MONSTER# 733 | (length (initialize-monsters))))))) 734 | 735 | ;; Property: 736 | ;; the player will have less points in at least one of its 737 | ;; fields 738 | (define (prop:monster-attack-player-dec i) 739 | (test-begin 740 | (for ([i (in-range i)]) 741 | (define pl (player MAX-HEALTH MAX-AGILITY MAX-STRENGTH)) 742 | (define mon (first (initialize-monsters))) 743 | (begin 744 | (all-monsters-attack-player pl (list mon)) 745 | (check-true (or (< (player-health pl) MAX-HEALTH) 746 | (< (player-agility pl) MAX-AGILITY) 747 | (< (player-strength pl) MAX-STRENGTH))))))) 748 | 749 | ;; Property: 750 | ;; If there are monster, then the player will 751 | ;; have less points in at least one of its fields 752 | (define (prop:monsters-attack-player-dec i) 753 | (test-begin 754 | (for ([i (in-range i)]) 755 | (define pl (player MAX-HEALTH MAX-AGILITY MAX-STRENGTH)) 756 | (define monsters (initialize-monsters)) 757 | (define wor (orc-world pl monsters 0 0)) 758 | (begin 759 | (all-monsters-attack-player pl monsters) 760 | (check-true (or (< (player-health pl) MAX-HEALTH) 761 | (< (player-agility pl) MAX-AGILITY) 762 | (< (player-strength pl) MAX-STRENGTH))))))) 763 | 764 | ;; Property: The health of the targeted monster, m, 765 | ;; is less than what it was. and 766 | ;; [(sub1 (monster-health m)), 767 | ;; (- (monster-health m) 768 | ;; (/ (player-strength (orc-world-player w)) 2))] 769 | (define (prop:stab!-health i) 770 | (test-begin 771 | (for ([i (in-range i)]) 772 | (begin (define mon (first(initialize-monsters))) 773 | (define ht (monster-health mon)) 774 | (define pl (random-player)) 775 | (define w (orc-world pl (list mon) 2 0)) 776 | (stab w) 777 | (check-true (> ht (monster-health (first (orc-world-lom w))))))))) 778 | 779 | ;; random-player: -> Player 780 | ;; creates a random player 781 | (define (random-player) 782 | (player (add1 (random MAX-HEALTH)) 783 | (add1 (random MAX-AGILITY)) 784 | (add1 (random MAX-STRENGTH)))) 785 | 786 | ;; testing initializers 787 | (prop:monster-init-length 1000) 788 | (check-true (monster? (first (initialize-monsters)))) 789 | (check-true (> 10 (monster-health (first (initialize-monsters))))) 790 | (check-equal? (length (initialize-monsters)) MONSTER#) 791 | (check-equal? (length (orc-world-lom WORLD1)) MONSTER#) 792 | (check-true (>= (let ([p (initialize-player)]) 793 | (player-health p)) 794 | (let ([p (initialize-player)]) 795 | (all-monsters-attack-player p (list AN-ORC)) 796 | (player-health p)))) 797 | (check-true (> (player-health (initialize-player)) 798 | (let ([p (initialize-player)]) 799 | (all-monsters-attack-player p (list A-HYDRA)) 800 | (player-health p)))) 801 | (check-true (< (let ([p (initialize-player)]) 802 | (all-monsters-attack-player p (list A-SLIME)) 803 | (player-agility p)) 804 | (let ([p (initialize-player)]) 805 | (player-agility p)))) 806 | (check-true (let ([p (initialize-player)]) 807 | (all-monsters-attack-player p (list A-BRIGAND)) 808 | (or (= (player-health p) 809 | (- (player-health (initialize-player)) 2)) 810 | (= (player-agility p) 811 | (- (player-agility (initialize-player)) 3)) 812 | (= (player-strength p) 813 | (- (player-strength (initialize-player)) 4))))) 814 | (check-equal? (length (orc-world-lom WORLD1)) MONSTER#) 815 | (check-equal? (orc-world-player WORLD1) (orc-world-player WORLD1)) 816 | 817 | ;; testing the-monster's attacks 818 | 819 | (prop:monster-attack-player-dec 1000) 820 | (prop:monsters-attack-player-dec 1000) 821 | (check-true (or (> (player-health (orc-world-player (WORLD2))) 822 | (player-health (orc-world-player 823 | (let ([w (WORLD2)]) 824 | (all-monsters-attack-player (orc-world-player w) (orc-world-lom w)) 825 | w)))) 826 | (> (player-strength (orc-world-player (WORLD2))) 827 | (player-strength (orc-world-player 828 | (let ([w (WORLD2)]) 829 | (all-monsters-attack-player (orc-world-player w) (orc-world-lom w)) 830 | w)))) 831 | (> (player-agility (orc-world-player (WORLD2))) 832 | (player-agility (orc-world-player 833 | (let ([w (WORLD2)]) 834 | (all-monsters-attack-player (orc-world-player w) (orc-world-lom w)) 835 | w)))))) 836 | 837 | ;; testing the player's actions 838 | 839 | (prop:stab!-health 1000) 840 | (test-begin (define o (orc 'image 0 5)) 841 | (damage-monster o 5) 842 | (check-equal? o (orc 'image 0 5))) 843 | (test-begin (define o (orc 'image 0 5)) 844 | (damage-monster o 0) 845 | (check-equal? o (orc 'image 0 5))) 846 | (check-equal? (player-health (orc-world-player 847 | (let () 848 | (define w (struct-copy orc-world WORLD1)) 849 | (heal w) 850 | w))) 851 | (min MAX-HEALTH 852 | (+ 8 (player-health (orc-world-player WORLD1))))) 853 | 854 | (check-equal? (length (orc-world-lom 855 | (let () 856 | (define w (struct-copy orc-world WORLD1)) 857 | (stab w) 858 | w))) 859 | MONSTER#) 860 | 861 | ;; testing game predicates 862 | 863 | (check-false (lose? WORLD0)) 864 | (check-true (lose? (orc-world (player 0 30 30) empty 0 0))) 865 | (check-true (all-dead? (list (orc 'image 0 0) (hydra 'image 0)))) 866 | (check-true (all-dead? (list AN-ORC))) 867 | (check-true (win? (orc-world (initialize-player) (list (orc 'image 0 0)) 0 0))) 868 | (check-true (win? (orc-world (initialize-player) (list AN-ORC) 0 0))) 869 | (check-true (end-of-orc-battle? (orc-world (initialize-player) (list (orc 'image 0 0)) 0 0))) 870 | (check-true (end-of-orc-battle? (orc-world (initialize-player) (list AN-ORC) 0 0))) 871 | (check-true (end-of-orc-battle? (orc-world (player 0 30 30) empty 0 0))) 872 | (check-true (player-dead? (player 0 2 5))) 873 | (check-false (player-dead? (initialize-player))) 874 | (check-false (not (monster-alive? A-HYDRA))) 875 | (check-true (monster-alive? (monster 'image 1))) 876 | (check-false (monster-alive? (orc 'image 0 0))) 877 | 878 | ;; testing utilities 879 | 880 | (prop:rand-frac-range 1000) 881 | 882 | "all tests run") 883 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "realm") 4 | 5 | (define name "Realm of Racket Source Code") 6 | 7 | (define compile-omit-paths 8 | '( 9 | "chapter5/ufo-source.rkt" 10 | ; "chapter6" 11 | ; "chapter8" 12 | ; "chapter10" 13 | ; "chapter12" 14 | ; "chapter13" 15 | ; "chapter14" 16 | )) 17 | 18 | ; (define scribblings '(("htdp.scrbl"))) 19 | (define deps '("base" 20 | "htdp-lib")) 21 | (define build-deps '("rackunit-lib")) 22 | 23 | (define pkg-desc "Sample code for _Realm of Racket_") 24 | 25 | (define pkg-authors '(matthias)) 26 | 27 | (define license 28 | '(Apache-2.0 OR MIT)) 29 | -------------------------------------------------------------------------------- /readme.txt: -------------------------------------------------------------------------------- 1 | 2 | This folder contains the source code for the games from Realm of Racket. 3 | It is organized into sub-folders labeled 'chapters'. Each 'chapter' folder 4 | contains the code and the graphics needed to run the examples from the 5 | corresponding book chapter. 6 | -------------------------------------------------------------------------------- /todo.txt: -------------------------------------------------------------------------------- 1 | 2 | This is the first complete draft of the Realm of Racket code. 3 | ------------------------------------------------------------ 4 | 5 | 1. need to eliminate the AI from chapter 10 6 | 7 | 2. the game in 12 does not correctly advertise whose turn it is 8 | same bug may exist in chapter 10 9 | 10 | 3. we should offer a way to link the chapter 12 game to the AI 11 | XOR to allow a second human player 12 | 13 | --------------------------------------------------------------------------------