990 lines
41 KiB
Racket
990 lines
41 KiB
Racket
#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))
|
|
(for/fold ([foods '()]) ([f foods])
|
|
(cond
|
|
[(body-collide? f b)
|
|
(set-body-size! b (+ PLAYER-FATTEN-DELTA (body-size b)))
|
|
foods]
|
|
[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))
|
|
(cond [(empty? foods) (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 (get-iws p) (serialize-universe 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)))
|
|
|
|
;
|
|
;
|
|
;
|
|
;
|
|
; ;;;; ;
|
|
; ; ; ;
|
|
; ; ; ;;; ;;;;; ;;; ; ;;;; ;; ;; ;; ;; ;;;; ;;; ; ;;;;;
|
|
; ; ; ; ; ; ; ;; ; ; ;; ; ;; ; ; ; ; ;; ;
|
|
; ; ; ; ;;;; ; ; ; ; ; ; ; ;;;;;; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;;;; ;;;;; ;;;;; ;;;; ;;;; ;;; ;;; ;;; ;;; ;;;;; ;;;; ;;;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
|
|
;; 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))))
|
|
|
|
;; 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-equal? (eat-all-the-things (ip iworld1 "player10" (body 11 0) '(1+10i)) (list (body 10 0)))
|
|
empty)
|
|
(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))
|
|
;; 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)))
|
|
|
|
"server: all tests run") |