diff options
Diffstat (limited to 'net/ricketyspace/ror')
51 files changed, 0 insertions, 7068 deletions
diff --git a/net/ricketyspace/ror/eight/graphics/README.txt b/net/ricketyspace/ror/eight/graphics/README.txt deleted file mode 100644 index 5895c77..0000000 --- a/net/ricketyspace/ror/eight/graphics/README.txt +++ /dev/null @@ -1,3 +0,0 @@ -Graphics from github.com/racket/realm - -Commit: 973041cb6a5c696b99b79a diff --git a/net/ricketyspace/ror/eight/graphics/brigand.bmp b/net/ricketyspace/ror/eight/graphics/brigand.bmp Binary files differdeleted file mode 100644 index 7bbd3c0..0000000 --- a/net/ricketyspace/ror/eight/graphics/brigand.bmp +++ /dev/null diff --git a/net/ricketyspace/ror/eight/graphics/hydra.png b/net/ricketyspace/ror/eight/graphics/hydra.png Binary files differdeleted file mode 100644 index b495920..0000000 --- a/net/ricketyspace/ror/eight/graphics/hydra.png +++ /dev/null diff --git a/net/ricketyspace/ror/eight/graphics/hydrar.png b/net/ricketyspace/ror/eight/graphics/hydrar.png Binary files differdeleted file mode 100644 index e555bfe..0000000 --- a/net/ricketyspace/ror/eight/graphics/hydrar.png +++ /dev/null diff --git a/net/ricketyspace/ror/eight/graphics/orc.gif b/net/ricketyspace/ror/eight/graphics/orc.gif Binary files differdeleted file mode 100644 index 5553322..0000000 --- a/net/ricketyspace/ror/eight/graphics/orc.gif +++ /dev/null diff --git a/net/ricketyspace/ror/eight/graphics/orc.png b/net/ricketyspace/ror/eight/graphics/orc.png Binary files differdeleted file mode 100644 index d269b6a..0000000 --- a/net/ricketyspace/ror/eight/graphics/orc.png +++ /dev/null diff --git a/net/ricketyspace/ror/eight/graphics/orcSprite.png b/net/ricketyspace/ror/eight/graphics/orcSprite.png Binary files differdeleted file mode 100644 index cdc223c..0000000 --- a/net/ricketyspace/ror/eight/graphics/orcSprite.png +++ /dev/null diff --git a/net/ricketyspace/ror/eight/graphics/player.bmp b/net/ricketyspace/ror/eight/graphics/player.bmp Binary files differdeleted file mode 100644 index c6a04a0..0000000 --- a/net/ricketyspace/ror/eight/graphics/player.bmp +++ /dev/null diff --git a/net/ricketyspace/ror/eight/graphics/slime.bmp b/net/ricketyspace/ror/eight/graphics/slime.bmp Binary files differdeleted file mode 100644 index 208c188..0000000 --- a/net/ricketyspace/ror/eight/graphics/slime.bmp +++ /dev/null diff --git a/net/ricketyspace/ror/eight/orc.rkt b/net/ricketyspace/ror/eight/orc.rkt deleted file mode 100644 index f00d587..0000000 --- a/net/ricketyspace/ror/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/net/ricketyspace/ror/eleven/lazy.rkt b/net/ricketyspace/ror/eleven/lazy.rkt deleted file mode 100644 index 6f54719..0000000 --- a/net/ricketyspace/ror/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/net/ricketyspace/ror/five/guess.rkt b/net/ricketyspace/ror/five/guess.rkt deleted file mode 100644 index f7a117a..0000000 --- a/net/ricketyspace/ror/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/net/ricketyspace/ror/five/loco.rkt b/net/ricketyspace/ror/five/loco.rkt deleted file mode 100644 index 977c976..0000000 --- a/net/ricketyspace/ror/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/net/ricketyspace/ror/five/resources/caroille.png b/net/ricketyspace/ror/five/resources/caroille.png Binary files differdeleted file mode 100644 index 052cc58..0000000 --- a/net/ricketyspace/ror/five/resources/caroille.png +++ /dev/null diff --git a/net/ricketyspace/ror/five/resources/caroille.svg b/net/ricketyspace/ror/five/resources/caroille.svg deleted file mode 100644 index eb4db63..0000000 --- a/net/ricketyspace/ror/five/resources/caroille.svg +++ /dev/null @@ -1,125 +0,0 @@ -<?xml version="1.0" encoding="UTF-8" standalone="no"?> -<!-- Created with Inkscape (http://www.inkscape.org/) --> - -<svg - xmlns:dc="http://purl.org/dc/elements/1.1/" - xmlns:cc="http://creativecommons.org/ns#" - xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" - xmlns:svg="http://www.w3.org/2000/svg" - xmlns="http://www.w3.org/2000/svg" - xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd" - xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" - width="80" - height="80" - viewBox="0 0 21.166666 21.166667" - version="1.1" - id="svg8" - inkscape:version="0.92.3 (2405546, 2018-03-11)" - sodipodi:docname="caroille.svg"> - <title - id="title3715">caroille</title> - <defs - id="defs2"> - <inkscape:perspective - sodipodi:type="inkscape:persp3d" - inkscape:vp_x="1.8428503 : 18.575596 : 1" - inkscape:vp_y="0 : 999.99999 : 0" - inkscape:vp_z="28.301183 : 18.575596 : 1" - inkscape:persp3d-origin="15.072016 : 14.165874 : 1" - id="perspective3723" /> - </defs> - <sodipodi:namedview - id="base" - pagecolor="#ffffff" - bordercolor="#666666" - borderopacity="1.0" - inkscape:pageopacity="0.0" - inkscape:pageshadow="2" - inkscape:zoom="3.959798" - inkscape:cx="72.620745" - inkscape:cy="61.452165" - inkscape:document-units="mm" - inkscape:current-layer="layer1" - showgrid="false" - units="px" - showguides="false" - inkscape:window-width="1280" - inkscape:window-height="800" - inkscape:window-x="0" - inkscape:window-y="0" - inkscape:window-maximized="0" /> - <metadata - id="metadata5"> - <rdf:RDF> - <cc:Work - rdf:about=""> - <dc:format>image/svg+xml</dc:format> - <dc:type - rdf:resource="http://purl.org/dc/dcmitype/StillImage" /> - <dc:title>caroille</dc:title> - <cc:license - rdf:resource="http://creativecommons.org/publicdomain/zero/1.0/" /> - <dc:date>2018-04-02</dc:date> - <dc:creator> - <cc:Agent> - <dc:title>rsiddharth <s@ricketyspace.net></dc:title> - </cc:Agent> - </dc:creator> - <dc:subject> - <rdf:Bag> - <rdf:li>car</rdf:li> - </rdf:Bag> - </dc:subject> - </cc:Work> - <cc:License - rdf:about="http://creativecommons.org/publicdomain/zero/1.0/"> - <cc:permits - rdf:resource="http://creativecommons.org/ns#Reproduction" /> - <cc:permits - rdf:resource="http://creativecommons.org/ns#Distribution" /> - <cc:permits - rdf:resource="http://creativecommons.org/ns#DerivativeWorks" /> - </cc:License> - </rdf:RDF> - </metadata> - <g - inkscape:label="Layer 1" - inkscape:groupmode="layer" - id="layer1" - transform="translate(0,-275.83332)"> - <g - id="g3759" - transform="matrix(1.6602564,0,0,1.6602564,-10.597836,-177.21015)" - inkscape:export-xdpi="96" - inkscape:export-ydpi="96"> - <rect - ry="0.8018086" - style="stroke-width:0.26458332" - y="277.95703" - x="7.550364" - height="3.4745038" - width="10.423512" - id="rect3717" /> - <circle - style="stroke-width:0.26458332" - r="1.1692964" - cy="281.3313" - cx="9.254199" - id="path3719" /> - <circle - id="circle3721" - cx="15.969346" - cy="281.49835" - r="1.1692964" - style="stroke-width:0.26458332" /> - <rect - ry="1.1693041" - style="stroke-width:0.24171647" - y="275.9859" - x="9.7219286" - height="2.7395124" - width="5.9133382" - id="rect3753" /> - </g> - </g> -</svg> diff --git a/net/ricketyspace/ror/five/resources/ufo-fart.png b/net/ricketyspace/ror/five/resources/ufo-fart.png Binary files differdeleted file mode 100644 index 13d1c4a..0000000 --- a/net/ricketyspace/ror/five/resources/ufo-fart.png +++ /dev/null diff --git a/net/ricketyspace/ror/five/resources/ufo-fart.svg b/net/ricketyspace/ror/five/resources/ufo-fart.svg deleted file mode 100644 index cf86021..0000000 --- a/net/ricketyspace/ror/five/resources/ufo-fart.svg +++ /dev/null @@ -1,188 +0,0 @@ -<?xml version="1.0" encoding="UTF-8" standalone="no"?> -<!-- Created with Inkscape (http://www.inkscape.org/) --> - -<svg - xmlns:dc="http://purl.org/dc/elements/1.1/" - xmlns:cc="http://creativecommons.org/ns#" - xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" - xmlns:svg="http://www.w3.org/2000/svg" - xmlns="http://www.w3.org/2000/svg" - xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd" - xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" - width="50" - height="50" - viewBox="0 0 13.229166 13.229167" - version="1.1" - id="svg8" - inkscape:version="0.92.3 (2405546, 2018-03-11)" - sodipodi:docname="ufo-gas.svg"> - <title - id="title10">UFO Fart</title> - <defs - id="defs2" /> - <sodipodi:namedview - id="base" - pagecolor="#ffffff" - bordercolor="#666666" - borderopacity="1.0" - inkscape:pageopacity="0.0" - inkscape:pageshadow="2" - inkscape:zoom="7.9195959" - inkscape:cx="19.4951" - inkscape:cy="22.795424" - inkscape:document-units="mm" - inkscape:current-layer="layer1" - showgrid="false" - units="px" - inkscape:window-width="1280" - inkscape:window-height="800" - inkscape:window-x="0" - inkscape:window-y="0" - inkscape:window-maximized="0" /> - <metadata - id="metadata5"> - <rdf:RDF> - <cc:Work - rdf:about=""> - <dc:format>image/svg+xml</dc:format> - <dc:type - rdf:resource="http://purl.org/dc/dcmitype/StillImage" /> - <dc:title>UFO Fart</dc:title> - <cc:license - rdf:resource="http://creativecommons.org/publicdomain/zero/1.0/" /> - <dc:date>2018-04-17</dc:date> - <dc:creator> - <cc:Agent> - <dc:title>rsiddharth <s@ricketyspace.net></dc:title> - </cc:Agent> - </dc:creator> - </cc:Work> - <cc:License - rdf:about="http://creativecommons.org/publicdomain/zero/1.0/"> - <cc:permits - rdf:resource="http://creativecommons.org/ns#Reproduction" /> - <cc:permits - rdf:resource="http://creativecommons.org/ns#Distribution" /> - <cc:permits - rdf:resource="http://creativecommons.org/ns#DerivativeWorks" /> - </cc:License> - </rdf:RDF> - </metadata> - <g - inkscape:label="Layer 1" - inkscape:groupmode="layer" - id="layer1" - transform="translate(0,-283.77082)"> - <g - id="g160"> - <circle - style="fill:#ffffff;stroke-width:0.09590441" - r="0.071714237" - cy="288.4332" - cx="4.474267" - id="circle38" /> - </g> - <g - id="g202" - inkscape:export-xdpi="76.796082" - inkscape:export-ydpi="76.796082"> - <g - id="g180"> - <circle - style="stroke-width:0.20158729" - r="0.53453904" - cy="285.58438" - cx="6.4067097" - id="circle20" /> - <circle - style="fill:#ffffff;stroke-width:0.06017532" - r="0.044997171" - cy="285.91135" - cx="6.4122667" - id="circle22" /> - </g> - <g - id="g132"> - <circle - style="stroke-width:0.42837298" - r="1.1358955" - cy="294.70496" - cx="2.898797" - id="circle42" /> - <circle - style="fill:#ffffff;stroke-width:0.12787254" - r="0.095618986" - cy="295.48981" - cx="2.5584671" - id="circle44" /> - </g> - <circle - id="circle36" - cx="4.920023" - cy="287.93967" - r="0.85192156" - style="stroke-width:0.32127973" - transform="translate(0,9.1666667e-6)" /> - <g - id="g176"> - <circle - style="stroke-width:0.32127973" - r="0.85192156" - cy="287.83945" - cx="8.294301" - id="circle48" /> - <circle - style="fill:#ffffff;stroke-width:0.09590441" - r="0.071714237" - cy="288.35379" - cx="8.6660032" - id="circle50" /> - </g> - <g - id="g136"> - <circle - id="path12" - cx="3.9511709" - cy="291.24713" - r="1.2528259" - style="stroke-width:0.47247022" /> - <circle - id="path14" - cx="3.5711958" - cy="292.09247" - r="0.10546212" - style="fill:#ffffff;stroke-width:0.1410359" /> - </g> - <g - id="g152"> - <circle - style="stroke-width:0.47247022" - r="1.2528259" - cy="291.31396" - cx="9.7308741" - id="circle54" /> - <circle - style="fill:#ffffff;stroke-width:0.1410359" - r="0.10546212" - cy="292.10916" - cx="10.269638" - id="circle56" /> - </g> - <g - id="g156"> - <circle - id="circle66" - cx="10.549387" - cy="294.57132" - r="1.1358955" - style="stroke-width:0.42837298" /> - <circle - id="circle68" - cx="10.976822" - cy="295.35028" - r="0.095618986" - style="fill:#ffffff;stroke-width:0.12787254" /> - </g> - </g> - </g> -</svg> diff --git a/net/ricketyspace/ror/five/resources/zarking-ufo.png b/net/ricketyspace/ror/five/resources/zarking-ufo.png Binary files differdeleted file mode 100644 index bd5eb43..0000000 --- a/net/ricketyspace/ror/five/resources/zarking-ufo.png +++ /dev/null diff --git a/net/ricketyspace/ror/five/resources/zarking-ufo.svg b/net/ricketyspace/ror/five/resources/zarking-ufo.svg deleted file mode 100644 index 84b8844..0000000 --- a/net/ricketyspace/ror/five/resources/zarking-ufo.svg +++ /dev/null @@ -1,128 +0,0 @@ -<?xml version="1.0" encoding="UTF-8" standalone="no"?> -<!-- Created with Inkscape (http://www.inkscape.org/) --> - -<svg - xmlns:dc="http://purl.org/dc/elements/1.1/" - xmlns:cc="http://creativecommons.org/ns#" - xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" - xmlns:svg="http://www.w3.org/2000/svg" - xmlns="http://www.w3.org/2000/svg" - xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd" - xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" - width="100" - height="100" - viewBox="0 0 26.458333 26.458334" - version="1.1" - id="svg8" - inkscape:version="0.92.3pre0 (0ab9bec, 2018-03-03)" - sodipodi:docname="zarking-ufo.svg"> - <title - id="title4518">Zarking UFO</title> - <defs - id="defs2" /> - <sodipodi:namedview - id="base" - pagecolor="#ffffff" - bordercolor="#666666" - borderopacity="1.0" - inkscape:pageopacity="0.0" - inkscape:pageshadow="2" - inkscape:zoom="0.98994949" - inkscape:cx="52.159535" - inkscape:cy="240.12864" - inkscape:document-units="mm" - inkscape:current-layer="layer1" - showgrid="false" - units="px" - inkscape:window-width="1280" - inkscape:window-height="800" - inkscape:window-x="0" - inkscape:window-y="0" - inkscape:window-maximized="0" /> - <metadata - id="metadata5"> - <rdf:RDF> - <cc:Work - rdf:about=""> - <dc:format>image/svg+xml</dc:format> - <dc:type - rdf:resource="http://purl.org/dc/dcmitype/StillImage" /> - <dc:title>Zarking UFO</dc:title> - <cc:license - rdf:resource="http://creativecommons.org/publicdomain/zero/1.0/" /> - <dc:date>2018-03-09</dc:date> - <dc:creator> - <cc:Agent> - <dc:title>rsiddharth <s@ricketyspace.net></dc:title> - </cc:Agent> - </dc:creator> - </cc:Work> - <cc:License - rdf:about="http://creativecommons.org/publicdomain/zero/1.0/"> - <cc:permits - rdf:resource="http://creativecommons.org/ns#Reproduction" /> - <cc:permits - rdf:resource="http://creativecommons.org/ns#Distribution" /> - <cc:permits - rdf:resource="http://creativecommons.org/ns#DerivativeWorks" /> - </cc:License> - </rdf:RDF> - </metadata> - <g - inkscape:label="Layer 1" - inkscape:groupmode="layer" - id="layer1" - transform="translate(0,-270.54165)"> - <path - style="opacity:1;fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:0;stroke-linecap:round;stroke-linejoin:round;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;paint-order:normal" - id="path4602" - sodipodi:type="arc" - sodipodi:cx="16.591591" - sodipodi:cy="284.83923" - sodipodi:rx="0.04593695" - sodipodi:ry="0.0083521726" - sodipodi:start="0" - sodipodi:end="3.1415927" - sodipodi:open="true" - d="m 16.637528,284.83923 a 0.04593695,0.00835217 0 0 1 -0.02297,0.007 0.04593695,0.00835217 0 0 1 -0.04594,0 0.04593695,0.00835217 0 0 1 -0.02297,-0.007" /> - <g - id="g4627" - transform="matrix(5.4364839,0,0,5.4364839,-58.979175,-1255.7408)"> - <path - transform="scale(1,-1)" - d="m 14.843864,-283.24774 a 1.4941016,1.4941016 0 0 1 -0.747051,1.29393 1.4941016,1.4941016 0 0 1 -1.494102,0 1.4941016,1.4941016 0 0 1 -0.747051,-1.29393" - sodipodi:open="true" - sodipodi:end="3.1415927" - sodipodi:start="0" - sodipodi:ry="1.4941016" - sodipodi:rx="1.4941016" - sodipodi:cy="-283.24774" - sodipodi:cx="13.349762" - sodipodi:type="arc" - id="path4593" - style="opacity:1;fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:0;stroke-linecap:round;stroke-linejoin:round;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;paint-order:normal" /> - <path - inkscape:connector-curvature="0" - id="rect4600" - d="m 11.32607,283.91839 c 1.383215,-10e-6 2.766429,0 4.149644,0 -0.187618,-0.20965 -0.375238,-0.4193 -0.562857,-0.62894 -1.014054,-0.009 -2.028106,-0.0197 -3.04216,-0.0296 -0.181543,0.21952 -0.363085,0.43904 -0.544627,0.65857 z" - style="opacity:1;fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:0;stroke-linecap:round;stroke-linejoin:round;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;paint-order:normal" /> - <path - d="m 14.445777,283.94208 a 1.0925874,0.37207031 0 0 1 -0.546294,0.32222 1.0925874,0.37207031 0 0 1 -1.092587,0 1.0925874,0.37207031 0 0 1 -0.546294,-0.32222" - sodipodi:open="true" - sodipodi:end="3.1415927" - sodipodi:start="0" - sodipodi:ry="0.37207031" - sodipodi:rx="1.0925874" - sodipodi:cy="283.94208" - sodipodi:cx="13.353189" - sodipodi:type="arc" - id="path4607" - style="opacity:1;fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:0;stroke-linecap:round;stroke-linejoin:round;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;paint-order:normal" /> - <path - inkscape:connector-curvature="0" - id="path4609" - d="m 12.522043,282.31051 c -0.03576,0.11467 -0.06681,0.23061 -0.09375,0.34765 0.02456,0.0134 0.01871,0.058 0.05273,0.0566 0.03764,-0.0375 0.0043,-0.11891 0.06641,-0.13672 l -0.002,-0.0176 c 0.01392,-0.0139 0.03466,0.003 0.04883,0.006 0.01317,-0.006 0.01975,-0.0378 -0.002,-0.0352 -0.01323,-0.0163 0.03655,-0.0357 -0.0039,-0.041 -0.02263,-0.0213 -0.0046,-0.0742 0.0293,-0.0625 0.01962,-0.008 0.0409,-0.0326 0.0078,-0.0449 -0.01308,-0.0169 -0.0161,-0.0415 -0.0059,-0.0605 l -0.04297,-0.0156 -0.04687,-0.006 z" - style="opacity:1;fill:#ffffff;fill-opacity:1;stroke:#000000;stroke-width:0;stroke-linecap:round;stroke-linejoin:round;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;paint-order:normal" /> - </g> - </g> -</svg> diff --git a/net/ricketyspace/ror/five/ufo.rkt b/net/ricketyspace/ror/five/ufo.rkt deleted file mode 100644 index 6f8136c..0000000 --- a/net/ricketyspace/ror/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/net/ricketyspace/ror/fourteen/client.rkt b/net/ricketyspace/ror/fourteen/client.rkt deleted file mode 100644 index 52305a1..0000000 --- a/net/ricketyspace/ror/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/net/ricketyspace/ror/fourteen/graphics/cupcake.gif b/net/ricketyspace/ror/fourteen/graphics/cupcake.gif Binary files differdeleted file mode 100644 index 20b1bef..0000000 --- a/net/ricketyspace/ror/fourteen/graphics/cupcake.gif +++ /dev/null diff --git a/net/ricketyspace/ror/fourteen/graphics/hungry-henry.gif b/net/ricketyspace/ror/fourteen/graphics/hungry-henry.gif Binary files differdeleted file mode 100644 index cce6948..0000000 --- a/net/ricketyspace/ror/fourteen/graphics/hungry-henry.gif +++ /dev/null diff --git a/net/ricketyspace/ror/fourteen/readme.txt b/net/ricketyspace/ror/fourteen/readme.txt deleted file mode 100644 index 042b0f4..0000000 --- a/net/ricketyspace/ror/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/net/ricketyspace/ror/fourteen/run.rkt b/net/ricketyspace/ror/fourteen/run.rkt deleted file mode 100644 index 4a244b7..0000000 --- a/net/ricketyspace/ror/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/net/ricketyspace/ror/fourteen/server.rkt b/net/ricketyspace/ror/fourteen/server.rkt deleted file mode 100644 index 078533b..0000000 --- a/net/ricketyspace/ror/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/net/ricketyspace/ror/fourteen/shared.rkt b/net/ricketyspace/ror/fourteen/shared.rkt deleted file mode 100644 index 7f3a549..0000000 --- a/net/ricketyspace/ror/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/net/ricketyspace/ror/one/hw.rkt b/net/ricketyspace/ror/one/hw.rkt deleted file mode 100644 index fec7e25..0000000 --- a/net/ricketyspace/ror/one/hw.rkt +++ /dev/null @@ -1,3 +0,0 @@ -#lang racket - -'(hello-world) diff --git a/net/ricketyspace/ror/six/resources/body.gif b/net/ricketyspace/ror/six/resources/body.gif Binary files differdeleted file mode 100644 index 94a0956..0000000 --- a/net/ricketyspace/ror/six/resources/body.gif +++ /dev/null diff --git a/net/ricketyspace/ror/six/resources/goo-red.gif b/net/ricketyspace/ror/six/resources/goo-red.gif Binary files differdeleted file mode 100644 index bf767b1..0000000 --- a/net/ricketyspace/ror/six/resources/goo-red.gif +++ /dev/null diff --git a/net/ricketyspace/ror/six/resources/goo.gif b/net/ricketyspace/ror/six/resources/goo.gif Binary files differdeleted file mode 100644 index cb0d98b..0000000 --- a/net/ricketyspace/ror/six/resources/goo.gif +++ /dev/null diff --git a/net/ricketyspace/ror/six/resources/head.gif b/net/ricketyspace/ror/six/resources/head.gif Binary files differdeleted file mode 100644 index 664f679..0000000 --- a/net/ricketyspace/ror/six/resources/head.gif +++ /dev/null diff --git a/net/ricketyspace/ror/six/resources/obstacle.gif b/net/ricketyspace/ror/six/resources/obstacle.gif Binary files differdeleted file mode 100644 index 6ff288e..0000000 --- a/net/ricketyspace/ror/six/resources/obstacle.gif +++ /dev/null diff --git a/net/ricketyspace/ror/six/resources/tail.gif b/net/ricketyspace/ror/six/resources/tail.gif Binary files differdeleted file mode 100644 index 6fbd317..0000000 --- a/net/ricketyspace/ror/six/resources/tail.gif +++ /dev/null diff --git a/net/ricketyspace/ror/six/snake.rkt b/net/ricketyspace/ror/six/snake.rkt deleted file mode 100644 index c57b01c..0000000 --- a/net/ricketyspace/ror/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/net/ricketyspace/ror/six/snakes.rkt b/net/ricketyspace/ror/six/snakes.rkt deleted file mode 100644 index dae3468..0000000 --- a/net/ricketyspace/ror/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/net/ricketyspace/ror/ten/graphics/dice1.png b/net/ricketyspace/ror/ten/graphics/dice1.png Binary files differdeleted file mode 100644 index 3f4899c..0000000 --- a/net/ricketyspace/ror/ten/graphics/dice1.png +++ /dev/null diff --git a/net/ricketyspace/ror/ten/graphics/dice2.png b/net/ricketyspace/ror/ten/graphics/dice2.png Binary files differdeleted file mode 100644 index 2fa32ea..0000000 --- a/net/ricketyspace/ror/ten/graphics/dice2.png +++ /dev/null diff --git a/net/ricketyspace/ror/ten/graphics/dice3.png b/net/ricketyspace/ror/ten/graphics/dice3.png Binary files differdeleted file mode 100644 index 005ee75..0000000 --- a/net/ricketyspace/ror/ten/graphics/dice3.png +++ /dev/null diff --git a/net/ricketyspace/ror/ten/graphics/dice4.png b/net/ricketyspace/ror/ten/graphics/dice4.png Binary files differdeleted file mode 100644 index 47bb291..0000000 --- a/net/ricketyspace/ror/ten/graphics/dice4.png +++ /dev/null diff --git a/net/ricketyspace/ror/ten/source.rkt b/net/ricketyspace/ror/ten/source.rkt deleted file mode 100644 index a2b6a96..0000000 --- a/net/ricketyspace/ror/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, <enter> to mark, <d> to unmark, and <p> 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/net/ricketyspace/ror/thirteen/client.rkt b/net/ricketyspace/ror/thirteen/client.rkt deleted file mode 100644 index dc3b184..0000000 --- a/net/ricketyspace/ror/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/net/ricketyspace/ror/thirteen/run.rkt b/net/ricketyspace/ror/thirteen/run.rkt deleted file mode 100644 index b8726ac..0000000 --- a/net/ricketyspace/ror/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/net/ricketyspace/ror/thirteen/server.rkt b/net/ricketyspace/ror/thirteen/server.rkt deleted file mode 100644 index 12ff10a..0000000 --- a/net/ricketyspace/ror/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/net/ricketyspace/ror/thirteen/shared.rkt b/net/ricketyspace/ror/thirteen/shared.rkt deleted file mode 100644 index 176c429..0000000 --- a/net/ricketyspace/ror/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/net/ricketyspace/ror/twelve/graphics/dice1.png b/net/ricketyspace/ror/twelve/graphics/dice1.png Binary files differdeleted file mode 100644 index 3f4899c..0000000 --- a/net/ricketyspace/ror/twelve/graphics/dice1.png +++ /dev/null diff --git a/net/ricketyspace/ror/twelve/graphics/dice2.png b/net/ricketyspace/ror/twelve/graphics/dice2.png Binary files differdeleted file mode 100644 index 2fa32ea..0000000 --- a/net/ricketyspace/ror/twelve/graphics/dice2.png +++ /dev/null diff --git a/net/ricketyspace/ror/twelve/graphics/dice3.png b/net/ricketyspace/ror/twelve/graphics/dice3.png Binary files differdeleted file mode 100644 index 005ee75..0000000 --- a/net/ricketyspace/ror/twelve/graphics/dice3.png +++ /dev/null diff --git a/net/ricketyspace/ror/twelve/graphics/dice4.png b/net/ricketyspace/ror/twelve/graphics/dice4.png Binary files differdeleted file mode 100644 index 47bb291..0000000 --- a/net/ricketyspace/ror/twelve/graphics/dice4.png +++ /dev/null diff --git a/net/ricketyspace/ror/twelve/source.rkt b/net/ricketyspace/ror/twelve/source.rkt deleted file mode 100644 index dc37e87..0000000 --- a/net/ricketyspace/ror/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, <enter> to mark, <d> to unmark, and <p> 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/net/ricketyspace/ror/two/guess.rkt b/net/ricketyspace/ror/two/guess.rkt deleted file mode 100644 index ab05056..0000000 --- a/net/ricketyspace/ror/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)) |
