From 9d23e66fe8332abc7a1bbd9022f3e58e1133b3fb Mon Sep 17 00:00:00 2001 From: rsiddharth Date: Fri, 3 Jul 2020 15:49:09 -0400 Subject: name directories like the realm repo. --- chapter5/guess.rkt | 75 +++++++++++++++ chapter5/loco.rkt | 59 ++++++++++++ chapter5/resources/caroille.png | Bin 0 -> 886 bytes chapter5/resources/caroille.svg | 125 ++++++++++++++++++++++++ chapter5/resources/ufo-fart.png | Bin 0 -> 868 bytes chapter5/resources/ufo-fart.svg | 188 +++++++++++++++++++++++++++++++++++++ chapter5/resources/zarking-ufo.png | Bin 0 -> 1337 bytes chapter5/resources/zarking-ufo.svg | 128 +++++++++++++++++++++++++ chapter5/ufo.rkt | 86 +++++++++++++++++ 9 files changed, 661 insertions(+) create mode 100644 chapter5/guess.rkt create mode 100644 chapter5/loco.rkt create mode 100644 chapter5/resources/caroille.png create mode 100644 chapter5/resources/caroille.svg create mode 100644 chapter5/resources/ufo-fart.png create mode 100644 chapter5/resources/ufo-fart.svg create mode 100644 chapter5/resources/zarking-ufo.png create mode 100644 chapter5/resources/zarking-ufo.svg create mode 100644 chapter5/ufo.rkt (limited to 'chapter5') diff --git a/chapter5/guess.rkt b/chapter5/guess.rkt new file mode 100644 index 0000000..f7a117a --- /dev/null +++ b/chapter5/guess.rkt @@ -0,0 +1,75 @@ +#lang racket +(require 2htdp/universe 2htdp/image) + +(struct interval (small big guesses)) + +;;; constants +(define TEXT-SIZE 12) +(define HELP-TEXT + (text "↑ for larger numbers, ↓ for smaller ones" + TEXT-SIZE + "blue")) +(define HELP-TEXT2 + (text "Press = when your number is guessed; q to quit." + TEXT-SIZE + "blue")) +(define COLOR "red") +(define WIDTH (+ (image-width HELP-TEXT2) 10)) +(define HEIGHT 150) +(define SIZE 72) +(define TEXT-X 3) +(define TEXT-UPPER-Y 10) +(define TEXT-LOWER-Y 135) +(define GUESSES-SIZE 12) +(define GUESSES-COLOR "green") +(define MT-SC + (place-image/align + HELP-TEXT TEXT-X TEXT-UPPER-Y "left" "top" + (place-image/align + HELP-TEXT2 TEXT-X TEXT-LOWER-Y "left" "bottom" + (empty-scene WIDTH HEIGHT)))) + +;; main +(define (start lower upper) + (big-bang (interval lower upper 0) + (on-key deal-with-guess) + (to-draw render) + (stop-when single? render-last-scene))) + +;; key events +(define (deal-with-guess w key) + (cond [(key=? key "up") (bigger w)] + [(key=? key "down") (smaller w)] + [(key=? key "q") (stop-with w)] + [(key=? key "=") (stop-with w)] + [else w])) + +(define (smaller w) + (interval (interval-small w) + (max (interval-small w) (sub1 (guess w))) + (+ 1 (interval-guesses w)))) + +(define (bigger w) + (interval (min (interval-big w) (add1 (guess w))) + (interval-big w) + (+ 1 (interval-guesses w)))) + +(define (guess w) + (quotient (+ (interval-small w) (interval-big w)) 2)) + +(define (render w) + (overlay (overlay/offset + (text (number->string (guess w)) SIZE COLOR) 0 40 + (text (number->string (interval-guesses w)) + GUESSES-SIZE GUESSES-COLOR)) + MT-SC)) + +(define (render-last-scene w) + (overlay (overlay/offset + (text "End" SIZE COLOR) 0 40 + (text (number->string (interval-guesses w)) + GUESSES-SIZE GUESSES-COLOR)) + MT-SC)) + +(define (single? w) + (= (interval-small w) (interval-big w))) diff --git a/chapter5/loco.rkt b/chapter5/loco.rkt new file mode 100644 index 0000000..977c976 --- /dev/null +++ b/chapter5/loco.rkt @@ -0,0 +1,59 @@ +#lang racket +(require 2htdp/universe 2htdp/image) + +(define WIDTH 300) +(define HEIGHT 300) +(define CAROILLE (bitmap/file "resources/caroille.png")) +(define CAROILLE-WIDTH (image-width CAROILLE)) + +;;; +;;; If the car is placed at X = 1/2 its width, its back will be +;;; touching the left edge of the World. +;;; +;;; If the car is place at X = - 1/2 its width, its front will be touching +;;; the left edge of the World. +;;; +(define CAROILLE-WIDTH-HALF (/ CAROILLE-WIDTH 2.0)) + +;;; Structure to represent the X position of two cars in animation. +(struct cars (one two)) + +(define (caroille-past-right-edge? pos) + (> pos (- WIDTH CAROILLE-WIDTH-HALF))) + +(define (caroille-fully-past-right-edge? pos) + (>= pos (+ WIDTH CAROILLE-WIDTH-HALF))) + +(define (caroille-fully-past-left-edge? pos) + (>= pos CAROILLE-WIDTH-HALF)) + +(define (caroille-fully-inside? pos) + (and (caroille-fully-past-left-edge? pos) + (not (caroille-past-right-edge? pos)))) + +(define (move caroilles) + (let ((caroille-one (cars-one caroilles)) + (caroille-two (cars-two caroilles))) + (cond + ;; Case set I - one of the cars is fully inside. + ((caroille-fully-inside? caroille-one) + (cars (+ 1 caroille-one) caroille-two)) + ((caroille-fully-inside? caroille-two) + (cars caroille-one (+ 1 caroille-two))) + ;; Case set II - one of the cars disappeared into the right edge. + ((caroille-fully-past-right-edge? caroille-one) + (cars (- CAROILLE-WIDTH-HALF) (+ 1 caroille-two))) + ((caroille-fully-past-right-edge? caroille-two) + (cars (+ 1 caroille-one) (- CAROILLE-WIDTH-HALF))) + ;; Case else - Both cars are partially out. + (else (cars (+ 1 caroille-one) (+ 1 caroille-two)))))) + +(define (draw-cars caroilles) + (place-image CAROILLE (cars-one caroilles) (/ HEIGHT 2) + (place-image CAROILLE (cars-two caroilles) (/ HEIGHT 2) + (empty-scene WIDTH HEIGHT)))) + +(define (start) + (big-bang (cars CAROILLE-WIDTH-HALF (- CAROILLE-WIDTH-HALF)) + (on-tick move) + (to-draw draw-cars))) diff --git a/chapter5/resources/caroille.png b/chapter5/resources/caroille.png new file mode 100644 index 0000000..052cc58 Binary files /dev/null and b/chapter5/resources/caroille.png differ diff --git a/chapter5/resources/caroille.svg b/chapter5/resources/caroille.svg new file mode 100644 index 0000000..eb4db63 --- /dev/null +++ b/chapter5/resources/caroille.svg @@ -0,0 +1,125 @@ + + + + + caroille + + + + + + + + image/svg+xml + + caroille + + 2018-04-02 + + + rsiddharth <s@ricketyspace.net> + + + + + car + + + + + + + + + + + + + + + + + + + diff --git a/chapter5/resources/ufo-fart.png b/chapter5/resources/ufo-fart.png new file mode 100644 index 0000000..13d1c4a Binary files /dev/null and b/chapter5/resources/ufo-fart.png differ diff --git a/chapter5/resources/ufo-fart.svg b/chapter5/resources/ufo-fart.svg new file mode 100644 index 0000000..cf86021 --- /dev/null +++ b/chapter5/resources/ufo-fart.svg @@ -0,0 +1,188 @@ + + + + + UFO Fart + + + + + + image/svg+xml + + UFO Fart + + 2018-04-17 + + + rsiddharth <s@ricketyspace.net> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/chapter5/resources/zarking-ufo.png b/chapter5/resources/zarking-ufo.png new file mode 100644 index 0000000..bd5eb43 Binary files /dev/null and b/chapter5/resources/zarking-ufo.png differ diff --git a/chapter5/resources/zarking-ufo.svg b/chapter5/resources/zarking-ufo.svg new file mode 100644 index 0000000..84b8844 --- /dev/null +++ b/chapter5/resources/zarking-ufo.svg @@ -0,0 +1,128 @@ + + + + + Zarking UFO + + + + + + image/svg+xml + + Zarking UFO + + 2018-03-09 + + + rsiddharth <s@ricketyspace.net> + + + + + + + + + + + + + + + + + + + + diff --git a/chapter5/ufo.rkt b/chapter5/ufo.rkt new file mode 100644 index 0000000..6f8136c --- /dev/null +++ b/chapter5/ufo.rkt @@ -0,0 +1,86 @@ +#lang racket +(require 2htdp/universe 2htdp/image) + +;;; world structure +(struct ufo (x y fart)) + +;;; constants +(define WORLD-WIDTH 300) +(define WORLD-HEIGHT 325) +(define MOVE-LEN 3) +(define UFO (bitmap/file "resources/zarking-ufo.png")) +(define UFO-FART (bitmap/file "resources/ufo-fart.png")) +(define UFO-WIDTH (image-width UFO)) +(define UFO-HEIGHT (image-height UFO)) +(define UFO-FART-HEIGHT (image-height UFO-FART)) + +;;; ufo movement functions +(define (ufo-move-up current-state) + (let ((x (ufo-x current-state)) + (y-up (- (ufo-y current-state) MOVE-LEN)) + (fart #t)) + (cond [(>= y-up (+ (/ UFO-HEIGHT 2) (/ UFO-FART-HEIGHT 2))) + (ufo x y-up fart)] + [else current-state]))) + +(define (ufo-move-down current-state) + (let ((x (ufo-x current-state)) + (y-down (+ (ufo-y current-state) MOVE-LEN))) + (cond [(<= y-down (- (+ WORLD-HEIGHT (/ UFO-FART-HEIGHT 2)) + (/ UFO-HEIGHT 2))) + (ufo x y-down #t)] + [else current-state]))) + + +(define (ufo-move-left current-state) + (let ((x-left (- (ufo-x current-state) MOVE-LEN)) + (y (ufo-y current-state)) + (fart #t)) + (cond [(>= x-left (/ UFO-WIDTH 2)) + (ufo x-left y fart)] + [else current-state]))) + +(define (ufo-move-right current-state) + (let ((x-right (+ (ufo-x current-state) MOVE-LEN)) + (y (ufo-y current-state)) + (fart #t)) + (cond [(<= x-right (- WORLD-WIDTH (/ UFO-WIDTH 2))) + (ufo x-right y fart)] + [else current-state]))) + + +;;; big bang functions +(define (draw-a-ufo current-state) + (place-image (overlay/align/offset + "middle" "bottom" UFO 0 35 + (if (ufo-fart current-state) + UFO-FART + (circle 0 "outline" "white"))) + (ufo-x current-state) + (ufo-y current-state) + (empty-scene WORLD-WIDTH WORLD-HEIGHT))) + +(define (add-3-to-posy current-state) + (ufo (ufo-x current-state) + (+ (ufo-y current-state) 3))) + +(define (posy-is-300 current-state) + (>= (ufo-y current-state) 300)) + +(define (move-ufo current-state key) + (cond [(key=? key "up") (ufo-move-up current-state)] + [(key=? key "down") (ufo-move-down current-state)] + [(key=? key "left") (ufo-move-left current-state)] + [(key=? key "right") (ufo-move-right current-state)] + [else current-state])) + +(define (ufo-stopped current-state key) + (let ((fart #f)) + (ufo (ufo-x current-state) (ufo-y current-state) fart))) + +;;; the big bang +(big-bang (ufo (/ WORLD-WIDTH 2) (/ WORLD-HEIGHT 2) #f) + (to-draw draw-a-ufo) + (on-key move-ufo) + (on-release ufo-stopped)) + -- cgit v1.2.3