From 9d23e66fe8332abc7a1bbd9022f3e58e1133b3fb Mon Sep 17 00:00:00 2001 From: rsiddharth Date: Fri, 3 Jul 2020 15:49:09 -0400 Subject: name directories like the realm repo. --- chapter1/hw.rkt | 3 + chapter10/graphics/dice1.png | Bin 0 -> 869 bytes chapter10/graphics/dice2.png | Bin 0 -> 887 bytes chapter10/graphics/dice3.png | Bin 0 -> 812 bytes chapter10/graphics/dice4.png | Bin 0 -> 968 bytes chapter10/source.rkt | 1218 ++++++++++++++++++++++++++++++++++ chapter11/lazy.rkt | 23 + chapter12/graphics/dice1.png | Bin 0 -> 869 bytes chapter12/graphics/dice2.png | Bin 0 -> 887 bytes chapter12/graphics/dice3.png | Bin 0 -> 812 bytes chapter12/graphics/dice4.png | Bin 0 -> 968 bytes chapter12/source.rkt | 1240 +++++++++++++++++++++++++++++++++++ chapter13/client.rkt | 189 ++++++ chapter13/run.rkt | 13 + chapter13/server.rkt | 149 +++++ chapter13/shared.rkt | 28 + chapter14/client.rkt | 611 +++++++++++++++++ chapter14/graphics/cupcake.gif | Bin 0 -> 1796 bytes chapter14/graphics/hungry-henry.gif | Bin 0 -> 1132 bytes chapter14/readme.txt | 29 + chapter14/run.rkt | 59 ++ chapter14/server.rkt | 1065 ++++++++++++++++++++++++++++++ chapter14/shared.rkt | 156 +++++ chapter2/guess.rkt | 21 + chapter5/guess.rkt | 75 +++ chapter5/loco.rkt | 59 ++ chapter5/resources/caroille.png | Bin 0 -> 886 bytes chapter5/resources/caroille.svg | 125 ++++ chapter5/resources/ufo-fart.png | Bin 0 -> 868 bytes chapter5/resources/ufo-fart.svg | 188 ++++++ chapter5/resources/zarking-ufo.png | Bin 0 -> 1337 bytes chapter5/resources/zarking-ufo.svg | 128 ++++ chapter5/ufo.rkt | 86 +++ chapter6/resources/body.gif | Bin 0 -> 1079 bytes chapter6/resources/goo-red.gif | Bin 0 -> 681 bytes chapter6/resources/goo.gif | Bin 0 -> 878 bytes chapter6/resources/head.gif | Bin 0 -> 776 bytes chapter6/resources/obstacle.gif | Bin 0 -> 667 bytes chapter6/resources/tail.gif | Bin 0 -> 1079 bytes chapter6/snake.rkt | 295 +++++++++ chapter6/snakes.rkt | 362 ++++++++++ chapter8/graphics/README.txt | 3 + chapter8/graphics/brigand.bmp | Bin 0 -> 6960 bytes chapter8/graphics/hydra.png | Bin 0 -> 11948 bytes chapter8/graphics/hydrar.png | Bin 0 -> 11654 bytes chapter8/graphics/orc.gif | Bin 0 -> 1980 bytes chapter8/graphics/orc.png | Bin 0 -> 10504 bytes chapter8/graphics/orcSprite.png | Bin 0 -> 7949 bytes chapter8/graphics/player.bmp | Bin 0 -> 92856 bytes chapter8/graphics/slime.bmp | Bin 0 -> 21056 bytes chapter8/orc.rkt | 943 ++++++++++++++++++++++++++ eight/graphics/README.txt | 3 - eight/graphics/brigand.bmp | Bin 6960 -> 0 bytes eight/graphics/hydra.png | Bin 11948 -> 0 bytes eight/graphics/hydrar.png | Bin 11654 -> 0 bytes eight/graphics/orc.gif | Bin 1980 -> 0 bytes eight/graphics/orc.png | Bin 10504 -> 0 bytes eight/graphics/orcSprite.png | Bin 7949 -> 0 bytes eight/graphics/player.bmp | Bin 92856 -> 0 bytes eight/graphics/slime.bmp | Bin 21056 -> 0 bytes eight/orc.rkt | 943 -------------------------- eleven/lazy.rkt | 23 - five/guess.rkt | 75 --- five/loco.rkt | 59 -- five/resources/caroille.png | Bin 886 -> 0 bytes five/resources/caroille.svg | 125 ---- five/resources/ufo-fart.png | Bin 868 -> 0 bytes five/resources/ufo-fart.svg | 188 ------ five/resources/zarking-ufo.png | Bin 1337 -> 0 bytes five/resources/zarking-ufo.svg | 128 ---- five/ufo.rkt | 86 --- fourteen/client.rkt | 611 ----------------- fourteen/graphics/cupcake.gif | Bin 1796 -> 0 bytes fourteen/graphics/hungry-henry.gif | Bin 1132 -> 0 bytes fourteen/readme.txt | 29 - fourteen/run.rkt | 59 -- fourteen/server.rkt | 1065 ------------------------------ fourteen/shared.rkt | 156 ----- one/hw.rkt | 3 - six/resources/body.gif | Bin 1079 -> 0 bytes six/resources/goo-red.gif | Bin 681 -> 0 bytes six/resources/goo.gif | Bin 878 -> 0 bytes six/resources/head.gif | Bin 776 -> 0 bytes six/resources/obstacle.gif | Bin 667 -> 0 bytes six/resources/tail.gif | Bin 1079 -> 0 bytes six/snake.rkt | 295 --------- six/snakes.rkt | 362 ---------- ten/graphics/dice1.png | Bin 869 -> 0 bytes ten/graphics/dice2.png | Bin 887 -> 0 bytes ten/graphics/dice3.png | Bin 812 -> 0 bytes ten/graphics/dice4.png | Bin 968 -> 0 bytes ten/source.rkt | 1218 ---------------------------------- thirteen/client.rkt | 189 ------ thirteen/run.rkt | 13 - thirteen/server.rkt | 149 ----- thirteen/shared.rkt | 28 - twelve/graphics/dice1.png | Bin 869 -> 0 bytes twelve/graphics/dice2.png | Bin 887 -> 0 bytes twelve/graphics/dice3.png | Bin 812 -> 0 bytes twelve/graphics/dice4.png | Bin 968 -> 0 bytes twelve/source.rkt | 1240 ----------------------------------- two/guess.rkt | 21 - 102 files changed, 7068 insertions(+), 7068 deletions(-) create mode 100644 chapter1/hw.rkt create mode 100644 chapter10/graphics/dice1.png create mode 100644 chapter10/graphics/dice2.png create mode 100644 chapter10/graphics/dice3.png create mode 100644 chapter10/graphics/dice4.png create mode 100644 chapter10/source.rkt create mode 100644 chapter11/lazy.rkt create mode 100644 chapter12/graphics/dice1.png create mode 100644 chapter12/graphics/dice2.png create mode 100644 chapter12/graphics/dice3.png create mode 100644 chapter12/graphics/dice4.png create mode 100644 chapter12/source.rkt create mode 100644 chapter13/client.rkt create mode 100644 chapter13/run.rkt create mode 100644 chapter13/server.rkt create mode 100644 chapter13/shared.rkt create mode 100644 chapter14/client.rkt create mode 100644 chapter14/graphics/cupcake.gif create mode 100644 chapter14/graphics/hungry-henry.gif create mode 100644 chapter14/readme.txt create mode 100644 chapter14/run.rkt create mode 100644 chapter14/server.rkt create mode 100644 chapter14/shared.rkt create mode 100644 chapter2/guess.rkt create mode 100644 chapter5/guess.rkt create mode 100644 chapter5/loco.rkt create mode 100644 chapter5/resources/caroille.png create mode 100644 chapter5/resources/caroille.svg create mode 100644 chapter5/resources/ufo-fart.png create mode 100644 chapter5/resources/ufo-fart.svg create mode 100644 chapter5/resources/zarking-ufo.png create mode 100644 chapter5/resources/zarking-ufo.svg create mode 100644 chapter5/ufo.rkt create mode 100644 chapter6/resources/body.gif create mode 100644 chapter6/resources/goo-red.gif create mode 100644 chapter6/resources/goo.gif create mode 100644 chapter6/resources/head.gif create mode 100644 chapter6/resources/obstacle.gif create mode 100644 chapter6/resources/tail.gif create mode 100644 chapter6/snake.rkt create mode 100644 chapter6/snakes.rkt create mode 100644 chapter8/graphics/README.txt create mode 100644 chapter8/graphics/brigand.bmp create mode 100644 chapter8/graphics/hydra.png create mode 100644 chapter8/graphics/hydrar.png create mode 100644 chapter8/graphics/orc.gif create mode 100644 chapter8/graphics/orc.png create mode 100644 chapter8/graphics/orcSprite.png create mode 100644 chapter8/graphics/player.bmp create mode 100644 chapter8/graphics/slime.bmp create mode 100644 chapter8/orc.rkt delete mode 100644 eight/graphics/README.txt delete mode 100644 eight/graphics/brigand.bmp delete mode 100644 eight/graphics/hydra.png delete mode 100644 eight/graphics/hydrar.png delete mode 100644 eight/graphics/orc.gif delete mode 100644 eight/graphics/orc.png delete mode 100644 eight/graphics/orcSprite.png delete mode 100644 eight/graphics/player.bmp delete mode 100644 eight/graphics/slime.bmp delete mode 100644 eight/orc.rkt delete mode 100644 eleven/lazy.rkt delete mode 100644 five/guess.rkt delete mode 100644 five/loco.rkt delete mode 100644 five/resources/caroille.png delete mode 100644 five/resources/caroille.svg delete mode 100644 five/resources/ufo-fart.png delete mode 100644 five/resources/ufo-fart.svg delete mode 100644 five/resources/zarking-ufo.png delete mode 100644 five/resources/zarking-ufo.svg delete mode 100644 five/ufo.rkt delete mode 100644 fourteen/client.rkt delete mode 100644 fourteen/graphics/cupcake.gif delete mode 100644 fourteen/graphics/hungry-henry.gif delete mode 100644 fourteen/readme.txt delete mode 100644 fourteen/run.rkt delete mode 100644 fourteen/server.rkt delete mode 100644 fourteen/shared.rkt delete mode 100644 one/hw.rkt delete mode 100644 six/resources/body.gif delete mode 100644 six/resources/goo-red.gif delete mode 100644 six/resources/goo.gif delete mode 100644 six/resources/head.gif delete mode 100644 six/resources/obstacle.gif delete mode 100644 six/resources/tail.gif delete mode 100644 six/snake.rkt delete mode 100644 six/snakes.rkt delete mode 100644 ten/graphics/dice1.png delete mode 100644 ten/graphics/dice2.png delete mode 100644 ten/graphics/dice3.png delete mode 100644 ten/graphics/dice4.png delete mode 100644 ten/source.rkt delete mode 100644 thirteen/client.rkt delete mode 100644 thirteen/run.rkt delete mode 100644 thirteen/server.rkt delete mode 100644 thirteen/shared.rkt delete mode 100644 twelve/graphics/dice1.png delete mode 100644 twelve/graphics/dice2.png delete mode 100644 twelve/graphics/dice3.png delete mode 100644 twelve/graphics/dice4.png delete mode 100644 twelve/source.rkt delete mode 100644 two/guess.rkt diff --git a/chapter1/hw.rkt b/chapter1/hw.rkt new file mode 100644 index 0000000..fec7e25 --- /dev/null +++ b/chapter1/hw.rkt @@ -0,0 +1,3 @@ +#lang racket + +'(hello-world) diff --git a/chapter10/graphics/dice1.png b/chapter10/graphics/dice1.png new file mode 100644 index 0000000..3f4899c Binary files /dev/null and b/chapter10/graphics/dice1.png differ diff --git a/chapter10/graphics/dice2.png b/chapter10/graphics/dice2.png new file mode 100644 index 0000000..2fa32ea Binary files /dev/null and b/chapter10/graphics/dice2.png differ diff --git a/chapter10/graphics/dice3.png b/chapter10/graphics/dice3.png new file mode 100644 index 0000000..005ee75 Binary files /dev/null and b/chapter10/graphics/dice3.png differ diff --git a/chapter10/graphics/dice4.png b/chapter10/graphics/dice4.png new file mode 100644 index 0000000..47bb291 Binary files /dev/null and b/chapter10/graphics/dice4.png differ diff --git a/chapter10/source.rkt b/chapter10/source.rkt new file mode 100644 index 0000000..a2b6a96 --- /dev/null +++ b/chapter10/source.rkt @@ -0,0 +1,1218 @@ +#lang racket + +#| + The Dice of Doom game, the eager version + ---------------------------------------- + + The Dice of Doom game is a turn-based game for two players sharing one keyboard. + Since this implementation employs an eager strategy to build the complete game + tree of all possible moves, it is only a step in the right direction. + + Each player owns hexagonal territories, which are arranged into a planar game + board. A territory comes with a number of dice. When it is a player's turn, + she marks one of her territories as a launching pad for an attack at a + neigboring territory of the other player. Such an attack is enabled only if + her chosen territory has more dice than the territory of the other player. + The effect of the attack is that the territory changes ownership and that all + but one of the attack dice are moved to the newly conquered territory. A + player may continue her turn as long as she can launch attacks. Optionally, + she may choose to pass after her first attack is executed, meaning she ends + her turn. At the end of a turn, a number of dices are distributed across the + players' territories. The game is over when a player whose turn it is cannot + attack on her first move. + + A player can use the following five keys to play the game: + -- with ← and → (arrow keys), the player changes the territory focus + -- with enter, the player marks a territory the launching pad for an attack + -- with the "d" key, the player unmarks a territory + -- with the "p" key the player passes. + Once a player passes, the game announces whose turn it is next. + + Play + ---- + + Run and evaluate + (roll-the-dice) + This will pop up a window that the game board, and instructions. +|# + +(require 2htdp/image (except-in 2htdp/universe left right)) + +; +; +; +; +; ;;;; ; ;;; ;;; ;; ;; +; ; ; ; ; ; ; +; ; ; ;;; ;;; ; ;;;; ; ; ;;;; ;; ;;; ; ;;; ; +; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; +; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; +; ;;;; ;;;;; ;;;; ;;;;; ; ; ;;;; ;;;;; ;;;;; ;;; ;; +; +; +; +; + +;; --------------------------------------------------------------------------------------------------- +;; Data + +(struct dice-world (src board gt) #:transparent) +;; DiceWorld = (dice-world (U #false Natural) Board GameTree) +;; in (dice-world i b gt) +;; -- if i is a Natural, it is an index for the territory that the player has marked for an attack +;; -- if i is #f, no territory has been marked yet +;; b is the current board +;; gt is the game-tree for the given i and b + +(struct game (board player moves) #:transparent) +;; GameTree = (game Board Player [Listof Move]) +;; in (game-tree b p lm) +;; -- b is the current board +;; -- p is the current player +;; -- lm is the list of moves that that player may execute + +;; Board = [List-of Territory] +;; the first field in the list is the currently marked territory + +;; Player ∈ [0, PLAYER#) | Natural + +(struct move (action gt) #:transparent) +;; Move = (move Action GameTree) +;; in (move a gt) +;; -- a represents the actione to be takem +;; -- gt is the game-tree resulting from that action + +;; Action is one of: +;; -- '() a passing move +;; -- (list Natural Natural) the move where the first attacks the second + +(struct territory (index player dice x y) #:transparent) +;; Territory = (territory Natural Player Dice Integer Integer) +;; in (territory i p d x y) +;; -- i is a unique identifier for the territory; it also determines its initial location +;; -- p is the player who owns this territory +;; -- d is the number of dice on this board +;; -- x is the x coordiate of this territory in pixels +;; -- y is the y coordiate of this territory in pixels + +;; Territory Natural -> Territory +;; updates number of dice on territory +(define (territory-set-dice t d) + (territory (territory-index t) (territory-player t) d (territory-x t) (territory-y t))) + +;; Territory Player -> Territory +;; updates owner of territory +(define (territory-set-player t p) + (territory (territory-index t) p (territory-dice t) (territory-x t) (territory-y t))) + +;; --------------------------------------------------------------------------------------------------- +;; sample game tree for BOOK + +(define b1 + (list (territory 1 0 1 'a 'b) + (territory 0 0 1 'x 'y))) + +(define b1-alternative + (list (territory 0 0 1 'x 'y) + (territory 1 0 1 'a 'b))) + +(define b3 + (list (territory 0 0 2 'x 'y) + (territory 1 1 1 'a 'b))) + +(define gt1 (game b1 1 '())) + +(define mv2 (move '() gt1)) + +(define gt2 (game b1-alternative 0 (list mv2))) + +(define mv3 (move '(0 1) gt2)) + +(define gt3 (game b3 0 (list mv3))) + +;; --------------------------------------------------------------------------------------------------- +;; Constants + +; initalization constants +(define PLAYER# 2) +(define DICE# 3) +(define BOARD 2) +(define GRID (* BOARD BOARD)) +(define INIT-PLAYER 0) +(define INIT-SPARE-DICE 10) +; The depth at which to limit the gametree +(define AI-DEPTH 4) +(define AI 1) + +; graphical constants: territories +(define DICE-OFFSET 6) +(define SIDE 75) +(define OFFSET0 (* 2 SIDE)) +(define ROTATION 30) +(define HEX 6) +(define (hexagon color) + (rotate ROTATION (regular-polygon SIDE HEX "solid" color))) +(define X-OFFSET (image-width (hexagon "black"))) +(define Y-OFFSET (* (image-height (hexagon "black")) 3/4)) + +; graphical constants +(define COLORS + (list (make-color 255 0 0 100) + (make-color 0 255 0 100) + (make-color 0 0 255 100))) +(define FOCUS (rotate ROTATION (regular-polygon SIDE 6 "outline" "black"))) +(define D1 (bitmap "graphics/dice1.png")) +(define D2 (bitmap "graphics/dice2.png")) +(define D3 (bitmap "graphics/dice3.png")) +(define D4 (bitmap "graphics/dice4.png")) +(define IMG-LIST (list D1 D2 D3 D4)) + +(define TEXT-SIZE 25) +(define TEXT-COLOR "black") +(define INSTRUCT + "← and → to move among territories, to mark, to unmark, and

to pass") +(define AI-TURN "It's the Mighty AI's turn") +(define YOUR-TURN "It's your turn") +(define INFO-X-OFFSET 100) +(define INFO-Y-OFFSET 50) + +(define INSTRUCTIONS (text INSTRUCT TEXT-SIZE TEXT-COLOR)) +(define WIDTH (+ (image-width INSTRUCTIONS) 50)) +(define HEIGHT 600) +(define (PLAIN) + (define iw (image-width INSTRUCTIONS)) + (define bw (* SIDE 2 BOARD)) + (set! WIDTH (+ (max iw bw) 50)) + (set! HEIGHT (+ (* SIDE 2 BOARD) 50)) + (empty-scene WIDTH HEIGHT)) +(define (ISCENE) + (define mt (PLAIN)) + (when (or (> (image-width mt) 1280) (> (image-height mt) 800)) + (error 'scene "it is impossible to draw a ~s x ~s game scene for a 1280 x 800 laptop screen" (image-width mt) (image-height mt))) + (place-image INSTRUCTIONS (* .5 WIDTH) (* .9 HEIGHT) mt)) + +; +; +; +; +; ;;; ;;; ; +; ;; ;; +; ;; ;; ;;;; ;;; ;; ;; +; ; ; ; ; ; ; ;; ; +; ; ; ; ;;;;; ; ; ; +; ; ; ; ; ; ; ; +; ; ; ; ;; ; ; ; +; ;;; ;;; ;;; ;; ;;;;; ;;; ;;; +; +; +; +; + +;; --------------------------------------------------------------------------------------------------- + +;; start the game +(define (roll-the-dice) + (big-bang (create-world-of-dice-and-doom) + (on-key interact-with-board) + (to-draw draw-dice-world) + (stop-when no-more-moves-in-world? + draw-end-of-dice-world))) + +;; -> DiceWorld +;; Returns a randomly generated world. If the world that +;; has been generated starts as a tie, the world is regenerated. +;; property: world is not in endgame state (no-more-moves? returns false) +(define (create-world-of-dice-and-doom) + (define board (territory-build)) + (define gamet (game-tree board INIT-PLAYER INIT-SPARE-DICE)) + (define new-world (dice-world #f board gamet)) + (if (no-more-moves-in-world? new-world) + (create-world-of-dice-and-doom) + new-world)) + +;; DiceWorld Key -> DiceWorld +;; Handles key events from a player +(define (interact-with-board w k) + (cond [(key=? "left" k) + (refocus-board w left)] + [(key=? "right" k) + (refocus-board w right)] + [(key=? "p" k) + (pass w)] + [(key=? "\r" k) + (mark w)] + [(key=? "d" k) + (unmark w)] + [else w])) + +;; Diceworld -> Scene +;; draws the world +(define (draw-dice-world w) + (add-player-info + (game-player (dice-world-gt w)) + (add-winning-probability w (add-board-to-scene w (ISCENE))))) + +;; DiceWorld -> Boolean +;; is it possible to play any moves from this world state? +(define (no-more-moves-in-world? w) + (define tree (dice-world-gt w)) + (define board (dice-world-board w)) + (define player (game-player tree)) + (or (no-more-moves? tree) + (for/and ((t board)) (= (territory-player t) player)))) + +;; DiceWorld -> Image +;; render the endgame screen +(define (draw-end-of-dice-world w) + (define board (dice-world-board w)) + (define message (text (won board) TEXT-SIZE TEXT-COLOR)) + (define background (add-board-to-scene w (PLAIN))) + (overlay message background)) + +;; Board -> String +;; Which player has won the game -- eager is for N human players +(define (won board) + (define-values (best-score w) (winners board)) + (if (cons? (rest w)) "It's a tie." "You won.")) + +; +; +; +; +; ;;;;; ; +; ; ; +; ; ;; ;; ;;; ;;;;; +; ; ;; ; ; ; +; ; ; ; ; ; +; ; ; ; ; ; +; ; ; ; ; ; ; +; ;;;;; ;;; ;;; ;;;;; ;;; +; +; +; +; + +;; --------------------------------------------------------------------------------------------------- +;; Making A Board + +;; -> Board +;; Creates a list of territories the size of GRID with given x and y coordinates +;; properties: dice is (0,MAX-DICE] +;; returns list of size GRID +(define (territory-build) + (for/list ([n (in-range GRID)]) + (territory n (modulo n PLAYER#) (dice) (get-x n) (get-y n)))) + +;; -> Natural +;; the number of initial die on a territory +(define (dice) + (add1 (random DICE#))) + +;; Natural -> Number +;; the x coordinate for territory n of a board +(define (get-x n) + (+ OFFSET0 + (if (odd? (get-row n)) 0 (/ X-OFFSET 2)) + (* X-OFFSET (modulo n BOARD)))) + +;; Natural -> Number +;; the y coordinate for territory n of a board +(define (get-y n) + (+ OFFSET0 (* Y-OFFSET (get-row n)))) + +;; --------------------------------------------------------------------------------------------------- +;; Making a Game Tree + +;; Board Player Natural -> GameTree +;; creates a complete game-tree from the given board, player, and spare dice +(define (game-tree board player dice) + ;; create tree of attacks from this position; add passing move + (define (attacks board) + (for*/list ([src board] + [dst (neighbors (territory-index src))] + #:when (attackable? board player src dst)) + (define from (territory-index src)) + (define dice (territory-dice src)) + (define newb (execute board player from dst dice)) + (define attacks-from-newb + (game newb player (cons (passes newb) (attacks newb)))) + (move (list from dst) attacks-from-newb))) + ;; create a passing move , distribute dice, continue + (define (passes board) + (define-values (new-dice newb) (distribute board player dice)) + (move '() (game-tree newb (switch player) new-dice))) + ;; -- START: -- + (game board player (attacks board))) + +;; Player -> Player +;; switches from one player to the next +(define (switch player) + (modulo (+ player 1) PLAYER#)) + +;; Board Player Natural -> Natural Board +;; adds reinforcements to the game board +;; > (add-new-dice (list (territory 0 2 2 9 0)) 2 2)) +;; (list (territory 0 2 2 9 0)) +(define (distribute board player spare-dice) + (for/fold ([dice spare-dice] [new-board '()]) ([t board]) + (if (and (= (territory-player t) player) + (< (territory-dice t) DICE#) + (not (zero? dice))) + (values (- dice 1) (cons (add-dice-to t) new-board)) + (values dice (cons t new-board))))) + +;; Territory -> Territory +;; adds one dice to the given territory +(define (add-dice-to t) + (territory-set-dice t (add1 (territory-dice t)))) + +;; Board Player Territory Natural -> Boolean +;; can player attack dst from src? +(define (attackable? board player src dst) + (define dst-t + (findf (lambda (t) (= (territory-index t) dst)) board)) + (and dst-t + (= (territory-player src) player) + (not (= (territory-player dst-t) player)) + (> (territory-dice src) (territory-dice dst-t)))) + +;; Board Natural Natural Natural Natural -> Board +;; Creates a new board after an attack +;; updates only src and dst +(define (execute board player src dst dice) + (for/list ([t board]) + (define idx (territory-index t)) + (cond [(= idx src) (territory-set-dice t 1)] + [(= idx dst) + (define s (territory-set-dice t (- dice 1))) + (territory-set-player s player)] + [else t]))) + +;; --------------------------------------------------------------------------------------------------- +;; Getting Neigbors + +;; Natural -> [List-of Natural] +;; returns the neighbors of the current spot +;; > (neighbors 0) +;; '(1 2 3) +(define (neighbors pos) + (define top? (< pos BOARD)) + (define bottom? (= (get-row pos) (sub1 BOARD))) + (define even-row? (zero? (modulo (get-row pos) 2))) + (define right? (zero? (modulo (add1 pos) BOARD))) + (define left? (zero? (modulo pos BOARD))) + (if even-row? + (even-row pos top? bottom? right? left?) + (odd-row pos top? bottom? right? left?))) + +;; Natural Boolean Boolean Boolean Boolean -> [Listof Naturals] +;; gets the neighbors for a territory on an even row +(define (even-row pos top? bottom? right? left?) + (append (add (or top? right?) (add1 (- pos BOARD))) + (add (or bottom? right?) (add1 (+ pos BOARD))) + (add top? (- pos BOARD)) + (add bottom? (+ pos BOARD)) + (add right? (add1 pos)) + (add left? (sub1 pos)))) + +;; Natural Boolean Boolean Boolean Boolean -> [Listof Naturals] +;; gets the neighbors for a territory on an odd row +(define (odd-row pos top? bottom? right? left?) + (append (add top? (- pos BOARD)) + (add bottom? (+ pos BOARD)) + (add (or top? left?) (sub1 (- pos BOARD))) + (add (or bottom? left?) (sub1 (+ pos BOARD))) + (add right? (add1 pos)) + (add left? (sub1 pos)))) + +;; Boolean X -> [Listof X] +;; returns (list x) if (not b) else empty +(define (add b x) + (if b '() (list x))) + +; +; +; +; +; ;;; ;;; ;;;;;; +; ; ; ; ; ; +; ; ; ;;;; ;;; ;;; ; ; ;;; ;;; ;;;; ;; ;; ;;;;; ;;;;; +; ; ; ; ; ; ; ;;; ; ; ; ; ;; ; ; ; ; +; ;;; ;;;;;; ; ; ; ; ; ; ;;;;;; ; ; ; ;;;; +; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; +; ;;; ;; ;;;;; ; ;;;;;; ;; ;;;;; ;;; ;;; ;;; ;;;;; +; ; +; ;;; +; +; + +;; --------------------------------------------------------------------------------------------------- +;; Territory Focusing and Marking + +;; DiceWorld [Board -> Board] -> World +;; Creates a new World that has a rotated territory list +;; > (define lterritory (territory 0 0 1 9 2)) +;; > (define rterritory (territory 0 0 1 9 0)) +;; > (refocus-board-action (dice-world -1 (list rterritory lterritory ...) GT) left) +;; (dice-world -1 (list lterritory ... rterritory) GT) +;; > (refocus-board-action (dice-world -1 (list lterritory ... rterritory) GT) left) +;; (dice-world -1 (list rterritory lterritory ...) GT) +(define (refocus-board w direction) + (define source (dice-world-src w)) + (define board (dice-world-board w)) + (define tree (dice-world-gt w)) + (define player (game-player tree)) + (define (owner? tid) + (if source (not (= tid player)) (= tid player))) + (define new-board (rotate-until owner? board direction)) + (dice-world source new-board tree)) + +;; [Player -> Boolean] Board (Board -> Board) -> Board +;; rotate until the first element of the list satisfies owned-by +(define (rotate-until owned-by board rotate) + (define next-list (rotate board)) + (if (owned-by (territory-player (first next-list))) + next-list + (rotate-until owned-by next-list rotate))) + +;; Board -> Board +;; rotate a list to the left +(define (left l) + (append (rest l) (list (first l)))) + +;; Board -> Board +;; rotate a list to the right +(define (right l) + (reverse (left (reverse l)))) + +;; --------------------------------------------------------------------------------------------------- +;; Handling Moves + +;; DiceWorld -> DiceWorld +;; executes a passing move on the world state +;; THIS DEFINITION IS NOT USED FOR THE ABSTRACT VERSION OF THE MODULE. +(define (pass.10 w) + (define m (find-move (game-moves (dice-world-gt w)) '())) + (cond [(not m) w] + [else ;; (no-more-moves? m) + (dice-world #f (game-board m) m)])) + +;; DiceWorld -> DiceWorld +;; unmarks a marked territory +(define (unmark w) + (dice-world #f (dice-world-board w) (dice-world-gt w))) + +;; DiceWorld -> DiceWorld +;; marks a territory as the launching pad for an attack or launches the attack +(define (mark w) + (define tree (dice-world-gt w)) + (define board (dice-world-board w)) + (define source (dice-world-src w)) + (define focus (territory-index (first board))) + (if source + (attacking w source focus) + (dice-world focus board tree))) + +;; DiceWorld Natural Natural -> DiceWorld +(define (attacking w source target) + (define feasible (game-moves (dice-world-gt w))) + (define attack (list source target)) + (define next (find-move feasible attack)) + (define src-t (findf (lambda (t) (= (territory-index t) source)) + (dice-world-board w))) + (define dst-t (findf (lambda (t) (= (territory-index t) target)) + (dice-world-board w))) + (define win? (dice-attack-win src-t dst-t)) + (cond [(not next) w] + [win? (dice-world #f (game-board next) next)] + [else (dice-world-attack-lost w src-t)])) + +;; [List-of Moves] [or '() [List Natural Natural]] -> [or #f Game-tree] +;; find the move from the current list of moves +(define (find-move moves a) + (define m (findf (lambda (m) (equal? (move-action m) a)) moves)) + (and m (move-gt m))) + +;; Game -> Boolean +;; are there any moves in this game record? +(define (no-more-moves? g) + (empty? (game-moves g))) + +;; Territory Territory -> Boolean +;; attack from src territory to destination territory +;; and see who wins +(define (dice-attack-win src-t dst-t) + (define (roll-dice n) + (for/list ([i n]) + (random 1 7))) + (define (sum l) + (foldl + 0 l)) + (define src-attack (sum (roll-dice (territory-dice src-t)))) + (define dst-defend (sum (roll-dice (territory-dice dst-t)))) + (if (> src-attack dst-defend) #t #f)) + + +(define (probability-of-winning st dt) + "Find the probability of source territory defeating destination territory. + + `st` is the source territory. + `dt` is the destination territory." + + ; Given the number of dice, returns a list all dice combinations. + (define (dice-all-combination dice-num) + (cond [(= dice-num 1) + (for/list ([i (in-range 1 7)]) + (list i))] + [else + (for*/list ([i (in-range 1 7)] + [r (dice-all-combination + (- dice-num 1))]) + (cons i r))])) + + + ; Given a list of dice combinations, returns a hashmap where the key + ; is the 'dice sum' and the value is the number of combinations + ; whose sum is the 'dice sum'. + (define (dice-sum-hash dice-combinations) + (for/foldr + ([h (make-hash)]) ([c dice-combinations]) + (let ((sum (for/sum ([n c]) n))) + (hash-set! h sum (+ (hash-ref h sum 0) 1)) + h))) + + + ; sh: -> hashmap + ; key: dice sum, + ; value: number of ways we can arrive at sum + (define sh (dice-sum-hash + (dice-all-combination (territory-dice st)))) + + ; dh: -> hashmap + ; key: dice sum, + ; value: number of ways we can arrive at sum + (define dh (dice-sum-hash + (dice-all-combination (territory-dice dt)))) + + ; Generic probability function. + (define (probability f t) + (/ (* 1.0 f) t)) + + ; Computes the total number of favorable outcomes for the source + ; territory when its dice sum is `s-ds` against the + ; destination's territory. + ; + ; s-ds -> source dice sum. + ; n -> number of we can arrive at sum `s-ds`. + (define (favorable-outcomes s-ds n) + (* (for/sum [(d-ds (hash-keys dh))] + (if (< d-ds s-ds) + (hash-ref dh d-ds) + 0)) + n)) + + ; Computes the total number of favorable outcomes for the source + ; territory against the destination's territory. + (define (all-favorable-outcomes) + (foldr + 0 + (for/list [(s-ds (hash-keys sh))] + (favorable-outcomes + s-ds + (hash-ref sh s-ds))))) + + (define (all-outcomes) + (let ((sd (territory-dice st)) + (dd (territory-dice dt))) + (* (expt 6 sd) (expt 6 dd)))) + + (probability (all-favorable-outcomes) (all-outcomes))) + + +;; DiceWorld Territory -> DiceWorld +;; generate dice world for the case where player +;; loses the dice attack +(define (dice-world-attack-lost w src-t) + (define src (territory-index src-t)) + (define player (territory-player src-t)) + (define newb (for/list ([t (dice-world-board w)]) + (define idx (territory-index t)) + (cond [(= idx src) (territory-set-dice t 1)] + [else t]))) + (define new-gt (game-tree newb player 0)) + (dice-world #f newb new-gt)) + +; +; +; +; +; ;;;;; ;; ; +; ; ; ; +; ; ; ;;;; ;; ;; ;;; ; ;;;; ;; ;;; ;;; ;; ;; ;;; ;; +; ; ; ; ; ;; ; ; ;; ; ; ;; ; ;; ; ; ;; +; ;;;; ;;;;;; ; ; ; ; ;;;;;; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; +; ;;; ; ;;;;; ;;; ;;; ;;; ;; ;;;;; ;;;;; ;;;;; ;;; ;;; ;;; ; +; ; +; ;;;; +; +; + +;; Player Scene-> Scene +;; Draws the world +(define (add-player-info player s) + (define str (whose-turn player)) + (define txt (text str TEXT-SIZE TEXT-COLOR)) + (place-image txt (- WIDTH INFO-X-OFFSET) INFO-Y-OFFSET s)) + +(define (add-winning-probability w s) + (define board (dice-world-board w)) + (define source (dice-world-src w)) + (define target (territory-index (first board))) + (define feasible (game-moves (dice-world-gt w))) + (define attack (list source target)) + (define next (find-move feasible attack)) + + (define (find-territory index) + (findf (lambda (t) (= (territory-index t) index)) + (dice-world-board w))) + + (if (and source next) + (place-image + (text (string-append + "Winning Probability " + (~r + (probability-of-winning (find-territory source) + (find-territory target)) + #:precision 2)) + TEXT-SIZE TEXT-COLOR) + (- WIDTH 150) 100 s) + s)) + +;; DiceWorld Scene -> Scene +;; folds through the board and creates an image representation of it +(define (add-board-to-scene w s) + (define board (dice-world-board w)) + (define player (game-player (dice-world-gt w))) + (define focus? (dice-world-src w)) + (define trtry1 (first board)) + (define p-focus (territory-player trtry1)) + (define t-image (draw-territory trtry1)) + (define image (draw-focus focus? p-focus player t-image)) + (define base-s (add-territory trtry1 image s)) + (for/fold ([s base-s]) ([t (rest board)]) + (add-territory t (draw-territory t) s))) + +;; Nat Player Player Image -> Image +;; add focus marker to territory if needed +(define (draw-focus marked? p-in-focus p t-image) + (if (or (and (not marked?) (= p-in-focus p)) + (and marked? (not (= p-in-focus p)))) + (overlay FOCUS t-image) + t-image)) + +;; Image Territory Image -> Image +(define (add-territory t image scene) + (place-image image (territory-x t) (territory-y t) scene)) + +;; Territory -> Image +;; renders a single territory +(define (draw-territory t) + (define color (color-chooser (territory-player t))) + (overlay (hexagon color) (draw-dice (territory-dice t)))) + +;; Natural -> Image +;; renders all n >= 1 dice as a stack of dice +(define (draw-dice n) + (define first-die (get-dice-image 0)) + (define height-die (image-height first-die)) + (for/fold ([s first-die]) ([i (- n 1)]) + (define dice-image (get-dice-image (+ i 1))) + (define y-offset (* height-die (+ .5 (* i .25)))) + (overlay/offset s 0 y-offset dice-image))) + +;; Player -> Color +;; Determines a color for each player +(define (color-chooser p) + (list-ref COLORS p)) + +;; -> Image +;; returns an image from the list of dice images +(define (get-dice-image i) + (list-ref IMG-LIST (modulo i (length IMG-LIST)))) + +; +; +; +; +; ;;;;;; ;; ; +; ; ; ; +; ; ; ;; ;; ;;; ; ;;; ;; ;; ;;; ;; +; ;;; ;; ; ; ;; ; ;; ; ; ;; +; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ;; ; ; ; ; ;; +; ;;;;;; ;;; ;;; ;;; ;; ;;;;; ;;; ;;; ;;; ; +; ; +; ;;;; +; +; + +;; Board ->* Natural [non-empty-listof Player] +;; gives the number of winning territories and the players(s) who have them +;; > (winners (list (territory 0 0 1 9 0) (territory 0 0 1 9 1))) +;; (values 2 '(0)) +;; > (winners (list (territory 0 1 1 9 0) (territory 0 0 1 9 1))) +;; (values 1 '(0 1)) +(define (winners board) + (for/fold ([best 0][winners '()]) ([p PLAYER#]) + (define p-score (sum-territory board p)) + (cond [(> p-score best) (values p-score (list p))] + [(< p-score best) (values best winners)] + [(= p-score best) (values best (cons p winners))]))) + +;; Board Player -> Natural +;; counts the number of territorys the player owns +;; > (sum-territory (list (territory 0 1 1 9 0) (territory 0 1 1 9 1)) 1) +;; 2 +(define (sum-territory board player) + (for/fold ([result 0]) ([t board]) + (if (= (territory-player t) player) (+ result 1) result))) + + +; +; +; +; +; +; ;;; ;;;;;;; +; ;; ; +; ; ; ; +; ; ; ; +; ; ; ; +; ;;;;;; ; +; ; ; ; +; ; ; ; +; ;;; ;;; ;;;;;;; +; +; +; +; + +;; Player -> {AI-TURN, YOUR-TURN} +;; THIS REQUIRES A DIFFERENT DEFINITION FOR PLAIN CHAPTER 10. +(define (whose-turn player) + (if (= player AI) AI-TURN YOUR-TURN)) + +;; DiceWorld -> DiceWorld +;; executes a passing move on the world state +;; THIS REQUIRES A DIFFERENT DEFINITION FOR PLAIN CHAPTER 10. +(define (pass w) + (define m (find-move (game-moves (dice-world-gt w)) '())) + (cond [(not m) w] + [(or (no-more-moves? m) (not (= (game-player m) AI))) + (dice-world #f (game-board m) m)] + [else + (define ai (the-ai-plays m)) + (dice-world #f (game-board ai) ai)])) + +;; GameTree -> GameTree +;; Computer calls this function until it is no longer the player +(define (the-ai-plays tree) + (define ratings (rate-moves tree AI-DEPTH)) + (define the-move (first (argmax second ratings))) + (define new-tree (move-gt the-move)) + (if (= (game-player new-tree) AI) + (the-ai-plays new-tree) + new-tree)) + +;; GameTree Natural -> [List-of (List Move Number)] +;; assigns a value to each move that is being considered +;; and return those values in a list +(define (rate-moves tree depth) + (for/list ((move (game-moves tree))) + (list move (rate-position (move-gt move) (- depth 1))))) + +;; GameTree Natural -> Number +;; Returns a number that is the best move for the given player. +(define (rate-position tree depth) + (cond [(or (= depth 0) (no-more-moves? tree)) + (define-values (best w) (winners (game-board tree))) + (if (member AI w) (/ 1 (length w)) 0)] + [else + (define ratings (rate-moves tree depth)) + (apply (if (= (game-player tree) AI) max min) + (map second ratings))])) + +; +; +; +; +; ;; +; ; +; ; ; ;; ;; ;; ;; ;;;;; +; ; ; ; ; ; ; ; ; +; ; ; ; ; ;; ;;;; +; ;;; ; ; ;; ; +; ; ; ; ;; ; ; ; ; +; ;;; ;;; ;; ;; ;; ;; ;;;;; +; +; +; +; + +;; Natural -> Natural +;; gets the row that territory is on, indexed from 0 +;; [test vary on current board-size] +(define (get-row pos) + (quotient pos BOARD)) + + +; +; +; +; +; +; ;;;;;;; ; +; ; ; ; ; +; ; ; ; ;;; ;;;; ; ;;;;;; ;;;; ; +; ; ; ; ; ; ; ;; ; ; ;; +; ; ; ; ; ; ; +; ; ;;;;;;; ;;;;; ; ;;;;; +; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; +; ;;;;; ;;;; ;;;;;; ;;;; ;;;;;; +; +; +; +; + +;; --------------------------------------------------------------------------------------------------- + +;; Natural -> Void +;; make the board larger +(define (set-grid n) + (set! BOARD n) + (set! GRID (* n n))) + +(module+ test + + (require rackunit rackunit/text-ui) + + ;; (-> any) -> void + ;; runs the thunk PROP-NUM times + (define (check-property t) + (test-begin (for ((i 50)) (t)))) + + ;; Properties + (define (property:starting-world-playable) + (unless (and (= BOARD 2) (= PLAYER# 2)) + (error 'starting-world-playable "BOARD-SIZE != 2 or PLAYERS# != 2")) + (check-false (no-more-moves-in-world? (create-world-of-dice-and-doom)))) + + (define (property:dice-in-range) + (check-true (andmap (λ (b) (>= DICE# (territory-dice b) 1)) (territory-build)) + "dice out of range")) + + (define (property:board-correct-size) + (check-equal? (length (territory-build)) GRID + "board incorrect-size")) + + (define (property:no-pass-on-first-move) + (define (move-action? m) (equal? (move-action m) '())) + (check-true (not (memf move-action? (game-moves (game-tree (territory-build) 0 0)))) + "no pass on first move")) + + ;; --------------------------------------------------------------------------------------------------- + + + ;; testing game initialization + + (check-equal? (territory-index (first (territory-build))) 0) + (check-equal? (territory-player (first (territory-build))) 0) + (check-equal? (territory-index (second (territory-build))) 1) + (check-equal? (territory-player (second (territory-build))) 1) + (check-equal? (territory-index (third (territory-build))) 2) + (check-equal? (territory-player (third (territory-build))) 0) + (check-equal? (territory-index (fourth (territory-build))) 3) + (check-equal? (territory-player (fourth (territory-build))) 1) + + (check-property property:starting-world-playable) + (check-property property:board-correct-size) + (check-property property:dice-in-range) + (check-property property:no-pass-on-first-move) + + ;; --------------------------------------------------------------------------------------------------- + ;; testing territory manipulation + + ;; legal? + (check-true + (and (attackable? (list (territory 0 0 2 9 0) (territory 3 1 1 9 0)) 0 (territory 0 0 2 9 0) 3) #t)) + (check-false + (attackable? (list (territory 0 0 2 9 0) (territory 3 1 1 9 0)) 0 (territory 0 0 2 9 0) 0)) + (check-false + (attackable? (list (territory 0 0 2 9 0) (territory 5 1 1 9 0)) 1 (territory 0 0 2 9 0) 5)) + + ;; get-row + (check-equal? (get-row 0) 0) + (check-equal? (get-row 1) 0) + (check-equal? (get-row 2) 1) + (check-equal? (get-row 3) 1) + (check-equal? (get-row 12) 6) ;; checks math. actually invalid on board of size 2 + (check-equal? (get-row 11) 5) ;; checks math. actually invalid on board of size 2 + (check-equal? (get-row 13) 6) ;; checks math. actually invalid on board of size 2 + (check-equal? (get-row 14) 7) ;; checks math. actually invalid on board of size 2 + + ;; --------------------------------------------------------------------------------------------------- + (define board3 + (list (territory 0 1 1 9 0) (territory 1 1 1 8 0) (territory 2 1 3 43.5 5) (territory 3 1 1 6 5))) + (define b1+0+3 + (list (territory 0 0 2 9 0) (territory 1 1 1 8 0) (territory 2 0 2 43.5 5) (territory 3 1 1 6 5))) + (define b2+1+2 + (list (territory 0 0 1 9 0) (territory 1 1 3 8 0) (territory 2 0 2 43.5 5) (territory 3 1 2 6 5))) + (define board6 + (list (territory 0 0 1 9 0) (territory 1 1 2 8 0) (territory 2 0 3 43.5 5) (territory 3 1 2 6 5))) + (define bard6+ + (list (territory 0 0 1 9 0) (territory 1 1 2 8 0) (territory 2 0 3 43.5 5) (territory 3 1 2 6 5))) + + (define (distribute/list a b c) + (define-values (x y) (distribute a b c)) + (list x y)) + + (define board0 + (list (territory 0 0 1 9 0) (territory 1 1 2 8 0) (territory 2 0 2 43.5 5) (territory 3 1 1 6 5))) + (define board1 + (list (territory 0 0 1 9 0) (territory 1 1 1 8 0) (territory 2 0 1 43.5 5) (territory 3 1 1 6 5))) + (define b1+1+2 + (list (territory 0 0 1 9 0) (territory 1 1 2 8 0) (territory 2 0 1 43.5 5) (territory 3 1 2 6 5))) + (define board2 + (list (territory 0 0 1 9 0) (territory 1 1 1 8 0) (territory 2 0 3 43.5 5) (territory 3 1 1 6 5))) + + (define g-tree1 (game board1 0 '())) + (define g-tree2 (game-tree board0 0 0)) + + ; (define world31 (dice-world #f board1 g-tree1)) + (define world2 (dice-world #f board2 g-tree2)) + + ;; testing book tree + + (check-equal? (game-tree (list (territory 0 0 2 'x 'y) + (territory 1 1 1 'a 'b)) + 0 + 0) + gt3) + + + ;; testing tree generation + + (define (property:attack-location-valid) + (define moves (game-moves (game-tree (territory-build) 0 0))) + (check-true (and (for/and ([m moves]) + (define m1 (move-action m)) + (member (second m1) (neighbors (first m1)))) + #t) + "invalid attack location")) + + (define (property:add-to-territory-always-up-one) + (define r (random 10000)) + (check-equal? (add-dice-to (territory 0 0 r 0 0)) + (territory 0 0 (add1 r) 0 0) + "add to territory always up one")) + + (define (property:attackable?-does-not-need-neighbores-check) + (define (check-attackable? gt) + (for/and ([move (game-moves gt)] + #:when (not (empty? (move-action move)))) + (define action (move-action move)) + (define gt (move-gt move)) + (and (member (second action) (neighbors (first action))) + (check-attackable? gt)))) + + ;;start + (define old-size BOARD) + (set-grid 2) + (define testing-gt (dice-world-gt (create-world-of-dice-and-doom))) + (check-true (check-attackable? testing-gt) "An attack move between non-neighbores was created") + (set-grid old-size)) + + + ;; game-tree + (check-equal? (game-tree board1 0 0) g-tree1) + (check-equal? (game-tree board3 1 0) (game board3 1 '())) + (check-equal? (game-tree board3 0 0) (game board3 0 '())) + (check-property property:attackable?-does-not-need-neighbores-check) + + ;; find-move + (check-false (find-move '() '())) + (check-equal? (find-move (list (move '() (game '() 0 '()))) '()) (game '() 0 '())) + ;; Attacking-Moves + (check-property property:attack-location-valid) + + ;; switch-players + (check-equal? (switch 0) 1) + (check-equal? (switch 1) 0) + + ;; Add-New-Dice + (check-equal? (distribute/list (game-board g-tree1) 0 3) (list 1 (reverse b1+0+3))) + (check-equal? (distribute/list (game-board g-tree1) 1 2) (list 0 (reverse b1+1+2))) + (check-equal? (distribute/list (game-board g-tree2) 1 2) (list 0 (reverse b2+1+2))) + (check-equal? (distribute/list board6 0 0) (list 0 (reverse bard6+))) + + ;; add-to-territory + (check-equal? (add-dice-to (territory 0 1 2 9 0)) (territory 0 1 3 9 0)) + (check-equal? (add-dice-to (territory 0 1 1 9 0)) (territory 0 1 2 9 0)) + (check-equal? (add-dice-to (territory 0 1 5 9 0)) (territory 0 1 6 9 0)) + (check-property property:add-to-territory-always-up-one) + + ;; --------------------------------------------------------------------------------------------------- + (define board7 + (list (territory 0 0 1 9 0) (territory 1 1 1 8 0) (territory 2 0 2 43.5 5) (territory 3 1 1 6 5))) + (define board8 + (list (territory 0 1 1 9 0) (territory 1 1 1 8 0) (territory 2 0 3 43.5 5) (territory 3 1 1 6 5))) + (define board9 + (list (territory 0 0 1 9 0) (territory 1 1 1 8 0) (territory 2 0 2 43.5 5) (territory 3 0 1 6 5))) + (define board10 + (list (territory 0 0 1 9 0) (territory 1 1 3 8 0) (territory 2 0 2 43.5 5) (territory 3 1 1 6 5))) + + ;; testing attacks + + (check-equal? + (execute board7 0 2 1 2) + (list (territory 0 0 1 9 0) (territory 1 0 1 8 0) (territory 2 0 1 43.5 5) (territory 3 1 1 6 5))) + + (check-equal? + (execute board8 0 2 1 3) + (list (territory 0 1 1 9 0) (territory 1 0 2 8 0) (territory 2 0 1 43.5 5) (territory 3 1 1 6 5))) + + (check-equal? + (execute board9 0 2 1 2) + (list (territory 0 0 1 9 0) (territory 1 0 1 8 0) (territory 2 0 1 43.5 5) (territory 3 0 1 6 5))) + + (check-equal? + (execute board10 1 1 0 3) + (list(territory 0 1 2 9 0) (territory 1 1 1 8 0) (territory 2 0 2 43.5 5) (territory 3 1 1 6 5))) + + ;; Neighbors + (check-equal? (neighbors 2) '(0 3)) + (check-equal? (neighbors 0) '(3 2 1)) + (check-equal? (neighbors 1) '(3 0)) + (check-equal? (neighbors 3) '(1 0 2)) + + ;; --------------------------------------------------------------------------------------------------- + (define board20 + (list (territory 0 0 1 9 2) (territory 1 0 1 9 0) (territory 2 2 1 9 0))) + (define board21 + (list (territory 0 1 1 9 0) (territory 1 1 1 8 0) (territory 2 1 1 43.5 5) (territory 3 1 1 6 5))) + + ;; testing focus manipulation + ;; interact-with-board + (check-equal? + (interact-with-board world2 "\r") + (dice-world (territory-index (car (dice-world-board world2))) (dice-world-board world2) g-tree2)) + + (check-equal? (interact-with-board world2 "p") world2) + + ;; refocus-board-action + (check-equal? + (refocus-board (dice-world #f (list (territory 0 0 1 9 0) (territory 0 0 1 9 2)) g-tree1) left) + (dice-world #f (list (territory 0 0 1 9 2) (territory 0 0 1 9 0)) g-tree1)) + + (check-equal? + (refocus-board (dice-world #f (list (territory 0 0 1 9 2) (territory 0 1 1 9 0)) g-tree1) right) + (dice-world #f (list (territory 0 0 1 9 2) (territory 0 1 1 9 0)) g-tree1)) + + (check-equal? + (refocus-board (dice-world 0 board20 g-tree1) left) + (dice-world 0 (list (territory 2 2 1 9 0) (territory 0 0 1 9 2) (territory 1 0 1 9 0)) g-tree1)) + + (check-equal? + (refocus-board (dice-world 0 (list (territory 0 0 1 9 2) (territory 0 1 1 9 0)) g-tree1) left) + (dice-world 0 (list (territory 0 1 1 9 0) (territory 0 0 1 9 2)) g-tree1)) + + (check-equal? + (refocus-board (dice-world 0 (list(territory 0 0 1 9 2) (territory 0 1 1 9 0)) g-tree1) right) + (dice-world 0 (list (territory 0 1 1 9 0) (territory 0 0 1 9 2)) g-tree1)) + + ;;unmark + (check-equal? (unmark (dice-world 1 board21 g-tree1)) (dice-world #f board21 g-tree1)) + + (check-equal? (unmark (dice-world 1 (list (territory 0 1 1 9 0) (territory 1 1 1 8 0)) g-tree1)) + (dice-world #f (list (territory 0 1 1 9 0) (territory 1 1 1 8 0)) g-tree1)) + (check-equal? (unmark (dice-world 0 (list (territory 0 1 1 9 0)) g-tree1)) + (dice-world #f (list (territory 0 1 1 9 0)) g-tree1)) + (check-equal? (unmark (dice-world #f (list (territory 0 1 1 9 0)) g-tree1)) + (dice-world #f (list (territory 0 1 1 9 0)) g-tree1)) + + ;; --------------------------------------------------------------------------------------------------- + (define (winners/list w) + (define-values (a b) (winners w)) + (cons a b)) + + ;; testing functions that determine 'winning' and declare the winner + + ;; winners + (check-equal? (winners/list (list (territory 0 0 1 9 0) (territory 0 0 1 9 1))) (list 2 0)) + (check-equal? (winners/list (list (territory 0 1 1 9 0) (territory 0 0 1 9 1))) (list 1 1 0)) + + ;; sum-territory + (check-equal? (sum-territory (list (territory 0 0 1 9 0) (territory 0 0 1 9 1)) 0) 2) + (check-equal? (sum-territory (list (territory 0 0 1 9 0) (territory 0 0 1 9 1)) 1) 0) + (check-equal? (sum-territory (list (territory 0 0 1 9 0) (territory 0 0 1 9 1)) 2) 0) + (check-equal? (sum-territory (list (territory 0 1 1 9 0) (territory 0 0 1 9 1)) 1) 1) + (check-equal? (sum-territory (list (territory 0 1 1 9 0) (territory 0 0 1 9 1)) 0) 1) + + ;; --------------------------------------------------------------------------------------------------- + ;; testing the AI + + (define tree0 + (game-tree (list (territory 0 1 3 0 0) + (territory 1 0 2 0 0) + (territory 2 0 2 0 0) + (territory 3 0 2 0 0)) + 1 15)) + + (define territory1 (territory 3 0 3 280 262.5)) + + (define board31 + (list territory1 + (territory 2 0 3 150 262.5) + (territory 1 1 2 345 150) + (territory 0 0 2 215 150))) + + (define world1 + (dice-world #f board31 (game board31 1 '()))) + + ;; testing the AI functions + + ;; MF: one of these two tests should fail! + (check-true (and (attackable? board31 0 territory1 1) #t)) + (check-true (no-more-moves-in-world? world1)) + + (check-equal? (interact-with-board (dice-world 3 '() '()) "d") + (dice-world #f '() '())) + + (check-equal? (game-board (the-ai-plays tree0)) + (list (territory 3 1 3 0 0) + (territory 2 0 2 0 0) + (territory 1 0 2 0 0) + (territory 0 1 2 0 0))) + + (check-equal? (game-player (the-ai-plays tree0)) + 0) + + (check-equal? (game-board (move-gt (first (game-moves tree0)))) + (list (territory 0 1 1 0 0) + (territory 1 0 2 0 0) + (territory 2 0 2 0 0) + (territory 3 1 2 0 0))) + + (check-equal? (game-player (move-gt (first (game-moves tree0)))) + 1) + + (check-equal? (rate-position tree0 AI-DEPTH) 1/2) + (check-equal? (rate-position (move-gt (first (game-moves tree0))) AI-DEPTH) + 1/2) + + "all tests run") diff --git a/chapter11/lazy.rkt b/chapter11/lazy.rkt new file mode 100644 index 0000000..6f54719 --- /dev/null +++ b/chapter11/lazy.rkt @@ -0,0 +1,23 @@ +#lang racket + +(define (make-lazy+ i) + (lambda () + (apply + (build-list (* 500 i) values)))) + + +(define long-big-list (build-list 5000 make-lazy+)) + + +(define (compute-every-1000th l) + (for/list ([thunk l] + [i (in-naturals)] + #:when (zero? (remainder i 1000))) + (thunk))) + + +(define (memoize.v2 suspended-c) + (define (hidden) + (define the-value (suspended-c)) + (set! hidden (lambda () the-value)) + the-value) + (lambda () (hidden))) diff --git a/chapter12/graphics/dice1.png b/chapter12/graphics/dice1.png new file mode 100644 index 0000000..3f4899c Binary files /dev/null and b/chapter12/graphics/dice1.png differ diff --git a/chapter12/graphics/dice2.png b/chapter12/graphics/dice2.png new file mode 100644 index 0000000..2fa32ea Binary files /dev/null and b/chapter12/graphics/dice2.png differ diff --git a/chapter12/graphics/dice3.png b/chapter12/graphics/dice3.png new file mode 100644 index 0000000..005ee75 Binary files /dev/null and b/chapter12/graphics/dice3.png differ diff --git a/chapter12/graphics/dice4.png b/chapter12/graphics/dice4.png new file mode 100644 index 0000000..47bb291 Binary files /dev/null and b/chapter12/graphics/dice4.png differ diff --git a/chapter12/source.rkt b/chapter12/source.rkt new file mode 100644 index 0000000..dc37e87 --- /dev/null +++ b/chapter12/source.rkt @@ -0,0 +1,1240 @@ +#lang racket + +#| + The Dice of Doom game, the eager version + ---------------------------------------- + + The Dice of Doom game is a turn-based game for two players sharing one keyboard. + Since this implementation employs an eager strategy to build the complete game + tree of all possible moves, it is only a step in the right direction. + + Each player owns hexagonal territories, which are arranged into a planar game + board. A territory comes with a number of dice. When it is a player's turn, + she marks one of her territories as a launching pad for an attack at a + neigboring territory of the other player. Such an attack is enabled only if + her chosen territory has more dice than the territory of the other player. + The effect of the attack is that the territory changes ownership and that all + but one of the attack dice are moved to the newly conquered territory. A + player may continue her turn as long as she can launch attacks. Optionally, + she may choose to pass after her first attack is executed, meaning she ends + her turn. At the end of a turn, a number of dices are distributed across the + players' territories. The game is over when a player whose turn it is cannot + attack on her first move. + + A player can use the following five keys to play the game: + -- with ← and → (arrow keys), the player changes the territory focus + -- with enter, the player marks a territory the launching pad for an attack + -- with the "d" key, the player unmarks a territory + -- with the "p" key the player passes. + Once a player passes, the game announces whose turn it is next. + + Play + ---- + + Run and evaluate + (roll-the-dice) + This will pop up a window that the game board, and instructions. +|# + +(require 2htdp/image (except-in 2htdp/universe left right)) + +; +; +; +; +; ;;;; ; ;;; ;;; ;; ;; +; ; ; ; ; ; ; +; ; ; ;;; ;;; ; ;;;; ; ; ;;;; ;; ;;; ; ;;; ; +; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; +; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; +; ;;;; ;;;;; ;;;; ;;;;; ; ; ;;;; ;;;;; ;;;;; ;;; ;; +; +; +; +; + +;; --------------------------------------------------------------------------------------------------- +;; Data + +(struct dice-world (src board gt) #:transparent) +;; DiceWorld = (dice-world (U #false Natural) Board GameTree) +;; in (dice-world i b gt) +;; -- if i is a Natural, it is an index for the territory that the player has marked for an attack +;; -- if i is #f, no territory has been marked yet +;; b is the current board +;; gt is the game-tree for the given i and b + +(define-values (game game? game-board game-player game-moves) + (let () + (struct game (board player delayed-moves)) + (values game + game? + game-board + game-player + (lambda (g) (force (game-delayed-moves g)))))) +;; GameTree = (game Board Player [Listof Move]) +;; in (game-tree b p lm) +;; -- b is the current board +;; -- p is the current player +;; -- lm is the list of moves that that player may execute + +;; Board = [List-of Territory] +;; the first field in the list is the currently marked territory + +;; Player ∈ [0, PLAYER#) | Natural + +(struct move (action gt) #:transparent) +;; Move = (move Action GameTree) +;; in (move a gt) +;; -- a represents the actione to be takem +;; -- gt is the game-tree resulting from that action + +;; Action is one of: +;; -- '() a passing move +;; -- (list Natural Natural) the move where the first attacks the second + +(struct territory (index player dice x y) #:transparent) +;; Territory = (territory Natural Player Dice Integer Integer) +;; in (territory i p d x y) +;; -- i is a unique identifier for the territory; it also determines its initial location +;; -- p is the player who owns this territory +;; -- d is the number of dice on this board +;; -- x is the x coordiate of this territory in pixels +;; -- y is the y coordiate of this territory in pixels + +;; Territory Natural -> Territory +;; updates number of dice on territory +(define (territory-set-dice t d) + (territory (territory-index t) (territory-player t) d (territory-x t) (territory-y t))) + +;; Territory Player -> Territory +;; updates owner of territory +(define (territory-set-player t p) + (territory (territory-index t) p (territory-dice t) (territory-x t) (territory-y t))) + +;; --------------------------------------------------------------------------------------------------- +;; sample game tree for BOOK + +(define b1 + (list (territory 1 0 1 'a 'b) + (territory 0 0 1 'x 'y))) + +(define b1-alternative + (list (territory 0 0 1 'x 'y) + (territory 1 0 1 'a 'b))) + +(define b3 + (list (territory 0 0 2 'x 'y) + (territory 1 1 1 'a 'b))) + +(define gt1 (game b1 1 '())) + +(define mv2 (move '() gt1)) + +(define gt2 (game b1-alternative 0 (list mv2))) + +(define mv3 (move '(0 1) gt2)) + +(define gt3 (game b3 0 (list mv3))) + +;; --------------------------------------------------------------------------------------------------- +;; Constants + +; initalization constants +(define PLAYER# 2) +(define DICE# 3) +(define BOARD 3) +(define GRID (* BOARD BOARD)) +(define INIT-PLAYER 0) +(define INIT-SPARE-DICE 10) +; The depth at which to limit the gametree +(define AI-DEPTH 4) +(define AI 1) + +; graphical constants: territories +(define DICE-OFFSET 6) +(define SIDE 75) +(define OFFSET0 (* 2 SIDE)) +(define ROTATION 30) +(define HEX 6) +(define (hexagon color) + (rotate ROTATION (regular-polygon SIDE HEX "solid" color))) +(define X-OFFSET (image-width (hexagon "black"))) +(define Y-OFFSET (* (image-height (hexagon "black")) 3/4)) + +; graphical constants +(define COLORS + (list (make-color 255 0 0 100) + (make-color 0 255 0 100) + (make-color 0 0 255 100))) +(define FOCUS (rotate ROTATION (regular-polygon SIDE 6 "outline" "black"))) +(define D1 (bitmap "graphics/dice1.png")) +(define D2 (bitmap "graphics/dice2.png")) +(define D3 (bitmap "graphics/dice3.png")) +(define D4 (bitmap "graphics/dice4.png")) +(define IMG-LIST (list D1 D2 D3 D4)) + +(define TEXT-SIZE 25) +(define TEXT-COLOR "black") +(define INSTRUCT + "← and → to move among territories, to mark, to unmark, and

to pass") +(define AI-INSTRUCT + "press any key to let the AI play") +(define AI-TURN "It's the Mighty AI's turn") +(define YOUR-TURN "It's your turn") +(define INFO-X-OFFSET 180) +(define INFO-Y-OFFSET 50) + +(define INSTRUCTIONS (text INSTRUCT TEXT-SIZE TEXT-COLOR)) +(define AI-INSTRUCTIONS (text AI-INSTRUCT TEXT-SIZE TEXT-COLOR)) +(define WIDTH (+ (image-width INSTRUCTIONS) 50)) +(define HEIGHT 600) +(define (PLAIN) + (define iw (image-width INSTRUCTIONS)) + (define bw (* SIDE 2 BOARD)) + (set! WIDTH (+ (max iw bw) 50)) + (set! HEIGHT (+ (* SIDE 2 BOARD) 50)) + (empty-scene WIDTH HEIGHT)) +(define (ISCENE w) + (define mt (PLAIN)) + (when (or (> (image-width mt) 1280) (> (image-height mt) 800)) + (error 'scene "it is impossible to draw a ~s x ~s game scene for a 1280 x 800 laptop screen" (image-width mt) (image-height mt))) + (place-image + (if (= (game-player (dice-world-gt w)) AI) + AI-INSTRUCTIONS + INSTRUCTIONS) + (* .5 WIDTH) (* .9 HEIGHT) mt)) + +; +; +; +; +; ;;; ;;; ; +; ;; ;; +; ;; ;; ;;;; ;;; ;; ;; +; ; ; ; ; ; ; ;; ; +; ; ; ; ;;;;; ; ; ; +; ; ; ; ; ; ; ; +; ; ; ; ;; ; ; ; +; ;;; ;;; ;;; ;; ;;;;; ;;; ;;; +; +; +; +; + +;; --------------------------------------------------------------------------------------------------- + +;; start the game +(define (roll-the-dice) + (big-bang (create-world-of-dice-and-doom) + (on-key interact-with-board) + (to-draw draw-dice-world) + (stop-when no-more-moves-in-world? + draw-end-of-dice-world))) + +;; -> DiceWorld +;; Returns a randomly generated world. If the world that +;; has been generated starts as a tie, the world is regenerated. +;; property: world is not in endgame state (no-more-moves? returns false) +(define (create-world-of-dice-and-doom) + (define board (territory-build)) + (define gamet (game-tree board INIT-PLAYER INIT-SPARE-DICE)) + (define new-world (dice-world #f board gamet)) + (if (no-more-moves-in-world? new-world) + (create-world-of-dice-and-doom) + new-world)) + +;; DiceWorld Key -> DiceWorld +;; Handles key events from a player +(define (interact-with-board w k) + (cond [(= (game-player (dice-world-gt w)) AI) + (ai-step-through w)] + [(key=? "left" k) + (refocus-board w left)] + [(key=? "right" k) + (refocus-board w right)] + [(key=? "p" k) + (pass w)] + [(key=? "\r" k) + (mark w)] + [(key=? "d" k) + (unmark w)] + [else w])) + +;; Diceworld -> Scene +;; draws the world +(define (draw-dice-world w) + (add-player-info + (game-player (dice-world-gt w)) + (add-winning-probability w (add-board-to-scene w (ISCENE w))))) + +;; DiceWorld -> Boolean +;; is it possible to play any moves from this world state? +(define (no-more-moves-in-world? w) + (define tree (dice-world-gt w)) + (define board (dice-world-board w)) + (define player (game-player tree)) + (or (no-more-moves? tree) + (for/and ((t board)) (= (territory-player t) player)))) + +;; DiceWorld -> Image +;; render the endgame screen +(define (draw-end-of-dice-world w) + (define board (dice-world-board w)) + (define message (text (won board) TEXT-SIZE TEXT-COLOR)) + (define background (add-board-to-scene w (PLAIN))) + (overlay message background)) + +;; Board -> String +;; Which player has won the game -- eager is for N human players +(define (won board) + (define-values (best-score w) (winners board)) + (cond [(cons? (rest w)) "It's a tie."] + [(= (car w) AI) "AI won."] + [else "You won."])) + +; +; +; +; +; ;;;;; ; +; ; ; +; ; ;; ;; ;;; ;;;;; +; ; ;; ; ; ; +; ; ; ; ; ; +; ; ; ; ; ; +; ; ; ; ; ; ; +; ;;;;; ;;; ;;; ;;;;; ;;; +; +; +; +; + +;; --------------------------------------------------------------------------------------------------- +;; Making A Board + +;; -> Board +;; Creates a list of territories the size of GRID with given x and y coordinates +;; properties: dice is (0,MAX-DICE] +;; returns list of size GRID +(define (territory-build) + (for/list ([n (in-range GRID)]) + (territory n (modulo n PLAYER#) (dice) (get-x n) (get-y n)))) + +;; -> Natural +;; the number of initial die on a territory +(define (dice) + (add1 (random DICE#))) + +;; Natural -> Number +;; the x coordinate for territory n of a board +(define (get-x n) + (+ OFFSET0 + (if (odd? (get-row n)) 0 (/ X-OFFSET 2)) + (* X-OFFSET (modulo n BOARD)))) + +;; Natural -> Number +;; the y coordinate for territory n of a board +(define (get-y n) + (+ OFFSET0 (* Y-OFFSET (get-row n)))) + +;; --------------------------------------------------------------------------------------------------- +;; Making a Game Tree + +;; Board Player Natural -> GameTree +;; creates a complete game-tree from the given board, player, and spare dice +(define (game-tree board player dice) + ;; create tree of attacks from this position; add passing move + (define (attacks board) + (for*/list ([src board] + [dst (neighbors (territory-index src))] + #:when (attackable? board player src dst)) + (define from (territory-index src)) + (define dice (territory-dice src)) + (define newb (execute board player from dst dice)) + (define attacks-from-newb + (game newb player (delay (cons (passes newb) (attacks newb))))) + (move (list from dst) attacks-from-newb))) + ;; create a passing move , distribute dice, continue + (define (passes board) + (define-values (new-dice newb) (distribute board player dice)) + (move '() (game-tree newb (switch player) new-dice))) + ;; -- START: -- + (game board player (delay (attacks board)))) + +;; Player -> Player +;; switches from one player to the next +(define (switch player) + (modulo (+ player 1) PLAYER#)) + +;; Board Player Natural -> Natural Board +;; adds reinforcements to the game board +;; > (add-new-dice (list (territory 0 2 2 9 0)) 2 2)) +;; (list (territory 0 2 2 9 0)) +(define (distribute board player spare-dice) + (for/fold ([dice spare-dice] [new-board '()]) ([t board]) + (if (and (= (territory-player t) player) + (< (territory-dice t) DICE#) + (not (zero? dice))) + (values (- dice 1) (cons (add-dice-to t) new-board)) + (values dice (cons t new-board))))) + +;; Territory -> Territory +;; adds one dice to the given territory +(define (add-dice-to t) + (territory-set-dice t (add1 (territory-dice t)))) + +;; Board Player Territory Natural -> Boolean +;; can player attack dst from src? +(define (attackable? board player src dst) + (define dst-t + (findf (lambda (t) (= (territory-index t) dst)) board)) + (and dst-t + (= (territory-player src) player) + (not (= (territory-player dst-t) player)) + (> (territory-dice src) (territory-dice dst-t)))) + +;; Board Natural Natural Natural Natural -> Board +;; Creates a new board after an attack +;; updates only src and dst +(define (execute board player src dst dice) + (for/list ([t board]) + (define idx (territory-index t)) + (cond [(= idx src) (territory-set-dice t 1)] + [(= idx dst) + (define s (territory-set-dice t (- dice 1))) + (territory-set-player s player)] + [else t]))) + +;; --------------------------------------------------------------------------------------------------- +;; Getting Neigbors + +;; Natural -> [List-of Natural] +;; returns the neighbors of the current spot +;; > (neighbors 0) +;; '(1 2 3) +(define (neighbors pos) + (define top? (< pos BOARD)) + (define bottom? (= (get-row pos) (sub1 BOARD))) + (define even-row? (zero? (modulo (get-row pos) 2))) + (define right? (zero? (modulo (add1 pos) BOARD))) + (define left? (zero? (modulo pos BOARD))) + (if even-row? + (even-row pos top? bottom? right? left?) + (odd-row pos top? bottom? right? left?))) + +;; Natural Boolean Boolean Boolean Boolean -> [Listof Naturals] +;; gets the neighbors for a territory on an even row +(define (even-row pos top? bottom? right? left?) + (append (add (or top? right?) (add1 (- pos BOARD))) + (add (or bottom? right?) (add1 (+ pos BOARD))) + (add top? (- pos BOARD)) + (add bottom? (+ pos BOARD)) + (add right? (add1 pos)) + (add left? (sub1 pos)))) + +;; Natural Boolean Boolean Boolean Boolean -> [Listof Naturals] +;; gets the neighbors for a territory on an odd row +(define (odd-row pos top? bottom? right? left?) + (append (add top? (- pos BOARD)) + (add bottom? (+ pos BOARD)) + (add (or top? left?) (sub1 (- pos BOARD))) + (add (or bottom? left?) (sub1 (+ pos BOARD))) + (add right? (add1 pos)) + (add left? (sub1 pos)))) + +;; Boolean X -> [Listof X] +;; returns (list x) if (not b) else empty +(define (add b x) + (if b '() (list x))) + +; +; +; +; +; ;;; ;;; ;;;;;; +; ; ; ; ; ; +; ; ; ;;;; ;;; ;;; ; ; ;;; ;;; ;;;; ;; ;; ;;;;; ;;;;; +; ; ; ; ; ; ; ;;; ; ; ; ; ;; ; ; ; ; +; ;;; ;;;;;; ; ; ; ; ; ; ;;;;;; ; ; ; ;;;; +; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; +; ;;; ;; ;;;;; ; ;;;;;; ;; ;;;;; ;;; ;;; ;;; ;;;;; +; ; +; ;;; +; +; + +;; --------------------------------------------------------------------------------------------------- +;; Territory Focusing and Marking + +;; DiceWorld [Board -> Board] -> World +;; Creates a new World that has a rotated territory list +;; > (define lterritory (territory 0 0 1 9 2)) +;; > (define rterritory (territory 0 0 1 9 0)) +;; > (refocus-board-action (dice-world -1 (list rterritory lterritory ...) GT) left) +;; (dice-world -1 (list lterritory ... rterritory) GT) +;; > (refocus-board-action (dice-world -1 (list lterritory ... rterritory) GT) left) +;; (dice-world -1 (list rterritory lterritory ...) GT) +(define (refocus-board w direction) + (define source (dice-world-src w)) + (define board (dice-world-board w)) + (define tree (dice-world-gt w)) + (define player (game-player tree)) + (define (owner? tid) + (if source (not (= tid player)) (= tid player))) + (define new-board (rotate-until owner? board direction)) + (dice-world source new-board tree)) + +;; [Player -> Boolean] Board (Board -> Board) -> Board +;; rotate until the first element of the list satisfies owned-by +(define (rotate-until owned-by board rotate) + (define next-list (rotate board)) + (if (owned-by (territory-player (first next-list))) + next-list + (rotate-until owned-by next-list rotate))) + +;; Board -> Board +;; rotate a list to the left +(define (left l) + (append (rest l) (list (first l)))) + +;; Board -> Board +;; rotate a list to the right +(define (right l) + (reverse (left (reverse l)))) + +;; --------------------------------------------------------------------------------------------------- +;; Handling Moves + +;; DiceWorld -> DiceWorld +;; executes a passing move on the world state +;; THIS DEFINITION IS NOT USED FOR THE ABSTRACT VERSION OF THE MODULE. +(define (pass.10 w) + (define m (find-move (game-moves (dice-world-gt w)) '())) + (cond [(not m) w] + [else ;; (no-more-moves? m) + (dice-world #f (game-board m) m)])) + +;; DiceWorld -> DiceWorld +;; unmarks a marked territory +(define (unmark w) + (dice-world #f (dice-world-board w) (dice-world-gt w))) + +;; DiceWorld -> DiceWorld +;; marks a territory as the launching pad for an attack or launches the attack +(define (mark w) + (define tree (dice-world-gt w)) + (define board (dice-world-board w)) + (define source (dice-world-src w)) + (define focus (territory-index (first board))) + (if source + (attacking w source focus) + (dice-world focus board tree))) + +;; DiceWorld Natural Natural -> DiceWorld +(define (attacking w source target) + (define feasible (game-moves (dice-world-gt w))) + (define attack (list source target)) + (define next (find-move feasible attack)) + (define src-t (findf (lambda (t) (= (territory-index t) source)) + (dice-world-board w))) + (define dst-t (findf (lambda (t) (= (territory-index t) target)) + (dice-world-board w))) + (define win? (dice-attack-win src-t dst-t)) + (cond [(not next) w] + [win? (dice-world #f (game-board next) next)] + [else (dice-world-attack-lost w src-t)])) + +;; [List-of Moves] [or '() [List Natural Natural]] -> [or #f Game-tree] +;; find the move from the current list of moves +(define (find-move moves a) + (define m (findf (lambda (m) (equal? (move-action m) a)) moves)) + (and m (move-gt m))) + +;; Game -> Boolean +;; are there any moves in this game record? +(define (no-more-moves? g) + (empty? (game-moves g))) + +;; Territory Territory -> Boolean +;; attack from src territory to destination territory +;; and see who wins +(define (dice-attack-win src-t dst-t) + (define (roll-dice n) + (for/list ([i n]) + (random 1 7))) + (define (sum l) + (foldl + 0 l)) + (define src-attack (sum (roll-dice (territory-dice src-t)))) + (define dst-defend (sum (roll-dice (territory-dice dst-t)))) + (if (> src-attack dst-defend) #t #f)) + + +(define (probability-of-winning st dt) + "Find the probability of source territory defeating destination territory. + + `st` is the source territory. + `dt` is the destination territory." + + ; Given the number of dice, returns a list all dice combinations. + (define (dice-all-combination dice-num) + (cond [(= dice-num 1) + (for/list ([i (in-range 1 7)]) + (list i))] + [else + (for*/list ([i (in-range 1 7)] + [r (dice-all-combination + (- dice-num 1))]) + (cons i r))])) + + + ; Given a list of dice combinations, returns a hashmap where the key + ; is the 'dice sum' and the value is the number of combinations + ; whose sum is the 'dice sum'. + (define (dice-sum-hash dice-combinations) + (for/foldr + ([h (make-hash)]) ([c dice-combinations]) + (let ((sum (for/sum ([n c]) n))) + (hash-set! h sum (+ (hash-ref h sum 0) 1)) + h))) + + + ; sh: -> hashmap + ; key: dice sum, + ; value: number of ways we can arrive at sum + (define sh (dice-sum-hash + (dice-all-combination (territory-dice st)))) + + ; dh: -> hashmap + ; key: dice sum, + ; value: number of ways we can arrive at sum + (define dh (dice-sum-hash + (dice-all-combination (territory-dice dt)))) + + ; Generic probability function. + (define (probability f t) + (/ (* 1.0 f) t)) + + ; Computes the total number of favorable outcomes for the source + ; territory when its dice sum is `s-ds` against the + ; destination's territory. + ; + ; s-ds -> source dice sum. + ; n -> number of we can arrive at sum `s-ds`. + (define (favorable-outcomes s-ds n) + (* (for/sum [(d-ds (hash-keys dh))] + (if (< d-ds s-ds) + (hash-ref dh d-ds) + 0)) + n)) + + ; Computes the total number of favorable outcomes for the source + ; territory against the destination's territory. + (define (all-favorable-outcomes) + (foldr + 0 + (for/list [(s-ds (hash-keys sh))] + (favorable-outcomes + s-ds + (hash-ref sh s-ds))))) + + (define (all-outcomes) + (let ((sd (territory-dice st)) + (dd (territory-dice dt))) + (* (expt 6 sd) (expt 6 dd)))) + + (probability (all-favorable-outcomes) (all-outcomes))) + + +;; DiceWorld Territory -> DiceWorld +;; generate dice world for the case where player +;; loses the dice attack +(define (dice-world-attack-lost w src-t) + (define src (territory-index src-t)) + (define player (territory-player src-t)) + (define newb (for/list ([t (dice-world-board w)]) + (define idx (territory-index t)) + (cond [(= idx src) (territory-set-dice t 1)] + [else t]))) + (define new-gt (game-tree newb player 0)) + (dice-world #f newb new-gt)) + +; +; +; +; +; ;;;;; ;; ; +; ; ; ; +; ; ; ;;;; ;; ;; ;;; ; ;;;; ;; ;;; ;;; ;; ;; ;;; ;; +; ; ; ; ; ;; ; ; ;; ; ; ;; ; ;; ; ; ;; +; ;;;; ;;;;;; ; ; ; ; ;;;;;; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; +; ;;; ; ;;;;; ;;; ;;; ;;; ;; ;;;;; ;;;;; ;;;;; ;;; ;;; ;;; ; +; ; +; ;;;; +; +; + +;; Player Scene-> Scene +;; Draws the world +(define (add-player-info player s) + (define str (whose-turn player)) + (define txt (text str TEXT-SIZE TEXT-COLOR)) + (place-image txt (- WIDTH INFO-X-OFFSET) INFO-Y-OFFSET s)) + +(define (add-winning-probability w s) + (define board (dice-world-board w)) + (define source (dice-world-src w)) + (define target (territory-index (first board))) + (define feasible (game-moves (dice-world-gt w))) + (define attack (list source target)) + (define next (find-move feasible attack)) + + (define (find-territory index) + (findf (lambda (t) (= (territory-index t) index)) + (dice-world-board w))) + + (if (and source next) + (place-image + (text (string-append + "Winning Probability " + (~r + (probability-of-winning (find-territory source) + (find-territory target)) + #:precision 2)) + TEXT-SIZE TEXT-COLOR) + (- WIDTH 170) 100 s) + s)) + +;; DiceWorld Scene -> Scene +;; folds through the board and creates an image representation of it +(define (add-board-to-scene w s) + (define board (dice-world-board w)) + (define player (game-player (dice-world-gt w))) + (define focus? (dice-world-src w)) + (define trtry1 (first board)) + (define p-focus (territory-player trtry1)) + (define t-image (draw-territory trtry1)) + (define image (draw-focus focus? p-focus player t-image)) + (define base-s (add-territory trtry1 image s)) + (for/fold ([s base-s]) ([t (rest board)]) + (add-territory t (draw-territory t) s))) + +;; Nat Player Player Image -> Image +;; add focus marker to territory if needed +(define (draw-focus marked? p-in-focus p t-image) + (if (or (and (not marked?) (= p-in-focus p)) + (and marked? (not (= p-in-focus p)))) + (overlay FOCUS t-image) + t-image)) + +;; Image Territory Image -> Image +(define (add-territory t image scene) + (place-image image (territory-x t) (territory-y t) scene)) + +;; Territory -> Image +;; renders a single territory +(define (draw-territory t) + (define color (color-chooser (territory-player t))) + (overlay (hexagon color) (draw-dice (territory-dice t)))) + +;; Natural -> Image +;; renders all n >= 1 dice as a stack of dice +(define (draw-dice n) + (define first-die (get-dice-image 0)) + (define height-die (image-height first-die)) + (for/fold ([s first-die]) ([i (- n 1)]) + (define dice-image (get-dice-image (+ i 1))) + (define y-offset (* height-die (+ .5 (* i .25)))) + (overlay/offset s 0 y-offset dice-image))) + +;; Player -> Color +;; Determines a color for each player +(define (color-chooser p) + (list-ref COLORS p)) + +;; -> Image +;; returns an image from the list of dice images +(define (get-dice-image i) + (list-ref IMG-LIST (modulo i (length IMG-LIST)))) + +; +; +; +; +; ;;;;;; ;; ; +; ; ; ; +; ; ; ;; ;; ;;; ; ;;; ;; ;; ;;; ;; +; ;;; ;; ; ; ;; ; ;; ; ; ;; +; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ;; ; ; ; ; ;; +; ;;;;;; ;;; ;;; ;;; ;; ;;;;; ;;; ;;; ;;; ; +; ; +; ;;;; +; +; + +;; Board ->* Natural [non-empty-listof Player] +;; gives the number of winning territories and the players(s) who have them +;; > (winners (list (territory 0 0 1 9 0) (territory 0 0 1 9 1))) +;; (values 2 '(0)) +;; > (winners (list (territory 0 1 1 9 0) (territory 0 0 1 9 1))) +;; (values 1 '(0 1)) +(define (winners board) + (for/fold ([best 0][winners '()]) ([p PLAYER#]) + (define p-score (sum-territory board p)) + (cond [(> p-score best) (values p-score (list p))] + [(< p-score best) (values best winners)] + [(= p-score best) (values best (cons p winners))]))) + +;; Board Player -> Natural +;; counts the number of territorys the player owns +;; > (sum-territory (list (territory 0 1 1 9 0) (territory 0 1 1 9 1)) 1) +;; 2 +(define (sum-territory board player) + (for/fold ([result 0]) ([t board]) + (if (= (territory-player t) player) (+ result 1) result))) + + +; +; +; +; +; +; ;;; ;;;;;;; +; ;; ; +; ; ; ; +; ; ; ; +; ; ; ; +; ;;;;;; ; +; ; ; ; +; ; ; ; +; ;;; ;;; ;;;;;;; +; +; +; +; + +;; Player -> {AI-TURN, YOUR-TURN} +;; THIS REQUIRES A DIFFERENT DEFINITION FOR PLAIN CHAPTER 10. +(define (whose-turn player) + (if (= player AI) AI-TURN YOUR-TURN)) + +;; DiceWorld -> DiceWorld +;; executes a passing move on the world state +;; THIS REQUIRES A DIFFERENT DEFINITION FOR PLAIN CHAPTER 10. +(define (pass w) + (define m (find-move (game-moves (dice-world-gt w)) '())) + (cond [(not m) w] + [(or (no-more-moves? m) (not (= (game-player m) AI))) + (dice-world #f (game-board m) m)] + [else + (define ai (the-ai-plays m)) + (dice-world #f (game-board ai) ai)])) + +;; GameTree -> GameTree +;; Computer calls this function until it is no longer the player +(define (the-ai-plays tree) + (define ratings (rate-moves tree AI-DEPTH)) + (define the-move (first (argmax second ratings))) + (define new-tree (move-gt the-move)) + new-tree) + +;; DiceWold -> DiceWorld +;; Executes AI's turn. +(define (ai-step-through w) + (define new-gt (the-ai-plays (dice-world-gt w))) + (dice-world #f (game-board new-gt) new-gt)) + +;; GameTree Natural -> [List-of (List Move Number)] +;; assigns a value to each move that is being considered +;; and return those values in a list +(define (rate-moves tree depth) + (for/list ((move (game-moves tree))) + (list move (rate-position (move-gt move) (- depth 1))))) + +;; GameTree Natural -> Number +;; Returns a number that is the best move for the given player. +(define (rate-position tree depth) + (cond [(or (= depth 0) (no-more-moves? tree)) + (define-values (best w) (winners (game-board tree))) + (if (member AI w) (/ 1 (length w)) 0)] + [else + (define ratings (rate-moves tree depth)) + (apply (if (= (game-player tree) AI) max min) + (map second ratings))])) + +; +; +; +; +; ;; +; ; +; ; ; ;; ;; ;; ;; ;;;;; +; ; ; ; ; ; ; ; ; +; ; ; ; ; ;; ;;;; +; ;;; ; ; ;; ; +; ; ; ; ;; ; ; ; ; +; ;;; ;;; ;; ;; ;; ;; ;;;;; +; +; +; +; + +;; Natural -> Natural +;; gets the row that territory is on, indexed from 0 +;; [test vary on current board-size] +(define (get-row pos) + (quotient pos BOARD)) + + +; +; +; +; +; +; ;;;;;;; ; +; ; ; ; ; +; ; ; ; ;;; ;;;; ; ;;;;;; ;;;; ; +; ; ; ; ; ; ; ;; ; ; ;; +; ; ; ; ; ; ; +; ; ;;;;;;; ;;;;; ; ;;;;; +; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; +; ;;;;; ;;;; ;;;;;; ;;;; ;;;;;; +; +; +; +; + +;; --------------------------------------------------------------------------------------------------- + +;; Natural -> Void +;; make the board larger +(define (set-grid n) + (set! BOARD n) + (set! GRID (* n n))) + +(module+ test + + (require rackunit rackunit/text-ui) + + ;; (-> any) -> void + ;; runs the thunk PROP-NUM times + (define (check-property t) + (test-begin (for ((i 50)) (t)))) + + ;; Properties + (define (property:starting-world-playable) + (unless (and (= BOARD 2) (= PLAYER# 2)) + (error 'starting-world-playable "BOARD-SIZE != 2 or PLAYERS# != 2")) + (check-false (no-more-moves-in-world? (create-world-of-dice-and-doom)))) + + (define (property:dice-in-range) + (check-true (andmap (λ (b) (>= DICE# (territory-dice b) 1)) (territory-build)) + "dice out of range")) + + (define (property:board-correct-size) + (check-equal? (length (territory-build)) GRID + "board incorrect-size")) + + (define (property:no-pass-on-first-move) + (define (move-action? m) (equal? (move-action m) '())) + (check-true (not (memf move-action? (game-moves (game-tree (territory-build) 0 0)))) + "no pass on first move")) + + ;; --------------------------------------------------------------------------------------------------- + + + ;; testing game initialization + + (check-equal? (territory-index (first (territory-build))) 0) + (check-equal? (territory-player (first (territory-build))) 0) + (check-equal? (territory-index (second (territory-build))) 1) + (check-equal? (territory-player (second (territory-build))) 1) + (check-equal? (territory-index (third (territory-build))) 2) + (check-equal? (territory-player (third (territory-build))) 0) + (check-equal? (territory-index (fourth (territory-build))) 3) + (check-equal? (territory-player (fourth (territory-build))) 1) + + (check-property property:starting-world-playable) + (check-property property:board-correct-size) + (check-property property:dice-in-range) + (check-property property:no-pass-on-first-move) + + ;; --------------------------------------------------------------------------------------------------- + ;; testing territory manipulation + + ;; legal? + (check-true + (and (attackable? (list (territory 0 0 2 9 0) (territory 3 1 1 9 0)) 0 (territory 0 0 2 9 0) 3) #t)) + (check-false + (attackable? (list (territory 0 0 2 9 0) (territory 3 1 1 9 0)) 0 (territory 0 0 2 9 0) 0)) + (check-false + (attackable? (list (territory 0 0 2 9 0) (territory 5 1 1 9 0)) 1 (territory 0 0 2 9 0) 5)) + + ;; get-row + (check-equal? (get-row 0) 0) + (check-equal? (get-row 1) 0) + (check-equal? (get-row 2) 1) + (check-equal? (get-row 3) 1) + (check-equal? (get-row 12) 6) ;; checks math. actually invalid on board of size 2 + (check-equal? (get-row 11) 5) ;; checks math. actually invalid on board of size 2 + (check-equal? (get-row 13) 6) ;; checks math. actually invalid on board of size 2 + (check-equal? (get-row 14) 7) ;; checks math. actually invalid on board of size 2 + + ;; --------------------------------------------------------------------------------------------------- + (define board3 + (list (territory 0 1 1 9 0) (territory 1 1 1 8 0) (territory 2 1 3 43.5 5) (territory 3 1 1 6 5))) + (define b1+0+3 + (list (territory 0 0 2 9 0) (territory 1 1 1 8 0) (territory 2 0 2 43.5 5) (territory 3 1 1 6 5))) + (define b2+1+2 + (list (territory 0 0 1 9 0) (territory 1 1 3 8 0) (territory 2 0 2 43.5 5) (territory 3 1 2 6 5))) + (define board6 + (list (territory 0 0 1 9 0) (territory 1 1 2 8 0) (territory 2 0 3 43.5 5) (territory 3 1 2 6 5))) + (define bard6+ + (list (territory 0 0 1 9 0) (territory 1 1 2 8 0) (territory 2 0 3 43.5 5) (territory 3 1 2 6 5))) + + (define (distribute/list a b c) + (define-values (x y) (distribute a b c)) + (list x y)) + + (define board0 + (list (territory 0 0 1 9 0) (territory 1 1 2 8 0) (territory 2 0 2 43.5 5) (territory 3 1 1 6 5))) + (define board1 + (list (territory 0 0 1 9 0) (territory 1 1 1 8 0) (territory 2 0 1 43.5 5) (territory 3 1 1 6 5))) + (define b1+1+2 + (list (territory 0 0 1 9 0) (territory 1 1 2 8 0) (territory 2 0 1 43.5 5) (territory 3 1 2 6 5))) + (define board2 + (list (territory 0 0 1 9 0) (territory 1 1 1 8 0) (territory 2 0 3 43.5 5) (territory 3 1 1 6 5))) + + (define g-tree1 (game board1 0 '())) + (define g-tree2 (game-tree board0 0 0)) + + ; (define world31 (dice-world #f board1 g-tree1)) + (define world2 (dice-world #f board2 g-tree2)) + + ;; testing book tree + + (check-equal? (game-tree (list (territory 0 0 2 'x 'y) + (territory 1 1 1 'a 'b)) + 0 + 0) + gt3) + + + ;; testing tree generation + + (define (property:attack-location-valid) + (define moves (game-moves (game-tree (territory-build) 0 0))) + (check-true (and (for/and ([m moves]) + (define m1 (move-action m)) + (member (second m1) (neighbors (first m1)))) + #t) + "invalid attack location")) + + (define (property:add-to-territory-always-up-one) + (define r (random 10000)) + (check-equal? (add-dice-to (territory 0 0 r 0 0)) + (territory 0 0 (add1 r) 0 0) + "add to territory always up one")) + + (define (property:attackable?-does-not-need-neighbores-check) + (define (check-attackable? gt) + (for/and ([move (game-moves gt)] + #:when (not (empty? (move-action move)))) + (define action (move-action move)) + (define gt (move-gt move)) + (and (member (second action) (neighbors (first action))) + (check-attackable? gt)))) + + ;;start + (define old-size BOARD) + (set-grid 2) + (define testing-gt (dice-world-gt (create-world-of-dice-and-doom))) + (check-true (check-attackable? testing-gt) "An attack move between non-neighbores was created") + (set-grid old-size)) + + + ;; game-tree + (check-equal? (game-tree board1 0 0) g-tree1) + (check-equal? (game-tree board3 1 0) (game board3 1 '())) + (check-equal? (game-tree board3 0 0) (game board3 0 '())) + (check-property property:attackable?-does-not-need-neighbores-check) + + ;; find-move + (check-false (find-move '() '())) + (check-equal? (find-move (list (move '() (game '() 0 '()))) '()) (game '() 0 '())) + ;; Attacking-Moves + (check-property property:attack-location-valid) + + ;; switch-players + (check-equal? (switch 0) 1) + (check-equal? (switch 1) 0) + + ;; Add-New-Dice + (check-equal? (distribute/list (game-board g-tree1) 0 3) (list 1 (reverse b1+0+3))) + (check-equal? (distribute/list (game-board g-tree1) 1 2) (list 0 (reverse b1+1+2))) + (check-equal? (distribute/list (game-board g-tree2) 1 2) (list 0 (reverse b2+1+2))) + (check-equal? (distribute/list board6 0 0) (list 0 (reverse bard6+))) + + ;; add-to-territory + (check-equal? (add-dice-to (territory 0 1 2 9 0)) (territory 0 1 3 9 0)) + (check-equal? (add-dice-to (territory 0 1 1 9 0)) (territory 0 1 2 9 0)) + (check-equal? (add-dice-to (territory 0 1 5 9 0)) (territory 0 1 6 9 0)) + (check-property property:add-to-territory-always-up-one) + + ;; --------------------------------------------------------------------------------------------------- + (define board7 + (list (territory 0 0 1 9 0) (territory 1 1 1 8 0) (territory 2 0 2 43.5 5) (territory 3 1 1 6 5))) + (define board8 + (list (territory 0 1 1 9 0) (territory 1 1 1 8 0) (territory 2 0 3 43.5 5) (territory 3 1 1 6 5))) + (define board9 + (list (territory 0 0 1 9 0) (territory 1 1 1 8 0) (territory 2 0 2 43.5 5) (territory 3 0 1 6 5))) + (define board10 + (list (territory 0 0 1 9 0) (territory 1 1 3 8 0) (territory 2 0 2 43.5 5) (territory 3 1 1 6 5))) + + ;; testing attacks + + (check-equal? + (execute board7 0 2 1 2) + (list (territory 0 0 1 9 0) (territory 1 0 1 8 0) (territory 2 0 1 43.5 5) (territory 3 1 1 6 5))) + + (check-equal? + (execute board8 0 2 1 3) + (list (territory 0 1 1 9 0) (territory 1 0 2 8 0) (territory 2 0 1 43.5 5) (territory 3 1 1 6 5))) + + (check-equal? + (execute board9 0 2 1 2) + (list (territory 0 0 1 9 0) (territory 1 0 1 8 0) (territory 2 0 1 43.5 5) (territory 3 0 1 6 5))) + + (check-equal? + (execute board10 1 1 0 3) + (list(territory 0 1 2 9 0) (territory 1 1 1 8 0) (territory 2 0 2 43.5 5) (territory 3 1 1 6 5))) + + ;; Neighbors + (check-equal? (neighbors 2) '(0 3)) + (check-equal? (neighbors 0) '(3 2 1)) + (check-equal? (neighbors 1) '(3 0)) + (check-equal? (neighbors 3) '(1 0 2)) + + ;; --------------------------------------------------------------------------------------------------- + (define board20 + (list (territory 0 0 1 9 2) (territory 1 0 1 9 0) (territory 2 2 1 9 0))) + (define board21 + (list (territory 0 1 1 9 0) (territory 1 1 1 8 0) (territory 2 1 1 43.5 5) (territory 3 1 1 6 5))) + + ;; testing focus manipulation + ;; interact-with-board + (check-equal? + (interact-with-board world2 "\r") + (dice-world (territory-index (car (dice-world-board world2))) (dice-world-board world2) g-tree2)) + + (check-equal? (interact-with-board world2 "p") world2) + + ;; refocus-board-action + (check-equal? + (refocus-board (dice-world #f (list (territory 0 0 1 9 0) (territory 0 0 1 9 2)) g-tree1) left) + (dice-world #f (list (territory 0 0 1 9 2) (territory 0 0 1 9 0)) g-tree1)) + + (check-equal? + (refocus-board (dice-world #f (list (territory 0 0 1 9 2) (territory 0 1 1 9 0)) g-tree1) right) + (dice-world #f (list (territory 0 0 1 9 2) (territory 0 1 1 9 0)) g-tree1)) + + (check-equal? + (refocus-board (dice-world 0 board20 g-tree1) left) + (dice-world 0 (list (territory 2 2 1 9 0) (territory 0 0 1 9 2) (territory 1 0 1 9 0)) g-tree1)) + + (check-equal? + (refocus-board (dice-world 0 (list (territory 0 0 1 9 2) (territory 0 1 1 9 0)) g-tree1) left) + (dice-world 0 (list (territory 0 1 1 9 0) (territory 0 0 1 9 2)) g-tree1)) + + (check-equal? + (refocus-board (dice-world 0 (list(territory 0 0 1 9 2) (territory 0 1 1 9 0)) g-tree1) right) + (dice-world 0 (list (territory 0 1 1 9 0) (territory 0 0 1 9 2)) g-tree1)) + + ;;unmark + (check-equal? (unmark (dice-world 1 board21 g-tree1)) (dice-world #f board21 g-tree1)) + + (check-equal? (unmark (dice-world 1 (list (territory 0 1 1 9 0) (territory 1 1 1 8 0)) g-tree1)) + (dice-world #f (list (territory 0 1 1 9 0) (territory 1 1 1 8 0)) g-tree1)) + (check-equal? (unmark (dice-world 0 (list (territory 0 1 1 9 0)) g-tree1)) + (dice-world #f (list (territory 0 1 1 9 0)) g-tree1)) + (check-equal? (unmark (dice-world #f (list (territory 0 1 1 9 0)) g-tree1)) + (dice-world #f (list (territory 0 1 1 9 0)) g-tree1)) + + ;; --------------------------------------------------------------------------------------------------- + (define (winners/list w) + (define-values (a b) (winners w)) + (cons a b)) + + ;; testing functions that determine 'winning' and declare the winner + + ;; winners + (check-equal? (winners/list (list (territory 0 0 1 9 0) (territory 0 0 1 9 1))) (list 2 0)) + (check-equal? (winners/list (list (territory 0 1 1 9 0) (territory 0 0 1 9 1))) (list 1 1 0)) + + ;; sum-territory + (check-equal? (sum-territory (list (territory 0 0 1 9 0) (territory 0 0 1 9 1)) 0) 2) + (check-equal? (sum-territory (list (territory 0 0 1 9 0) (territory 0 0 1 9 1)) 1) 0) + (check-equal? (sum-territory (list (territory 0 0 1 9 0) (territory 0 0 1 9 1)) 2) 0) + (check-equal? (sum-territory (list (territory 0 1 1 9 0) (territory 0 0 1 9 1)) 1) 1) + (check-equal? (sum-territory (list (territory 0 1 1 9 0) (territory 0 0 1 9 1)) 0) 1) + + ;; --------------------------------------------------------------------------------------------------- + ;; testing the AI + + (define tree0 + (game-tree (list (territory 0 1 3 0 0) + (territory 1 0 2 0 0) + (territory 2 0 2 0 0) + (territory 3 0 2 0 0)) + 1 15)) + + (define territory1 (territory 3 0 3 280 262.5)) + + (define board31 + (list territory1 + (territory 2 0 3 150 262.5) + (territory 1 1 2 345 150) + (territory 0 0 2 215 150))) + + (define world1 + (dice-world #f board31 (game board31 1 '()))) + + ;; testing the AI functions + + ;; MF: one of these two tests should fail! + (check-true (and (attackable? board31 0 territory1 1) #t)) + (check-true (no-more-moves-in-world? world1)) + + (check-equal? (interact-with-board (dice-world 3 '() '()) "d") + (dice-world #f '() '())) + + (check-equal? (game-board (the-ai-plays tree0)) + (list (territory 3 1 3 0 0) + (territory 2 0 2 0 0) + (territory 1 0 2 0 0) + (territory 0 1 2 0 0))) + + (check-equal? (game-player (the-ai-plays tree0)) + 0) + + (check-equal? (game-board (move-gt (first (game-moves tree0)))) + (list (territory 0 1 1 0 0) + (territory 1 0 2 0 0) + (territory 2 0 2 0 0) + (territory 3 1 2 0 0))) + + (check-equal? (game-player (move-gt (first (game-moves tree0)))) + 1) + + (check-equal? (rate-position tree0 AI-DEPTH) 1/2) + (check-equal? (rate-position (move-gt (first (game-moves tree0))) AI-DEPTH) + 1/2) + + "all tests run") diff --git a/chapter13/client.rkt b/chapter13/client.rkt new file mode 100644 index 0000000..dc3b184 --- /dev/null +++ b/chapter13/client.rkt @@ -0,0 +1,189 @@ +#lang racket + +(require 2htdp/image 2htdp/universe "shared.rkt") + +(provide launch-guess-client) + +(struct client-state (type clue guess action done)) + +(define ClientState0 (client-state -1 "" #f "" #f)) + +(define SCENE-WIDTH 300) +(define SCENE-HEIGHT 200) + +(define (launch-guess-client n host) + (big-bang ClientState0 + (on-draw draw-guess) + (on-key handle-keys) + (name n) + (register host) + (on-receive handle-msg))) + +(define (handle-keys w key) + (cond [(= (client-state-type w) PLAYER) (handle-keys-player w key)] + [(= (client-state-type w) GUESSER) (handle-keys-guesser w key)] + [else w])) + +(define (handle-keys-player w key) + (define (action) + (client-state-action w)) + (define (guess) + (client-state-guess w)) + (define (set-clue clue) + (client-state PLAYER clue (guess) (action) #f)) + (cond [(and (string=? (action) "c") (key=? key "c")) + (make-package w (server-msg PLAYER "c" ""))] + [(and (string=? (action) "a") (key=? key "up")) + (make-package (set-clue "up") (server-msg PLAYER "a" "up"))] + [(and (string=? (action) "a") (key=? key "down")) + (make-package (set-clue "down") (server-msg PLAYER "a" "down"))] + [(and (string=? (action) "a") (key=? key "=")) + (make-package (set-clue "=") (server-msg PLAYER "a" "="))] + [else w])) + +(define (handle-keys-guesser w key) + (define (action) + (client-state-action w)) + (cond [(and (string=? (action) "c") (key=? key "c") + (make-package w (server-msg GUESSER "c" "")))] + [(and (string=? (action) "g") (key=? key "g") + (make-package w (server-msg GUESSER "g" "")))] + [else w])) + +(define (handle-msg c c-msg) + (cond [(not (client-msg? c-msg)) c] + [(= (client-msg-type c-msg) PLAYER) + (handle-msg-player c c-msg)] + [(= (client-msg-type c-msg) GUESSER) + (handle-msg-guesser c c-msg)] + [else c])) + +(define (handle-msg-player c c-msg) + (define (is-done) + (client-msg-done c-msg)) + (define (action) + (client-msg-action c-msg)) + (define (set-done) + (let ([guess (client-msg-guess c-msg)]) + (client-state PLAYER "" guess "" #t))) + (define (set-check) + (let ([clue (client-state-clue c)]) + (client-state PLAYER clue #f "c" #f))) + (define (set-act) + (let ([guess (client-msg-guess c-msg)]) + (client-state PLAYER "" guess "a" #f))) + (cond [(is-done) (set-done)] + [(string=? (action) "c") (set-check)] + [(string=? (action) "a") (set-act)] + [else c])) + +(define (handle-msg-guesser c c-msg) + (define (is-done) + (client-msg-done c-msg)) + (define (action) + (client-msg-action c-msg)) + (define (set-done) + (let ([guess (client-msg-guess c-msg)]) + (client-state GUESSER "" guess "" #t))) + (define (set-check) + (let ([clue (client-msg-clue c-msg)] + [guess (client-msg-guess c-msg)]) + (client-state GUESSER clue guess "c" #f))) + (define (set-guess) + (let ([clue (client-msg-clue c-msg)] + [guess (client-msg-guess c-msg)]) + (client-state GUESSER clue guess "g" #f))) + (cond [(is-done) (set-done)] + [(string=? (action) "c") (set-check)] + [(string=? (action) "g") (set-guess)] + [else c])) + +(define (draw-guess c) + (define (render type result desc help) + (place-image/align + type 5 5 "left" "top" + (overlay (above result desc help) + (empty-scene SCENE-WIDTH SCENE-HEIGHT)))) + (let ([type (draw-type c)] + [result (draw-result c)] + [desc (draw-desc c)] + [help (draw-help c)]) + (render type result desc help))) + +(define (draw-type c) + (text (cond [(= (client-state-type c) PLAYER) "Player"] + [(= (client-state-type c) GUESSER) "Guesser"] + [else "..."]) + 14 "black")) + +(define (draw-result c) + (text (cond [(= (client-state-type c) PLAYER) + (draw-result-player c)] + [else (draw-result-guesser c)]) + 14 "black")) + +(define (draw-result-player c) + (define (done) + (client-state-done c)) + (define (action) + (client-state-action c)) + (define (guess) + (number->string (client-state-guess c))) + (cond [(and (not (done)) (string=? (action) "")) "..."] + [(done) (string-append (guess) " it is!")] + [(string=? (action) "a") (string-append "Guess: " (guess))] + [else ""])) + +(define (draw-result-guesser c) + (define (done) + (client-state-done c)) + (define (action) + (client-state-action c)) + (define (guess) + (let ([g (client-state-guess c)]) + (cond [(number? g) (number->string g)] + [else ""]))) + (define (clue) + (cond [(string=? (client-state-clue c) "up") ">"] + [else "<"])) + (cond [(and (not (done)) (string=? (action) "") "...")] + [(done) (string-append (guess) " it is!")] + [(and (string=? (action) "g") (> (string-length (guess)) 0)) + (string-append "Number " (clue) " " (guess))] + [(string=? (action) "c") (string-append "Guess: " (guess))] + [else ""])) + +(define (draw-desc c) + (text (cond [(= (client-state-type c) PLAYER) ""] + [else (draw-desc-guesser c)]) + 10 "black")) + +(define (draw-desc-guesser c) + (define (action) + (client-state-action c)) + (cond [(string=? (action) "c") "Waiting for player to act on guess"] + [else ""])) + +(define (draw-help c) + (define (type) + (client-state-type c)) + (text (cond [(= (type) PLAYER) (draw-help-player c)] + [else (draw-help-guesser c)]) + 10 "black")) + +(define (draw-help-player c) + (define (action) + (client-state-action c)) + (cond [(string=? (action) "c") "Press 'c' to check"] + [(string=? (action) "a") "Press ↑, ↓, or = "] + [else ""])) + +(define (draw-help-guesser c) + (define (action) + (client-state-action c)) + (define (done) + (client-state-done c)) + (cond [(string=? (action) "g") "Press 'g' to guess"] + [(string=? (action) "c") "Press 'c' to check"] + [(done) "Good Job!"] + [else ""])) diff --git a/chapter13/run.rkt b/chapter13/run.rkt new file mode 100644 index 0000000..b8726ac --- /dev/null +++ b/chapter13/run.rkt @@ -0,0 +1,13 @@ +#lang racket + +(require 2htdp/universe "client.rkt" "server.rkt") + +(define (run) + (launch-many-worlds (launch-guess-client "Adam" LOCALHOST) + (launch-guess-server) + (launch-guess-client "Eve" LOCALHOST))) + +(define (bad) + (launch-many-worlds (launch-guess-client "Adam" LOCALHOST) + (launch-guess-server) + (launch-guess-client "Beatrice" LOCALHOST))) diff --git a/chapter13/server.rkt b/chapter13/server.rkt new file mode 100644 index 0000000..12ff10a --- /dev/null +++ b/chapter13/server.rkt @@ -0,0 +1,149 @@ +#lang racket + +(provide launch-guess-server) + +(require 2htdp/image 2htdp/universe "shared.rkt") + +(struct interval (small big) #:transparent) + +;; paction -> 'c' or 'a' +;; gaction -> 'c' or 'g' +(struct server-state (interval clue guess paction gaction clients done)) + +(define u0 (server-state (interval LOWER UPPER) "" #f "c" "" 1 #f)) + +(define (launch-guess-server) + (universe #f + (state #t) + (on-new connect) + (on-msg handle-msg))) + +(define (connect u client) + (cond [(false? u) + (make-bundle + u0 + (list (make-mail client (client-msg PLAYER "" #f "c" #f))) + '())] + [(= (server-state-clients u) 1) + (make-bundle + (server-state + (server-state-interval u) (server-state-clue u) + (server-state-guess u) (server-state-paction u) + "g" 2 #f) + (list (make-mail client (client-msg GUESSER "" #f "g" #f))) + '())] + [else (make-bundle u empty (list client))])) + +(define (handle-msg u client s-msg) + (cond [(not (server-msg? s-msg)) (make-bundle u empty (list client))] + [(= (server-msg-type s-msg) PLAYER) + (handle-msg-player u client s-msg)] + [(= (server-msg-type s-msg) GUESSER) + (handle-msg-guesser u client s-msg)] + [else (make-bundle u empty (list client))])) + +(define (handle-msg-player u client s-msg) + (define (set-paction paction) + (let ([interval (server-state-interval u)] + [clue (server-state-clue u)] + [guess (server-state-guess u)] + [gaction (server-state-gaction u)] + [clients (server-state-clients u)]) + (server-state interval clue guess paction gaction clients #f))) + (define (set-clue clue) + (let ([interval (server-state-interval u)] + [guess (server-state-guess u)] + [gaction (server-state-gaction u)] + [clients (server-state-clients u)] + [done (server-state-done u)]) + (server-state interval clue guess "c" gaction clients done))) + (define (set-done) + (let ([interval (server-state-interval u)] + [guess (server-state-guess u)] + [gaction (server-state-gaction u)] + [clients (server-state-clients u)]) + (server-state interval "" guess "" gaction clients #t))) + (define (mail clue guess action done) + (list (make-mail client (client-msg PLAYER clue guess action done)))) + (let* ([clue (server-state-clue u)] + [guess (server-state-guess u)] + [action (server-msg-action s-msg)] + [done (server-state-done u)] + [action-ok (string=? (server-state-paction u) action)] + [has-guess (number? guess)] + [data (server-msg-data s-msg)]) + (cond [(not action-ok) + (make-bundle u empty (list client))] + [(and (string=? action "c") (not has-guess)) + (make-bundle u (mail clue guess action done) empty)] + [(and (string=? action "c") has-guess) + (make-bundle (set-paction "a") (mail clue guess "a" done) empty)] + [(and (string=? action "a") (member data '("up" "down"))) + (make-bundle (set-clue data) (mail data #f "c" done) empty)] + [(and (string=? action "a") (string=? data "=")) + (make-bundle (set-done) (mail "" guess "" #t) empty)] + [else (make-bundle u empty (list client))]))) + +(define (handle-msg-guesser u client s-msg) + (define (set-guess interval clue guess) + (let ([paction (server-state-paction u)] + [clients (server-state-clients u)] + [done (server-state-done u)]) + (server-state interval clue guess paction "c" clients done))) + (define (set-gaction gaction) + (let ([interval (server-state-interval u)] + [clue (server-state-clue u)] + [guess (server-state-guess u)] + [paction (server-state-paction u)] + [clients (server-state-clients u)] + [done (server-state-done u)]) + (server-state interval clue guess paction gaction clients done))) + (define (has-clue) + (> (string-length (server-state-clue u)) 0)) + (define (is-done) + (server-state-done u)) + (define (mail clue guess action done) + (list (make-mail client + (client-msg GUESSER clue guess action done)))) + (let* ([action (server-msg-action s-msg)] + [interval (server-state-interval u)] + [clue (server-state-clue u)] + [current-guess (server-state-guess u)] + [done (server-state-done u)] + [action-ok (string=? (server-state-gaction u) action)]) + (cond [(not action-ok) (make-bundle u empty (list client))] + [(is-done) + (make-bundle (set-gaction "") + (mail "" current-guess "" #t) empty)] + [(and (string=? action "g") (not (has-clue))) + (let ([guess (guess interval)]) + (make-bundle (set-guess interval "" guess) + (mail "" guess "c" done) empty))] + [(and (string=? action "g") (has-clue)) + (let* ([n-interval (next-interval interval clue)] + [guess (guess n-interval)]) + (make-bundle (set-guess n-interval "" guess) + (mail "" guess "c" done) empty))] + [(and (string=? action "c") (has-clue)) + (make-bundle (set-gaction "g") + (mail clue current-guess "g" done) empty)] + [else (make-bundle u (mail clue current-guess action done) + empty)]))) + +(define (next-interval interval clue) + (cond [(not (string? clue)) interval] + [(string=? "up" clue) (bigger interval)] + [(string=? "down" clue) (smaller interval)] + [else interval])) + +(define (single? w) + (= (interval-small w) (interval-big w))) + +(define (guess w) + (quotient (+ (interval-small w) (interval-big w)) 2)) + +(define (smaller w) + (interval (interval-small w) (max (interval-small w) (sub1 (guess w))))) + +(define (bigger w) + (interval (min (interval-big w) (add1 (guess w))) (interval-big w))) diff --git a/chapter13/shared.rkt b/chapter13/shared.rkt new file mode 100644 index 0000000..176c429 --- /dev/null +++ b/chapter13/shared.rkt @@ -0,0 +1,28 @@ +#lang racket + +(provide + UPPER + LOWER + PLAYER + GUESSER + client-msg + client-msg? + client-msg-type + client-msg-clue + client-msg-guess + client-msg-action + client-msg-done + server-msg + server-msg? + server-msg-type + server-msg-action + server-msg-data) + +(define UPPER 100) +(define LOWER 0) + +(define PLAYER 0) +(define GUESSER 1) + +(struct client-msg (type clue guess action done) #:prefab) +(struct server-msg (type action data) #:prefab) diff --git a/chapter14/client.rkt b/chapter14/client.rkt new file mode 100644 index 0000000..52305a1 --- /dev/null +++ b/chapter14/client.rkt @@ -0,0 +1,611 @@ +#lang racket + +;; This module implements the client for the Hungry Henry game + +(provide + lets-eat ;; String String[IP Address] -> Meal + ;; launch single client and register at specified host + ) + +(require "shared.rkt" 2htdp/universe 2htdp/image) + +; +; +; +; ; ; +; ; ; +; ; ; ;;; ; ;; ; ;;; ; ; +; ; ; ; ; ;; ; ;; ; ; ; +; ;;;;; ; ; ; ; ; ; ; +; ; ; ;;;;; ; ; ; ; ; +; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; +; ; ; ;;;; ; ; ; ; +; ; +; ;; +; + + +;; Image Constants +(define FOOD-IMG (bitmap "graphics/cupcake.gif")) +(define PLAYER-IMG (bitmap "graphics/hungry-henry.gif")) +(define BASE (empty-scene WIDTH HEIGHT)) +(define WAYPOINT-NODE (circle 3 'solid 'black)) +;; Color Constants +(define PLAYER-COLOR "red") +(define MY-COLOR "blue") +(define WAYPOINT-COLOR "green") +;; Text Constants +(define LOADING... "Waiting For Server") +(define TEXT-SIZE 20) +(define SCORE-SIZE 20) +(define TEXT-COLOR "black") +(define END-OPEN-TEXT "your score was: ") +(define END-CLOSE-TEXT ", the winner was player ") +(define LOADING-OPEN-TEXT "\nYou are ") +(define SEPERATOR ": ") +;; PBAR constants +(define PBAR-HEIGHT 35) +(define PBAR-LOC (- HEIGHT PBAR-HEIGHT)) +(define PBAR-COLOR "red") +(define PBAR-TEXT (text "loading..." 20 "black")) +;; Message ID Constants +(define UPDATE-LENGTH 3) +(define SPLAYER-LENGTH 3) +(define SBODY-LENGTH 2) +(define END-LENGTH 2) +(define SCORE-LIST-LENGTH 2) +;; Init Constants +(define ZERO% 0) +(define LOADING (text LOADING... 20 "black")) + +;; ----------------------------------------------------------------------------- +;; State of Client + +(struct app (id img countdown) #:transparent) +(struct entree (id players food) #:transparent) + +;; Meal is one of +;; - Appetizer +;; - Entree +;; Appetizer = (app [or Id #f] Image Number∈[0,1]) +;; interpretation: +;; -- the first field is this players id, #f if it hasnt been sent yet +;; -- the second is the loading image +;; -- the third is the %%% of loading time passed, represents the loading state +;; Entree = (entree Id [Listof Feaster] [Listof Food]) +;; interpretation: +;; -- the first field is this player's id +;; -- the second field represents complete information about all players +;; -- the third field specifies the location of the cupcakes + +(define INITIAL (app #f LOADING ZERO%)) + +; +; +; +; ; +; ; +; ;;; ;;; +; ;; ;; +; ; ; ; ; ;;;; ;;; ;; ;;; +; ; ; ; ; ; ; ; ;; ; +; ; ; ; ; ; ; ; ; +; ; ;; ; ;;;;;; ; ; ; +; ; ;; ; ; ; ; ; ; +; ; ; ; ; ; ; ; +; ; ; ; ;; ; ; ; +; ;;; ;;; ;;;; ;; ;;;;;;; ;;; ;;; +; +; +; +; +; + +(define (lets-eat label server) + (big-bang INITIAL + (to-draw render-the-meal) + (on-mouse set-waypoint) + (on-receive handle-server-messages) + (register server) + (name label))) + +;; Meal Message -> Meal +;; handles incomming messages +(define (handle-server-messages meal msg) + (cond [(app? meal) (handle-appetizer-message meal msg)] + [(entree? meal) (handle-entree-message meal msg)])) + +;; Meal Number Number MouseEvent -> Meal +;; handles what happends on a click +(define (set-waypoint meal x y event) + (if (and (entree? meal) (string=? event "button-down")) + (make-package meal (list GOTO x y)) + meal)) + +;; Meal -> Image +;; deals with draw some kind of meal +(define (render-the-meal meal) + (cond [(app? meal) (render-appetizer meal)] + [(entree? meal) (render-entree meal)])) + +; +; +; +; ;;;; ; +; ; ; +; ; ; ;;; ;;;; ;;; ;;; ; ; ;;; +; ; ; ; ; ; ; ; ; ; ; ; ; +; ;;;; ; ; ; ; ; ; ; ; ; ; +; ; ; ;;;;; ; ;;;;; ; ;; ;; ;;;;; +; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; +; ; ; ;;;; ;;;; ;;;; ; ; ;;;; +; +; +; + +;; ----------------------------------------------------------------------------- +;; Appetizer + +;; Appetizer Message -> Meal +;; starts the game if the message is valid +(define (handle-appetizer-message s msg) + (cond [(id? msg) (app msg (app-img s) (app-countdown s))] + [(time? msg) (app (app-id s) (app-img s) msg)] + [(state? msg) (switch-to-entree s msg)] + ;; fault tolerant + [else s])) + +;; Appetizer State -> Meal +(define (switch-to-entree s m) + (apply entree (app-id s) (rest m))) + +;; ----------------------------------------------------------------------------- +;; Appetizer + +;; Entree Message -> Meal +;; either updates the world or ends the game +(define (handle-entree-message s msg) + (cond [(state? msg) (update-entree s msg)] + [(score? msg) (restart s msg)] + [else s])) + +;; Entree State -> Entree +;; creates a new entree based on the update mesg +(define (update-entree s state-msg) + (apply entree (entree-id s) (rest state-msg))) + +;; Entree EndMessage -> Appetizer +;; Tranistion to start state +(define (restart s end-msg) + (define score-image (render-scores end-msg)) + (app (entree-id s) (above LOADING score-image) ZERO%)) + +;; ----------------------------------------------------------------------------- +;; predicates for recognizing network messages + +;; Message -> Boolean +;; checks if message is a valid update message +(define (state? msg) + (and (list? msg) + (= UPDATE-LENGTH (length msg)) + (symbol? (first msg)) + (list? (second msg)) + (list? (third msg)) + (symbol=? SERIALIZE (first msg)) + (andmap player? (second msg)) + (andmap body? (third msg)))) + +;; Message -> Boolean +;; checks if message is a valid time message +(define (time? msg) + (and (real? msg) (<= 0 msg 1))) + +;; Message -> Boolean +;; checks if is end game message +(define (score? msg) + (and (list? msg) + (= END-LENGTH (length msg)) + (symbol? (first msg)) + (list? (second msg)) + (symbol=? SCORE (first msg)) + (score-list? (second msg)))) + +;; List -> Boolean +;; is this a list binding names to scores? +(define (score-list? l) + (for/and ([s l]) + (and (list? s) + (= SCORE-LIST-LENGTH (length s)) + (id? (first s)) + (number? (second s))))) + +; +; +; +; ; +; ; +; ;;;;;; +; ; ; +; ; ; ;; ;; ;;;; ;;; ;; ;;; ;; ;;; ;;; ;; +; ; ; ;;; ; ; ; ; ; ; ;; ; ; ;; +; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; +; ;;;;;; ;;;;;; ;;;; ;; ; ; ;;;;;;; ;;; ;;; ;;; ; +; ; +; ;; +; ;;;; +; +; + +;; ----------------------------------------------------------------------------- +;; Appetizer Drawing + +;; Appetizer -> Image +;; tells the player that we're waiting for the server. shows id +(define (render-appetizer app) + (add-progress-bar (render-id+image app) (app-countdown app))) + +;; Image Number∈[0,1] -> Image +;; draws the progress bar +(define (add-progress-bar base count) + (place-image (render-progress count) (/ WIDTH 2) PBAR-LOC base)) + +;; Number∈[0,1] -> Image +;; draw a progress bar that is count percent complete +(define (render-progress count) + (overlay PBAR-TEXT (rectangle (* count WIDTH) PBAR-HEIGHT "solid" PBAR-COLOR))) + +;; Appetizer -> Image +;; gets the text to display on the loading screen +(define (render-id+image app) + (define id (app-id app)) + (define base-image (app-img app)) + (overlay + (cond + [(boolean? id) base-image] + [else (define s (string-append LOADING-OPEN-TEXT id)) + (above base-image (text s TEXT-SIZE TEXT-COLOR))]) + BASE)) + +;; ----------------------------------------------------------------------------- +;; Entree Drawing + +;; Entree -> Image +;; draws a Entree +(define (render-entree entree) + (define id (entree-id entree)) + (define pl (entree-players entree)) + (define fd (entree-food entree)) + (add-path id pl (add-players id pl (add-food fd BASE)))) + +;; [Listof Food] Image -> Image +;; draws all the food +(define (add-food foods base-scene) + (for/fold ([scn base-scene]) ([f foods]) + (place-image FOOD-IMG (body-x f) (body-y f) scn))) + +;; Id [Listof Feaster] Image -> Image +;; draws all players +(define (add-players id lof base-scene) + (for/fold ([scn base-scene]) ([feaster lof]) + (place-image (render-avatar id feaster) + (feaster-x feaster) (feaster-y feaster) + scn))) + +;; Id Feaster -> Image +;; gets an image for the player +(define (render-avatar id player) + (define size (body-size (player-body player))) + (define color + (if (id=? id (player-id player)) MY-COLOR PLAYER-COLOR)) + (above + (render-text (player-id player)) + (overlay (render-player-score player) + PLAYER-IMG + (circle size 'outline color)))) + +;; Feaster -> Image +;; Draw the players score +(define (render-player-score player) + (render-text (number->string (get-score (body-size (player-body player)))))) + +;; Id [Listof Feaster] Image -> Image +;; draws the path of the player whose id is passed in +(define (add-path id players base-scene) + (define player + (findf (lambda (x) (id=? id (player-id x))) players)) + (if (boolean? player) + base-scene + (add-waypoint* player base-scene))) + +;; Feaster Image -> Image +;; draws the list of way points to the scene +(define (add-waypoint* player base-scene) + (define loc (body-loc (player-body player))) + (define ways (player-waypoints player)) + (define-values (resulting-scene _) + (for/fold ([scn base-scene][from loc]) ([to ways]) + (values (add-waypoint from to scn) to))) + resulting-scene) + +;; Complex Complex Image -> Image +;; Add a waypoint to the scene at those coordinates +(define (add-waypoint from to s) + (define x-from (real-part from)) + (define y-from (imag-part from)) + (define x-to (real-part to)) + (define y-to (imag-part to)) + (define with-line (add-line s x-to y-to x-from y-from WAYPOINT-COLOR)) + (place-image WAYPOINT-NODE x-to y-to with-line)) + +;; ----------------------------------------------------------------------------- +;; render the end + +;; Score -> Image +;; draws the end of the game +(define (render-scores msg) + (define scores (sort (second msg) < #:key second)) + (for/fold ([img empty-image]) ([name-score scores]) + (define txt (get-text name-score)) + (above (render-text txt) img))) + +;; (list ID Natural) -> string +;; builds a string for that winning pair +(define (get-text name-score) + (define-values (name score) (apply values name-score)) + (string-append name SEPERATOR (number->string score))) + + +; +; +; +; +; +; ;;;;; +; ;; +; ; ; ;; ;; ;;; ;;; +; ; ; ; ; ; ; +; ; ; ; ; ; ; +; ; ; ; ; ;; +; ;;;;;; ; ; ;; +; ; ; ; ; ; ; +; ; ; ; ;; ; ; +; ;;; ;;; ;;; ;; ;;; ;;; +; +; +; +; +; + +;; String -> Image +;; draws the text +(define (render-text txt) + (text txt TEXT-SIZE TEXT-COLOR)) + +;; player -> Number +;; Gets the X coord of a entrees +(define (feaster-x feaster) + (body-x (player-body feaster))) + +;; player -> Number +;; Gets the Y coord of a entrees +(define (feaster-y feaster) + (body-y (player-body feaster))) + +;; body -> Number +;; gets the X coord of a body +(define (body-x body) + (real-part (body-loc body))) + +;; body -> Number +;; gets the Y coord of a body +(define (body-y body) + (imag-part (body-loc body))) + +; +; +; +; +; +; ;;;;;;;;; ; +; ; ; ; ; +; ; ; ; ;;;; ;;;; ; ;;;;;;; ;;;; ; +; ; ; ; ; ; ; ;; ; ; ;; +; ; ; ; ; ; ; +; ; ;;;;;;;; ;;;;; ; ;;;;; +; ; ; ; ; ; +; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; +; ;;;;; ;;;;; ;;;;;; ;;;; ;;;;;; +; +; +; +; +; + +(module+ test + + (require rackunit rackunit/text-ui) + + ;; testing main client + (check-equal? (switch-to-entree (app "foo" 'blah 1) '(STATE () ())) + (entree "foo" '()'())) + (check-equal? (handle-server-messages (app #f 'ksajfhsdkjhfr 1) .5) + (handle-appetizer-message (app #f 'ksajfhsdkjhfr 1) .5)) + ;;dispatch-mouse + (check-equal? (set-waypoint (app 1 LOADING 0) 1 1 "button-down") + (app 1 LOADING 0)) + (check-equal? (set-waypoint (app 1 LOADING 0) 1 1 "button-up") + (app 1 LOADING 0)) + (check-equal? (set-waypoint (app #f LOADING 0) 1 1 "button-down") + (app #f LOADING 0)) + (check-equal? (set-waypoint (app #f LOADING 0) 1 1 "button-up") + (app #f LOADING 0)) + (check-equal? (set-waypoint (entree "player1" (list (player "player1" (body 1 1+1i) empty)) empty) 1 1 "button-up") + (entree "player1" (list (player "player1" (body 1 1+1i) empty)) empty)) + (check-equal? (set-waypoint (entree "player1" (list (player "player1" (body 1 1+1i) empty)) empty) + 1 1 "button-down") + (make-package (entree "player1" (list (player "player1" (body 1 1+1i) empty)) empty) + (list 'goto 1 1))) + ;;render-the-meal + + ;; testing message receipt + ;; app-may-start + ;; entree-msg + ;; update-msg? + + (check-true (state? `(,SERIALIZE (,(player "player1" (body 1+4i 234) `()) ,(player "player1" (body 3 3) `())) + (,(body 1+i 2) ,(body 2 2))))) + (check-true (state? `(,SERIALIZE (,(player "player1" (body 1+4i 234) `())) + (,(body 1+i 2) ,(body 2 2))))) + (check-true (state? `(,SERIALIZE () + (,(body 1+i 2) ,(body 2 2))))) + (check-true (state? `(,SERIALIZE (,(player "player1" (body 1+4i 234) `()) ,(player "player1" (body 3 3) `())) + ()))) + + (check-false (state? `(,SERIALIZE (("player1" (1+4i 234) ()) ("player1" (3 3) ())) + ((1+i 2) (2 2))))) + (check-false (state? `(,SERIALIZE (("player1" (1+4i 234) ())) + ((1+i 2) (2 2))))) + (check-false (state? `(,SERIALIZE () + ((1+i 2) (2 2))))) + (check-false (state? `(,SERIALIZE (("player1" (1+4i 234) ()) ("player1" (3 3) ())) + ()))) + (check-true (state? `(,SERIALIZE () + ()))) + (check-false (state? `(,SERIALIZE (("player1" (1+4i 234) ()) ("player1" (3 3) ())) + ((1+i 2) (2 2))))) + (check-false (state? `(,SERIALIZE (("player1" (1+4i 234) ())) + ((1+i 2) (2 2))))) + (check-false (state? `(,SERIALIZE () + ((1+i 2) (2 2))))) + (check-false (state? `(,SERIALIZE (("player1" (1+4i 234) ()) ("player1" (3 3) ())) + ()))) + + (check-false (state? '(u ((1 1+4i 234)) + ((1+i 2) (2 2))))) + (check-false (state? '(((1 1+4i 234)) + ((1+i 2) (2 2))))) + (check-false (state? '(u ((1 1+4i)) + ((1+i 2) (2 2))))) + (check-false (state? '(u ((1 1+4i 234)) + ((1+i 2) (2 b))))) + (check-false (state? '(u ((1 1+4i 234))))) + (check-false (state? '(u ((1+i 2) (2 2))))) + (check-false (state? '(((1+i 2) (2 2))))) + (check-false (state? 4)) + (check-false (state? 'f)) + ;; score-list? + (check-true (score-list? '(("s" 0) ("l" 0) ("sdf" 0)))) + (check-true (score-list? empty)) + (check-true (score-list? '(("s" 0) ("l" 0)))) + (check-false (score-list? '(('s 0) ('l 0) ('sdf 0)))) + (check-false (score-list? '((s 0) (l 0)))) + (check-false (score-list? '((s) (l)))) + (check-false (score-list? '((s 0) (l 0)))) + ;; update-entree + (check-equal? (update-entree (entree "player10" '() '()) + `(s (,(player "player1" (body 10 10) `(3 4+9i)) + ,(player "player10" (body 103 10+4i) `(3 5+78i))) + (,(body 5 10) ,(body 30 30)))) + (entree "player10" (list (player "player1" (body 10 10) (list 3 4+9i)) + (player "player10" (body 103 10+4i) (list 3 5+78i))) + (list (body 5 10) (body 30 30)))) + + + ;; testing rendering the client + + ;; draw-app + (check-equal? (render-appetizer (app #f LOADING 0)) + (add-progress-bar (overlay LOADING + BASE) + 0)) + ;; draw-entree + + + ;; draw-players + + (check-equal? (add-players "player0" + (list (player "player1" (body 40 23+34i) empty) + (player "player0" (body 50 1+3i) empty)) + BASE) + (place-image (render-avatar "player0" (player "player0" (body 50 1+3i) empty)) + 1 3 + (place-image (render-avatar "player0" (player "player1" (body 40 23+34i) empty)) + 23 34 + BASE))) + (check-equal? (add-players "player0" + (list (player "player1" (body 40 23+34i) empty)) + BASE) + (place-image (render-avatar "player0" (player "player1" (body 40 23+34i) empty)) + 23 34 + BASE)) + + ;; draw-player + + ;; get-player-image + (check-equal? (render-avatar "player0" (player "player0" (body 30 1+3i) empty)) + (above (render-text "player0") + (overlay (text (number->string (get-score 30)) 20 'black) + PLAYER-IMG (circle 30 "outline" MY-COLOR)))) + (check-equal? (render-avatar "player0" (player "player1" (body 30 1+3i) empty)) + (above (render-text "player1") + (overlay (text (number->string (get-score 30)) 20 'black) + PLAYER-IMG (circle 30 "outline" PLAYER-COLOR)))) + + ;; draw-food + (check-equal? (add-food (list (body 34 54+3i) + (body 9 45+23i)) + BASE) + (place-image FOOD-IMG + 45 23 + (place-image + FOOD-IMG + 54 3 + BASE))) + (check-equal? (add-food (list (body 34 54+3i)) + BASE) + (place-image + FOOD-IMG + 54 3 + BASE)) + + + ;; testing auxiliary functions + ;; player-x + (check-equal? (feaster-x (player 20 (body 3 1+3i) empty)) + 1) + (check-equal? (feaster-x (player 20 (body 3 4+3i) empty)) + 4) + (check-equal? (feaster-x (player 20 (body 3 4+67i) empty)) + 4) + ;; player-y + (check-equal? (feaster-y (player 20 (body 3 1+3i) empty)) + 3) + (check-equal? (feaster-y (player 20 (body 3 4+3i) empty)) + 3) + (check-equal? (feaster-y (player 20 (body 3 4+67i) empty)) + 67) + + ;; body-x + (check-equal? (body-x (body 20 1+2i)) + 1) + (check-equal? (body-x (body 20 4+2i)) + 4) + (check-equal? (body-x (body 20 3+2i)) + 3) + ;; body-y + (check-equal? (body-y (body 20 4+1i)) + 1) + (check-equal? (body-y (body 20 1+4i)) + 4) + (check-equal? (body-y (body 20 3)) + 0) + + "client: all tests run") + diff --git a/chapter14/graphics/cupcake.gif b/chapter14/graphics/cupcake.gif new file mode 100644 index 0000000..20b1bef Binary files /dev/null and b/chapter14/graphics/cupcake.gif differ diff --git a/chapter14/graphics/hungry-henry.gif b/chapter14/graphics/hungry-henry.gif new file mode 100644 index 0000000..cce6948 Binary files /dev/null and b/chapter14/graphics/hungry-henry.gif differ diff --git a/chapter14/readme.txt b/chapter14/readme.txt new file mode 100644 index 0000000..042b0f4 --- /dev/null +++ b/chapter14/readme.txt @@ -0,0 +1,29 @@ +This chapter implements a distributed game, dubbed "Hungry Henry." + +TO PLAY, open the file + + run.rkt + +in DrRacket. The instructions for playing are at the top of the file. + +TO EXPERIMENT, open the files + + -- run.rkt + -- server.rkt + -- client.rkt + -- shared.rkt + +in four different tabs or windows in DrRacket. Switch to the 'run.rkt' +tab and select + + View | Show Module browser + +to see how these files are related. To switch to one of these four files, +you may click the boxes in the module browsers. Alternatively click the +tab you wish to work on. It is also possible to select tabs via key +strokes. + +Each file except for 'run.rkt' comes with test submodules at the bottom of +the file. + + diff --git a/chapter14/run.rkt b/chapter14/run.rkt new file mode 100644 index 0000000..4a244b7 --- /dev/null +++ b/chapter14/run.rkt @@ -0,0 +1,59 @@ +#lang racket + +#| + Hungry Henry, a multi-player, distributed game + ----------------------------------------------- + + This game is a multi-player competition for cupcakes. Each player owns an + avatar, called a "Henry", and competes for a limited number of cupcakes, + distributed over a rectangular space. A player launches her Henry via + a series of mouse clicks, so-called waypoints. Her Henry moves from waypoint + to waypoint. If it gets close enough to a cupcake, he eats the cupcake and + fattens up. As a Henry fattens up, he slows down. When all cupcakes are + consumed, the fattest Henry wins. + + Notes: + 1. The cupcakes remain in place until they are eaten. + 2. Once a waypoiny is recorded, it cannot be removed. + 3. Waypoints are visited in a first-come, first-serve order. + + Play + ---- + + Click Run. Evaluate + + (serve-dinner) + + in the Interactions Panel. This will pop up three windows: + -- Matthias, a game window + -- David, another game window + -- Universe, the game server's console + + Play. You can play the part of both participants. Alternatively, click + the David or Matthias window (to obtain focus) and click again to choose + a way point for David's or Matthias's "hungry henry". Watch the hungry + henries go for the cup cake and eat them up. You can make either one of them + win or you can force a tie. + + To run the game on two distinct computers: + + -- copy this folder to another computer, determine its IP number "12.345.67.98" + -- open run.rkt + -- evaluate + (bon-appetit) + + -- on your own computer, open run.rkt and run + -- evaluate + (lets-eat SomeNameAsAString "12.345.67.98") +|# + +(require (only-in "server.rkt" bon-appetit) + (only-in "client.rkt" lets-eat) + 2htdp/universe) + +;; launch server worlds for playtesting +(define (serve-dinner) + (launch-many-worlds + (bon-appetit) + (lets-eat "Matthias" LOCALHOST) + (lets-eat "David" LOCALHOST))) diff --git a/chapter14/server.rkt b/chapter14/server.rkt new file mode 100644 index 0000000..078533b --- /dev/null +++ b/chapter14/server.rkt @@ -0,0 +1,1065 @@ +#lang racket + +;; This module implements the server for the Hungry Henry game + +(provide + bon-appetit ;; -> Void + ;; launch the server for Hungry Henry + ) + +(require "shared.rkt" 2htdp/universe) + +#| ----------------------------------------------------------------------------- +The server is responsible for: +-- starting the game +-- moving Henrys +-- have Henrys eat, remove food on collision +-- collecting and broadcasting information about the movement of players +-- ending games +|# + +; +; +; +; ; ; ; ; +; ; ; ; ; +; ; ; ; ; ; ;; ;; ; ; ;;; ; ; ; ; ;;; ; ;; ; ;;; ; ; +; ; ; ; ; ;; ; ; ;; ;; ; ; ; ; ; ; ; ;; ; ;; ; ; ; +; ;;;;; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ; +; ; ; ;; ; ; ; ;; ; ; ; ; ; ;;;; ; ; ; ; +; ; ; ; +; ;;; ;; ;; +; + + +;; Init Constants +(define TICK .1) +(define PLAYER-LIMIT 2) +(define START-TIME 0) +(define WAIT-TIME 250) + +(define FOOD*PLAYERS 5) + +(define WEIGHT-FACTOR 2.1) +(define BASE-SPEED (/ (expt PLAYER-SIZE 2) WEIGHT-FACTOR)) + +;; Data Definitions +(struct join (clients [time #:mutable]) #:transparent) +(struct play (players food spectators) #:transparent #:mutable) + +;; plus some update primitives: + +;; JoinUniverse Player -> JoinUniverse +(define (join-add-player j new-p) + (join (cons new-p (join-clients j)) (join-time j))) + +;; PlayUniverse IP -> PlayUniverse +(define (play-add-spectator pu new-s) + (define players (play-players pu)) + (define spectators (play-spectators pu)) + (play players (play-food pu) (cons new-s spectators))) + +;; PlayUniverse IWorld -> PlayUniverse +;; removes player that uses iworld +(define (play-remove p iw) + (define players (play-players p)) + (define spectators (play-spectators p)) + (play (rip iw players) (play-food p) (rip iw spectators))) + +;; JoinUniverse IWorld -> JoinUniverse +;; removes players and spectators that use iw from this world +(define (join-remove j iw) + (join (rip iw (join-clients j)) (join-time j))) + +;; IWorld [Listof Player] -> [Listof Player] +;; remove player that contains the given IWorld +(define (rip iw players) + (remove iw players (lambda (iw p) (iworld=? iw (ip-iw p))))) + +;; LIKE: +;; (struct ip ip? ip-id ip-iw ip-body ip-waypoints ip-player) +(define-values + (ip ip? ip-id ip-iw ip-body ip-waypoints ip-player) + (let () + (struct ip (id iw body waypoints player) #:transparent) + (define (create iw id body waypoints) + (ip id iw body waypoints (player id body waypoints))) + (values + create ip? ip-id ip-iw ip-body ip-waypoints ip-player))) + +;; ServerState is one of +;; -- JoinUniverse +;; -- PlayUniverse +;; JoinUniververse = (join [Listof IPs] Nat) +;; interpretation: +;; -- the first field lists the currently connected client-player +;; -- the second field is the number of ticks since the server started +;; PlayUniverse = (play [Listof IPs] [Listof Food] [Listof IP]) +;; interpretation: +;; -- the first field lists all participating players +;; -- the second field lists the cupcakes +;; --- the third field enumerates the spectating players +;; IP = (ip Id IWorld Body [Listof Complex] Feaster) +;; interpretation: +;; the struct represents the Universe's perspective of a connected player +;; -- the first field is the assigned unique Id +;; -- the second field is the IWorld representing the remote connection to the client +;; -- the third field is the Body of the player +;; -- the fourth field is the list of player-chosen Waypoints, +;; ordered from oldest click to most-recent +;; meaning the first one has to be visited first by the Henry +;; -- the fifth field is the serialized representation of the first four fields + +(define JOIN0 (join empty START-TIME)) + +; +; +; +; +; ;;; ;;; ; +; ;; ;; +; ;; ;; ;;;; ;;; ;; ;; +; ; ; ; ; ; ; ;; ; +; ; ; ; ;;;;; ; ; ; +; ; ; ; ; ; ; ; +; ; ; ; ;; ; ; ; +; ;;; ;;; ;;; ;; ;;;;; ;;; ;;; +; +; +; +; + +(define (bon-appetit) + (universe JOIN0 + (on-new connect) + (on-msg handle-goto-message) + (on-tick tick-tock TICK) + (on-disconnect disconnect))) + +;; ServerState IWorld -> Bundle +;; adds a new connection to a JoinUniverse and ticks. Ignores otherwise +(define (connect s iw) + (cond [(join? s) (add-player s iw)] + [(play? s) (add-spectator s iw)])) + +;; ServerState IWorld Sexpr -> Bundle +;; accepts goto messages from clients +(define (handle-goto-message s iw msg) + (cond [(and (play? s) (goto? msg)) (goto s iw msg)] + [else (empty-bundle s)])) + +;; ServerState -> Bundle +;; handle a tick event +(define (tick-tock s) + (cond [(join? s) (wait-or-play s)] + [(play? s) (move-and-eat s)])) + +;; ServerState IWorld -> Bundle +;; handles loss of a client +(define (disconnect s iw) + (cond [(join? s) (drop-client s iw)] + [(play? s) (drop-player s iw)])) + +; +; +; +; ; ; ; ; +; ; ; ; +; ; ; ;;;; ;;; ;;;;; ;;; ; ;; ;; ; +; ; ; ; ; ; ; ; ;; ; ; ;; +; ; ; ; ; ; ; ; ; ; ; ; +; ;; ;; ;;;; ; ; ; ; ; ; ; +; ;; ;; ; ; ; ; ; ; ; ; ; +; ; ; ; ;; ; ; ; ; ; ; ;; +; ; ; ;; ; ; ;;; ; ; ; ;; ; +; ; +; ;;; +; + +;; JoinUniverse -> Bundle +;; count down and might transition +(define (wait-or-play j) + (cond [(keep-waiting? j) (keep-waiting j)] + [else (start-game j)])) + +;; JoinUniverse -> Boolean +;; is it time to start? +(define (keep-waiting? j) + (or (> PLAYER-LIMIT (length (join-clients j))) + (> WAIT-TIME (join-time j)))) + +;; JoinUniverse -> [Bundle JoinUniverse] +(define (keep-waiting j) + (set-join-time! j (+ (join-time j) 1)) + (time-broadcast j)) + +;; JoinUniverse -> [Bundle JoinUniverse] +;; broadcasts the new load time fraction to the players +(define (time-broadcast j) + (define iworlds (map ip-iw (join-clients j))) + (define load% (min 1 (/ (join-time j) WAIT-TIME))) + (make-bundle j (broadcast iworlds load%) empty)) + +;; JoinUniverse -> [Bundle PlayUniverse] +;; starts the game +(define (start-game j) + (define clients (join-clients j)) + (define cupcakes (bake-cupcakes (length clients))) + (broadcast-universe (play clients cupcakes empty))) + +;; Number -> [Listof Food] +;; creates the amount of food for that number of players +(define (bake-cupcakes player#) + (for/list ([i (in-range (* player# FOOD*PLAYERS))]) + (create-a-body CUPCAKE))) + +; +; +; ;;; +; ;;;; ; ; +; ; ; ; +; ; ; ; ;;;; ; ; ;;; ; ;; ;; ; +; ; ; ; ; ; ; ; ;; ; ; ;; +; ;;; ; ; ; ; ; ; ; ; ; +; ; ; ;;;; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ;; ; ; ; ; ; ;; +; ; ; ;; ; ; ; ; ; ;; ; +; ; ; +; ;; ;;; +; + +;; PlayUniverse -> Bundle +;; moves everything. eats. may end game +(define (move-and-eat pu) + (define nplayers (move-player* (play-players pu))) + (define nfood (feed-em-all nplayers (play-food pu))) + (progress nplayers nfood (play-spectators pu))) + +;; [Listof IP] -> [Listof IP] +;; moves all players +(define (move-player* players) + (for/list ([p players]) + (define waypoints (ip-waypoints p)) + (cond [(empty? waypoints) p] + [else (define body (ip-body p)) + (define nwpts + (move-toward-waypoint body waypoints)) + (ip (ip-iw p) (ip-id p) body nwpts)]))) + +;; Body [Listof Complex] -> [Listof Complex] +;; effect: set body's location +;; determine new waypoints for player +;; pre: (cons? waypoints) +(define (move-toward-waypoint body waypoints) + (define goal (first waypoints)) + (define bloc (body-loc body)) + (define line (- goal bloc)) + (define dist (magnitude line)) + (define speed (/ BASE-SPEED (body-size body))) + (cond + [(<= dist speed) + (set-body-loc! body goal) + (rest waypoints)] + [else ; (> distance speed 0) + (set-body-loc! body (+ bloc (* (/ line dist) speed))) + waypoints])) + +;; [Listof Player] [Listof Food] -> [Listof Food] +;; feeds all players and removes food +(define (feed-em-all players foods) + (for/fold ([foods foods]) ([p players]) + (eat-all-the-things p foods))) + +;; IP [Listof Food] -> [Listof Food] +;; effect: fatten player as he eats +;; determine left-over foods +(define (eat-all-the-things player foods) + (define b (ip-body player)) + (define (new-cupcakes) + (cond [(> (length foods) 10) '()] + [else + (for/list ([i (in-range (random 1 3))]) + (create-a-body CUPCAKE))])) + (for/fold ([foods '()]) ([f foods]) + (cond + [(body-collide? f b) + (set-body-size! b (+ PLAYER-FATTEN-DELTA (body-size b))) + (append foods (new-cupcakes))] + [else (cons f foods)]))) + +;; body body -> Boolean +;; Have two bodys collided? +(define (body-collide? s1 s2) + (<= (magnitude (- (body-loc s1) (body-loc s2))) + (+ (body-size s1) (body-size s2)))) + +;; [Listof Ip] [Listof Food] [Listof IP] -> Bundle +;; moves all objects. may end game +(define (progress pls foods spectators) + (define p (play pls foods spectators)) + (define (max-score) + (foldl (λ (pl max) + (let ([pl-score (cadr pl)]) + (if (> pl-score max) pl-score max))) + 0 (score pls))) + (define (end-game?) + (or (empty? foods) (> (max-score) 30))) + (cond [(end-game?) (end-game-broadcast p)] + [else (broadcast-universe p)])) + +;; PlayUniverse -> [Bundle JoinUniverse] +;; ends the game, and restarts it +(define (end-game-broadcast p) + (define iws (get-iws p)) + (define msg (list SCORE (score (play-players p)))) + (define mls (broadcast iws msg)) + (make-bundle (remake-join p) mls empty)) + +;; Play-Universe -> JoinUniverse +;; Readies the ServerState for a new game +(define (remake-join p) + (define players (refresh (play-players p))) + (define spectators (play-spectators p)) + (join (append players spectators) START-TIME)) + +;; [Listof Players] -> [Listof Players] +;; creates new players for new game +(define (refresh players) + (for/list ([p players]) + (create-player (ip-iw p) (ip-id p)))) + +;; [Listof IP] -> [Listof (list Id Score)] +;; makes the endgame message informing clients of all the size +(define (score ps) + (for/list ([p ps]) + (list (ip-id p) (get-score (body-size (ip-body p)))))) + +; +; +; +; +; ;;; ;;; +; ;; ;; +; ;; ;; ;;;; ;;;;; ;;;;; ;;;; ;;; ;; ;;;; ;;;;; +; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; +; ; ; ; ;;;;;; ;;;; ;;;; ;;;;; ; ; ;;;;;; ;;;; +; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ; +; ;;; ;;; ;;;;; ;;;;; ;;;;; ;;; ;; ;;; ; ;;;;; ;;;;; +; ; +; ;;;; +; +; + +;; ----------------------------------------------------------------------------- +;; Play Universe + +;; Message -> Boolean +;; checks if message is a drag +(define (goto? msg) + (and (list? msg) + (= GOTO-LENGTH (length msg)) + (symbol? (first msg)) + (number? (second msg)) + (number? (third msg)) + (symbol=? GOTO (first msg)) + (<= 0 (second msg) WIDTH) + (<= 0 (third msg) HEIGHT))) + +;; PlayUniverse IWorld GotoMessage -> PlayUniverse +;; handles a player clicking. checks for collisions, updates score, removes food +;; Effect: changes a player's waypoints +(define (goto p iw msg) + (define c (make-rectangular (second msg) (third msg))) + (set-play-players! p (add-waypoint (play-players p) c iw)) + (broadcast-universe p)) + +;; [Listof IPs] Complex IWorld -> [Listof IPs] +;; adds that complex to the waypoints of the given players +(define (add-waypoint ps c iw) + (for/list ([p ps]) + (cond [(iworld=? (ip-iw p) iw) + (ip (ip-iw p) + (ip-id p) + (ip-body p) + (append (ip-waypoints p) (list c)))] + [else p]))) + +; +; +; +; +; ;;;; ; +; ; ; ; +; ; ;;;; ;; ;; ;; ;; ;;;; ;;; ; ;;;;; ;;; ;;;; ;; ;; +; ; ; ; ;; ; ;; ; ; ; ; ;; ; ; ; ; ;; ; +; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;;; ;;;; ;;; ;;; ;;; ;;; ;;;;; ;;;; ;;; ;;;;; ;;;; ;;; ;;; +; +; +; +; + + +;; ----------------------------------------------------------------------------- +;; Join Universe + +;; [Universe Player -> Universe] -> [Universe IWorld -> [Bundle Universe]] +;; creates a function that deals with a new connection during join or play phase +(define (make-connection adder) + (lambda (u iw) + (define player (named-player iw)) + (define mails (list (make-mail iw (ip-id player)))) + (make-bundle (adder u player) mails empty))) + +;; JoinUniverse IWorld ID -> [Bundle JoinUniverse] +;; creates an internal player for the IWorld, adds it to Universe as waiting player +(define add-player (make-connection join-add-player)) + +;; PlayUniverse IWorld -> [Bundle PlayUniverse] +;; creates an internal player for the IWorld, adds it to Universe as spectator +(define add-spectator (make-connection play-add-spectator)) + +;; [Listof IP] IWorld ->* Player +(define (named-player iw) + (create-player iw (symbol->string (gensym (iworld-name iw))))) + +; +; +; +; +; ;;; ; ; ;; ; +; ; ;; ; +; ; ;;;; ;; ;;; ;;; ;;;; ; ;;; ;;;;; ;;;; +; ;;;; ; ; ;; ; ; ; ; ; ; ; ; ; +; ; ;;;;;; ; ; ;;;;; ; ; ; ;;;;;; +; ; ; ; ; ; ; ; ; ; ; +; ;; ; ; ; ; ; ;; ; ; ; ; ; +; ; ;;; ;;;;; ;;;;; ;;;;; ;;; ;; ;;;;; ;;;;; ;;;;; ;;;;; +; +; +; +; + +;; PlayUniverse -> [Bundle PlayUniverse [Listof [Mail StateMessage]]] +;; bundle this universe, serialize it, broadcast it, and drop noone +(define (broadcast-universe p) + (define mails (broadcast-for (get-ips p) p)) + (make-bundle p mails empty)) + +;; [Listof IWorlds] Message -> [Listof Mail] +;; sends mail to all clients +(define (broadcast iws msgs) + (map (lambda (iw) (make-mail iw msgs)) iws)) + +;; PlayUniverse -> (list s [Listof SerializedPlayer] [Listof SerializedFood]) +;; prepairs a message for an update world/ServerState state +(define (serialize-universe p) + (define serialized-players (map ip-player (play-players p))) + (list SERIALIZE serialized-players (play-food p))) + +;; [Listof IPs] PlayUniverse -> [Listof Mail] +;; generates mails for all clients +(define (broadcast-for ips p) + (define (mk-mail-for pl) + (make-mail (ip-iw pl) (serialize-universe-for pl p))) + (foldl (lambda (pl mails) (cons (mk-mail-for pl) mails)) '() ips)) + +;; IP PlayUniverse -> (list s [Listof SerializedPlayer] [ListOf SerializedFood]) +;; prepares message for an update world/ServerState state for a player +(define (serialize-universe-for pl p) + (list SERIALIZE + (serialize-players-for pl (play-players p)) + (play-food p))) + +;; IP IPs -> [ListOf SerializedPlayer] +;; prepares serialized list of players for the SERIALIZE message for a +;; player. +(define (serialize-players-for pl pls) + (define (filter-out waypoints) + (if (empty? waypoints) + waypoints + (list (first waypoints)))) + (define (mk-pl plyr) + (cond [(id=? (ip-id plyr) (ip-id pl)) (ip-player plyr)] + [else (player (ip-id plyr) + (ip-body plyr) + (filter-out (ip-waypoints plyr)))])) + (foldr (lambda (plyr srlzd-pls) (cons (mk-pl plyr) srlzd-pls)) '() pls)) + +; +; +; +; +; ;;;; ; +; ; ; ; +; ; ; ;;; ;;;;; ;;; ; ;;;; ;; ;; ;; ;; ;;;; ;;; ; ;;;;; +; ; ; ; ; ; ; ;; ; ; ;; ; ;; ; ; ; ; ;; ; +; ; ; ; ;;;; ; ; ; ; ; ; ; ;;;;;; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;;;; ;;;;; ;;;;; ;;;; ;;;; ;;; ;;; ;;; ;;; ;;;;; ;;;; ;;; +; +; +; +; + +;; JoinUniverse IWorld -> Bundle +;; remove that iworld from list of clients +(define (drop-client j iw) + (empty-bundle (join-remove j iw))) + +;; PlayUniverse IWorld -> Bundle +;; removes a player from the ServerState and tells the players +(define (drop-player p iw) + (broadcast-universe (play-remove p iw))) + +; +; +; +; +; ;; +; ; +; ; ; ;; ;; ;; ;; +; ; ; ; ; ; ; +; ; ; ; ; ;; +; ;;; ; ; ;; +; ; ; ; ;; ; ; +; ;;; ;;; ;; ;; ;; ;; +; +; +; +; + +;; Number -> Body +;; creates a random body, that does not touch the edge +(define (create-a-body size) + (define x (+ size (random (- WIDTH size)))) + (define y (+ size (random (- HEIGHT size)))) + (body size (make-rectangular x y))) + +;; PlayUniverse -> [Listof IWorlds] +;; gets the iworlds of all players +(define (get-iws p) + (map ip-iw (append (play-players p) (play-spectators p)))) + +;; PlayUnivers -> [Listof IP] +(define (get-ips p) + (append (play-players p) (play-spectators p))) + +;; ServerState -> Bundle +;; makes a bundle that sends no messages and disconnects noone +(define (empty-bundle s) + (make-bundle s empty empty)) + +;; IWorld Id -> IP +;; creates a player with that idnumber +(define (create-player iw n) + (ip iw n (create-a-body PLAYER-SIZE) empty)) + +; +; +; +; +; ;;;;;;; +; ; ; ; ; +; ; ;;;; ;;;;; ;;;;; ;;;;; +; ; ; ; ; ; ; ; ; +; ; ;;;;;; ;;;; ; ;;;; +; ; ; ; ; ; +; ; ; ; ; ; ; ; ; +; ;;; ;;;;; ;;;;; ;;; ;;;;; +; +; +; +; + +(module+ test + (require rackunit rackunit/text-ui) + + (define PROP-NUM 500) + (define do-prop (make-parameter #t)) + (do-prop #f) + + ;; thunk -> void + ;; runs the thunk PROP-NUM times + (define (check-property t) + (when (do-prop) (test-begin (doo PROP-NUM t)))) + + ;; doo : number thunk -> + ;; does the thunk n times + (define (doo n l) + (l) + (unless (zero? n) + (doo (sub1 n) l))) + + ;; testing main server + + ;; new-connection + + ;; drop-client + (check-equal? (drop-client (join (list (ip iworld1 "player1" (body 10 1+10i) empty) + (ip iworld2 "player2" (body 10 1+10i) empty) + (ip iworld3 "player3" (body 10 1+10i) empty)) 100) + iworld1) + (empty-bundle (join (list (ip iworld2 "player2" (body 10 1+10i) empty) + (ip iworld3 "player3" (body 10 1+10i) empty)) + 100))) + (check-equal? (drop-client (join (list (ip iworld1 "player1" (body 10 1+10i) empty) + (ip iworld2 "player2" (body 10 1+10i) empty) + (ip iworld3 "player3" (body 10 1+10i) empty)) 100) + iworld2) + (empty-bundle (join (list (ip iworld1 "player1" (body 10 1+10i) empty) + (ip iworld3 "player3" (body 10 1+10i) empty)) 100))) + (check-equal? (drop-client (join (list (ip iworld1 "player1" (body 10 1+10i) empty) + (ip iworld2 "player2" (body 10 1+10i) empty) + (ip iworld3 "player3" (body 10 1+10i) empty)) 100) + iworld3) + (empty-bundle (join (list (ip iworld1 "player1" (body 10 1+10i) empty) + (ip iworld2 "player2" (body 10 1+10i) empty)) 100))) + + ;; remove-player + (check-equal? (drop-player + (play (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld2 "player345" (body 56 3+45i) empty)) + (list (body 87 67+23i) + (body 5 3+4i)) + empty) + iworld1) + (let ([remd (play-remove + (play (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld2 "player345" (body 56 3+45i) empty)) + (list (body 87 67+23i) + (body 5 3+4i)) + empty) + iworld1)]) + (broadcast-universe remd) + #; + (make-bundle remd (serial/broadcast-univ remd) empty))) + + (check-equal? (drop-player + (play (list (ip iworld2 "player345" (body 56 3+45i) empty)) + (list (body 87 67+23i) + (body 5 3+4i)) + (list (ip iworld1 "player10" (body 10 1+10i) empty))) + iworld1) + (let ([remd (play-remove + (play (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld2 "player345" (body 56 3+45i) empty)) + (list (body 87 67+23i) + (body 5 3+4i)) + empty) + iworld1)]) + (broadcast-universe remd) + #; + (make-bundle remd (serial/broadcast-univ remd) empty))) + + ;; ready-to-go + (check-false (keep-waiting? (join (list (create-player iworld1 "player") + (create-player iworld2 "player")) + 250))) + (check-false (keep-waiting? (join (list (create-player iworld1 "player") + (create-player iworld1 "player") + (create-player iworld2 "player")) + 456345132135213))) + (check-true (keep-waiting? (join (list (create-player iworld2 "player")) -234))) + (check-true (keep-waiting? (join (list (create-player iworld2 "player")) 10))) + + + + ;; handle-join + ;; name + ;; update-player + + ;; remove-player-by-iworld + (check-equal? (play-remove + (play (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld2 "player324" (body 56 3+45i) empty)) + (list (body 87 67+23i) + (body 5 3+4i)) + empty) + iworld1) + (play (list (ip iworld2 "player324" (body 56 3+45i) empty)) + (list (body 87 67+23i) + (body 5 3+4i)) + empty) + empty) + (check-equal? (play-remove + (play (list (ip iworld2 "player324" (body 56 3+45i) empty)) + (list (body 87 67+23i) + (body 5 3+4i)) + empty) + iworld2) + (play (list) + (list (body 87 67+23i) + (body 5 3+4i)) + empty)) + + ;; testing messaging + + ;; goto? + + (check-true (goto? '(goto 3 2))) + (check-true (goto? '(goto 3 2))) + (check-true (goto? '(goto 0 2))) + (check-true (goto? '(goto 6 2))) + (check-false (goto? `(goto ,(add1 WIDTH) 0))) + (check-false (goto? `(goto 0 ,(add1 HEIGHT)))) + (check-false (goto? '(goto -1 0))) + (check-false (goto? '(goto 0 -1))) + (check-false (goto? '(goto 1))) + (check-false (goto? '(drag 6+2i))) + (check-false (goto? '(drag 1))) + (check-false (goto? '(6+1i))) + (check-false (goto? '(1 2))) + (check-false (goto? '(goto 6+2i))) + (check-false (goto? '(drag 1 2))) + (check-false (goto? 'click)) + (check-false (goto? "click")) + (check-false (goto? #t)) + + ;;add-waypoint + + (check-equal? (add-waypoint `(,(ip iworld1 "player10" (body 10 1+10i) empty)) 8+9i iworld1) + (list (ip iworld1 "player10" (body 10 1+10i) '(8+9i)))) + (check-equal? (add-waypoint `(,(ip iworld1 "player10" (body 10 1+10i) '(23+45i))) 8+9i iworld1) + (list (ip iworld1 "player10" (body 10 1+10i) '(23+45i 8+9i)))) + + ;; goto + + (check-equal? (goto (play (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld2 "player345" (body 56 3+45i) empty)) + (list (body 87 67+23i) + (body 5 3+4i)) + empty) + iworld1 '(goto 1 1)) + (let ([state (play (list (ip iworld1 "player10" (body 10 1+10i)'(1+1i)) + (ip iworld2 "player345" (body 56 3+45i) empty)) + (list (body 87 67+23i) + (body 5 3+4i)) + empty)]) + (broadcast-universe state) + #; + (make-bundle state (serial/broadcast-univ state) empty))) + + (check-equal? (goto (play (list (ip iworld1 "player10" (body 10 1+10i) '(1+4i)) + (ip iworld2 "player345" (body 56 3+45i) empty)) + (list (body 87 67+23i) + (body 5 3+4i)) + empty) + iworld1 '(goto 1 1)) + (let ([state (play (list (ip iworld1 "player10" (body 10 1+10i) '(1+4i 1+1i)) + (ip iworld2 "player345" (body 56 3+45i) empty)) + (list (body 87 67+23i) + (body 5 3+4i)) + empty)]) + (broadcast-universe state) + #; + (make-bundle state (serial/broadcast-univ state) empty))) + + ;; eat-all-the-things + (check-pred >= (length (eat-all-the-things (ip iworld1 "player10" (body 11 0) '(1+10i)) (list (body 10 0)))) + 1) + (check-equal? (eat-all-the-things (ip iworld1 "player10" (body 10 0) '(1+10i)) (list (body 10 40+5i))) + (list (body 10 40+5i))) + + ;; testing initialization + + ;; property of no motion to same point in move-body + ;; also checks for divide by zero error in move-player* + (define (property:no-same-point) + (define (random-near n) + (define ε 1/1000000) + (+ n (* (random 10) ε (sub1 (* 2 (random 2)))))) + + (define test-body (create-a-body 1)) + + (define waypoints + (for/list ([r (in-range (add1 (random 100)))]) + (define x (real-part (body-loc test-body))) + (define y (imag-part (body-loc test-body))) + (make-rectangular (random-near x) (random-near y)))) + + (define random-p (ip iworld1 "nope" test-body waypoints)) + + (define (test p) + (cond [(empty? (ip-waypoints p)) + #t] + [(= (first (ip-waypoints p)) + (body-loc (ip-body p))) + #f] + [else (test (move-player* (list p)))])) + + (check-true (test random-p))) + + ;; does spawn food create the nessecary amount of food? + (define (property:player/food-number-correct) + (define players (random 50)) + (check-equal? (length (bake-cupcakes players)) + (* FOOD*PLAYERS players))) + + ;; is random-body on the board? + (define (test-body-in-bounds) + (define size 10) + (define body (create-a-body size)) + (check-true (and (< size (real-part (body-loc body)) (- WIDTH size)) + (< size (imag-part (body-loc body)) (- HEIGHT size))) + "body out of bounds")) + + + + + ;;create-name + ;; (check-equal? (create-name empty "john") "john") + ;; (check-equal? (create-name (list (ip iworld1 "player10" (body 10 0) '(1+10i))) "player10") "player10*") + #; + (check-equal? (create-name (list (ip iworld1 "player10" (body 10 0) '(1+10i)) + (ip iworld1 "player10*" (body 10 0) '(1+10i))) + "player10") + "player10**") + #; + (check-property property:unique-name) + + ;; spawn-food + (check-property property:player/food-number-correct) + + ;; random-body + (check-property test-body-in-bounds) + + ;; testing clock tick handling + + (define tbody1 (body 100 1+3i)) + (define tbody2 (body 100 1)) + (define tbody3 (body 100 0+3i)) + (define tbody4 (body 100 101)) + + (define waypoints1 '(1+3i 1 0+3i 10+10i)) + (define waypoints2 '(100)) + + ;; move-player* + (check-equal? (move-player* + (list (ip iworld1 "player10" (body 10 1+10i) '(1+10.01i)))) + (list (ip iworld1 "player10" (body 10 1+10.01i) empty))) + (check-property property:no-same-point) + ;; move-twards-waypoint + + + (test-begin + (check-equal? (move-toward-waypoint tbody1 waypoints1) + (rest waypoints1) + "waypoint removal failed") + (check-equal? tbody1 (body 100 1+3i) "movement failed") + (set! tbody1 (body 100 1+3i))) + + (test-begin + ;; test dependent on (< BASE-SPEED 100) + (check-equal? (move-toward-waypoint tbody2 waypoints2) + waypoints2 + "waypoint removal failed") + (check-equal? tbody2 (body 100 (+ 1 (make-rectangular (/ BASE-SPEED 100) 0))) + "movement failed") + (set! tbody2 (body 100 1))) + + (test-begin + (check-equal? (move-toward-waypoint tbody4 waypoints2) + '()) + (check-equal? tbody4 (body 100 100)) + (set! tbody4 (body 100 101))) + + ;; countdown + (check-equal? (wait-or-play (join (list (ip iworld1 "player10" (body 10 1+10i) empty)) 0)) + (make-bundle + (join (list (ip iworld1 "player10" (body 10 1+10i) empty)) 1) + (broadcast (list iworld1) (/ 1 WAIT-TIME)) + empty)) + (check-equal? (wait-or-play (join empty 0)) + (empty-bundle (join empty 1))) + + ;;countdown + (check-equal? (wait-or-play (join (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld1 "player345" (body 56 3+45i) empty)) + 100)) + (make-bundle (join (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld1 "player345" (body 56 3+45i) empty)) + 101) + (broadcast (list iworld1 iworld1) (/ 101 WAIT-TIME)) + empty)) + (check-equal? (wait-or-play (join (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld1 "player345" (body 56 3+45i) empty)) + 1)) + (make-bundle (join (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld1 "player345" (body 56 3+45i) empty)) + 2) + (broadcast (list iworld1 iworld1) (/ 2 WAIT-TIME)) + empty)) + ;; progress + (check-equal? (progress + (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld1 "player345" (body 56 3+45i) empty)) + (list (body 87 67+23i) + (body 5 3+4i)) + empty) + (broadcast-universe + (play (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld1 "player345" (body 56 3+45i) empty)) + (list (body 87 67+23i) + (body 5 3+4i)) + empty)) + #; + (make-bundle + (play (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld1 "player345" (body 56 3+45i) empty)) + (list (body 87 67+23i) + (body 5 3+4i)) + empty) + (serial/broadcast-univ (play (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld1 "player345" (body 56 3+45i) empty)) + (list (body 87 67+23i) + (body 5 3+4i)) + empty)) + empty)) + + ;; body-collide? + (check-true (body-collide? (body 10 10+10i) (body 10 10+10i))) + (check-true (body-collide? (body 10 10+10i) (body 10 0+10i))) + (check-true (body-collide? (body 10 10+10i) (body 10 10))) + (check-true (body-collide? (body 10 10+10i) (body 10 20))) + (check-true (body-collide? (body 10 10+10i) (body 10 0+20i))) + + (check-false (body-collide? (body 1 10+10i) (body 1 10+13i))) + (check-false (body-collide? (body 1 10+10i) (body 1 0+10i))) + (check-false (body-collide? (body 1 10+10i) (body 1 10))) + (check-false (body-collide? (body 1 10+10i) (body 1 20))) + (check-false (body-collide? (body 1 10+10i) (body 1 0+20i))) + + ;; serial/broadcast-univ + #; + (check-equal? (serial/broadcast-univ + (play (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld2 "player345" (body 56 3+45i) empty)) + (list (body 87 67+23i) + (body 5 3+4i)) + empty)) + (let ([serialized (serialize-universe (play (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld2 "player345" (body 56 3+45i) empty)) + (list (body 87 67+23i) + (body 5 3+4i)) + empty))]) + (list (make-mail iworld1 serialized) + (make-mail iworld2 serialized)))) + + ;; time-broadcast + (let ([j (join '() 100)]) + (check-equal? (time-broadcast j) + (make-bundle j '() '()))) + (let ([j (join `(,(ip iworld1 "sallyjoe" (body 0 0+0i) '())) 100)]) + (check-equal? (time-broadcast j) + (make-bundle j `(,(make-mail iworld1 (/ 100 WAIT-TIME))) '()))) + + ;; testing auxiliary functions + (check-equal? (score `(,(ip iworld1 "foo" (body 1000 +inf.0) '()) + ,(ip iworld1 "bar" (body 0 +inf.0) '()))) + `(("foo" ,(get-score 1000)) + ("bar" ,(get-score 0)))) + ;; get-iws + ;; empty-bundle + (check-equal? (empty-bundle (join (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld2 "player345" (body 56 3+45i) empty)) 132)) + (make-bundle (join (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld2 "player345" (body 56 3+45i) empty)) 132) empty empty)) + (check-equal? (empty-bundle (join (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld2 "player345" (body 56 3+45i) empty)) 345)) + (make-bundle (join (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld2 "player345" (body 56 3+45i) empty)) 345) empty empty)) + (check-equal? (empty-bundle (play (list (ip iworld1 "player1" (body 87 67+23i) empty)) + (list (body 87 67+23i) + (body 89 32+345i)) + empty)) + (make-bundle + (play (list (ip iworld1 "player1" (body 87 67+23i) empty)) + (list (body 87 67+23i) + (body 89 32+345i)) + empty) + empty + empty)) + + ;; get-iws + (check-equal? (get-iws (play (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld2 "player345" (body 56 3+45i) empty)) + (list (body 87 67+23i) + (body 5 3+4i)) + empty)) + (list iworld1 iworld2)) + (check-equal? (get-iws (play (list (ip iworld1 "player10" (body 10 1+10i) empty)) + empty + empty)) + (list iworld1)) + + ;; get-ips + (let ([players (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld2 "player345" (body 56 3+45i) empty))] + [spectators (list (ip iworld1 "player10" (body 15 2+65i) empty))]) + (check-equal? (get-ips (play players + (list (body 87 67+23i) + (body 5 3+4i)) + spectators)) + (append players spectators)) + (check-equal? (get-ips (play (list (first players)) + (list (body 87 67+23i) + (body 5 3+4i)) + empty)) + (append (list (first players)) empty))) + + ;; broadcast + (check-equal? (broadcast (list iworld1 iworld3 iworld2) + '(testing testing 1 2 3)) + (let ([message '(testing testing 1 2 3)]) + (list (make-mail iworld1 + message) + (make-mail iworld3 + message) + (make-mail iworld2 + message)))) + (check-equal? (broadcast (list iworld1) + '(testing testing 1 2 3)) + (let ([message '(testing testing 1 2 3)]) + (list (make-mail iworld1 + message)))) + (check-equal? (broadcast (list iworld1 iworld3) + 9) + (let ([message 9]) + (list (make-mail iworld1 + message) + (make-mail iworld3 + message)))) + + ;; broadcast-state + (let ([state (play (list (ip iworld1 "player10" (body 10 1+10i) empty) + (ip iworld2 "player345" (body 56 3+45i) empty)) + (list (body 87 67+23i) + (body 5 3+4i)) + empty)]) + (check-equal? (broadcast-universe state) + (broadcast-universe state))) + + ;; serialize-players-for + (let* ([waypoints1 (list (make-rectangular 383 212) + (make-rectangular 282 192))] + [waypoints2 (list (make-rectangular 918 319) + (make-rectangular 481 119) + (make-rectangular 129 321))] + [pls (list (ip iworld1 "player10" (body 10 1+10i) waypoints1) + (ip iworld2 "player345" (body 56 3+45i) waypoints2))] + [pl (first pls)]) + (check-equal? (player-waypoints (first (serialize-players-for pl pls))) + waypoints1) + (check-equal? (player-waypoints (second (serialize-players-for pl pls))) + (list (make-rectangular 918 319)))) + + "server: all tests run") diff --git a/chapter14/shared.rkt b/chapter14/shared.rkt new file mode 100644 index 0000000..7f3a549 --- /dev/null +++ b/chapter14/shared.rkt @@ -0,0 +1,156 @@ +#lang racket + +;; This module describes the shared vocabulary and knowledge for the server +;; and client modules of the Hungry Henry game. + +(provide ;; type Id + id? ;; Any -> Boolean : Id + id=? ;; Id Id -> Boolean + ;; type GOTO + ;; type SOTO = Time | Ackn | State | Score + ;; type Food + ;; type Feaster + ;; type Body + (struct-out player) ;; + (struct-out body) ;; + get-score ;; Nat -> Nat + PLAYER-FATTEN-DELTA + WIDTH HEIGHT CUPCAKE PLAYER-SIZE + SCORE GOTO SERIALIZE + GOTO-LENGTH) + +#| ----------------------------------------------------------------------------- + +;; --- Tasks -------------------------------------------------------------------- + +The game server keeps track of the entire game state [to avoid cheating by +lients]. It collects waypoints, moves the avatars on behalf of the clients, +detects collisions with cupcakes, has avatars eat and grow, and discovers the +end of the game. As events occur, it informs all clients about all actions and, +at the end of the game, tallies the scores. + +Each client displays the current state of the game as broadcast by the server. +It also records and sends all mouse clicks to the server. + +;; --- Messages and Protocol --------------------------------------------------- + +The server and the client exchange messages to inform each other about +the events in the game. + +Client To Server Message: +------------------------ + + GOTO = (list GOTO PositiveNumber PositiveNumber) + represents the coordinates of player's latest waypoint, + obtained via a mouse click. + Constraint: in (list GOTO x y), (and (<= 0 x WIDTH) (<= 0 y HEIGHT)) + +Server to Client Message: +------------------------- + + SOTO is one of: + -- Number ∈ [0,1] + called a Time message + repreents the percentage of loading time left + -- ID + called an Ackn message + represents the unique id that the server assigns to the client, + based on the client's name + -- (list SERIALIZE [Listof Feaster] [Listof Food]) + called a State message + represents the complete current state of the game + -- (list SCORE [Listof (list Id Natural)]) + called a Score message + informs clients that the game is over and the sizes of each player. +|# +;; Shared Data Definitions for Messages + +(struct player (id body waypoints) #:prefab) +(struct body (size loc) #:prefab #:mutable) +;; Food = Body +;; Feaster = (player Id Body [Listof Complex]) +;; interpretation: +;; -- id is the player's id +;; -- body is the player's size and location +;; -- loc are the player's waypoints, ordered from first to last +;; Body = (body PositiveNumber Complex) +;; interpretation: any 'body' on the playing field, both players and cupcakes +;; -- the postive number specifies the body's size +;; -- the complex number represents the body's location +;; PlayerId = String +(define id? string?) +(define id=? string=?) + +;; Message ID Constants +(define SCORE 'score) +(define SERIALIZE 'state) +(define GOTO 'goto) +(define GOTO-LENGTH 3) + +#| --- Protocol ---------------------------------------------------------------- + + Client1 Client2 Server + | | | + | register(name1) | [universe protocol] + |----------------------------->| + | | | + | | ID | an identifier message + |<-----------------------------| + | | t | percentage of wait time + |<-----------------------------| + |<-----------------------------| + |<-----------------------------| + | | | + | | register(name2) + | |------------->| + | | | + | | ID | + | |<-------------| + | | t | percentage of wait time + |<-----------------------------| + | |<-------------| + |<-----------------------------| + | |<-------------| + | | | <==== end of wait time [clock, players] + | state msg | + |<-----------------------------| `(state (,feaster1 ,feaster2) ,foods) + | |<-------------| + | | | + click | GOTO | | `(goto ,x ,y) + ====> |----------------------------->| new state + | | | + | state msg | + |<-----------------------------| `(state (,feaster1 ,feaster2) ,foods) + | |<-------------| + | | | + | | | move, eat: + |<-----------------------------| `(state (,feaster1 ,feaster2) ,foods) + | |<-------------| + | | | + | click | GOTO | `(goto ,x ,y) + | ====> |------------->| + | | | + | state msg | + |<-----------------------------| `(state (,feaster1 ,feaster2) ,foods) + | |<-------------| + | | | + | score msg | all food is eaten: + |<-----------------------------| `(score ((,id ,score) ...)) + | |<-------------| + | | | + --- --- --- + +|# + +;; Shared Logical Constants +(define WIDTH 1000) +(define HEIGHT 700) +(define CUPCAKE 15) +(define PLAYER-SIZE (* 3 CUPCAKE)) +(define PLAYER-FATTEN-DELTA 5) + +;; Number -> Number ;; move to serer +;; gets aplayers score given its fatness +(define (get-score f) + (/ (- f PLAYER-SIZE) PLAYER-FATTEN-DELTA)) + diff --git a/chapter2/guess.rkt b/chapter2/guess.rkt new file mode 100644 index 0000000..ab05056 --- /dev/null +++ b/chapter2/guess.rkt @@ -0,0 +1,21 @@ +#lang racket + +(define lower 1) + +(define upper 100) + +(define (start n m) + (set! lower (min n m)) + (set! upper (max n m)) + (guess)) + +(define (guess) + (quotient (+ lower upper) 2)) + +(define (smaller) + (set! upper (max lower (sub1 (guess)))) + (guess)) + +(define (bigger) + (set! lower (min upper (add1 (guess)))) + (guess)) diff --git a/chapter5/guess.rkt b/chapter5/guess.rkt new file mode 100644 index 0000000..f7a117a --- /dev/null +++ b/chapter5/guess.rkt @@ -0,0 +1,75 @@ +#lang racket +(require 2htdp/universe 2htdp/image) + +(struct interval (small big guesses)) + +;;; constants +(define TEXT-SIZE 12) +(define HELP-TEXT + (text "↑ for larger numbers, ↓ for smaller ones" + TEXT-SIZE + "blue")) +(define HELP-TEXT2 + (text "Press = when your number is guessed; q to quit." + TEXT-SIZE + "blue")) +(define COLOR "red") +(define WIDTH (+ (image-width HELP-TEXT2) 10)) +(define HEIGHT 150) +(define SIZE 72) +(define TEXT-X 3) +(define TEXT-UPPER-Y 10) +(define TEXT-LOWER-Y 135) +(define GUESSES-SIZE 12) +(define GUESSES-COLOR "green") +(define MT-SC + (place-image/align + HELP-TEXT TEXT-X TEXT-UPPER-Y "left" "top" + (place-image/align + HELP-TEXT2 TEXT-X TEXT-LOWER-Y "left" "bottom" + (empty-scene WIDTH HEIGHT)))) + +;; main +(define (start lower upper) + (big-bang (interval lower upper 0) + (on-key deal-with-guess) + (to-draw render) + (stop-when single? render-last-scene))) + +;; key events +(define (deal-with-guess w key) + (cond [(key=? key "up") (bigger w)] + [(key=? key "down") (smaller w)] + [(key=? key "q") (stop-with w)] + [(key=? key "=") (stop-with w)] + [else w])) + +(define (smaller w) + (interval (interval-small w) + (max (interval-small w) (sub1 (guess w))) + (+ 1 (interval-guesses w)))) + +(define (bigger w) + (interval (min (interval-big w) (add1 (guess w))) + (interval-big w) + (+ 1 (interval-guesses w)))) + +(define (guess w) + (quotient (+ (interval-small w) (interval-big w)) 2)) + +(define (render w) + (overlay (overlay/offset + (text (number->string (guess w)) SIZE COLOR) 0 40 + (text (number->string (interval-guesses w)) + GUESSES-SIZE GUESSES-COLOR)) + MT-SC)) + +(define (render-last-scene w) + (overlay (overlay/offset + (text "End" SIZE COLOR) 0 40 + (text (number->string (interval-guesses w)) + GUESSES-SIZE GUESSES-COLOR)) + MT-SC)) + +(define (single? w) + (= (interval-small w) (interval-big w))) diff --git a/chapter5/loco.rkt b/chapter5/loco.rkt new file mode 100644 index 0000000..977c976 --- /dev/null +++ b/chapter5/loco.rkt @@ -0,0 +1,59 @@ +#lang racket +(require 2htdp/universe 2htdp/image) + +(define WIDTH 300) +(define HEIGHT 300) +(define CAROILLE (bitmap/file "resources/caroille.png")) +(define CAROILLE-WIDTH (image-width CAROILLE)) + +;;; +;;; If the car is placed at X = 1/2 its width, its back will be +;;; touching the left edge of the World. +;;; +;;; If the car is place at X = - 1/2 its width, its front will be touching +;;; the left edge of the World. +;;; +(define CAROILLE-WIDTH-HALF (/ CAROILLE-WIDTH 2.0)) + +;;; Structure to represent the X position of two cars in animation. +(struct cars (one two)) + +(define (caroille-past-right-edge? pos) + (> pos (- WIDTH CAROILLE-WIDTH-HALF))) + +(define (caroille-fully-past-right-edge? pos) + (>= pos (+ WIDTH CAROILLE-WIDTH-HALF))) + +(define (caroille-fully-past-left-edge? pos) + (>= pos CAROILLE-WIDTH-HALF)) + +(define (caroille-fully-inside? pos) + (and (caroille-fully-past-left-edge? pos) + (not (caroille-past-right-edge? pos)))) + +(define (move caroilles) + (let ((caroille-one (cars-one caroilles)) + (caroille-two (cars-two caroilles))) + (cond + ;; Case set I - one of the cars is fully inside. + ((caroille-fully-inside? caroille-one) + (cars (+ 1 caroille-one) caroille-two)) + ((caroille-fully-inside? caroille-two) + (cars caroille-one (+ 1 caroille-two))) + ;; Case set II - one of the cars disappeared into the right edge. + ((caroille-fully-past-right-edge? caroille-one) + (cars (- CAROILLE-WIDTH-HALF) (+ 1 caroille-two))) + ((caroille-fully-past-right-edge? caroille-two) + (cars (+ 1 caroille-one) (- CAROILLE-WIDTH-HALF))) + ;; Case else - Both cars are partially out. + (else (cars (+ 1 caroille-one) (+ 1 caroille-two)))))) + +(define (draw-cars caroilles) + (place-image CAROILLE (cars-one caroilles) (/ HEIGHT 2) + (place-image CAROILLE (cars-two caroilles) (/ HEIGHT 2) + (empty-scene WIDTH HEIGHT)))) + +(define (start) + (big-bang (cars CAROILLE-WIDTH-HALF (- CAROILLE-WIDTH-HALF)) + (on-tick move) + (to-draw draw-cars))) diff --git a/chapter5/resources/caroille.png b/chapter5/resources/caroille.png new file mode 100644 index 0000000..052cc58 Binary files /dev/null and b/chapter5/resources/caroille.png differ diff --git a/chapter5/resources/caroille.svg b/chapter5/resources/caroille.svg new file mode 100644 index 0000000..eb4db63 --- /dev/null +++ b/chapter5/resources/caroille.svg @@ -0,0 +1,125 @@ + + + + + caroille + + + + + + + + image/svg+xml + + caroille + + 2018-04-02 + + + rsiddharth <s@ricketyspace.net> + + + + + car + + + + + + + + + + + + + + + + + + + diff --git a/chapter5/resources/ufo-fart.png b/chapter5/resources/ufo-fart.png new file mode 100644 index 0000000..13d1c4a Binary files /dev/null and b/chapter5/resources/ufo-fart.png differ diff --git a/chapter5/resources/ufo-fart.svg b/chapter5/resources/ufo-fart.svg new file mode 100644 index 0000000..cf86021 --- /dev/null +++ b/chapter5/resources/ufo-fart.svg @@ -0,0 +1,188 @@ + + + + + UFO Fart + + + + + + image/svg+xml + + UFO Fart + + 2018-04-17 + + + rsiddharth <s@ricketyspace.net> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/chapter5/resources/zarking-ufo.png b/chapter5/resources/zarking-ufo.png new file mode 100644 index 0000000..bd5eb43 Binary files /dev/null and b/chapter5/resources/zarking-ufo.png differ diff --git a/chapter5/resources/zarking-ufo.svg b/chapter5/resources/zarking-ufo.svg new file mode 100644 index 0000000..84b8844 --- /dev/null +++ b/chapter5/resources/zarking-ufo.svg @@ -0,0 +1,128 @@ + + + + + Zarking UFO + + + + + + image/svg+xml + + Zarking UFO + + 2018-03-09 + + + rsiddharth <s@ricketyspace.net> + + + + + + + + + + + + + + + + + + + + diff --git a/chapter5/ufo.rkt b/chapter5/ufo.rkt new file mode 100644 index 0000000..6f8136c --- /dev/null +++ b/chapter5/ufo.rkt @@ -0,0 +1,86 @@ +#lang racket +(require 2htdp/universe 2htdp/image) + +;;; world structure +(struct ufo (x y fart)) + +;;; constants +(define WORLD-WIDTH 300) +(define WORLD-HEIGHT 325) +(define MOVE-LEN 3) +(define UFO (bitmap/file "resources/zarking-ufo.png")) +(define UFO-FART (bitmap/file "resources/ufo-fart.png")) +(define UFO-WIDTH (image-width UFO)) +(define UFO-HEIGHT (image-height UFO)) +(define UFO-FART-HEIGHT (image-height UFO-FART)) + +;;; ufo movement functions +(define (ufo-move-up current-state) + (let ((x (ufo-x current-state)) + (y-up (- (ufo-y current-state) MOVE-LEN)) + (fart #t)) + (cond [(>= y-up (+ (/ UFO-HEIGHT 2) (/ UFO-FART-HEIGHT 2))) + (ufo x y-up fart)] + [else current-state]))) + +(define (ufo-move-down current-state) + (let ((x (ufo-x current-state)) + (y-down (+ (ufo-y current-state) MOVE-LEN))) + (cond [(<= y-down (- (+ WORLD-HEIGHT (/ UFO-FART-HEIGHT 2)) + (/ UFO-HEIGHT 2))) + (ufo x y-down #t)] + [else current-state]))) + + +(define (ufo-move-left current-state) + (let ((x-left (- (ufo-x current-state) MOVE-LEN)) + (y (ufo-y current-state)) + (fart #t)) + (cond [(>= x-left (/ UFO-WIDTH 2)) + (ufo x-left y fart)] + [else current-state]))) + +(define (ufo-move-right current-state) + (let ((x-right (+ (ufo-x current-state) MOVE-LEN)) + (y (ufo-y current-state)) + (fart #t)) + (cond [(<= x-right (- WORLD-WIDTH (/ UFO-WIDTH 2))) + (ufo x-right y fart)] + [else current-state]))) + + +;;; big bang functions +(define (draw-a-ufo current-state) + (place-image (overlay/align/offset + "middle" "bottom" UFO 0 35 + (if (ufo-fart current-state) + UFO-FART + (circle 0 "outline" "white"))) + (ufo-x current-state) + (ufo-y current-state) + (empty-scene WORLD-WIDTH WORLD-HEIGHT))) + +(define (add-3-to-posy current-state) + (ufo (ufo-x current-state) + (+ (ufo-y current-state) 3))) + +(define (posy-is-300 current-state) + (>= (ufo-y current-state) 300)) + +(define (move-ufo current-state key) + (cond [(key=? key "up") (ufo-move-up current-state)] + [(key=? key "down") (ufo-move-down current-state)] + [(key=? key "left") (ufo-move-left current-state)] + [(key=? key "right") (ufo-move-right current-state)] + [else current-state])) + +(define (ufo-stopped current-state key) + (let ((fart #f)) + (ufo (ufo-x current-state) (ufo-y current-state) fart))) + +;;; the big bang +(big-bang (ufo (/ WORLD-WIDTH 2) (/ WORLD-HEIGHT 2) #f) + (to-draw draw-a-ufo) + (on-key move-ufo) + (on-release ufo-stopped)) + diff --git a/chapter6/resources/body.gif b/chapter6/resources/body.gif new file mode 100644 index 0000000..94a0956 Binary files /dev/null and b/chapter6/resources/body.gif differ diff --git a/chapter6/resources/goo-red.gif b/chapter6/resources/goo-red.gif new file mode 100644 index 0000000..bf767b1 Binary files /dev/null and b/chapter6/resources/goo-red.gif differ diff --git a/chapter6/resources/goo.gif b/chapter6/resources/goo.gif new file mode 100644 index 0000000..cb0d98b Binary files /dev/null and b/chapter6/resources/goo.gif differ diff --git a/chapter6/resources/head.gif b/chapter6/resources/head.gif new file mode 100644 index 0000000..664f679 Binary files /dev/null and b/chapter6/resources/head.gif differ diff --git a/chapter6/resources/obstacle.gif b/chapter6/resources/obstacle.gif new file mode 100644 index 0000000..6ff288e Binary files /dev/null and b/chapter6/resources/obstacle.gif differ diff --git a/chapter6/resources/tail.gif b/chapter6/resources/tail.gif new file mode 100644 index 0000000..6fbd317 Binary files /dev/null and b/chapter6/resources/tail.gif differ diff --git a/chapter6/snake.rkt b/chapter6/snake.rkt new file mode 100644 index 0000000..c57b01c --- /dev/null +++ b/chapter6/snake.rkt @@ -0,0 +1,295 @@ +#lang racket +(require 2htdp/universe 2htdp/image) + +;; data +(struct pit (snake goos obstacles dinged)) +(struct snake (dir segs)) +(struct goo (loc expire type)) +(struct obstacle (loc expire)) +(struct posn (x y)) + +;; constants +(define TICK-RATE 1/10) + +(define SIZE 30) + +(define SEG-SIZE 15) + +(define EXPIRATION-TIME 150) +(define OBSTACLE-EXPIRATION-TIME 250) + +(define WIDTH-PX (* SEG-SIZE 30)) +(define HEIGHT-PX (* SEG-SIZE 30)) + +(define MT-SCENE (empty-scene WIDTH-PX HEIGHT-PX)) +(define GOO-IMG (bitmap "resources/goo.gif")) +(define GOO-RED-IMG (bitmap "resources/goo-red.gif")) +(define OBSTACLE-IMG (bitmap "resources/obstacle.gif")) +(define SEG-IMG (bitmap "resources/body.gif")) +(define HEAD-IMG (bitmap "resources/head.gif")) + +(define HEAD-LEFT-IMG HEAD-IMG) +(define HEAD-DOWN-IMG (rotate 90 HEAD-LEFT-IMG)) +(define HEAD-RIGHT-IMG (flip-horizontal HEAD-LEFT-IMG)) +(define HEAD-UP-IMG (flip-vertical HEAD-DOWN-IMG)) + +(define ENDGAME-TEXT-SIZE 15) + +;; main +(define (start-snake) + (big-bang (pit (snake "right" (list (posn 1 1))) + (list (fresh-goo) + (fresh-goo) + (fresh-goo) + (fresh-goo) + (fresh-goo) + (fresh-goo)) + (list (fresh-obstacle) + (fresh-obstacle)) + 0) + (on-tick next-pit TICK-RATE) + (on-key direct-snake) + (to-draw render-pit) + (stop-when dead? render-end))) + +(define (next-pit w) + (define snake (pit-snake w)) + (define goos (pit-goos w)) + (define obstacles (pit-obstacles w)) + (define dinged (pit-dinged w)) + (define goo-to-eat (can-eat snake goos)) + (if goo-to-eat + (pit (grow-size snake (goo-type goo-to-eat)) + (age-goo (eat goos goo-to-eat)) + (age-obstacle obstacles) (+ 1 dinged)) + (pit (slither snake) + (age-goo goos) + (age-obstacle obstacles) dinged))) + +(define (direct-snake w ke) + (cond [(dir? ke) (world-change-dir w ke)] + [else w])) + +(define (render-pit w) + (snake+scene (pit-snake w) + (goo-list+scene (pit-goos w) + (obstacle-list+scene + (pit-obstacles w) MT-SCENE)))) + +(define (dead? w) + (define snake (pit-snake w)) + (or (self-colliding? snake) + (wall-colliding? snake) + (obstacle-colliding? snake (pit-obstacles w)))) + +(define (render-end w) + (overlay (above (text "Game Over" ENDGAME-TEXT-SIZE "black") + (text (string-append "You dinged " + (number->string (pit-dinged w)) + " goos.") + ENDGAME-TEXT-SIZE "black")) + (render-pit w))) + + +;; clock +(define (can-eat snake goos) + (cond [(empty? goos) #f] + [else (if (close? (snake-head snake) (first goos)) + (first goos) + (can-eat snake (rest goos)))])) + +(define (eat goos goo-to-eat) + (append (list (fresh-goo)) (remove goo-to-eat goos))) + +(define (close? s g) + (posn=? s (goo-loc g))) + +(define (grow-size sn size) + (cond [(= size 0) sn] + [else (grow-size (grow sn) (- size 1))])) + +(define (grow sn) + (snake (snake-dir sn) + (cons (next-head sn) (snake-segs sn)))) + +(define (slither sn) + (snake (snake-dir sn) + (cons (next-head sn) (all-but-last (snake-segs sn))))) + +(define (next-head sn) + (define head (snake-head sn)) + (define dir (snake-dir sn)) + (cond [(string=? dir "up") (posn-move head 0 -1)] + [(string=? dir "down") (posn-move head 0 1)] + [(string=? dir "left") (posn-move head -1 0)] + [(string=? dir "right") (posn-move head 1 0)])) + +(define (posn-move p dx dy) + (posn (+ (posn-x p) dx) + (+ (posn-y p) dy))) + +(define (all-but-last segs) + (cond [(empty? (rest segs)) empty] + [else (cons (first segs) (all-but-last (rest segs)))])) + +(define (age-goo goos) + (rot (renew goos))) + +(define (renew goos) + (cond [(empty? goos) empty] + [(rotten? (first goos)) + (append (fresh-goos) (renew (rest goos)))] + [else + (append (list (first goos)) (renew (rest goos)))])) + +(define (rot goos) + (cond [(empty? goos) empty] + [else (cons (decay (first goos)) (rot (rest goos)))])) + +(define (rotten? g) + (zero? (goo-expire g))) + +(define (decay g) + (goo (goo-loc g) (sub1 (goo-expire g)) (goo-type g))) + +(define (fresh-goo) + (goo (posn (add1 (random (sub1 SIZE))) + (add1 (random (sub1 SIZE)))) + EXPIRATION-TIME + (random 1 3))) + +(define (fresh-goos) + (define (gen-goos n) + (cond [(= n 0) empty] + [else (cons (fresh-goo) (gen-goos (- n 1)))])) + (let ((n (random 3))) + (gen-goos n))) + +(define (age-obstacle obstacles) + (rot-obstacles (renew-obstacles obstacles))) + +(define (renew-obstacles obstacles) + (cond [(empty? obstacles) empty] + [(obstacle-expired? (first obstacles)) + (cons (fresh-obstacle) (renew-obstacles (rest obstacles)))] + [else + (cons (first obstacles) (renew-obstacles (rest obstacles)))])) + +(define (rot-obstacles obstacles) + (cond [(empty? obstacles) empty] + [else (cons (decay-obstacle (first obstacles)) + (rot-obstacles (rest obstacles)))])) + +(define (obstacle-expired? obs) + (zero? (obstacle-expire obs))) + +(define (decay-obstacle obs) + (obstacle (obstacle-loc obs) (sub1 (obstacle-expire obs)))) + +(define (fresh-obstacle) + (obstacle (posn (add1 (random (sub1 SIZE))) + (add1 (random (sub1 SIZE)))) + OBSTACLE-EXPIRATION-TIME)) + +;; keys +(define (dir? x) + (or (key=? x "up") + (key=? x "down") + (key=? x "left") + (key=? x "right"))) + +(define (world-change-dir w d) + (define the-snake (pit-snake w)) + (cond [(and (opposite-dir? (snake-dir the-snake) d) + (cons? (rest (snake-segs the-snake)))) + (stop-with w)] + [else + (pit (snake-change-dir the-snake d) + (pit-goos w) + (pit-obstacles w) + (pit-dinged w))])) + +(define (opposite-dir? d1 d2) + (cond [(string=? d1 "up") (string=? d2 "down")] + [(string=? d1 "down") (string=? d2 "up")] + [(string=? d1 "left") (string=? d2 "right")] + [(string=? d1 "right") (string=? d2 "left")])) + + +;; render +(define (snake+scene snake scene) + (define snake-body-scene + (img-list+scene (snake-body snake) SEG-IMG scene)) + (define dir (snake-dir snake)) + (img+scene (snake-head snake) + (cond [(string=? "up" dir) HEAD-UP-IMG] + [(string=? "down" dir) HEAD-DOWN-IMG] + [(string=? "left" dir) HEAD-LEFT-IMG] + [(string=? "right" dir) HEAD-RIGHT-IMG]) + snake-body-scene)) + +(define (goo-list+scene goos scene) + (define (get-posns-from-goo goos type) + (cond [(empty? goos) empty] + [(= (goo-type (first goos)) type) + (cons (goo-loc (first goos)) + (get-posns-from-goo (rest goos) type))] + [else (get-posns-from-goo (rest goos) type)])) + (img-list+scene (get-posns-from-goo goos 1) GOO-IMG + (img-list+scene (get-posns-from-goo goos 2) + GOO-RED-IMG scene))) + +(define (obstacle-list+scene obstacles scene) + (define (get-posns-from-obstacle obstacles) + (cond [(empty? obstacles) empty] + [else (cons (obstacle-loc (first obstacles)) + (get-posns-from-obstacle (rest obstacles)))])) + (img-list+scene (get-posns-from-obstacle obstacles) + OBSTACLE-IMG scene)) + +(define (img-list+scene posns img scene) + (cond [(empty? posns) scene] + [else (img+scene + (first posns) + img + (img-list+scene (rest posns) img scene))])) + +(define (img+scene posn img scene) + (place-image img + (* (posn-x posn) SEG-SIZE) + (* (posn-y posn) SEG-SIZE) + scene)) + + +;; end game +(define (self-colliding? snake) + (cons? (member (snake-head snake) (snake-body snake)))) + +(define (wall-colliding? snake) + (define x (posn-x (snake-head snake))) + (define y (posn-y (snake-head snake))) + (or (= 0 x) (= x SIZE) + (= 0 y) (= y SIZE))) + +(define (obstacle-colliding? snake obstacles) + (cond [(empty? obstacles) #f] + [(posn=? (snake-head snake) + (obstacle-loc (first obstacles))) #t] + [else (obstacle-colliding? snake (rest obstacles))])) + +;; aux +(define (posn=? p1 p2) + (and (= (posn-x p1) (posn-x p2)) + (= (posn-y p1) (posn-y p2)))) + +(define (snake-head sn) + (first (snake-segs sn))) + +(define (snake-body sn) + (rest (snake-segs sn))) + +(define (snake-tail sn) + (last (snake-segs sn))) + +(define (snake-change-dir sn d) + (snake d (snake-segs sn))) diff --git a/chapter6/snakes.rkt b/chapter6/snakes.rkt new file mode 100644 index 0000000..dae3468 --- /dev/null +++ b/chapter6/snakes.rkt @@ -0,0 +1,362 @@ +#lang racket +(require 2htdp/universe 2htdp/image) + +;; data +(struct pit (snake-1 snake-2 goos obstacles dinged)) +(struct snake (dir segs)) +(struct goo (loc expire type)) +(struct obstacle (loc expire)) +(struct posn (x y)) + +;; constants +(define TICK-RATE 1/10) + +(define SIZE 30) + +(define SEG-SIZE 15) + +(define EXPIRATION-TIME 150) +(define OBSTACLE-EXPIRATION-TIME 250) + +(define WIDTH-PX (* SEG-SIZE 30)) +(define HEIGHT-PX (* SEG-SIZE 30)) + +(define MT-SCENE (empty-scene WIDTH-PX HEIGHT-PX)) +(define GOO-IMG (bitmap "resources/goo.gif")) +(define GOO-RED-IMG (bitmap "resources/goo-red.gif")) +(define OBSTACLE-IMG (bitmap "resources/obstacle.gif")) +(define SEG-IMG (bitmap "resources/body.gif")) +(define HEAD-IMG (bitmap "resources/head.gif")) + +(define HEAD-LEFT-IMG HEAD-IMG) +(define HEAD-DOWN-IMG (rotate 90 HEAD-LEFT-IMG)) +(define HEAD-RIGHT-IMG (flip-horizontal HEAD-LEFT-IMG)) +(define HEAD-UP-IMG (flip-vertical HEAD-DOWN-IMG)) + +(define ENDGAME-TEXT-SIZE 15) + +;; main +(define (start-snakes) + (big-bang (pit (snake "right" (list (posn 1 1))) + (snake "d" (list (posn 1 10))) + (list (fresh-goo) + (fresh-goo) + (fresh-goo) + (fresh-goo) + (fresh-goo) + (fresh-goo)) + (list (fresh-obstacle) + (fresh-obstacle)) + 0) + (on-tick next-pit TICK-RATE) + (on-pad direct-snakes) + (to-draw render-pit) + (stop-when dead? render-end))) + +(define (next-pit w) + (define snake-1 (pit-snake-1 w)) + (define snake-2 (pit-snake-2 w)) + (define goos (pit-goos w)) + (define obstacles (pit-obstacles w)) + (define dinged (pit-dinged w)) + (define goo-to-eat-sn1 (can-eat snake-1 goos)) + (define goo-to-eat-sn2 (can-eat snake-2 goos)) + (cond [(and goo-to-eat-sn1 goo-to-eat-sn2) ; sn1 and sn2 dinged. + (pit (grow-size snake-1 (goo-type goo-to-eat-sn1)) + (grow-size snake-2 (goo-type goo-to-eat-sn2)) + (age-goo (eat (eat goos goo-to-eat-sn1) goo-to-eat-sn2)) + (age-obstacle obstacles) (+ 2 dinged))] + [(and goo-to-eat-sn1 (not goo-to-eat-sn2)) ; sn1 dinged. + (pit (grow-size snake-1 (goo-type goo-to-eat-sn1)) + (slither snake-2) + (age-goo (eat goos goo-to-eat-sn1)) + (age-obstacle obstacles) (+ 1 dinged))] + [(and (not goo-to-eat-sn1) goo-to-eat-sn2) ; sn2 dinged. + (pit (slither snake-1) + (grow-size snake-2 (goo-type goo-to-eat-sn2)) + (age-goo (eat goos goo-to-eat-sn2)) + (age-obstacle obstacles) (+ 1 dinged))] + [else ; none dinged. + (pit (slither snake-1) + (slither snake-2) + (age-goo goos) + (age-obstacle obstacles) dinged)])) + + +(define (direct-snakes w ke) + (cond [(arrow-key? ke) (direct-snake-1 w ke)] + [(wasd-key? ke) (direct-snake-2 w ke)] + [else w])) + +(define (direct-snake-1 w ke) + (world-change-dir 1 w ke)) + +(define (direct-snake-2 w ke) + (world-change-dir 2 w ke)) + +(define (render-pit w) + (snake+scene (pit-snake-1 w) + (snake+scene (pit-snake-2 w) + (goo-list+scene (pit-goos w) + (obstacle-list+scene + (pit-obstacles w) MT-SCENE))))) + +(define (dead? w) + (define snake-1 (pit-snake-1 w)) + (define snake-2 (pit-snake-2 w)) + (define (colliding? sn sn-other) + (or (self-colliding? sn) + (wall-colliding? sn) + (obstacle-colliding? sn (pit-obstacles w)) + (snake-colliding? sn sn-other))) + (or (colliding? snake-1 snake-2) (colliding? snake-2 snake-1))) + +(define (render-end w) + (overlay (above (text "Game Over" ENDGAME-TEXT-SIZE "black") + (text (string-append "Dinged " + (number->string (pit-dinged w)) + " goos.") + ENDGAME-TEXT-SIZE "black")) + (render-pit w))) + + +;; clock +(define (can-eat snake goos) + (cond [(empty? goos) #f] + [else (if (close? (snake-head snake) (first goos)) + (first goos) + (can-eat snake (rest goos)))])) + +(define (eat goos goo-to-eat) + (append (list (fresh-goo)) (remove goo-to-eat goos))) + +(define (close? s g) + (posn=? s (goo-loc g))) + +(define (grow-size sn size) + (cond [(= size 0) sn] + [else (grow-size (grow sn) (- size 1))])) + +(define (grow sn) + (snake (snake-dir sn) + (cons (next-head sn) (snake-segs sn)))) + +(define (slither sn) + (snake (snake-dir sn) + (cons (next-head sn) (all-but-last (snake-segs sn))))) + +(define (next-head sn) + (define head (snake-head sn)) + (define dir (snake-dir sn)) + (cond [(or (string=? dir "up") (string=? dir "w")) (posn-move head 0 -1)] + [(or (string=? dir "down") (string=? dir "s")) (posn-move head 0 1)] + [(or (string=? dir "left") (string=? dir "a")) (posn-move head -1 0)] + [(or (string=? dir "right") (string=? dir "d")) (posn-move head 1 0)])) + +(define (posn-move p dx dy) + (posn (+ (posn-x p) dx) + (+ (posn-y p) dy))) + +(define (all-but-last segs) + (cond [(empty? (rest segs)) empty] + [else (cons (first segs) (all-but-last (rest segs)))])) + +(define (age-goo goos) + (rot (renew goos))) + +(define (renew goos) + (cond [(empty? goos) empty] + [(rotten? (first goos)) + (append (fresh-goos) (renew (rest goos)))] + [else + (append (list (first goos)) (renew (rest goos)))])) + +(define (rot goos) + (cond [(empty? goos) empty] + [else (cons (decay (first goos)) (rot (rest goos)))])) + +(define (rotten? g) + (zero? (goo-expire g))) + +(define (decay g) + (goo (goo-loc g) (sub1 (goo-expire g)) (goo-type g))) + +(define (fresh-goo) + (goo (posn (add1 (random (sub1 SIZE))) + (add1 (random (sub1 SIZE)))) + EXPIRATION-TIME + (random 1 3))) + +(define (fresh-goos) + (define (gen-goos n) + (cond [(= n 0) empty] + [else (cons (fresh-goo) (gen-goos (- n 1)))])) + (let ((n (random 3))) + (gen-goos n))) + +(define (age-obstacle obstacles) + (rot-obstacles (renew-obstacles obstacles))) + +(define (renew-obstacles obstacles) + (cond [(empty? obstacles) empty] + [(obstacle-expired? (first obstacles)) + (cons (fresh-obstacle) (renew-obstacles (rest obstacles)))] + [else + (cons (first obstacles) (renew-obstacles (rest obstacles)))])) + +(define (rot-obstacles obstacles) + (cond [(empty? obstacles) empty] + [else (cons (decay-obstacle (first obstacles)) + (rot-obstacles (rest obstacles)))])) + +(define (obstacle-expired? obs) + (zero? (obstacle-expire obs))) + +(define (decay-obstacle obs) + (obstacle (obstacle-loc obs) (sub1 (obstacle-expire obs)))) + +(define (fresh-obstacle) + (obstacle (posn (add1 (random (sub1 SIZE))) + (add1 (random (sub1 SIZE)))) + OBSTACLE-EXPIRATION-TIME)) + +;; keys +(define (dir? x) + (or (arrow-key? x) + (wasd-key? x))) + +(define (arrow-key? x) + (or (key=? x "up") + (key=? x "down") + (key=? x "left") + (key=? x "right"))) + +(define (wasd-key? x) + (or (key=? x "w") + (key=? x "s") + (key=? x "a") + (key=? x "d"))) + +(define (world-change-dir sn-number w d) + (define snake-1 (pit-snake-1 w)) + (define snake-2 (pit-snake-2 w)) + (cond [(and (= sn-number 1) ;snake-1 + (opposite-dir? (snake-dir snake-1) d) + (cons? (rest (snake-segs snake-1)))) + (stop-with w)] + [(and (= sn-number 2) ;snake-2 + (opposite-dir? (snake-dir snake-2) d) + (cons? (rest (snake-segs snake-2)))) + (stop-with w)] + [(= sn-number 1) ;snake-1 change dir. + (pit (snake-change-dir snake-1 d) + (pit-snake-2 w) + (pit-goos w) + (pit-obstacles w) + (pit-dinged w))] + [else ;snake-2 change dir. + (pit (pit-snake-1 w) + (snake-change-dir snake-2 d) + (pit-goos w) + (pit-obstacles w) + (pit-dinged w))])) + +(define (opposite-dir? d1 d2) + (cond [(string=? d1 "up") (string=? d2 "down")] + [(string=? d1 "down") (string=? d2 "up")] + [(string=? d1 "left") (string=? d2 "right")] + [(string=? d1 "right") (string=? d2 "left")] + [(string=? d1 "w") (string=? d2 "s")] + [(string=? d1 "s") (string=? d2 "w")] + [(string=? d1 "a") (string=? d2 "d")] + [(string=? d1 "d") (string=? d2 "a")])) + + +;; render +(define (snake+scene snake scene) + (define snake-body-scene + (img-list+scene (snake-body snake) SEG-IMG scene)) + (define dir (snake-dir snake)) + (img+scene (snake-head snake) + (cond [(or (string=? "up" dir) (string=? "w" dir)) + HEAD-UP-IMG] + [(or (string=? "down" dir) (string=? "s" dir)) + HEAD-DOWN-IMG] + [(or (string=? "left" dir) (string=? "a" dir)) + HEAD-LEFT-IMG] + [(or (string=? "right" dir) (string=? "d" dir)) + HEAD-RIGHT-IMG]) + snake-body-scene)) + +(define (goo-list+scene goos scene) + (define (get-posns-from-goo goos type) + (cond [(empty? goos) empty] + [(= (goo-type (first goos)) type) + (cons (goo-loc (first goos)) + (get-posns-from-goo (rest goos) type))] + [else (get-posns-from-goo (rest goos) type)])) + (img-list+scene (get-posns-from-goo goos 1) GOO-IMG + (img-list+scene (get-posns-from-goo goos 2) + GOO-RED-IMG scene))) + +(define (obstacle-list+scene obstacles scene) + (define (get-posns-from-obstacle obstacles) + (cond [(empty? obstacles) empty] + [else (cons (obstacle-loc (first obstacles)) + (get-posns-from-obstacle (rest obstacles)))])) + (img-list+scene (get-posns-from-obstacle obstacles) + OBSTACLE-IMG scene)) + +(define (img-list+scene posns img scene) + (cond [(empty? posns) scene] + [else (img+scene + (first posns) + img + (img-list+scene (rest posns) img scene))])) + +(define (img+scene posn img scene) + (place-image img + (* (posn-x posn) SEG-SIZE) + (* (posn-y posn) SEG-SIZE) + scene)) + + +;; end game +(define (self-colliding? snake) + (cons? (member (snake-head snake) (snake-body snake)))) + +(define (wall-colliding? snake) + (define x (posn-x (snake-head snake))) + (define y (posn-y (snake-head snake))) + (or (= 0 x) (= x SIZE) + (= 0 y) (= y SIZE))) + +(define (obstacle-colliding? snake obstacles) + (cond [(empty? obstacles) #f] + [(posn=? (snake-head snake) + (obstacle-loc (first obstacles))) #t] + [else (obstacle-colliding? snake (rest obstacles))])) + +(define (snake-colliding? snake snake-other) + (define (head-in-other sn other) + (cond [(empty? other) #f] + [(posn=? sn (first other)) #t] + [else (head-in-other sn (rest other))])) + (head-in-other (snake-head snake) (snake-segs snake-other))) + +;; aux +(define (posn=? p1 p2) + (and (= (posn-x p1) (posn-x p2)) + (= (posn-y p1) (posn-y p2)))) + +(define (snake-head sn) + (first (snake-segs sn))) + +(define (snake-body sn) + (rest (snake-segs sn))) + +(define (snake-tail sn) + (last (snake-segs sn))) + +(define (snake-change-dir sn d) + (snake d (snake-segs sn))) diff --git a/chapter8/graphics/README.txt b/chapter8/graphics/README.txt new file mode 100644 index 0000000..5895c77 --- /dev/null +++ b/chapter8/graphics/README.txt @@ -0,0 +1,3 @@ +Graphics from github.com/racket/realm + +Commit: 973041cb6a5c696b99b79a diff --git a/chapter8/graphics/brigand.bmp b/chapter8/graphics/brigand.bmp new file mode 100644 index 0000000..7bbd3c0 Binary files /dev/null and b/chapter8/graphics/brigand.bmp differ diff --git a/chapter8/graphics/hydra.png b/chapter8/graphics/hydra.png new file mode 100644 index 0000000..b495920 Binary files /dev/null and b/chapter8/graphics/hydra.png differ diff --git a/chapter8/graphics/hydrar.png b/chapter8/graphics/hydrar.png new file mode 100644 index 0000000..e555bfe Binary files /dev/null and b/chapter8/graphics/hydrar.png differ diff --git a/chapter8/graphics/orc.gif b/chapter8/graphics/orc.gif new file mode 100644 index 0000000..5553322 Binary files /dev/null and b/chapter8/graphics/orc.gif differ diff --git a/chapter8/graphics/orc.png b/chapter8/graphics/orc.png new file mode 100644 index 0000000..d269b6a Binary files /dev/null and b/chapter8/graphics/orc.png differ diff --git a/chapter8/graphics/orcSprite.png b/chapter8/graphics/orcSprite.png new file mode 100644 index 0000000..cdc223c Binary files /dev/null and b/chapter8/graphics/orcSprite.png differ diff --git a/chapter8/graphics/player.bmp b/chapter8/graphics/player.bmp new file mode 100644 index 0000000..c6a04a0 Binary files /dev/null and b/chapter8/graphics/player.bmp differ diff --git a/chapter8/graphics/slime.bmp b/chapter8/graphics/slime.bmp new file mode 100644 index 0000000..208c188 Binary files /dev/null and b/chapter8/graphics/slime.bmp differ diff --git a/chapter8/orc.rkt b/chapter8/orc.rkt new file mode 100644 index 0000000..f00d587 --- /dev/null +++ b/chapter8/orc.rkt @@ -0,0 +1,943 @@ +#lang racket + +#| + + From github.com/racket/realm + + With some trivial changes. + + Commit: 973041cb6a5c696b99b79a +|# + +#| + The Orc game + ------------- + + The Orc game is a turn-based battle game between monsters and the player. + + The player encounters a room full of monsters of all kinds, including + orcs, hydras, hydrars, slimes, and brigands. They are ready to attack. It is + the player's task to get rid of the monsters. + + When the game starts up, it is the player's turn, meaning she is given + permission to attack a (randomly chosen number) of times. The player uses + nine keys to play + -- With the four arrow keys the player navigates among the twelve monsters. + -- With "s", "f", "h", and "m" + -- the player can 's'tab a specific monster, + -- the player may 'f'lail at several monsters; + -- the player may 'h'eal herself. + -- the player may 'm'asturbate for a change. + -- the player may 'b'lock to gain armor. + When the player runs out of attacks, all live monsters attack the player. + After that, it is the player's turn again. + + Just in case, the player can end a turn prematurely with "e". + + Play + ---- + + Run and evaluate + (start-game) + This will pop up a window that displays the player's vitals, the orcs and + their basic state, and the game instructions. +|# + + +(require 2htdp/image 2htdp/universe) + +; +; +; +; ;;; ;;; ;;; ;; ;; +; ; ; ; ; ; ; +; ; ; ;; ;;; ;;; ; ; ; ;;;; ;; ;;; ; ;;; ; +; ; ; ;; ;; ;; ; ; ; ; ; ;; ; ; ;; +; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; +; ;;; ;;;;; ;;;; ; ; ;;;; ;;;;; ;;;;; ;;; ;; +; +; +; +; + +;; The OrcWorld as Data: +(struct orc-world (player lom attack# target) #:transparent #:mutable) +;; A OrcWorld is a (orc-world Player [listof Monster] Nat Nat) +;; The third field of the world refers to the number of attacks left. +;; The fourth field refers to the position of the next attack target. + +(struct player (health agility strength armor) #:transparent #:mutable) +;; A Player is a (player Nat Nat Nat Nat) +;; The player's fields correspond to hit points, strength, agility, armor. + +(struct monster (image [health #:mutable]) #:transparent) +(struct orc monster (club) #:transparent) +(struct hydra monster () #:transparent) +(struct hydrar monster () #:transparent) +(struct slime monster (sliminess) #:transparent) +(struct brigand monster () #:transparent) +;; A Monster is a (monster Image Nat) +;; (moster i h) is a monster at position i in the list with health h +;; Each monster is equipped with the index number, +;; which is used to identify the current target. +;; +;; An Orc is an (orc Nat Nat Nat) +;; A Slime is a (slime Nat Nat Nat) +;; A Brigrand is a (brigand Nat Nat) +;; A Hydra is a (hydra Nat Nat) +;; A Hydrar is a (hydrar Nat Nat) +;; +;; The four monster types all inherit the id and health fields from monster. +;; Two have additional attributes: +;; -- (orc i h c) means the orc's club has strength c +;; -- (slime i h a) means the slime can reduce the player's agility by a + +;; ----------------------------------------------------------------------------- +;; THE CONSTANTS IN THE WORLD + +;; player attributes +(define MAX-HEALTH 35) +(define MAX-AGILITY 35) +(define MAX-STRENGTH 35) +(define MAX-ARMOR 35) + +;; depending on other player attributes, +;; the game picks the number of attacks, flailing and stabbing damage +(define ATTACKS# 4) +(define STAB-DAMAGE 2) +(define FLAIL-DAMAGE 3) +(define MASTURBATE-DAMAGE 5) +(define HEALING 8) +(define BLOCK 8) + +;; monster attributes +(define MONSTER# 12) +(define PER-ROW 4) +(unless (zero? (remainder MONSTER# PER-ROW)) + (error 'constraint "PER-ROW must divide MONSTER# evenly into rows")) + +(define MONSTER-HEALTH0 9) +(define CLUB-STRENGTH 8) +(define SLIMINESS 5) + +(define HEALTH-DAMAGE -2) +(define AGILITY-DAMAGE -3) +(define STRENGTH-DAMAGE -4) + +;; string constants +(define STRENGTH "strength") +(define AGILITY "agility") +(define HEALTH "health") +(define ARMOR "armor") +(define LOSE "YOU LOSE") +(define WIN "YOU WIN") +(define DEAD "DEAD") +(define REMAINING "Remaining attacks ") +(define INSTRUCTIONS-2 "Select a monster using the arrow keys") +(define INSTRUCTIONS-1 + (string-append "Press S to stab a monster | Press F to Flail wildly " + "| Press H to Heal | Press M to Masturbate")) + +;; graphical constants +(define HEALTH-BAR-HEIGHT 12) +(define HEALTH-BAR-WIDTH 50) + +;; compute constants for image frames +(define ORC (bitmap "graphics/orc.png")) +(define HYDRA (bitmap "graphics/hydra.png")) +(define HYDRAR (bitmap "graphics/hydrar.png")) +(define SLIME (bitmap "graphics/slime.bmp")) +(define BRIGAND (bitmap "graphics/brigand.bmp")) + +(define PIC-LIST (list ORC HYDRA HYDRAR SLIME BRIGAND)) +(define w (apply max (map image-width PIC-LIST))) +(define h (apply max (map image-height PIC-LIST))) + +;; images: player, monsters, constant texts +(define PLAYER-IMAGE (bitmap "graphics/player.bmp")) + +(define FRAME (rectangle w h 'outline 'white)) +(define TARGET (circle (- (/ w 2) 2) 'outline 'blue)) + +(define ORC-IMAGE (overlay ORC FRAME)) +(define HYDRA-IMAGE (overlay HYDRA FRAME)) +(define HYDRAR-IMAGE (overlay HYDRAR FRAME)) +(define SLIME-IMAGE (overlay SLIME FRAME)) +(define BRIGAND-IMAGE (overlay BRIGAND FRAME)) + +(define V-SPACER (rectangle 0 10 "solid" "white")) +(define H-SPACER (rectangle 10 0 "solid" "white")) + +;; fonts & texts & colors +(define AGILITY-COLOR "blue") +(define HEALTH-COLOR "crimson") +(define STRENGTH-COLOR "forest green") +(define ARMOR-COLOR "goldenrod") +(define MONSTER-COLOR "crimson") +(define MESSAGE-COLOR "black") +(define ATTACK-COLOR "crimson") + +(define HEALTH-SIZE (- HEALTH-BAR-HEIGHT 4)) +(define DEAD-TEXT-SIZE (- HEALTH-BAR-HEIGHT 2)) +(define INSTRUCTION-TEXT-SIZE 16) +(define MESSAGES-SIZE 40) + +(define INSTRUCTION-TEXT + (above + (text INSTRUCTIONS-2 (- INSTRUCTION-TEXT-SIZE 2) "blue") + (text INSTRUCTIONS-1 (- INSTRUCTION-TEXT-SIZE 4) "blue"))) + +(define DEAD-TEXT (text DEAD DEAD-TEXT-SIZE "crimson")) + +; +; +; +; ;;; ;;; ; +; ;; ;; +; ;; ;; ;;;; ;;; ;; ;; +; ; ; ; ; ; ; ;; ; +; ; ; ; ;;;;; ; ; ; +; ; ; ; ; ; ; ; +; ; ; ; ;; ; ; ; +; ;;; ;;; ;;; ;; ;;;;; ;;; ;;; +; +; +; +; + +;; Start the game +(define (start-game) + (big-bang (initialize-orc-world) + (on-key player-acts-on-monsters) + (to-draw render-orc-battle) + (stop-when end-of-orc-battle? render-the-end))) + +;; -> OrcWorld +;; creates an orc-world ready for battling orcs +(define (initialize-orc-world) + (define player0 (initialize-player)) + (define lom0 (initialize-monsters)) + (orc-world player0 lom0 (random-number-of-attacks player0) 0)) + +;; OrcWorld Key-Event -> OrcWorld +;; act on key events by the player, if the player has attacks left +(define (player-acts-on-monsters w k) + (cond + [(zero? (orc-world-attack# w)) w] + + [(key=? "s" k) (stab w)] + [(key=? "h" k) (heal w)] + [(key=? "f" k) (flail w)] + [(key=? "m" k) (masturbate w)] + [(key=? "b" k) (block w)] + + [(key=? "right" k) (move-target w +1)] + [(key=? "left" k) (move-target w -1)] + [(key=? "down" k) (move-target w (+ PER-ROW))] + [(key=? "up" k) (move-target w (- PER-ROW))] + + [(key=? "e" k) (end-turn w)] +;; [(key=? "n" k) (initialize-orc-world)] + + [else w]) + (give-monster-turn-if-attack#=0 w) + w) + +;; OrcWorld -> Image +;; renders the orc world +(define (render-orc-battle w) + (render-orc-world w (orc-world-target w) (instructions w))) + +;; OrcWorld -> Boolean +;; is the battle over? i.e., the player lost or all monsters are dead +(define (end-of-orc-battle? w) + (or (win? w) (lose? w))) + +;; OrcWorld -> Image +;; render the final orc world +(define (render-the-end w) + (render-orc-world w #f (message (if (lose? w) LOSE WIN)))) + +;; ----------------------------------------------------------------------------- + +;; WORLD MANAGEMENT +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; +; +; +; ;;;;; ; +; ; ; +; ; ;; ;; ;;; ;;;;; +; ; ;; ; ; ; +; ; ; ; ; ; +; ; ; ; ; ; +; ; ; ; ; ; ; +; ;;;;; ;;; ;;; ;;;;; ;;; +; +; +; +; + +;; -> Player +;; create a player with maximal capabilities +(define (initialize-player) + (player MAX-HEALTH MAX-AGILITY MAX-STRENGTH 0)) + +;; -> [Listof Monster] +;; create a list of random monsters of length MONSTER-NUM, +(define (initialize-monsters) + ;; Nat -> Monster + ;; makes a random monster + (define (create-monster _) + (define health (random+ MONSTER-HEALTH0)) + (case (random 4) + [(0) (orc ORC-IMAGE health (random+ CLUB-STRENGTH))] + [(1) (hydra HYDRA-IMAGE health)] + [(2) (hydrar HYDRAR-IMAGE health)] + [(3) (slime SLIME-IMAGE health (random+ SLIMINESS))] + [(4) (brigand BRIGAND-IMAGE health)] + [else (error "can't happen")])) + (build-list MONSTER# create-monster)) + +;; Player -> Nat +;; compute a feasible number of attacks the player may execute +(define (random-number-of-attacks p) + (random-quotient (player-agility p) + ATTACKS#)) + +; +; +; +; ;;; ;;; ;;;;;; +; ; ; ; ; ; +; ; ; ;;;; ;;; ;;; ; ; ;;; ;;; ;;;; ;; ;; ;;;;; ;;;;; +; ; ; ; ; ; ; ;;; ; ; ; ; ;; ; ; ; ; +; ;;; ;;;;;; ; ; ; ; ; ; ;;;;;; ; ; ; ;;;; +; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; +; ;;; ;; ;;;;; ; ;;;;;; ;; ;;;;; ;;; ;;; ;;; ;;;;; +; ; +; ;;; +; +; + +;; ----------------------------------------------------------------------------- +;; player actions + +;; OrcWorld Nat -> Void +;; Effect: reduces the target by a given amount +;; > (move-target +;; (orc-world (player 5 5 5) (list (monster 0 2) (monster 1 3)) 1 0) +;; 1) +;; (orc-world (player 5 5 5) (list (monster 0 2) (monster 1 3)) 1 1) +(define (move-target w n) + (set-orc-world-target! w (modulo (+ n (orc-world-target w)) MONSTER#))) + +;; OrcWorld -> Void +;; Effect: ends the player's turn by setting the number of attacks to 0 +(define (end-turn w) + (set-orc-world-attack#! w 0)) + +;; OrcWorld -> Void +;; Effect: reduces the number of remaining attacks for this turn +;; and increases the player's health level +(define (heal w) + (decrease-attack# w) + (player-health+ (orc-world-player w) HEALING)) + +;; OrcWorld -> Void +(define (block w) + (decrease-attack# w) + (player-armor+ (orc-world-player w) BLOCK)) + +;; OrcWorld -> Void +;; Effect: reduces a targeted monster's health +(define (stab w) + (decrease-attack# w) + (define target (current-target w)) + (define damage + (random-quotient (player-strength (orc-world-player w)) + STAB-DAMAGE)) + (damage-monster target damage)) + +;; OrcWorld -> Void +;; Effect: damages a random number of live monsters, +;; determined by strength of the player +;; starting with the currently targeted monster +(define (flail w) + (decrease-attack# w) + (define target (current-target w)) + (define alive (filter monster-alive? (orc-world-lom w))) + (define pick# + (min + (random-quotient (player-strength (orc-world-player w)) + FLAIL-DAMAGE) + (length alive))) + (define getem (cons target (take alive pick#))) + (for-each (lambda (m) (damage-monster m 1)) getem)) + +;; OrcWorld -> Void + +;; Effect: reduces player agility by x and 2x damages a random number +;; of live monsters +(define (masturbate w) + (decrease-attack# w) + (define alive (filter monster-alive? (orc-world-lom w))) + (define x (random-quotient (player-strength (orc-world-player w)) + MASTURBATE-DAMAGE)) + (define pick# (min x (length alive))) + (define getem (take alive pick#)) + (player-agility+ (orc-world-player w) (- x)) + (for-each (lambda (m) (damage-monster m (* 2 x))) getem)) + +;; OrcWorld -> Void +;; Effect: decrease number of remaining attacks +(define (decrease-attack# w) + (set-orc-world-attack#! w (sub1 (orc-world-attack# w)))) + +;; Monster Nat -> Void +;; Effect: reduces the hit-strength of a monster +(define (damage-monster m delta) + (set-monster-health! m (interval- (monster-health m) delta))) + +;; World -> Monster +(define (current-target w) + (list-ref (orc-world-lom w) (orc-world-target w))) + +;; ----------------------------------------------------------------------------- +;; monster action + +;; OrcWorld -> Void +;; if it is the monsters turn, they attack +;; > (orc-world (player 4 4 4) empty 3 3) +;; (orc-world (player 4 4 4) empty 3 3) +(define (give-monster-turn-if-attack#=0 w) + (when (zero? (orc-world-attack# w)) + (define player (orc-world-player w)) + (all-monsters-attack-player player (orc-world-lom w)) + (set-orc-world-attack#! w (random-number-of-attacks player)))) + +;; Player [Listof Monster] -> Void +;; Each monster attacks the player +(define (all-monsters-attack-player player lom) + ;; Monster -> Void + (define (one-monster-attacks-player monster) + (define armor (player-armor player)) + (define block (cond + [(zero? armor) 0] + [else (random+ armor)])) + ;; block buffers the damage + (define (damage d) + (+ d block)) + ;; reduce player's armor by block + (player-armor+ player (* -1 block)) + (cond + [(orc? monster) + (player-health+ player (damage (random- (orc-club monster))))] + [(hydra? monster) + (player-health+ player (damage (random- (monster-health monster))))] + [(hydrar? monster) + (player-health+ player (random- (monster-health monster)))] + [(slime? monster) + (player-health+ player (damage -1)) + (player-agility+ player (damage (random- (slime-sliminess monster))))] + [(brigand? monster) + (case (random 3) + [(0) (player-health+ player (damage HEALTH-DAMAGE))] + [(1) (player-agility+ player (damage AGILITY-DAMAGE))] + [(2) (player-strength+ player (damage STRENGTH-DAMAGE))])])) + ;; -- IN -- + (for-each one-monster-attacks-player (filter monster-alive? lom))) + +;; ----------------------------------------------------------------------------- +;; actions on player + +;; [Player -> Nat] [Player Nat -> Void] Nat -> Player Nat -> Void +;; effect: change player's selector attribute by adding delta, but max out +(define (player-update! setter selector max-value) + (lambda (player delta) + (setter player + (interval+ (selector player) delta max-value)))) + +;; Player Nat -> Void +(define player-health+ + (player-update! set-player-health! player-health MAX-HEALTH)) + +;; Player Nat -> Void +(define player-agility+ + (player-update! set-player-agility! player-agility MAX-AGILITY)) + +;; Player Nat -> Void +(define player-strength+ + (player-update! set-player-strength! player-strength MAX-STRENGTH)) + +;; Player Nat -> Void +(define player-armor+ + (player-update! set-player-armor! player-armor MAX-ARMOR)) + +; +; +; +; ;;;;; ;; ; +; ; ; ; +; ; ; ;;;; ;; ;; ;;; ; ;;;; ;; ;;; ;;; ;; ;; ;;; ;; +; ; ; ; ; ;; ; ; ;; ; ; ;; ; ;; ; ; ;; +; ;;;; ;;;;;; ; ; ; ; ;;;;;; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; +; ;;; ; ;;;;; ;;; ;;; ;;; ;; ;;;;; ;;;;; ;;;;; ;;; ;;; ;;; ; +; ; +; ;;;; +; +; + +;; OrcWorld Boolean Image -> Image +;; draws all the monsters and the player, then adds message +(define (render-orc-world w with-target additional-text) + (define i-player (render-player (orc-world-player w))) + (define i-monster (render-monsters (orc-world-lom w) with-target)) + (above V-SPACER + (beside H-SPACER + i-player + H-SPACER H-SPACER H-SPACER + (above i-monster + V-SPACER V-SPACER V-SPACER + additional-text) + H-SPACER) + V-SPACER)) + +;; Player -> Image +;; render player with three status bars +(define (render-player p) + (above/align + "left" + (status-bar (player-strength p) MAX-STRENGTH STRENGTH-COLOR STRENGTH) + V-SPACER + (status-bar (player-agility p) MAX-AGILITY AGILITY-COLOR AGILITY) + V-SPACER + (status-bar (player-health p) MAX-HEALTH HEALTH-COLOR HEALTH) + V-SPACER + (status-bar (player-armor p) MAX-ARMOR ARMOR-COLOR ARMOR) + V-SPACER V-SPACER V-SPACER + PLAYER-IMAGE)) + +;; Nat Nat Color String -> Image +;; creates a labeled rectangle of width/max proportions +;; assume: (<= width max) +(define (status-bar v-current v-max color label) + (define w (* (/ v-current v-max) HEALTH-BAR-WIDTH)) + (define f (rectangle w HEALTH-BAR-HEIGHT 'solid color)) + (define b (rectangle HEALTH-BAR-WIDTH HEALTH-BAR-HEIGHT 'outline color)) + (define bar (overlay/align 'left 'top f b)) + (beside bar H-SPACER (text label HEALTH-SIZE color))) + +;; String -> Image +(define (message str) + (text str MESSAGES-SIZE MESSAGE-COLOR)) + +;; OrcWorld -> Image +(define (instructions w) + (define na (number->string (orc-world-attack# w))) + (define ra (string-append REMAINING na)) + (above (text ra INSTRUCTION-TEXT-SIZE ATTACK-COLOR) INSTRUCTION-TEXT)) + +;; [Listof Monster] [Opt Nat] -> Image +;; add all monsters on lom, including status bar +;; label the target unless it isn't called for +(define (render-monsters lom with-target) + ;; the currently targeted monster (if needed) + (define target + (if (number? with-target) + (list-ref lom with-target) + 'a-silly-symbol-that-cannot-be-eq-to-an-orc)) + + ;; Monster -> Image + (define (render-one-monster m) + (define image + (if (eq? m target) + (overlay TARGET (monster-image m)) + (monster-image m))) + (define health (monster-health m)) + (define health-bar + (if (= health 0) + (overlay DEAD-TEXT (status-bar 0 1 'white "")) + (status-bar health MONSTER-HEALTH0 MONSTER-COLOR ""))) + (above health-bar image)) + + (arrange (map render-one-monster lom))) + +;; [Listof Image] -> Image +;; break a list of images into rows of PER-ROW +(define (arrange lom) + (cond + [(empty? lom) empty-image] + [else (define row-image (apply beside (take lom PER-ROW))) + (above row-image (arrange (drop lom PER-ROW)))])) + + +; +; +; +; ;;;;;; ;; ;;; +; ; ; ; ; ; +; ; ; ;; ;; ;;; ; ; +; ;;; ;; ; ; ;; ; +; ; ; ; ; ; ; ; +; ; ; ; ; ; ; +; ; ; ; ; ; ;; +; ;;;;;; ;;; ;;; ;;; ;; ;; +; +; +; +; + +;; OrcWorld -> Boolean +;; Has the player won? +;; > (orc-world (player 1 1 1) (list (monster 0 0)) 0 0) +;; #t +(define (win? w) + (all-dead? (orc-world-lom w))) + +;; OrcWorld -> Boolean +;; Has the player lost? +;; > (lose? (orc-world (player 0 2 2) empty 0 0)) +;; #t +(define (lose? w) + (player-dead? (orc-world-player w))) + +;; Player -> Boolean +;; Is the player dead? +;; > (orc-world (player 1 0 1) empty 0 0) +;; #t +(define (player-dead? p) + (or (= (player-health p) 0) + (= (player-agility p) 0) + (= (player-strength p) 0))) + +;; [Listof Monster] -> Boolean +;; Are all the monsters in the list dead?s +;; > (all-dead? (orc-world (player 5 5 5) (list (monster 1 0)) 0 1)) +;; #t +(define (all-dead? lom) + (not (ormap monster-alive? lom))) + +;; Monster -> Boolean +;; Is the monster alive? +(define (monster-alive? m) + (> (monster-health m) 0)) + + +; +; +; +; ;; +; ; +; ; ; ;; ;; ;; ;; ;;;;; +; ; ; ; ; ; ; ; ; +; ; ; ; ; ;; ;;;; +; ;;; ; ; ;; ; +; ; ; ; ;; ; ; ; ; +; ;;; ;;; ;; ;; ;; ;; ;;;;; +; +; +; +; + +;; Nat Nat -> Nat +;; a random number between 1 and the (quotient x y) +(define (random-quotient x y) + (define div (quotient x y)) + (if (> 0 div) 0 (random+ (add1 div)))) + +;; Nat -> Nat +;; (random+ n) creates a random number in [1,n] +(define (random+ n) + (add1 (random n))) + +;; Nat -> Nat +;; (random+ n) creates a random number in [-n,-1] +(define (random- n) + (- (add1 (random n)))) + +;; Nat Nat [Nat] -> Nat +;; subtract n from m but stay in [0,max-value] +(define (interval- n m (max-value 100)) + (min (max 0 (- n m)) max-value)) + +;; Nat Nat [Nat] -> Nat +;; subtract n from m but stay in [0,max-value] +(define (interval+ n m (max-value 100)) + (interval- n (- m) max-value)) + +; +; +; +; ;;;;;; +; ; ; ; +; ; ;;;; ;;;;; ;;;;; ;;;;; +; ; ; ; ; ; ; ; ; +; ; ;;;;;; ;;;; ; ;;;; +; ; ; ; ; ; +; ; ; ; ; ; ; ; ; +; ;;; ;;;;; ;;;;; ;;; ;;;;; +; +; +; +; + +(module+ test + + (require rackunit rackunit/text-ui) + + ;; Test structs + (define WORLD0 (orc-world (initialize-player) empty 0 0)) + (define WORLD1 (struct-copy orc-world (initialize-orc-world) [attack# 5])) + (define (WORLD2) (struct-copy orc-world (initialize-orc-world) [attack# 0])) + ;; these are random worlds + (define AN-ORC (orc 'image 0 5)) + (define A-SLIME (slime 'image 1 6)) + (define A-HYDRA (hydra 'image 2)) + (define A-BRIGAND (brigand 'image 3)) + + ;; testing move-target + + (check-equal? (let ([w (orc-world 'dummy 'dummy 'dummy 0)]) + (move-target w +1) + w) + (orc-world 'dummy 'dummy 'dummy 1)) + (check-equal? (let ([w (orc-world 'dummy 'dummy 'dummy 0)]) + (move-target w -1) + w) + (orc-world 'dummy 'dummy 'dummy (- MONSTER# 1))) + (check-equal? (let ([w (orc-world 'dummy 'dummy 'dummy 0)]) + (move-target w (- PER-ROW)) + w) + (orc-world 'dummy 'dummy 'dummy (- MONSTER# PER-ROW))) + (check-equal? (let ([w (orc-world 'dummy 'dummy 'dummy 1)]) + (move-target w (+ PER-ROW)) + w) + (orc-world 'dummy 'dummy 'dummy (+ PER-ROW 1))) + (check-equal? (begin + (move-target WORLD1 0) + WORLD1) + WORLD1) + (check-equal? (let () + (define w (struct-copy orc-world WORLD1)) + (move-target w 4) + w) + (struct-copy orc-world WORLD1 [target (+ 4 (orc-world-target WORLD1))])) + (check-equal? (current-target WORLD1) + (first (orc-world-lom WORLD1))) + + ;; testing basic player manipulations + + (check-equal? (let ([p (player 1 0 0 0)]) + (player-health+ p 5) + p) + (player 6 0 0 0)) + (check-equal? (let ([p (player 0 1 0 0)]) + (player-agility+ p 5) + p) + (player 0 6 0 0)) + + (check-equal? (let ([p (player 0 0 1 0)]) + (player-strength+ p 5) + p) + (player 0 0 6 0)) + + (check-equal? (let ([p (player 5 5 5 0)]) + (all-monsters-attack-player p (list (orc 'image 1 1))) + p) + (player 4 5 5 0)) + + (check-equal? (let ([p (player 5 5 5 0)]) + (all-monsters-attack-player p (list (hydra 'image 1))) + p) + (player 4 5 5 0)) + + (check-equal? (let ([p (player 5 5 5 0)]) + (all-monsters-attack-player p (list (slime 'image 1 1))) + p) + (player 4 4 5 0)) + + (check member + (let ([p (player 5 5 5 0)]) + (all-monsters-attack-player p (list (brigand 'image 1))) + p) + (list (player 3 5 5 0) + (player 5 2 5 0) + (player 5 5 1 0))) + + ;; Properties + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; Property: + ;; the output will always be in [1, (/ X Y)] + (define (prop:rand-frac-range i) + (test-begin + (for ([i (in-range i)]) + (define x (random 4294967087)) + (define y (random 4294967087)) + (check-true (<= 1 (random-quotient x y) (add1 (/ x y))))))) + + ;; Property: + ;; The number of the monsters in the list is equal to + ;; MONSTER-NUM + (define (prop:monster-init-length i) + (test-begin + (for ([i (in-range i)]) + (check-true (= MONSTER# + (length (initialize-monsters))))))) + + ;; Property: + ;; the player will have less points in at least one of its + ;; fields + (define (prop:monster-attack-player-dec i) + (test-begin + (for ([i (in-range i)]) + (define pl (player MAX-HEALTH MAX-AGILITY MAX-STRENGTH 0)) + (define mon (first (initialize-monsters))) + (begin + (all-monsters-attack-player pl (list mon)) + (check-true (or (< (player-health pl) MAX-HEALTH) + (< (player-agility pl) MAX-AGILITY) + (< (player-strength pl) MAX-STRENGTH))))))) + + ;; Property: + ;; If there are monster, then the player will + ;; have less points in at least one of its fields + (define (prop:monsters-attack-player-dec i) + (test-begin + (for ([i (in-range i)]) + (define pl (player MAX-HEALTH MAX-AGILITY MAX-STRENGTH 0)) + (define monsters (initialize-monsters)) + (define wor (orc-world pl monsters 0 0)) + (begin + (all-monsters-attack-player pl monsters) + (check-true (or (< (player-health pl) MAX-HEALTH) + (< (player-agility pl) MAX-AGILITY) + (< (player-strength pl) MAX-STRENGTH))))))) + + ;; Property: The health of the targeted monster, m, + ;; is less than what it was. and + ;; [(sub1 (monster-health m)), + ;; (- (monster-health m) + ;; (/ (player-strength (orc-world-player w)) 2))] + (define (prop:stab!-health i) + (test-begin + (for ([i (in-range i)]) + (begin (define mon (first(initialize-monsters))) + (define ht (monster-health mon)) + (define pl (random-player)) + (define w (orc-world pl (list mon) 2 0)) + (stab w) + (check-true (> ht (monster-health (first (orc-world-lom w))))))))) + + ;; random-player: -> Player + ;; creates a random player + (define (random-player) + (player (add1 (random MAX-HEALTH)) + (add1 (random MAX-AGILITY)) + (add1 (random MAX-STRENGTH)) + 0)) + + ;; testing initializers + (prop:monster-init-length 1000) + (check-true (monster? (first (initialize-monsters)))) + (check-true (> 10 (monster-health (first (initialize-monsters))))) + (check-equal? (length (initialize-monsters)) MONSTER#) + (check-equal? (length (orc-world-lom WORLD1)) MONSTER#) + (check-true (>= (let ([p (initialize-player)]) + (player-health p)) + (let ([p (initialize-player)]) + (all-monsters-attack-player p (list AN-ORC)) + (player-health p)))) + (check-true (> (player-health (initialize-player)) + (let ([p (initialize-player)]) + (all-monsters-attack-player p (list A-HYDRA)) + (player-health p)))) + (check-true (< (let ([p (initialize-player)]) + (all-monsters-attack-player p (list A-SLIME)) + (player-agility p)) + (let ([p (initialize-player)]) + (player-agility p)))) + (check-true (let ([p (initialize-player)]) + (all-monsters-attack-player p (list A-BRIGAND)) + (or (= (player-health p) + (- (player-health (initialize-player)) 2)) + (= (player-agility p) + (- (player-agility (initialize-player)) 3)) + (= (player-strength p) + (- (player-strength (initialize-player)) 4))))) + (check-equal? (length (orc-world-lom WORLD1)) MONSTER#) + (check-equal? (orc-world-player WORLD1) (orc-world-player WORLD1)) + + ;; testing the-monster's attacks + + (prop:monster-attack-player-dec 1000) + (prop:monsters-attack-player-dec 1000) + (check-true (or (> (player-health (orc-world-player (WORLD2))) + (player-health (orc-world-player + (let ([w (WORLD2)]) + (all-monsters-attack-player (orc-world-player w) (orc-world-lom w)) + w)))) + (> (player-strength (orc-world-player (WORLD2))) + (player-strength (orc-world-player + (let ([w (WORLD2)]) + (all-monsters-attack-player (orc-world-player w) (orc-world-lom w)) + w)))) + (> (player-agility (orc-world-player (WORLD2))) + (player-agility (orc-world-player + (let ([w (WORLD2)]) + (all-monsters-attack-player (orc-world-player w) (orc-world-lom w)) + w)))))) + + ;; testing the player's actions + + (prop:stab!-health 1000) + (test-begin (define o (orc 'image 0 5)) + (damage-monster o 5) + (check-equal? o (orc 'image 0 5))) + (test-begin (define o (orc 'image 0 5)) + (damage-monster o 0) + (check-equal? o (orc 'image 0 5))) + (check-equal? (player-health (orc-world-player + (let () + (define w (struct-copy orc-world WORLD1)) + (heal w) + w))) + (min MAX-HEALTH + (+ 8 (player-health (orc-world-player WORLD1))))) + + (check-equal? (length (orc-world-lom + (let () + (define w (struct-copy orc-world WORLD1)) + (stab w) + w))) + MONSTER#) + + ;; testing game predicates + + (check-false (lose? WORLD0)) + (check-true (lose? (orc-world (player 0 30 30 0) empty 0 0))) + (check-true (all-dead? (list (orc 'image 0 0) (hydra 'image 0)))) + (check-true (all-dead? (list AN-ORC))) + (check-true (win? (orc-world (initialize-player) (list (orc 'image 0 0)) 0 0))) + (check-true (win? (orc-world (initialize-player) (list AN-ORC) 0 0))) + (check-true (end-of-orc-battle? (orc-world (initialize-player) (list (orc 'image 0 0)) 0 0))) + (check-true (end-of-orc-battle? (orc-world (initialize-player) (list AN-ORC) 0 0))) + (check-true (end-of-orc-battle? (orc-world (player 0 30 30 0) empty 0 0))) + (check-true (player-dead? (player 0 2 5 0))) + (check-false (player-dead? (initialize-player))) + (check-false (not (monster-alive? A-HYDRA))) + (check-true (monster-alive? (monster 'image 1))) + (check-false (monster-alive? (orc 'image 0 0))) + + ;; testing utilities + + (prop:rand-frac-range 1000) + + "all tests run") diff --git a/eight/graphics/README.txt b/eight/graphics/README.txt deleted file mode 100644 index 5895c77..0000000 --- a/eight/graphics/README.txt +++ /dev/null @@ -1,3 +0,0 @@ -Graphics from github.com/racket/realm - -Commit: 973041cb6a5c696b99b79a diff --git a/eight/graphics/brigand.bmp b/eight/graphics/brigand.bmp deleted file mode 100644 index 7bbd3c0..0000000 Binary files a/eight/graphics/brigand.bmp and /dev/null differ diff --git a/eight/graphics/hydra.png b/eight/graphics/hydra.png deleted file mode 100644 index b495920..0000000 Binary files a/eight/graphics/hydra.png and /dev/null differ diff --git a/eight/graphics/hydrar.png b/eight/graphics/hydrar.png deleted file mode 100644 index e555bfe..0000000 Binary files a/eight/graphics/hydrar.png and /dev/null differ diff --git a/eight/graphics/orc.gif b/eight/graphics/orc.gif deleted file mode 100644 index 5553322..0000000 Binary files a/eight/graphics/orc.gif and /dev/null differ diff --git a/eight/graphics/orc.png b/eight/graphics/orc.png deleted file mode 100644 index d269b6a..0000000 Binary files a/eight/graphics/orc.png and /dev/null differ diff --git a/eight/graphics/orcSprite.png b/eight/graphics/orcSprite.png deleted file mode 100644 index cdc223c..0000000 Binary files a/eight/graphics/orcSprite.png and /dev/null differ diff --git a/eight/graphics/player.bmp b/eight/graphics/player.bmp deleted file mode 100644 index c6a04a0..0000000 Binary files a/eight/graphics/player.bmp and /dev/null differ diff --git a/eight/graphics/slime.bmp b/eight/graphics/slime.bmp deleted file mode 100644 index 208c188..0000000 Binary files a/eight/graphics/slime.bmp and /dev/null differ diff --git a/eight/orc.rkt b/eight/orc.rkt deleted file mode 100644 index f00d587..0000000 --- a/eight/orc.rkt +++ /dev/null @@ -1,943 +0,0 @@ -#lang racket - -#| - - From github.com/racket/realm - - With some trivial changes. - - Commit: 973041cb6a5c696b99b79a -|# - -#| - The Orc game - ------------- - - The Orc game is a turn-based battle game between monsters and the player. - - The player encounters a room full of monsters of all kinds, including - orcs, hydras, hydrars, slimes, and brigands. They are ready to attack. It is - the player's task to get rid of the monsters. - - When the game starts up, it is the player's turn, meaning she is given - permission to attack a (randomly chosen number) of times. The player uses - nine keys to play - -- With the four arrow keys the player navigates among the twelve monsters. - -- With "s", "f", "h", and "m" - -- the player can 's'tab a specific monster, - -- the player may 'f'lail at several monsters; - -- the player may 'h'eal herself. - -- the player may 'm'asturbate for a change. - -- the player may 'b'lock to gain armor. - When the player runs out of attacks, all live monsters attack the player. - After that, it is the player's turn again. - - Just in case, the player can end a turn prematurely with "e". - - Play - ---- - - Run and evaluate - (start-game) - This will pop up a window that displays the player's vitals, the orcs and - their basic state, and the game instructions. -|# - - -(require 2htdp/image 2htdp/universe) - -; -; -; -; ;;; ;;; ;;; ;; ;; -; ; ; ; ; ; ; -; ; ; ;; ;;; ;;; ; ; ; ;;;; ;; ;;; ; ;;; ; -; ; ; ;; ;; ;; ; ; ; ; ; ;; ; ; ;; -; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; -; ;;; ;;;;; ;;;; ; ; ;;;; ;;;;; ;;;;; ;;; ;; -; -; -; -; - -;; The OrcWorld as Data: -(struct orc-world (player lom attack# target) #:transparent #:mutable) -;; A OrcWorld is a (orc-world Player [listof Monster] Nat Nat) -;; The third field of the world refers to the number of attacks left. -;; The fourth field refers to the position of the next attack target. - -(struct player (health agility strength armor) #:transparent #:mutable) -;; A Player is a (player Nat Nat Nat Nat) -;; The player's fields correspond to hit points, strength, agility, armor. - -(struct monster (image [health #:mutable]) #:transparent) -(struct orc monster (club) #:transparent) -(struct hydra monster () #:transparent) -(struct hydrar monster () #:transparent) -(struct slime monster (sliminess) #:transparent) -(struct brigand monster () #:transparent) -;; A Monster is a (monster Image Nat) -;; (moster i h) is a monster at position i in the list with health h -;; Each monster is equipped with the index number, -;; which is used to identify the current target. -;; -;; An Orc is an (orc Nat Nat Nat) -;; A Slime is a (slime Nat Nat Nat) -;; A Brigrand is a (brigand Nat Nat) -;; A Hydra is a (hydra Nat Nat) -;; A Hydrar is a (hydrar Nat Nat) -;; -;; The four monster types all inherit the id and health fields from monster. -;; Two have additional attributes: -;; -- (orc i h c) means the orc's club has strength c -;; -- (slime i h a) means the slime can reduce the player's agility by a - -;; ----------------------------------------------------------------------------- -;; THE CONSTANTS IN THE WORLD - -;; player attributes -(define MAX-HEALTH 35) -(define MAX-AGILITY 35) -(define MAX-STRENGTH 35) -(define MAX-ARMOR 35) - -;; depending on other player attributes, -;; the game picks the number of attacks, flailing and stabbing damage -(define ATTACKS# 4) -(define STAB-DAMAGE 2) -(define FLAIL-DAMAGE 3) -(define MASTURBATE-DAMAGE 5) -(define HEALING 8) -(define BLOCK 8) - -;; monster attributes -(define MONSTER# 12) -(define PER-ROW 4) -(unless (zero? (remainder MONSTER# PER-ROW)) - (error 'constraint "PER-ROW must divide MONSTER# evenly into rows")) - -(define MONSTER-HEALTH0 9) -(define CLUB-STRENGTH 8) -(define SLIMINESS 5) - -(define HEALTH-DAMAGE -2) -(define AGILITY-DAMAGE -3) -(define STRENGTH-DAMAGE -4) - -;; string constants -(define STRENGTH "strength") -(define AGILITY "agility") -(define HEALTH "health") -(define ARMOR "armor") -(define LOSE "YOU LOSE") -(define WIN "YOU WIN") -(define DEAD "DEAD") -(define REMAINING "Remaining attacks ") -(define INSTRUCTIONS-2 "Select a monster using the arrow keys") -(define INSTRUCTIONS-1 - (string-append "Press S to stab a monster | Press F to Flail wildly " - "| Press H to Heal | Press M to Masturbate")) - -;; graphical constants -(define HEALTH-BAR-HEIGHT 12) -(define HEALTH-BAR-WIDTH 50) - -;; compute constants for image frames -(define ORC (bitmap "graphics/orc.png")) -(define HYDRA (bitmap "graphics/hydra.png")) -(define HYDRAR (bitmap "graphics/hydrar.png")) -(define SLIME (bitmap "graphics/slime.bmp")) -(define BRIGAND (bitmap "graphics/brigand.bmp")) - -(define PIC-LIST (list ORC HYDRA HYDRAR SLIME BRIGAND)) -(define w (apply max (map image-width PIC-LIST))) -(define h (apply max (map image-height PIC-LIST))) - -;; images: player, monsters, constant texts -(define PLAYER-IMAGE (bitmap "graphics/player.bmp")) - -(define FRAME (rectangle w h 'outline 'white)) -(define TARGET (circle (- (/ w 2) 2) 'outline 'blue)) - -(define ORC-IMAGE (overlay ORC FRAME)) -(define HYDRA-IMAGE (overlay HYDRA FRAME)) -(define HYDRAR-IMAGE (overlay HYDRAR FRAME)) -(define SLIME-IMAGE (overlay SLIME FRAME)) -(define BRIGAND-IMAGE (overlay BRIGAND FRAME)) - -(define V-SPACER (rectangle 0 10 "solid" "white")) -(define H-SPACER (rectangle 10 0 "solid" "white")) - -;; fonts & texts & colors -(define AGILITY-COLOR "blue") -(define HEALTH-COLOR "crimson") -(define STRENGTH-COLOR "forest green") -(define ARMOR-COLOR "goldenrod") -(define MONSTER-COLOR "crimson") -(define MESSAGE-COLOR "black") -(define ATTACK-COLOR "crimson") - -(define HEALTH-SIZE (- HEALTH-BAR-HEIGHT 4)) -(define DEAD-TEXT-SIZE (- HEALTH-BAR-HEIGHT 2)) -(define INSTRUCTION-TEXT-SIZE 16) -(define MESSAGES-SIZE 40) - -(define INSTRUCTION-TEXT - (above - (text INSTRUCTIONS-2 (- INSTRUCTION-TEXT-SIZE 2) "blue") - (text INSTRUCTIONS-1 (- INSTRUCTION-TEXT-SIZE 4) "blue"))) - -(define DEAD-TEXT (text DEAD DEAD-TEXT-SIZE "crimson")) - -; -; -; -; ;;; ;;; ; -; ;; ;; -; ;; ;; ;;;; ;;; ;; ;; -; ; ; ; ; ; ; ;; ; -; ; ; ; ;;;;; ; ; ; -; ; ; ; ; ; ; ; -; ; ; ; ;; ; ; ; -; ;;; ;;; ;;; ;; ;;;;; ;;; ;;; -; -; -; -; - -;; Start the game -(define (start-game) - (big-bang (initialize-orc-world) - (on-key player-acts-on-monsters) - (to-draw render-orc-battle) - (stop-when end-of-orc-battle? render-the-end))) - -;; -> OrcWorld -;; creates an orc-world ready for battling orcs -(define (initialize-orc-world) - (define player0 (initialize-player)) - (define lom0 (initialize-monsters)) - (orc-world player0 lom0 (random-number-of-attacks player0) 0)) - -;; OrcWorld Key-Event -> OrcWorld -;; act on key events by the player, if the player has attacks left -(define (player-acts-on-monsters w k) - (cond - [(zero? (orc-world-attack# w)) w] - - [(key=? "s" k) (stab w)] - [(key=? "h" k) (heal w)] - [(key=? "f" k) (flail w)] - [(key=? "m" k) (masturbate w)] - [(key=? "b" k) (block w)] - - [(key=? "right" k) (move-target w +1)] - [(key=? "left" k) (move-target w -1)] - [(key=? "down" k) (move-target w (+ PER-ROW))] - [(key=? "up" k) (move-target w (- PER-ROW))] - - [(key=? "e" k) (end-turn w)] -;; [(key=? "n" k) (initialize-orc-world)] - - [else w]) - (give-monster-turn-if-attack#=0 w) - w) - -;; OrcWorld -> Image -;; renders the orc world -(define (render-orc-battle w) - (render-orc-world w (orc-world-target w) (instructions w))) - -;; OrcWorld -> Boolean -;; is the battle over? i.e., the player lost or all monsters are dead -(define (end-of-orc-battle? w) - (or (win? w) (lose? w))) - -;; OrcWorld -> Image -;; render the final orc world -(define (render-the-end w) - (render-orc-world w #f (message (if (lose? w) LOSE WIN)))) - -;; ----------------------------------------------------------------------------- - -;; WORLD MANAGEMENT -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -; -; -; -; ;;;;; ; -; ; ; -; ; ;; ;; ;;; ;;;;; -; ; ;; ; ; ; -; ; ; ; ; ; -; ; ; ; ; ; -; ; ; ; ; ; ; -; ;;;;; ;;; ;;; ;;;;; ;;; -; -; -; -; - -;; -> Player -;; create a player with maximal capabilities -(define (initialize-player) - (player MAX-HEALTH MAX-AGILITY MAX-STRENGTH 0)) - -;; -> [Listof Monster] -;; create a list of random monsters of length MONSTER-NUM, -(define (initialize-monsters) - ;; Nat -> Monster - ;; makes a random monster - (define (create-monster _) - (define health (random+ MONSTER-HEALTH0)) - (case (random 4) - [(0) (orc ORC-IMAGE health (random+ CLUB-STRENGTH))] - [(1) (hydra HYDRA-IMAGE health)] - [(2) (hydrar HYDRAR-IMAGE health)] - [(3) (slime SLIME-IMAGE health (random+ SLIMINESS))] - [(4) (brigand BRIGAND-IMAGE health)] - [else (error "can't happen")])) - (build-list MONSTER# create-monster)) - -;; Player -> Nat -;; compute a feasible number of attacks the player may execute -(define (random-number-of-attacks p) - (random-quotient (player-agility p) - ATTACKS#)) - -; -; -; -; ;;; ;;; ;;;;;; -; ; ; ; ; ; -; ; ; ;;;; ;;; ;;; ; ; ;;; ;;; ;;;; ;; ;; ;;;;; ;;;;; -; ; ; ; ; ; ; ;;; ; ; ; ; ;; ; ; ; ; -; ;;; ;;;;;; ; ; ; ; ; ; ;;;;;; ; ; ; ;;;; -; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; -; ;;; ;; ;;;;; ; ;;;;;; ;; ;;;;; ;;; ;;; ;;; ;;;;; -; ; -; ;;; -; -; - -;; ----------------------------------------------------------------------------- -;; player actions - -;; OrcWorld Nat -> Void -;; Effect: reduces the target by a given amount -;; > (move-target -;; (orc-world (player 5 5 5) (list (monster 0 2) (monster 1 3)) 1 0) -;; 1) -;; (orc-world (player 5 5 5) (list (monster 0 2) (monster 1 3)) 1 1) -(define (move-target w n) - (set-orc-world-target! w (modulo (+ n (orc-world-target w)) MONSTER#))) - -;; OrcWorld -> Void -;; Effect: ends the player's turn by setting the number of attacks to 0 -(define (end-turn w) - (set-orc-world-attack#! w 0)) - -;; OrcWorld -> Void -;; Effect: reduces the number of remaining attacks for this turn -;; and increases the player's health level -(define (heal w) - (decrease-attack# w) - (player-health+ (orc-world-player w) HEALING)) - -;; OrcWorld -> Void -(define (block w) - (decrease-attack# w) - (player-armor+ (orc-world-player w) BLOCK)) - -;; OrcWorld -> Void -;; Effect: reduces a targeted monster's health -(define (stab w) - (decrease-attack# w) - (define target (current-target w)) - (define damage - (random-quotient (player-strength (orc-world-player w)) - STAB-DAMAGE)) - (damage-monster target damage)) - -;; OrcWorld -> Void -;; Effect: damages a random number of live monsters, -;; determined by strength of the player -;; starting with the currently targeted monster -(define (flail w) - (decrease-attack# w) - (define target (current-target w)) - (define alive (filter monster-alive? (orc-world-lom w))) - (define pick# - (min - (random-quotient (player-strength (orc-world-player w)) - FLAIL-DAMAGE) - (length alive))) - (define getem (cons target (take alive pick#))) - (for-each (lambda (m) (damage-monster m 1)) getem)) - -;; OrcWorld -> Void - -;; Effect: reduces player agility by x and 2x damages a random number -;; of live monsters -(define (masturbate w) - (decrease-attack# w) - (define alive (filter monster-alive? (orc-world-lom w))) - (define x (random-quotient (player-strength (orc-world-player w)) - MASTURBATE-DAMAGE)) - (define pick# (min x (length alive))) - (define getem (take alive pick#)) - (player-agility+ (orc-world-player w) (- x)) - (for-each (lambda (m) (damage-monster m (* 2 x))) getem)) - -;; OrcWorld -> Void -;; Effect: decrease number of remaining attacks -(define (decrease-attack# w) - (set-orc-world-attack#! w (sub1 (orc-world-attack# w)))) - -;; Monster Nat -> Void -;; Effect: reduces the hit-strength of a monster -(define (damage-monster m delta) - (set-monster-health! m (interval- (monster-health m) delta))) - -;; World -> Monster -(define (current-target w) - (list-ref (orc-world-lom w) (orc-world-target w))) - -;; ----------------------------------------------------------------------------- -;; monster action - -;; OrcWorld -> Void -;; if it is the monsters turn, they attack -;; > (orc-world (player 4 4 4) empty 3 3) -;; (orc-world (player 4 4 4) empty 3 3) -(define (give-monster-turn-if-attack#=0 w) - (when (zero? (orc-world-attack# w)) - (define player (orc-world-player w)) - (all-monsters-attack-player player (orc-world-lom w)) - (set-orc-world-attack#! w (random-number-of-attacks player)))) - -;; Player [Listof Monster] -> Void -;; Each monster attacks the player -(define (all-monsters-attack-player player lom) - ;; Monster -> Void - (define (one-monster-attacks-player monster) - (define armor (player-armor player)) - (define block (cond - [(zero? armor) 0] - [else (random+ armor)])) - ;; block buffers the damage - (define (damage d) - (+ d block)) - ;; reduce player's armor by block - (player-armor+ player (* -1 block)) - (cond - [(orc? monster) - (player-health+ player (damage (random- (orc-club monster))))] - [(hydra? monster) - (player-health+ player (damage (random- (monster-health monster))))] - [(hydrar? monster) - (player-health+ player (random- (monster-health monster)))] - [(slime? monster) - (player-health+ player (damage -1)) - (player-agility+ player (damage (random- (slime-sliminess monster))))] - [(brigand? monster) - (case (random 3) - [(0) (player-health+ player (damage HEALTH-DAMAGE))] - [(1) (player-agility+ player (damage AGILITY-DAMAGE))] - [(2) (player-strength+ player (damage STRENGTH-DAMAGE))])])) - ;; -- IN -- - (for-each one-monster-attacks-player (filter monster-alive? lom))) - -;; ----------------------------------------------------------------------------- -;; actions on player - -;; [Player -> Nat] [Player Nat -> Void] Nat -> Player Nat -> Void -;; effect: change player's selector attribute by adding delta, but max out -(define (player-update! setter selector max-value) - (lambda (player delta) - (setter player - (interval+ (selector player) delta max-value)))) - -;; Player Nat -> Void -(define player-health+ - (player-update! set-player-health! player-health MAX-HEALTH)) - -;; Player Nat -> Void -(define player-agility+ - (player-update! set-player-agility! player-agility MAX-AGILITY)) - -;; Player Nat -> Void -(define player-strength+ - (player-update! set-player-strength! player-strength MAX-STRENGTH)) - -;; Player Nat -> Void -(define player-armor+ - (player-update! set-player-armor! player-armor MAX-ARMOR)) - -; -; -; -; ;;;;; ;; ; -; ; ; ; -; ; ; ;;;; ;; ;; ;;; ; ;;;; ;; ;;; ;;; ;; ;; ;;; ;; -; ; ; ; ; ;; ; ; ;; ; ; ;; ; ;; ; ; ;; -; ;;;; ;;;;;; ; ; ; ; ;;;;;; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; -; ;;; ; ;;;;; ;;; ;;; ;;; ;; ;;;;; ;;;;; ;;;;; ;;; ;;; ;;; ; -; ; -; ;;;; -; -; - -;; OrcWorld Boolean Image -> Image -;; draws all the monsters and the player, then adds message -(define (render-orc-world w with-target additional-text) - (define i-player (render-player (orc-world-player w))) - (define i-monster (render-monsters (orc-world-lom w) with-target)) - (above V-SPACER - (beside H-SPACER - i-player - H-SPACER H-SPACER H-SPACER - (above i-monster - V-SPACER V-SPACER V-SPACER - additional-text) - H-SPACER) - V-SPACER)) - -;; Player -> Image -;; render player with three status bars -(define (render-player p) - (above/align - "left" - (status-bar (player-strength p) MAX-STRENGTH STRENGTH-COLOR STRENGTH) - V-SPACER - (status-bar (player-agility p) MAX-AGILITY AGILITY-COLOR AGILITY) - V-SPACER - (status-bar (player-health p) MAX-HEALTH HEALTH-COLOR HEALTH) - V-SPACER - (status-bar (player-armor p) MAX-ARMOR ARMOR-COLOR ARMOR) - V-SPACER V-SPACER V-SPACER - PLAYER-IMAGE)) - -;; Nat Nat Color String -> Image -;; creates a labeled rectangle of width/max proportions -;; assume: (<= width max) -(define (status-bar v-current v-max color label) - (define w (* (/ v-current v-max) HEALTH-BAR-WIDTH)) - (define f (rectangle w HEALTH-BAR-HEIGHT 'solid color)) - (define b (rectangle HEALTH-BAR-WIDTH HEALTH-BAR-HEIGHT 'outline color)) - (define bar (overlay/align 'left 'top f b)) - (beside bar H-SPACER (text label HEALTH-SIZE color))) - -;; String -> Image -(define (message str) - (text str MESSAGES-SIZE MESSAGE-COLOR)) - -;; OrcWorld -> Image -(define (instructions w) - (define na (number->string (orc-world-attack# w))) - (define ra (string-append REMAINING na)) - (above (text ra INSTRUCTION-TEXT-SIZE ATTACK-COLOR) INSTRUCTION-TEXT)) - -;; [Listof Monster] [Opt Nat] -> Image -;; add all monsters on lom, including status bar -;; label the target unless it isn't called for -(define (render-monsters lom with-target) - ;; the currently targeted monster (if needed) - (define target - (if (number? with-target) - (list-ref lom with-target) - 'a-silly-symbol-that-cannot-be-eq-to-an-orc)) - - ;; Monster -> Image - (define (render-one-monster m) - (define image - (if (eq? m target) - (overlay TARGET (monster-image m)) - (monster-image m))) - (define health (monster-health m)) - (define health-bar - (if (= health 0) - (overlay DEAD-TEXT (status-bar 0 1 'white "")) - (status-bar health MONSTER-HEALTH0 MONSTER-COLOR ""))) - (above health-bar image)) - - (arrange (map render-one-monster lom))) - -;; [Listof Image] -> Image -;; break a list of images into rows of PER-ROW -(define (arrange lom) - (cond - [(empty? lom) empty-image] - [else (define row-image (apply beside (take lom PER-ROW))) - (above row-image (arrange (drop lom PER-ROW)))])) - - -; -; -; -; ;;;;;; ;; ;;; -; ; ; ; ; ; -; ; ; ;; ;; ;;; ; ; -; ;;; ;; ; ; ;; ; -; ; ; ; ; ; ; ; -; ; ; ; ; ; ; -; ; ; ; ; ; ;; -; ;;;;;; ;;; ;;; ;;; ;; ;; -; -; -; -; - -;; OrcWorld -> Boolean -;; Has the player won? -;; > (orc-world (player 1 1 1) (list (monster 0 0)) 0 0) -;; #t -(define (win? w) - (all-dead? (orc-world-lom w))) - -;; OrcWorld -> Boolean -;; Has the player lost? -;; > (lose? (orc-world (player 0 2 2) empty 0 0)) -;; #t -(define (lose? w) - (player-dead? (orc-world-player w))) - -;; Player -> Boolean -;; Is the player dead? -;; > (orc-world (player 1 0 1) empty 0 0) -;; #t -(define (player-dead? p) - (or (= (player-health p) 0) - (= (player-agility p) 0) - (= (player-strength p) 0))) - -;; [Listof Monster] -> Boolean -;; Are all the monsters in the list dead?s -;; > (all-dead? (orc-world (player 5 5 5) (list (monster 1 0)) 0 1)) -;; #t -(define (all-dead? lom) - (not (ormap monster-alive? lom))) - -;; Monster -> Boolean -;; Is the monster alive? -(define (monster-alive? m) - (> (monster-health m) 0)) - - -; -; -; -; ;; -; ; -; ; ; ;; ;; ;; ;; ;;;;; -; ; ; ; ; ; ; ; ; -; ; ; ; ; ;; ;;;; -; ;;; ; ; ;; ; -; ; ; ; ;; ; ; ; ; -; ;;; ;;; ;; ;; ;; ;; ;;;;; -; -; -; -; - -;; Nat Nat -> Nat -;; a random number between 1 and the (quotient x y) -(define (random-quotient x y) - (define div (quotient x y)) - (if (> 0 div) 0 (random+ (add1 div)))) - -;; Nat -> Nat -;; (random+ n) creates a random number in [1,n] -(define (random+ n) - (add1 (random n))) - -;; Nat -> Nat -;; (random+ n) creates a random number in [-n,-1] -(define (random- n) - (- (add1 (random n)))) - -;; Nat Nat [Nat] -> Nat -;; subtract n from m but stay in [0,max-value] -(define (interval- n m (max-value 100)) - (min (max 0 (- n m)) max-value)) - -;; Nat Nat [Nat] -> Nat -;; subtract n from m but stay in [0,max-value] -(define (interval+ n m (max-value 100)) - (interval- n (- m) max-value)) - -; -; -; -; ;;;;;; -; ; ; ; -; ; ;;;; ;;;;; ;;;;; ;;;;; -; ; ; ; ; ; ; ; ; -; ; ;;;;;; ;;;; ; ;;;; -; ; ; ; ; ; -; ; ; ; ; ; ; ; ; -; ;;; ;;;;; ;;;;; ;;; ;;;;; -; -; -; -; - -(module+ test - - (require rackunit rackunit/text-ui) - - ;; Test structs - (define WORLD0 (orc-world (initialize-player) empty 0 0)) - (define WORLD1 (struct-copy orc-world (initialize-orc-world) [attack# 5])) - (define (WORLD2) (struct-copy orc-world (initialize-orc-world) [attack# 0])) - ;; these are random worlds - (define AN-ORC (orc 'image 0 5)) - (define A-SLIME (slime 'image 1 6)) - (define A-HYDRA (hydra 'image 2)) - (define A-BRIGAND (brigand 'image 3)) - - ;; testing move-target - - (check-equal? (let ([w (orc-world 'dummy 'dummy 'dummy 0)]) - (move-target w +1) - w) - (orc-world 'dummy 'dummy 'dummy 1)) - (check-equal? (let ([w (orc-world 'dummy 'dummy 'dummy 0)]) - (move-target w -1) - w) - (orc-world 'dummy 'dummy 'dummy (- MONSTER# 1))) - (check-equal? (let ([w (orc-world 'dummy 'dummy 'dummy 0)]) - (move-target w (- PER-ROW)) - w) - (orc-world 'dummy 'dummy 'dummy (- MONSTER# PER-ROW))) - (check-equal? (let ([w (orc-world 'dummy 'dummy 'dummy 1)]) - (move-target w (+ PER-ROW)) - w) - (orc-world 'dummy 'dummy 'dummy (+ PER-ROW 1))) - (check-equal? (begin - (move-target WORLD1 0) - WORLD1) - WORLD1) - (check-equal? (let () - (define w (struct-copy orc-world WORLD1)) - (move-target w 4) - w) - (struct-copy orc-world WORLD1 [target (+ 4 (orc-world-target WORLD1))])) - (check-equal? (current-target WORLD1) - (first (orc-world-lom WORLD1))) - - ;; testing basic player manipulations - - (check-equal? (let ([p (player 1 0 0 0)]) - (player-health+ p 5) - p) - (player 6 0 0 0)) - (check-equal? (let ([p (player 0 1 0 0)]) - (player-agility+ p 5) - p) - (player 0 6 0 0)) - - (check-equal? (let ([p (player 0 0 1 0)]) - (player-strength+ p 5) - p) - (player 0 0 6 0)) - - (check-equal? (let ([p (player 5 5 5 0)]) - (all-monsters-attack-player p (list (orc 'image 1 1))) - p) - (player 4 5 5 0)) - - (check-equal? (let ([p (player 5 5 5 0)]) - (all-monsters-attack-player p (list (hydra 'image 1))) - p) - (player 4 5 5 0)) - - (check-equal? (let ([p (player 5 5 5 0)]) - (all-monsters-attack-player p (list (slime 'image 1 1))) - p) - (player 4 4 5 0)) - - (check member - (let ([p (player 5 5 5 0)]) - (all-monsters-attack-player p (list (brigand 'image 1))) - p) - (list (player 3 5 5 0) - (player 5 2 5 0) - (player 5 5 1 0))) - - ;; Properties - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; Property: - ;; the output will always be in [1, (/ X Y)] - (define (prop:rand-frac-range i) - (test-begin - (for ([i (in-range i)]) - (define x (random 4294967087)) - (define y (random 4294967087)) - (check-true (<= 1 (random-quotient x y) (add1 (/ x y))))))) - - ;; Property: - ;; The number of the monsters in the list is equal to - ;; MONSTER-NUM - (define (prop:monster-init-length i) - (test-begin - (for ([i (in-range i)]) - (check-true (= MONSTER# - (length (initialize-monsters))))))) - - ;; Property: - ;; the player will have less points in at least one of its - ;; fields - (define (prop:monster-attack-player-dec i) - (test-begin - (for ([i (in-range i)]) - (define pl (player MAX-HEALTH MAX-AGILITY MAX-STRENGTH 0)) - (define mon (first (initialize-monsters))) - (begin - (all-monsters-attack-player pl (list mon)) - (check-true (or (< (player-health pl) MAX-HEALTH) - (< (player-agility pl) MAX-AGILITY) - (< (player-strength pl) MAX-STRENGTH))))))) - - ;; Property: - ;; If there are monster, then the player will - ;; have less points in at least one of its fields - (define (prop:monsters-attack-player-dec i) - (test-begin - (for ([i (in-range i)]) - (define pl (player MAX-HEALTH MAX-AGILITY MAX-STRENGTH 0)) - (define monsters (initialize-monsters)) - (define wor (orc-world pl monsters 0 0)) - (begin - (all-monsters-attack-player pl monsters) - (check-true (or (< (player-health pl) MAX-HEALTH) - (< (player-agility pl) MAX-AGILITY) - (< (player-strength pl) MAX-STRENGTH))))))) - - ;; Property: The health of the targeted monster, m, - ;; is less than what it was. and - ;; [(sub1 (monster-health m)), - ;; (- (monster-health m) - ;; (/ (player-strength (orc-world-player w)) 2))] - (define (prop:stab!-health i) - (test-begin - (for ([i (in-range i)]) - (begin (define mon (first(initialize-monsters))) - (define ht (monster-health mon)) - (define pl (random-player)) - (define w (orc-world pl (list mon) 2 0)) - (stab w) - (check-true (> ht (monster-health (first (orc-world-lom w))))))))) - - ;; random-player: -> Player - ;; creates a random player - (define (random-player) - (player (add1 (random MAX-HEALTH)) - (add1 (random MAX-AGILITY)) - (add1 (random MAX-STRENGTH)) - 0)) - - ;; testing initializers - (prop:monster-init-length 1000) - (check-true (monster? (first (initialize-monsters)))) - (check-true (> 10 (monster-health (first (initialize-monsters))))) - (check-equal? (length (initialize-monsters)) MONSTER#) - (check-equal? (length (orc-world-lom WORLD1)) MONSTER#) - (check-true (>= (let ([p (initialize-player)]) - (player-health p)) - (let ([p (initialize-player)]) - (all-monsters-attack-player p (list AN-ORC)) - (player-health p)))) - (check-true (> (player-health (initialize-player)) - (let ([p (initialize-player)]) - (all-monsters-attack-player p (list A-HYDRA)) - (player-health p)))) - (check-true (< (let ([p (initialize-player)]) - (all-monsters-attack-player p (list A-SLIME)) - (player-agility p)) - (let ([p (initialize-player)]) - (player-agility p)))) - (check-true (let ([p (initialize-player)]) - (all-monsters-attack-player p (list A-BRIGAND)) - (or (= (player-health p) - (- (player-health (initialize-player)) 2)) - (= (player-agility p) - (- (player-agility (initialize-player)) 3)) - (= (player-strength p) - (- (player-strength (initialize-player)) 4))))) - (check-equal? (length (orc-world-lom WORLD1)) MONSTER#) - (check-equal? (orc-world-player WORLD1) (orc-world-player WORLD1)) - - ;; testing the-monster's attacks - - (prop:monster-attack-player-dec 1000) - (prop:monsters-attack-player-dec 1000) - (check-true (or (> (player-health (orc-world-player (WORLD2))) - (player-health (orc-world-player - (let ([w (WORLD2)]) - (all-monsters-attack-player (orc-world-player w) (orc-world-lom w)) - w)))) - (> (player-strength (orc-world-player (WORLD2))) - (player-strength (orc-world-player - (let ([w (WORLD2)]) - (all-monsters-attack-player (orc-world-player w) (orc-world-lom w)) - w)))) - (> (player-agility (orc-world-player (WORLD2))) - (player-agility (orc-world-player - (let ([w (WORLD2)]) - (all-monsters-attack-player (orc-world-player w) (orc-world-lom w)) - w)))))) - - ;; testing the player's actions - - (prop:stab!-health 1000) - (test-begin (define o (orc 'image 0 5)) - (damage-monster o 5) - (check-equal? o (orc 'image 0 5))) - (test-begin (define o (orc 'image 0 5)) - (damage-monster o 0) - (check-equal? o (orc 'image 0 5))) - (check-equal? (player-health (orc-world-player - (let () - (define w (struct-copy orc-world WORLD1)) - (heal w) - w))) - (min MAX-HEALTH - (+ 8 (player-health (orc-world-player WORLD1))))) - - (check-equal? (length (orc-world-lom - (let () - (define w (struct-copy orc-world WORLD1)) - (stab w) - w))) - MONSTER#) - - ;; testing game predicates - - (check-false (lose? WORLD0)) - (check-true (lose? (orc-world (player 0 30 30 0) empty 0 0))) - (check-true (all-dead? (list (orc 'image 0 0) (hydra 'image 0)))) - (check-true (all-dead? (list AN-ORC))) - (check-true (win? (orc-world (initialize-player) (list (orc 'image 0 0)) 0 0))) - (check-true (win? (orc-world (initialize-player) (list AN-ORC) 0 0))) - (check-true (end-of-orc-battle? (orc-world (initialize-player) (list (orc 'image 0 0)) 0 0))) - (check-true (end-of-orc-battle? (orc-world (initialize-player) (list AN-ORC) 0 0))) - (check-true (end-of-orc-battle? (orc-world (player 0 30 30 0) empty 0 0))) - (check-true (player-dead? (player 0 2 5 0))) - (check-false (player-dead? (initialize-player))) - (check-false (not (monster-alive? A-HYDRA))) - (check-true (monster-alive? (monster 'image 1))) - (check-false (monster-alive? (orc 'image 0 0))) - - ;; testing utilities - - (prop:rand-frac-range 1000) - - "all tests run") diff --git a/eleven/lazy.rkt b/eleven/lazy.rkt deleted file mode 100644 index 6f54719..0000000 --- a/eleven/lazy.rkt +++ /dev/null @@ -1,23 +0,0 @@ -#lang racket - -(define (make-lazy+ i) - (lambda () - (apply + (build-list (* 500 i) values)))) - - -(define long-big-list (build-list 5000 make-lazy+)) - - -(define (compute-every-1000th l) - (for/list ([thunk l] - [i (in-naturals)] - #:when (zero? (remainder i 1000))) - (thunk))) - - -(define (memoize.v2 suspended-c) - (define (hidden) - (define the-value (suspended-c)) - (set! hidden (lambda () the-value)) - the-value) - (lambda () (hidden))) diff --git a/five/guess.rkt b/five/guess.rkt deleted file mode 100644 index f7a117a..0000000 --- a/five/guess.rkt +++ /dev/null @@ -1,75 +0,0 @@ -#lang racket -(require 2htdp/universe 2htdp/image) - -(struct interval (small big guesses)) - -;;; constants -(define TEXT-SIZE 12) -(define HELP-TEXT - (text "↑ for larger numbers, ↓ for smaller ones" - TEXT-SIZE - "blue")) -(define HELP-TEXT2 - (text "Press = when your number is guessed; q to quit." - TEXT-SIZE - "blue")) -(define COLOR "red") -(define WIDTH (+ (image-width HELP-TEXT2) 10)) -(define HEIGHT 150) -(define SIZE 72) -(define TEXT-X 3) -(define TEXT-UPPER-Y 10) -(define TEXT-LOWER-Y 135) -(define GUESSES-SIZE 12) -(define GUESSES-COLOR "green") -(define MT-SC - (place-image/align - HELP-TEXT TEXT-X TEXT-UPPER-Y "left" "top" - (place-image/align - HELP-TEXT2 TEXT-X TEXT-LOWER-Y "left" "bottom" - (empty-scene WIDTH HEIGHT)))) - -;; main -(define (start lower upper) - (big-bang (interval lower upper 0) - (on-key deal-with-guess) - (to-draw render) - (stop-when single? render-last-scene))) - -;; key events -(define (deal-with-guess w key) - (cond [(key=? key "up") (bigger w)] - [(key=? key "down") (smaller w)] - [(key=? key "q") (stop-with w)] - [(key=? key "=") (stop-with w)] - [else w])) - -(define (smaller w) - (interval (interval-small w) - (max (interval-small w) (sub1 (guess w))) - (+ 1 (interval-guesses w)))) - -(define (bigger w) - (interval (min (interval-big w) (add1 (guess w))) - (interval-big w) - (+ 1 (interval-guesses w)))) - -(define (guess w) - (quotient (+ (interval-small w) (interval-big w)) 2)) - -(define (render w) - (overlay (overlay/offset - (text (number->string (guess w)) SIZE COLOR) 0 40 - (text (number->string (interval-guesses w)) - GUESSES-SIZE GUESSES-COLOR)) - MT-SC)) - -(define (render-last-scene w) - (overlay (overlay/offset - (text "End" SIZE COLOR) 0 40 - (text (number->string (interval-guesses w)) - GUESSES-SIZE GUESSES-COLOR)) - MT-SC)) - -(define (single? w) - (= (interval-small w) (interval-big w))) diff --git a/five/loco.rkt b/five/loco.rkt deleted file mode 100644 index 977c976..0000000 --- a/five/loco.rkt +++ /dev/null @@ -1,59 +0,0 @@ -#lang racket -(require 2htdp/universe 2htdp/image) - -(define WIDTH 300) -(define HEIGHT 300) -(define CAROILLE (bitmap/file "resources/caroille.png")) -(define CAROILLE-WIDTH (image-width CAROILLE)) - -;;; -;;; If the car is placed at X = 1/2 its width, its back will be -;;; touching the left edge of the World. -;;; -;;; If the car is place at X = - 1/2 its width, its front will be touching -;;; the left edge of the World. -;;; -(define CAROILLE-WIDTH-HALF (/ CAROILLE-WIDTH 2.0)) - -;;; Structure to represent the X position of two cars in animation. -(struct cars (one two)) - -(define (caroille-past-right-edge? pos) - (> pos (- WIDTH CAROILLE-WIDTH-HALF))) - -(define (caroille-fully-past-right-edge? pos) - (>= pos (+ WIDTH CAROILLE-WIDTH-HALF))) - -(define (caroille-fully-past-left-edge? pos) - (>= pos CAROILLE-WIDTH-HALF)) - -(define (caroille-fully-inside? pos) - (and (caroille-fully-past-left-edge? pos) - (not (caroille-past-right-edge? pos)))) - -(define (move caroilles) - (let ((caroille-one (cars-one caroilles)) - (caroille-two (cars-two caroilles))) - (cond - ;; Case set I - one of the cars is fully inside. - ((caroille-fully-inside? caroille-one) - (cars (+ 1 caroille-one) caroille-two)) - ((caroille-fully-inside? caroille-two) - (cars caroille-one (+ 1 caroille-two))) - ;; Case set II - one of the cars disappeared into the right edge. - ((caroille-fully-past-right-edge? caroille-one) - (cars (- CAROILLE-WIDTH-HALF) (+ 1 caroille-two))) - ((caroille-fully-past-right-edge? caroille-two) - (cars (+ 1 caroille-one) (- CAROILLE-WIDTH-HALF))) - ;; Case else - Both cars are partially out. - (else (cars (+ 1 caroille-one) (+ 1 caroille-two)))))) - -(define (draw-cars caroilles) - (place-image CAROILLE (cars-one caroilles) (/ HEIGHT 2) - (place-image CAROILLE (cars-two caroilles) (/ HEIGHT 2) - (empty-scene WIDTH HEIGHT)))) - -(define (start) - (big-bang (cars CAROILLE-WIDTH-HALF (- CAROILLE-WIDTH-HALF)) - (on-tick move) - (to-draw draw-cars))) diff --git a/five/resources/caroille.png b/five/resources/caroille.png deleted file mode 100644 index 052cc58..0000000 Binary files a/five/resources/caroille.png and /dev/null differ diff --git a/five/resources/caroille.svg b/five/resources/caroille.svg deleted file mode 100644 index eb4db63..0000000 --- a/five/resources/caroille.svg +++ /dev/null @@ -1,125 +0,0 @@ - - - - - caroille - - - - - - - - image/svg+xml - - caroille - - 2018-04-02 - - - rsiddharth <s@ricketyspace.net> - - - - - car - - - - - - - - - - - - - - - - - - - diff --git a/five/resources/ufo-fart.png b/five/resources/ufo-fart.png deleted file mode 100644 index 13d1c4a..0000000 Binary files a/five/resources/ufo-fart.png and /dev/null differ diff --git a/five/resources/ufo-fart.svg b/five/resources/ufo-fart.svg deleted file mode 100644 index cf86021..0000000 --- a/five/resources/ufo-fart.svg +++ /dev/null @@ -1,188 +0,0 @@ - - - - - UFO Fart - - - - - - image/svg+xml - - UFO Fart - - 2018-04-17 - - - rsiddharth <s@ricketyspace.net> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/five/resources/zarking-ufo.png b/five/resources/zarking-ufo.png deleted file mode 100644 index bd5eb43..0000000 Binary files a/five/resources/zarking-ufo.png and /dev/null differ diff --git a/five/resources/zarking-ufo.svg b/five/resources/zarking-ufo.svg deleted file mode 100644 index 84b8844..0000000 --- a/five/resources/zarking-ufo.svg +++ /dev/null @@ -1,128 +0,0 @@ - - - - - Zarking UFO - - - - - - image/svg+xml - - Zarking UFO - - 2018-03-09 - - - rsiddharth <s@ricketyspace.net> - - - - - - - - - - - - - - - - - - - - diff --git a/five/ufo.rkt b/five/ufo.rkt deleted file mode 100644 index 6f8136c..0000000 --- a/five/ufo.rkt +++ /dev/null @@ -1,86 +0,0 @@ -#lang racket -(require 2htdp/universe 2htdp/image) - -;;; world structure -(struct ufo (x y fart)) - -;;; constants -(define WORLD-WIDTH 300) -(define WORLD-HEIGHT 325) -(define MOVE-LEN 3) -(define UFO (bitmap/file "resources/zarking-ufo.png")) -(define UFO-FART (bitmap/file "resources/ufo-fart.png")) -(define UFO-WIDTH (image-width UFO)) -(define UFO-HEIGHT (image-height UFO)) -(define UFO-FART-HEIGHT (image-height UFO-FART)) - -;;; ufo movement functions -(define (ufo-move-up current-state) - (let ((x (ufo-x current-state)) - (y-up (- (ufo-y current-state) MOVE-LEN)) - (fart #t)) - (cond [(>= y-up (+ (/ UFO-HEIGHT 2) (/ UFO-FART-HEIGHT 2))) - (ufo x y-up fart)] - [else current-state]))) - -(define (ufo-move-down current-state) - (let ((x (ufo-x current-state)) - (y-down (+ (ufo-y current-state) MOVE-LEN))) - (cond [(<= y-down (- (+ WORLD-HEIGHT (/ UFO-FART-HEIGHT 2)) - (/ UFO-HEIGHT 2))) - (ufo x y-down #t)] - [else current-state]))) - - -(define (ufo-move-left current-state) - (let ((x-left (- (ufo-x current-state) MOVE-LEN)) - (y (ufo-y current-state)) - (fart #t)) - (cond [(>= x-left (/ UFO-WIDTH 2)) - (ufo x-left y fart)] - [else current-state]))) - -(define (ufo-move-right current-state) - (let ((x-right (+ (ufo-x current-state) MOVE-LEN)) - (y (ufo-y current-state)) - (fart #t)) - (cond [(<= x-right (- WORLD-WIDTH (/ UFO-WIDTH 2))) - (ufo x-right y fart)] - [else current-state]))) - - -;;; big bang functions -(define (draw-a-ufo current-state) - (place-image (overlay/align/offset - "middle" "bottom" UFO 0 35 - (if (ufo-fart current-state) - UFO-FART - (circle 0 "outline" "white"))) - (ufo-x current-state) - (ufo-y current-state) - (empty-scene WORLD-WIDTH WORLD-HEIGHT))) - -(define (add-3-to-posy current-state) - (ufo (ufo-x current-state) - (+ (ufo-y current-state) 3))) - -(define (posy-is-300 current-state) - (>= (ufo-y current-state) 300)) - -(define (move-ufo current-state key) - (cond [(key=? key "up") (ufo-move-up current-state)] - [(key=? key "down") (ufo-move-down current-state)] - [(key=? key "left") (ufo-move-left current-state)] - [(key=? key "right") (ufo-move-right current-state)] - [else current-state])) - -(define (ufo-stopped current-state key) - (let ((fart #f)) - (ufo (ufo-x current-state) (ufo-y current-state) fart))) - -;;; the big bang -(big-bang (ufo (/ WORLD-WIDTH 2) (/ WORLD-HEIGHT 2) #f) - (to-draw draw-a-ufo) - (on-key move-ufo) - (on-release ufo-stopped)) - diff --git a/fourteen/client.rkt b/fourteen/client.rkt deleted file mode 100644 index 52305a1..0000000 --- a/fourteen/client.rkt +++ /dev/null @@ -1,611 +0,0 @@ -#lang racket - -;; This module implements the client for the Hungry Henry game - -(provide - lets-eat ;; String String[IP Address] -> Meal - ;; launch single client and register at specified host - ) - -(require "shared.rkt" 2htdp/universe 2htdp/image) - -; -; -; -; ; ; -; ; ; -; ; ; ;;; ; ;; ; ;;; ; ; -; ; ; ; ; ;; ; ;; ; ; ; -; ;;;;; ; ; ; ; ; ; ; -; ; ; ;;;;; ; ; ; ; ; -; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; -; ; ; ;;;; ; ; ; ; -; ; -; ;; -; - - -;; Image Constants -(define FOOD-IMG (bitmap "graphics/cupcake.gif")) -(define PLAYER-IMG (bitmap "graphics/hungry-henry.gif")) -(define BASE (empty-scene WIDTH HEIGHT)) -(define WAYPOINT-NODE (circle 3 'solid 'black)) -;; Color Constants -(define PLAYER-COLOR "red") -(define MY-COLOR "blue") -(define WAYPOINT-COLOR "green") -;; Text Constants -(define LOADING... "Waiting For Server") -(define TEXT-SIZE 20) -(define SCORE-SIZE 20) -(define TEXT-COLOR "black") -(define END-OPEN-TEXT "your score was: ") -(define END-CLOSE-TEXT ", the winner was player ") -(define LOADING-OPEN-TEXT "\nYou are ") -(define SEPERATOR ": ") -;; PBAR constants -(define PBAR-HEIGHT 35) -(define PBAR-LOC (- HEIGHT PBAR-HEIGHT)) -(define PBAR-COLOR "red") -(define PBAR-TEXT (text "loading..." 20 "black")) -;; Message ID Constants -(define UPDATE-LENGTH 3) -(define SPLAYER-LENGTH 3) -(define SBODY-LENGTH 2) -(define END-LENGTH 2) -(define SCORE-LIST-LENGTH 2) -;; Init Constants -(define ZERO% 0) -(define LOADING (text LOADING... 20 "black")) - -;; ----------------------------------------------------------------------------- -;; State of Client - -(struct app (id img countdown) #:transparent) -(struct entree (id players food) #:transparent) - -;; Meal is one of -;; - Appetizer -;; - Entree -;; Appetizer = (app [or Id #f] Image Number∈[0,1]) -;; interpretation: -;; -- the first field is this players id, #f if it hasnt been sent yet -;; -- the second is the loading image -;; -- the third is the %%% of loading time passed, represents the loading state -;; Entree = (entree Id [Listof Feaster] [Listof Food]) -;; interpretation: -;; -- the first field is this player's id -;; -- the second field represents complete information about all players -;; -- the third field specifies the location of the cupcakes - -(define INITIAL (app #f LOADING ZERO%)) - -; -; -; -; ; -; ; -; ;;; ;;; -; ;; ;; -; ; ; ; ; ;;;; ;;; ;; ;;; -; ; ; ; ; ; ; ; ;; ; -; ; ; ; ; ; ; ; ; -; ; ;; ; ;;;;;; ; ; ; -; ; ;; ; ; ; ; ; ; -; ; ; ; ; ; ; ; -; ; ; ; ;; ; ; ; -; ;;; ;;; ;;;; ;; ;;;;;;; ;;; ;;; -; -; -; -; -; - -(define (lets-eat label server) - (big-bang INITIAL - (to-draw render-the-meal) - (on-mouse set-waypoint) - (on-receive handle-server-messages) - (register server) - (name label))) - -;; Meal Message -> Meal -;; handles incomming messages -(define (handle-server-messages meal msg) - (cond [(app? meal) (handle-appetizer-message meal msg)] - [(entree? meal) (handle-entree-message meal msg)])) - -;; Meal Number Number MouseEvent -> Meal -;; handles what happends on a click -(define (set-waypoint meal x y event) - (if (and (entree? meal) (string=? event "button-down")) - (make-package meal (list GOTO x y)) - meal)) - -;; Meal -> Image -;; deals with draw some kind of meal -(define (render-the-meal meal) - (cond [(app? meal) (render-appetizer meal)] - [(entree? meal) (render-entree meal)])) - -; -; -; -; ;;;; ; -; ; ; -; ; ; ;;; ;;;; ;;; ;;; ; ; ;;; -; ; ; ; ; ; ; ; ; ; ; ; ; -; ;;;; ; ; ; ; ; ; ; ; ; ; -; ; ; ;;;;; ; ;;;;; ; ;; ;; ;;;;; -; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; -; ; ; ;;;; ;;;; ;;;; ; ; ;;;; -; -; -; - -;; ----------------------------------------------------------------------------- -;; Appetizer - -;; Appetizer Message -> Meal -;; starts the game if the message is valid -(define (handle-appetizer-message s msg) - (cond [(id? msg) (app msg (app-img s) (app-countdown s))] - [(time? msg) (app (app-id s) (app-img s) msg)] - [(state? msg) (switch-to-entree s msg)] - ;; fault tolerant - [else s])) - -;; Appetizer State -> Meal -(define (switch-to-entree s m) - (apply entree (app-id s) (rest m))) - -;; ----------------------------------------------------------------------------- -;; Appetizer - -;; Entree Message -> Meal -;; either updates the world or ends the game -(define (handle-entree-message s msg) - (cond [(state? msg) (update-entree s msg)] - [(score? msg) (restart s msg)] - [else s])) - -;; Entree State -> Entree -;; creates a new entree based on the update mesg -(define (update-entree s state-msg) - (apply entree (entree-id s) (rest state-msg))) - -;; Entree EndMessage -> Appetizer -;; Tranistion to start state -(define (restart s end-msg) - (define score-image (render-scores end-msg)) - (app (entree-id s) (above LOADING score-image) ZERO%)) - -;; ----------------------------------------------------------------------------- -;; predicates for recognizing network messages - -;; Message -> Boolean -;; checks if message is a valid update message -(define (state? msg) - (and (list? msg) - (= UPDATE-LENGTH (length msg)) - (symbol? (first msg)) - (list? (second msg)) - (list? (third msg)) - (symbol=? SERIALIZE (first msg)) - (andmap player? (second msg)) - (andmap body? (third msg)))) - -;; Message -> Boolean -;; checks if message is a valid time message -(define (time? msg) - (and (real? msg) (<= 0 msg 1))) - -;; Message -> Boolean -;; checks if is end game message -(define (score? msg) - (and (list? msg) - (= END-LENGTH (length msg)) - (symbol? (first msg)) - (list? (second msg)) - (symbol=? SCORE (first msg)) - (score-list? (second msg)))) - -;; List -> Boolean -;; is this a list binding names to scores? -(define (score-list? l) - (for/and ([s l]) - (and (list? s) - (= SCORE-LIST-LENGTH (length s)) - (id? (first s)) - (number? (second s))))) - -; -; -; -; ; -; ; -; ;;;;;; -; ; ; -; ; ; ;; ;; ;;;; ;;; ;; ;;; ;; ;;; ;;; ;; -; ; ; ;;; ; ; ; ; ; ; ;; ; ; ;; -; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; -; ;;;;;; ;;;;;; ;;;; ;; ; ; ;;;;;;; ;;; ;;; ;;; ; -; ; -; ;; -; ;;;; -; -; - -;; ----------------------------------------------------------------------------- -;; Appetizer Drawing - -;; Appetizer -> Image -;; tells the player that we're waiting for the server. shows id -(define (render-appetizer app) - (add-progress-bar (render-id+image app) (app-countdown app))) - -;; Image Number∈[0,1] -> Image -;; draws the progress bar -(define (add-progress-bar base count) - (place-image (render-progress count) (/ WIDTH 2) PBAR-LOC base)) - -;; Number∈[0,1] -> Image -;; draw a progress bar that is count percent complete -(define (render-progress count) - (overlay PBAR-TEXT (rectangle (* count WIDTH) PBAR-HEIGHT "solid" PBAR-COLOR))) - -;; Appetizer -> Image -;; gets the text to display on the loading screen -(define (render-id+image app) - (define id (app-id app)) - (define base-image (app-img app)) - (overlay - (cond - [(boolean? id) base-image] - [else (define s (string-append LOADING-OPEN-TEXT id)) - (above base-image (text s TEXT-SIZE TEXT-COLOR))]) - BASE)) - -;; ----------------------------------------------------------------------------- -;; Entree Drawing - -;; Entree -> Image -;; draws a Entree -(define (render-entree entree) - (define id (entree-id entree)) - (define pl (entree-players entree)) - (define fd (entree-food entree)) - (add-path id pl (add-players id pl (add-food fd BASE)))) - -;; [Listof Food] Image -> Image -;; draws all the food -(define (add-food foods base-scene) - (for/fold ([scn base-scene]) ([f foods]) - (place-image FOOD-IMG (body-x f) (body-y f) scn))) - -;; Id [Listof Feaster] Image -> Image -;; draws all players -(define (add-players id lof base-scene) - (for/fold ([scn base-scene]) ([feaster lof]) - (place-image (render-avatar id feaster) - (feaster-x feaster) (feaster-y feaster) - scn))) - -;; Id Feaster -> Image -;; gets an image for the player -(define (render-avatar id player) - (define size (body-size (player-body player))) - (define color - (if (id=? id (player-id player)) MY-COLOR PLAYER-COLOR)) - (above - (render-text (player-id player)) - (overlay (render-player-score player) - PLAYER-IMG - (circle size 'outline color)))) - -;; Feaster -> Image -;; Draw the players score -(define (render-player-score player) - (render-text (number->string (get-score (body-size (player-body player)))))) - -;; Id [Listof Feaster] Image -> Image -;; draws the path of the player whose id is passed in -(define (add-path id players base-scene) - (define player - (findf (lambda (x) (id=? id (player-id x))) players)) - (if (boolean? player) - base-scene - (add-waypoint* player base-scene))) - -;; Feaster Image -> Image -;; draws the list of way points to the scene -(define (add-waypoint* player base-scene) - (define loc (body-loc (player-body player))) - (define ways (player-waypoints player)) - (define-values (resulting-scene _) - (for/fold ([scn base-scene][from loc]) ([to ways]) - (values (add-waypoint from to scn) to))) - resulting-scene) - -;; Complex Complex Image -> Image -;; Add a waypoint to the scene at those coordinates -(define (add-waypoint from to s) - (define x-from (real-part from)) - (define y-from (imag-part from)) - (define x-to (real-part to)) - (define y-to (imag-part to)) - (define with-line (add-line s x-to y-to x-from y-from WAYPOINT-COLOR)) - (place-image WAYPOINT-NODE x-to y-to with-line)) - -;; ----------------------------------------------------------------------------- -;; render the end - -;; Score -> Image -;; draws the end of the game -(define (render-scores msg) - (define scores (sort (second msg) < #:key second)) - (for/fold ([img empty-image]) ([name-score scores]) - (define txt (get-text name-score)) - (above (render-text txt) img))) - -;; (list ID Natural) -> string -;; builds a string for that winning pair -(define (get-text name-score) - (define-values (name score) (apply values name-score)) - (string-append name SEPERATOR (number->string score))) - - -; -; -; -; -; -; ;;;;; -; ;; -; ; ; ;; ;; ;;; ;;; -; ; ; ; ; ; ; -; ; ; ; ; ; ; -; ; ; ; ; ;; -; ;;;;;; ; ; ;; -; ; ; ; ; ; ; -; ; ; ; ;; ; ; -; ;;; ;;; ;;; ;; ;;; ;;; -; -; -; -; -; - -;; String -> Image -;; draws the text -(define (render-text txt) - (text txt TEXT-SIZE TEXT-COLOR)) - -;; player -> Number -;; Gets the X coord of a entrees -(define (feaster-x feaster) - (body-x (player-body feaster))) - -;; player -> Number -;; Gets the Y coord of a entrees -(define (feaster-y feaster) - (body-y (player-body feaster))) - -;; body -> Number -;; gets the X coord of a body -(define (body-x body) - (real-part (body-loc body))) - -;; body -> Number -;; gets the Y coord of a body -(define (body-y body) - (imag-part (body-loc body))) - -; -; -; -; -; -; ;;;;;;;;; ; -; ; ; ; ; -; ; ; ; ;;;; ;;;; ; ;;;;;;; ;;;; ; -; ; ; ; ; ; ; ;; ; ; ;; -; ; ; ; ; ; ; -; ; ;;;;;;;; ;;;;; ; ;;;;; -; ; ; ; ; ; -; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; -; ;;;;; ;;;;; ;;;;;; ;;;; ;;;;;; -; -; -; -; -; - -(module+ test - - (require rackunit rackunit/text-ui) - - ;; testing main client - (check-equal? (switch-to-entree (app "foo" 'blah 1) '(STATE () ())) - (entree "foo" '()'())) - (check-equal? (handle-server-messages (app #f 'ksajfhsdkjhfr 1) .5) - (handle-appetizer-message (app #f 'ksajfhsdkjhfr 1) .5)) - ;;dispatch-mouse - (check-equal? (set-waypoint (app 1 LOADING 0) 1 1 "button-down") - (app 1 LOADING 0)) - (check-equal? (set-waypoint (app 1 LOADING 0) 1 1 "button-up") - (app 1 LOADING 0)) - (check-equal? (set-waypoint (app #f LOADING 0) 1 1 "button-down") - (app #f LOADING 0)) - (check-equal? (set-waypoint (app #f LOADING 0) 1 1 "button-up") - (app #f LOADING 0)) - (check-equal? (set-waypoint (entree "player1" (list (player "player1" (body 1 1+1i) empty)) empty) 1 1 "button-up") - (entree "player1" (list (player "player1" (body 1 1+1i) empty)) empty)) - (check-equal? (set-waypoint (entree "player1" (list (player "player1" (body 1 1+1i) empty)) empty) - 1 1 "button-down") - (make-package (entree "player1" (list (player "player1" (body 1 1+1i) empty)) empty) - (list 'goto 1 1))) - ;;render-the-meal - - ;; testing message receipt - ;; app-may-start - ;; entree-msg - ;; update-msg? - - (check-true (state? `(,SERIALIZE (,(player "player1" (body 1+4i 234) `()) ,(player "player1" (body 3 3) `())) - (,(body 1+i 2) ,(body 2 2))))) - (check-true (state? `(,SERIALIZE (,(player "player1" (body 1+4i 234) `())) - (,(body 1+i 2) ,(body 2 2))))) - (check-true (state? `(,SERIALIZE () - (,(body 1+i 2) ,(body 2 2))))) - (check-true (state? `(,SERIALIZE (,(player "player1" (body 1+4i 234) `()) ,(player "player1" (body 3 3) `())) - ()))) - - (check-false (state? `(,SERIALIZE (("player1" (1+4i 234) ()) ("player1" (3 3) ())) - ((1+i 2) (2 2))))) - (check-false (state? `(,SERIALIZE (("player1" (1+4i 234) ())) - ((1+i 2) (2 2))))) - (check-false (state? `(,SERIALIZE () - ((1+i 2) (2 2))))) - (check-false (state? `(,SERIALIZE (("player1" (1+4i 234) ()) ("player1" (3 3) ())) - ()))) - (check-true (state? `(,SERIALIZE () - ()))) - (check-false (state? `(,SERIALIZE (("player1" (1+4i 234) ()) ("player1" (3 3) ())) - ((1+i 2) (2 2))))) - (check-false (state? `(,SERIALIZE (("player1" (1+4i 234) ())) - ((1+i 2) (2 2))))) - (check-false (state? `(,SERIALIZE () - ((1+i 2) (2 2))))) - (check-false (state? `(,SERIALIZE (("player1" (1+4i 234) ()) ("player1" (3 3) ())) - ()))) - - (check-false (state? '(u ((1 1+4i 234)) - ((1+i 2) (2 2))))) - (check-false (state? '(((1 1+4i 234)) - ((1+i 2) (2 2))))) - (check-false (state? '(u ((1 1+4i)) - ((1+i 2) (2 2))))) - (check-false (state? '(u ((1 1+4i 234)) - ((1+i 2) (2 b))))) - (check-false (state? '(u ((1 1+4i 234))))) - (check-false (state? '(u ((1+i 2) (2 2))))) - (check-false (state? '(((1+i 2) (2 2))))) - (check-false (state? 4)) - (check-false (state? 'f)) - ;; score-list? - (check-true (score-list? '(("s" 0) ("l" 0) ("sdf" 0)))) - (check-true (score-list? empty)) - (check-true (score-list? '(("s" 0) ("l" 0)))) - (check-false (score-list? '(('s 0) ('l 0) ('sdf 0)))) - (check-false (score-list? '((s 0) (l 0)))) - (check-false (score-list? '((s) (l)))) - (check-false (score-list? '((s 0) (l 0)))) - ;; update-entree - (check-equal? (update-entree (entree "player10" '() '()) - `(s (,(player "player1" (body 10 10) `(3 4+9i)) - ,(player "player10" (body 103 10+4i) `(3 5+78i))) - (,(body 5 10) ,(body 30 30)))) - (entree "player10" (list (player "player1" (body 10 10) (list 3 4+9i)) - (player "player10" (body 103 10+4i) (list 3 5+78i))) - (list (body 5 10) (body 30 30)))) - - - ;; testing rendering the client - - ;; draw-app - (check-equal? (render-appetizer (app #f LOADING 0)) - (add-progress-bar (overlay LOADING - BASE) - 0)) - ;; draw-entree - - - ;; draw-players - - (check-equal? (add-players "player0" - (list (player "player1" (body 40 23+34i) empty) - (player "player0" (body 50 1+3i) empty)) - BASE) - (place-image (render-avatar "player0" (player "player0" (body 50 1+3i) empty)) - 1 3 - (place-image (render-avatar "player0" (player "player1" (body 40 23+34i) empty)) - 23 34 - BASE))) - (check-equal? (add-players "player0" - (list (player "player1" (body 40 23+34i) empty)) - BASE) - (place-image (render-avatar "player0" (player "player1" (body 40 23+34i) empty)) - 23 34 - BASE)) - - ;; draw-player - - ;; get-player-image - (check-equal? (render-avatar "player0" (player "player0" (body 30 1+3i) empty)) - (above (render-text "player0") - (overlay (text (number->string (get-score 30)) 20 'black) - PLAYER-IMG (circle 30 "outline" MY-COLOR)))) - (check-equal? (render-avatar "player0" (player "player1" (body 30 1+3i) empty)) - (above (render-text "player1") - (overlay (text (number->string (get-score 30)) 20 'black) - PLAYER-IMG (circle 30 "outline" PLAYER-COLOR)))) - - ;; draw-food - (check-equal? (add-food (list (body 34 54+3i) - (body 9 45+23i)) - BASE) - (place-image FOOD-IMG - 45 23 - (place-image - FOOD-IMG - 54 3 - BASE))) - (check-equal? (add-food (list (body 34 54+3i)) - BASE) - (place-image - FOOD-IMG - 54 3 - BASE)) - - - ;; testing auxiliary functions - ;; player-x - (check-equal? (feaster-x (player 20 (body 3 1+3i) empty)) - 1) - (check-equal? (feaster-x (player 20 (body 3 4+3i) empty)) - 4) - (check-equal? (feaster-x (player 20 (body 3 4+67i) empty)) - 4) - ;; player-y - (check-equal? (feaster-y (player 20 (body 3 1+3i) empty)) - 3) - (check-equal? (feaster-y (player 20 (body 3 4+3i) empty)) - 3) - (check-equal? (feaster-y (player 20 (body 3 4+67i) empty)) - 67) - - ;; body-x - (check-equal? (body-x (body 20 1+2i)) - 1) - (check-equal? (body-x (body 20 4+2i)) - 4) - (check-equal? (body-x (body 20 3+2i)) - 3) - ;; body-y - (check-equal? (body-y (body 20 4+1i)) - 1) - (check-equal? (body-y (body 20 1+4i)) - 4) - (check-equal? (body-y (body 20 3)) - 0) - - "client: all tests run") - diff --git a/fourteen/graphics/cupcake.gif b/fourteen/graphics/cupcake.gif deleted file mode 100644 index 20b1bef..0000000 Binary files a/fourteen/graphics/cupcake.gif and /dev/null differ diff --git a/fourteen/graphics/hungry-henry.gif b/fourteen/graphics/hungry-henry.gif deleted file mode 100644 index cce6948..0000000 Binary files a/fourteen/graphics/hungry-henry.gif and /dev/null differ diff --git a/fourteen/readme.txt b/fourteen/readme.txt deleted file mode 100644 index 042b0f4..0000000 --- a/fourteen/readme.txt +++ /dev/null @@ -1,29 +0,0 @@ -This chapter implements a distributed game, dubbed "Hungry Henry." - -TO PLAY, open the file - - run.rkt - -in DrRacket. The instructions for playing are at the top of the file. - -TO EXPERIMENT, open the files - - -- run.rkt - -- server.rkt - -- client.rkt - -- shared.rkt - -in four different tabs or windows in DrRacket. Switch to the 'run.rkt' -tab and select - - View | Show Module browser - -to see how these files are related. To switch to one of these four files, -you may click the boxes in the module browsers. Alternatively click the -tab you wish to work on. It is also possible to select tabs via key -strokes. - -Each file except for 'run.rkt' comes with test submodules at the bottom of -the file. - - diff --git a/fourteen/run.rkt b/fourteen/run.rkt deleted file mode 100644 index 4a244b7..0000000 --- a/fourteen/run.rkt +++ /dev/null @@ -1,59 +0,0 @@ -#lang racket - -#| - Hungry Henry, a multi-player, distributed game - ----------------------------------------------- - - This game is a multi-player competition for cupcakes. Each player owns an - avatar, called a "Henry", and competes for a limited number of cupcakes, - distributed over a rectangular space. A player launches her Henry via - a series of mouse clicks, so-called waypoints. Her Henry moves from waypoint - to waypoint. If it gets close enough to a cupcake, he eats the cupcake and - fattens up. As a Henry fattens up, he slows down. When all cupcakes are - consumed, the fattest Henry wins. - - Notes: - 1. The cupcakes remain in place until they are eaten. - 2. Once a waypoiny is recorded, it cannot be removed. - 3. Waypoints are visited in a first-come, first-serve order. - - Play - ---- - - Click Run. Evaluate - - (serve-dinner) - - in the Interactions Panel. This will pop up three windows: - -- Matthias, a game window - -- David, another game window - -- Universe, the game server's console - - Play. You can play the part of both participants. Alternatively, click - the David or Matthias window (to obtain focus) and click again to choose - a way point for David's or Matthias's "hungry henry". Watch the hungry - henries go for the cup cake and eat them up. You can make either one of them - win or you can force a tie. - - To run the game on two distinct computers: - - -- copy this folder to another computer, determine its IP number "12.345.67.98" - -- open run.rkt - -- evaluate - (bon-appetit) - - -- on your own computer, open run.rkt and run - -- evaluate - (lets-eat SomeNameAsAString "12.345.67.98") -|# - -(require (only-in "server.rkt" bon-appetit) - (only-in "client.rkt" lets-eat) - 2htdp/universe) - -;; launch server worlds for playtesting -(define (serve-dinner) - (launch-many-worlds - (bon-appetit) - (lets-eat "Matthias" LOCALHOST) - (lets-eat "David" LOCALHOST))) diff --git a/fourteen/server.rkt b/fourteen/server.rkt deleted file mode 100644 index 078533b..0000000 --- a/fourteen/server.rkt +++ /dev/null @@ -1,1065 +0,0 @@ -#lang racket - -;; This module implements the server for the Hungry Henry game - -(provide - bon-appetit ;; -> Void - ;; launch the server for Hungry Henry - ) - -(require "shared.rkt" 2htdp/universe) - -#| ----------------------------------------------------------------------------- -The server is responsible for: --- starting the game --- moving Henrys --- have Henrys eat, remove food on collision --- collecting and broadcasting information about the movement of players --- ending games -|# - -; -; -; -; ; ; ; ; -; ; ; ; ; -; ; ; ; ; ; ;; ;; ; ; ;;; ; ; ; ; ;;; ; ;; ; ;;; ; ; -; ; ; ; ; ;; ; ; ;; ;; ; ; ; ; ; ; ; ;; ; ;; ; ; ; -; ;;;;; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ; -; ; ; ;; ; ; ; ;; ; ; ; ; ; ;;;; ; ; ; ; -; ; ; ; -; ;;; ;; ;; -; - - -;; Init Constants -(define TICK .1) -(define PLAYER-LIMIT 2) -(define START-TIME 0) -(define WAIT-TIME 250) - -(define FOOD*PLAYERS 5) - -(define WEIGHT-FACTOR 2.1) -(define BASE-SPEED (/ (expt PLAYER-SIZE 2) WEIGHT-FACTOR)) - -;; Data Definitions -(struct join (clients [time #:mutable]) #:transparent) -(struct play (players food spectators) #:transparent #:mutable) - -;; plus some update primitives: - -;; JoinUniverse Player -> JoinUniverse -(define (join-add-player j new-p) - (join (cons new-p (join-clients j)) (join-time j))) - -;; PlayUniverse IP -> PlayUniverse -(define (play-add-spectator pu new-s) - (define players (play-players pu)) - (define spectators (play-spectators pu)) - (play players (play-food pu) (cons new-s spectators))) - -;; PlayUniverse IWorld -> PlayUniverse -;; removes player that uses iworld -(define (play-remove p iw) - (define players (play-players p)) - (define spectators (play-spectators p)) - (play (rip iw players) (play-food p) (rip iw spectators))) - -;; JoinUniverse IWorld -> JoinUniverse -;; removes players and spectators that use iw from this world -(define (join-remove j iw) - (join (rip iw (join-clients j)) (join-time j))) - -;; IWorld [Listof Player] -> [Listof Player] -;; remove player that contains the given IWorld -(define (rip iw players) - (remove iw players (lambda (iw p) (iworld=? iw (ip-iw p))))) - -;; LIKE: -;; (struct ip ip? ip-id ip-iw ip-body ip-waypoints ip-player) -(define-values - (ip ip? ip-id ip-iw ip-body ip-waypoints ip-player) - (let () - (struct ip (id iw body waypoints player) #:transparent) - (define (create iw id body waypoints) - (ip id iw body waypoints (player id body waypoints))) - (values - create ip? ip-id ip-iw ip-body ip-waypoints ip-player))) - -;; ServerState is one of -;; -- JoinUniverse -;; -- PlayUniverse -;; JoinUniververse = (join [Listof IPs] Nat) -;; interpretation: -;; -- the first field lists the currently connected client-player -;; -- the second field is the number of ticks since the server started -;; PlayUniverse = (play [Listof IPs] [Listof Food] [Listof IP]) -;; interpretation: -;; -- the first field lists all participating players -;; -- the second field lists the cupcakes -;; --- the third field enumerates the spectating players -;; IP = (ip Id IWorld Body [Listof Complex] Feaster) -;; interpretation: -;; the struct represents the Universe's perspective of a connected player -;; -- the first field is the assigned unique Id -;; -- the second field is the IWorld representing the remote connection to the client -;; -- the third field is the Body of the player -;; -- the fourth field is the list of player-chosen Waypoints, -;; ordered from oldest click to most-recent -;; meaning the first one has to be visited first by the Henry -;; -- the fifth field is the serialized representation of the first four fields - -(define JOIN0 (join empty START-TIME)) - -; -; -; -; -; ;;; ;;; ; -; ;; ;; -; ;; ;; ;;;; ;;; ;; ;; -; ; ; ; ; ; ; ;; ; -; ; ; ; ;;;;; ; ; ; -; ; ; ; ; ; ; ; -; ; ; ; ;; ; ; ; -; ;;; ;;; ;;; ;; ;;;;; ;;; ;;; -; -; -; -; - -(define (bon-appetit) - (universe JOIN0 - (on-new connect) - (on-msg handle-goto-message) - (on-tick tick-tock TICK) - (on-disconnect disconnect))) - -;; ServerState IWorld -> Bundle -;; adds a new connection to a JoinUniverse and ticks. Ignores otherwise -(define (connect s iw) - (cond [(join? s) (add-player s iw)] - [(play? s) (add-spectator s iw)])) - -;; ServerState IWorld Sexpr -> Bundle -;; accepts goto messages from clients -(define (handle-goto-message s iw msg) - (cond [(and (play? s) (goto? msg)) (goto s iw msg)] - [else (empty-bundle s)])) - -;; ServerState -> Bundle -;; handle a tick event -(define (tick-tock s) - (cond [(join? s) (wait-or-play s)] - [(play? s) (move-and-eat s)])) - -;; ServerState IWorld -> Bundle -;; handles loss of a client -(define (disconnect s iw) - (cond [(join? s) (drop-client s iw)] - [(play? s) (drop-player s iw)])) - -; -; -; -; ; ; ; ; -; ; ; ; -; ; ; ;;;; ;;; ;;;;; ;;; ; ;; ;; ; -; ; ; ; ; ; ; ; ;; ; ; ;; -; ; ; ; ; ; ; ; ; ; ; ; -; ;; ;; ;;;; ; ; ; ; ; ; ; -; ;; ;; ; ; ; ; ; ; ; ; ; -; ; ; ; ;; ; ; ; ; ; ; ;; -; ; ; ;; ; ; ;;; ; ; ; ;; ; -; ; -; ;;; -; - -;; JoinUniverse -> Bundle -;; count down and might transition -(define (wait-or-play j) - (cond [(keep-waiting? j) (keep-waiting j)] - [else (start-game j)])) - -;; JoinUniverse -> Boolean -;; is it time to start? -(define (keep-waiting? j) - (or (> PLAYER-LIMIT (length (join-clients j))) - (> WAIT-TIME (join-time j)))) - -;; JoinUniverse -> [Bundle JoinUniverse] -(define (keep-waiting j) - (set-join-time! j (+ (join-time j) 1)) - (time-broadcast j)) - -;; JoinUniverse -> [Bundle JoinUniverse] -;; broadcasts the new load time fraction to the players -(define (time-broadcast j) - (define iworlds (map ip-iw (join-clients j))) - (define load% (min 1 (/ (join-time j) WAIT-TIME))) - (make-bundle j (broadcast iworlds load%) empty)) - -;; JoinUniverse -> [Bundle PlayUniverse] -;; starts the game -(define (start-game j) - (define clients (join-clients j)) - (define cupcakes (bake-cupcakes (length clients))) - (broadcast-universe (play clients cupcakes empty))) - -;; Number -> [Listof Food] -;; creates the amount of food for that number of players -(define (bake-cupcakes player#) - (for/list ([i (in-range (* player# FOOD*PLAYERS))]) - (create-a-body CUPCAKE))) - -; -; -; ;;; -; ;;;; ; ; -; ; ; ; -; ; ; ; ;;;; ; ; ;;; ; ;; ;; ; -; ; ; ; ; ; ; ; ;; ; ; ;; -; ;;; ; ; ; ; ; ; ; ; ; -; ; ; ;;;; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ;; ; ; ; ; ; ;; -; ; ; ;; ; ; ; ; ; ;; ; -; ; ; -; ;; ;;; -; - -;; PlayUniverse -> Bundle -;; moves everything. eats. may end game -(define (move-and-eat pu) - (define nplayers (move-player* (play-players pu))) - (define nfood (feed-em-all nplayers (play-food pu))) - (progress nplayers nfood (play-spectators pu))) - -;; [Listof IP] -> [Listof IP] -;; moves all players -(define (move-player* players) - (for/list ([p players]) - (define waypoints (ip-waypoints p)) - (cond [(empty? waypoints) p] - [else (define body (ip-body p)) - (define nwpts - (move-toward-waypoint body waypoints)) - (ip (ip-iw p) (ip-id p) body nwpts)]))) - -;; Body [Listof Complex] -> [Listof Complex] -;; effect: set body's location -;; determine new waypoints for player -;; pre: (cons? waypoints) -(define (move-toward-waypoint body waypoints) - (define goal (first waypoints)) - (define bloc (body-loc body)) - (define line (- goal bloc)) - (define dist (magnitude line)) - (define speed (/ BASE-SPEED (body-size body))) - (cond - [(<= dist speed) - (set-body-loc! body goal) - (rest waypoints)] - [else ; (> distance speed 0) - (set-body-loc! body (+ bloc (* (/ line dist) speed))) - waypoints])) - -;; [Listof Player] [Listof Food] -> [Listof Food] -;; feeds all players and removes food -(define (feed-em-all players foods) - (for/fold ([foods foods]) ([p players]) - (eat-all-the-things p foods))) - -;; IP [Listof Food] -> [Listof Food] -;; effect: fatten player as he eats -;; determine left-over foods -(define (eat-all-the-things player foods) - (define b (ip-body player)) - (define (new-cupcakes) - (cond [(> (length foods) 10) '()] - [else - (for/list ([i (in-range (random 1 3))]) - (create-a-body CUPCAKE))])) - (for/fold ([foods '()]) ([f foods]) - (cond - [(body-collide? f b) - (set-body-size! b (+ PLAYER-FATTEN-DELTA (body-size b))) - (append foods (new-cupcakes))] - [else (cons f foods)]))) - -;; body body -> Boolean -;; Have two bodys collided? -(define (body-collide? s1 s2) - (<= (magnitude (- (body-loc s1) (body-loc s2))) - (+ (body-size s1) (body-size s2)))) - -;; [Listof Ip] [Listof Food] [Listof IP] -> Bundle -;; moves all objects. may end game -(define (progress pls foods spectators) - (define p (play pls foods spectators)) - (define (max-score) - (foldl (λ (pl max) - (let ([pl-score (cadr pl)]) - (if (> pl-score max) pl-score max))) - 0 (score pls))) - (define (end-game?) - (or (empty? foods) (> (max-score) 30))) - (cond [(end-game?) (end-game-broadcast p)] - [else (broadcast-universe p)])) - -;; PlayUniverse -> [Bundle JoinUniverse] -;; ends the game, and restarts it -(define (end-game-broadcast p) - (define iws (get-iws p)) - (define msg (list SCORE (score (play-players p)))) - (define mls (broadcast iws msg)) - (make-bundle (remake-join p) mls empty)) - -;; Play-Universe -> JoinUniverse -;; Readies the ServerState for a new game -(define (remake-join p) - (define players (refresh (play-players p))) - (define spectators (play-spectators p)) - (join (append players spectators) START-TIME)) - -;; [Listof Players] -> [Listof Players] -;; creates new players for new game -(define (refresh players) - (for/list ([p players]) - (create-player (ip-iw p) (ip-id p)))) - -;; [Listof IP] -> [Listof (list Id Score)] -;; makes the endgame message informing clients of all the size -(define (score ps) - (for/list ([p ps]) - (list (ip-id p) (get-score (body-size (ip-body p)))))) - -; -; -; -; -; ;;; ;;; -; ;; ;; -; ;; ;; ;;;; ;;;;; ;;;;; ;;;; ;;; ;; ;;;; ;;;;; -; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; -; ; ; ; ;;;;;; ;;;; ;;;; ;;;;; ; ; ;;;;;; ;;;; -; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ; -; ;;; ;;; ;;;;; ;;;;; ;;;;; ;;; ;; ;;; ; ;;;;; ;;;;; -; ; -; ;;;; -; -; - -;; ----------------------------------------------------------------------------- -;; Play Universe - -;; Message -> Boolean -;; checks if message is a drag -(define (goto? msg) - (and (list? msg) - (= GOTO-LENGTH (length msg)) - (symbol? (first msg)) - (number? (second msg)) - (number? (third msg)) - (symbol=? GOTO (first msg)) - (<= 0 (second msg) WIDTH) - (<= 0 (third msg) HEIGHT))) - -;; PlayUniverse IWorld GotoMessage -> PlayUniverse -;; handles a player clicking. checks for collisions, updates score, removes food -;; Effect: changes a player's waypoints -(define (goto p iw msg) - (define c (make-rectangular (second msg) (third msg))) - (set-play-players! p (add-waypoint (play-players p) c iw)) - (broadcast-universe p)) - -;; [Listof IPs] Complex IWorld -> [Listof IPs] -;; adds that complex to the waypoints of the given players -(define (add-waypoint ps c iw) - (for/list ([p ps]) - (cond [(iworld=? (ip-iw p) iw) - (ip (ip-iw p) - (ip-id p) - (ip-body p) - (append (ip-waypoints p) (list c)))] - [else p]))) - -; -; -; -; -; ;;;; ; -; ; ; ; -; ; ;;;; ;; ;; ;; ;; ;;;; ;;; ; ;;;;; ;;; ;;;; ;; ;; -; ; ; ; ;; ; ;; ; ; ; ; ;; ; ; ; ; ;; ; -; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ;;; ;;;; ;;; ;;; ;;; ;;; ;;;;; ;;;; ;;; ;;;;; ;;;; ;;; ;;; -; -; -; -; - - -;; ----------------------------------------------------------------------------- -;; Join Universe - -;; [Universe Player -> Universe] -> [Universe IWorld -> [Bundle Universe]] -;; creates a function that deals with a new connection during join or play phase -(define (make-connection adder) - (lambda (u iw) - (define player (named-player iw)) - (define mails (list (make-mail iw (ip-id player)))) - (make-bundle (adder u player) mails empty))) - -;; JoinUniverse IWorld ID -> [Bundle JoinUniverse] -;; creates an internal player for the IWorld, adds it to Universe as waiting player -(define add-player (make-connection join-add-player)) - -;; PlayUniverse IWorld -> [Bundle PlayUniverse] -;; creates an internal player for the IWorld, adds it to Universe as spectator -(define add-spectator (make-connection play-add-spectator)) - -;; [Listof IP] IWorld ->* Player -(define (named-player iw) - (create-player iw (symbol->string (gensym (iworld-name iw))))) - -; -; -; -; -; ;;; ; ; ;; ; -; ; ;; ; -; ; ;;;; ;; ;;; ;;; ;;;; ; ;;; ;;;;; ;;;; -; ;;;; ; ; ;; ; ; ; ; ; ; ; ; ; -; ; ;;;;;; ; ; ;;;;; ; ; ; ;;;;;; -; ; ; ; ; ; ; ; ; ; ; -; ;; ; ; ; ; ; ;; ; ; ; ; ; -; ; ;;; ;;;;; ;;;;; ;;;;; ;;; ;; ;;;;; ;;;;; ;;;;; ;;;;; -; -; -; -; - -;; PlayUniverse -> [Bundle PlayUniverse [Listof [Mail StateMessage]]] -;; bundle this universe, serialize it, broadcast it, and drop noone -(define (broadcast-universe p) - (define mails (broadcast-for (get-ips p) p)) - (make-bundle p mails empty)) - -;; [Listof IWorlds] Message -> [Listof Mail] -;; sends mail to all clients -(define (broadcast iws msgs) - (map (lambda (iw) (make-mail iw msgs)) iws)) - -;; PlayUniverse -> (list s [Listof SerializedPlayer] [Listof SerializedFood]) -;; prepairs a message for an update world/ServerState state -(define (serialize-universe p) - (define serialized-players (map ip-player (play-players p))) - (list SERIALIZE serialized-players (play-food p))) - -;; [Listof IPs] PlayUniverse -> [Listof Mail] -;; generates mails for all clients -(define (broadcast-for ips p) - (define (mk-mail-for pl) - (make-mail (ip-iw pl) (serialize-universe-for pl p))) - (foldl (lambda (pl mails) (cons (mk-mail-for pl) mails)) '() ips)) - -;; IP PlayUniverse -> (list s [Listof SerializedPlayer] [ListOf SerializedFood]) -;; prepares message for an update world/ServerState state for a player -(define (serialize-universe-for pl p) - (list SERIALIZE - (serialize-players-for pl (play-players p)) - (play-food p))) - -;; IP IPs -> [ListOf SerializedPlayer] -;; prepares serialized list of players for the SERIALIZE message for a -;; player. -(define (serialize-players-for pl pls) - (define (filter-out waypoints) - (if (empty? waypoints) - waypoints - (list (first waypoints)))) - (define (mk-pl plyr) - (cond [(id=? (ip-id plyr) (ip-id pl)) (ip-player plyr)] - [else (player (ip-id plyr) - (ip-body plyr) - (filter-out (ip-waypoints plyr)))])) - (foldr (lambda (plyr srlzd-pls) (cons (mk-pl plyr) srlzd-pls)) '() pls)) - -; -; -; -; -; ;;;; ; -; ; ; ; -; ; ; ;;; ;;;;; ;;; ; ;;;; ;; ;; ;; ;; ;;;; ;;; ; ;;;;; -; ; ; ; ; ; ; ;; ; ; ;; ; ;; ; ; ; ; ;; ; -; ; ; ; ;;;; ; ; ; ; ; ; ; ;;;;;; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ;;;; ;;;;; ;;;;; ;;;; ;;;; ;;; ;;; ;;; ;;; ;;;;; ;;;; ;;; -; -; -; -; - -;; JoinUniverse IWorld -> Bundle -;; remove that iworld from list of clients -(define (drop-client j iw) - (empty-bundle (join-remove j iw))) - -;; PlayUniverse IWorld -> Bundle -;; removes a player from the ServerState and tells the players -(define (drop-player p iw) - (broadcast-universe (play-remove p iw))) - -; -; -; -; -; ;; -; ; -; ; ; ;; ;; ;; ;; -; ; ; ; ; ; ; -; ; ; ; ; ;; -; ;;; ; ; ;; -; ; ; ; ;; ; ; -; ;;; ;;; ;; ;; ;; ;; -; -; -; -; - -;; Number -> Body -;; creates a random body, that does not touch the edge -(define (create-a-body size) - (define x (+ size (random (- WIDTH size)))) - (define y (+ size (random (- HEIGHT size)))) - (body size (make-rectangular x y))) - -;; PlayUniverse -> [Listof IWorlds] -;; gets the iworlds of all players -(define (get-iws p) - (map ip-iw (append (play-players p) (play-spectators p)))) - -;; PlayUnivers -> [Listof IP] -(define (get-ips p) - (append (play-players p) (play-spectators p))) - -;; ServerState -> Bundle -;; makes a bundle that sends no messages and disconnects noone -(define (empty-bundle s) - (make-bundle s empty empty)) - -;; IWorld Id -> IP -;; creates a player with that idnumber -(define (create-player iw n) - (ip iw n (create-a-body PLAYER-SIZE) empty)) - -; -; -; -; -; ;;;;;;; -; ; ; ; ; -; ; ;;;; ;;;;; ;;;;; ;;;;; -; ; ; ; ; ; ; ; ; -; ; ;;;;;; ;;;; ; ;;;; -; ; ; ; ; ; -; ; ; ; ; ; ; ; ; -; ;;; ;;;;; ;;;;; ;;; ;;;;; -; -; -; -; - -(module+ test - (require rackunit rackunit/text-ui) - - (define PROP-NUM 500) - (define do-prop (make-parameter #t)) - (do-prop #f) - - ;; thunk -> void - ;; runs the thunk PROP-NUM times - (define (check-property t) - (when (do-prop) (test-begin (doo PROP-NUM t)))) - - ;; doo : number thunk -> - ;; does the thunk n times - (define (doo n l) - (l) - (unless (zero? n) - (doo (sub1 n) l))) - - ;; testing main server - - ;; new-connection - - ;; drop-client - (check-equal? (drop-client (join (list (ip iworld1 "player1" (body 10 1+10i) empty) - (ip iworld2 "player2" (body 10 1+10i) empty) - (ip iworld3 "player3" (body 10 1+10i) empty)) 100) - iworld1) - (empty-bundle (join (list (ip iworld2 "player2" (body 10 1+10i) empty) - (ip iworld3 "player3" (body 10 1+10i) empty)) - 100))) - (check-equal? (drop-client (join (list (ip iworld1 "player1" (body 10 1+10i) empty) - (ip iworld2 "player2" (body 10 1+10i) empty) - (ip iworld3 "player3" (body 10 1+10i) empty)) 100) - iworld2) - (empty-bundle (join (list (ip iworld1 "player1" (body 10 1+10i) empty) - (ip iworld3 "player3" (body 10 1+10i) empty)) 100))) - (check-equal? (drop-client (join (list (ip iworld1 "player1" (body 10 1+10i) empty) - (ip iworld2 "player2" (body 10 1+10i) empty) - (ip iworld3 "player3" (body 10 1+10i) empty)) 100) - iworld3) - (empty-bundle (join (list (ip iworld1 "player1" (body 10 1+10i) empty) - (ip iworld2 "player2" (body 10 1+10i) empty)) 100))) - - ;; remove-player - (check-equal? (drop-player - (play (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld2 "player345" (body 56 3+45i) empty)) - (list (body 87 67+23i) - (body 5 3+4i)) - empty) - iworld1) - (let ([remd (play-remove - (play (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld2 "player345" (body 56 3+45i) empty)) - (list (body 87 67+23i) - (body 5 3+4i)) - empty) - iworld1)]) - (broadcast-universe remd) - #; - (make-bundle remd (serial/broadcast-univ remd) empty))) - - (check-equal? (drop-player - (play (list (ip iworld2 "player345" (body 56 3+45i) empty)) - (list (body 87 67+23i) - (body 5 3+4i)) - (list (ip iworld1 "player10" (body 10 1+10i) empty))) - iworld1) - (let ([remd (play-remove - (play (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld2 "player345" (body 56 3+45i) empty)) - (list (body 87 67+23i) - (body 5 3+4i)) - empty) - iworld1)]) - (broadcast-universe remd) - #; - (make-bundle remd (serial/broadcast-univ remd) empty))) - - ;; ready-to-go - (check-false (keep-waiting? (join (list (create-player iworld1 "player") - (create-player iworld2 "player")) - 250))) - (check-false (keep-waiting? (join (list (create-player iworld1 "player") - (create-player iworld1 "player") - (create-player iworld2 "player")) - 456345132135213))) - (check-true (keep-waiting? (join (list (create-player iworld2 "player")) -234))) - (check-true (keep-waiting? (join (list (create-player iworld2 "player")) 10))) - - - - ;; handle-join - ;; name - ;; update-player - - ;; remove-player-by-iworld - (check-equal? (play-remove - (play (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld2 "player324" (body 56 3+45i) empty)) - (list (body 87 67+23i) - (body 5 3+4i)) - empty) - iworld1) - (play (list (ip iworld2 "player324" (body 56 3+45i) empty)) - (list (body 87 67+23i) - (body 5 3+4i)) - empty) - empty) - (check-equal? (play-remove - (play (list (ip iworld2 "player324" (body 56 3+45i) empty)) - (list (body 87 67+23i) - (body 5 3+4i)) - empty) - iworld2) - (play (list) - (list (body 87 67+23i) - (body 5 3+4i)) - empty)) - - ;; testing messaging - - ;; goto? - - (check-true (goto? '(goto 3 2))) - (check-true (goto? '(goto 3 2))) - (check-true (goto? '(goto 0 2))) - (check-true (goto? '(goto 6 2))) - (check-false (goto? `(goto ,(add1 WIDTH) 0))) - (check-false (goto? `(goto 0 ,(add1 HEIGHT)))) - (check-false (goto? '(goto -1 0))) - (check-false (goto? '(goto 0 -1))) - (check-false (goto? '(goto 1))) - (check-false (goto? '(drag 6+2i))) - (check-false (goto? '(drag 1))) - (check-false (goto? '(6+1i))) - (check-false (goto? '(1 2))) - (check-false (goto? '(goto 6+2i))) - (check-false (goto? '(drag 1 2))) - (check-false (goto? 'click)) - (check-false (goto? "click")) - (check-false (goto? #t)) - - ;;add-waypoint - - (check-equal? (add-waypoint `(,(ip iworld1 "player10" (body 10 1+10i) empty)) 8+9i iworld1) - (list (ip iworld1 "player10" (body 10 1+10i) '(8+9i)))) - (check-equal? (add-waypoint `(,(ip iworld1 "player10" (body 10 1+10i) '(23+45i))) 8+9i iworld1) - (list (ip iworld1 "player10" (body 10 1+10i) '(23+45i 8+9i)))) - - ;; goto - - (check-equal? (goto (play (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld2 "player345" (body 56 3+45i) empty)) - (list (body 87 67+23i) - (body 5 3+4i)) - empty) - iworld1 '(goto 1 1)) - (let ([state (play (list (ip iworld1 "player10" (body 10 1+10i)'(1+1i)) - (ip iworld2 "player345" (body 56 3+45i) empty)) - (list (body 87 67+23i) - (body 5 3+4i)) - empty)]) - (broadcast-universe state) - #; - (make-bundle state (serial/broadcast-univ state) empty))) - - (check-equal? (goto (play (list (ip iworld1 "player10" (body 10 1+10i) '(1+4i)) - (ip iworld2 "player345" (body 56 3+45i) empty)) - (list (body 87 67+23i) - (body 5 3+4i)) - empty) - iworld1 '(goto 1 1)) - (let ([state (play (list (ip iworld1 "player10" (body 10 1+10i) '(1+4i 1+1i)) - (ip iworld2 "player345" (body 56 3+45i) empty)) - (list (body 87 67+23i) - (body 5 3+4i)) - empty)]) - (broadcast-universe state) - #; - (make-bundle state (serial/broadcast-univ state) empty))) - - ;; eat-all-the-things - (check-pred >= (length (eat-all-the-things (ip iworld1 "player10" (body 11 0) '(1+10i)) (list (body 10 0)))) - 1) - (check-equal? (eat-all-the-things (ip iworld1 "player10" (body 10 0) '(1+10i)) (list (body 10 40+5i))) - (list (body 10 40+5i))) - - ;; testing initialization - - ;; property of no motion to same point in move-body - ;; also checks for divide by zero error in move-player* - (define (property:no-same-point) - (define (random-near n) - (define ε 1/1000000) - (+ n (* (random 10) ε (sub1 (* 2 (random 2)))))) - - (define test-body (create-a-body 1)) - - (define waypoints - (for/list ([r (in-range (add1 (random 100)))]) - (define x (real-part (body-loc test-body))) - (define y (imag-part (body-loc test-body))) - (make-rectangular (random-near x) (random-near y)))) - - (define random-p (ip iworld1 "nope" test-body waypoints)) - - (define (test p) - (cond [(empty? (ip-waypoints p)) - #t] - [(= (first (ip-waypoints p)) - (body-loc (ip-body p))) - #f] - [else (test (move-player* (list p)))])) - - (check-true (test random-p))) - - ;; does spawn food create the nessecary amount of food? - (define (property:player/food-number-correct) - (define players (random 50)) - (check-equal? (length (bake-cupcakes players)) - (* FOOD*PLAYERS players))) - - ;; is random-body on the board? - (define (test-body-in-bounds) - (define size 10) - (define body (create-a-body size)) - (check-true (and (< size (real-part (body-loc body)) (- WIDTH size)) - (< size (imag-part (body-loc body)) (- HEIGHT size))) - "body out of bounds")) - - - - - ;;create-name - ;; (check-equal? (create-name empty "john") "john") - ;; (check-equal? (create-name (list (ip iworld1 "player10" (body 10 0) '(1+10i))) "player10") "player10*") - #; - (check-equal? (create-name (list (ip iworld1 "player10" (body 10 0) '(1+10i)) - (ip iworld1 "player10*" (body 10 0) '(1+10i))) - "player10") - "player10**") - #; - (check-property property:unique-name) - - ;; spawn-food - (check-property property:player/food-number-correct) - - ;; random-body - (check-property test-body-in-bounds) - - ;; testing clock tick handling - - (define tbody1 (body 100 1+3i)) - (define tbody2 (body 100 1)) - (define tbody3 (body 100 0+3i)) - (define tbody4 (body 100 101)) - - (define waypoints1 '(1+3i 1 0+3i 10+10i)) - (define waypoints2 '(100)) - - ;; move-player* - (check-equal? (move-player* - (list (ip iworld1 "player10" (body 10 1+10i) '(1+10.01i)))) - (list (ip iworld1 "player10" (body 10 1+10.01i) empty))) - (check-property property:no-same-point) - ;; move-twards-waypoint - - - (test-begin - (check-equal? (move-toward-waypoint tbody1 waypoints1) - (rest waypoints1) - "waypoint removal failed") - (check-equal? tbody1 (body 100 1+3i) "movement failed") - (set! tbody1 (body 100 1+3i))) - - (test-begin - ;; test dependent on (< BASE-SPEED 100) - (check-equal? (move-toward-waypoint tbody2 waypoints2) - waypoints2 - "waypoint removal failed") - (check-equal? tbody2 (body 100 (+ 1 (make-rectangular (/ BASE-SPEED 100) 0))) - "movement failed") - (set! tbody2 (body 100 1))) - - (test-begin - (check-equal? (move-toward-waypoint tbody4 waypoints2) - '()) - (check-equal? tbody4 (body 100 100)) - (set! tbody4 (body 100 101))) - - ;; countdown - (check-equal? (wait-or-play (join (list (ip iworld1 "player10" (body 10 1+10i) empty)) 0)) - (make-bundle - (join (list (ip iworld1 "player10" (body 10 1+10i) empty)) 1) - (broadcast (list iworld1) (/ 1 WAIT-TIME)) - empty)) - (check-equal? (wait-or-play (join empty 0)) - (empty-bundle (join empty 1))) - - ;;countdown - (check-equal? (wait-or-play (join (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld1 "player345" (body 56 3+45i) empty)) - 100)) - (make-bundle (join (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld1 "player345" (body 56 3+45i) empty)) - 101) - (broadcast (list iworld1 iworld1) (/ 101 WAIT-TIME)) - empty)) - (check-equal? (wait-or-play (join (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld1 "player345" (body 56 3+45i) empty)) - 1)) - (make-bundle (join (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld1 "player345" (body 56 3+45i) empty)) - 2) - (broadcast (list iworld1 iworld1) (/ 2 WAIT-TIME)) - empty)) - ;; progress - (check-equal? (progress - (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld1 "player345" (body 56 3+45i) empty)) - (list (body 87 67+23i) - (body 5 3+4i)) - empty) - (broadcast-universe - (play (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld1 "player345" (body 56 3+45i) empty)) - (list (body 87 67+23i) - (body 5 3+4i)) - empty)) - #; - (make-bundle - (play (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld1 "player345" (body 56 3+45i) empty)) - (list (body 87 67+23i) - (body 5 3+4i)) - empty) - (serial/broadcast-univ (play (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld1 "player345" (body 56 3+45i) empty)) - (list (body 87 67+23i) - (body 5 3+4i)) - empty)) - empty)) - - ;; body-collide? - (check-true (body-collide? (body 10 10+10i) (body 10 10+10i))) - (check-true (body-collide? (body 10 10+10i) (body 10 0+10i))) - (check-true (body-collide? (body 10 10+10i) (body 10 10))) - (check-true (body-collide? (body 10 10+10i) (body 10 20))) - (check-true (body-collide? (body 10 10+10i) (body 10 0+20i))) - - (check-false (body-collide? (body 1 10+10i) (body 1 10+13i))) - (check-false (body-collide? (body 1 10+10i) (body 1 0+10i))) - (check-false (body-collide? (body 1 10+10i) (body 1 10))) - (check-false (body-collide? (body 1 10+10i) (body 1 20))) - (check-false (body-collide? (body 1 10+10i) (body 1 0+20i))) - - ;; serial/broadcast-univ - #; - (check-equal? (serial/broadcast-univ - (play (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld2 "player345" (body 56 3+45i) empty)) - (list (body 87 67+23i) - (body 5 3+4i)) - empty)) - (let ([serialized (serialize-universe (play (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld2 "player345" (body 56 3+45i) empty)) - (list (body 87 67+23i) - (body 5 3+4i)) - empty))]) - (list (make-mail iworld1 serialized) - (make-mail iworld2 serialized)))) - - ;; time-broadcast - (let ([j (join '() 100)]) - (check-equal? (time-broadcast j) - (make-bundle j '() '()))) - (let ([j (join `(,(ip iworld1 "sallyjoe" (body 0 0+0i) '())) 100)]) - (check-equal? (time-broadcast j) - (make-bundle j `(,(make-mail iworld1 (/ 100 WAIT-TIME))) '()))) - - ;; testing auxiliary functions - (check-equal? (score `(,(ip iworld1 "foo" (body 1000 +inf.0) '()) - ,(ip iworld1 "bar" (body 0 +inf.0) '()))) - `(("foo" ,(get-score 1000)) - ("bar" ,(get-score 0)))) - ;; get-iws - ;; empty-bundle - (check-equal? (empty-bundle (join (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld2 "player345" (body 56 3+45i) empty)) 132)) - (make-bundle (join (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld2 "player345" (body 56 3+45i) empty)) 132) empty empty)) - (check-equal? (empty-bundle (join (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld2 "player345" (body 56 3+45i) empty)) 345)) - (make-bundle (join (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld2 "player345" (body 56 3+45i) empty)) 345) empty empty)) - (check-equal? (empty-bundle (play (list (ip iworld1 "player1" (body 87 67+23i) empty)) - (list (body 87 67+23i) - (body 89 32+345i)) - empty)) - (make-bundle - (play (list (ip iworld1 "player1" (body 87 67+23i) empty)) - (list (body 87 67+23i) - (body 89 32+345i)) - empty) - empty - empty)) - - ;; get-iws - (check-equal? (get-iws (play (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld2 "player345" (body 56 3+45i) empty)) - (list (body 87 67+23i) - (body 5 3+4i)) - empty)) - (list iworld1 iworld2)) - (check-equal? (get-iws (play (list (ip iworld1 "player10" (body 10 1+10i) empty)) - empty - empty)) - (list iworld1)) - - ;; get-ips - (let ([players (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld2 "player345" (body 56 3+45i) empty))] - [spectators (list (ip iworld1 "player10" (body 15 2+65i) empty))]) - (check-equal? (get-ips (play players - (list (body 87 67+23i) - (body 5 3+4i)) - spectators)) - (append players spectators)) - (check-equal? (get-ips (play (list (first players)) - (list (body 87 67+23i) - (body 5 3+4i)) - empty)) - (append (list (first players)) empty))) - - ;; broadcast - (check-equal? (broadcast (list iworld1 iworld3 iworld2) - '(testing testing 1 2 3)) - (let ([message '(testing testing 1 2 3)]) - (list (make-mail iworld1 - message) - (make-mail iworld3 - message) - (make-mail iworld2 - message)))) - (check-equal? (broadcast (list iworld1) - '(testing testing 1 2 3)) - (let ([message '(testing testing 1 2 3)]) - (list (make-mail iworld1 - message)))) - (check-equal? (broadcast (list iworld1 iworld3) - 9) - (let ([message 9]) - (list (make-mail iworld1 - message) - (make-mail iworld3 - message)))) - - ;; broadcast-state - (let ([state (play (list (ip iworld1 "player10" (body 10 1+10i) empty) - (ip iworld2 "player345" (body 56 3+45i) empty)) - (list (body 87 67+23i) - (body 5 3+4i)) - empty)]) - (check-equal? (broadcast-universe state) - (broadcast-universe state))) - - ;; serialize-players-for - (let* ([waypoints1 (list (make-rectangular 383 212) - (make-rectangular 282 192))] - [waypoints2 (list (make-rectangular 918 319) - (make-rectangular 481 119) - (make-rectangular 129 321))] - [pls (list (ip iworld1 "player10" (body 10 1+10i) waypoints1) - (ip iworld2 "player345" (body 56 3+45i) waypoints2))] - [pl (first pls)]) - (check-equal? (player-waypoints (first (serialize-players-for pl pls))) - waypoints1) - (check-equal? (player-waypoints (second (serialize-players-for pl pls))) - (list (make-rectangular 918 319)))) - - "server: all tests run") diff --git a/fourteen/shared.rkt b/fourteen/shared.rkt deleted file mode 100644 index 7f3a549..0000000 --- a/fourteen/shared.rkt +++ /dev/null @@ -1,156 +0,0 @@ -#lang racket - -;; This module describes the shared vocabulary and knowledge for the server -;; and client modules of the Hungry Henry game. - -(provide ;; type Id - id? ;; Any -> Boolean : Id - id=? ;; Id Id -> Boolean - ;; type GOTO - ;; type SOTO = Time | Ackn | State | Score - ;; type Food - ;; type Feaster - ;; type Body - (struct-out player) ;; - (struct-out body) ;; - get-score ;; Nat -> Nat - PLAYER-FATTEN-DELTA - WIDTH HEIGHT CUPCAKE PLAYER-SIZE - SCORE GOTO SERIALIZE - GOTO-LENGTH) - -#| ----------------------------------------------------------------------------- - -;; --- Tasks -------------------------------------------------------------------- - -The game server keeps track of the entire game state [to avoid cheating by -lients]. It collects waypoints, moves the avatars on behalf of the clients, -detects collisions with cupcakes, has avatars eat and grow, and discovers the -end of the game. As events occur, it informs all clients about all actions and, -at the end of the game, tallies the scores. - -Each client displays the current state of the game as broadcast by the server. -It also records and sends all mouse clicks to the server. - -;; --- Messages and Protocol --------------------------------------------------- - -The server and the client exchange messages to inform each other about -the events in the game. - -Client To Server Message: ------------------------- - - GOTO = (list GOTO PositiveNumber PositiveNumber) - represents the coordinates of player's latest waypoint, - obtained via a mouse click. - Constraint: in (list GOTO x y), (and (<= 0 x WIDTH) (<= 0 y HEIGHT)) - -Server to Client Message: -------------------------- - - SOTO is one of: - -- Number ∈ [0,1] - called a Time message - repreents the percentage of loading time left - -- ID - called an Ackn message - represents the unique id that the server assigns to the client, - based on the client's name - -- (list SERIALIZE [Listof Feaster] [Listof Food]) - called a State message - represents the complete current state of the game - -- (list SCORE [Listof (list Id Natural)]) - called a Score message - informs clients that the game is over and the sizes of each player. -|# -;; Shared Data Definitions for Messages - -(struct player (id body waypoints) #:prefab) -(struct body (size loc) #:prefab #:mutable) -;; Food = Body -;; Feaster = (player Id Body [Listof Complex]) -;; interpretation: -;; -- id is the player's id -;; -- body is the player's size and location -;; -- loc are the player's waypoints, ordered from first to last -;; Body = (body PositiveNumber Complex) -;; interpretation: any 'body' on the playing field, both players and cupcakes -;; -- the postive number specifies the body's size -;; -- the complex number represents the body's location -;; PlayerId = String -(define id? string?) -(define id=? string=?) - -;; Message ID Constants -(define SCORE 'score) -(define SERIALIZE 'state) -(define GOTO 'goto) -(define GOTO-LENGTH 3) - -#| --- Protocol ---------------------------------------------------------------- - - Client1 Client2 Server - | | | - | register(name1) | [universe protocol] - |----------------------------->| - | | | - | | ID | an identifier message - |<-----------------------------| - | | t | percentage of wait time - |<-----------------------------| - |<-----------------------------| - |<-----------------------------| - | | | - | | register(name2) - | |------------->| - | | | - | | ID | - | |<-------------| - | | t | percentage of wait time - |<-----------------------------| - | |<-------------| - |<-----------------------------| - | |<-------------| - | | | <==== end of wait time [clock, players] - | state msg | - |<-----------------------------| `(state (,feaster1 ,feaster2) ,foods) - | |<-------------| - | | | - click | GOTO | | `(goto ,x ,y) - ====> |----------------------------->| new state - | | | - | state msg | - |<-----------------------------| `(state (,feaster1 ,feaster2) ,foods) - | |<-------------| - | | | - | | | move, eat: - |<-----------------------------| `(state (,feaster1 ,feaster2) ,foods) - | |<-------------| - | | | - | click | GOTO | `(goto ,x ,y) - | ====> |------------->| - | | | - | state msg | - |<-----------------------------| `(state (,feaster1 ,feaster2) ,foods) - | |<-------------| - | | | - | score msg | all food is eaten: - |<-----------------------------| `(score ((,id ,score) ...)) - | |<-------------| - | | | - --- --- --- - -|# - -;; Shared Logical Constants -(define WIDTH 1000) -(define HEIGHT 700) -(define CUPCAKE 15) -(define PLAYER-SIZE (* 3 CUPCAKE)) -(define PLAYER-FATTEN-DELTA 5) - -;; Number -> Number ;; move to serer -;; gets aplayers score given its fatness -(define (get-score f) - (/ (- f PLAYER-SIZE) PLAYER-FATTEN-DELTA)) - diff --git a/one/hw.rkt b/one/hw.rkt deleted file mode 100644 index fec7e25..0000000 --- a/one/hw.rkt +++ /dev/null @@ -1,3 +0,0 @@ -#lang racket - -'(hello-world) diff --git a/six/resources/body.gif b/six/resources/body.gif deleted file mode 100644 index 94a0956..0000000 Binary files a/six/resources/body.gif and /dev/null differ diff --git a/six/resources/goo-red.gif b/six/resources/goo-red.gif deleted file mode 100644 index bf767b1..0000000 Binary files a/six/resources/goo-red.gif and /dev/null differ diff --git a/six/resources/goo.gif b/six/resources/goo.gif deleted file mode 100644 index cb0d98b..0000000 Binary files a/six/resources/goo.gif and /dev/null differ diff --git a/six/resources/head.gif b/six/resources/head.gif deleted file mode 100644 index 664f679..0000000 Binary files a/six/resources/head.gif and /dev/null differ diff --git a/six/resources/obstacle.gif b/six/resources/obstacle.gif deleted file mode 100644 index 6ff288e..0000000 Binary files a/six/resources/obstacle.gif and /dev/null differ diff --git a/six/resources/tail.gif b/six/resources/tail.gif deleted file mode 100644 index 6fbd317..0000000 Binary files a/six/resources/tail.gif and /dev/null differ diff --git a/six/snake.rkt b/six/snake.rkt deleted file mode 100644 index c57b01c..0000000 --- a/six/snake.rkt +++ /dev/null @@ -1,295 +0,0 @@ -#lang racket -(require 2htdp/universe 2htdp/image) - -;; data -(struct pit (snake goos obstacles dinged)) -(struct snake (dir segs)) -(struct goo (loc expire type)) -(struct obstacle (loc expire)) -(struct posn (x y)) - -;; constants -(define TICK-RATE 1/10) - -(define SIZE 30) - -(define SEG-SIZE 15) - -(define EXPIRATION-TIME 150) -(define OBSTACLE-EXPIRATION-TIME 250) - -(define WIDTH-PX (* SEG-SIZE 30)) -(define HEIGHT-PX (* SEG-SIZE 30)) - -(define MT-SCENE (empty-scene WIDTH-PX HEIGHT-PX)) -(define GOO-IMG (bitmap "resources/goo.gif")) -(define GOO-RED-IMG (bitmap "resources/goo-red.gif")) -(define OBSTACLE-IMG (bitmap "resources/obstacle.gif")) -(define SEG-IMG (bitmap "resources/body.gif")) -(define HEAD-IMG (bitmap "resources/head.gif")) - -(define HEAD-LEFT-IMG HEAD-IMG) -(define HEAD-DOWN-IMG (rotate 90 HEAD-LEFT-IMG)) -(define HEAD-RIGHT-IMG (flip-horizontal HEAD-LEFT-IMG)) -(define HEAD-UP-IMG (flip-vertical HEAD-DOWN-IMG)) - -(define ENDGAME-TEXT-SIZE 15) - -;; main -(define (start-snake) - (big-bang (pit (snake "right" (list (posn 1 1))) - (list (fresh-goo) - (fresh-goo) - (fresh-goo) - (fresh-goo) - (fresh-goo) - (fresh-goo)) - (list (fresh-obstacle) - (fresh-obstacle)) - 0) - (on-tick next-pit TICK-RATE) - (on-key direct-snake) - (to-draw render-pit) - (stop-when dead? render-end))) - -(define (next-pit w) - (define snake (pit-snake w)) - (define goos (pit-goos w)) - (define obstacles (pit-obstacles w)) - (define dinged (pit-dinged w)) - (define goo-to-eat (can-eat snake goos)) - (if goo-to-eat - (pit (grow-size snake (goo-type goo-to-eat)) - (age-goo (eat goos goo-to-eat)) - (age-obstacle obstacles) (+ 1 dinged)) - (pit (slither snake) - (age-goo goos) - (age-obstacle obstacles) dinged))) - -(define (direct-snake w ke) - (cond [(dir? ke) (world-change-dir w ke)] - [else w])) - -(define (render-pit w) - (snake+scene (pit-snake w) - (goo-list+scene (pit-goos w) - (obstacle-list+scene - (pit-obstacles w) MT-SCENE)))) - -(define (dead? w) - (define snake (pit-snake w)) - (or (self-colliding? snake) - (wall-colliding? snake) - (obstacle-colliding? snake (pit-obstacles w)))) - -(define (render-end w) - (overlay (above (text "Game Over" ENDGAME-TEXT-SIZE "black") - (text (string-append "You dinged " - (number->string (pit-dinged w)) - " goos.") - ENDGAME-TEXT-SIZE "black")) - (render-pit w))) - - -;; clock -(define (can-eat snake goos) - (cond [(empty? goos) #f] - [else (if (close? (snake-head snake) (first goos)) - (first goos) - (can-eat snake (rest goos)))])) - -(define (eat goos goo-to-eat) - (append (list (fresh-goo)) (remove goo-to-eat goos))) - -(define (close? s g) - (posn=? s (goo-loc g))) - -(define (grow-size sn size) - (cond [(= size 0) sn] - [else (grow-size (grow sn) (- size 1))])) - -(define (grow sn) - (snake (snake-dir sn) - (cons (next-head sn) (snake-segs sn)))) - -(define (slither sn) - (snake (snake-dir sn) - (cons (next-head sn) (all-but-last (snake-segs sn))))) - -(define (next-head sn) - (define head (snake-head sn)) - (define dir (snake-dir sn)) - (cond [(string=? dir "up") (posn-move head 0 -1)] - [(string=? dir "down") (posn-move head 0 1)] - [(string=? dir "left") (posn-move head -1 0)] - [(string=? dir "right") (posn-move head 1 0)])) - -(define (posn-move p dx dy) - (posn (+ (posn-x p) dx) - (+ (posn-y p) dy))) - -(define (all-but-last segs) - (cond [(empty? (rest segs)) empty] - [else (cons (first segs) (all-but-last (rest segs)))])) - -(define (age-goo goos) - (rot (renew goos))) - -(define (renew goos) - (cond [(empty? goos) empty] - [(rotten? (first goos)) - (append (fresh-goos) (renew (rest goos)))] - [else - (append (list (first goos)) (renew (rest goos)))])) - -(define (rot goos) - (cond [(empty? goos) empty] - [else (cons (decay (first goos)) (rot (rest goos)))])) - -(define (rotten? g) - (zero? (goo-expire g))) - -(define (decay g) - (goo (goo-loc g) (sub1 (goo-expire g)) (goo-type g))) - -(define (fresh-goo) - (goo (posn (add1 (random (sub1 SIZE))) - (add1 (random (sub1 SIZE)))) - EXPIRATION-TIME - (random 1 3))) - -(define (fresh-goos) - (define (gen-goos n) - (cond [(= n 0) empty] - [else (cons (fresh-goo) (gen-goos (- n 1)))])) - (let ((n (random 3))) - (gen-goos n))) - -(define (age-obstacle obstacles) - (rot-obstacles (renew-obstacles obstacles))) - -(define (renew-obstacles obstacles) - (cond [(empty? obstacles) empty] - [(obstacle-expired? (first obstacles)) - (cons (fresh-obstacle) (renew-obstacles (rest obstacles)))] - [else - (cons (first obstacles) (renew-obstacles (rest obstacles)))])) - -(define (rot-obstacles obstacles) - (cond [(empty? obstacles) empty] - [else (cons (decay-obstacle (first obstacles)) - (rot-obstacles (rest obstacles)))])) - -(define (obstacle-expired? obs) - (zero? (obstacle-expire obs))) - -(define (decay-obstacle obs) - (obstacle (obstacle-loc obs) (sub1 (obstacle-expire obs)))) - -(define (fresh-obstacle) - (obstacle (posn (add1 (random (sub1 SIZE))) - (add1 (random (sub1 SIZE)))) - OBSTACLE-EXPIRATION-TIME)) - -;; keys -(define (dir? x) - (or (key=? x "up") - (key=? x "down") - (key=? x "left") - (key=? x "right"))) - -(define (world-change-dir w d) - (define the-snake (pit-snake w)) - (cond [(and (opposite-dir? (snake-dir the-snake) d) - (cons? (rest (snake-segs the-snake)))) - (stop-with w)] - [else - (pit (snake-change-dir the-snake d) - (pit-goos w) - (pit-obstacles w) - (pit-dinged w))])) - -(define (opposite-dir? d1 d2) - (cond [(string=? d1 "up") (string=? d2 "down")] - [(string=? d1 "down") (string=? d2 "up")] - [(string=? d1 "left") (string=? d2 "right")] - [(string=? d1 "right") (string=? d2 "left")])) - - -;; render -(define (snake+scene snake scene) - (define snake-body-scene - (img-list+scene (snake-body snake) SEG-IMG scene)) - (define dir (snake-dir snake)) - (img+scene (snake-head snake) - (cond [(string=? "up" dir) HEAD-UP-IMG] - [(string=? "down" dir) HEAD-DOWN-IMG] - [(string=? "left" dir) HEAD-LEFT-IMG] - [(string=? "right" dir) HEAD-RIGHT-IMG]) - snake-body-scene)) - -(define (goo-list+scene goos scene) - (define (get-posns-from-goo goos type) - (cond [(empty? goos) empty] - [(= (goo-type (first goos)) type) - (cons (goo-loc (first goos)) - (get-posns-from-goo (rest goos) type))] - [else (get-posns-from-goo (rest goos) type)])) - (img-list+scene (get-posns-from-goo goos 1) GOO-IMG - (img-list+scene (get-posns-from-goo goos 2) - GOO-RED-IMG scene))) - -(define (obstacle-list+scene obstacles scene) - (define (get-posns-from-obstacle obstacles) - (cond [(empty? obstacles) empty] - [else (cons (obstacle-loc (first obstacles)) - (get-posns-from-obstacle (rest obstacles)))])) - (img-list+scene (get-posns-from-obstacle obstacles) - OBSTACLE-IMG scene)) - -(define (img-list+scene posns img scene) - (cond [(empty? posns) scene] - [else (img+scene - (first posns) - img - (img-list+scene (rest posns) img scene))])) - -(define (img+scene posn img scene) - (place-image img - (* (posn-x posn) SEG-SIZE) - (* (posn-y posn) SEG-SIZE) - scene)) - - -;; end game -(define (self-colliding? snake) - (cons? (member (snake-head snake) (snake-body snake)))) - -(define (wall-colliding? snake) - (define x (posn-x (snake-head snake))) - (define y (posn-y (snake-head snake))) - (or (= 0 x) (= x SIZE) - (= 0 y) (= y SIZE))) - -(define (obstacle-colliding? snake obstacles) - (cond [(empty? obstacles) #f] - [(posn=? (snake-head snake) - (obstacle-loc (first obstacles))) #t] - [else (obstacle-colliding? snake (rest obstacles))])) - -;; aux -(define (posn=? p1 p2) - (and (= (posn-x p1) (posn-x p2)) - (= (posn-y p1) (posn-y p2)))) - -(define (snake-head sn) - (first (snake-segs sn))) - -(define (snake-body sn) - (rest (snake-segs sn))) - -(define (snake-tail sn) - (last (snake-segs sn))) - -(define (snake-change-dir sn d) - (snake d (snake-segs sn))) diff --git a/six/snakes.rkt b/six/snakes.rkt deleted file mode 100644 index dae3468..0000000 --- a/six/snakes.rkt +++ /dev/null @@ -1,362 +0,0 @@ -#lang racket -(require 2htdp/universe 2htdp/image) - -;; data -(struct pit (snake-1 snake-2 goos obstacles dinged)) -(struct snake (dir segs)) -(struct goo (loc expire type)) -(struct obstacle (loc expire)) -(struct posn (x y)) - -;; constants -(define TICK-RATE 1/10) - -(define SIZE 30) - -(define SEG-SIZE 15) - -(define EXPIRATION-TIME 150) -(define OBSTACLE-EXPIRATION-TIME 250) - -(define WIDTH-PX (* SEG-SIZE 30)) -(define HEIGHT-PX (* SEG-SIZE 30)) - -(define MT-SCENE (empty-scene WIDTH-PX HEIGHT-PX)) -(define GOO-IMG (bitmap "resources/goo.gif")) -(define GOO-RED-IMG (bitmap "resources/goo-red.gif")) -(define OBSTACLE-IMG (bitmap "resources/obstacle.gif")) -(define SEG-IMG (bitmap "resources/body.gif")) -(define HEAD-IMG (bitmap "resources/head.gif")) - -(define HEAD-LEFT-IMG HEAD-IMG) -(define HEAD-DOWN-IMG (rotate 90 HEAD-LEFT-IMG)) -(define HEAD-RIGHT-IMG (flip-horizontal HEAD-LEFT-IMG)) -(define HEAD-UP-IMG (flip-vertical HEAD-DOWN-IMG)) - -(define ENDGAME-TEXT-SIZE 15) - -;; main -(define (start-snakes) - (big-bang (pit (snake "right" (list (posn 1 1))) - (snake "d" (list (posn 1 10))) - (list (fresh-goo) - (fresh-goo) - (fresh-goo) - (fresh-goo) - (fresh-goo) - (fresh-goo)) - (list (fresh-obstacle) - (fresh-obstacle)) - 0) - (on-tick next-pit TICK-RATE) - (on-pad direct-snakes) - (to-draw render-pit) - (stop-when dead? render-end))) - -(define (next-pit w) - (define snake-1 (pit-snake-1 w)) - (define snake-2 (pit-snake-2 w)) - (define goos (pit-goos w)) - (define obstacles (pit-obstacles w)) - (define dinged (pit-dinged w)) - (define goo-to-eat-sn1 (can-eat snake-1 goos)) - (define goo-to-eat-sn2 (can-eat snake-2 goos)) - (cond [(and goo-to-eat-sn1 goo-to-eat-sn2) ; sn1 and sn2 dinged. - (pit (grow-size snake-1 (goo-type goo-to-eat-sn1)) - (grow-size snake-2 (goo-type goo-to-eat-sn2)) - (age-goo (eat (eat goos goo-to-eat-sn1) goo-to-eat-sn2)) - (age-obstacle obstacles) (+ 2 dinged))] - [(and goo-to-eat-sn1 (not goo-to-eat-sn2)) ; sn1 dinged. - (pit (grow-size snake-1 (goo-type goo-to-eat-sn1)) - (slither snake-2) - (age-goo (eat goos goo-to-eat-sn1)) - (age-obstacle obstacles) (+ 1 dinged))] - [(and (not goo-to-eat-sn1) goo-to-eat-sn2) ; sn2 dinged. - (pit (slither snake-1) - (grow-size snake-2 (goo-type goo-to-eat-sn2)) - (age-goo (eat goos goo-to-eat-sn2)) - (age-obstacle obstacles) (+ 1 dinged))] - [else ; none dinged. - (pit (slither snake-1) - (slither snake-2) - (age-goo goos) - (age-obstacle obstacles) dinged)])) - - -(define (direct-snakes w ke) - (cond [(arrow-key? ke) (direct-snake-1 w ke)] - [(wasd-key? ke) (direct-snake-2 w ke)] - [else w])) - -(define (direct-snake-1 w ke) - (world-change-dir 1 w ke)) - -(define (direct-snake-2 w ke) - (world-change-dir 2 w ke)) - -(define (render-pit w) - (snake+scene (pit-snake-1 w) - (snake+scene (pit-snake-2 w) - (goo-list+scene (pit-goos w) - (obstacle-list+scene - (pit-obstacles w) MT-SCENE))))) - -(define (dead? w) - (define snake-1 (pit-snake-1 w)) - (define snake-2 (pit-snake-2 w)) - (define (colliding? sn sn-other) - (or (self-colliding? sn) - (wall-colliding? sn) - (obstacle-colliding? sn (pit-obstacles w)) - (snake-colliding? sn sn-other))) - (or (colliding? snake-1 snake-2) (colliding? snake-2 snake-1))) - -(define (render-end w) - (overlay (above (text "Game Over" ENDGAME-TEXT-SIZE "black") - (text (string-append "Dinged " - (number->string (pit-dinged w)) - " goos.") - ENDGAME-TEXT-SIZE "black")) - (render-pit w))) - - -;; clock -(define (can-eat snake goos) - (cond [(empty? goos) #f] - [else (if (close? (snake-head snake) (first goos)) - (first goos) - (can-eat snake (rest goos)))])) - -(define (eat goos goo-to-eat) - (append (list (fresh-goo)) (remove goo-to-eat goos))) - -(define (close? s g) - (posn=? s (goo-loc g))) - -(define (grow-size sn size) - (cond [(= size 0) sn] - [else (grow-size (grow sn) (- size 1))])) - -(define (grow sn) - (snake (snake-dir sn) - (cons (next-head sn) (snake-segs sn)))) - -(define (slither sn) - (snake (snake-dir sn) - (cons (next-head sn) (all-but-last (snake-segs sn))))) - -(define (next-head sn) - (define head (snake-head sn)) - (define dir (snake-dir sn)) - (cond [(or (string=? dir "up") (string=? dir "w")) (posn-move head 0 -1)] - [(or (string=? dir "down") (string=? dir "s")) (posn-move head 0 1)] - [(or (string=? dir "left") (string=? dir "a")) (posn-move head -1 0)] - [(or (string=? dir "right") (string=? dir "d")) (posn-move head 1 0)])) - -(define (posn-move p dx dy) - (posn (+ (posn-x p) dx) - (+ (posn-y p) dy))) - -(define (all-but-last segs) - (cond [(empty? (rest segs)) empty] - [else (cons (first segs) (all-but-last (rest segs)))])) - -(define (age-goo goos) - (rot (renew goos))) - -(define (renew goos) - (cond [(empty? goos) empty] - [(rotten? (first goos)) - (append (fresh-goos) (renew (rest goos)))] - [else - (append (list (first goos)) (renew (rest goos)))])) - -(define (rot goos) - (cond [(empty? goos) empty] - [else (cons (decay (first goos)) (rot (rest goos)))])) - -(define (rotten? g) - (zero? (goo-expire g))) - -(define (decay g) - (goo (goo-loc g) (sub1 (goo-expire g)) (goo-type g))) - -(define (fresh-goo) - (goo (posn (add1 (random (sub1 SIZE))) - (add1 (random (sub1 SIZE)))) - EXPIRATION-TIME - (random 1 3))) - -(define (fresh-goos) - (define (gen-goos n) - (cond [(= n 0) empty] - [else (cons (fresh-goo) (gen-goos (- n 1)))])) - (let ((n (random 3))) - (gen-goos n))) - -(define (age-obstacle obstacles) - (rot-obstacles (renew-obstacles obstacles))) - -(define (renew-obstacles obstacles) - (cond [(empty? obstacles) empty] - [(obstacle-expired? (first obstacles)) - (cons (fresh-obstacle) (renew-obstacles (rest obstacles)))] - [else - (cons (first obstacles) (renew-obstacles (rest obstacles)))])) - -(define (rot-obstacles obstacles) - (cond [(empty? obstacles) empty] - [else (cons (decay-obstacle (first obstacles)) - (rot-obstacles (rest obstacles)))])) - -(define (obstacle-expired? obs) - (zero? (obstacle-expire obs))) - -(define (decay-obstacle obs) - (obstacle (obstacle-loc obs) (sub1 (obstacle-expire obs)))) - -(define (fresh-obstacle) - (obstacle (posn (add1 (random (sub1 SIZE))) - (add1 (random (sub1 SIZE)))) - OBSTACLE-EXPIRATION-TIME)) - -;; keys -(define (dir? x) - (or (arrow-key? x) - (wasd-key? x))) - -(define (arrow-key? x) - (or (key=? x "up") - (key=? x "down") - (key=? x "left") - (key=? x "right"))) - -(define (wasd-key? x) - (or (key=? x "w") - (key=? x "s") - (key=? x "a") - (key=? x "d"))) - -(define (world-change-dir sn-number w d) - (define snake-1 (pit-snake-1 w)) - (define snake-2 (pit-snake-2 w)) - (cond [(and (= sn-number 1) ;snake-1 - (opposite-dir? (snake-dir snake-1) d) - (cons? (rest (snake-segs snake-1)))) - (stop-with w)] - [(and (= sn-number 2) ;snake-2 - (opposite-dir? (snake-dir snake-2) d) - (cons? (rest (snake-segs snake-2)))) - (stop-with w)] - [(= sn-number 1) ;snake-1 change dir. - (pit (snake-change-dir snake-1 d) - (pit-snake-2 w) - (pit-goos w) - (pit-obstacles w) - (pit-dinged w))] - [else ;snake-2 change dir. - (pit (pit-snake-1 w) - (snake-change-dir snake-2 d) - (pit-goos w) - (pit-obstacles w) - (pit-dinged w))])) - -(define (opposite-dir? d1 d2) - (cond [(string=? d1 "up") (string=? d2 "down")] - [(string=? d1 "down") (string=? d2 "up")] - [(string=? d1 "left") (string=? d2 "right")] - [(string=? d1 "right") (string=? d2 "left")] - [(string=? d1 "w") (string=? d2 "s")] - [(string=? d1 "s") (string=? d2 "w")] - [(string=? d1 "a") (string=? d2 "d")] - [(string=? d1 "d") (string=? d2 "a")])) - - -;; render -(define (snake+scene snake scene) - (define snake-body-scene - (img-list+scene (snake-body snake) SEG-IMG scene)) - (define dir (snake-dir snake)) - (img+scene (snake-head snake) - (cond [(or (string=? "up" dir) (string=? "w" dir)) - HEAD-UP-IMG] - [(or (string=? "down" dir) (string=? "s" dir)) - HEAD-DOWN-IMG] - [(or (string=? "left" dir) (string=? "a" dir)) - HEAD-LEFT-IMG] - [(or (string=? "right" dir) (string=? "d" dir)) - HEAD-RIGHT-IMG]) - snake-body-scene)) - -(define (goo-list+scene goos scene) - (define (get-posns-from-goo goos type) - (cond [(empty? goos) empty] - [(= (goo-type (first goos)) type) - (cons (goo-loc (first goos)) - (get-posns-from-goo (rest goos) type))] - [else (get-posns-from-goo (rest goos) type)])) - (img-list+scene (get-posns-from-goo goos 1) GOO-IMG - (img-list+scene (get-posns-from-goo goos 2) - GOO-RED-IMG scene))) - -(define (obstacle-list+scene obstacles scene) - (define (get-posns-from-obstacle obstacles) - (cond [(empty? obstacles) empty] - [else (cons (obstacle-loc (first obstacles)) - (get-posns-from-obstacle (rest obstacles)))])) - (img-list+scene (get-posns-from-obstacle obstacles) - OBSTACLE-IMG scene)) - -(define (img-list+scene posns img scene) - (cond [(empty? posns) scene] - [else (img+scene - (first posns) - img - (img-list+scene (rest posns) img scene))])) - -(define (img+scene posn img scene) - (place-image img - (* (posn-x posn) SEG-SIZE) - (* (posn-y posn) SEG-SIZE) - scene)) - - -;; end game -(define (self-colliding? snake) - (cons? (member (snake-head snake) (snake-body snake)))) - -(define (wall-colliding? snake) - (define x (posn-x (snake-head snake))) - (define y (posn-y (snake-head snake))) - (or (= 0 x) (= x SIZE) - (= 0 y) (= y SIZE))) - -(define (obstacle-colliding? snake obstacles) - (cond [(empty? obstacles) #f] - [(posn=? (snake-head snake) - (obstacle-loc (first obstacles))) #t] - [else (obstacle-colliding? snake (rest obstacles))])) - -(define (snake-colliding? snake snake-other) - (define (head-in-other sn other) - (cond [(empty? other) #f] - [(posn=? sn (first other)) #t] - [else (head-in-other sn (rest other))])) - (head-in-other (snake-head snake) (snake-segs snake-other))) - -;; aux -(define (posn=? p1 p2) - (and (= (posn-x p1) (posn-x p2)) - (= (posn-y p1) (posn-y p2)))) - -(define (snake-head sn) - (first (snake-segs sn))) - -(define (snake-body sn) - (rest (snake-segs sn))) - -(define (snake-tail sn) - (last (snake-segs sn))) - -(define (snake-change-dir sn d) - (snake d (snake-segs sn))) diff --git a/ten/graphics/dice1.png b/ten/graphics/dice1.png deleted file mode 100644 index 3f4899c..0000000 Binary files a/ten/graphics/dice1.png and /dev/null differ diff --git a/ten/graphics/dice2.png b/ten/graphics/dice2.png deleted file mode 100644 index 2fa32ea..0000000 Binary files a/ten/graphics/dice2.png and /dev/null differ diff --git a/ten/graphics/dice3.png b/ten/graphics/dice3.png deleted file mode 100644 index 005ee75..0000000 Binary files a/ten/graphics/dice3.png and /dev/null differ diff --git a/ten/graphics/dice4.png b/ten/graphics/dice4.png deleted file mode 100644 index 47bb291..0000000 Binary files a/ten/graphics/dice4.png and /dev/null differ diff --git a/ten/source.rkt b/ten/source.rkt deleted file mode 100644 index a2b6a96..0000000 --- a/ten/source.rkt +++ /dev/null @@ -1,1218 +0,0 @@ -#lang racket - -#| - The Dice of Doom game, the eager version - ---------------------------------------- - - The Dice of Doom game is a turn-based game for two players sharing one keyboard. - Since this implementation employs an eager strategy to build the complete game - tree of all possible moves, it is only a step in the right direction. - - Each player owns hexagonal territories, which are arranged into a planar game - board. A territory comes with a number of dice. When it is a player's turn, - she marks one of her territories as a launching pad for an attack at a - neigboring territory of the other player. Such an attack is enabled only if - her chosen territory has more dice than the territory of the other player. - The effect of the attack is that the territory changes ownership and that all - but one of the attack dice are moved to the newly conquered territory. A - player may continue her turn as long as she can launch attacks. Optionally, - she may choose to pass after her first attack is executed, meaning she ends - her turn. At the end of a turn, a number of dices are distributed across the - players' territories. The game is over when a player whose turn it is cannot - attack on her first move. - - A player can use the following five keys to play the game: - -- with ← and → (arrow keys), the player changes the territory focus - -- with enter, the player marks a territory the launching pad for an attack - -- with the "d" key, the player unmarks a territory - -- with the "p" key the player passes. - Once a player passes, the game announces whose turn it is next. - - Play - ---- - - Run and evaluate - (roll-the-dice) - This will pop up a window that the game board, and instructions. -|# - -(require 2htdp/image (except-in 2htdp/universe left right)) - -; -; -; -; -; ;;;; ; ;;; ;;; ;; ;; -; ; ; ; ; ; ; -; ; ; ;;; ;;; ; ;;;; ; ; ;;;; ;; ;;; ; ;;; ; -; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; -; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; -; ;;;; ;;;;; ;;;; ;;;;; ; ; ;;;; ;;;;; ;;;;; ;;; ;; -; -; -; -; - -;; --------------------------------------------------------------------------------------------------- -;; Data - -(struct dice-world (src board gt) #:transparent) -;; DiceWorld = (dice-world (U #false Natural) Board GameTree) -;; in (dice-world i b gt) -;; -- if i is a Natural, it is an index for the territory that the player has marked for an attack -;; -- if i is #f, no territory has been marked yet -;; b is the current board -;; gt is the game-tree for the given i and b - -(struct game (board player moves) #:transparent) -;; GameTree = (game Board Player [Listof Move]) -;; in (game-tree b p lm) -;; -- b is the current board -;; -- p is the current player -;; -- lm is the list of moves that that player may execute - -;; Board = [List-of Territory] -;; the first field in the list is the currently marked territory - -;; Player ∈ [0, PLAYER#) | Natural - -(struct move (action gt) #:transparent) -;; Move = (move Action GameTree) -;; in (move a gt) -;; -- a represents the actione to be takem -;; -- gt is the game-tree resulting from that action - -;; Action is one of: -;; -- '() a passing move -;; -- (list Natural Natural) the move where the first attacks the second - -(struct territory (index player dice x y) #:transparent) -;; Territory = (territory Natural Player Dice Integer Integer) -;; in (territory i p d x y) -;; -- i is a unique identifier for the territory; it also determines its initial location -;; -- p is the player who owns this territory -;; -- d is the number of dice on this board -;; -- x is the x coordiate of this territory in pixels -;; -- y is the y coordiate of this territory in pixels - -;; Territory Natural -> Territory -;; updates number of dice on territory -(define (territory-set-dice t d) - (territory (territory-index t) (territory-player t) d (territory-x t) (territory-y t))) - -;; Territory Player -> Territory -;; updates owner of territory -(define (territory-set-player t p) - (territory (territory-index t) p (territory-dice t) (territory-x t) (territory-y t))) - -;; --------------------------------------------------------------------------------------------------- -;; sample game tree for BOOK - -(define b1 - (list (territory 1 0 1 'a 'b) - (territory 0 0 1 'x 'y))) - -(define b1-alternative - (list (territory 0 0 1 'x 'y) - (territory 1 0 1 'a 'b))) - -(define b3 - (list (territory 0 0 2 'x 'y) - (territory 1 1 1 'a 'b))) - -(define gt1 (game b1 1 '())) - -(define mv2 (move '() gt1)) - -(define gt2 (game b1-alternative 0 (list mv2))) - -(define mv3 (move '(0 1) gt2)) - -(define gt3 (game b3 0 (list mv3))) - -;; --------------------------------------------------------------------------------------------------- -;; Constants - -; initalization constants -(define PLAYER# 2) -(define DICE# 3) -(define BOARD 2) -(define GRID (* BOARD BOARD)) -(define INIT-PLAYER 0) -(define INIT-SPARE-DICE 10) -; The depth at which to limit the gametree -(define AI-DEPTH 4) -(define AI 1) - -; graphical constants: territories -(define DICE-OFFSET 6) -(define SIDE 75) -(define OFFSET0 (* 2 SIDE)) -(define ROTATION 30) -(define HEX 6) -(define (hexagon color) - (rotate ROTATION (regular-polygon SIDE HEX "solid" color))) -(define X-OFFSET (image-width (hexagon "black"))) -(define Y-OFFSET (* (image-height (hexagon "black")) 3/4)) - -; graphical constants -(define COLORS - (list (make-color 255 0 0 100) - (make-color 0 255 0 100) - (make-color 0 0 255 100))) -(define FOCUS (rotate ROTATION (regular-polygon SIDE 6 "outline" "black"))) -(define D1 (bitmap "graphics/dice1.png")) -(define D2 (bitmap "graphics/dice2.png")) -(define D3 (bitmap "graphics/dice3.png")) -(define D4 (bitmap "graphics/dice4.png")) -(define IMG-LIST (list D1 D2 D3 D4)) - -(define TEXT-SIZE 25) -(define TEXT-COLOR "black") -(define INSTRUCT - "← and → to move among territories, to mark, to unmark, and

to pass") -(define AI-TURN "It's the Mighty AI's turn") -(define YOUR-TURN "It's your turn") -(define INFO-X-OFFSET 100) -(define INFO-Y-OFFSET 50) - -(define INSTRUCTIONS (text INSTRUCT TEXT-SIZE TEXT-COLOR)) -(define WIDTH (+ (image-width INSTRUCTIONS) 50)) -(define HEIGHT 600) -(define (PLAIN) - (define iw (image-width INSTRUCTIONS)) - (define bw (* SIDE 2 BOARD)) - (set! WIDTH (+ (max iw bw) 50)) - (set! HEIGHT (+ (* SIDE 2 BOARD) 50)) - (empty-scene WIDTH HEIGHT)) -(define (ISCENE) - (define mt (PLAIN)) - (when (or (> (image-width mt) 1280) (> (image-height mt) 800)) - (error 'scene "it is impossible to draw a ~s x ~s game scene for a 1280 x 800 laptop screen" (image-width mt) (image-height mt))) - (place-image INSTRUCTIONS (* .5 WIDTH) (* .9 HEIGHT) mt)) - -; -; -; -; -; ;;; ;;; ; -; ;; ;; -; ;; ;; ;;;; ;;; ;; ;; -; ; ; ; ; ; ; ;; ; -; ; ; ; ;;;;; ; ; ; -; ; ; ; ; ; ; ; -; ; ; ; ;; ; ; ; -; ;;; ;;; ;;; ;; ;;;;; ;;; ;;; -; -; -; -; - -;; --------------------------------------------------------------------------------------------------- - -;; start the game -(define (roll-the-dice) - (big-bang (create-world-of-dice-and-doom) - (on-key interact-with-board) - (to-draw draw-dice-world) - (stop-when no-more-moves-in-world? - draw-end-of-dice-world))) - -;; -> DiceWorld -;; Returns a randomly generated world. If the world that -;; has been generated starts as a tie, the world is regenerated. -;; property: world is not in endgame state (no-more-moves? returns false) -(define (create-world-of-dice-and-doom) - (define board (territory-build)) - (define gamet (game-tree board INIT-PLAYER INIT-SPARE-DICE)) - (define new-world (dice-world #f board gamet)) - (if (no-more-moves-in-world? new-world) - (create-world-of-dice-and-doom) - new-world)) - -;; DiceWorld Key -> DiceWorld -;; Handles key events from a player -(define (interact-with-board w k) - (cond [(key=? "left" k) - (refocus-board w left)] - [(key=? "right" k) - (refocus-board w right)] - [(key=? "p" k) - (pass w)] - [(key=? "\r" k) - (mark w)] - [(key=? "d" k) - (unmark w)] - [else w])) - -;; Diceworld -> Scene -;; draws the world -(define (draw-dice-world w) - (add-player-info - (game-player (dice-world-gt w)) - (add-winning-probability w (add-board-to-scene w (ISCENE))))) - -;; DiceWorld -> Boolean -;; is it possible to play any moves from this world state? -(define (no-more-moves-in-world? w) - (define tree (dice-world-gt w)) - (define board (dice-world-board w)) - (define player (game-player tree)) - (or (no-more-moves? tree) - (for/and ((t board)) (= (territory-player t) player)))) - -;; DiceWorld -> Image -;; render the endgame screen -(define (draw-end-of-dice-world w) - (define board (dice-world-board w)) - (define message (text (won board) TEXT-SIZE TEXT-COLOR)) - (define background (add-board-to-scene w (PLAIN))) - (overlay message background)) - -;; Board -> String -;; Which player has won the game -- eager is for N human players -(define (won board) - (define-values (best-score w) (winners board)) - (if (cons? (rest w)) "It's a tie." "You won.")) - -; -; -; -; -; ;;;;; ; -; ; ; -; ; ;; ;; ;;; ;;;;; -; ; ;; ; ; ; -; ; ; ; ; ; -; ; ; ; ; ; -; ; ; ; ; ; ; -; ;;;;; ;;; ;;; ;;;;; ;;; -; -; -; -; - -;; --------------------------------------------------------------------------------------------------- -;; Making A Board - -;; -> Board -;; Creates a list of territories the size of GRID with given x and y coordinates -;; properties: dice is (0,MAX-DICE] -;; returns list of size GRID -(define (territory-build) - (for/list ([n (in-range GRID)]) - (territory n (modulo n PLAYER#) (dice) (get-x n) (get-y n)))) - -;; -> Natural -;; the number of initial die on a territory -(define (dice) - (add1 (random DICE#))) - -;; Natural -> Number -;; the x coordinate for territory n of a board -(define (get-x n) - (+ OFFSET0 - (if (odd? (get-row n)) 0 (/ X-OFFSET 2)) - (* X-OFFSET (modulo n BOARD)))) - -;; Natural -> Number -;; the y coordinate for territory n of a board -(define (get-y n) - (+ OFFSET0 (* Y-OFFSET (get-row n)))) - -;; --------------------------------------------------------------------------------------------------- -;; Making a Game Tree - -;; Board Player Natural -> GameTree -;; creates a complete game-tree from the given board, player, and spare dice -(define (game-tree board player dice) - ;; create tree of attacks from this position; add passing move - (define (attacks board) - (for*/list ([src board] - [dst (neighbors (territory-index src))] - #:when (attackable? board player src dst)) - (define from (territory-index src)) - (define dice (territory-dice src)) - (define newb (execute board player from dst dice)) - (define attacks-from-newb - (game newb player (cons (passes newb) (attacks newb)))) - (move (list from dst) attacks-from-newb))) - ;; create a passing move , distribute dice, continue - (define (passes board) - (define-values (new-dice newb) (distribute board player dice)) - (move '() (game-tree newb (switch player) new-dice))) - ;; -- START: -- - (game board player (attacks board))) - -;; Player -> Player -;; switches from one player to the next -(define (switch player) - (modulo (+ player 1) PLAYER#)) - -;; Board Player Natural -> Natural Board -;; adds reinforcements to the game board -;; > (add-new-dice (list (territory 0 2 2 9 0)) 2 2)) -;; (list (territory 0 2 2 9 0)) -(define (distribute board player spare-dice) - (for/fold ([dice spare-dice] [new-board '()]) ([t board]) - (if (and (= (territory-player t) player) - (< (territory-dice t) DICE#) - (not (zero? dice))) - (values (- dice 1) (cons (add-dice-to t) new-board)) - (values dice (cons t new-board))))) - -;; Territory -> Territory -;; adds one dice to the given territory -(define (add-dice-to t) - (territory-set-dice t (add1 (territory-dice t)))) - -;; Board Player Territory Natural -> Boolean -;; can player attack dst from src? -(define (attackable? board player src dst) - (define dst-t - (findf (lambda (t) (= (territory-index t) dst)) board)) - (and dst-t - (= (territory-player src) player) - (not (= (territory-player dst-t) player)) - (> (territory-dice src) (territory-dice dst-t)))) - -;; Board Natural Natural Natural Natural -> Board -;; Creates a new board after an attack -;; updates only src and dst -(define (execute board player src dst dice) - (for/list ([t board]) - (define idx (territory-index t)) - (cond [(= idx src) (territory-set-dice t 1)] - [(= idx dst) - (define s (territory-set-dice t (- dice 1))) - (territory-set-player s player)] - [else t]))) - -;; --------------------------------------------------------------------------------------------------- -;; Getting Neigbors - -;; Natural -> [List-of Natural] -;; returns the neighbors of the current spot -;; > (neighbors 0) -;; '(1 2 3) -(define (neighbors pos) - (define top? (< pos BOARD)) - (define bottom? (= (get-row pos) (sub1 BOARD))) - (define even-row? (zero? (modulo (get-row pos) 2))) - (define right? (zero? (modulo (add1 pos) BOARD))) - (define left? (zero? (modulo pos BOARD))) - (if even-row? - (even-row pos top? bottom? right? left?) - (odd-row pos top? bottom? right? left?))) - -;; Natural Boolean Boolean Boolean Boolean -> [Listof Naturals] -;; gets the neighbors for a territory on an even row -(define (even-row pos top? bottom? right? left?) - (append (add (or top? right?) (add1 (- pos BOARD))) - (add (or bottom? right?) (add1 (+ pos BOARD))) - (add top? (- pos BOARD)) - (add bottom? (+ pos BOARD)) - (add right? (add1 pos)) - (add left? (sub1 pos)))) - -;; Natural Boolean Boolean Boolean Boolean -> [Listof Naturals] -;; gets the neighbors for a territory on an odd row -(define (odd-row pos top? bottom? right? left?) - (append (add top? (- pos BOARD)) - (add bottom? (+ pos BOARD)) - (add (or top? left?) (sub1 (- pos BOARD))) - (add (or bottom? left?) (sub1 (+ pos BOARD))) - (add right? (add1 pos)) - (add left? (sub1 pos)))) - -;; Boolean X -> [Listof X] -;; returns (list x) if (not b) else empty -(define (add b x) - (if b '() (list x))) - -; -; -; -; -; ;;; ;;; ;;;;;; -; ; ; ; ; ; -; ; ; ;;;; ;;; ;;; ; ; ;;; ;;; ;;;; ;; ;; ;;;;; ;;;;; -; ; ; ; ; ; ; ;;; ; ; ; ; ;; ; ; ; ; -; ;;; ;;;;;; ; ; ; ; ; ; ;;;;;; ; ; ; ;;;; -; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; -; ;;; ;; ;;;;; ; ;;;;;; ;; ;;;;; ;;; ;;; ;;; ;;;;; -; ; -; ;;; -; -; - -;; --------------------------------------------------------------------------------------------------- -;; Territory Focusing and Marking - -;; DiceWorld [Board -> Board] -> World -;; Creates a new World that has a rotated territory list -;; > (define lterritory (territory 0 0 1 9 2)) -;; > (define rterritory (territory 0 0 1 9 0)) -;; > (refocus-board-action (dice-world -1 (list rterritory lterritory ...) GT) left) -;; (dice-world -1 (list lterritory ... rterritory) GT) -;; > (refocus-board-action (dice-world -1 (list lterritory ... rterritory) GT) left) -;; (dice-world -1 (list rterritory lterritory ...) GT) -(define (refocus-board w direction) - (define source (dice-world-src w)) - (define board (dice-world-board w)) - (define tree (dice-world-gt w)) - (define player (game-player tree)) - (define (owner? tid) - (if source (not (= tid player)) (= tid player))) - (define new-board (rotate-until owner? board direction)) - (dice-world source new-board tree)) - -;; [Player -> Boolean] Board (Board -> Board) -> Board -;; rotate until the first element of the list satisfies owned-by -(define (rotate-until owned-by board rotate) - (define next-list (rotate board)) - (if (owned-by (territory-player (first next-list))) - next-list - (rotate-until owned-by next-list rotate))) - -;; Board -> Board -;; rotate a list to the left -(define (left l) - (append (rest l) (list (first l)))) - -;; Board -> Board -;; rotate a list to the right -(define (right l) - (reverse (left (reverse l)))) - -;; --------------------------------------------------------------------------------------------------- -;; Handling Moves - -;; DiceWorld -> DiceWorld -;; executes a passing move on the world state -;; THIS DEFINITION IS NOT USED FOR THE ABSTRACT VERSION OF THE MODULE. -(define (pass.10 w) - (define m (find-move (game-moves (dice-world-gt w)) '())) - (cond [(not m) w] - [else ;; (no-more-moves? m) - (dice-world #f (game-board m) m)])) - -;; DiceWorld -> DiceWorld -;; unmarks a marked territory -(define (unmark w) - (dice-world #f (dice-world-board w) (dice-world-gt w))) - -;; DiceWorld -> DiceWorld -;; marks a territory as the launching pad for an attack or launches the attack -(define (mark w) - (define tree (dice-world-gt w)) - (define board (dice-world-board w)) - (define source (dice-world-src w)) - (define focus (territory-index (first board))) - (if source - (attacking w source focus) - (dice-world focus board tree))) - -;; DiceWorld Natural Natural -> DiceWorld -(define (attacking w source target) - (define feasible (game-moves (dice-world-gt w))) - (define attack (list source target)) - (define next (find-move feasible attack)) - (define src-t (findf (lambda (t) (= (territory-index t) source)) - (dice-world-board w))) - (define dst-t (findf (lambda (t) (= (territory-index t) target)) - (dice-world-board w))) - (define win? (dice-attack-win src-t dst-t)) - (cond [(not next) w] - [win? (dice-world #f (game-board next) next)] - [else (dice-world-attack-lost w src-t)])) - -;; [List-of Moves] [or '() [List Natural Natural]] -> [or #f Game-tree] -;; find the move from the current list of moves -(define (find-move moves a) - (define m (findf (lambda (m) (equal? (move-action m) a)) moves)) - (and m (move-gt m))) - -;; Game -> Boolean -;; are there any moves in this game record? -(define (no-more-moves? g) - (empty? (game-moves g))) - -;; Territory Territory -> Boolean -;; attack from src territory to destination territory -;; and see who wins -(define (dice-attack-win src-t dst-t) - (define (roll-dice n) - (for/list ([i n]) - (random 1 7))) - (define (sum l) - (foldl + 0 l)) - (define src-attack (sum (roll-dice (territory-dice src-t)))) - (define dst-defend (sum (roll-dice (territory-dice dst-t)))) - (if (> src-attack dst-defend) #t #f)) - - -(define (probability-of-winning st dt) - "Find the probability of source territory defeating destination territory. - - `st` is the source territory. - `dt` is the destination territory." - - ; Given the number of dice, returns a list all dice combinations. - (define (dice-all-combination dice-num) - (cond [(= dice-num 1) - (for/list ([i (in-range 1 7)]) - (list i))] - [else - (for*/list ([i (in-range 1 7)] - [r (dice-all-combination - (- dice-num 1))]) - (cons i r))])) - - - ; Given a list of dice combinations, returns a hashmap where the key - ; is the 'dice sum' and the value is the number of combinations - ; whose sum is the 'dice sum'. - (define (dice-sum-hash dice-combinations) - (for/foldr - ([h (make-hash)]) ([c dice-combinations]) - (let ((sum (for/sum ([n c]) n))) - (hash-set! h sum (+ (hash-ref h sum 0) 1)) - h))) - - - ; sh: -> hashmap - ; key: dice sum, - ; value: number of ways we can arrive at sum - (define sh (dice-sum-hash - (dice-all-combination (territory-dice st)))) - - ; dh: -> hashmap - ; key: dice sum, - ; value: number of ways we can arrive at sum - (define dh (dice-sum-hash - (dice-all-combination (territory-dice dt)))) - - ; Generic probability function. - (define (probability f t) - (/ (* 1.0 f) t)) - - ; Computes the total number of favorable outcomes for the source - ; territory when its dice sum is `s-ds` against the - ; destination's territory. - ; - ; s-ds -> source dice sum. - ; n -> number of we can arrive at sum `s-ds`. - (define (favorable-outcomes s-ds n) - (* (for/sum [(d-ds (hash-keys dh))] - (if (< d-ds s-ds) - (hash-ref dh d-ds) - 0)) - n)) - - ; Computes the total number of favorable outcomes for the source - ; territory against the destination's territory. - (define (all-favorable-outcomes) - (foldr + 0 - (for/list [(s-ds (hash-keys sh))] - (favorable-outcomes - s-ds - (hash-ref sh s-ds))))) - - (define (all-outcomes) - (let ((sd (territory-dice st)) - (dd (territory-dice dt))) - (* (expt 6 sd) (expt 6 dd)))) - - (probability (all-favorable-outcomes) (all-outcomes))) - - -;; DiceWorld Territory -> DiceWorld -;; generate dice world for the case where player -;; loses the dice attack -(define (dice-world-attack-lost w src-t) - (define src (territory-index src-t)) - (define player (territory-player src-t)) - (define newb (for/list ([t (dice-world-board w)]) - (define idx (territory-index t)) - (cond [(= idx src) (territory-set-dice t 1)] - [else t]))) - (define new-gt (game-tree newb player 0)) - (dice-world #f newb new-gt)) - -; -; -; -; -; ;;;;; ;; ; -; ; ; ; -; ; ; ;;;; ;; ;; ;;; ; ;;;; ;; ;;; ;;; ;; ;; ;;; ;; -; ; ; ; ; ;; ; ; ;; ; ; ;; ; ;; ; ; ;; -; ;;;; ;;;;;; ; ; ; ; ;;;;;; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; -; ;;; ; ;;;;; ;;; ;;; ;;; ;; ;;;;; ;;;;; ;;;;; ;;; ;;; ;;; ; -; ; -; ;;;; -; -; - -;; Player Scene-> Scene -;; Draws the world -(define (add-player-info player s) - (define str (whose-turn player)) - (define txt (text str TEXT-SIZE TEXT-COLOR)) - (place-image txt (- WIDTH INFO-X-OFFSET) INFO-Y-OFFSET s)) - -(define (add-winning-probability w s) - (define board (dice-world-board w)) - (define source (dice-world-src w)) - (define target (territory-index (first board))) - (define feasible (game-moves (dice-world-gt w))) - (define attack (list source target)) - (define next (find-move feasible attack)) - - (define (find-territory index) - (findf (lambda (t) (= (territory-index t) index)) - (dice-world-board w))) - - (if (and source next) - (place-image - (text (string-append - "Winning Probability " - (~r - (probability-of-winning (find-territory source) - (find-territory target)) - #:precision 2)) - TEXT-SIZE TEXT-COLOR) - (- WIDTH 150) 100 s) - s)) - -;; DiceWorld Scene -> Scene -;; folds through the board and creates an image representation of it -(define (add-board-to-scene w s) - (define board (dice-world-board w)) - (define player (game-player (dice-world-gt w))) - (define focus? (dice-world-src w)) - (define trtry1 (first board)) - (define p-focus (territory-player trtry1)) - (define t-image (draw-territory trtry1)) - (define image (draw-focus focus? p-focus player t-image)) - (define base-s (add-territory trtry1 image s)) - (for/fold ([s base-s]) ([t (rest board)]) - (add-territory t (draw-territory t) s))) - -;; Nat Player Player Image -> Image -;; add focus marker to territory if needed -(define (draw-focus marked? p-in-focus p t-image) - (if (or (and (not marked?) (= p-in-focus p)) - (and marked? (not (= p-in-focus p)))) - (overlay FOCUS t-image) - t-image)) - -;; Image Territory Image -> Image -(define (add-territory t image scene) - (place-image image (territory-x t) (territory-y t) scene)) - -;; Territory -> Image -;; renders a single territory -(define (draw-territory t) - (define color (color-chooser (territory-player t))) - (overlay (hexagon color) (draw-dice (territory-dice t)))) - -;; Natural -> Image -;; renders all n >= 1 dice as a stack of dice -(define (draw-dice n) - (define first-die (get-dice-image 0)) - (define height-die (image-height first-die)) - (for/fold ([s first-die]) ([i (- n 1)]) - (define dice-image (get-dice-image (+ i 1))) - (define y-offset (* height-die (+ .5 (* i .25)))) - (overlay/offset s 0 y-offset dice-image))) - -;; Player -> Color -;; Determines a color for each player -(define (color-chooser p) - (list-ref COLORS p)) - -;; -> Image -;; returns an image from the list of dice images -(define (get-dice-image i) - (list-ref IMG-LIST (modulo i (length IMG-LIST)))) - -; -; -; -; -; ;;;;;; ;; ; -; ; ; ; -; ; ; ;; ;; ;;; ; ;;; ;; ;; ;;; ;; -; ;;; ;; ; ; ;; ; ;; ; ; ;; -; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ;; ; ; ; ; ;; -; ;;;;;; ;;; ;;; ;;; ;; ;;;;; ;;; ;;; ;;; ; -; ; -; ;;;; -; -; - -;; Board ->* Natural [non-empty-listof Player] -;; gives the number of winning territories and the players(s) who have them -;; > (winners (list (territory 0 0 1 9 0) (territory 0 0 1 9 1))) -;; (values 2 '(0)) -;; > (winners (list (territory 0 1 1 9 0) (territory 0 0 1 9 1))) -;; (values 1 '(0 1)) -(define (winners board) - (for/fold ([best 0][winners '()]) ([p PLAYER#]) - (define p-score (sum-territory board p)) - (cond [(> p-score best) (values p-score (list p))] - [(< p-score best) (values best winners)] - [(= p-score best) (values best (cons p winners))]))) - -;; Board Player -> Natural -;; counts the number of territorys the player owns -;; > (sum-territory (list (territory 0 1 1 9 0) (territory 0 1 1 9 1)) 1) -;; 2 -(define (sum-territory board player) - (for/fold ([result 0]) ([t board]) - (if (= (territory-player t) player) (+ result 1) result))) - - -; -; -; -; -; -; ;;; ;;;;;;; -; ;; ; -; ; ; ; -; ; ; ; -; ; ; ; -; ;;;;;; ; -; ; ; ; -; ; ; ; -; ;;; ;;; ;;;;;;; -; -; -; -; - -;; Player -> {AI-TURN, YOUR-TURN} -;; THIS REQUIRES A DIFFERENT DEFINITION FOR PLAIN CHAPTER 10. -(define (whose-turn player) - (if (= player AI) AI-TURN YOUR-TURN)) - -;; DiceWorld -> DiceWorld -;; executes a passing move on the world state -;; THIS REQUIRES A DIFFERENT DEFINITION FOR PLAIN CHAPTER 10. -(define (pass w) - (define m (find-move (game-moves (dice-world-gt w)) '())) - (cond [(not m) w] - [(or (no-more-moves? m) (not (= (game-player m) AI))) - (dice-world #f (game-board m) m)] - [else - (define ai (the-ai-plays m)) - (dice-world #f (game-board ai) ai)])) - -;; GameTree -> GameTree -;; Computer calls this function until it is no longer the player -(define (the-ai-plays tree) - (define ratings (rate-moves tree AI-DEPTH)) - (define the-move (first (argmax second ratings))) - (define new-tree (move-gt the-move)) - (if (= (game-player new-tree) AI) - (the-ai-plays new-tree) - new-tree)) - -;; GameTree Natural -> [List-of (List Move Number)] -;; assigns a value to each move that is being considered -;; and return those values in a list -(define (rate-moves tree depth) - (for/list ((move (game-moves tree))) - (list move (rate-position (move-gt move) (- depth 1))))) - -;; GameTree Natural -> Number -;; Returns a number that is the best move for the given player. -(define (rate-position tree depth) - (cond [(or (= depth 0) (no-more-moves? tree)) - (define-values (best w) (winners (game-board tree))) - (if (member AI w) (/ 1 (length w)) 0)] - [else - (define ratings (rate-moves tree depth)) - (apply (if (= (game-player tree) AI) max min) - (map second ratings))])) - -; -; -; -; -; ;; -; ; -; ; ; ;; ;; ;; ;; ;;;;; -; ; ; ; ; ; ; ; ; -; ; ; ; ; ;; ;;;; -; ;;; ; ; ;; ; -; ; ; ; ;; ; ; ; ; -; ;;; ;;; ;; ;; ;; ;; ;;;;; -; -; -; -; - -;; Natural -> Natural -;; gets the row that territory is on, indexed from 0 -;; [test vary on current board-size] -(define (get-row pos) - (quotient pos BOARD)) - - -; -; -; -; -; -; ;;;;;;; ; -; ; ; ; ; -; ; ; ; ;;; ;;;; ; ;;;;;; ;;;; ; -; ; ; ; ; ; ; ;; ; ; ;; -; ; ; ; ; ; ; -; ; ;;;;;;; ;;;;; ; ;;;;; -; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; -; ;;;;; ;;;; ;;;;;; ;;;; ;;;;;; -; -; -; -; - -;; --------------------------------------------------------------------------------------------------- - -;; Natural -> Void -;; make the board larger -(define (set-grid n) - (set! BOARD n) - (set! GRID (* n n))) - -(module+ test - - (require rackunit rackunit/text-ui) - - ;; (-> any) -> void - ;; runs the thunk PROP-NUM times - (define (check-property t) - (test-begin (for ((i 50)) (t)))) - - ;; Properties - (define (property:starting-world-playable) - (unless (and (= BOARD 2) (= PLAYER# 2)) - (error 'starting-world-playable "BOARD-SIZE != 2 or PLAYERS# != 2")) - (check-false (no-more-moves-in-world? (create-world-of-dice-and-doom)))) - - (define (property:dice-in-range) - (check-true (andmap (λ (b) (>= DICE# (territory-dice b) 1)) (territory-build)) - "dice out of range")) - - (define (property:board-correct-size) - (check-equal? (length (territory-build)) GRID - "board incorrect-size")) - - (define (property:no-pass-on-first-move) - (define (move-action? m) (equal? (move-action m) '())) - (check-true (not (memf move-action? (game-moves (game-tree (territory-build) 0 0)))) - "no pass on first move")) - - ;; --------------------------------------------------------------------------------------------------- - - - ;; testing game initialization - - (check-equal? (territory-index (first (territory-build))) 0) - (check-equal? (territory-player (first (territory-build))) 0) - (check-equal? (territory-index (second (territory-build))) 1) - (check-equal? (territory-player (second (territory-build))) 1) - (check-equal? (territory-index (third (territory-build))) 2) - (check-equal? (territory-player (third (territory-build))) 0) - (check-equal? (territory-index (fourth (territory-build))) 3) - (check-equal? (territory-player (fourth (territory-build))) 1) - - (check-property property:starting-world-playable) - (check-property property:board-correct-size) - (check-property property:dice-in-range) - (check-property property:no-pass-on-first-move) - - ;; --------------------------------------------------------------------------------------------------- - ;; testing territory manipulation - - ;; legal? - (check-true - (and (attackable? (list (territory 0 0 2 9 0) (territory 3 1 1 9 0)) 0 (territory 0 0 2 9 0) 3) #t)) - (check-false - (attackable? (list (territory 0 0 2 9 0) (territory 3 1 1 9 0)) 0 (territory 0 0 2 9 0) 0)) - (check-false - (attackable? (list (territory 0 0 2 9 0) (territory 5 1 1 9 0)) 1 (territory 0 0 2 9 0) 5)) - - ;; get-row - (check-equal? (get-row 0) 0) - (check-equal? (get-row 1) 0) - (check-equal? (get-row 2) 1) - (check-equal? (get-row 3) 1) - (check-equal? (get-row 12) 6) ;; checks math. actually invalid on board of size 2 - (check-equal? (get-row 11) 5) ;; checks math. actually invalid on board of size 2 - (check-equal? (get-row 13) 6) ;; checks math. actually invalid on board of size 2 - (check-equal? (get-row 14) 7) ;; checks math. actually invalid on board of size 2 - - ;; --------------------------------------------------------------------------------------------------- - (define board3 - (list (territory 0 1 1 9 0) (territory 1 1 1 8 0) (territory 2 1 3 43.5 5) (territory 3 1 1 6 5))) - (define b1+0+3 - (list (territory 0 0 2 9 0) (territory 1 1 1 8 0) (territory 2 0 2 43.5 5) (territory 3 1 1 6 5))) - (define b2+1+2 - (list (territory 0 0 1 9 0) (territory 1 1 3 8 0) (territory 2 0 2 43.5 5) (territory 3 1 2 6 5))) - (define board6 - (list (territory 0 0 1 9 0) (territory 1 1 2 8 0) (territory 2 0 3 43.5 5) (territory 3 1 2 6 5))) - (define bard6+ - (list (territory 0 0 1 9 0) (territory 1 1 2 8 0) (territory 2 0 3 43.5 5) (territory 3 1 2 6 5))) - - (define (distribute/list a b c) - (define-values (x y) (distribute a b c)) - (list x y)) - - (define board0 - (list (territory 0 0 1 9 0) (territory 1 1 2 8 0) (territory 2 0 2 43.5 5) (territory 3 1 1 6 5))) - (define board1 - (list (territory 0 0 1 9 0) (territory 1 1 1 8 0) (territory 2 0 1 43.5 5) (territory 3 1 1 6 5))) - (define b1+1+2 - (list (territory 0 0 1 9 0) (territory 1 1 2 8 0) (territory 2 0 1 43.5 5) (territory 3 1 2 6 5))) - (define board2 - (list (territory 0 0 1 9 0) (territory 1 1 1 8 0) (territory 2 0 3 43.5 5) (territory 3 1 1 6 5))) - - (define g-tree1 (game board1 0 '())) - (define g-tree2 (game-tree board0 0 0)) - - ; (define world31 (dice-world #f board1 g-tree1)) - (define world2 (dice-world #f board2 g-tree2)) - - ;; testing book tree - - (check-equal? (game-tree (list (territory 0 0 2 'x 'y) - (territory 1 1 1 'a 'b)) - 0 - 0) - gt3) - - - ;; testing tree generation - - (define (property:attack-location-valid) - (define moves (game-moves (game-tree (territory-build) 0 0))) - (check-true (and (for/and ([m moves]) - (define m1 (move-action m)) - (member (second m1) (neighbors (first m1)))) - #t) - "invalid attack location")) - - (define (property:add-to-territory-always-up-one) - (define r (random 10000)) - (check-equal? (add-dice-to (territory 0 0 r 0 0)) - (territory 0 0 (add1 r) 0 0) - "add to territory always up one")) - - (define (property:attackable?-does-not-need-neighbores-check) - (define (check-attackable? gt) - (for/and ([move (game-moves gt)] - #:when (not (empty? (move-action move)))) - (define action (move-action move)) - (define gt (move-gt move)) - (and (member (second action) (neighbors (first action))) - (check-attackable? gt)))) - - ;;start - (define old-size BOARD) - (set-grid 2) - (define testing-gt (dice-world-gt (create-world-of-dice-and-doom))) - (check-true (check-attackable? testing-gt) "An attack move between non-neighbores was created") - (set-grid old-size)) - - - ;; game-tree - (check-equal? (game-tree board1 0 0) g-tree1) - (check-equal? (game-tree board3 1 0) (game board3 1 '())) - (check-equal? (game-tree board3 0 0) (game board3 0 '())) - (check-property property:attackable?-does-not-need-neighbores-check) - - ;; find-move - (check-false (find-move '() '())) - (check-equal? (find-move (list (move '() (game '() 0 '()))) '()) (game '() 0 '())) - ;; Attacking-Moves - (check-property property:attack-location-valid) - - ;; switch-players - (check-equal? (switch 0) 1) - (check-equal? (switch 1) 0) - - ;; Add-New-Dice - (check-equal? (distribute/list (game-board g-tree1) 0 3) (list 1 (reverse b1+0+3))) - (check-equal? (distribute/list (game-board g-tree1) 1 2) (list 0 (reverse b1+1+2))) - (check-equal? (distribute/list (game-board g-tree2) 1 2) (list 0 (reverse b2+1+2))) - (check-equal? (distribute/list board6 0 0) (list 0 (reverse bard6+))) - - ;; add-to-territory - (check-equal? (add-dice-to (territory 0 1 2 9 0)) (territory 0 1 3 9 0)) - (check-equal? (add-dice-to (territory 0 1 1 9 0)) (territory 0 1 2 9 0)) - (check-equal? (add-dice-to (territory 0 1 5 9 0)) (territory 0 1 6 9 0)) - (check-property property:add-to-territory-always-up-one) - - ;; --------------------------------------------------------------------------------------------------- - (define board7 - (list (territory 0 0 1 9 0) (territory 1 1 1 8 0) (territory 2 0 2 43.5 5) (territory 3 1 1 6 5))) - (define board8 - (list (territory 0 1 1 9 0) (territory 1 1 1 8 0) (territory 2 0 3 43.5 5) (territory 3 1 1 6 5))) - (define board9 - (list (territory 0 0 1 9 0) (territory 1 1 1 8 0) (territory 2 0 2 43.5 5) (territory 3 0 1 6 5))) - (define board10 - (list (territory 0 0 1 9 0) (territory 1 1 3 8 0) (territory 2 0 2 43.5 5) (territory 3 1 1 6 5))) - - ;; testing attacks - - (check-equal? - (execute board7 0 2 1 2) - (list (territory 0 0 1 9 0) (territory 1 0 1 8 0) (territory 2 0 1 43.5 5) (territory 3 1 1 6 5))) - - (check-equal? - (execute board8 0 2 1 3) - (list (territory 0 1 1 9 0) (territory 1 0 2 8 0) (territory 2 0 1 43.5 5) (territory 3 1 1 6 5))) - - (check-equal? - (execute board9 0 2 1 2) - (list (territory 0 0 1 9 0) (territory 1 0 1 8 0) (territory 2 0 1 43.5 5) (territory 3 0 1 6 5))) - - (check-equal? - (execute board10 1 1 0 3) - (list(territory 0 1 2 9 0) (territory 1 1 1 8 0) (territory 2 0 2 43.5 5) (territory 3 1 1 6 5))) - - ;; Neighbors - (check-equal? (neighbors 2) '(0 3)) - (check-equal? (neighbors 0) '(3 2 1)) - (check-equal? (neighbors 1) '(3 0)) - (check-equal? (neighbors 3) '(1 0 2)) - - ;; --------------------------------------------------------------------------------------------------- - (define board20 - (list (territory 0 0 1 9 2) (territory 1 0 1 9 0) (territory 2 2 1 9 0))) - (define board21 - (list (territory 0 1 1 9 0) (territory 1 1 1 8 0) (territory 2 1 1 43.5 5) (territory 3 1 1 6 5))) - - ;; testing focus manipulation - ;; interact-with-board - (check-equal? - (interact-with-board world2 "\r") - (dice-world (territory-index (car (dice-world-board world2))) (dice-world-board world2) g-tree2)) - - (check-equal? (interact-with-board world2 "p") world2) - - ;; refocus-board-action - (check-equal? - (refocus-board (dice-world #f (list (territory 0 0 1 9 0) (territory 0 0 1 9 2)) g-tree1) left) - (dice-world #f (list (territory 0 0 1 9 2) (territory 0 0 1 9 0)) g-tree1)) - - (check-equal? - (refocus-board (dice-world #f (list (territory 0 0 1 9 2) (territory 0 1 1 9 0)) g-tree1) right) - (dice-world #f (list (territory 0 0 1 9 2) (territory 0 1 1 9 0)) g-tree1)) - - (check-equal? - (refocus-board (dice-world 0 board20 g-tree1) left) - (dice-world 0 (list (territory 2 2 1 9 0) (territory 0 0 1 9 2) (territory 1 0 1 9 0)) g-tree1)) - - (check-equal? - (refocus-board (dice-world 0 (list (territory 0 0 1 9 2) (territory 0 1 1 9 0)) g-tree1) left) - (dice-world 0 (list (territory 0 1 1 9 0) (territory 0 0 1 9 2)) g-tree1)) - - (check-equal? - (refocus-board (dice-world 0 (list(territory 0 0 1 9 2) (territory 0 1 1 9 0)) g-tree1) right) - (dice-world 0 (list (territory 0 1 1 9 0) (territory 0 0 1 9 2)) g-tree1)) - - ;;unmark - (check-equal? (unmark (dice-world 1 board21 g-tree1)) (dice-world #f board21 g-tree1)) - - (check-equal? (unmark (dice-world 1 (list (territory 0 1 1 9 0) (territory 1 1 1 8 0)) g-tree1)) - (dice-world #f (list (territory 0 1 1 9 0) (territory 1 1 1 8 0)) g-tree1)) - (check-equal? (unmark (dice-world 0 (list (territory 0 1 1 9 0)) g-tree1)) - (dice-world #f (list (territory 0 1 1 9 0)) g-tree1)) - (check-equal? (unmark (dice-world #f (list (territory 0 1 1 9 0)) g-tree1)) - (dice-world #f (list (territory 0 1 1 9 0)) g-tree1)) - - ;; --------------------------------------------------------------------------------------------------- - (define (winners/list w) - (define-values (a b) (winners w)) - (cons a b)) - - ;; testing functions that determine 'winning' and declare the winner - - ;; winners - (check-equal? (winners/list (list (territory 0 0 1 9 0) (territory 0 0 1 9 1))) (list 2 0)) - (check-equal? (winners/list (list (territory 0 1 1 9 0) (territory 0 0 1 9 1))) (list 1 1 0)) - - ;; sum-territory - (check-equal? (sum-territory (list (territory 0 0 1 9 0) (territory 0 0 1 9 1)) 0) 2) - (check-equal? (sum-territory (list (territory 0 0 1 9 0) (territory 0 0 1 9 1)) 1) 0) - (check-equal? (sum-territory (list (territory 0 0 1 9 0) (territory 0 0 1 9 1)) 2) 0) - (check-equal? (sum-territory (list (territory 0 1 1 9 0) (territory 0 0 1 9 1)) 1) 1) - (check-equal? (sum-territory (list (territory 0 1 1 9 0) (territory 0 0 1 9 1)) 0) 1) - - ;; --------------------------------------------------------------------------------------------------- - ;; testing the AI - - (define tree0 - (game-tree (list (territory 0 1 3 0 0) - (territory 1 0 2 0 0) - (territory 2 0 2 0 0) - (territory 3 0 2 0 0)) - 1 15)) - - (define territory1 (territory 3 0 3 280 262.5)) - - (define board31 - (list territory1 - (territory 2 0 3 150 262.5) - (territory 1 1 2 345 150) - (territory 0 0 2 215 150))) - - (define world1 - (dice-world #f board31 (game board31 1 '()))) - - ;; testing the AI functions - - ;; MF: one of these two tests should fail! - (check-true (and (attackable? board31 0 territory1 1) #t)) - (check-true (no-more-moves-in-world? world1)) - - (check-equal? (interact-with-board (dice-world 3 '() '()) "d") - (dice-world #f '() '())) - - (check-equal? (game-board (the-ai-plays tree0)) - (list (territory 3 1 3 0 0) - (territory 2 0 2 0 0) - (territory 1 0 2 0 0) - (territory 0 1 2 0 0))) - - (check-equal? (game-player (the-ai-plays tree0)) - 0) - - (check-equal? (game-board (move-gt (first (game-moves tree0)))) - (list (territory 0 1 1 0 0) - (territory 1 0 2 0 0) - (territory 2 0 2 0 0) - (territory 3 1 2 0 0))) - - (check-equal? (game-player (move-gt (first (game-moves tree0)))) - 1) - - (check-equal? (rate-position tree0 AI-DEPTH) 1/2) - (check-equal? (rate-position (move-gt (first (game-moves tree0))) AI-DEPTH) - 1/2) - - "all tests run") diff --git a/thirteen/client.rkt b/thirteen/client.rkt deleted file mode 100644 index dc3b184..0000000 --- a/thirteen/client.rkt +++ /dev/null @@ -1,189 +0,0 @@ -#lang racket - -(require 2htdp/image 2htdp/universe "shared.rkt") - -(provide launch-guess-client) - -(struct client-state (type clue guess action done)) - -(define ClientState0 (client-state -1 "" #f "" #f)) - -(define SCENE-WIDTH 300) -(define SCENE-HEIGHT 200) - -(define (launch-guess-client n host) - (big-bang ClientState0 - (on-draw draw-guess) - (on-key handle-keys) - (name n) - (register host) - (on-receive handle-msg))) - -(define (handle-keys w key) - (cond [(= (client-state-type w) PLAYER) (handle-keys-player w key)] - [(= (client-state-type w) GUESSER) (handle-keys-guesser w key)] - [else w])) - -(define (handle-keys-player w key) - (define (action) - (client-state-action w)) - (define (guess) - (client-state-guess w)) - (define (set-clue clue) - (client-state PLAYER clue (guess) (action) #f)) - (cond [(and (string=? (action) "c") (key=? key "c")) - (make-package w (server-msg PLAYER "c" ""))] - [(and (string=? (action) "a") (key=? key "up")) - (make-package (set-clue "up") (server-msg PLAYER "a" "up"))] - [(and (string=? (action) "a") (key=? key "down")) - (make-package (set-clue "down") (server-msg PLAYER "a" "down"))] - [(and (string=? (action) "a") (key=? key "=")) - (make-package (set-clue "=") (server-msg PLAYER "a" "="))] - [else w])) - -(define (handle-keys-guesser w key) - (define (action) - (client-state-action w)) - (cond [(and (string=? (action) "c") (key=? key "c") - (make-package w (server-msg GUESSER "c" "")))] - [(and (string=? (action) "g") (key=? key "g") - (make-package w (server-msg GUESSER "g" "")))] - [else w])) - -(define (handle-msg c c-msg) - (cond [(not (client-msg? c-msg)) c] - [(= (client-msg-type c-msg) PLAYER) - (handle-msg-player c c-msg)] - [(= (client-msg-type c-msg) GUESSER) - (handle-msg-guesser c c-msg)] - [else c])) - -(define (handle-msg-player c c-msg) - (define (is-done) - (client-msg-done c-msg)) - (define (action) - (client-msg-action c-msg)) - (define (set-done) - (let ([guess (client-msg-guess c-msg)]) - (client-state PLAYER "" guess "" #t))) - (define (set-check) - (let ([clue (client-state-clue c)]) - (client-state PLAYER clue #f "c" #f))) - (define (set-act) - (let ([guess (client-msg-guess c-msg)]) - (client-state PLAYER "" guess "a" #f))) - (cond [(is-done) (set-done)] - [(string=? (action) "c") (set-check)] - [(string=? (action) "a") (set-act)] - [else c])) - -(define (handle-msg-guesser c c-msg) - (define (is-done) - (client-msg-done c-msg)) - (define (action) - (client-msg-action c-msg)) - (define (set-done) - (let ([guess (client-msg-guess c-msg)]) - (client-state GUESSER "" guess "" #t))) - (define (set-check) - (let ([clue (client-msg-clue c-msg)] - [guess (client-msg-guess c-msg)]) - (client-state GUESSER clue guess "c" #f))) - (define (set-guess) - (let ([clue (client-msg-clue c-msg)] - [guess (client-msg-guess c-msg)]) - (client-state GUESSER clue guess "g" #f))) - (cond [(is-done) (set-done)] - [(string=? (action) "c") (set-check)] - [(string=? (action) "g") (set-guess)] - [else c])) - -(define (draw-guess c) - (define (render type result desc help) - (place-image/align - type 5 5 "left" "top" - (overlay (above result desc help) - (empty-scene SCENE-WIDTH SCENE-HEIGHT)))) - (let ([type (draw-type c)] - [result (draw-result c)] - [desc (draw-desc c)] - [help (draw-help c)]) - (render type result desc help))) - -(define (draw-type c) - (text (cond [(= (client-state-type c) PLAYER) "Player"] - [(= (client-state-type c) GUESSER) "Guesser"] - [else "..."]) - 14 "black")) - -(define (draw-result c) - (text (cond [(= (client-state-type c) PLAYER) - (draw-result-player c)] - [else (draw-result-guesser c)]) - 14 "black")) - -(define (draw-result-player c) - (define (done) - (client-state-done c)) - (define (action) - (client-state-action c)) - (define (guess) - (number->string (client-state-guess c))) - (cond [(and (not (done)) (string=? (action) "")) "..."] - [(done) (string-append (guess) " it is!")] - [(string=? (action) "a") (string-append "Guess: " (guess))] - [else ""])) - -(define (draw-result-guesser c) - (define (done) - (client-state-done c)) - (define (action) - (client-state-action c)) - (define (guess) - (let ([g (client-state-guess c)]) - (cond [(number? g) (number->string g)] - [else ""]))) - (define (clue) - (cond [(string=? (client-state-clue c) "up") ">"] - [else "<"])) - (cond [(and (not (done)) (string=? (action) "") "...")] - [(done) (string-append (guess) " it is!")] - [(and (string=? (action) "g") (> (string-length (guess)) 0)) - (string-append "Number " (clue) " " (guess))] - [(string=? (action) "c") (string-append "Guess: " (guess))] - [else ""])) - -(define (draw-desc c) - (text (cond [(= (client-state-type c) PLAYER) ""] - [else (draw-desc-guesser c)]) - 10 "black")) - -(define (draw-desc-guesser c) - (define (action) - (client-state-action c)) - (cond [(string=? (action) "c") "Waiting for player to act on guess"] - [else ""])) - -(define (draw-help c) - (define (type) - (client-state-type c)) - (text (cond [(= (type) PLAYER) (draw-help-player c)] - [else (draw-help-guesser c)]) - 10 "black")) - -(define (draw-help-player c) - (define (action) - (client-state-action c)) - (cond [(string=? (action) "c") "Press 'c' to check"] - [(string=? (action) "a") "Press ↑, ↓, or = "] - [else ""])) - -(define (draw-help-guesser c) - (define (action) - (client-state-action c)) - (define (done) - (client-state-done c)) - (cond [(string=? (action) "g") "Press 'g' to guess"] - [(string=? (action) "c") "Press 'c' to check"] - [(done) "Good Job!"] - [else ""])) diff --git a/thirteen/run.rkt b/thirteen/run.rkt deleted file mode 100644 index b8726ac..0000000 --- a/thirteen/run.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket - -(require 2htdp/universe "client.rkt" "server.rkt") - -(define (run) - (launch-many-worlds (launch-guess-client "Adam" LOCALHOST) - (launch-guess-server) - (launch-guess-client "Eve" LOCALHOST))) - -(define (bad) - (launch-many-worlds (launch-guess-client "Adam" LOCALHOST) - (launch-guess-server) - (launch-guess-client "Beatrice" LOCALHOST))) diff --git a/thirteen/server.rkt b/thirteen/server.rkt deleted file mode 100644 index 12ff10a..0000000 --- a/thirteen/server.rkt +++ /dev/null @@ -1,149 +0,0 @@ -#lang racket - -(provide launch-guess-server) - -(require 2htdp/image 2htdp/universe "shared.rkt") - -(struct interval (small big) #:transparent) - -;; paction -> 'c' or 'a' -;; gaction -> 'c' or 'g' -(struct server-state (interval clue guess paction gaction clients done)) - -(define u0 (server-state (interval LOWER UPPER) "" #f "c" "" 1 #f)) - -(define (launch-guess-server) - (universe #f - (state #t) - (on-new connect) - (on-msg handle-msg))) - -(define (connect u client) - (cond [(false? u) - (make-bundle - u0 - (list (make-mail client (client-msg PLAYER "" #f "c" #f))) - '())] - [(= (server-state-clients u) 1) - (make-bundle - (server-state - (server-state-interval u) (server-state-clue u) - (server-state-guess u) (server-state-paction u) - "g" 2 #f) - (list (make-mail client (client-msg GUESSER "" #f "g" #f))) - '())] - [else (make-bundle u empty (list client))])) - -(define (handle-msg u client s-msg) - (cond [(not (server-msg? s-msg)) (make-bundle u empty (list client))] - [(= (server-msg-type s-msg) PLAYER) - (handle-msg-player u client s-msg)] - [(= (server-msg-type s-msg) GUESSER) - (handle-msg-guesser u client s-msg)] - [else (make-bundle u empty (list client))])) - -(define (handle-msg-player u client s-msg) - (define (set-paction paction) - (let ([interval (server-state-interval u)] - [clue (server-state-clue u)] - [guess (server-state-guess u)] - [gaction (server-state-gaction u)] - [clients (server-state-clients u)]) - (server-state interval clue guess paction gaction clients #f))) - (define (set-clue clue) - (let ([interval (server-state-interval u)] - [guess (server-state-guess u)] - [gaction (server-state-gaction u)] - [clients (server-state-clients u)] - [done (server-state-done u)]) - (server-state interval clue guess "c" gaction clients done))) - (define (set-done) - (let ([interval (server-state-interval u)] - [guess (server-state-guess u)] - [gaction (server-state-gaction u)] - [clients (server-state-clients u)]) - (server-state interval "" guess "" gaction clients #t))) - (define (mail clue guess action done) - (list (make-mail client (client-msg PLAYER clue guess action done)))) - (let* ([clue (server-state-clue u)] - [guess (server-state-guess u)] - [action (server-msg-action s-msg)] - [done (server-state-done u)] - [action-ok (string=? (server-state-paction u) action)] - [has-guess (number? guess)] - [data (server-msg-data s-msg)]) - (cond [(not action-ok) - (make-bundle u empty (list client))] - [(and (string=? action "c") (not has-guess)) - (make-bundle u (mail clue guess action done) empty)] - [(and (string=? action "c") has-guess) - (make-bundle (set-paction "a") (mail clue guess "a" done) empty)] - [(and (string=? action "a") (member data '("up" "down"))) - (make-bundle (set-clue data) (mail data #f "c" done) empty)] - [(and (string=? action "a") (string=? data "=")) - (make-bundle (set-done) (mail "" guess "" #t) empty)] - [else (make-bundle u empty (list client))]))) - -(define (handle-msg-guesser u client s-msg) - (define (set-guess interval clue guess) - (let ([paction (server-state-paction u)] - [clients (server-state-clients u)] - [done (server-state-done u)]) - (server-state interval clue guess paction "c" clients done))) - (define (set-gaction gaction) - (let ([interval (server-state-interval u)] - [clue (server-state-clue u)] - [guess (server-state-guess u)] - [paction (server-state-paction u)] - [clients (server-state-clients u)] - [done (server-state-done u)]) - (server-state interval clue guess paction gaction clients done))) - (define (has-clue) - (> (string-length (server-state-clue u)) 0)) - (define (is-done) - (server-state-done u)) - (define (mail clue guess action done) - (list (make-mail client - (client-msg GUESSER clue guess action done)))) - (let* ([action (server-msg-action s-msg)] - [interval (server-state-interval u)] - [clue (server-state-clue u)] - [current-guess (server-state-guess u)] - [done (server-state-done u)] - [action-ok (string=? (server-state-gaction u) action)]) - (cond [(not action-ok) (make-bundle u empty (list client))] - [(is-done) - (make-bundle (set-gaction "") - (mail "" current-guess "" #t) empty)] - [(and (string=? action "g") (not (has-clue))) - (let ([guess (guess interval)]) - (make-bundle (set-guess interval "" guess) - (mail "" guess "c" done) empty))] - [(and (string=? action "g") (has-clue)) - (let* ([n-interval (next-interval interval clue)] - [guess (guess n-interval)]) - (make-bundle (set-guess n-interval "" guess) - (mail "" guess "c" done) empty))] - [(and (string=? action "c") (has-clue)) - (make-bundle (set-gaction "g") - (mail clue current-guess "g" done) empty)] - [else (make-bundle u (mail clue current-guess action done) - empty)]))) - -(define (next-interval interval clue) - (cond [(not (string? clue)) interval] - [(string=? "up" clue) (bigger interval)] - [(string=? "down" clue) (smaller interval)] - [else interval])) - -(define (single? w) - (= (interval-small w) (interval-big w))) - -(define (guess w) - (quotient (+ (interval-small w) (interval-big w)) 2)) - -(define (smaller w) - (interval (interval-small w) (max (interval-small w) (sub1 (guess w))))) - -(define (bigger w) - (interval (min (interval-big w) (add1 (guess w))) (interval-big w))) diff --git a/thirteen/shared.rkt b/thirteen/shared.rkt deleted file mode 100644 index 176c429..0000000 --- a/thirteen/shared.rkt +++ /dev/null @@ -1,28 +0,0 @@ -#lang racket - -(provide - UPPER - LOWER - PLAYER - GUESSER - client-msg - client-msg? - client-msg-type - client-msg-clue - client-msg-guess - client-msg-action - client-msg-done - server-msg - server-msg? - server-msg-type - server-msg-action - server-msg-data) - -(define UPPER 100) -(define LOWER 0) - -(define PLAYER 0) -(define GUESSER 1) - -(struct client-msg (type clue guess action done) #:prefab) -(struct server-msg (type action data) #:prefab) diff --git a/twelve/graphics/dice1.png b/twelve/graphics/dice1.png deleted file mode 100644 index 3f4899c..0000000 Binary files a/twelve/graphics/dice1.png and /dev/null differ diff --git a/twelve/graphics/dice2.png b/twelve/graphics/dice2.png deleted file mode 100644 index 2fa32ea..0000000 Binary files a/twelve/graphics/dice2.png and /dev/null differ diff --git a/twelve/graphics/dice3.png b/twelve/graphics/dice3.png deleted file mode 100644 index 005ee75..0000000 Binary files a/twelve/graphics/dice3.png and /dev/null differ diff --git a/twelve/graphics/dice4.png b/twelve/graphics/dice4.png deleted file mode 100644 index 47bb291..0000000 Binary files a/twelve/graphics/dice4.png and /dev/null differ diff --git a/twelve/source.rkt b/twelve/source.rkt deleted file mode 100644 index dc37e87..0000000 --- a/twelve/source.rkt +++ /dev/null @@ -1,1240 +0,0 @@ -#lang racket - -#| - The Dice of Doom game, the eager version - ---------------------------------------- - - The Dice of Doom game is a turn-based game for two players sharing one keyboard. - Since this implementation employs an eager strategy to build the complete game - tree of all possible moves, it is only a step in the right direction. - - Each player owns hexagonal territories, which are arranged into a planar game - board. A territory comes with a number of dice. When it is a player's turn, - she marks one of her territories as a launching pad for an attack at a - neigboring territory of the other player. Such an attack is enabled only if - her chosen territory has more dice than the territory of the other player. - The effect of the attack is that the territory changes ownership and that all - but one of the attack dice are moved to the newly conquered territory. A - player may continue her turn as long as she can launch attacks. Optionally, - she may choose to pass after her first attack is executed, meaning she ends - her turn. At the end of a turn, a number of dices are distributed across the - players' territories. The game is over when a player whose turn it is cannot - attack on her first move. - - A player can use the following five keys to play the game: - -- with ← and → (arrow keys), the player changes the territory focus - -- with enter, the player marks a territory the launching pad for an attack - -- with the "d" key, the player unmarks a territory - -- with the "p" key the player passes. - Once a player passes, the game announces whose turn it is next. - - Play - ---- - - Run and evaluate - (roll-the-dice) - This will pop up a window that the game board, and instructions. -|# - -(require 2htdp/image (except-in 2htdp/universe left right)) - -; -; -; -; -; ;;;; ; ;;; ;;; ;; ;; -; ; ; ; ; ; ; -; ; ; ;;; ;;; ; ;;;; ; ; ;;;; ;; ;;; ; ;;; ; -; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; -; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; -; ;;;; ;;;;; ;;;; ;;;;; ; ; ;;;; ;;;;; ;;;;; ;;; ;; -; -; -; -; - -;; --------------------------------------------------------------------------------------------------- -;; Data - -(struct dice-world (src board gt) #:transparent) -;; DiceWorld = (dice-world (U #false Natural) Board GameTree) -;; in (dice-world i b gt) -;; -- if i is a Natural, it is an index for the territory that the player has marked for an attack -;; -- if i is #f, no territory has been marked yet -;; b is the current board -;; gt is the game-tree for the given i and b - -(define-values (game game? game-board game-player game-moves) - (let () - (struct game (board player delayed-moves)) - (values game - game? - game-board - game-player - (lambda (g) (force (game-delayed-moves g)))))) -;; GameTree = (game Board Player [Listof Move]) -;; in (game-tree b p lm) -;; -- b is the current board -;; -- p is the current player -;; -- lm is the list of moves that that player may execute - -;; Board = [List-of Territory] -;; the first field in the list is the currently marked territory - -;; Player ∈ [0, PLAYER#) | Natural - -(struct move (action gt) #:transparent) -;; Move = (move Action GameTree) -;; in (move a gt) -;; -- a represents the actione to be takem -;; -- gt is the game-tree resulting from that action - -;; Action is one of: -;; -- '() a passing move -;; -- (list Natural Natural) the move where the first attacks the second - -(struct territory (index player dice x y) #:transparent) -;; Territory = (territory Natural Player Dice Integer Integer) -;; in (territory i p d x y) -;; -- i is a unique identifier for the territory; it also determines its initial location -;; -- p is the player who owns this territory -;; -- d is the number of dice on this board -;; -- x is the x coordiate of this territory in pixels -;; -- y is the y coordiate of this territory in pixels - -;; Territory Natural -> Territory -;; updates number of dice on territory -(define (territory-set-dice t d) - (territory (territory-index t) (territory-player t) d (territory-x t) (territory-y t))) - -;; Territory Player -> Territory -;; updates owner of territory -(define (territory-set-player t p) - (territory (territory-index t) p (territory-dice t) (territory-x t) (territory-y t))) - -;; --------------------------------------------------------------------------------------------------- -;; sample game tree for BOOK - -(define b1 - (list (territory 1 0 1 'a 'b) - (territory 0 0 1 'x 'y))) - -(define b1-alternative - (list (territory 0 0 1 'x 'y) - (territory 1 0 1 'a 'b))) - -(define b3 - (list (territory 0 0 2 'x 'y) - (territory 1 1 1 'a 'b))) - -(define gt1 (game b1 1 '())) - -(define mv2 (move '() gt1)) - -(define gt2 (game b1-alternative 0 (list mv2))) - -(define mv3 (move '(0 1) gt2)) - -(define gt3 (game b3 0 (list mv3))) - -;; --------------------------------------------------------------------------------------------------- -;; Constants - -; initalization constants -(define PLAYER# 2) -(define DICE# 3) -(define BOARD 3) -(define GRID (* BOARD BOARD)) -(define INIT-PLAYER 0) -(define INIT-SPARE-DICE 10) -; The depth at which to limit the gametree -(define AI-DEPTH 4) -(define AI 1) - -; graphical constants: territories -(define DICE-OFFSET 6) -(define SIDE 75) -(define OFFSET0 (* 2 SIDE)) -(define ROTATION 30) -(define HEX 6) -(define (hexagon color) - (rotate ROTATION (regular-polygon SIDE HEX "solid" color))) -(define X-OFFSET (image-width (hexagon "black"))) -(define Y-OFFSET (* (image-height (hexagon "black")) 3/4)) - -; graphical constants -(define COLORS - (list (make-color 255 0 0 100) - (make-color 0 255 0 100) - (make-color 0 0 255 100))) -(define FOCUS (rotate ROTATION (regular-polygon SIDE 6 "outline" "black"))) -(define D1 (bitmap "graphics/dice1.png")) -(define D2 (bitmap "graphics/dice2.png")) -(define D3 (bitmap "graphics/dice3.png")) -(define D4 (bitmap "graphics/dice4.png")) -(define IMG-LIST (list D1 D2 D3 D4)) - -(define TEXT-SIZE 25) -(define TEXT-COLOR "black") -(define INSTRUCT - "← and → to move among territories, to mark, to unmark, and

to pass") -(define AI-INSTRUCT - "press any key to let the AI play") -(define AI-TURN "It's the Mighty AI's turn") -(define YOUR-TURN "It's your turn") -(define INFO-X-OFFSET 180) -(define INFO-Y-OFFSET 50) - -(define INSTRUCTIONS (text INSTRUCT TEXT-SIZE TEXT-COLOR)) -(define AI-INSTRUCTIONS (text AI-INSTRUCT TEXT-SIZE TEXT-COLOR)) -(define WIDTH (+ (image-width INSTRUCTIONS) 50)) -(define HEIGHT 600) -(define (PLAIN) - (define iw (image-width INSTRUCTIONS)) - (define bw (* SIDE 2 BOARD)) - (set! WIDTH (+ (max iw bw) 50)) - (set! HEIGHT (+ (* SIDE 2 BOARD) 50)) - (empty-scene WIDTH HEIGHT)) -(define (ISCENE w) - (define mt (PLAIN)) - (when (or (> (image-width mt) 1280) (> (image-height mt) 800)) - (error 'scene "it is impossible to draw a ~s x ~s game scene for a 1280 x 800 laptop screen" (image-width mt) (image-height mt))) - (place-image - (if (= (game-player (dice-world-gt w)) AI) - AI-INSTRUCTIONS - INSTRUCTIONS) - (* .5 WIDTH) (* .9 HEIGHT) mt)) - -; -; -; -; -; ;;; ;;; ; -; ;; ;; -; ;; ;; ;;;; ;;; ;; ;; -; ; ; ; ; ; ; ;; ; -; ; ; ; ;;;;; ; ; ; -; ; ; ; ; ; ; ; -; ; ; ; ;; ; ; ; -; ;;; ;;; ;;; ;; ;;;;; ;;; ;;; -; -; -; -; - -;; --------------------------------------------------------------------------------------------------- - -;; start the game -(define (roll-the-dice) - (big-bang (create-world-of-dice-and-doom) - (on-key interact-with-board) - (to-draw draw-dice-world) - (stop-when no-more-moves-in-world? - draw-end-of-dice-world))) - -;; -> DiceWorld -;; Returns a randomly generated world. If the world that -;; has been generated starts as a tie, the world is regenerated. -;; property: world is not in endgame state (no-more-moves? returns false) -(define (create-world-of-dice-and-doom) - (define board (territory-build)) - (define gamet (game-tree board INIT-PLAYER INIT-SPARE-DICE)) - (define new-world (dice-world #f board gamet)) - (if (no-more-moves-in-world? new-world) - (create-world-of-dice-and-doom) - new-world)) - -;; DiceWorld Key -> DiceWorld -;; Handles key events from a player -(define (interact-with-board w k) - (cond [(= (game-player (dice-world-gt w)) AI) - (ai-step-through w)] - [(key=? "left" k) - (refocus-board w left)] - [(key=? "right" k) - (refocus-board w right)] - [(key=? "p" k) - (pass w)] - [(key=? "\r" k) - (mark w)] - [(key=? "d" k) - (unmark w)] - [else w])) - -;; Diceworld -> Scene -;; draws the world -(define (draw-dice-world w) - (add-player-info - (game-player (dice-world-gt w)) - (add-winning-probability w (add-board-to-scene w (ISCENE w))))) - -;; DiceWorld -> Boolean -;; is it possible to play any moves from this world state? -(define (no-more-moves-in-world? w) - (define tree (dice-world-gt w)) - (define board (dice-world-board w)) - (define player (game-player tree)) - (or (no-more-moves? tree) - (for/and ((t board)) (= (territory-player t) player)))) - -;; DiceWorld -> Image -;; render the endgame screen -(define (draw-end-of-dice-world w) - (define board (dice-world-board w)) - (define message (text (won board) TEXT-SIZE TEXT-COLOR)) - (define background (add-board-to-scene w (PLAIN))) - (overlay message background)) - -;; Board -> String -;; Which player has won the game -- eager is for N human players -(define (won board) - (define-values (best-score w) (winners board)) - (cond [(cons? (rest w)) "It's a tie."] - [(= (car w) AI) "AI won."] - [else "You won."])) - -; -; -; -; -; ;;;;; ; -; ; ; -; ; ;; ;; ;;; ;;;;; -; ; ;; ; ; ; -; ; ; ; ; ; -; ; ; ; ; ; -; ; ; ; ; ; ; -; ;;;;; ;;; ;;; ;;;;; ;;; -; -; -; -; - -;; --------------------------------------------------------------------------------------------------- -;; Making A Board - -;; -> Board -;; Creates a list of territories the size of GRID with given x and y coordinates -;; properties: dice is (0,MAX-DICE] -;; returns list of size GRID -(define (territory-build) - (for/list ([n (in-range GRID)]) - (territory n (modulo n PLAYER#) (dice) (get-x n) (get-y n)))) - -;; -> Natural -;; the number of initial die on a territory -(define (dice) - (add1 (random DICE#))) - -;; Natural -> Number -;; the x coordinate for territory n of a board -(define (get-x n) - (+ OFFSET0 - (if (odd? (get-row n)) 0 (/ X-OFFSET 2)) - (* X-OFFSET (modulo n BOARD)))) - -;; Natural -> Number -;; the y coordinate for territory n of a board -(define (get-y n) - (+ OFFSET0 (* Y-OFFSET (get-row n)))) - -;; --------------------------------------------------------------------------------------------------- -;; Making a Game Tree - -;; Board Player Natural -> GameTree -;; creates a complete game-tree from the given board, player, and spare dice -(define (game-tree board player dice) - ;; create tree of attacks from this position; add passing move - (define (attacks board) - (for*/list ([src board] - [dst (neighbors (territory-index src))] - #:when (attackable? board player src dst)) - (define from (territory-index src)) - (define dice (territory-dice src)) - (define newb (execute board player from dst dice)) - (define attacks-from-newb - (game newb player (delay (cons (passes newb) (attacks newb))))) - (move (list from dst) attacks-from-newb))) - ;; create a passing move , distribute dice, continue - (define (passes board) - (define-values (new-dice newb) (distribute board player dice)) - (move '() (game-tree newb (switch player) new-dice))) - ;; -- START: -- - (game board player (delay (attacks board)))) - -;; Player -> Player -;; switches from one player to the next -(define (switch player) - (modulo (+ player 1) PLAYER#)) - -;; Board Player Natural -> Natural Board -;; adds reinforcements to the game board -;; > (add-new-dice (list (territory 0 2 2 9 0)) 2 2)) -;; (list (territory 0 2 2 9 0)) -(define (distribute board player spare-dice) - (for/fold ([dice spare-dice] [new-board '()]) ([t board]) - (if (and (= (territory-player t) player) - (< (territory-dice t) DICE#) - (not (zero? dice))) - (values (- dice 1) (cons (add-dice-to t) new-board)) - (values dice (cons t new-board))))) - -;; Territory -> Territory -;; adds one dice to the given territory -(define (add-dice-to t) - (territory-set-dice t (add1 (territory-dice t)))) - -;; Board Player Territory Natural -> Boolean -;; can player attack dst from src? -(define (attackable? board player src dst) - (define dst-t - (findf (lambda (t) (= (territory-index t) dst)) board)) - (and dst-t - (= (territory-player src) player) - (not (= (territory-player dst-t) player)) - (> (territory-dice src) (territory-dice dst-t)))) - -;; Board Natural Natural Natural Natural -> Board -;; Creates a new board after an attack -;; updates only src and dst -(define (execute board player src dst dice) - (for/list ([t board]) - (define idx (territory-index t)) - (cond [(= idx src) (territory-set-dice t 1)] - [(= idx dst) - (define s (territory-set-dice t (- dice 1))) - (territory-set-player s player)] - [else t]))) - -;; --------------------------------------------------------------------------------------------------- -;; Getting Neigbors - -;; Natural -> [List-of Natural] -;; returns the neighbors of the current spot -;; > (neighbors 0) -;; '(1 2 3) -(define (neighbors pos) - (define top? (< pos BOARD)) - (define bottom? (= (get-row pos) (sub1 BOARD))) - (define even-row? (zero? (modulo (get-row pos) 2))) - (define right? (zero? (modulo (add1 pos) BOARD))) - (define left? (zero? (modulo pos BOARD))) - (if even-row? - (even-row pos top? bottom? right? left?) - (odd-row pos top? bottom? right? left?))) - -;; Natural Boolean Boolean Boolean Boolean -> [Listof Naturals] -;; gets the neighbors for a territory on an even row -(define (even-row pos top? bottom? right? left?) - (append (add (or top? right?) (add1 (- pos BOARD))) - (add (or bottom? right?) (add1 (+ pos BOARD))) - (add top? (- pos BOARD)) - (add bottom? (+ pos BOARD)) - (add right? (add1 pos)) - (add left? (sub1 pos)))) - -;; Natural Boolean Boolean Boolean Boolean -> [Listof Naturals] -;; gets the neighbors for a territory on an odd row -(define (odd-row pos top? bottom? right? left?) - (append (add top? (- pos BOARD)) - (add bottom? (+ pos BOARD)) - (add (or top? left?) (sub1 (- pos BOARD))) - (add (or bottom? left?) (sub1 (+ pos BOARD))) - (add right? (add1 pos)) - (add left? (sub1 pos)))) - -;; Boolean X -> [Listof X] -;; returns (list x) if (not b) else empty -(define (add b x) - (if b '() (list x))) - -; -; -; -; -; ;;; ;;; ;;;;;; -; ; ; ; ; ; -; ; ; ;;;; ;;; ;;; ; ; ;;; ;;; ;;;; ;; ;; ;;;;; ;;;;; -; ; ; ; ; ; ; ;;; ; ; ; ; ;; ; ; ; ; -; ;;; ;;;;;; ; ; ; ; ; ; ;;;;;; ; ; ; ;;;; -; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; -; ;;; ;; ;;;;; ; ;;;;;; ;; ;;;;; ;;; ;;; ;;; ;;;;; -; ; -; ;;; -; -; - -;; --------------------------------------------------------------------------------------------------- -;; Territory Focusing and Marking - -;; DiceWorld [Board -> Board] -> World -;; Creates a new World that has a rotated territory list -;; > (define lterritory (territory 0 0 1 9 2)) -;; > (define rterritory (territory 0 0 1 9 0)) -;; > (refocus-board-action (dice-world -1 (list rterritory lterritory ...) GT) left) -;; (dice-world -1 (list lterritory ... rterritory) GT) -;; > (refocus-board-action (dice-world -1 (list lterritory ... rterritory) GT) left) -;; (dice-world -1 (list rterritory lterritory ...) GT) -(define (refocus-board w direction) - (define source (dice-world-src w)) - (define board (dice-world-board w)) - (define tree (dice-world-gt w)) - (define player (game-player tree)) - (define (owner? tid) - (if source (not (= tid player)) (= tid player))) - (define new-board (rotate-until owner? board direction)) - (dice-world source new-board tree)) - -;; [Player -> Boolean] Board (Board -> Board) -> Board -;; rotate until the first element of the list satisfies owned-by -(define (rotate-until owned-by board rotate) - (define next-list (rotate board)) - (if (owned-by (territory-player (first next-list))) - next-list - (rotate-until owned-by next-list rotate))) - -;; Board -> Board -;; rotate a list to the left -(define (left l) - (append (rest l) (list (first l)))) - -;; Board -> Board -;; rotate a list to the right -(define (right l) - (reverse (left (reverse l)))) - -;; --------------------------------------------------------------------------------------------------- -;; Handling Moves - -;; DiceWorld -> DiceWorld -;; executes a passing move on the world state -;; THIS DEFINITION IS NOT USED FOR THE ABSTRACT VERSION OF THE MODULE. -(define (pass.10 w) - (define m (find-move (game-moves (dice-world-gt w)) '())) - (cond [(not m) w] - [else ;; (no-more-moves? m) - (dice-world #f (game-board m) m)])) - -;; DiceWorld -> DiceWorld -;; unmarks a marked territory -(define (unmark w) - (dice-world #f (dice-world-board w) (dice-world-gt w))) - -;; DiceWorld -> DiceWorld -;; marks a territory as the launching pad for an attack or launches the attack -(define (mark w) - (define tree (dice-world-gt w)) - (define board (dice-world-board w)) - (define source (dice-world-src w)) - (define focus (territory-index (first board))) - (if source - (attacking w source focus) - (dice-world focus board tree))) - -;; DiceWorld Natural Natural -> DiceWorld -(define (attacking w source target) - (define feasible (game-moves (dice-world-gt w))) - (define attack (list source target)) - (define next (find-move feasible attack)) - (define src-t (findf (lambda (t) (= (territory-index t) source)) - (dice-world-board w))) - (define dst-t (findf (lambda (t) (= (territory-index t) target)) - (dice-world-board w))) - (define win? (dice-attack-win src-t dst-t)) - (cond [(not next) w] - [win? (dice-world #f (game-board next) next)] - [else (dice-world-attack-lost w src-t)])) - -;; [List-of Moves] [or '() [List Natural Natural]] -> [or #f Game-tree] -;; find the move from the current list of moves -(define (find-move moves a) - (define m (findf (lambda (m) (equal? (move-action m) a)) moves)) - (and m (move-gt m))) - -;; Game -> Boolean -;; are there any moves in this game record? -(define (no-more-moves? g) - (empty? (game-moves g))) - -;; Territory Territory -> Boolean -;; attack from src territory to destination territory -;; and see who wins -(define (dice-attack-win src-t dst-t) - (define (roll-dice n) - (for/list ([i n]) - (random 1 7))) - (define (sum l) - (foldl + 0 l)) - (define src-attack (sum (roll-dice (territory-dice src-t)))) - (define dst-defend (sum (roll-dice (territory-dice dst-t)))) - (if (> src-attack dst-defend) #t #f)) - - -(define (probability-of-winning st dt) - "Find the probability of source territory defeating destination territory. - - `st` is the source territory. - `dt` is the destination territory." - - ; Given the number of dice, returns a list all dice combinations. - (define (dice-all-combination dice-num) - (cond [(= dice-num 1) - (for/list ([i (in-range 1 7)]) - (list i))] - [else - (for*/list ([i (in-range 1 7)] - [r (dice-all-combination - (- dice-num 1))]) - (cons i r))])) - - - ; Given a list of dice combinations, returns a hashmap where the key - ; is the 'dice sum' and the value is the number of combinations - ; whose sum is the 'dice sum'. - (define (dice-sum-hash dice-combinations) - (for/foldr - ([h (make-hash)]) ([c dice-combinations]) - (let ((sum (for/sum ([n c]) n))) - (hash-set! h sum (+ (hash-ref h sum 0) 1)) - h))) - - - ; sh: -> hashmap - ; key: dice sum, - ; value: number of ways we can arrive at sum - (define sh (dice-sum-hash - (dice-all-combination (territory-dice st)))) - - ; dh: -> hashmap - ; key: dice sum, - ; value: number of ways we can arrive at sum - (define dh (dice-sum-hash - (dice-all-combination (territory-dice dt)))) - - ; Generic probability function. - (define (probability f t) - (/ (* 1.0 f) t)) - - ; Computes the total number of favorable outcomes for the source - ; territory when its dice sum is `s-ds` against the - ; destination's territory. - ; - ; s-ds -> source dice sum. - ; n -> number of we can arrive at sum `s-ds`. - (define (favorable-outcomes s-ds n) - (* (for/sum [(d-ds (hash-keys dh))] - (if (< d-ds s-ds) - (hash-ref dh d-ds) - 0)) - n)) - - ; Computes the total number of favorable outcomes for the source - ; territory against the destination's territory. - (define (all-favorable-outcomes) - (foldr + 0 - (for/list [(s-ds (hash-keys sh))] - (favorable-outcomes - s-ds - (hash-ref sh s-ds))))) - - (define (all-outcomes) - (let ((sd (territory-dice st)) - (dd (territory-dice dt))) - (* (expt 6 sd) (expt 6 dd)))) - - (probability (all-favorable-outcomes) (all-outcomes))) - - -;; DiceWorld Territory -> DiceWorld -;; generate dice world for the case where player -;; loses the dice attack -(define (dice-world-attack-lost w src-t) - (define src (territory-index src-t)) - (define player (territory-player src-t)) - (define newb (for/list ([t (dice-world-board w)]) - (define idx (territory-index t)) - (cond [(= idx src) (territory-set-dice t 1)] - [else t]))) - (define new-gt (game-tree newb player 0)) - (dice-world #f newb new-gt)) - -; -; -; -; -; ;;;;; ;; ; -; ; ; ; -; ; ; ;;;; ;; ;; ;;; ; ;;;; ;; ;;; ;;; ;; ;; ;;; ;; -; ; ; ; ; ;; ; ; ;; ; ; ;; ; ;; ; ; ;; -; ;;;; ;;;;;; ; ; ; ; ;;;;;; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; -; ;;; ; ;;;;; ;;; ;;; ;;; ;; ;;;;; ;;;;; ;;;;; ;;; ;;; ;;; ; -; ; -; ;;;; -; -; - -;; Player Scene-> Scene -;; Draws the world -(define (add-player-info player s) - (define str (whose-turn player)) - (define txt (text str TEXT-SIZE TEXT-COLOR)) - (place-image txt (- WIDTH INFO-X-OFFSET) INFO-Y-OFFSET s)) - -(define (add-winning-probability w s) - (define board (dice-world-board w)) - (define source (dice-world-src w)) - (define target (territory-index (first board))) - (define feasible (game-moves (dice-world-gt w))) - (define attack (list source target)) - (define next (find-move feasible attack)) - - (define (find-territory index) - (findf (lambda (t) (= (territory-index t) index)) - (dice-world-board w))) - - (if (and source next) - (place-image - (text (string-append - "Winning Probability " - (~r - (probability-of-winning (find-territory source) - (find-territory target)) - #:precision 2)) - TEXT-SIZE TEXT-COLOR) - (- WIDTH 170) 100 s) - s)) - -;; DiceWorld Scene -> Scene -;; folds through the board and creates an image representation of it -(define (add-board-to-scene w s) - (define board (dice-world-board w)) - (define player (game-player (dice-world-gt w))) - (define focus? (dice-world-src w)) - (define trtry1 (first board)) - (define p-focus (territory-player trtry1)) - (define t-image (draw-territory trtry1)) - (define image (draw-focus focus? p-focus player t-image)) - (define base-s (add-territory trtry1 image s)) - (for/fold ([s base-s]) ([t (rest board)]) - (add-territory t (draw-territory t) s))) - -;; Nat Player Player Image -> Image -;; add focus marker to territory if needed -(define (draw-focus marked? p-in-focus p t-image) - (if (or (and (not marked?) (= p-in-focus p)) - (and marked? (not (= p-in-focus p)))) - (overlay FOCUS t-image) - t-image)) - -;; Image Territory Image -> Image -(define (add-territory t image scene) - (place-image image (territory-x t) (territory-y t) scene)) - -;; Territory -> Image -;; renders a single territory -(define (draw-territory t) - (define color (color-chooser (territory-player t))) - (overlay (hexagon color) (draw-dice (territory-dice t)))) - -;; Natural -> Image -;; renders all n >= 1 dice as a stack of dice -(define (draw-dice n) - (define first-die (get-dice-image 0)) - (define height-die (image-height first-die)) - (for/fold ([s first-die]) ([i (- n 1)]) - (define dice-image (get-dice-image (+ i 1))) - (define y-offset (* height-die (+ .5 (* i .25)))) - (overlay/offset s 0 y-offset dice-image))) - -;; Player -> Color -;; Determines a color for each player -(define (color-chooser p) - (list-ref COLORS p)) - -;; -> Image -;; returns an image from the list of dice images -(define (get-dice-image i) - (list-ref IMG-LIST (modulo i (length IMG-LIST)))) - -; -; -; -; -; ;;;;;; ;; ; -; ; ; ; -; ; ; ;; ;; ;;; ; ;;; ;; ;; ;;; ;; -; ;;; ;; ; ; ;; ; ;; ; ; ;; -; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ;; ; ; ; ; ;; -; ;;;;;; ;;; ;;; ;;; ;; ;;;;; ;;; ;;; ;;; ; -; ; -; ;;;; -; -; - -;; Board ->* Natural [non-empty-listof Player] -;; gives the number of winning territories and the players(s) who have them -;; > (winners (list (territory 0 0 1 9 0) (territory 0 0 1 9 1))) -;; (values 2 '(0)) -;; > (winners (list (territory 0 1 1 9 0) (territory 0 0 1 9 1))) -;; (values 1 '(0 1)) -(define (winners board) - (for/fold ([best 0][winners '()]) ([p PLAYER#]) - (define p-score (sum-territory board p)) - (cond [(> p-score best) (values p-score (list p))] - [(< p-score best) (values best winners)] - [(= p-score best) (values best (cons p winners))]))) - -;; Board Player -> Natural -;; counts the number of territorys the player owns -;; > (sum-territory (list (territory 0 1 1 9 0) (territory 0 1 1 9 1)) 1) -;; 2 -(define (sum-territory board player) - (for/fold ([result 0]) ([t board]) - (if (= (territory-player t) player) (+ result 1) result))) - - -; -; -; -; -; -; ;;; ;;;;;;; -; ;; ; -; ; ; ; -; ; ; ; -; ; ; ; -; ;;;;;; ; -; ; ; ; -; ; ; ; -; ;;; ;;; ;;;;;;; -; -; -; -; - -;; Player -> {AI-TURN, YOUR-TURN} -;; THIS REQUIRES A DIFFERENT DEFINITION FOR PLAIN CHAPTER 10. -(define (whose-turn player) - (if (= player AI) AI-TURN YOUR-TURN)) - -;; DiceWorld -> DiceWorld -;; executes a passing move on the world state -;; THIS REQUIRES A DIFFERENT DEFINITION FOR PLAIN CHAPTER 10. -(define (pass w) - (define m (find-move (game-moves (dice-world-gt w)) '())) - (cond [(not m) w] - [(or (no-more-moves? m) (not (= (game-player m) AI))) - (dice-world #f (game-board m) m)] - [else - (define ai (the-ai-plays m)) - (dice-world #f (game-board ai) ai)])) - -;; GameTree -> GameTree -;; Computer calls this function until it is no longer the player -(define (the-ai-plays tree) - (define ratings (rate-moves tree AI-DEPTH)) - (define the-move (first (argmax second ratings))) - (define new-tree (move-gt the-move)) - new-tree) - -;; DiceWold -> DiceWorld -;; Executes AI's turn. -(define (ai-step-through w) - (define new-gt (the-ai-plays (dice-world-gt w))) - (dice-world #f (game-board new-gt) new-gt)) - -;; GameTree Natural -> [List-of (List Move Number)] -;; assigns a value to each move that is being considered -;; and return those values in a list -(define (rate-moves tree depth) - (for/list ((move (game-moves tree))) - (list move (rate-position (move-gt move) (- depth 1))))) - -;; GameTree Natural -> Number -;; Returns a number that is the best move for the given player. -(define (rate-position tree depth) - (cond [(or (= depth 0) (no-more-moves? tree)) - (define-values (best w) (winners (game-board tree))) - (if (member AI w) (/ 1 (length w)) 0)] - [else - (define ratings (rate-moves tree depth)) - (apply (if (= (game-player tree) AI) max min) - (map second ratings))])) - -; -; -; -; -; ;; -; ; -; ; ; ;; ;; ;; ;; ;;;;; -; ; ; ; ; ; ; ; ; -; ; ; ; ; ;; ;;;; -; ;;; ; ; ;; ; -; ; ; ; ;; ; ; ; ; -; ;;; ;;; ;; ;; ;; ;; ;;;;; -; -; -; -; - -;; Natural -> Natural -;; gets the row that territory is on, indexed from 0 -;; [test vary on current board-size] -(define (get-row pos) - (quotient pos BOARD)) - - -; -; -; -; -; -; ;;;;;;; ; -; ; ; ; ; -; ; ; ; ;;; ;;;; ; ;;;;;; ;;;; ; -; ; ; ; ; ; ; ;; ; ; ;; -; ; ; ; ; ; ; -; ; ;;;;;;; ;;;;; ; ;;;;; -; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; -; ;;;;; ;;;; ;;;;;; ;;;; ;;;;;; -; -; -; -; - -;; --------------------------------------------------------------------------------------------------- - -;; Natural -> Void -;; make the board larger -(define (set-grid n) - (set! BOARD n) - (set! GRID (* n n))) - -(module+ test - - (require rackunit rackunit/text-ui) - - ;; (-> any) -> void - ;; runs the thunk PROP-NUM times - (define (check-property t) - (test-begin (for ((i 50)) (t)))) - - ;; Properties - (define (property:starting-world-playable) - (unless (and (= BOARD 2) (= PLAYER# 2)) - (error 'starting-world-playable "BOARD-SIZE != 2 or PLAYERS# != 2")) - (check-false (no-more-moves-in-world? (create-world-of-dice-and-doom)))) - - (define (property:dice-in-range) - (check-true (andmap (λ (b) (>= DICE# (territory-dice b) 1)) (territory-build)) - "dice out of range")) - - (define (property:board-correct-size) - (check-equal? (length (territory-build)) GRID - "board incorrect-size")) - - (define (property:no-pass-on-first-move) - (define (move-action? m) (equal? (move-action m) '())) - (check-true (not (memf move-action? (game-moves (game-tree (territory-build) 0 0)))) - "no pass on first move")) - - ;; --------------------------------------------------------------------------------------------------- - - - ;; testing game initialization - - (check-equal? (territory-index (first (territory-build))) 0) - (check-equal? (territory-player (first (territory-build))) 0) - (check-equal? (territory-index (second (territory-build))) 1) - (check-equal? (territory-player (second (territory-build))) 1) - (check-equal? (territory-index (third (territory-build))) 2) - (check-equal? (territory-player (third (territory-build))) 0) - (check-equal? (territory-index (fourth (territory-build))) 3) - (check-equal? (territory-player (fourth (territory-build))) 1) - - (check-property property:starting-world-playable) - (check-property property:board-correct-size) - (check-property property:dice-in-range) - (check-property property:no-pass-on-first-move) - - ;; --------------------------------------------------------------------------------------------------- - ;; testing territory manipulation - - ;; legal? - (check-true - (and (attackable? (list (territory 0 0 2 9 0) (territory 3 1 1 9 0)) 0 (territory 0 0 2 9 0) 3) #t)) - (check-false - (attackable? (list (territory 0 0 2 9 0) (territory 3 1 1 9 0)) 0 (territory 0 0 2 9 0) 0)) - (check-false - (attackable? (list (territory 0 0 2 9 0) (territory 5 1 1 9 0)) 1 (territory 0 0 2 9 0) 5)) - - ;; get-row - (check-equal? (get-row 0) 0) - (check-equal? (get-row 1) 0) - (check-equal? (get-row 2) 1) - (check-equal? (get-row 3) 1) - (check-equal? (get-row 12) 6) ;; checks math. actually invalid on board of size 2 - (check-equal? (get-row 11) 5) ;; checks math. actually invalid on board of size 2 - (check-equal? (get-row 13) 6) ;; checks math. actually invalid on board of size 2 - (check-equal? (get-row 14) 7) ;; checks math. actually invalid on board of size 2 - - ;; --------------------------------------------------------------------------------------------------- - (define board3 - (list (territory 0 1 1 9 0) (territory 1 1 1 8 0) (territory 2 1 3 43.5 5) (territory 3 1 1 6 5))) - (define b1+0+3 - (list (territory 0 0 2 9 0) (territory 1 1 1 8 0) (territory 2 0 2 43.5 5) (territory 3 1 1 6 5))) - (define b2+1+2 - (list (territory 0 0 1 9 0) (territory 1 1 3 8 0) (territory 2 0 2 43.5 5) (territory 3 1 2 6 5))) - (define board6 - (list (territory 0 0 1 9 0) (territory 1 1 2 8 0) (territory 2 0 3 43.5 5) (territory 3 1 2 6 5))) - (define bard6+ - (list (territory 0 0 1 9 0) (territory 1 1 2 8 0) (territory 2 0 3 43.5 5) (territory 3 1 2 6 5))) - - (define (distribute/list a b c) - (define-values (x y) (distribute a b c)) - (list x y)) - - (define board0 - (list (territory 0 0 1 9 0) (territory 1 1 2 8 0) (territory 2 0 2 43.5 5) (territory 3 1 1 6 5))) - (define board1 - (list (territory 0 0 1 9 0) (territory 1 1 1 8 0) (territory 2 0 1 43.5 5) (territory 3 1 1 6 5))) - (define b1+1+2 - (list (territory 0 0 1 9 0) (territory 1 1 2 8 0) (territory 2 0 1 43.5 5) (territory 3 1 2 6 5))) - (define board2 - (list (territory 0 0 1 9 0) (territory 1 1 1 8 0) (territory 2 0 3 43.5 5) (territory 3 1 1 6 5))) - - (define g-tree1 (game board1 0 '())) - (define g-tree2 (game-tree board0 0 0)) - - ; (define world31 (dice-world #f board1 g-tree1)) - (define world2 (dice-world #f board2 g-tree2)) - - ;; testing book tree - - (check-equal? (game-tree (list (territory 0 0 2 'x 'y) - (territory 1 1 1 'a 'b)) - 0 - 0) - gt3) - - - ;; testing tree generation - - (define (property:attack-location-valid) - (define moves (game-moves (game-tree (territory-build) 0 0))) - (check-true (and (for/and ([m moves]) - (define m1 (move-action m)) - (member (second m1) (neighbors (first m1)))) - #t) - "invalid attack location")) - - (define (property:add-to-territory-always-up-one) - (define r (random 10000)) - (check-equal? (add-dice-to (territory 0 0 r 0 0)) - (territory 0 0 (add1 r) 0 0) - "add to territory always up one")) - - (define (property:attackable?-does-not-need-neighbores-check) - (define (check-attackable? gt) - (for/and ([move (game-moves gt)] - #:when (not (empty? (move-action move)))) - (define action (move-action move)) - (define gt (move-gt move)) - (and (member (second action) (neighbors (first action))) - (check-attackable? gt)))) - - ;;start - (define old-size BOARD) - (set-grid 2) - (define testing-gt (dice-world-gt (create-world-of-dice-and-doom))) - (check-true (check-attackable? testing-gt) "An attack move between non-neighbores was created") - (set-grid old-size)) - - - ;; game-tree - (check-equal? (game-tree board1 0 0) g-tree1) - (check-equal? (game-tree board3 1 0) (game board3 1 '())) - (check-equal? (game-tree board3 0 0) (game board3 0 '())) - (check-property property:attackable?-does-not-need-neighbores-check) - - ;; find-move - (check-false (find-move '() '())) - (check-equal? (find-move (list (move '() (game '() 0 '()))) '()) (game '() 0 '())) - ;; Attacking-Moves - (check-property property:attack-location-valid) - - ;; switch-players - (check-equal? (switch 0) 1) - (check-equal? (switch 1) 0) - - ;; Add-New-Dice - (check-equal? (distribute/list (game-board g-tree1) 0 3) (list 1 (reverse b1+0+3))) - (check-equal? (distribute/list (game-board g-tree1) 1 2) (list 0 (reverse b1+1+2))) - (check-equal? (distribute/list (game-board g-tree2) 1 2) (list 0 (reverse b2+1+2))) - (check-equal? (distribute/list board6 0 0) (list 0 (reverse bard6+))) - - ;; add-to-territory - (check-equal? (add-dice-to (territory 0 1 2 9 0)) (territory 0 1 3 9 0)) - (check-equal? (add-dice-to (territory 0 1 1 9 0)) (territory 0 1 2 9 0)) - (check-equal? (add-dice-to (territory 0 1 5 9 0)) (territory 0 1 6 9 0)) - (check-property property:add-to-territory-always-up-one) - - ;; --------------------------------------------------------------------------------------------------- - (define board7 - (list (territory 0 0 1 9 0) (territory 1 1 1 8 0) (territory 2 0 2 43.5 5) (territory 3 1 1 6 5))) - (define board8 - (list (territory 0 1 1 9 0) (territory 1 1 1 8 0) (territory 2 0 3 43.5 5) (territory 3 1 1 6 5))) - (define board9 - (list (territory 0 0 1 9 0) (territory 1 1 1 8 0) (territory 2 0 2 43.5 5) (territory 3 0 1 6 5))) - (define board10 - (list (territory 0 0 1 9 0) (territory 1 1 3 8 0) (territory 2 0 2 43.5 5) (territory 3 1 1 6 5))) - - ;; testing attacks - - (check-equal? - (execute board7 0 2 1 2) - (list (territory 0 0 1 9 0) (territory 1 0 1 8 0) (territory 2 0 1 43.5 5) (territory 3 1 1 6 5))) - - (check-equal? - (execute board8 0 2 1 3) - (list (territory 0 1 1 9 0) (territory 1 0 2 8 0) (territory 2 0 1 43.5 5) (territory 3 1 1 6 5))) - - (check-equal? - (execute board9 0 2 1 2) - (list (territory 0 0 1 9 0) (territory 1 0 1 8 0) (territory 2 0 1 43.5 5) (territory 3 0 1 6 5))) - - (check-equal? - (execute board10 1 1 0 3) - (list(territory 0 1 2 9 0) (territory 1 1 1 8 0) (territory 2 0 2 43.5 5) (territory 3 1 1 6 5))) - - ;; Neighbors - (check-equal? (neighbors 2) '(0 3)) - (check-equal? (neighbors 0) '(3 2 1)) - (check-equal? (neighbors 1) '(3 0)) - (check-equal? (neighbors 3) '(1 0 2)) - - ;; --------------------------------------------------------------------------------------------------- - (define board20 - (list (territory 0 0 1 9 2) (territory 1 0 1 9 0) (territory 2 2 1 9 0))) - (define board21 - (list (territory 0 1 1 9 0) (territory 1 1 1 8 0) (territory 2 1 1 43.5 5) (territory 3 1 1 6 5))) - - ;; testing focus manipulation - ;; interact-with-board - (check-equal? - (interact-with-board world2 "\r") - (dice-world (territory-index (car (dice-world-board world2))) (dice-world-board world2) g-tree2)) - - (check-equal? (interact-with-board world2 "p") world2) - - ;; refocus-board-action - (check-equal? - (refocus-board (dice-world #f (list (territory 0 0 1 9 0) (territory 0 0 1 9 2)) g-tree1) left) - (dice-world #f (list (territory 0 0 1 9 2) (territory 0 0 1 9 0)) g-tree1)) - - (check-equal? - (refocus-board (dice-world #f (list (territory 0 0 1 9 2) (territory 0 1 1 9 0)) g-tree1) right) - (dice-world #f (list (territory 0 0 1 9 2) (territory 0 1 1 9 0)) g-tree1)) - - (check-equal? - (refocus-board (dice-world 0 board20 g-tree1) left) - (dice-world 0 (list (territory 2 2 1 9 0) (territory 0 0 1 9 2) (territory 1 0 1 9 0)) g-tree1)) - - (check-equal? - (refocus-board (dice-world 0 (list (territory 0 0 1 9 2) (territory 0 1 1 9 0)) g-tree1) left) - (dice-world 0 (list (territory 0 1 1 9 0) (territory 0 0 1 9 2)) g-tree1)) - - (check-equal? - (refocus-board (dice-world 0 (list(territory 0 0 1 9 2) (territory 0 1 1 9 0)) g-tree1) right) - (dice-world 0 (list (territory 0 1 1 9 0) (territory 0 0 1 9 2)) g-tree1)) - - ;;unmark - (check-equal? (unmark (dice-world 1 board21 g-tree1)) (dice-world #f board21 g-tree1)) - - (check-equal? (unmark (dice-world 1 (list (territory 0 1 1 9 0) (territory 1 1 1 8 0)) g-tree1)) - (dice-world #f (list (territory 0 1 1 9 0) (territory 1 1 1 8 0)) g-tree1)) - (check-equal? (unmark (dice-world 0 (list (territory 0 1 1 9 0)) g-tree1)) - (dice-world #f (list (territory 0 1 1 9 0)) g-tree1)) - (check-equal? (unmark (dice-world #f (list (territory 0 1 1 9 0)) g-tree1)) - (dice-world #f (list (territory 0 1 1 9 0)) g-tree1)) - - ;; --------------------------------------------------------------------------------------------------- - (define (winners/list w) - (define-values (a b) (winners w)) - (cons a b)) - - ;; testing functions that determine 'winning' and declare the winner - - ;; winners - (check-equal? (winners/list (list (territory 0 0 1 9 0) (territory 0 0 1 9 1))) (list 2 0)) - (check-equal? (winners/list (list (territory 0 1 1 9 0) (territory 0 0 1 9 1))) (list 1 1 0)) - - ;; sum-territory - (check-equal? (sum-territory (list (territory 0 0 1 9 0) (territory 0 0 1 9 1)) 0) 2) - (check-equal? (sum-territory (list (territory 0 0 1 9 0) (territory 0 0 1 9 1)) 1) 0) - (check-equal? (sum-territory (list (territory 0 0 1 9 0) (territory 0 0 1 9 1)) 2) 0) - (check-equal? (sum-territory (list (territory 0 1 1 9 0) (territory 0 0 1 9 1)) 1) 1) - (check-equal? (sum-territory (list (territory 0 1 1 9 0) (territory 0 0 1 9 1)) 0) 1) - - ;; --------------------------------------------------------------------------------------------------- - ;; testing the AI - - (define tree0 - (game-tree (list (territory 0 1 3 0 0) - (territory 1 0 2 0 0) - (territory 2 0 2 0 0) - (territory 3 0 2 0 0)) - 1 15)) - - (define territory1 (territory 3 0 3 280 262.5)) - - (define board31 - (list territory1 - (territory 2 0 3 150 262.5) - (territory 1 1 2 345 150) - (territory 0 0 2 215 150))) - - (define world1 - (dice-world #f board31 (game board31 1 '()))) - - ;; testing the AI functions - - ;; MF: one of these two tests should fail! - (check-true (and (attackable? board31 0 territory1 1) #t)) - (check-true (no-more-moves-in-world? world1)) - - (check-equal? (interact-with-board (dice-world 3 '() '()) "d") - (dice-world #f '() '())) - - (check-equal? (game-board (the-ai-plays tree0)) - (list (territory 3 1 3 0 0) - (territory 2 0 2 0 0) - (territory 1 0 2 0 0) - (territory 0 1 2 0 0))) - - (check-equal? (game-player (the-ai-plays tree0)) - 0) - - (check-equal? (game-board (move-gt (first (game-moves tree0)))) - (list (territory 0 1 1 0 0) - (territory 1 0 2 0 0) - (territory 2 0 2 0 0) - (territory 3 1 2 0 0))) - - (check-equal? (game-player (move-gt (first (game-moves tree0)))) - 1) - - (check-equal? (rate-position tree0 AI-DEPTH) 1/2) - (check-equal? (rate-position (move-gt (first (game-moves tree0))) AI-DEPTH) - 1/2) - - "all tests run") diff --git a/two/guess.rkt b/two/guess.rkt deleted file mode 100644 index ab05056..0000000 --- a/two/guess.rkt +++ /dev/null @@ -1,21 +0,0 @@ -#lang racket - -(define lower 1) - -(define upper 100) - -(define (start n m) - (set! lower (min n m)) - (set! upper (max n m)) - (guess)) - -(define (guess) - (quotient (+ lower upper) 2)) - -(define (smaller) - (set! upper (max lower (sub1 (guess)))) - (guess)) - -(define (bigger) - (set! lower (min upper (add1 (guess)))) - (guess)) -- cgit v1.2.3