Permalink
Browse files

world now doesn't export image. Added cow example

  • Loading branch information...
1 parent 620ffdb commit 45783388ba1d58951a5d7f77583cb7119ac09525 Danny Yoo committed Aug 19, 2011
Showing with 251 additions and 6 deletions.
  1. +242 −0 examples/cow.rkt
  2. +2 −1 examples/expanding-circle.rkt
  3. +3 −1 examples/pacman.rkt
  4. +1 −0 examples/rain-world-program.rkt
  5. +2 −1 examples/whale.rkt
  6. +1 −3 world.rkt
View
@@ -0,0 +1,242 @@
+#lang planet dyoo/whalesong
+(require (planet dyoo/whalesong/js)
+ (planet dyoo/whalesong/image)
+ (planet dyoo/whalesong/world))
+
+
+;; Occupy the whole screen.
+(void (call-method body "css" "margin" 0))
+(void (call-method body "css" "padding" 0))
+(void (call-method body "css" "overflow" "hidden"))
+
+;; A Cow game
+
+
+(define-struct posn (x y))
+
+;Graphical Constants
+(define COW-LEFT
+ (open-image-url "http://world.cs.brown.edu/1/clipart/cow-left.png"))
+(define COW-RIGHT
+ (open-image-url "http://world.cs.brown.edu/1/clipart/cow-right.png"))
+(define UFO
+ (open-image-url "http://world.cs.brown.edu/1/clipart/ufo.png"))
+(define UFO-CAPTURE
+ (open-image-url "http://world.cs.brown.edu/1/clipart/ufo-capture.png"))
+
+
+;Physical Constants
+(define SCREEN-WIDTH (viewport-width))
+(define SCREEN-HEIGHT (viewport-height))
+
+(define BACKGROUND (empty-scene SCREEN-WIDTH SCREEN-HEIGHT))
+(define UFO-HEIGHT (image-height UFO))
+(define UFO-WIDTH (image-width UFO))
+(define HALF-UFO-WIDTH (/ UFO-WIDTH 2))
+(define HALF-UFO-HEIGHT (/ UFO-HEIGHT 2))
+(define COW-HEIGHT (image-height COW-RIGHT))
+(define COW-WIDTH (image-width COW-RIGHT))
+(define HALF-COW-HEIGHT (/ COW-HEIGHT 2))
+(define HALF-COW-WIDTH (/ COW-WIDTH 2))
+(define COW-SPEED 2)
+(define UFO-SPEED 5)
+
+; A cow is a posn and a string
+; p : posn dir : string ("right" or "left")
+; Represents a cow's position and the direction it faces
+(define-struct cow (p dir))
+
+(define cow0 (make-cow (make-posn (/ SCREEN-WIDTH 2) (- SCREEN-HEIGHT HALF-COW-HEIGHT)) "right"))
+(define cow1 (make-cow (make-posn (/ SCREEN-WIDTH 4) (- SCREEN-HEIGHT HALF-COW-HEIGHT)) "right"))
+(define cow2 (make-cow (make-posn (* SCREEN-WIDTH 3/4) (- SCREEN-HEIGHT HALF-COW-HEIGHT)) "left"))
+
+; A world is a posn and a list-of-cows
+; ufo: posn cows: list-of-cows
+; Represents the ufo's position and all the cows' positions directions
+(define-struct world (ufo cows))
+
+(define world-test (make-world (make-posn 10 10)
+ (list cow0 cow1)))
+(define world0 (make-world (make-posn (/ SCREEN-WIDTH 2) HALF-UFO-HEIGHT)
+ (list cow0 cow1 cow2)))
+
+; draw-cows: list-of-cows scene -> scene
+; draw-cows consumes a list-of-cows and a scene and produces a scene with cows at their posns
+; given: a list of three cows (facing "right", "right", and "left")
+; should produce: three cows drawn on a scene facing those directions at the bottom of the screen
+; given: empty
+; should produce: empty scene
+(define (draw-cows aloc scene)
+ (cond
+ [(null? aloc) scene]
+ [(pair? aloc) (place-image (cond
+ [(string=? (cow-dir (car aloc)) "right")
+ COW-RIGHT]
+ [(string=? (cow-dir (car aloc)) "left")
+ COW-LEFT])
+ (posn-x (cow-p (car aloc)))
+ (posn-y (cow-p (car aloc)))
+ (draw-cows (cdr aloc) scene))]))
+
+
+
+; draw-ufo: posn scene img -> scene
+; draw-ufo consumes a posn, a scene, and an img and produces a scene with a ufo drawn on the screen at the posn
+; given: (make-posn 0 0) (empty-scene 500 500) UFO
+; should produce: the UFO appearing on a scene at the top left corner
+(define (draw-ufo p scene ufo-img)
+ (place-image ufo-img (posn-x p) (posn-y p) scene))
+
+; draw: world -> scene
+; draw consumes a world and produces a scene with all the images
+; given: world-test
+; should produce: a ufo starting in the middle and three cows drawn on the background. The ufo should move left or right
+; depending on whether left or right is pressed on the keyboard, respectively, if the ufo isn't hitting a left or right wall.
+; Two cows start facing right, and one faces left. If a cow collides with another cow, both should change direction. If a cow
+; runs into a wall, it should change direction. If the ufo hits a cow, it should change images to the ufo captured image.
+(define (draw w)
+ (draw-cows (world-cows w)
+ (draw-ufo (world-ufo w)
+ BACKGROUND (if (anything-touching-cow? (world-ufo w)
+ HALF-UFO-WIDTH
+ HALF-UFO-HEIGHT
+ (world-cows w)) UFO-CAPTURE UFO))))
+
+; move-ufo-y: world -> world
+; move-ufo-y consumes a world and produces a world with the ufo moved down
+(define (move-ufo-y w)
+ (make-world (make-posn (posn-x (world-ufo w))
+ (+ UFO-SPEED (posn-y (world-ufo w))))
+ (world-cows w)))
+
+
+
+; move-ufo-x: world key -> world
+; move-ufo-x consumes a world and key and produces a world with the ufo moved by keys
+(define (move-ufo-x w key)
+ (make-world
+ (make-posn
+ (cond
+ [(and (key=? key "left") (not (hitting-wall? (world-ufo w) "left")))
+ (- (posn-x (world-ufo w)) UFO-SPEED)]
+ [(and (key=? key "right") (not (hitting-wall? (world-ufo w) "right")))
+ (+ (posn-x (world-ufo w)) UFO-SPEED)]
+ [else (posn-x (world-ufo w))])
+ (posn-y (world-ufo w)))
+ (world-cows w)))
+
+;ufo-done? : world -> boolean
+;consumes a world and returns true if the ufo is touching any cow or the ground; otherwise, returns false
+(define (ufo-done? w)
+ (or
+ (anything-touching-cow? (world-ufo w)
+ HALF-UFO-WIDTH
+ HALF-UFO-HEIGHT
+ (world-cows w))
+ (hitting-wall? (world-ufo w) "down")))
+
+
+;anything-touching-cow? : posn num num list-of-posns -> boolean
+;anything-touching-cow? consumes a posn, an image height, an image width, and a list-of-cows and returns true if the image at the posns is touching any of the cows in the list based on the image height and width, otherwise returns false
+(define (anything-touching-cow? img-p img-w img-h aloc)
+ (cond
+ [(null? aloc) false]
+ [(pair? aloc)
+ (or
+ (and
+ (or
+ (and (>= (- (posn-x img-p) img-w) (- (posn-x (cow-p (car aloc))) HALF-COW-WIDTH))
+ (<= (- (posn-x img-p) img-w) (+ (posn-x (cow-p (car aloc))) HALF-COW-WIDTH)))
+ (and (>= (+ (posn-x img-p) img-w) (- (posn-x (cow-p (car aloc))) HALF-COW-WIDTH))
+ (<= (+ (posn-x img-p) img-w) (+ (posn-x (cow-p (car aloc))) HALF-COW-WIDTH))))
+ (>= (+ (posn-y img-p) img-h) (- (posn-y (cow-p (car aloc))) HALF-COW-HEIGHT)))
+ (anything-touching-cow? img-p img-w img-h (cdr aloc)))]))
+
+
+;remove-cow-from-list : cow list-of-cows -> list-of-cows
+;remove-cow-from-list consumes a cow and a list-of-cows and returns a list-of-cows with cow removed
+(define (remove-cow-from-list c aloc)
+ (cond
+ [(null? aloc) '()]
+ [(pair? aloc) (cond
+ [(posn=? (cow-p c) (cow-p (car aloc))) (cdr aloc)]
+ [else (cons (car aloc) (remove-cow-from-list c (cdr aloc)))])]))
+
+
+;process-cows : world -> world
+;process-cows consumes a world and produces a world with the cows moved and hit-tested
+(define (process-cows w)
+ (make-world (world-ufo w) (move-cows (new-dirs (world-cows w) (world-cows w)))))
+
+
+;move-all-on-tick : world -> world
+;move-all-on-tick consumes a world and produces a world with all objects inside of it moved every "tick" of big-bang
+(define (move-all-on-tick w)
+ (process-cows (move-ufo-y w)))
+
+
+;move-cows : list-of-cows -> list-of-cows
+;move-cows consumes a list-of-cows and produces a list of cows moved to the left or right depending on the cows' directions
+(define (move-cows aloc)
+ (cond
+ [(null? aloc) '()]
+ [(pair? aloc) (cons
+ (make-cow
+ (make-posn
+ (
+ (cond
+ [(string=? (cow-dir (car aloc)) "right") +]
+ [(string=? (cow-dir (car aloc)) "left") -])
+ (posn-x (cow-p (car aloc))) COW-SPEED)
+ (posn-y (cow-p (car aloc))))
+ (cow-dir (car aloc)))
+ (move-cows (cdr aloc)))]))
+
+
+;new-dirs : list-of-cows list-of-cows -> list-of-cows
+;consumes two identical lists-of-cows and produces a list-of-cows in which all cows' dirs are updated
+;e.g. changes the cow's direction if it collides with another cow or reaches the edge of the screen, otherwise leaves it unchanged
+(define (new-dirs aloc1 aloc2)
+ (cond
+ [(null? aloc1) '()]
+ [(pair? aloc1) (cons (make-cow (cow-p (car aloc1))
+ (update-dir (car aloc1) aloc2))
+ (new-dirs (cdr aloc1) aloc2))]))
+
+
+;update-dir : cow list-of-cows -> String
+;update-dir consumes a cow and a list-of-cows and changes it's direction if it hits a wall or another cow
+(define (update-dir c aloc)
+ (cond
+ [(hitting-wall? (cow-p c) "right") "left"]
+ [(hitting-wall? (cow-p c) "left") "right"]
+ [(anything-touching-cow? (cow-p c) HALF-COW-WIDTH HALF-COW-HEIGHT (remove-cow-from-list c aloc))
+ (cond
+ [(string=? (cow-dir c) "left") "right"]
+ [(string=? (cow-dir c) "right") "left"])]
+ [else (cow-dir c)]))
+
+;hitting-wall? : posn String -> boolean
+;hitting-wall? consumes a posn and a direction and returns true if the posn is past the edge of the screen in that direction
+;otherwise returns false
+(define (hitting-wall? p dir)
+ (cond
+ [(string=? dir "right") (> (posn-x p) SCREEN-WIDTH)]
+ [(string=? dir "left") (< (posn-x p) 0)]
+ [(string=? dir "down") (> (posn-y p) SCREEN-HEIGHT)]))
+
+
+;posn=? : posn posn -> boolean
+;posn=? consumes two posns and returns true if they are equal, otherwise returns false
+(define (posn=? p1 p2)
+ (and
+ (= (posn-x p1) (posn-x p2))
+ (= (posn-y p1) (posn-y p2))))
+
+
+;big-bang creates the world
+(big-bang world0
+ (to-draw draw)
+ (on-key move-ufo-x)
+ (on-tick move-all-on-tick)
+ (stop-when ufo-done?))
@@ -1,6 +1,7 @@
#lang planet dyoo/whalesong
-(require (planet dyoo/whalesong/world))
+(require (planet dyoo/whalesong/world)
+ (planet dyoo/whalesong/image))
(define handler (on-tick add1 1))
View
@@ -1,6 +1,8 @@
#lang planet dyoo/whalesong
-(require (planet dyoo/whalesong/world))
+(require (planet dyoo/whalesong/world)
+ (planet dyoo/whalesong/image)
+ )
;; Constants:
@@ -1,6 +1,7 @@
#lang planet dyoo/whalesong
(require (planet dyoo/whalesong/world)
+ (planet dyoo/whalesong/image)
(planet dyoo/whalesong/js))
;; Occupy the whole screen.
View
@@ -1,6 +1,7 @@
#lang planet dyoo/whalesong
-(require (planet dyoo/whalesong/world))
+(require (planet dyoo/whalesong/world)
+ (planet dyoo/whalesong/image))
(define-struct world (x direction))
View
@@ -1,6 +1,4 @@
#lang s-exp "lang/base.rkt"
(require "world/main.rkt")
-(require "image.rkt")
-(provide (all-from-out "world/main.rkt")
- (all-from-out "image.rkt"))
+(provide (all-from-out "world/main.rkt"))

0 comments on commit 4578338

Please sign in to comment.