├── .gitignore ├── 2d-tests.rkt ├── 2d.rkt ├── 3d-tests.rkt ├── 3d.rkt ├── GClef.png ├── GClef.svg ├── LICENSE ├── README.md ├── asteroids-tests.rkt ├── asteroids1.rkt ├── asteroids2.rkt ├── asteroids3.rkt ├── asteroids4.rkt ├── asteroids5.rkt ├── asteroids6.rkt ├── boids1.rkt ├── boids2.rkt ├── boids3.rkt ├── boulder1.rkt ├── boulder2.rkt ├── boulder3.rkt ├── forest1.rkt ├── images ├── asteroids5.png ├── boulder.png ├── boulder2-screenshot.png ├── deadfred.png ├── dragon.png ├── falling-boulder.png ├── gem.gif ├── mud.gif ├── smallface.gif ├── space-pizza.png ├── spaceship.png ├── spaceship2.png ├── stars7.png └── wall.gif ├── learn-music-phrase1-tests.rkt ├── learn-music-phrase1.rkt ├── learn-music-phrase2-tests.rkt ├── learn-music-phrase2.rkt ├── learn-music1.rkt ├── learn-music2.rkt ├── learn-music3.rkt ├── learn-music4.rkt ├── stars.rkt ├── stars2.rkt ├── stars3.rkt ├── stars4.rkt ├── stars5.rkt ├── stars6.rkt ├── stars7.rkt ├── thrust-tests.rkt ├── thrust1.rkt ├── thrust2.rkt ├── tree1.rkt ├── tree1b.rkt ├── tree2.rkt ├── tree2b.rkt ├── tree3.rkt └── util.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | .DS_Store 3 | compiled -------------------------------------------------------------------------------- /2d-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require rackunit) 4 | (require "2d.rkt") 5 | 6 | (test-case 7 | "tests pos to angles and distances" 8 | (check-= (angle-between (pos 100 100) (pos 100 200)) 9 | 90 0.01) 10 | (check-= (angle-between (pos 100 100) (pos 150 150)) 11 | 45 0.01) 12 | (check-= (angle-between (pos 0 0) (pos 50 50)) 13 | 45 0.01) 14 | (check-= (angle-between (pos 0 0) (pos 0 50)) 15 | 90 0.01) 16 | (check-= (angle-between (pos 0 0) (pos -50 -50)) 17 | -135 0.01) 18 | 19 | (check-= (distance-between (pos 100 100) (pos 200 100)) 20 | 100 0.01) 21 | (check-= (distance-between (pos 0 0) (pos 100 100)) 22 | 141.42 0.01)) 23 | 24 | ;; --------------------------------------------------------- 25 | 26 | (test-case 27 | "tests for between" 28 | (check-true (between? 5 3 12)) 29 | (check-true (between? 9 11 9))) 30 | 31 | (test-case 32 | "tests for inside circle" 33 | (check-true (inside-circle? (pos 0 0) 10 (pos 7 7))) 34 | (check-true (inside-circle? (pos 0 0) 10 (pos -7 -7))) 35 | (check-false (inside-circle? (pos 0 0) 10 (pos 8 8)))) 36 | 37 | (test-case 38 | "tests for inside rectangle" 39 | (check-true (inside-rect? (pos 0 0) (pos 100 10) (pos 99 10))) 40 | (check-false (inside-rect? (pos 0 0) (pos 100 10) (pos 101 10))) 41 | (check-true (inside-rect? (pos 50 -10) (pos -50 0) (pos 0 -5))) 42 | (check-false (inside-rect? (pos 100 0) (pos 95 1000) (pos 101 100))) 43 | ) 44 | 45 | (test-case 46 | "tests for inside triangle" 47 | (check-true (inside-triangle? (list (pos 0 0) (pos 100 100) (pos 5 50)) 48 | (pos 50 50))) 49 | (check-false (inside-triangle? (list (pos 0 0) (pos 100 100) (pos 5 50)) 50 | (pos 51 50))) 51 | (check-true (inside-triangle? (list (pos 0 0) (pos 100 100) (pos 5 50)) 52 | (pos 2.5 25)))) -------------------------------------------------------------------------------- /2d.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; Functions for 2d drawing and transformation 4 | 5 | (require lang/posn) 6 | 7 | (struct pos (x y) #:transparent) 8 | 9 | (define (move-pos a-pos a-direction a-speed) 10 | (define r (degrees->radians a-direction)) 11 | (pos (+ (pos-x a-pos) (* a-speed (cos r))) 12 | (+ (pos-y a-pos) (* a-speed (sin r))))) 13 | 14 | (define (add-direction-speeds d1 s1 d2 s2) 15 | ;; Given two direction & speed pairs, calculate the 16 | ;; combined effect and return new direction and speed 17 | (if (and (zero? s1) (zero? s2)) 18 | (list d1 0) 19 | (let* ([vec1 (move-pos (pos 0 0) d1 s1)] 20 | [vec2 (move-pos (pos 0 0) d2 s2)] 21 | [c-vec (pos (+ (pos-x vec1) (pos-x vec2)) 22 | (+ (pos-y vec1) (pos-y vec2)))] 23 | [direction (radians->degrees 24 | (atan (pos-y c-vec) 25 | (pos-x c-vec)))] 26 | [speed (sqrt (+ (sqr (pos-x c-vec)) 27 | (sqr (pos-y c-vec))))]) 28 | (list direction speed)))) 29 | 30 | (define (pos->posn points) 31 | (map (λ (p) (make-posn (pos-x p) (pos-y p))) 32 | points)) 33 | 34 | (define (pos-dx a-pos b-pos) 35 | (- (pos-x b-pos) (pos-x a-pos))) 36 | 37 | (define (pos-dy a-pos b-pos) 38 | (- (pos-y b-pos) (pos-y a-pos))) 39 | 40 | (define (angle-between a-pos b-pos) 41 | (radians->degrees 42 | (atan (pos-dy a-pos b-pos) 43 | (pos-dx a-pos b-pos)))) 44 | 45 | (define (distance-between a-pos b-pos) 46 | (sqrt (+ (sqr (pos-dx a-pos b-pos)) 47 | (sqr (pos-dy a-pos b-pos))))) 48 | 49 | (define (points-around-centre centre-pos radius step) 50 | (for/list ([a (range 0 360 step)]) 51 | (move-pos centre-pos a radius))) 52 | 53 | ;; ----------------------------------------------------------- 54 | 55 | (define (inside-circle? circle-pos radius a-pos) 56 | (define distance 57 | (sqrt (+ (expt (- (pos-x a-pos) (pos-x circle-pos)) 2) 58 | (expt (- (pos-y a-pos) (pos-y circle-pos)) 2)))) 59 | (<= distance radius)) 60 | 61 | (define (between? a x y) 62 | "Is a between x and y?" 63 | (or (<= x a y) 64 | (>= x a y))) 65 | 66 | (define (inside-rect? rpos1 rpos2 a-pos) 67 | "Is a-pos inside the rectangle defined by corners rpos1 and 2?" 68 | (and (between? (pos-x a-pos) (pos-x rpos1) (pos-x rpos2)) 69 | (between? (pos-y a-pos) (pos-y rpos1) (pos-y rpos2)))) 70 | 71 | (define (inside-triangle? points a-pos) 72 | "Is a-pos inside this triangle defined by the 3 points?" 73 | (let* ([angle1-2 (angle-between (first points) (second points))] 74 | [angle1-3 (angle-between (first points) (third points))] 75 | [angle1-a (angle-between (first points) a-pos)] 76 | [angle2-1 (angle-between (second points) (first points))] 77 | [angle2-3 (angle-between (second points) (third points))] 78 | [angle2-a (angle-between (second points) a-pos)]) 79 | (and (between? angle1-a angle1-2 angle1-3) 80 | (between? angle2-a angle2-1 angle2-3)))) 81 | 82 | ;; ----------------------------------------------------------- 83 | 84 | (provide pos pos-x pos-y pos->posn 85 | move-pos add-direction-speeds angle-between distance-between 86 | points-around-centre 87 | between? inside-circle? inside-rect? inside-triangle?) 88 | -------------------------------------------------------------------------------- /3d-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rackunit "3d.rkt") 4 | 5 | (test-case 6 | "tests for point distances" 7 | (check-equal? (point-distance (point 0 0 0) (point 0 0 0)) 8 | 0) 9 | (check-equal? (point-distance (point 3 4 0) (point 0 0 0)) 10 | 5) 11 | (check-equal? (point-distance (point 3 0 4) (point 0 0 0)) 12 | 5) 13 | (check-equal? (point-distance (point 3 3 3) (point 0 0 0)) 14 | (sqrt 27)) 15 | (check-equal? (point-distance (point 1 2 3) (point -2 -1 0)) 16 | (sqrt 27)) 17 | 18 | ) 19 | -------------------------------------------------------------------------------- /3d.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Screen size 4 | (define WIDTH 1000) 5 | (define HEIGHT 600) 6 | 7 | ;; A point in 3D space and a direction 8 | (struct point (x y z) #:transparent) 9 | (struct direction (inclination azimuth) #:transparent) 10 | ;; https://en.wikipedia.org/wiki/Spherical_coordinate_system 11 | 12 | ;; ----------------------------------------------------------- 13 | 14 | ;; Translation to screen x and y co-ords 15 | (define (screen-x p) (+ (/ (point-x p) (point-z p)) (/ WIDTH 2))) 16 | (define (screen-y p) (+ (/ (point-y p) (point-z p)) (/ HEIGHT 2))) 17 | (define (screen-size size p) 18 | ;; How big does s appear at pos p? 19 | ;; TODO: this should take into account distances x, y and z 20 | (if (> (point-z p) 0) 21 | (/ size (point-z p)) 22 | 0)) 23 | 24 | (define (point-distance p1 p2) 25 | (let ([dx (- (point-x p1) (point-x p2))] 26 | [dy (- (point-y p1) (point-y p2))] 27 | [dz (- (point-z p1) (point-z p2))]) 28 | (sqrt (+ (* dx dx) (* dy dy) (* dz dz))))) 29 | ;; http://math.stackexchange.com/questions/42640/calculate-distance-in-3d-space 30 | 31 | ;; ----------------------------------------------------------- 32 | 33 | 34 | (define (move-point p dir dist) 35 | ;; Return new xyz by moving a distance in a direction 36 | 37 | ;; x= r * sin azimuth * cos inclination 38 | ;; y= r * sin azimuth * sin inclination 39 | ;; z= r * cos azimuth 40 | 41 | (define inc (direction-inclination dir)) 42 | (define az (direction-azimuth dir)) 43 | 44 | (define dx (* dist (sin az) (cos inc))) 45 | (define dy (* dist (sin az) (sin inc))) 46 | (define dz (* dist (cos az))) 47 | 48 | (point (+ (point-x p) dx) 49 | (+ (point-y p) dy) 50 | (+ (point-z p) dz))) 51 | 52 | (define (add-points point1 point2) 53 | (point (+ (point-x point1) (point-x point2)) 54 | (+ (point-y point1) (point-y point2)) 55 | (+ (point-z point1) (point-z point2)))) 56 | 57 | (define (change-direction dir dir2) 58 | (direction (+ (direction-inclination dir) (direction-inclination dir2)) 59 | (+ (direction-azimuth dir) (direction-azimuth dir2)))) 60 | 61 | ;; ----------------------------------------------------------- 62 | 63 | (provide WIDTH HEIGHT 64 | screen-x screen-y screen-size 65 | point-distance 66 | move-point add-points change-direction 67 | (struct-out point) 68 | (struct-out direction)) -------------------------------------------------------------------------------- /GClef.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ericclack/racket-examples/ee858daac3577ead0c8463b9701a8653220039de/GClef.png -------------------------------------------------------------------------------- /GClef.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # racket-examples 2 | A set of example Racket games and demos that I created on my journey learning Racket. They use the [How to Design Programs](https://htdp.org/2019-02-24/) framework and demonstrate sprites, worlds, animation and game logic. 3 | 4 | My starting place for learning Racket was the books: Realm of Racket http://www.realmofracket.com/, The Little Schemer and The Seasoned Schemer https://mitpress.mit.edu/books/little-schemer-fourth-edition 5 | 6 | After that I created a set of games / demos (which you'll find in this repo), to help me prove I understood the principles and explore the language further. The games are pretty basic, but hopefully interesting to explore. 7 | 8 | If you find these examples useful feel free to leave suggestions on the issues page, or email me comments. 9 | 10 | Some thoughts on Racket: 11 | 12 | * I found each game pretty hard to write (my background is Python and other procedural languages) but once complete, surprising low in defects. 13 | * After getting over the lack of objects I found the functional approach produced a simpler design. 14 | * When making a game do objects and mutable state better model what's going on? 15 | 16 | Contents: 17 | 18 | * `asteroids` -- a simple arcade game. 19 | 20 | ![asteroids screen shot](/images/asteroids5.png) 21 | 22 | * `boids` -- bird like objects that flock together. 23 | 24 | * `boulder` -- a take on Boulder Dash. 25 | 26 | ![boulder screen shot](/images/boulder2-screenshot.png) 27 | 28 | * `learn-music` -- learn to read music with the guitar. Read more on my blog: http://ericclack.blogspot.co.uk/2015/12/learn-to-read-music-with-racket-scheme.html 29 | 30 | * `learn-music-phrase` -- like `learn-music` but presents sequences of notes to practice. 31 | 32 | * `stars` -- experiments with very basic 3d graphics, including stars and aliens with random 3d paths. 33 | 34 | ![stars screen shot](/images/stars7.png) 35 | 36 | * `thrust` -- a take on the game Thrust from 1986. 37 | 38 | --- 39 | 40 | Many of the app filenames have numbers, these indicate major changes -- 41 | so it's easy to look back at previous, simpler versions. 42 | -------------------------------------------------------------------------------- /asteroids-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require rackunit) 4 | (require/expose "asteroids6.rkt" (pos pos-x pos-y move-pos add-direction-speeds)) 5 | 6 | (define (check-equal-pos? pos1 pos2) 7 | (check-= (pos-x pos1) (pos-x pos2) 0.01) 8 | (check-= (pos-y pos1) (pos-y pos2) 0.01)) 9 | 10 | (test-case 11 | "move-pos tests" 12 | (check-equal-pos? (move-pos (pos 0 0) 90 5) 13 | (pos 0.0 5.0)) 14 | (check-equal-pos? (move-pos (pos 0 0) 180 5) 15 | (pos -5.0 0.0)) 16 | (check-equal-pos? (move-pos (pos 0 0) 270 5) 17 | (pos -0.0 -5.0)) 18 | (check-equal-pos? (move-pos (pos 0 0) 0 5) 19 | (pos 5 0)) 20 | ) 21 | 22 | (define (check-equal-list? list1 list2) 23 | (check-= (first list1) (first list2) 0.01) 24 | (check-= (second list1) (second list2) 0.01)) 25 | 26 | (test-case 27 | "tests for add-direction-speeds" 28 | (check-equal-list? (add-direction-speeds 0 0 90 5) 29 | (list 90.0 5.0)) 30 | (check-equal-list? (add-direction-speeds 0 0 180 5) 31 | (list 180.0 5.0)) 32 | (check-equal-list? (add-direction-speeds 0 0 270 5) 33 | (list -90.0 5.0)) 34 | (check-equal-list? (add-direction-speeds 0 0 0 5) 35 | (list 0 5)) 36 | 37 | (check-equal-list? (add-direction-speeds 0 0 45 5) 38 | (list 45.0 5.0)) 39 | (check-equal-list? (add-direction-speeds 0 0 135 5) 40 | (list 135.0 5.0)) 41 | (check-equal-list? (add-direction-speeds 0 0 225 5) 42 | (list -135 5.0)) 43 | (check-equal-list? (add-direction-speeds 0 0 295 5) 44 | (list -65 5.0)) 45 | 46 | ) 47 | -------------------------------------------------------------------------------- /asteroids1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | 5 | TODO: 6 | - Shooting 7 | - Splitting asteroids 8 | - Score 9 | - Moving ship 10 | |# 11 | 12 | (require 2htdp/universe 2htdp/image) 13 | (require "util.rkt") 14 | 15 | (struct world (asteroids ship) #:transparent) 16 | (struct pos (x y) #:transparent) 17 | (struct ship (pos direction speed) #:transparent) 18 | (struct asteroid (pos direction speed size) #:transparent) 19 | 20 | (define BIG-ASTEROID 60) 21 | (define NUM-ASTEROIDS 10) 22 | 23 | (define TICK-RATE 1/30) 24 | (define WIDTH 800) 25 | (define HEIGHT 600) 26 | 27 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 28 | 29 | (define (new-asteroid) 30 | (asteroid (pos (random WIDTH) (random HEIGHT)) 31 | (random 360) (+ 1 (random 2)) (random BIG-ASTEROID))) 32 | 33 | (define (move-pos a-pos a-direction a-speed) 34 | (define r (degrees->radians a-direction)) 35 | (pos (+ (pos-x a-pos) (* a-speed (cos r))) 36 | (+ (pos-y a-pos) (* a-speed (sin r))))) 37 | 38 | (define (wrap-pos a-pos a-size) 39 | (define x (pos-x a-pos)) 40 | (define y (pos-y a-pos)) 41 | (pos (cond 42 | [(> x (+ WIDTH a-size)) (- 0 a-size)] 43 | [(< x (- 0 a-size)) (+ WIDTH a-size)] 44 | [else x]) 45 | (cond 46 | [(> y (+ HEIGHT a-size)) (- 0 a-size)] 47 | [(< y (- 0 a-size)) (+ HEIGHT a-size)] 48 | [else y]))) 49 | 50 | (define (move-asteroid a) 51 | (asteroid (wrap-pos 52 | (move-pos (asteroid-pos a) (asteroid-direction a) (asteroid-speed a)) 53 | (asteroid-size a)) 54 | (asteroid-direction a) 55 | (asteroid-speed a) 56 | (asteroid-size a))) 57 | 58 | (define (next-world w) 59 | (world (map move-asteroid (world-asteroids w)) 60 | (world-ship w))) 61 | 62 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 63 | ;; Rendering 64 | 65 | (define (img+scene pos img scene) 66 | (place-image img (pos-x pos) (pos-y pos) scene)) 67 | 68 | (define (ship+scene a-ship scene) 69 | (img+scene (ship-pos a-ship) 70 | (rotate (ship-direction a-ship) 71 | (triangle 40 "solid" "white")) 72 | scene)) 73 | 74 | (define (asteroids+scene asteroids scene) 75 | (foldl (λ (a scene) 76 | (img+scene (asteroid-pos a) 77 | (circle (asteroid-size a) "solid" "gray") 78 | scene)) 79 | scene asteroids)) 80 | 81 | (define (render-world w) 82 | (ship+scene (world-ship w) 83 | (asteroids+scene (world-asteroids w) 84 | (empty-scene WIDTH HEIGHT "black")))) 85 | 86 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 87 | 88 | (define (direct-ship w a-key) 89 | (define a-ship (world-ship w)) 90 | (define a-direction 91 | (cond 92 | [(key=? a-key "left") 93 | (+ (ship-direction a-ship) 5)] 94 | [(key=? a-key "right") 95 | (- (ship-direction a-ship) 5)])) 96 | (world (world-asteroids w) 97 | (ship (ship-pos a-ship) a-direction (ship-speed a-ship)))) 98 | 99 | (define (go) 100 | (big-bang (world (times-repeat NUM-ASTEROIDS (new-asteroid)) 101 | (ship (pos (/ WIDTH 2) (/ HEIGHT 2)) 0 0)) 102 | (on-tick next-world TICK-RATE) 103 | (on-key direct-ship) 104 | (to-draw render-world))) 105 | -------------------------------------------------------------------------------- /asteroids2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | 5 | TODO: 6 | - Score 7 | - Moving ship 8 | |# 9 | 10 | (require 2htdp/universe 2htdp/image) 11 | (require "util.rkt") 12 | 13 | (struct world (asteroids ship bullets) #:transparent) 14 | (struct pos (x y) #:transparent) 15 | (struct ship (pos direction speed) #:transparent) 16 | (struct asteroid (pos direction speed size) #:transparent) 17 | (struct bullet (pos direction speed) #:transparent) 18 | 19 | (define BIG-ASTEROID 60) 20 | (define NUM-ASTEROIDS 5) 21 | (define BULLET-SPEED 5) 22 | 23 | (define TICK-RATE 1/30) 24 | (define WIDTH 800) 25 | (define HEIGHT 600) 26 | 27 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 28 | 29 | (define (new-asteroid) 30 | (asteroid (pos (random WIDTH) (random HEIGHT)) 31 | (random 360) (+ 1 (random 2)) (random BIG-ASTEROID))) 32 | 33 | (define (move-pos a-pos a-direction a-speed) 34 | (define r (degrees->radians a-direction)) 35 | (pos (+ (pos-x a-pos) (* a-speed (cos r))) 36 | (+ (pos-y a-pos) (* a-speed (sin r))))) 37 | 38 | (define (wrap-pos a-pos a-size) 39 | (define x (pos-x a-pos)) 40 | (define y (pos-y a-pos)) 41 | (pos (cond 42 | [(> x (+ WIDTH a-size)) (- 0 a-size)] 43 | [(< x (- 0 a-size)) (+ WIDTH a-size)] 44 | [else x]) 45 | (cond 46 | [(> y (+ HEIGHT a-size)) (- 0 a-size)] 47 | [(< y (- 0 a-size)) (+ HEIGHT a-size)] 48 | [else y]))) 49 | 50 | (define (inside-circle circle-pos radius a-pos) 51 | (define distance 52 | (sqrt (+ (expt (- (pos-x a-pos) (pos-x circle-pos)) 2) 53 | (expt (- (pos-y a-pos) (pos-y circle-pos)) 2)))) 54 | (<= distance radius)) 55 | 56 | (define (bullet-in-range a-bullet) 57 | (define x (pos-x (bullet-pos a-bullet))) 58 | (define y (pos-y (bullet-pos a-bullet))) 59 | (and (> x 0) (< x WIDTH) (> y 0) (< y HEIGHT))) 60 | 61 | (define (move-asteroid a) 62 | (asteroid (wrap-pos 63 | (move-pos (asteroid-pos a) (asteroid-direction a) (asteroid-speed a)) 64 | (asteroid-size a)) 65 | (asteroid-direction a) 66 | (asteroid-speed a) 67 | (asteroid-size a))) 68 | 69 | (define (new-bullet a-ship) 70 | (bullet (ship-pos a-ship) 71 | (ship-direction a-ship) 72 | BULLET-SPEED)) 73 | 74 | (define (move-bullet b) 75 | (bullet (move-pos (bullet-pos b) (bullet-direction b) (bullet-speed b)) 76 | (bullet-direction b) 77 | (bullet-speed b))) 78 | 79 | (define (hit-asteroids asteroids bullets) 80 | ;; If any asteroids have been hit, split them in half. 81 | ;; Asteroids that are too small are deleted. 82 | 83 | ;; A list like this (a a a a a) will result in a list 84 | ;; like this (a a (a a) a a) on hit, we use flatten 85 | ;; to return the right thing. 86 | 87 | (define (hit-asteroid? a bullets) 88 | ;; Has this asteroid been hit by any of the bullets? 89 | (cond 90 | [(empty? bullets) #f] 91 | [(inside-circle (asteroid-pos a) (asteroid-size a) 92 | (bullet-pos (car bullets))) #t] 93 | [else 94 | (hit-asteroid? a (cdr bullets))])) 95 | 96 | (define (split-asteroid a) 97 | (list (asteroid (asteroid-pos a) (- (asteroid-direction a) 90) 98 | (asteroid-speed a) (/ (asteroid-size a) 2)) 99 | (asteroid (asteroid-pos a) (+ (asteroid-direction a) 90) 100 | (asteroid-speed a) (/ (asteroid-size a) 2)))) 101 | 102 | (define (bullets-hit-asteroid a) 103 | (if (hit-asteroid? a bullets) 104 | (split-asteroid a) 105 | a)) 106 | 107 | (define (big-enough a) 108 | (> (asteroid-size a) 5)) 109 | 110 | (filter big-enough (flatten (map bullets-hit-asteroid asteroids)))) 111 | 112 | 113 | (define (live-bullets asteroids bullets) 114 | ;; Like hit-asteroids, but returns only bullets that 115 | ;; have not hit an asteroid 116 | 117 | (define (bullet-hit? b asteroids) 118 | (cond 119 | [(empty? asteroids) #f] 120 | [(inside-circle (asteroid-pos (car asteroids)) 121 | (asteroid-size (car asteroids)) 122 | (bullet-pos b)) #t] 123 | [else (bullet-hit? b (cdr asteroids))])) 124 | 125 | (define (bullet-hit-no-asteroids b) 126 | (not (bullet-hit? b asteroids))) 127 | 128 | (filter bullet-hit-no-asteroids bullets)) 129 | 130 | 131 | (define (next-world w) 132 | (define next-asteroids (hit-asteroids (world-asteroids w) (world-bullets w))) 133 | (define next-bullets (live-bullets (world-asteroids w) (world-bullets w))) 134 | 135 | (world (map move-asteroid next-asteroids) 136 | (world-ship w) 137 | (filter bullet-in-range (map move-bullet next-bullets)))) 138 | 139 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 140 | ;; Rendering 141 | 142 | (define (img+scene pos img scene) 143 | (place-image img (pos-x pos) (pos-y pos) scene)) 144 | 145 | (define (ship-img a-direction) 146 | (rotate (- 270 a-direction) 147 | (overlay/offset (triangle 30 "solid" "white") 0 8 148 | (triangle 30 "solid" "white")))) 149 | 150 | (define (ship+scene a-ship scene) 151 | (img+scene (ship-pos a-ship) 152 | (ship-img (ship-direction a-ship)) 153 | scene)) 154 | 155 | (define (asteroids+scene asteroids scene) 156 | (foldl (λ (a scene) 157 | (img+scene (asteroid-pos a) 158 | (circle (asteroid-size a) "solid" "gray") 159 | scene)) 160 | scene asteroids)) 161 | 162 | (define (bullets+scene bullets scene) 163 | (foldl (λ (b scene) 164 | (img+scene (bullet-pos b) 165 | (circle 2 "solid" "yellow") 166 | scene)) 167 | scene bullets)) 168 | 169 | (define (render-world w) 170 | (ship+scene (world-ship w) 171 | (asteroids+scene (world-asteroids w) 172 | (bullets+scene (world-bullets w) 173 | (empty-scene WIDTH HEIGHT "black"))))) 174 | 175 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 176 | 177 | (define (direct-ship w a-key) 178 | (define a-ship (world-ship w)) 179 | (define a-direction 180 | (cond 181 | [(key=? a-key "left") 182 | (- (ship-direction a-ship) 5)] 183 | [(key=? a-key "right") 184 | (+ (ship-direction a-ship) 5)] 185 | [else (ship-direction a-ship)])) 186 | (define bullets 187 | (cond 188 | [(key=? a-key " ") (cons (new-bullet a-ship) (world-bullets w))] 189 | [else (world-bullets w)])) 190 | 191 | (world (world-asteroids w) 192 | (ship (ship-pos a-ship) a-direction (ship-speed a-ship)) 193 | bullets)) 194 | 195 | (define (go) 196 | (big-bang (world (times-repeat NUM-ASTEROIDS (new-asteroid)) 197 | (ship (pos (/ WIDTH 2) (/ HEIGHT 2)) 0 0) 198 | '()) 199 | (on-tick next-world TICK-RATE) 200 | (on-key direct-ship) 201 | (to-draw render-world))) 202 | -------------------------------------------------------------------------------- /asteroids3.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | 5 | DONE: 6 | - Don't start asteroids on top of ship 7 | - Bullet speed added to craft speed 8 | 9 | TODO: 10 | - Ship crashing into asteroids + lives 11 | - Score 12 | |# 13 | 14 | (require 2htdp/universe 2htdp/image) 15 | (require "util.rkt") 16 | 17 | (struct world (asteroids ship bullets) #:transparent) 18 | (struct pos (x y) #:transparent) 19 | (struct ship (pos direction speed) #:transparent) 20 | (struct asteroid (pos direction speed size) #:transparent) 21 | (struct bullet (pos direction speed) #:transparent) 22 | 23 | (define BIG-ASTEROID 60) 24 | (define NUM-ASTEROIDS 5) 25 | (define BULLET-SPEED 5) 26 | (define SHIP-SIZE 30) 27 | 28 | (define TICK-RATE 1/30) 29 | (define WIDTH 800) 30 | (define HEIGHT 600) 31 | 32 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 33 | 34 | (define (new-asteroid) 35 | (asteroid (pos (random WIDTH) (random HEIGHT)) 36 | (random 360) (+ 1 (random 2)) BIG-ASTEROID)) 37 | 38 | (define (move-pos a-pos a-direction a-speed) 39 | (define r (degrees->radians a-direction)) 40 | (pos (+ (pos-x a-pos) (* a-speed (cos r))) 41 | (+ (pos-y a-pos) (* a-speed (sin r))))) 42 | 43 | (define (wrap-pos a-pos a-size) 44 | (define x (pos-x a-pos)) 45 | (define y (pos-y a-pos)) 46 | (pos (cond 47 | [(> x (+ WIDTH a-size)) (- 0 a-size)] 48 | [(< x (- 0 a-size)) (+ WIDTH a-size)] 49 | [else x]) 50 | (cond 51 | [(> y (+ HEIGHT a-size)) (- 0 a-size)] 52 | [(< y (- 0 a-size)) (+ HEIGHT a-size)] 53 | [else y]))) 54 | 55 | (define (inside-circle circle-pos radius a-pos) 56 | (define distance 57 | (sqrt (+ (expt (- (pos-x a-pos) (pos-x circle-pos)) 2) 58 | (expt (- (pos-y a-pos) (pos-y circle-pos)) 2)))) 59 | (<= distance radius)) 60 | 61 | (define (bullet-in-range a-bullet) 62 | (define x (pos-x (bullet-pos a-bullet))) 63 | (define y (pos-y (bullet-pos a-bullet))) 64 | (and (> x 0) (< x WIDTH) (> y 0) (< y HEIGHT))) 65 | 66 | (define (move-asteroid a) 67 | (asteroid (wrap-pos 68 | (move-pos (asteroid-pos a) (asteroid-direction a) (asteroid-speed a)) 69 | (asteroid-size a)) 70 | (asteroid-direction a) 71 | (asteroid-speed a) 72 | (asteroid-size a))) 73 | 74 | (define (new-bullet a-ship) 75 | (bullet (ship-pos a-ship) 76 | (ship-direction a-ship) 77 | (+ (ship-speed a-ship) BULLET-SPEED))) 78 | 79 | (define (move-bullet b) 80 | (bullet (move-pos (bullet-pos b) (bullet-direction b) (bullet-speed b)) 81 | (bullet-direction b) 82 | (bullet-speed b))) 83 | 84 | (define (hit-asteroids asteroids bullets) 85 | ;; If any asteroids have been hit, split them in half. 86 | ;; Asteroids that are too small are deleted. 87 | 88 | ;; A list like this (a a a a a) will result in a list 89 | ;; like this (a a (a a) a a) on hit, we use flatten 90 | ;; to return the right thing. 91 | 92 | (define (hit-asteroid? a bullets) 93 | ;; Has this asteroid been hit by any of the bullets? 94 | (cond 95 | [(empty? bullets) #f] 96 | [(inside-circle (asteroid-pos a) (asteroid-size a) 97 | (bullet-pos (car bullets))) #t] 98 | [else 99 | (hit-asteroid? a (cdr bullets))])) 100 | 101 | (define (split-asteroid a) 102 | (list (asteroid (asteroid-pos a) (- (asteroid-direction a) 90) 103 | (asteroid-speed a) (/ (asteroid-size a) 2)) 104 | (asteroid (asteroid-pos a) (+ (asteroid-direction a) 90) 105 | (asteroid-speed a) (/ (asteroid-size a) 2)))) 106 | 107 | (define (bullets-hit-asteroid a) 108 | (if (hit-asteroid? a bullets) 109 | (split-asteroid a) 110 | a)) 111 | 112 | (define (big-enough a) 113 | (> (asteroid-size a) 5)) 114 | 115 | (filter big-enough (flatten (map bullets-hit-asteroid asteroids)))) 116 | 117 | 118 | (define (live-bullets asteroids bullets) 119 | ;; Like hit-asteroids, but returns only bullets that 120 | ;; have not hit an asteroid 121 | 122 | (define (bullet-hit? b asteroids) 123 | (cond 124 | [(empty? asteroids) #f] 125 | [(inside-circle (asteroid-pos (car asteroids)) 126 | (asteroid-size (car asteroids)) 127 | (bullet-pos b)) #t] 128 | [else (bullet-hit? b (cdr asteroids))])) 129 | 130 | (define (bullet-hit-no-asteroids b) 131 | (not (bullet-hit? b asteroids))) 132 | 133 | (filter bullet-hit-no-asteroids bullets)) 134 | 135 | (define (move-ship a-ship) 136 | (ship (wrap-pos 137 | (move-pos (ship-pos a-ship) (ship-direction a-ship) (ship-speed a-ship)) 138 | SHIP-SIZE) 139 | (ship-direction a-ship) 140 | (ship-speed a-ship))) 141 | 142 | (define (next-world w) 143 | (define next-asteroids (hit-asteroids (world-asteroids w) (world-bullets w))) 144 | (define next-bullets (live-bullets (world-asteroids w) (world-bullets w))) 145 | 146 | (world (map move-asteroid next-asteroids) 147 | (move-ship (world-ship w)) 148 | (filter bullet-in-range (map move-bullet next-bullets)))) 149 | 150 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 151 | ;; Rendering 152 | 153 | (define (img+scene pos img scene) 154 | (place-image img (pos-x pos) (pos-y pos) scene)) 155 | 156 | (define (ship-img a-direction) 157 | (rotate (- 270 a-direction) 158 | (overlay/offset (triangle SHIP-SIZE "solid" "white") 0 8 159 | (triangle SHIP-SIZE "solid" "white")))) 160 | 161 | (define (ship+scene a-ship scene) 162 | (img+scene (ship-pos a-ship) 163 | (ship-img (ship-direction a-ship)) 164 | scene)) 165 | 166 | (define (asteroids+scene asteroids scene) 167 | (foldl (λ (a scene) 168 | (img+scene (asteroid-pos a) 169 | (circle (asteroid-size a) "solid" "gray") 170 | scene)) 171 | scene asteroids)) 172 | 173 | (define (bullets+scene bullets scene) 174 | (foldl (λ (b scene) 175 | (img+scene (bullet-pos b) 176 | (circle 2 "solid" "yellow") 177 | scene)) 178 | scene bullets)) 179 | 180 | (define (render-world w) 181 | (ship+scene (world-ship w) 182 | (asteroids+scene (world-asteroids w) 183 | (bullets+scene (world-bullets w) 184 | (empty-scene WIDTH HEIGHT "black"))))) 185 | 186 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 187 | 188 | (define (direct-ship w a-key) 189 | (define a-ship (world-ship w)) 190 | (define a-direction 191 | (+ (ship-direction a-ship) 192 | (cond 193 | [(key=? a-key "left") -5] 194 | [(key=? a-key "right") 5] 195 | [else 0]))) 196 | (define a-speed 197 | (+ (ship-speed a-ship) 198 | (cond 199 | [(key=? a-key "up") 1] 200 | [(key=? a-key "down") -1] 201 | [else 0]))) 202 | (define bullets 203 | (cond 204 | [(key=? a-key " ") (cons (new-bullet a-ship) (world-bullets w))] 205 | [else (world-bullets w)])) 206 | 207 | (world (world-asteroids w) 208 | (ship (ship-pos a-ship) a-direction a-speed) 209 | bullets)) 210 | 211 | (define (ship-crashed? w) 212 | (define a-ship (world-ship w)) 213 | (define (ship-hit-asteroids? asteroids) 214 | (cond 215 | [(empty? asteroids) #f] 216 | [(inside-circle (asteroid-pos (car asteroids)) 217 | (+ (asteroid-size (car asteroids)) 218 | (/ SHIP-SIZE 2)) 219 | (ship-pos a-ship)) #t] 220 | [else (ship-hit-asteroids? (cdr asteroids))])) 221 | 222 | (ship-hit-asteroids? (world-asteroids w))) 223 | 224 | (define (new-world) 225 | ;; Produce a world in which the ship has not just crashed 226 | (define asteroids (times-repeat NUM-ASTEROIDS (new-asteroid))) 227 | (define a-ship (ship (pos (/ WIDTH 2) (/ HEIGHT 2)) 0 0)) 228 | (define a-world 229 | (world asteroids a-ship '())) 230 | (if (ship-crashed? a-world) 231 | (new-world) 232 | a-world)) 233 | 234 | (define (go) 235 | (big-bang (new-world) 236 | (on-tick next-world TICK-RATE) 237 | (on-key direct-ship) 238 | (to-draw render-world) 239 | (stop-when ship-crashed?))) 240 | -------------------------------------------------------------------------------- /asteroids4.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | 5 | Asteroids - (go) to run. 6 | 7 | Left / right to rotate 8 | Up / down to speed up, slow down 9 | Space to fire. 10 | 11 | DONE: 12 | - Score 13 | 14 | TODO: 15 | - Lives 16 | 17 | |# 18 | 19 | (require 2htdp/universe 2htdp/image) 20 | (require "util.rkt") 21 | 22 | (struct world (asteroids ship bullets score) #:transparent) 23 | (struct pos (x y) #:transparent) 24 | (struct ship (pos direction speed) #:transparent) 25 | (struct asteroid (pos direction speed size) #:transparent) 26 | (struct bullet (pos direction speed) #:transparent) 27 | 28 | (define BIG-ASTEROID 60) 29 | (define NUM-ASTEROIDS 5) 30 | (define BULLET-SPEED 5) 31 | (define SHIP-SIZE 30) 32 | 33 | (define TICK-RATE 1/30) 34 | (define WIDTH 800) 35 | (define HEIGHT 600) 36 | 37 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 38 | 39 | (define (new-asteroid) 40 | (asteroid (pos (random WIDTH) (random HEIGHT)) 41 | (random 360) (+ 1 (random 2)) BIG-ASTEROID)) 42 | 43 | (define (move-pos a-pos a-direction a-speed) 44 | (define r (degrees->radians a-direction)) 45 | (pos (+ (pos-x a-pos) (* a-speed (cos r))) 46 | (+ (pos-y a-pos) (* a-speed (sin r))))) 47 | 48 | (define (wrap-pos a-pos a-size) 49 | (define x (pos-x a-pos)) 50 | (define y (pos-y a-pos)) 51 | (pos (cond 52 | [(> x (+ WIDTH a-size)) (- 0 a-size)] 53 | [(< x (- 0 a-size)) (+ WIDTH a-size)] 54 | [else x]) 55 | (cond 56 | [(> y (+ HEIGHT a-size)) (- 0 a-size)] 57 | [(< y (- 0 a-size)) (+ HEIGHT a-size)] 58 | [else y]))) 59 | 60 | (define (inside-circle circle-pos radius a-pos) 61 | (define distance 62 | (sqrt (+ (expt (- (pos-x a-pos) (pos-x circle-pos)) 2) 63 | (expt (- (pos-y a-pos) (pos-y circle-pos)) 2)))) 64 | (<= distance radius)) 65 | 66 | (define (bullet-in-range a-bullet) 67 | (define x (pos-x (bullet-pos a-bullet))) 68 | (define y (pos-y (bullet-pos a-bullet))) 69 | (and (> x 0) (< x WIDTH) (> y 0) (< y HEIGHT))) 70 | 71 | (define (move-asteroid a) 72 | (asteroid (wrap-pos 73 | (move-pos (asteroid-pos a) (asteroid-direction a) (asteroid-speed a)) 74 | (asteroid-size a)) 75 | (asteroid-direction a) 76 | (asteroid-speed a) 77 | (asteroid-size a))) 78 | 79 | (define (new-bullet a-ship) 80 | (bullet (ship-pos a-ship) 81 | (ship-direction a-ship) 82 | (+ (ship-speed a-ship) BULLET-SPEED))) 83 | 84 | (define (move-bullet b) 85 | (bullet (move-pos (bullet-pos b) (bullet-direction b) (bullet-speed b)) 86 | (bullet-direction b) 87 | (bullet-speed b))) 88 | 89 | (define (hit-asteroids asteroids bullets) 90 | ;; If any asteroids have been hit, split them in half. 91 | ;; Asteroids that are too small are deleted. 92 | 93 | ;; A list like this (a a a a a) will result in a list 94 | ;; like this (a a (a a) a a) on hit, we use flatten 95 | ;; to return the right thing. 96 | 97 | (define (hit-asteroid? a bullets) 98 | ;; Has this asteroid been hit by any of the bullets? 99 | (cond 100 | [(empty? bullets) #f] 101 | [(inside-circle (asteroid-pos a) (asteroid-size a) 102 | (bullet-pos (car bullets))) #t] 103 | [else 104 | (hit-asteroid? a (cdr bullets))])) 105 | 106 | (define (split-asteroid a) 107 | (list (asteroid (asteroid-pos a) (- (asteroid-direction a) 90) 108 | (asteroid-speed a) (/ (asteroid-size a) 2)) 109 | (asteroid (asteroid-pos a) (+ (asteroid-direction a) 90) 110 | (asteroid-speed a) (/ (asteroid-size a) 2)))) 111 | 112 | (define (bullets-hit-asteroid a) 113 | (if (hit-asteroid? a bullets) 114 | (split-asteroid a) 115 | a)) 116 | 117 | (define (big-enough a) 118 | (> (asteroid-size a) 5)) 119 | 120 | (filter big-enough (flatten (map bullets-hit-asteroid asteroids)))) 121 | 122 | (define (asteroids-diff prev-asteroids next-asteroids) 123 | ;; +1 point each time the number of asteroids decreases 124 | ;; regardless of size 125 | (define diff (- (length prev-asteroids) 126 | (length next-asteroids))) 127 | (if (> diff 0) diff 0)) 128 | 129 | 130 | (define (live-bullets asteroids bullets) 131 | ;; Like hit-asteroids, but returns only bullets that 132 | ;; have not hit an asteroid 133 | 134 | (define (bullet-hit? b asteroids) 135 | (cond 136 | [(empty? asteroids) #f] 137 | [(inside-circle (asteroid-pos (car asteroids)) 138 | (asteroid-size (car asteroids)) 139 | (bullet-pos b)) #t] 140 | [else (bullet-hit? b (cdr asteroids))])) 141 | 142 | (define (bullet-hit-no-asteroids b) 143 | (not (bullet-hit? b asteroids))) 144 | 145 | (filter bullet-hit-no-asteroids bullets)) 146 | 147 | (define (move-ship a-ship) 148 | (ship (wrap-pos 149 | (move-pos (ship-pos a-ship) (ship-direction a-ship) (ship-speed a-ship)) 150 | SHIP-SIZE) 151 | (ship-direction a-ship) 152 | (ship-speed a-ship))) 153 | 154 | (define (next-world w) 155 | (define next-asteroids (hit-asteroids (world-asteroids w) (world-bullets w))) 156 | (define next-bullets (live-bullets (world-asteroids w) (world-bullets w))) 157 | (define add-score (asteroids-diff (world-asteroids w) next-asteroids)) 158 | 159 | (world (map move-asteroid next-asteroids) 160 | (move-ship (world-ship w)) 161 | (filter bullet-in-range (map move-bullet next-bullets)) 162 | (+ add-score (world-score w)))) 163 | 164 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 165 | ;; Rendering 166 | 167 | (define (img+scene pos img scene) 168 | (place-image img (pos-x pos) (pos-y pos) scene)) 169 | 170 | (define (ship-img a-direction) 171 | (rotate (- 270 a-direction) 172 | (overlay/offset (triangle SHIP-SIZE "solid" "white") 0 8 173 | (triangle SHIP-SIZE "solid" "white")))) 174 | 175 | (define (ship+scene a-ship scene) 176 | (img+scene (ship-pos a-ship) 177 | (ship-img (ship-direction a-ship)) 178 | scene)) 179 | 180 | (define (asteroids+scene asteroids scene) 181 | (foldl (λ (a scene) 182 | (img+scene (asteroid-pos a) 183 | (circle (asteroid-size a) "solid" "gray") 184 | scene)) 185 | scene asteroids)) 186 | 187 | (define (bullets+scene bullets scene) 188 | (foldl (λ (b scene) 189 | (img+scene (bullet-pos b) 190 | (circle 2 "solid" "yellow") 191 | scene)) 192 | scene bullets)) 193 | 194 | (define (score+scene score scene) 195 | (place-image (text (string-append "Score: " 196 | (number->string score)) 197 | 24 "white") 55 20 scene)) 198 | 199 | (define (render-world w) 200 | (score+scene (world-score w) 201 | (ship+scene (world-ship w) 202 | (asteroids+scene (world-asteroids w) 203 | (bullets+scene (world-bullets w) 204 | (empty-scene WIDTH HEIGHT "black")))))) 205 | 206 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 207 | 208 | (define (direct-ship w a-key) 209 | (define a-ship (world-ship w)) 210 | (define a-direction 211 | (+ (ship-direction a-ship) 212 | (cond 213 | [(key=? a-key "left") -5] 214 | [(key=? a-key "right") 5] 215 | [else 0]))) 216 | (define a-speed 217 | (+ (ship-speed a-ship) 218 | (cond 219 | [(key=? a-key "up") 1] 220 | [(key=? a-key "down") -1] 221 | [else 0]))) 222 | (define bullets 223 | (cond 224 | [(key=? a-key " ") (cons (new-bullet a-ship) (world-bullets w))] 225 | [else (world-bullets w)])) 226 | 227 | (world (world-asteroids w) 228 | (ship (ship-pos a-ship) a-direction a-speed) 229 | bullets 230 | (world-score w))) 231 | 232 | (define (ship-crashed? w) 233 | (define a-ship (world-ship w)) 234 | (define (ship-hit-asteroids? asteroids) 235 | (cond 236 | [(empty? asteroids) #f] 237 | [(inside-circle (asteroid-pos (car asteroids)) 238 | (+ (asteroid-size (car asteroids)) 239 | (/ SHIP-SIZE 2)) 240 | (ship-pos a-ship)) #t] 241 | [else (ship-hit-asteroids? (cdr asteroids))])) 242 | 243 | (ship-hit-asteroids? (world-asteroids w))) 244 | 245 | (define (new-world) 246 | ;; Produce a world in which the ship has not just crashed 247 | (define asteroids (times-repeat NUM-ASTEROIDS (new-asteroid))) 248 | (define a-ship (ship (pos (/ WIDTH 2) (/ HEIGHT 2)) 0 0)) 249 | (define a-world 250 | (world asteroids a-ship '() 0)) 251 | (if (ship-crashed? a-world) 252 | (new-world) 253 | a-world)) 254 | 255 | (define (go) 256 | (big-bang (new-world) 257 | (on-tick next-world TICK-RATE) 258 | (on-key direct-ship) 259 | (to-draw render-world) 260 | (stop-when ship-crashed?))) 261 | -------------------------------------------------------------------------------- /asteroids5.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | 5 | Asteroids - (go) to run. 6 | 7 | Left / right to rotate 8 | Up / down to speed up, slow down 9 | Space to fire. 10 | 11 | DONE: 12 | - Multiple key presses, e.g. moving and shooting at the 13 | same time. 14 | - Some motivaton for the user to do more than just fire 15 | in circles endlessely - maybe limitted bullets? 16 | 17 | TODO: 18 | - It's too hard to begin with 19 | - Level up 20 | - Can leave bullets just sitting there (reverse and fire) 21 | - Lives 22 | 23 | |# 24 | 25 | (require 2htdp/universe 2htdp/image) 26 | (require "util.rkt") 27 | 28 | (struct world (asteroids ship bullets score) #:transparent) 29 | (struct pos (x y) #:transparent) 30 | (struct ship (pos direction speed) #:transparent) 31 | (struct asteroid (pos direction speed size) #:transparent) 32 | (struct bullet (pos direction speed) #:transparent) 33 | 34 | (define BIG-ASTEROID 50) 35 | (define NUM-ASTEROIDS 4) 36 | (define BULLET-SPEED 5) 37 | (define SHIP-SIZE 30) 38 | (define MAX-BULLETS 25) 39 | 40 | (define TICK-RATE 1/30) 41 | (define WIDTH 800) 42 | (define HEIGHT 600) 43 | 44 | (define KEY-STATE (make-hash)) 45 | 46 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 47 | 48 | (define (new-asteroid) 49 | (asteroid (pos (random WIDTH) (random HEIGHT)) 50 | (random 360) (+ 1 (random 2)) BIG-ASTEROID)) 51 | 52 | (define (move-pos a-pos a-direction a-speed) 53 | (define r (degrees->radians a-direction)) 54 | (pos (+ (pos-x a-pos) (* a-speed (cos r))) 55 | (+ (pos-y a-pos) (* a-speed (sin r))))) 56 | 57 | (define (wrap-pos a-pos a-size) 58 | (define x (pos-x a-pos)) 59 | (define y (pos-y a-pos)) 60 | (pos (cond 61 | [(> x (+ WIDTH a-size)) (- 0 a-size)] 62 | [(< x (- 0 a-size)) (+ WIDTH a-size)] 63 | [else x]) 64 | (cond 65 | [(> y (+ HEIGHT a-size)) (- 0 a-size)] 66 | [(< y (- 0 a-size)) (+ HEIGHT a-size)] 67 | [else y]))) 68 | 69 | (define (inside-circle circle-pos radius a-pos) 70 | (define distance 71 | (sqrt (+ (expt (- (pos-x a-pos) (pos-x circle-pos)) 2) 72 | (expt (- (pos-y a-pos) (pos-y circle-pos)) 2)))) 73 | (<= distance radius)) 74 | 75 | (define (bullet-in-range a-bullet) 76 | (define x (pos-x (bullet-pos a-bullet))) 77 | (define y (pos-y (bullet-pos a-bullet))) 78 | (and (> x 0) (< x WIDTH) (> y 0) (< y HEIGHT))) 79 | 80 | (define (move-asteroid a) 81 | (asteroid (wrap-pos 82 | (move-pos (asteroid-pos a) (asteroid-direction a) (asteroid-speed a)) 83 | (asteroid-size a)) 84 | (asteroid-direction a) 85 | (asteroid-speed a) 86 | (asteroid-size a))) 87 | 88 | (define (new-bullet a-ship) 89 | (bullet (ship-pos a-ship) 90 | (ship-direction a-ship) 91 | (+ (ship-speed a-ship) BULLET-SPEED))) 92 | 93 | (define (move-bullet b) 94 | (bullet (move-pos (bullet-pos b) (bullet-direction b) (bullet-speed b)) 95 | (bullet-direction b) 96 | (bullet-speed b))) 97 | 98 | (define (hit-asteroids asteroids bullets) 99 | ;; If any asteroids have been hit, split them in half. 100 | ;; Asteroids that are too small are deleted. 101 | 102 | ;; A list like this (a a a a a) will result in a list 103 | ;; like this (a a (a a) a a) on hit, we use flatten 104 | ;; to return the right thing. 105 | 106 | (define (hit-asteroid? a bullets) 107 | ;; Has this asteroid been hit by any of the bullets? 108 | (cond 109 | [(empty? bullets) #f] 110 | [(inside-circle (asteroid-pos a) (asteroid-size a) 111 | (bullet-pos (car bullets))) #t] 112 | [else 113 | (hit-asteroid? a (cdr bullets))])) 114 | 115 | (define (split-asteroid a) 116 | (list (asteroid (asteroid-pos a) (- (asteroid-direction a) 90) 117 | (asteroid-speed a) (/ (asteroid-size a) 2)) 118 | (asteroid (asteroid-pos a) (+ (asteroid-direction a) 90) 119 | (asteroid-speed a) (/ (asteroid-size a) 2)))) 120 | 121 | (define (bullets-hit-asteroid a) 122 | (if (hit-asteroid? a bullets) 123 | (split-asteroid a) 124 | a)) 125 | 126 | (define (big-enough a) 127 | (> (asteroid-size a) 5)) 128 | 129 | (filter big-enough (flatten (map bullets-hit-asteroid asteroids)))) 130 | 131 | (define (asteroids-diff prev-asteroids next-asteroids) 132 | ;; +1 point each time the number of asteroids decreases 133 | ;; regardless of size 134 | (define diff (- (length prev-asteroids) 135 | (length next-asteroids))) 136 | (if (> diff 0) diff 0)) 137 | 138 | 139 | (define (live-bullets asteroids bullets) 140 | ;; Like hit-asteroids, but returns only bullets that 141 | ;; have not hit an asteroid 142 | 143 | (define (bullet-hit? b asteroids) 144 | (cond 145 | [(empty? asteroids) #f] 146 | [(inside-circle (asteroid-pos (car asteroids)) 147 | (asteroid-size (car asteroids)) 148 | (bullet-pos b)) #t] 149 | [else (bullet-hit? b (cdr asteroids))])) 150 | 151 | (define (bullet-hit-no-asteroids b) 152 | (not (bullet-hit? b asteroids))) 153 | 154 | (filter bullet-hit-no-asteroids bullets)) 155 | 156 | (define (move-ship a-ship) 157 | (ship (wrap-pos 158 | (move-pos (ship-pos a-ship) (ship-direction a-ship) (ship-speed a-ship)) 159 | SHIP-SIZE) 160 | (ship-direction a-ship) 161 | (ship-speed a-ship))) 162 | 163 | (define (next-world w) 164 | (move-world (direct-ship w))) 165 | 166 | (define (move-world w) 167 | (define next-asteroids (hit-asteroids (world-asteroids w) (world-bullets w))) 168 | (define next-bullets (live-bullets (world-asteroids w) (world-bullets w))) 169 | (define add-score (asteroids-diff (world-asteroids w) next-asteroids)) 170 | 171 | (world (map move-asteroid next-asteroids) 172 | (move-ship (world-ship w)) 173 | (filter bullet-in-range (map move-bullet next-bullets)) 174 | (+ add-score (world-score w)))) 175 | 176 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 177 | ;; Rendering 178 | 179 | (define (img+scene pos img scene) 180 | (place-image img (pos-x pos) (pos-y pos) scene)) 181 | 182 | (define (ship-img a-direction) 183 | (rotate (- 270 a-direction) 184 | (overlay/offset (triangle SHIP-SIZE "solid" "white") 0 8 185 | (triangle SHIP-SIZE "solid" "white")))) 186 | 187 | (define (ship+scene a-ship scene) 188 | (img+scene (ship-pos a-ship) 189 | (ship-img (ship-direction a-ship)) 190 | scene)) 191 | 192 | (define (asteroids+scene asteroids scene) 193 | (foldl (λ (a scene) 194 | (img+scene (asteroid-pos a) 195 | (circle (asteroid-size a) "solid" "gray") 196 | scene)) 197 | scene asteroids)) 198 | 199 | (define (bullets+scene bullets scene) 200 | (foldl (λ (b scene) 201 | (img+scene (bullet-pos b) 202 | (circle 2 "solid" "yellow") 203 | scene)) 204 | scene bullets)) 205 | 206 | (define (score+scene score scene) 207 | (place-image (text (string-append "Score: " 208 | (number->string score)) 209 | 24 "white") 55 20 scene)) 210 | 211 | (define (render-world w) 212 | (score+scene (world-score w) 213 | (ship+scene (world-ship w) 214 | (asteroids+scene (world-asteroids w) 215 | (bullets+scene (world-bullets w) 216 | (empty-scene WIDTH HEIGHT "black")))))) 217 | 218 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 219 | 220 | (define (key-down w a-key) 221 | (hash-set! KEY-STATE a-key #t) 222 | w) 223 | 224 | (define (key-up w a-key) 225 | (hash-remove! KEY-STATE a-key) 226 | w) 227 | 228 | (define (key-pressed? a-key) 229 | (hash-ref KEY-STATE a-key #f)) 230 | 231 | (define (direct-ship w) 232 | (define a-ship (world-ship w)) 233 | (define a-direction 234 | (+ (ship-direction a-ship) 235 | (cond 236 | [(key-pressed? "left") -5] 237 | [(key-pressed? "right") 5] 238 | [else 0]))) 239 | (define a-speed 240 | (+ (ship-speed a-ship) 241 | (cond 242 | [(key-pressed? "up") 1] 243 | [(key-pressed? "down") -1] 244 | [else 0]))) 245 | (define bullets 246 | (cond 247 | [(and (key-pressed? " ") 248 | (< (length (world-bullets w)) MAX-BULLETS)) 249 | (cons (new-bullet a-ship) (world-bullets w))] 250 | [else (world-bullets w)])) 251 | 252 | (world (world-asteroids w) 253 | (ship (ship-pos a-ship) a-direction a-speed) 254 | bullets 255 | (world-score w))) 256 | 257 | (define (ship-crashed? w) 258 | (define a-ship (world-ship w)) 259 | (define (ship-hit-asteroids? asteroids) 260 | (cond 261 | [(empty? asteroids) #f] 262 | [(inside-circle (asteroid-pos (car asteroids)) 263 | (+ (asteroid-size (car asteroids)) 264 | (/ SHIP-SIZE 2)) 265 | (ship-pos a-ship)) #t] 266 | [else (ship-hit-asteroids? (cdr asteroids))])) 267 | 268 | (ship-hit-asteroids? (world-asteroids w))) 269 | 270 | (define (new-world) 271 | ;; Produce a world in which the ship has not just crashed 272 | (define asteroids (times-repeat NUM-ASTEROIDS (new-asteroid))) 273 | (define a-ship (ship (pos (/ WIDTH 2) (/ HEIGHT 2)) 0 0)) 274 | (define a-world 275 | (world asteroids a-ship '() 0)) 276 | (if (ship-crashed? a-world) 277 | (new-world) 278 | a-world)) 279 | 280 | (define (go) 281 | (hash-clear! KEY-STATE) 282 | (big-bang (new-world) 283 | (on-tick next-world TICK-RATE) 284 | (on-key key-down) 285 | (on-release key-up) 286 | (to-draw render-world) 287 | (stop-when ship-crashed?))) 288 | -------------------------------------------------------------------------------- /asteroids6.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | 5 | Asteroids - (go) to run. 6 | 7 | Left / right to rotate 8 | Up to thrust 9 | Space to fire. 10 | 11 | DONE: 12 | - Ship should carry on straight path even when turning 13 | - Multiple key presses, e.g. moving and shooting at the 14 | same time. 15 | - Some motivaton for the user to do more than just fire 16 | in circles endlessely - maybe limitted bullets? 17 | 18 | TODO: 19 | - It's too hard to begin with 20 | - Level up 21 | - Can leave bullets just sitting there (reverse and fire) 22 | - Lives 23 | 24 | |# 25 | 26 | (require 2htdp/universe 2htdp/image) 27 | (require "util.rkt") 28 | 29 | (struct world (asteroids ship bullets score level) #:transparent) 30 | (struct pos (x y) #:transparent) 31 | (struct ship (pos facing-direction speed travel-direction) #:transparent) 32 | (struct asteroid (pos direction speed size) #:transparent) 33 | (struct bullet (pos direction speed) #:transparent) 34 | 35 | (define BIG-ASTEROID 50) 36 | (define NUM-ASTEROIDS 3) 37 | (define BULLET-SPEED 5) 38 | (define SHIP-SIZE 30) 39 | (define MAX-BULLETS 15) 40 | (define ASTEROID-IMG (bitmap "images/space-pizza.png")) 41 | (define SPACESHIP-IMG (bitmap "images/spaceship2.png")) 42 | 43 | (define TICK-RATE 1/30) 44 | (define WIDTH 800) 45 | (define HEIGHT 600) 46 | 47 | (define KEY-STATE (make-hash)) 48 | 49 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 50 | 51 | (define (new-asteroid) 52 | (asteroid (pos (random WIDTH) (random HEIGHT)) 53 | (random 360) (+ 1 (random 2)) BIG-ASTEROID)) 54 | 55 | (define (move-pos a-pos a-direction a-speed) 56 | (define r (degrees->radians a-direction)) 57 | (pos (+ (pos-x a-pos) (* a-speed (cos r))) 58 | (+ (pos-y a-pos) (* a-speed (sin r))))) 59 | 60 | (define (add-direction-speeds d1 s1 d2 s2) 61 | ;; Given two direction & speed pairs, calculate the 62 | ;; combined effect and return new direction and speed 63 | (if (and (zero? s1) (zero? s2)) 64 | (list d1 0) 65 | (let* ([vec1 (move-pos (pos 0 0) d1 s1)] 66 | [vec2 (move-pos (pos 0 0) d2 s2)] 67 | [c-vec (pos (+ (pos-x vec1) (pos-x vec2)) 68 | (+ (pos-y vec1) (pos-y vec2)))] 69 | [direction (radians->degrees 70 | (atan (pos-y c-vec) 71 | (pos-x c-vec)))] 72 | [speed (sqrt (+ (sqr (pos-x c-vec)) 73 | (sqr (pos-y c-vec))))]) 74 | (list direction speed)))) 75 | 76 | (define (wrap-pos a-pos a-size) 77 | (define x (pos-x a-pos)) 78 | (define y (pos-y a-pos)) 79 | (pos (cond 80 | [(> x (+ WIDTH a-size)) (- 0 a-size)] 81 | [(< x (- 0 a-size)) (+ WIDTH a-size)] 82 | [else x]) 83 | (cond 84 | [(> y (+ HEIGHT a-size)) (- 0 a-size)] 85 | [(< y (- 0 a-size)) (+ HEIGHT a-size)] 86 | [else y]))) 87 | 88 | (define (inside-circle circle-pos radius a-pos) 89 | (define distance 90 | (sqrt (+ (expt (- (pos-x a-pos) (pos-x circle-pos)) 2) 91 | (expt (- (pos-y a-pos) (pos-y circle-pos)) 2)))) 92 | (<= distance radius)) 93 | 94 | (define (bullet-in-range a-bullet) 95 | (define x (pos-x (bullet-pos a-bullet))) 96 | (define y (pos-y (bullet-pos a-bullet))) 97 | (and (> x 0) (< x WIDTH) (> y 0) (< y HEIGHT))) 98 | 99 | (define (move-asteroid a) 100 | (asteroid (wrap-pos 101 | (move-pos (asteroid-pos a) (asteroid-direction a) (asteroid-speed a)) 102 | (asteroid-size a)) 103 | (asteroid-direction a) 104 | (asteroid-speed a) 105 | (asteroid-size a))) 106 | 107 | (define (new-bullet a-ship) 108 | (bullet (ship-pos a-ship) 109 | (ship-facing-direction a-ship) 110 | (+ (ship-speed a-ship) BULLET-SPEED))) 111 | 112 | (define (move-bullet b) 113 | (bullet (move-pos (bullet-pos b) (bullet-direction b) (bullet-speed b)) 114 | (bullet-direction b) 115 | (bullet-speed b))) 116 | 117 | (define (hit-asteroids asteroids bullets) 118 | ;; If any asteroids have been hit, split them in half. 119 | ;; Asteroids that are too small are deleted. 120 | 121 | ;; A list like this (a a a a a) will result in a list 122 | ;; like this (a a (a a) a a) on hit, we use flatten 123 | ;; to return the right thing. 124 | 125 | (define (hit-asteroid? a bullets) 126 | ;; Has this asteroid been hit by any of the bullets? 127 | (cond 128 | [(empty? bullets) #f] 129 | [(inside-circle (asteroid-pos a) (asteroid-size a) 130 | (bullet-pos (car bullets))) #t] 131 | [else 132 | (hit-asteroid? a (cdr bullets))])) 133 | 134 | (define (split-asteroid a) 135 | (list (asteroid (asteroid-pos a) (- (asteroid-direction a) 90) 136 | (asteroid-speed a) (/ (asteroid-size a) 2)) 137 | (asteroid (asteroid-pos a) (+ (asteroid-direction a) 90) 138 | (asteroid-speed a) (/ (asteroid-size a) 2)))) 139 | 140 | (define (bullets-hit-asteroid a) 141 | (if (hit-asteroid? a bullets) 142 | (split-asteroid a) 143 | a)) 144 | 145 | (define (big-enough a) 146 | (> (asteroid-size a) 5)) 147 | 148 | (filter big-enough (flatten (map bullets-hit-asteroid asteroids)))) 149 | 150 | (define (asteroids-diff prev-asteroids next-asteroids) 151 | ;; +1 point each time the number of asteroids decreases 152 | ;; regardless of size 153 | (define diff (- (length prev-asteroids) 154 | (length next-asteroids))) 155 | (if (> diff 0) diff 0)) 156 | 157 | 158 | (define (live-bullets asteroids bullets) 159 | ;; Like hit-asteroids, but returns only bullets that 160 | ;; have not hit an asteroid 161 | 162 | (define (bullet-hit? b asteroids) 163 | (cond 164 | [(empty? asteroids) #f] 165 | [(inside-circle (asteroid-pos (car asteroids)) 166 | (asteroid-size (car asteroids)) 167 | (bullet-pos b)) #t] 168 | [else (bullet-hit? b (cdr asteroids))])) 169 | 170 | (define (bullet-hit-no-asteroids b) 171 | (not (bullet-hit? b asteroids))) 172 | 173 | (filter bullet-hit-no-asteroids bullets)) 174 | 175 | (define (move-ship a-ship) 176 | (ship (wrap-pos 177 | (move-pos (ship-pos a-ship) (ship-travel-direction a-ship) (ship-speed a-ship)) 178 | SHIP-SIZE) 179 | (ship-facing-direction a-ship) 180 | (ship-speed a-ship) 181 | (ship-travel-direction a-ship))) 182 | 183 | (define (next-world w) 184 | (move-world (direct-ship w))) 185 | 186 | (define (move-world w) 187 | (define next-asteroids (hit-asteroids (world-asteroids w) (world-bullets w))) 188 | (define next-bullets (live-bullets (world-asteroids w) (world-bullets w))) 189 | (define add-score (asteroids-diff (world-asteroids w) next-asteroids)) 190 | 191 | (world (map move-asteroid next-asteroids) 192 | (move-ship (world-ship w)) 193 | (filter bullet-in-range (map move-bullet next-bullets)) 194 | (+ add-score (world-score w)) 195 | (world-level w))) 196 | 197 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 198 | ;; Rendering 199 | 200 | (define (img+scene pos img scene) 201 | (place-image img (pos-x pos) (pos-y pos) scene)) 202 | 203 | (define (ship-img a-direction) 204 | (rotate (- 0 a-direction) 205 | (scale 3 SPACESHIP-IMG))) 206 | 207 | (define (ship+scene a-ship scene) 208 | (img+scene (ship-pos a-ship) 209 | (ship-img (ship-facing-direction a-ship)) 210 | scene)) 211 | 212 | (define (asteroids+scene asteroids scene) 213 | (foldl (λ (a scene) 214 | (img+scene (asteroid-pos a) 215 | (scale (/ (asteroid-size a) 11) 216 | ASTEROID-IMG) 217 | scene)) 218 | scene asteroids)) 219 | 220 | (define (bullets+scene bullets scene) 221 | (foldl (λ (b scene) 222 | (img+scene (bullet-pos b) 223 | (circle 2 "solid" "yellow") 224 | scene)) 225 | scene bullets)) 226 | 227 | (define (score+scene score level scene) 228 | (place-image 229 | (above/align "left" 230 | (text (string-append "Score: " (number->string score)) 231 | 24 "white") 232 | (text (string-append "Level: " (number->string level)) 233 | 24 "white")) 234 | 55 35 235 | scene)) 236 | 237 | (define (render-world w) 238 | (score+scene (world-score w) (world-level w) 239 | (ship+scene (world-ship w) 240 | (asteroids+scene (world-asteroids w) 241 | (bullets+scene (world-bullets w) 242 | (empty-scene WIDTH HEIGHT "black")))))) 243 | 244 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 245 | 246 | (define (key-down w a-key) 247 | (hash-set! KEY-STATE a-key #t) 248 | w) 249 | 250 | (define (key-up w a-key) 251 | (hash-remove! KEY-STATE a-key) 252 | w) 253 | 254 | (define (key-pressed? a-key) 255 | (hash-ref KEY-STATE a-key #f)) 256 | 257 | (define (direct-ship w) 258 | (let* ([a-ship (world-ship w)] 259 | [new-facing-direction (+ (ship-facing-direction a-ship) 260 | (cond 261 | [(key-pressed? "left") -5] 262 | [(key-pressed? "right") 5] 263 | [else 0]))] 264 | 265 | [new-direction-speed (add-direction-speeds 266 | (ship-travel-direction a-ship) 267 | (ship-speed a-ship) 268 | new-facing-direction 269 | (if (key-pressed? "up") 1 0))] 270 | [bullets 271 | (cond 272 | [(and (key-pressed? " ") 273 | (< (length (world-bullets w)) MAX-BULLETS)) 274 | (cons (new-bullet a-ship) (world-bullets w))] 275 | [else (world-bullets w)])]) 276 | (world (world-asteroids w) 277 | (ship (ship-pos a-ship) new-facing-direction 278 | (second new-direction-speed) 279 | (first new-direction-speed)) 280 | bullets 281 | (world-score w) 282 | (world-level w)))) 283 | 284 | (define (ship-crashed? w) 285 | (define a-ship (world-ship w)) 286 | (define (ship-hit-asteroids? asteroids) 287 | (cond 288 | [(empty? asteroids) #f] 289 | [(inside-circle (asteroid-pos (car asteroids)) 290 | (+ (asteroid-size (car asteroids)) 291 | (/ SHIP-SIZE 2)) 292 | (ship-pos a-ship)) #t] 293 | [else (ship-hit-asteroids? (cdr asteroids))])) 294 | 295 | (ship-hit-asteroids? (world-asteroids w))) 296 | 297 | (define (new-world) 298 | ;; Produce a world in which the ship has not just crashed 299 | (define asteroids (times-repeat NUM-ASTEROIDS (new-asteroid))) 300 | (define a-ship (ship (pos (/ WIDTH 2) (/ HEIGHT 2)) 0 0 0)) 301 | (define a-world 302 | (world asteroids a-ship '() 0 1)) 303 | (if (ship-crashed? a-world) 304 | (new-world) 305 | a-world)) 306 | 307 | (define (go) 308 | (hash-clear! KEY-STATE) 309 | (big-bang (new-world) 310 | (on-tick next-world TICK-RATE) 311 | (on-key key-down) 312 | (on-release key-up) 313 | (to-draw render-world) 314 | (stop-when ship-crashed?))) 315 | -------------------------------------------------------------------------------- /boids1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| Boids - bird like objects - https://en.wikipedia.org/wiki/Boids 4 | 5 | Version 1: Just some circles moving in straight lines 6 | 7 | Run (go) to start. 8 | 9 | -- 10 | 11 | Copyright 2018, Eric Clack, eric@bn7.net 12 | This program is distributed under the terms of the GNU General 13 | Public License 14 | |# 15 | 16 | (require 2htdp/universe 2htdp/image) 17 | (require "util.rkt") 18 | 19 | (struct world (boids) #:transparent) 20 | (struct pos (x y) #:transparent) 21 | (struct boid (pos direction speed size) #:transparent) 22 | 23 | (define BIG-BOID 20) 24 | (define NUM-BOIDS 15) 25 | 26 | (define TICK-RATE 1/30) 27 | (define WIDTH 800) 28 | (define HEIGHT 600) 29 | 30 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 31 | 32 | (define (new-boid) 33 | (boid (pos (random WIDTH) (random HEIGHT)) 34 | (random 360) 35 | (+ 1 (random 2)) 36 | BIG-BOID)) 37 | 38 | (define (move-pos a-pos a-direction a-speed) 39 | (define r (degrees->radians a-direction)) 40 | (pos (+ (pos-x a-pos) (* a-speed (cos r))) 41 | (+ (pos-y a-pos) (* a-speed (sin r))))) 42 | 43 | (define (wrap-pos a-pos a-size) 44 | (define x (pos-x a-pos)) 45 | (define y (pos-y a-pos)) 46 | (pos (cond 47 | [(> x (+ WIDTH a-size)) (- 0 a-size)] 48 | [(< x (- 0 a-size)) (+ WIDTH a-size)] 49 | [else x]) 50 | (cond 51 | [(> y (+ HEIGHT a-size)) (- 0 a-size)] 52 | [(< y (- 0 a-size)) (+ HEIGHT a-size)] 53 | [else y]))) 54 | 55 | (define (move-boid a) 56 | (boid (wrap-pos 57 | (move-pos (boid-pos a) (boid-direction a) (boid-speed a)) 58 | (boid-size a)) 59 | (boid-direction a) 60 | (boid-speed a) 61 | (boid-size a))) 62 | 63 | (define (next-world w) 64 | (define next-boids (world-boids w) ) 65 | (world (map move-boid next-boids) 66 | )) 67 | 68 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 69 | ;; Rendering 70 | 71 | (define (img+scene pos img scene) 72 | (place-image img (pos-x pos) (pos-y pos) scene)) 73 | 74 | (define (boids+scene boids scene) 75 | (foldl (λ (a scene) 76 | (img+scene (boid-pos a) 77 | (circle (boid-size a) "solid" "gray") 78 | scene)) 79 | scene boids)) 80 | 81 | (define (render-world w) 82 | (boids+scene (world-boids w) 83 | (empty-scene WIDTH HEIGHT "black"))) 84 | 85 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 86 | 87 | (define (go) 88 | (big-bang (world (times-repeat NUM-BOIDS (new-boid))) 89 | (on-tick next-world TICK-RATE) 90 | (to-draw render-world))) 91 | -------------------------------------------------------------------------------- /boids2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| Boids - bird like objects - https://en.wikipedia.org/wiki/Boids 4 | 5 | Version 2: Boids don't like to get too close to the mouse. 6 | 7 | Run (go) to start. 8 | 9 | -- 10 | 11 | Copyright 2018, Eric Clack, eric@bn7.net 12 | This program is distributed under the terms of the GNU General 13 | Public License 14 | |# 15 | 16 | (require 2htdp/universe 2htdp/image) 17 | (require "util.rkt") 18 | (require "2d.rkt") 19 | 20 | (struct world (boids mousex mousey) #:transparent) 21 | (struct boid (pos direction speed size) #:transparent) 22 | 23 | (define BIG-BOID 20) 24 | (define NUM-BOIDS 15) 25 | 26 | (define TICK-RATE 1/30) 27 | (define WIDTH 800) 28 | (define HEIGHT 600) 29 | 30 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 31 | 32 | (define (new-boid) 33 | (boid (pos (random WIDTH) (random HEIGHT)) 34 | (random 360) 35 | (+ 1 (random 2)) 36 | BIG-BOID)) 37 | 38 | (define (move-pos a-pos a-direction a-speed) 39 | (define r (degrees->radians a-direction)) 40 | (pos (+ (pos-x a-pos) (* a-speed (cos r))) 41 | (+ (pos-y a-pos) (* a-speed (sin r))))) 42 | 43 | (define (wrap-pos a-pos a-size) 44 | (define x (pos-x a-pos)) 45 | (define y (pos-y a-pos)) 46 | (pos (cond 47 | [(> x (+ WIDTH a-size)) (- 0 a-size)] 48 | [(< x (- 0 a-size)) (+ WIDTH a-size)] 49 | [else x]) 50 | (cond 51 | [(> y (+ HEIGHT a-size)) (- 0 a-size)] 52 | [(< y (- 0 a-size)) (+ HEIGHT a-size)] 53 | [else y]))) 54 | 55 | (define (move-boid a) 56 | ;; Move a boid based on its speed, direction and size 57 | (boid (wrap-pos 58 | (move-pos (boid-pos a) (boid-direction a) (boid-speed a)) 59 | (boid-size a)) 60 | (boid-direction a) 61 | (boid-speed a) 62 | (boid-size a))) 63 | 64 | (define (distance-force d) 65 | ;; What force applied for distance d 66 | (define force-limit 100) 67 | (if (< d force-limit) 68 | (- (/ (- force-limit d) 69 | (* 2 force-limit))) 70 | 0)) 71 | 72 | (define (avoid-mouse all-boids mousex mousey) 73 | ;; Adjust boid speed and direction to avoid collisions 74 | 75 | (define (apply-force a-boid) 76 | ;; The mouse position applies a force to this boid 77 | ;; based on distance and angle between each 78 | (define angle (angle-between (boid-pos a-boid) 79 | (pos mousex mousey))) 80 | (define mag (distance-force (distance-between (boid-pos a-boid) 81 | (pos mousex mousey)))) 82 | (define new-d-s (add-direction-speeds 83 | (boid-direction a-boid) (boid-speed a-boid) 84 | angle mag)) 85 | 86 | (boid (boid-pos a-boid) 87 | (first new-d-s) 88 | (second new-d-s) 89 | (boid-size a-boid))) 90 | 91 | (map apply-force all-boids)) 92 | 93 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 94 | 95 | (define (next-world w) 96 | (world (map move-boid 97 | (avoid-mouse (world-boids w) 98 | (world-mousex w) 99 | (world-mousey w))) 100 | (world-mousex w) (world-mousey w))) 101 | 102 | (define (mouse-event w x y e) 103 | (world (world-boids w) x y)) 104 | 105 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 106 | ;; Rendering 107 | 108 | (define (img+scene pos img scene) 109 | (place-image img (pos-x pos) (pos-y pos) scene)) 110 | 111 | (define (boids+scene boids scene) 112 | (foldl (λ (a scene) 113 | (img+scene (boid-pos a) 114 | (circle (boid-size a) "solid" "gray") 115 | scene)) 116 | scene boids)) 117 | 118 | (define (render-world w) 119 | (boids+scene (world-boids w) 120 | (empty-scene WIDTH HEIGHT "black"))) 121 | 122 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 123 | 124 | (define (go) 125 | (big-bang (world (times-repeat NUM-BOIDS (new-boid)) 0 0) 126 | (on-tick next-world TICK-RATE) 127 | (on-mouse mouse-event) 128 | (to-draw render-world))) 129 | -------------------------------------------------------------------------------- /boids3.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| Boids - bird like objects - https://en.wikipedia.org/wiki/Boids 4 | 5 | Version 3: Boids like each other, but don't like the mouse. 6 | 7 | Run (go) to start. 8 | 9 | -- 10 | 11 | Copyright 2018, Eric Clack, eric@bn7.net 12 | This program is distributed under the terms of the GNU General 13 | Public License 14 | |# 15 | 16 | (require 2htdp/universe 2htdp/image) 17 | (require "util.rkt") 18 | (require "2d.rkt") 19 | 20 | (struct world (boids mousex mousey) #:transparent) 21 | (struct boid (pos direction speed size) #:transparent) 22 | 23 | (define BIG-BOID 20) 24 | (define NUM-BOIDS 10) 25 | 26 | (define TICK-RATE 1/30) 27 | (define WIDTH 800) 28 | (define HEIGHT 600) 29 | 30 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 31 | 32 | (define (new-boid) 33 | (boid (pos (random WIDTH) (random HEIGHT)) 34 | (random 360) 35 | (+ 1 (random 2)) 36 | BIG-BOID)) 37 | 38 | (define (move-pos a-pos a-direction a-speed) 39 | (define r (degrees->radians a-direction)) 40 | (pos (+ (pos-x a-pos) (* a-speed (cos r))) 41 | (+ (pos-y a-pos) (* a-speed (sin r))))) 42 | 43 | (define (wrap-pos a-pos a-size) 44 | (define x (pos-x a-pos)) 45 | (define y (pos-y a-pos)) 46 | (pos (cond 47 | [(> x (+ WIDTH a-size)) (- 0 a-size)] 48 | [(< x (- 0 a-size)) (+ WIDTH a-size)] 49 | [else x]) 50 | (cond 51 | [(> y (+ HEIGHT a-size)) (- 0 a-size)] 52 | [(< y (- 0 a-size)) (+ HEIGHT a-size)] 53 | [else y]))) 54 | 55 | (define (move-boid a) 56 | ;; Move a boid based on its speed, direction and size 57 | (boid (wrap-pos 58 | (move-pos (boid-pos a) (boid-direction a) (boid-speed a)) 59 | (boid-size a)) 60 | (boid-direction a) 61 | (boid-speed a) 62 | (boid-size a))) 63 | 64 | (define (boid-distance-force d) 65 | ;; What force applied for distance d 66 | (cond 67 | [(< d 30) 1] 68 | [(< d 50) .1] 69 | [(< d 100) -.1] 70 | [(< d 200) -.05] 71 | [else 0])) 72 | 73 | (define (mouse-distance-force d) 74 | ;; What force applied for distance d 75 | (cond 76 | [(< d 50) -.5] 77 | [(< d 100) -.1] 78 | [else 0])) 79 | 80 | (define (apply-force a-boid angle mag) 81 | ;; Apply force with mag at angle to a-boid 82 | (define new-d-s (add-direction-speeds 83 | (boid-direction a-boid) (boid-speed a-boid) 84 | angle mag)) 85 | 86 | (boid (boid-pos a-boid) 87 | (first new-d-s) 88 | (min 3 (second new-d-s)) ; max speed 89 | (boid-size a-boid))) 90 | 91 | (define (avoid-mouse all-boids mousex mousey) 92 | ;; Adjust boid speed and direction to avoid collisions 93 | 94 | (define (-avoid-mouse a-boid) 95 | ;; The mouse position applies a force to this boid 96 | ;; based on distance and angle between each 97 | (define angle (angle-between (boid-pos a-boid) 98 | (pos mousex mousey))) 99 | (define mag (mouse-distance-force (distance-between (boid-pos a-boid) 100 | (pos mousex mousey)))) 101 | (apply-force a-boid angle mag)) 102 | 103 | (map -avoid-mouse all-boids)) 104 | 105 | (define (avoid-collisions all-boids) 106 | (define (-avoid-collisions a-boid) 107 | ;; Get a list of angle/mag pairs between this boid and world 108 | (define angles-mags 109 | (map (λ (b) 110 | (list (angle-between (boid-pos a-boid) 111 | (boid-pos b)) 112 | (- (boid-distance-force (distance-between 113 | (boid-pos a-boid) 114 | (boid-pos b)))))) 115 | (remove a-boid all-boids))) 116 | 117 | (define (cumulative-force angle-mag a-boid) 118 | (apply-force a-boid (first angle-mag) (second angle-mag))) 119 | 120 | (foldl cumulative-force a-boid angles-mags)) 121 | 122 | (map -avoid-collisions all-boids)) 123 | 124 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 125 | 126 | (define (next-world w) 127 | (world (map move-boid 128 | (avoid-collisions 129 | (avoid-mouse (world-boids w) 130 | (world-mousex w) 131 | (world-mousey w)))) 132 | (world-mousex w) (world-mousey w))) 133 | 134 | (define (mouse-event w x y e) 135 | (world (world-boids w) x y)) 136 | 137 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 138 | ;; Rendering 139 | 140 | (define (img+scene pos img scene) 141 | (place-image img (pos-x pos) (pos-y pos) scene)) 142 | 143 | (define (boids+scene boids scene) 144 | (foldl (λ (a scene) 145 | (img+scene (boid-pos a) 146 | (circle (boid-size a) "solid" "gray") 147 | scene)) 148 | scene boids)) 149 | 150 | (define (render-world w) 151 | (boids+scene (world-boids w) 152 | (empty-scene WIDTH HEIGHT "black"))) 153 | 154 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 155 | 156 | (define (go) 157 | (big-bang (world (times-repeat NUM-BOIDS (new-boid)) 0 0) 158 | (on-tick next-world TICK-RATE) 159 | (on-mouse mouse-event) 160 | (to-draw render-world))) 161 | -------------------------------------------------------------------------------- /boulder1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | 5 | Boulder Dash clone 6 | 7 | DONE: 8 | - Add boulders and gems to landscape 9 | - Make boulders fall 10 | 11 | TODO: 12 | - Pushing boulders 13 | - Fred blanks out falling boulders sometimes 14 | - Collect gems 15 | |# 16 | 17 | (require 2htdp/universe) 18 | (require 2htdp/image) 19 | (require lang/posn) 20 | (require "util.rkt") 21 | 22 | ;; Debug 23 | (require unstable/debug) 24 | (require racket/trace) 25 | 26 | (define WIDTH 16) 27 | (define HEIGHT 16) 28 | (define BLOCK-SIZE 50) 29 | (define TICK-RATE 0.25) 30 | 31 | (struct world (landscape fred level) #:transparent) 32 | ;; A landscape is (make-vector (* WIDTH HEIGHT)) 33 | (struct pos (x y) #:transparent) 34 | (struct fred (pos) #:transparent) 35 | (struct block (what pos) #:transparent) 36 | 37 | (define FRED-IMG (bitmap "images/smallface.gif")) 38 | (define MUD-IMG (bitmap "images/mud.gif")) 39 | (define BOULDER-IMG (bitmap "images/boulder.png")) 40 | (define WALL-IMG (bitmap "images/wall.gif")) 41 | (define GEM-IMG (bitmap "images/gem.gif")) 42 | 43 | (define (block->img a-block) 44 | (cond 45 | [(eq? a-block 'mud) MUD-IMG] 46 | [(eq? a-block 'boulder) BOULDER-IMG] 47 | [(eq? a-block 'wall) WALL-IMG] 48 | [(eq? a-block 'gem) GEM-IMG] 49 | [else (empty-scene BLOCK-SIZE BLOCK-SIZE "transparent")])) 50 | 51 | (define (vec-index a-pos) 52 | (+ (* (pos-y a-pos) WIDTH) (pos-x a-pos))) 53 | 54 | (define (pos->px p) 55 | (+ (/ BLOCK-SIZE 2) (* p BLOCK-SIZE))) 56 | 57 | (define (move-pos a-pos dx dy) 58 | (pos (+ (pos-x a-pos) dx) 59 | (+ (pos-y a-pos) dy))) 60 | 61 | (define (what_is_next_to a-landscape a-pos dx dy) 62 | (vector-ref a-landscape (vec-index (move-pos a-pos dx dy)))) 63 | 64 | (define (what-is-below a-landscape a-pos) 65 | (what_is_next_to a-landscape a-pos 0 1)) 66 | 67 | (define (can-fall a-landscape a-block) 68 | (eq? (what-is-below a-landscape (block-pos a-block)) 0)) 69 | 70 | (define (landscape-filter a-landscape what) 71 | ;; Return a list of blocks that match 'what' 72 | ;; A block is a (what pos) 73 | (for*/list ([y (range HEIGHT)] 74 | [x (range WIDTH)] 75 | #:when (eq? (vector-ref a-landscape (vec-index (pos x y))) 76 | what)) 77 | (block what (pos x y)))) 78 | 79 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 80 | 81 | (define (fred-can-move a-landscape a-fred dx dy) 82 | (member (what_is_next_to a-landscape (fred-pos a-fred) dx dy) 83 | '(0 mud gem))) 84 | 85 | (define (move-fred a-landscape a-fred dx dy) 86 | (define p (fred-pos a-fred)) 87 | (if (fred-can-move a-landscape a-fred dx dy) 88 | (fred (move-pos p dx dy)) 89 | a-fred)) 90 | 91 | (define (random-block) 92 | ;; mud is more likely 93 | (random-choice '(mud mud mud mud mud mud mud 94 | boulder boulder 95 | wall gem))) 96 | 97 | (define (make-landscape) 98 | (for*/vector ([y (range HEIGHT)] 99 | [x (range WIDTH)]) 100 | (cond 101 | ;; Walls around the edges 102 | [(or (= x 0) (= x (- WIDTH 1)) 103 | (= y 0) (= y (- HEIGHT 1))) 104 | 'wall] 105 | ;; Fred's pos 106 | [(and (= x 1) (= y 1)) 107 | 0] 108 | [else (random-block)]))) 109 | 110 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 111 | ;; Events 112 | 113 | (define (clear-freds-block! a-landscape a-fred) 114 | (vector-set! a-landscape (vec-index (fred-pos a-fred)) 0)) 115 | 116 | (define (boulders-fall! a-landscape) 117 | (define boulders (landscape-filter a-landscape 'boulder)) 118 | (for ([b (filter (curry can-fall a-landscape) boulders)]) 119 | (vector-set! a-landscape (vec-index (block-pos b)) 0) 120 | (vector-set! a-landscape (vec-index (move-pos (block-pos b) 0 1)) 121 | (block-what b)) 122 | )) 123 | 124 | (define (next-world w) 125 | (boulders-fall! (world-landscape w)) 126 | w) 127 | 128 | (define (direct-fred w a-key) 129 | (define f (world-fred w)) 130 | (define l (world-landscape w)) 131 | (define newf 132 | (cond 133 | [(key=? a-key "left") (move-fred l f -1 0)] 134 | [(key=? a-key "right") (move-fred l f 1 0)] 135 | [(key=? a-key "up") (move-fred l f 0 -1)] 136 | [(key=? a-key "down") (move-fred l f 0 1)] 137 | [else f])) 138 | (clear-freds-block! (world-landscape w) newf) 139 | (world (world-landscape w) newf (world-level w))) 140 | 141 | (define (fred-dead? w) 142 | #f) 143 | 144 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 145 | ;; Rendering 146 | 147 | (define (img+scene pos img scene) 148 | (place-image img 149 | (pos->px (pos-x pos)) (pos->px (pos-y pos)) 150 | scene)) 151 | 152 | (define (fred+scene a-fred scene) 153 | (img+scene (fred-pos a-fred) FRED-IMG 154 | scene)) 155 | 156 | (define (landscape-images a-landscape) 157 | (map block->img (vector->list a-landscape))) 158 | 159 | (define (landscape-posns) 160 | (for*/list ([y (range HEIGHT)] 161 | [x (range WIDTH)]) 162 | (make-posn (pos->px x) (pos->px y)) 163 | )) 164 | 165 | (define (landscape+scene a-landscape scene) 166 | (place-images (landscape-images a-landscape) 167 | (landscape-posns) scene)) 168 | 169 | (define (render-world w) 170 | (fred+scene (world-fred w) 171 | (landscape+scene (world-landscape w) 172 | (empty-scene (* WIDTH BLOCK-SIZE) 173 | (* HEIGHT BLOCK-SIZE) "black")))) 174 | 175 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 176 | 177 | (define (go) 178 | (big-bang (world (make-landscape) (fred (pos 1 1)) 1) 179 | (on-tick next-world TICK-RATE) 180 | (on-key direct-fred) 181 | (to-draw render-world) 182 | (stop-when fred-dead?))) 183 | -------------------------------------------------------------------------------- /boulder2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | 5 | Boulder Dash clone 6 | 7 | DONE: 8 | - Add boulders and gems to landscape 9 | - Make boulders fall 10 | - Store 'fred in landscape so that falling boulders works 11 | - Pushing boulders 12 | - Fred blanks out falling boulders sometimes 13 | - Collect gems 14 | 15 | TODO: 16 | - Boulder falling on fred ends game 17 | - Reset level with r 18 | - Aliens? 19 | - Bombs? 20 | - Make levels harder as you progress 21 | - Save and load levels -- or use text encoding 22 | - Still inconsistent use of block for struct and symbol 23 | |# 24 | 25 | (require 2htdp/universe) 26 | (require 2htdp/image) 27 | (require lang/posn) 28 | (require "util.rkt") 29 | 30 | ;; Debug 31 | ;;(require unstable/debug) 32 | ;;(require racket/trace) 33 | 34 | (define WIDTH 16) 35 | (define HEIGHT 16) 36 | (define BLOCK-SIZE 50) 37 | (define TICK-RATE 0.1) 38 | 39 | (struct world (landscape fred level) #:transparent) 40 | ;; A landscape is (make-vector (* WIDTH HEIGHT)) 41 | (struct pos (x y) #:transparent) 42 | (struct fred (pos) #:transparent) 43 | (struct block (what pos) #:transparent) 44 | 45 | (define FRED-IMG (bitmap "images/smallface.gif")) 46 | (define MUD-IMG (bitmap "images/mud.gif")) 47 | (define BOULDER-IMG (bitmap "images/boulder.png")) 48 | (define WALL-IMG (bitmap "images/wall.gif")) 49 | (define GEM-IMG (bitmap "images/gem.gif")) 50 | 51 | (define (blocksym->img a-symbol) 52 | (cond 53 | [(eq? a-symbol 'mud) MUD-IMG] 54 | [(eq? a-symbol 'boulder) BOULDER-IMG] 55 | [(eq? a-symbol 'wall) WALL-IMG] 56 | [(eq? a-symbol 'gem) GEM-IMG] 57 | [else (empty-scene BLOCK-SIZE BLOCK-SIZE "transparent")])) 58 | 59 | (define (vec-index a-pos) 60 | (+ (* (pos-y a-pos) WIDTH) (pos-x a-pos))) 61 | 62 | (define (set-block! a-landscape a-block) 63 | (vector-set! a-landscape (vec-index (block-pos a-block)) 64 | (block-what a-block))) 65 | 66 | (define (clear-block! a-landscape a-pos) 67 | (set-block! a-landscape (block 0 a-pos))) 68 | 69 | (define (pos->px p) 70 | (+ (/ BLOCK-SIZE 2) (* p BLOCK-SIZE))) 71 | 72 | (define (move-pos a-pos dx dy) 73 | (pos (+ (pos-x a-pos) dx) 74 | (+ (pos-y a-pos) dy))) 75 | 76 | (define (what_is_next_to a-landscape a-pos dx dy) 77 | ;; What is at a-pos + dx/dy? 78 | (vector-ref a-landscape (vec-index (move-pos a-pos dx dy)))) 79 | 80 | (define (what-is-below a-landscape a-pos) 81 | (what_is_next_to a-landscape a-pos 0 1)) 82 | 83 | (define (can-fall a-landscape a-block) 84 | (eq? (what-is-below a-landscape (block-pos a-block)) 0)) 85 | 86 | (define (landscape-filter a-landscape what) 87 | ;; Return a list of blocks that match 'what' 88 | ;; A block is a (what pos) 89 | (for*/list ([y (range HEIGHT)] 90 | [x (range WIDTH)] 91 | #:when (eq? (vector-ref a-landscape (vec-index (pos x y))) 92 | what)) 93 | (block what (pos x y)))) 94 | 95 | (define (no-gems-left? a-landscape) 96 | (empty? (landscape-filter a-landscape 'gem))) 97 | 98 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 99 | 100 | (define (random-block) 101 | ;; mud is more likely 102 | (random-choice '(mud mud mud mud mud mud mud 103 | boulder boulder 104 | wall gem))) 105 | 106 | (define (make-landscape) 107 | (for*/vector ([y (range HEIGHT)] 108 | [x (range WIDTH)]) 109 | (cond 110 | ;; Walls around the edges 111 | [(or (= x 0) (= x (- WIDTH 1)) 112 | (= y 0) (= y (- HEIGHT 1))) 113 | 'wall] 114 | ;; Fred's pos 115 | [(and (= x 1) (= y 1)) 116 | 0] 117 | [else (random-block)]))) 118 | 119 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 120 | ;; Events & movement 121 | 122 | (define (set-freds-block! a-landscape old-pos new-pos) 123 | (clear-block! a-landscape old-pos) 124 | (set-block! a-landscape (block 'fred new-pos))) 125 | 126 | (define (boulders-fall! a-landscape) 127 | (define boulders (landscape-filter a-landscape 'boulder)) 128 | (for ([b (filter (curry can-fall a-landscape) boulders)]) 129 | (let* ([cur-pos (block-pos b)] 130 | [new-pos (move-pos cur-pos 0 1)] 131 | [new-boulder (block 'boulder new-pos)]) 132 | (clear-block! a-landscape cur-pos) 133 | (set-block! a-landscape new-boulder) 134 | ))) 135 | 136 | (define (next-world w) 137 | (if (no-gems-left? (world-landscape w)) 138 | ;; Next level 139 | (world (make-landscape) (fred (pos 1 1)) (add1 (world-level w))) 140 | (begin 141 | (boulders-fall! (world-landscape w)) 142 | w))) 143 | 144 | (define (fred-can-move a-landscape a-fred dx dy) 145 | (member (what_is_next_to a-landscape (fred-pos a-fred) dx dy) 146 | '(0 mud gem))) 147 | 148 | (define (fred-can-push-boulder a-landscape a-fred dx dy) 149 | (and (zero? dy) 150 | (eq? (what_is_next_to a-landscape (fred-pos a-fred) dx 0) 'boulder) 151 | (eq? (what_is_next_to a-landscape (fred-pos a-fred) (* dx 2) 0) 0))) 152 | 153 | (define (try-move-fred! a-landscape a-fred dx dy) 154 | ;; Fred can move if there's mud, gem or empty space. 155 | ;; Change the landscape (fred's pos) and maybe a boulder 156 | ;; if fred pushes it 157 | (let* ([cur-pos (fred-pos a-fred)] 158 | [new-pos (move-pos cur-pos dx dy)]) 159 | (if (fred-can-move a-landscape a-fred dx dy) 160 | (begin 161 | (set-freds-block! a-landscape cur-pos new-pos) 162 | (fred new-pos)) 163 | (if (fred-can-push-boulder a-landscape a-fred dx dy) 164 | (begin 165 | (clear-block! a-landscape new-pos) 166 | (set-block! a-landscape (block 'boulder (move-pos new-pos dx dy))) 167 | (set-freds-block! a-landscape cur-pos new-pos) 168 | (fred new-pos)) 169 | a-fred)))) 170 | 171 | (define (direct-fred w a-key) 172 | (define f (world-fred w)) 173 | (define l (world-landscape w)) 174 | (define newf 175 | (cond 176 | [(key=? a-key "left") (try-move-fred! l f -1 0)] 177 | [(key=? a-key "right") (try-move-fred! l f 1 0)] 178 | [(key=? a-key "up") (try-move-fred! l f 0 -1)] 179 | [(key=? a-key "down") (try-move-fred! l f 0 1)] 180 | [else f])) 181 | (world (world-landscape w) newf (world-level w))) 182 | 183 | (define (fred-dead? w) 184 | #f) 185 | 186 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 187 | ;; Rendering 188 | 189 | (define (img+scene pos img scene) 190 | (place-image img 191 | (pos->px (pos-x pos)) (pos->px (pos-y pos)) 192 | scene)) 193 | 194 | (define (fred+scene a-fred scene) 195 | (img+scene (fred-pos a-fred) FRED-IMG 196 | scene)) 197 | 198 | (define (landscape-images a-landscape) 199 | (map blocksym->img (vector->list a-landscape))) 200 | 201 | (define (landscape-posns) 202 | (for*/list ([y (range HEIGHT)] 203 | [x (range WIDTH)]) 204 | (make-posn (pos->px x) (pos->px y)) 205 | )) 206 | 207 | (define (landscape+scene a-landscape scene) 208 | (place-images (landscape-images a-landscape) 209 | (landscape-posns) scene)) 210 | 211 | (define (render-world w) 212 | (fred+scene (world-fred w) 213 | (landscape+scene (world-landscape w) 214 | (empty-scene (* WIDTH BLOCK-SIZE) 215 | (* HEIGHT BLOCK-SIZE) "black")))) 216 | 217 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 218 | 219 | (define (go) 220 | (big-bang (world (make-landscape) (fred (pos 1 1)) 1) 221 | (on-tick next-world TICK-RATE) 222 | (on-key direct-fred) 223 | (to-draw render-world) 224 | (stop-when fred-dead?))) 225 | -------------------------------------------------------------------------------- /boulder3.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | 5 | Boulder Dash clone 6 | 7 | DONE: 8 | - Boulder falling on fred ends game 9 | - Reset level with r 10 | - Levels get harder 11 | - Dragons 12 | 13 | TODO: 14 | - Dragons - move more slowly 15 | - Dragons - kill fred 16 | - R to restart the same level, N for a new one 17 | - Bombs? 18 | - Save and load levels -- or use text encoding 19 | |# 20 | 21 | (require 2htdp/universe) 22 | (require 2htdp/image) 23 | (require lang/posn) 24 | (require "util.rkt") 25 | 26 | ;; Debug 27 | ;;(require unstable/debug) 28 | ;;(require racket/trace) 29 | 30 | (define WIDTH 16) 31 | (define HEIGHT 16) 32 | (define BLOCK-SIZE 50) 33 | (define TICK-RATE 0.1) 34 | 35 | (struct world (landscape fred level) #:transparent) 36 | ;; A landscape is (make-vector (* WIDTH HEIGHT)) 37 | (struct pos (x y) #:transparent) 38 | (struct fred (pos) #:transparent) 39 | (struct block (what pos) #:transparent) 40 | 41 | (define FRED-IMG (bitmap "images/smallface.gif")) 42 | (define DEAD-FRED-IMG (bitmap "images/deadfred.png")) 43 | (define MUD-IMG (bitmap "images/mud.gif")) 44 | (define BOULDER-IMG (bitmap "images/boulder.png")) 45 | (define FALLING-BOULDER-IMG (bitmap "images/falling-boulder.png")) 46 | (define WALL-IMG (bitmap "images/wall.gif")) 47 | (define GEM-IMG (bitmap "images/gem.gif")) 48 | (define DRAGON-IMG (bitmap "images/dragon.png")) 49 | 50 | (define (blocksym->img a-symbol) 51 | (cond 52 | [(eq? a-symbol 'mud) MUD-IMG] 53 | [(eq? a-symbol 'boulder) BOULDER-IMG] 54 | [(eq? a-symbol 'falling-boulder) FALLING-BOULDER-IMG] 55 | [(eq? a-symbol 'wall) WALL-IMG] 56 | [(eq? a-symbol 'gem) GEM-IMG] 57 | [(eq? a-symbol 'dragon) DRAGON-IMG] 58 | [else (empty-scene BLOCK-SIZE BLOCK-SIZE "transparent")])) 59 | 60 | (define (vec-index a-pos) 61 | (+ (* (pos-y a-pos) WIDTH) (pos-x a-pos))) 62 | 63 | (define (get-blocksym a-landscape a-pos) 64 | (vector-ref a-landscape (vec-index a-pos))) 65 | 66 | (define (get-block a-landscape a-pos) 67 | (block (get-block a-landscape a-pos) a-pos)) 68 | 69 | (define (set-block! a-landscape a-block) 70 | (vector-set! a-landscape (vec-index (block-pos a-block)) 71 | (block-what a-block))) 72 | 73 | (define (clear-block! a-landscape a-pos) 74 | (set-block! a-landscape (block 0 a-pos))) 75 | 76 | (define (pos->px p) 77 | (+ (/ BLOCK-SIZE 2) (* p BLOCK-SIZE))) 78 | 79 | (define (move-pos a-pos dx dy) 80 | (pos (+ (pos-x a-pos) dx) 81 | (+ (pos-y a-pos) dy))) 82 | 83 | (define (what-is-next-to a-landscape a-pos dx dy) 84 | ;; What is at a-pos + dx/dy? Return symbol 85 | (get-blocksym a-landscape (move-pos a-pos dx dy))) 86 | 87 | (define (what-is-below a-landscape a-pos) 88 | (what-is-next-to a-landscape a-pos 0 1)) 89 | 90 | (define (block-next-to a-landscape a-pos dx dy) 91 | ;; Like what-is-next-to but return block 92 | (let ([d-pos (move-pos a-pos dx dy)]) 93 | (block (get-blocksym a-landscape d-pos) 94 | d-pos))) 95 | 96 | (define (can-fall? a-landscape a-block) 97 | (let ([this-block (block-what a-block)] 98 | [block-below (what-is-below a-landscape (block-pos a-block))]) 99 | (if (eq? this-block 'falling-boulder) 100 | (member block-below '(0 fred)) 101 | (eq? block-below 0)))) 102 | 103 | (define (is-boulder? a-block) 104 | (or (eq? (block-what a-block) 'boulder) 105 | (eq? (block-what a-block) 'falling-boulder))) 106 | 107 | (define (is-gem? a-block) (eq? (block-what a-block) 'gem)) 108 | (define (is-dragon? a-block) (eq? (block-what a-block) 'dragon)) 109 | (define (is-empty? a-block) (eq? (block-what a-block) 0)) 110 | 111 | (define (landscape-filter a-landscape a-pred) 112 | ;; Return a list of blocks that match predicate 113 | ;; A block is a (what pos) 114 | (for*/list ([y (range HEIGHT)] 115 | [x (range WIDTH)] 116 | #:when (a-pred (block 117 | (vector-ref a-landscape (vec-index (pos x y))) 118 | (pos x y)))) 119 | (block (vector-ref a-landscape (vec-index (pos x y))) 120 | (pos x y)))) 121 | 122 | 123 | (define (no-gems-left? a-landscape) 124 | (empty? (landscape-filter a-landscape is-gem?))) 125 | 126 | (define (blanks-next-to a-landscape a-pos) 127 | ;; Return blanks poses next to this pos (N, E, S, W) 128 | (define bn block-next-to) 129 | (define blank-blocks 130 | (filter is-empty? (list 131 | (bn a-landscape a-pos -1 0) 132 | (bn a-landscape a-pos 1 0) 133 | (bn a-landscape a-pos 0 -1) 134 | (bn a-landscape a-pos 0 1)) 135 | )) 136 | (map block-pos blank-blocks)) 137 | 138 | 139 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 140 | 141 | (define (random-block level) 142 | ;; mud is more likely in lower levels 143 | (random-choice 144 | (append 145 | (times-repeat (+ 5 (- 10 (* 2 level))) 'mud) 146 | '(boulder boulder wall gem dragon)))) 147 | 148 | (define (make-landscape level) 149 | (for*/vector ([y (range HEIGHT)] 150 | [x (range WIDTH)]) 151 | (cond 152 | ;; Walls around the edges 153 | [(or (= x 0) (= x (- WIDTH 1)) 154 | (= y 0) (= y (- HEIGHT 1))) 155 | 'wall] 156 | ;; Fred's pos 157 | [(and (= x 1) (= y 1)) 158 | 'fred] 159 | [else (random-block level)]))) 160 | 161 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 162 | ;; Events & movement 163 | 164 | (define (set-freds-block! a-landscape old-pos new-pos) 165 | (clear-block! a-landscape old-pos) 166 | (set-block! a-landscape (block 'fred new-pos))) 167 | 168 | (define (boulders-fall! a-landscape) 169 | (define boulders (landscape-filter a-landscape is-boulder?)) 170 | (for ([b boulders]) 171 | (if (can-fall? a-landscape b) 172 | (let* ([cur-pos (block-pos b)] 173 | [new-pos (move-pos cur-pos 0 1)] 174 | [new-boulder (block 'falling-boulder new-pos)]) 175 | (clear-block! a-landscape cur-pos) 176 | (set-block! a-landscape new-boulder)) 177 | (set-block! a-landscape (block 'boulder (block-pos b)))) 178 | )) 179 | 180 | (define (dragons-move! a-landscape) 181 | (if (< (random) 0.1) 182 | (let ([dragons (landscape-filter a-landscape is-dragon?)]) 183 | (for ([d dragons]) 184 | (let* ([can-move (blanks-next-to a-landscape (block-pos d))] 185 | [new-pos (random-choice can-move)]) 186 | (if new-pos 187 | (begin 188 | (clear-block! a-landscape (block-pos d)) 189 | (set-block! a-landscape (block 'dragon new-pos))) 190 | #f)))) 191 | #f)) 192 | 193 | 194 | (define (next-world! w) 195 | (if (no-gems-left? (world-landscape w)) 196 | (let ([next-level (add1 (world-level w))]) 197 | (world (make-landscape next-level) (fred (pos 1 1)) next-level)) 198 | (begin 199 | (boulders-fall! (world-landscape w)) 200 | (dragons-move! (world-landscape w)) 201 | w))) 202 | 203 | (define (fred-can-move a-landscape a-fred dx dy) 204 | (member (what-is-next-to a-landscape (fred-pos a-fred) dx dy) 205 | '(0 mud gem))) 206 | 207 | (define (fred-can-push-boulder a-landscape a-fred dx dy) 208 | (and (zero? dy) 209 | (eq? (what-is-next-to a-landscape (fred-pos a-fred) dx 0) 'boulder) 210 | (eq? (what-is-next-to a-landscape (fred-pos a-fred) (* dx 2) 0) 0))) 211 | 212 | (define (try-move-fred! a-landscape a-fred dx dy) 213 | ;; Fred can move if there's mud, gem or empty space. 214 | ;; Change the landscape (fred's pos) and maybe a boulder 215 | ;; if fred pushes it 216 | (let* ([cur-pos (fred-pos a-fred)] 217 | [new-pos (move-pos cur-pos dx dy)]) 218 | (if (fred-can-move a-landscape a-fred dx dy) 219 | (begin 220 | (set-freds-block! a-landscape cur-pos new-pos) 221 | (fred new-pos)) 222 | (if (fred-can-push-boulder a-landscape a-fred dx dy) 223 | (begin 224 | (clear-block! a-landscape new-pos) 225 | (set-block! a-landscape (block 'boulder (move-pos new-pos dx dy))) 226 | (set-freds-block! a-landscape cur-pos new-pos) 227 | (fred new-pos)) 228 | a-fred)))) 229 | 230 | (define (direct-fred! w a-key) 231 | (define f (world-fred w)) 232 | (define l (world-landscape w)) 233 | (define newf 234 | (cond 235 | [(key=? a-key "left") (try-move-fred! l f -1 0)] 236 | [(key=? a-key "right") (try-move-fred! l f 1 0)] 237 | [(key=? a-key "up") (try-move-fred! l f 0 -1)] 238 | [(key=? a-key "down") (try-move-fred! l f 0 1)] 239 | [else f])) 240 | (if (key=? a-key "r") 241 | (world (make-landscape (world-level w)) (fred (pos 1 1)) (world-level w)) 242 | (world (world-landscape w) newf (world-level w)))) 243 | 244 | (define (fred-dead? w) 245 | ;; Fred is dead if he's not at his location in the landscape 246 | ;; e.g. there's a boulder there 247 | (let ([fp (fred-pos (world-fred w))]) 248 | (not (eq? (get-blocksym (world-landscape w) fp) 'fred)))) 249 | 250 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 251 | ;; Rendering 252 | 253 | (define (img+scene pos img scene) 254 | (place-image img 255 | (pos->px (pos-x pos)) (pos->px (pos-y pos)) 256 | scene)) 257 | 258 | (define (fred+scene a-fred scene) 259 | (img+scene (fred-pos a-fred) FRED-IMG scene)) 260 | 261 | (define (dead-fred+scene a-fred scene) 262 | (img+scene (fred-pos a-fred) DEAD-FRED-IMG scene)) 263 | 264 | (define (landscape-images a-landscape) 265 | (map blocksym->img (vector->list a-landscape))) 266 | 267 | (define (landscape-posns) 268 | (for*/list ([y (range HEIGHT)] 269 | [x (range WIDTH)]) 270 | (make-posn (pos->px x) (pos->px y)) 271 | )) 272 | 273 | (define (landscape+scene a-landscape scene) 274 | (place-images (landscape-images a-landscape) 275 | (landscape-posns) scene)) 276 | 277 | (define (render-world w) 278 | (define scene (landscape+scene (world-landscape w) 279 | (empty-scene (* WIDTH BLOCK-SIZE) 280 | (* HEIGHT BLOCK-SIZE) "black"))) 281 | (if (fred-dead? w) 282 | (dead-fred+scene (world-fred w) scene) 283 | (fred+scene (world-fred w) scene))) 284 | 285 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 286 | 287 | (define (go) 288 | (big-bang (world (make-landscape 1) (fred (pos 1 1)) 1) 289 | (on-tick next-world! TICK-RATE) 290 | (on-key direct-fred!) 291 | (to-draw render-world) 292 | (stop-when fred-dead?))) 293 | -------------------------------------------------------------------------------- /forest1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; 3D forest game 4 | 5 | ;; Version 1 6 | 7 | ;; To Do: 8 | ;; - Adapt from stars.rkt 9 | ;; - How big does something look at position x,y,z? Not just about z 10 | ;; - Why do trees get smaller as they get closer? 11 | ;; - move-tree should be move-player 12 | ;; - We currently have space physics -- up/down shouldn't keep us running 13 | ;; - Turn left/right 14 | 15 | (require 2htdp/universe 2htdp/image) 16 | (require "util.rkt") 17 | (require "3d.rkt") 18 | 19 | (require unstable/debug) 20 | 21 | ;; - to + of this value for new stars 22 | (define MAX-TREE-XY 500) 23 | 24 | (define MAX-TREES 25) 25 | (define MAX-ALIENS 10) 26 | (define ALIEN-SIZE 150) 27 | 28 | (define TICK-RATE 1/50) 29 | (define START-Z 100) 30 | 31 | ;; User controllable speed 32 | (define speed 0.1) 33 | (define MAX-SPEED 2.9) 34 | 35 | (define score 0) 36 | 37 | (define (random-tree-xy) (- (random MAX-TREE-XY) (/ MAX-TREE-XY 2))) 38 | (define (random-angle) (* (random) 2 pi)) 39 | 40 | ;; ----------------------------------------------------------- 41 | ;; The world and init 42 | 43 | (struct forest (stars aliens) #:transparent) 44 | (struct atree (pos) #:transparent) 45 | (struct alien (pos direction dirchange speed colour) #:transparent) 46 | 47 | 48 | (define (start-forest) 49 | (big-bang (init-world) 50 | (on-tick run TICK-RATE) 51 | (on-mouse mouse-event) 52 | (on-key key-event) 53 | (to-draw render-space) 54 | (stop-when end-game))) 55 | 56 | (define (init-world) 57 | (forest (times-repeat MAX-TREES (new-tree)) 58 | (times-repeat MAX-ALIENS (new-alien)))) 59 | 60 | ;; ----------------------------------------------------------- 61 | ;; Stars and Aliens 62 | 63 | (define (new-tree) 64 | (atree (point (random-tree-xy) 65 | 0 66 | (+ (random START-Z) 10)))) 67 | 68 | (define (move-tree s) 69 | (define p (atree-pos s)) 70 | (atree (point (point-x p) (point-y p) (- (point-z p) speed)))) 71 | 72 | (define (trees-in-view stars) 73 | (define (replace-tree s) 74 | (if (tree-out-of-view? s) (new-tree) s)) 75 | (map replace-tree stars)) 76 | 77 | (define (tree-out-of-view? s) 78 | (or 79 | (<= (point-z (atree-pos s)) 1) 80 | (> (point-z (atree-pos s)) 200))) 81 | 82 | ;; ........................................................... 83 | 84 | (define (new-alien) 85 | (define path (random-choice '(one two))) 86 | ;; direction is: inclination, azimuth 87 | ;; azimuth - 1.570 (pi/2) is left or right, no forward/backwards 88 | (define adirection 89 | (cond [(eq? path 'one) (direction 0 1.573)] 90 | [(eq? path 'two) (direction 1.573 1.571)] 91 | )) 92 | ;; Change in direction angles: inclination, azimuth 93 | (define achdirection 94 | (cond [(eq? path 'one) (direction (random-sign (/ (random) 10)) 0)] 95 | [(eq? path 'two) (direction (random-sign 0.09) 0.0002)] 96 | )) 97 | (define speed (+ 15 (random 15))) 98 | 99 | (alien 100 | (point 0 0 50) adirection achdirection speed 101 | (color (random-range 100 255) 102 | (random-range 100 255) 103 | (random-range 100 255)))) 104 | 105 | (define (move-alien a) 106 | (alien (add-points (move-point (alien-pos a) (alien-direction a) (alien-speed a)) 107 | (point 0 0 (- 0 speed))) 108 | (change-direction (alien-direction a) (alien-dirchange a)) 109 | (alien-dirchange a) 110 | (alien-speed a) 111 | (alien-colour a))) 112 | 113 | (define (aliens-in-view aliens) 114 | ;; Replace any aliens out of view with new ones 115 | (define (replace-alien s) 116 | (if (alien-out-of-view? s) (new-alien) s)) 117 | (map replace-alien aliens)) 118 | 119 | (define (alien-out-of-view? s) 120 | (or (<= (point-z (alien-pos s)) 1) 121 | (> (point-z (alien-pos s)) 100))) 122 | 123 | (define (run w) 124 | (forest (map move-tree (trees-in-view (forest-stars w))) 125 | (map move-alien (aliens-in-view (forest-aliens w))))) 126 | 127 | ;; ----------------------------------------------------------- 128 | ;; Input events 129 | 130 | (define (mouse-event w x y event) 131 | (define (kill-alien a) 132 | ;; If mouse pos x,y is inside the shape of the alien 133 | ;; then kill it, replacing it with a new one, otherwise leave it as it 134 | (define pos (alien-pos a)) 135 | (define size (screen-size ALIEN-SIZE pos)) 136 | (if (and (>= x (- (screen-x pos) size)) 137 | (<= x (+ (screen-x pos) size)) 138 | (>= y (- (screen-y pos) size)) 139 | (<= y (+ (screen-y pos) size))) 140 | (begin 141 | (set! score (add1 score)) 142 | (new-alien)) 143 | a)) 144 | 145 | (cond [(eq? event "button-down") 146 | (forest (forest-stars w) 147 | (map kill-alien (forest-aliens w)))] 148 | [else w])) 149 | 150 | (define (key-event w akey) 151 | (cond 152 | [(key=? akey "up") (set! speed (min (+ speed 0.1) MAX-SPEED))] 153 | [(key=? akey "down") (set! speed (max (- speed 0.1) (- 0 MAX-SPEED)))]) 154 | w) 155 | 156 | ;; ----------------------------------------------------------- 157 | ;; Rendering space, stars and aliens 158 | 159 | (define (render-space w) 160 | (score+scene 161 | (trees+scene (forest-stars w) 162 | (empty-scene WIDTH HEIGHT "black")))) 163 | 164 | (define (score+scene scene) 165 | (place-image 166 | (text (format "score : ~s" score) 24 "white") 167 | 60 20 168 | scene)) 169 | 170 | (define (tree-img t) 171 | (above (circle (tree-size t) "solid" (tree-colour t)) 172 | (rectangle (/ (tree-size t) 5) (tree-size t) "solid" (tree-colour t))) 173 | ) 174 | 175 | (define (trees+scene trees scene) 176 | ;; Place the stars on the scene 177 | (foldl (λ (s scene) 178 | (place-image (tree-img s) 179 | (screen-x (atree-pos s)) 180 | (screen-y (atree-pos s)) 181 | scene)) 182 | scene trees)) 183 | 184 | (define (tree-size t) 185 | (define d (abs (round (point-distance (atree-pos t) (point 0 0 0))))) 186 | (cond [(> d 100) 1] 187 | [else (+ 1 (/ (- 100 d) 4)) ])) 188 | 189 | (define (tree-colour s) 190 | (define z (round (point-z (atree-pos s)))) 191 | (cond [(> z 90) (color 255 255 255 20)] 192 | [else 193 | (define alph (min (+ 20 (* 2 (- 90 z))) 194 | 255)) 195 | (color 255 255 255 alph)])) 196 | 197 | ;; ----------------------------------------------------------- 198 | 199 | (define (end-game w) 200 | ;; No end! 201 | #f) 202 | 203 | (start-forest) -------------------------------------------------------------------------------- /images/asteroids5.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ericclack/racket-examples/ee858daac3577ead0c8463b9701a8653220039de/images/asteroids5.png -------------------------------------------------------------------------------- /images/boulder.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ericclack/racket-examples/ee858daac3577ead0c8463b9701a8653220039de/images/boulder.png -------------------------------------------------------------------------------- /images/boulder2-screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ericclack/racket-examples/ee858daac3577ead0c8463b9701a8653220039de/images/boulder2-screenshot.png -------------------------------------------------------------------------------- /images/deadfred.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ericclack/racket-examples/ee858daac3577ead0c8463b9701a8653220039de/images/deadfred.png -------------------------------------------------------------------------------- /images/dragon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ericclack/racket-examples/ee858daac3577ead0c8463b9701a8653220039de/images/dragon.png -------------------------------------------------------------------------------- /images/falling-boulder.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ericclack/racket-examples/ee858daac3577ead0c8463b9701a8653220039de/images/falling-boulder.png -------------------------------------------------------------------------------- /images/gem.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ericclack/racket-examples/ee858daac3577ead0c8463b9701a8653220039de/images/gem.gif -------------------------------------------------------------------------------- /images/mud.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ericclack/racket-examples/ee858daac3577ead0c8463b9701a8653220039de/images/mud.gif -------------------------------------------------------------------------------- /images/smallface.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ericclack/racket-examples/ee858daac3577ead0c8463b9701a8653220039de/images/smallface.gif -------------------------------------------------------------------------------- /images/space-pizza.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ericclack/racket-examples/ee858daac3577ead0c8463b9701a8653220039de/images/space-pizza.png -------------------------------------------------------------------------------- /images/spaceship.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ericclack/racket-examples/ee858daac3577ead0c8463b9701a8653220039de/images/spaceship.png -------------------------------------------------------------------------------- /images/spaceship2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ericclack/racket-examples/ee858daac3577ead0c8463b9701a8653220039de/images/spaceship2.png -------------------------------------------------------------------------------- /images/stars7.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ericclack/racket-examples/ee858daac3577ead0c8463b9701a8653220039de/images/stars7.png -------------------------------------------------------------------------------- /images/wall.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ericclack/racket-examples/ee858daac3577ead0c8463b9701a8653220039de/images/wall.gif -------------------------------------------------------------------------------- /learn-music-phrase1-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require rackunit "learn-music-phrase1.rkt") 4 | (require "util.rkt") 5 | (require/expose "learn-music-phrase1.rkt" (NOTES random-note-phrase-123 6 | random-note-phrase-135 7 | random-note-phrase pick-notes 8 | note-index world)) 9 | 10 | (test-case 11 | "tests for random-note-phrase-123" 12 | (check-true (list? (random-note-phrase-123))) 13 | (times-repeat 100 (check-equal? (length (random-note-phrase-123)) 3)) 14 | (let* ((phrase (random-note-phrase-123)) 15 | (n1 (first phrase)) 16 | (n2 (second phrase)) 17 | (n3 (third phrase))) 18 | (check-true (and (= (note-index n1) 19 | (- (note-index n2) 1) 20 | (- (note-index n3) 2))))) 21 | ) 22 | 23 | (test-case 24 | "tests for random-note-phrase-135" 25 | (check-true (list? (random-note-phrase-135))) 26 | (times-repeat 100 (check-equal? (length (random-note-phrase-135)) 3)) 27 | (let* ((phrase (random-note-phrase-135)) 28 | (n1 (first phrase)) 29 | (n2 (second phrase)) 30 | (n3 (third phrase))) 31 | (check-true (and (= (note-index n1) 32 | (- (note-index n2) 2) 33 | (- (note-index n3) 4))))) 34 | ) 35 | 36 | (test-case 37 | "tests for every-other" 38 | (check-equal? (every-other '(a b c d e f)) 39 | '(a c e)) 40 | (check-equal? (every-other '(a b c d e f g)) 41 | '(a c e g)) 42 | (check-equal? (every-other '()) '()) 43 | (check-equal? (every-other '(a)) '(a))) 44 | 45 | (test-case 46 | "tests for pick-notes" 47 | (check-equal? (pick-notes '(1 3 5) '(a b c d e f)) 48 | '(a c e))) 49 | 50 | (test-case 51 | "tests for random-note-phrase" 52 | (check-true (list? (random-note-phrase '(1 5 7))))) 53 | -------------------------------------------------------------------------------- /learn-music-phrase1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | Show notes, then play them, see if you get them right! 5 | Press any key if you find the note easy, you'll then 6 | get less time to play this note next time. 7 | 8 | Challenge: How to avoid practicing mistakes or quick 9 | corrections, wait for the player to remember first? 10 | 11 | CHANGES from v3: 12 | - Add drills to practice phrases of notes: 13 | (note, note+1 note+2) 14 | (note, note+2, note+4) 15 | etc 16 | - Show current note and the next one 17 | - Add back in easy-note logic for phrases - play them less 18 | often 19 | 20 | TODO: 21 | - Fix e2 ledger lines 22 | - Bigger display, scalable with some variable 23 | - Reverse phrases randomly 24 | - Save easy-notes for next time, so that the player 25 | doesn't need to edit the source code 26 | - Fix display of ledgers 27 | |# 28 | 29 | (require srfi/1) 30 | (require 2htdp/universe 2htdp/image) 31 | (require 2htdp/image) 32 | (require rsound) 33 | (require rsound/piano-tones) 34 | (require "util.rkt") 35 | (require racket/trace) 36 | 37 | ;; What notes do we want to practice? 38 | (define NOTES 39 | '(e2 f2 g2 a3 b3 c3 d3 e3 f3 g3 a4 b4 c4 d4 e4 f4 g4 a5 b5 c5)) 40 | ;; We need MIDI numbers to play them, these are the standard set 41 | (define PIANO-MIDI-NOTES 42 | '(52 53 55 57 59 60 62 64 65 67 69 71 72 74 76 77 79 81 83 84)) 43 | ;; Guitar midi notes are one octave lower 44 | (define MIDI-NOTES 45 | (map (λ (x) (- x 12)) PIANO-MIDI-NOTES)) 46 | 47 | ;; We want to show the open string notes differently 48 | (define OPEN-STRINGS 49 | '(e2 a3 d3 g3 b4 e4)) 50 | ;; The initial set of easy phrases for *me* to play - change this 51 | ;; to suit your needs 52 | (define EASY-PHRASES 53 | '((a3 b3 c3) (e4 f4 g4) (a4 b4 c4) (e3 e4 b4) (e3 g3 b4) (g3 a4 b4) (d3 e3 f3))) 54 | ;; How likely to skip easy phrases (0-1)? 55 | (define SKIP-EASY-PHRASES 0.7) 56 | 57 | ;; The canvas 58 | (define WIDTH 400) 59 | (define HEIGHT 300) 60 | (define G-CLEF (bitmap "GClef.png")) 61 | 62 | ;; How many seconds between notes? Change this to suit your needs 63 | (define TICK-RATE 0.75) 64 | 65 | (define PIX-PER-NOTE 11) 66 | (define PIX-BETWEEN-LINES (* 2 PIX-PER-NOTE)) 67 | 68 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 69 | 70 | (define (note-index a-note) 71 | (list-index (curry equal? a-note) NOTES)) 72 | 73 | (define above/align-left 74 | ((curry above/align) "left")) 75 | 76 | (define (stave) 77 | (overlay/offset 78 | (scale 0.53 G-CLEF) 79 | 120 -6 80 | (overlay 81 | (apply above/align-left 82 | (cons (line 300 0 "black") 83 | (times-repeat 4 84 | (above/align-left 85 | (line 0 20 "black") 86 | (line 300 0 "black") 87 | )))) 88 | (empty-scene WIDTH HEIGHT "white")))) 89 | 90 | (define (note-pos-relative-b4 a-note) 91 | ;; b4 is the middle of the stave 92 | ;; b4 = 0, a4 = -1, c4 = 1, etc 93 | (- (note-index a-note) PIX-PER-NOTE)) 94 | 95 | (define (note-y-pos a-note) 96 | (* PIX-PER-NOTE (note-pos-relative-b4 a-note))) 97 | 98 | (define (ledger-line) 99 | (line 30 0 "black")) 100 | 101 | (define (ledger-lines a-note) 102 | (define num-lines 103 | (/ (- (abs (note-pos-relative-b4 a-note)) 4) 2)) 104 | (define ledger-images 105 | (times-repeat num-lines (ledger-line))) 106 | (define ledger-lines-img 107 | (foldr (λ (i scene) (above i (empty-scene 0 PIX-BETWEEN-LINES) scene)) 108 | (empty-scene 0 0) 109 | ledger-images)) 110 | 111 | (if (ledger-lines-above? a-note) 112 | ;; TODO: replace pix numbers with formulae 113 | (overlay/align/offset 114 | "middle" "bottom" 115 | ledger-lines-img 116 | 0 193 117 | (empty-scene 0 HEIGHT)) 118 | (overlay/align/offset 119 | "middle" "top" 120 | ledger-lines-img 121 | 0 -216 122 | (empty-scene 0 HEIGHT)))) 123 | 124 | (define (ledger-lines-above? a-note) 125 | ;; Are the extenders above the stave (or below)? 126 | (>= (note-pos-relative-b4 a-note) 0)) 127 | 128 | (define (note-img a-note) 129 | ;; A note, with a hint for open strings 130 | (circle 10 131 | (if (member a-note OPEN-STRINGS) "outline" "solid") 132 | "black")) 133 | 134 | (define (note+ledger-line-img a-note) 135 | (overlay 136 | (ledger-lines a-note) 137 | (overlay/offset 138 | (note-img a-note) 139 | 0 (note-y-pos a-note) 140 | (empty-scene 0 HEIGHT)))) 141 | 142 | (define (note-phrase-img notes) 143 | ;; A sequence of notes including extenders 144 | (foldr (λ (n scene) (beside (note+ledger-line-img n) 145 | (empty-scene 10 0) scene)) 146 | (empty-scene 10 0) 147 | notes)) 148 | 149 | (define (show-notes notes) 150 | (overlay 151 | (note-phrase-img notes) 152 | (stave))) 153 | 154 | (define (show-note a-note) 155 | (show-notes (list a-note))) 156 | 157 | (define (play-note a-note) 158 | (play (piano-tone 159 | (list-ref MIDI-NOTES (note-index a-note))))) 160 | 161 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 162 | 163 | (define (next-random-note last-note easy-notes) 164 | ;; Next random note, but not last-note 165 | ;; also play easy-notes less often 166 | (define note (random-choice NOTES)) 167 | (if (or (eq? note last-note) 168 | (and (member note easy-notes) 169 | (< (random) SKIP-EASY-PHRASES))) 170 | (next-random-note last-note easy-notes) 171 | note)) 172 | 173 | (define (play-note-times a-note easy-notes) 174 | (if (member a-note easy-notes) 2 4)) 175 | 176 | ;; The procs next-note-phrase-??? return a sequence of notes 177 | ;; that make some kind of pleasing phrase 178 | 179 | (define (random-note-phrase-123) 180 | (random-note-phrase '(1 2 3))) 181 | 182 | (define (random-note-phrase-135) 183 | (random-note-phrase '(1 3 5))) 184 | 185 | (define (pick-notes deltas notes) 186 | (cond 187 | [(empty? deltas) '()] 188 | [else (cons (list-ref notes (- (car deltas) 1)) 189 | (pick-notes (cdr deltas) notes))])) 190 | 191 | (define (random-note-phrase deltas) 192 | (define first-note (next-random-note #f '())) 193 | (define notes (member first-note NOTES)) 194 | (define max-delta (apply max deltas)) 195 | (if (< (length notes) max-delta) 196 | (random-note-phrase deltas) 197 | (pick-notes deltas notes))) 198 | 199 | ;; Which type of note phrase to use? 200 | (define (next-note-phrase easy-phrases) 201 | (define phrase 202 | (random-note-phrase (random-choice '((1 2 3) (1 3 5) (1 5 3) (1 5 7) 203 | (4 2 3 1) (1 8 5))))) 204 | (if (and (member phrase easy-phrases) 205 | (< (random) SKIP-EASY-PHRASES)) 206 | (next-note-phrase easy-phrases) 207 | phrase)) 208 | 209 | 210 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 211 | ;; big-bang world 212 | 213 | (struct world (note notes-left phrase plays easy-phrases) #:transparent) 214 | 215 | (define (next-note w) 216 | ;; Play the next note from the current phrase, repeat the phrase 217 | ;; or generate a new one. 218 | 219 | (cond 220 | [(empty? (world-notes-left w)) 221 | ;; We've finished playing the phrase 222 | (cond 223 | [(= 1 (world-plays w)) 224 | ;; Finished repeats, make a new phrase 225 | (let* ([phrase (next-note-phrase (world-easy-phrases w))] 226 | [plays 4]) 227 | (next-note (world (car phrase) phrase phrase 228 | plays (world-easy-phrases w))))] 229 | [else 230 | ;; More repeats left, restart phrase 231 | (next-note (world #f (world-phrase w) (world-phrase w) 232 | (sub1 (world-plays w)) (world-easy-phrases w)))])] 233 | [else 234 | ;; We're still playing the phrase 235 | (play-note (car (world-notes-left w))) 236 | (world (car (world-notes-left w)) (cdr (world-notes-left w)) (world-phrase w) 237 | (world-plays w) (world-easy-phrases w))])) 238 | 239 | (define (easy-phrase w a-key) 240 | ;; The user finds the current note easy - stop playing it 241 | ;; and add it to the set 242 | (let ((phrase (world-phrase w)) 243 | (easy-phrases (world-easy-phrases w))) 244 | (world (world-note w) '() phrase 1 245 | (if (member phrase easy-phrases) 246 | easy-phrases 247 | (cons phrase easy-phrases))))) 248 | 249 | (define (render-scene w) 250 | (place-image/align 251 | (above/align "left" 252 | (text (string-append "Easy phrases: " 253 | (string-join (map (λ (x) (format "~a" x)) 254 | (world-easy-phrases w)) ", ")) 255 | 15 "black") 256 | (text "Press any key to add current note" 15 "black")) 257 | 5 5 "left" "top" 258 | (show-notes (world-phrase w)))) 259 | 260 | (define (go) 261 | (define phrase (next-note-phrase EASY-PHRASES)) 262 | (big-bang (world (car phrase) phrase phrase 4 EASY-PHRASES) 263 | (on-tick next-note TICK-RATE) 264 | (on-key easy-phrase) 265 | (to-draw render-scene))) 266 | 267 | (go) -------------------------------------------------------------------------------- /learn-music-phrase2-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require rackunit "learn-music-phrase2.rkt") 4 | (require "util.rkt") 5 | (require/expose "learn-music-phrase2.rkt" (NOTES random-note-phrase-123 6 | random-note-phrase-135 7 | random-note-phrase pick-notes 8 | note-index note-pos-relative-b4 9 | world)) 10 | 11 | (test-case 12 | "tests for note-index and note-pos-relative-b4" 13 | (check-equal? (note-index 'e2) 0) 14 | (check-equal? (note-index 'b4) 11) 15 | (check-equal? (note-pos-relative-b4 'e2) -11) 16 | (check-equal? (note-pos-relative-b4 'b4) 0) 17 | (check-equal? (note-pos-relative-b4 'e4) 3)) 18 | 19 | (test-case 20 | "tests for random-note-phrase-123" 21 | (check-true (list? (random-note-phrase-123))) 22 | (times-repeat 100 (check-equal? (length (random-note-phrase-123)) 3)) 23 | (let* ((phrase (random-note-phrase-123)) 24 | (n1 (first phrase)) 25 | (n2 (second phrase)) 26 | (n3 (third phrase))) 27 | (check-true (and (= (note-index n1) 28 | (- (note-index n2) 1) 29 | (- (note-index n3) 2))))) 30 | ) 31 | 32 | (test-case 33 | "tests for random-note-phrase-135" 34 | (check-true (list? (random-note-phrase-135))) 35 | (times-repeat 100 (check-equal? (length (random-note-phrase-135)) 3)) 36 | (let* ((phrase (random-note-phrase-135)) 37 | (n1 (first phrase)) 38 | (n2 (second phrase)) 39 | (n3 (third phrase))) 40 | (check-true (and (= (note-index n1) 41 | (- (note-index n2) 2) 42 | (- (note-index n3) 4))))) 43 | ) 44 | 45 | (test-case 46 | "tests for every-other" 47 | (check-equal? (every-other '(a b c d e f)) 48 | '(a c e)) 49 | (check-equal? (every-other '(a b c d e f g)) 50 | '(a c e g)) 51 | (check-equal? (every-other '()) '()) 52 | (check-equal? (every-other '(a)) '(a))) 53 | 54 | (test-case 55 | "tests for pick-notes" 56 | (check-equal? (pick-notes '(1 3 5) '(a b c d e f)) 57 | '(a c e))) 58 | 59 | (test-case 60 | "tests for random-note-phrase" 61 | (check-true (list? (random-note-phrase '(1 5 7))))) 62 | -------------------------------------------------------------------------------- /learn-music-phrase2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | Show notes, then play them, see if you get them right! 5 | Press any key if you find the note easy, you'll then 6 | get less time to play this note next time. 7 | 8 | Challenge: How to avoid practicing mistakes or quick 9 | corrections, wait for the player to remember first? 10 | 11 | CHANGES from v1: 12 | - Fix e2 ledger lines 13 | - Bigger display, scalable with some variable 14 | 15 | TODO: 16 | - Drills 17 | E.g. (show-notes '(e3 g3 b4 d4 f4)) 18 | (show-notes '(f3 a4 c4 e4)) 19 | - Reverse phrases randomly 20 | - Save easy-notes for next time, so that the player 21 | doesn't need to edit the source code 22 | - Fix display of ledgers 23 | |# 24 | 25 | (require srfi/1) 26 | (require 2htdp/universe 2htdp/image) 27 | (require 2htdp/image) 28 | (require rsound) 29 | (require rsound/piano-tones) 30 | (require "util.rkt") 31 | (require racket/trace) 32 | 33 | ;; What notes do we want to practice? 34 | (define NOTES 35 | '(e2 f2 g2 a3 b3 c3 d3 e3 f3 g3 a4 b4 c4 d4 e4 f4 g4 a5 b5 c5)) 36 | ;; We need MIDI numbers to play them, these are the standard set 37 | (define PIANO-MIDI-NOTES 38 | '(52 53 55 57 59 60 62 64 65 67 69 71 72 74 76 77 79 81 83 84)) 39 | ;; Guitar midi notes are one octave lower 40 | (define MIDI-NOTES 41 | (map (λ (x) (- x 12)) PIANO-MIDI-NOTES)) 42 | 43 | ;; We want to show the open string notes differently 44 | (define OPEN-STRINGS 45 | '(e2 a3 d3 g3 b4 e4)) 46 | 47 | ;; Our phrases to practice, expressed in terms of the root 48 | ;; note 1, so (1 2 3) is the root note and the next two in 49 | ;; the scale 50 | (define NOTE-PHRASES 51 | '((1 2 3) (1 3 5) (1 5 3) (1 5 7) (4 2 3 1) (1 8 5))) 52 | ;; The initial set of easy phrases for *me* to play - change this 53 | ;; to suit your needs 54 | (define EASY-PHRASES 55 | '((a3 b3 c3) (e4 f4 g4) (a4 b4 c4) (e3 e4 b4) (e3 g3 b4) (g3 a4 b4) (d3 e3 f3))) 56 | ;; How likely to skip easy phrases (0-1)? 57 | (define SKIP-EASY-PHRASES 0.7) 58 | 59 | ;; The canvas 60 | (define WIDTH 500) 61 | (define HEIGHT 400) 62 | (define G-CLEF (bitmap "GClef.png")) 63 | (define NOTE-SIZE 30) 64 | (define STAVE-WIDTH 400) 65 | 66 | ;; How many seconds between notes? Change this to suit your needs 67 | (define TICK-RATE 1) 68 | 69 | 70 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 71 | 72 | (define (note-index a-note) 73 | (list-index (curry equal? a-note) NOTES)) 74 | 75 | (define above/align-left 76 | ((curry above/align) "left")) 77 | 78 | (define (stave) 79 | (define scaled-clef-height (* (* NOTE-SIZE 5) 1.35)) 80 | (overlay/offset 81 | (scale (/ scaled-clef-height (image-height G-CLEF)) G-CLEF) 82 | 140 (+ 1 (- 0 (/ NOTE-SIZE 3))) 83 | (overlay 84 | (apply above/align-left 85 | (cons (line STAVE-WIDTH 0 "black") 86 | (times-repeat 4 87 | (above/align-left 88 | (line 0 (- NOTE-SIZE 1) "black") 89 | (line STAVE-WIDTH 0 "black") 90 | )))) 91 | (empty-scene WIDTH HEIGHT "white")))) 92 | 93 | (define (note-pos-relative-b4 a-note) 94 | ;; b4 is the middle of the stave 95 | ;; b4 = 0, a4 = -1, c4 = 1, etc 96 | (define b4-pos (note-index 'b4)) 97 | (- (note-index a-note) b4-pos)) 98 | 99 | (define (note-y-pos a-note) 100 | (* (/ NOTE-SIZE 2) (note-pos-relative-b4 a-note))) 101 | 102 | (define (ledger-line) 103 | (line (* NOTE-SIZE 1.3) 0 "black")) 104 | 105 | (define (ledger-lines a-note) 106 | (define num-lines 107 | (/ (- (abs (note-pos-relative-b4 a-note)) 5) 2)) 108 | (define ledger-images 109 | (times-repeat num-lines (ledger-line))) 110 | (define ledger-lines-img 111 | (foldr (λ (i scene) (above i (empty-scene 0 NOTE-SIZE) scene)) 112 | (empty-scene 0 0) 113 | ledger-images)) 114 | 115 | (if (ledger-lines-above? a-note) 116 | ;; TODO: replace pix numbers with formulae 117 | (overlay/align/offset 118 | "middle" "bottom" 119 | ledger-lines-img 120 | 0 (+ (/ HEIGHT 2) (* NOTE-SIZE 2)) 121 | (empty-scene 0 HEIGHT)) 122 | (overlay/align/offset 123 | "middle" "top" 124 | ledger-lines-img 125 | 0 (- 0 (+ (/ HEIGHT 2) (* NOTE-SIZE 3))) 126 | (empty-scene 0 HEIGHT)))) 127 | 128 | (define (ledger-lines-above? a-note) 129 | ;; Are the extenders above the stave (or below)? 130 | (>= (note-pos-relative-b4 a-note) 0)) 131 | 132 | (define (note-img a-note) 133 | ;; A note, with a hint for open strings 134 | (circle (/ NOTE-SIZE 2) 135 | "solid" 136 | (if (member a-note OPEN-STRINGS) "darkgreen" "black"))) 137 | 138 | (define (note+ledger-line-img a-note) 139 | (overlay 140 | (ledger-lines a-note) 141 | (overlay/offset 142 | (note-img a-note) 143 | 0 (note-y-pos a-note) 144 | (empty-scene 0 HEIGHT)))) 145 | 146 | (define (note-phrase-img notes) 147 | ;; A sequence of notes including extenders 148 | (foldr (λ (n scene) (beside (note+ledger-line-img n) 149 | (empty-scene (/ NOTE-SIZE 2) 0) scene)) 150 | (empty-scene (/ NOTE-SIZE 2) 0) 151 | notes)) 152 | 153 | (define (show-notes notes) 154 | (overlay 155 | (note-phrase-img notes) 156 | (stave))) 157 | 158 | (define (show-note a-note) 159 | (show-notes (list a-note))) 160 | 161 | (define (play-note a-note) 162 | (play (piano-tone 163 | (list-ref MIDI-NOTES (note-index a-note))))) 164 | 165 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 166 | 167 | (define (next-random-note last-note easy-notes) 168 | ;; Next random note, but not last-note 169 | ;; also play easy-notes less often 170 | (define note (random-choice NOTES)) 171 | (if (or (eq? note last-note) 172 | (and (member note easy-notes) 173 | (< (random) SKIP-EASY-PHRASES))) 174 | (next-random-note last-note easy-notes) 175 | note)) 176 | 177 | (define (play-note-times a-note easy-notes) 178 | (if (member a-note easy-notes) 2 4)) 179 | 180 | ;; The procs next-note-phrase-??? return a sequence of notes 181 | ;; that make some kind of pleasing phrase 182 | 183 | (define (random-note-phrase-123) 184 | (random-note-phrase '(1 2 3))) 185 | 186 | (define (random-note-phrase-135) 187 | (random-note-phrase '(1 3 5))) 188 | 189 | (define (pick-notes deltas notes) 190 | (cond 191 | [(empty? deltas) '()] 192 | [else (cons (list-ref notes (- (car deltas) 1)) 193 | (pick-notes (cdr deltas) notes))])) 194 | 195 | (define (random-note-phrase deltas) 196 | (define first-note (next-random-note #f '())) 197 | (define notes (member first-note NOTES)) 198 | (define max-delta (apply max deltas)) 199 | (if (< (length notes) max-delta) 200 | (random-note-phrase deltas) 201 | (pick-notes deltas notes))) 202 | 203 | ;; Which type of note phrase to use? 204 | (define (next-note-phrase easy-phrases) 205 | (define phrase (random-note-phrase 206 | (random-choice NOTE-PHRASES))) 207 | (if (and (member phrase easy-phrases) 208 | (< (random) SKIP-EASY-PHRASES)) 209 | (next-note-phrase easy-phrases) 210 | phrase)) 211 | 212 | 213 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 214 | ;; big-bang world 215 | 216 | (struct world (note notes-left phrase plays easy-phrases) #:transparent) 217 | 218 | (define (next-note w) 219 | ;; Play the next note from the current phrase, repeat the phrase 220 | ;; or generate a new one. 221 | 222 | (cond 223 | [(empty? (world-notes-left w)) 224 | ;; We've finished playing the phrase 225 | (cond 226 | [(= 1 (world-plays w)) 227 | ;; Finished repeats, make a new phrase 228 | (let* ([phrase (next-note-phrase (world-easy-phrases w))] 229 | [plays 4]) 230 | (next-note (world (car phrase) phrase phrase 231 | plays (world-easy-phrases w))))] 232 | [else 233 | ;; More repeats left, restart phrase 234 | (next-note (world #f (world-phrase w) (world-phrase w) 235 | (sub1 (world-plays w)) (world-easy-phrases w)))])] 236 | [else 237 | ;; We're still playing the phrase 238 | (play-note (car (world-notes-left w))) 239 | (world (car (world-notes-left w)) (cdr (world-notes-left w)) (world-phrase w) 240 | (world-plays w) (world-easy-phrases w))])) 241 | 242 | (define (easy-phrase w a-key) 243 | ;; The user finds the current note easy - stop playing it 244 | ;; and add it to the set 245 | (let ((phrase (world-phrase w)) 246 | (easy-phrases (world-easy-phrases w))) 247 | (world (world-note w) '() phrase 1 248 | (if (member phrase easy-phrases) 249 | easy-phrases 250 | (cons phrase easy-phrases))))) 251 | 252 | (define (render-scene w) 253 | (place-image/align 254 | (above/align "left" 255 | (text (string-append "Easy phrases: " 256 | (string-join (map (λ (x) (format "~a" x)) 257 | (world-easy-phrases w)) ", ")) 258 | 15 "black") 259 | (text "Press any key to add current note" 15 "black")) 260 | 5 5 "left" "top" 261 | (show-notes (world-phrase w)))) 262 | 263 | (define (go) 264 | (define phrase (next-note-phrase EASY-PHRASES)) 265 | (big-bang (world (car phrase) phrase phrase 4 EASY-PHRASES) 266 | (on-tick next-note TICK-RATE) 267 | (on-key easy-phrase) 268 | (to-draw render-scene))) 269 | 270 | (go) -------------------------------------------------------------------------------- /learn-music1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | Show notes, then play them, see if you get them right! 5 | 6 | TODO: 7 | - Add extender bars above and below main stave for high and low notes 8 | - Show a succession of notes 9 | |# 10 | 11 | 12 | (require srfi/1) 13 | (require 2htdp/image) 14 | (require rsound) 15 | (require rsound/piano-tones) 16 | (require "util.rkt") 17 | 18 | (define NOTES 19 | '(e2 f2 g2 a3 b3 c3 d3 e3 f3 g3 a4 b4 c4 d4 e4 f4 g4 a5)) 20 | 21 | (define MIDI-NOTES 22 | '(52 53 55 57 59 60 62 64 65 67 69 71 72 74 76 77 79 81)) 23 | 24 | (define PIX-PER-NOTE 11) 25 | 26 | (define (note-index a-note) 27 | (list-index (curry equal? a-note) NOTES)) 28 | 29 | (define above/align-left 30 | ((curry above/align) "left")) 31 | 32 | (define (stave) 33 | (apply above/align-left 34 | (cons (line 300 0 "white") 35 | (times-repeat 4 36 | (above/align-left 37 | (line 0 20 "white") 38 | (line 300 0 "white") 39 | )))) 40 | ) 41 | 42 | (define (note-y-pos a-note) 43 | (* PIX-PER-NOTE (- (note-index a-note) 11))) 44 | 45 | (define (show-note a-note) 46 | (overlay/offset 47 | (circle 10 "solid" "white") 48 | 0 (note-y-pos a-note) 49 | (stave))) 50 | 51 | (define (play-note a-note) 52 | (play (piano-tone 53 | (list-ref MIDI-NOTES (note-index a-note))))) 54 | 55 | (define (play-and-show-note a-note) 56 | (play-note a-note) 57 | (show-note a-note)) 58 | 59 | (play-and-show-note 'b4) 60 | -------------------------------------------------------------------------------- /learn-music2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | Show notes, then play them, see if you get them right! 5 | 6 | TODO: 7 | - Add extender bars above and below main stave for high and low notes 8 | - Show a succession of notes 9 | |# 10 | 11 | (require racket/trace) 12 | (require srfi/1) 13 | (require 2htdp/image) 14 | (require rsound) 15 | (require rsound/piano-tones) 16 | (require "util.rkt") 17 | 18 | (define WIDTH 300) 19 | (define HEIGHT 200) 20 | 21 | (define NOTES 22 | '(e2 f2 g2 a3 b3 c3 d3 e3 f3 g3 a4 b4 c4 d4 e4 f4 g4 a5 b5 c5 d5)) 23 | 24 | (define MIDI-NOTES 25 | '(52 53 55 57 59 60 62 64 65 67 69 71 72 74 76 77 79 81 83 84 86)) 26 | 27 | (define PIX-PER-NOTE 11) 28 | (define PIX-BETWEEN-LINES (* 2 PIX-PER-NOTE)) 29 | 30 | (define (note-index a-note) 31 | (list-index (curry equal? a-note) NOTES)) 32 | 33 | (define above/align-left 34 | ((curry above/align) "left")) 35 | 36 | (define (stave) 37 | (apply above/align-left 38 | (cons (line 300 0 "white") 39 | (times-repeat 4 40 | (above/align-left 41 | (line 0 20 "white") 42 | (line 300 0 "white") 43 | )))) 44 | ) 45 | 46 | (define (note-pos-relative-b4 a-note) 47 | ;; b4 is the middle of the stave 48 | ;; b4 = 0, a4 = -1, c4 = 1, etc 49 | (- (note-index a-note) 11)) 50 | 51 | (define (note-y-pos a-note) 52 | (* PIX-PER-NOTE (note-pos-relative-b4 a-note))) 53 | 54 | (define (extender-line) 55 | (line 30 0 "white")) 56 | 57 | (define (extenders a-note-pos) 58 | ;; Draw extenders from b4 up or down to note 59 | ;; the first few will be obscured by the 5 stave lines 60 | 61 | ;; Use absolute value of note pos: 62 | (if (< a-note-pos 0) (extenders (- 0 a-note-pos)) 63 | (cond 64 | [(= a-note-pos 0) (extender-line)] 65 | ;; No lines at odd note positions 66 | [(odd? a-note-pos) 67 | (extenders (sub1 a-note-pos))] 68 | [(overlay/align/offset 69 | "left" "top" 70 | (extender-line) 71 | 0 PIX-BETWEEN-LINES 72 | (extenders (sub1 a-note-pos)))]))) 73 | 74 | (define (extenders-above a-note) 75 | (>= (note-pos-relative-b4 a-note) 0)) 76 | 77 | (define (show-note a-note) 78 | (place-image/align 79 | (extenders (note-pos-relative-b4 a-note)) 80 | 150 (/ HEIGHT 2) "middle" 81 | (if (extenders-above a-note) "bottom" "top") 82 | (overlay/offset 83 | (circle 10 "solid" "white") 84 | 0 (note-y-pos a-note) 85 | (overlay 86 | (stave) (empty-scene WIDTH HEIGHT "black"))))) 87 | 88 | (define (play-note a-note) 89 | (play (piano-tone 90 | (list-ref MIDI-NOTES (note-index a-note))))) 91 | 92 | (define (play-and-show-note a-note) 93 | (play-note a-note) 94 | (show-note a-note)) 95 | 96 | (show-note 'b4) 97 | ;;(play-and-show-note 'b4) 98 | -------------------------------------------------------------------------------- /learn-music3.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | Show notes, then play them, see if you get them right! 5 | Press any key if you find the note easy, you'll then 6 | get less time to play this note next time. 7 | 8 | Challenge: How to avoid practicing mistakes or quick 9 | corrections, wait for the player to remember first? 10 | 11 | TODO: 12 | - Fix display of extenders that should be hidden by 13 | stave lines 14 | - Blue colouring for easy notes only considers default set 15 | - Play easy-notes less often 16 | - Sort easy-notes for better display, or show them on 17 | the stave? 18 | - Save easy-notes for next time, so that the player 19 | doesn't need to edit the source code 20 | |# 21 | 22 | (require srfi/1) 23 | (require 2htdp/universe 2htdp/image) 24 | (require 2htdp/image) 25 | (require rsound) 26 | (require rsound/piano-tones) 27 | 28 | ;; What notes do we want to practice? 29 | (define NOTES 30 | '(e2 f2 g2 a3 b3 c3 d3 e3 f3 g3 a4 b4 c4 d4 e4 f4 g4)) 31 | ;; We need MIDI numbers to play them, these are the standard set 32 | (define PIANO-MIDI-NOTES 33 | '(52 53 55 57 59 60 62 64 65 67 69 71 72 74 76 77 79)) 34 | ;; Guitar midi notes are one octave lower 35 | (define MIDI-NOTES 36 | (map (λ (x) (- x 12)) PIANO-MIDI-NOTES)) 37 | 38 | ;; We want to show the open string notes differently 39 | (define OPEN-STRINGS 40 | '(e2 a3 d3 g3 b4 e4)) 41 | ;; The initial set of easy notes for *me* to play - change this 42 | ;; to suit your needs 43 | (define EASY-NOTES 44 | '(c4 d4 f4 g4)) 45 | 46 | ;; The canvas 47 | (define WIDTH 400) 48 | (define HEIGHT 300) 49 | (define G-CLEF (bitmap "GClef.png")) 50 | 51 | ;; How many seconds between notes? Change this to suit your needs 52 | (define TICK-RATE 3) 53 | 54 | (define PIX-PER-NOTE 11) 55 | (define PIX-BETWEEN-LINES (* 2 PIX-PER-NOTE)) 56 | 57 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 58 | 59 | (define-syntax-rule (times-repeat n fn) 60 | (for/list ([i (in-range n)]) 61 | fn)) 62 | 63 | (define (random-choice list) 64 | (list-ref list (random (length list)))) 65 | 66 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 67 | 68 | (define (note-index a-note) 69 | (list-index (curry equal? a-note) NOTES)) 70 | 71 | (define above/align-left 72 | ((curry above/align) "left")) 73 | 74 | (define (stave) 75 | (apply above/align-left 76 | (cons (line 300 0 "black") 77 | (times-repeat 4 78 | (above/align-left 79 | (line 0 20 "black") 80 | (line 300 0 "black") 81 | ))))) 82 | 83 | (define (note-pos-relative-b4 a-note) 84 | ;; b4 is the middle of the stave 85 | ;; b4 = 0, a4 = -1, c4 = 1, etc 86 | (- (note-index a-note) PIX-PER-NOTE)) 87 | 88 | (define (note-y-pos a-note) 89 | (* PIX-PER-NOTE (note-pos-relative-b4 a-note))) 90 | 91 | (define (extender-line) 92 | (line 30 0 "black")) 93 | 94 | (define (extenders a-note-pos) 95 | ;; Draw extenders from b4 up or down to note 96 | ;; the first few will be obscured by the 5 stave lines 97 | 98 | ;; Use absolute value of note pos: 99 | (if (< a-note-pos 0) (extenders (- 0 a-note-pos)) 100 | (cond 101 | [(= a-note-pos 0) (extender-line)] 102 | ;; No lines at odd note positions 103 | [(odd? a-note-pos) 104 | (extenders (sub1 a-note-pos))] 105 | [(overlay/align/offset 106 | "left" "top" 107 | (extender-line) 108 | 0 PIX-BETWEEN-LINES 109 | (extenders (sub1 a-note-pos)))]))) 110 | 111 | (define (extenders-above a-note) 112 | ;; Are the extenders above the stave (or below)? 113 | (>= (note-pos-relative-b4 a-note) 0)) 114 | 115 | (define (note-img a-note) 116 | (circle 10 117 | (if (member a-note OPEN-STRINGS) "outline" "solid") 118 | (if (member a-note EASY-NOTES) "blue" "black"))) 119 | 120 | (define (show-note a-note) 121 | ;; Show the note on the stave with extenders and the G-Clef 122 | (overlay/offset 123 | (scale 0.53 G-CLEF) 124 | 120 -6 125 | (place-image/align 126 | (extenders (note-pos-relative-b4 a-note)) 127 | (/ WIDTH 2) (/ HEIGHT 2) "middle" 128 | (if (extenders-above a-note) "bottom" "top") 129 | (overlay/offset 130 | (note-img a-note) 131 | 0 (note-y-pos a-note) 132 | (overlay 133 | (stave) (empty-scene WIDTH HEIGHT "white")))))) 134 | 135 | (define (play-note a-note) 136 | (play (piano-tone 137 | (list-ref MIDI-NOTES (note-index a-note))))) 138 | 139 | (define (play-and-show-note a-note) 140 | (play-note a-note) 141 | (show-note a-note)) 142 | 143 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 144 | ;; big-bang world 145 | 146 | (struct world (note plays easy-notes) #:transparent) 147 | 148 | (define (next-random-note last-note) 149 | ;; Next random note, but not last-note 150 | (define note (random-choice NOTES)) 151 | (if (eq? note last-note) 152 | (next-random-note last-note) 153 | note)) 154 | 155 | (define (play-note-times a-note easy-notes) 156 | (if (member a-note easy-notes) 2 4)) 157 | 158 | (define (next-note w) 159 | ;; Play the next note, but first check if we've finished 160 | ;; playing this note. If we have, pick a new one. 161 | (cond 162 | [(zero? (world-plays w)) 163 | (let* ((note (next-random-note (world-note w))) 164 | (plays (play-note-times note (world-easy-notes w)))) 165 | (next-note (world note plays (world-easy-notes w))))] 166 | [else 167 | (play-note (world-note w)) 168 | (world (world-note w) (sub1 (world-plays w)) (world-easy-notes w))])) 169 | 170 | (define (easy-note w a-key) 171 | ;; The user finds the current note easy - stop playing it 172 | ;; and add it to the set 173 | (let ((note (world-note w)) 174 | (easy-notes (world-easy-notes w))) 175 | (world note 0 176 | (if (member note easy-notes) 177 | easy-notes 178 | (cons note easy-notes))))) 179 | 180 | (define (render-scene w) 181 | (place-image/align 182 | (above/align "left" 183 | (text (string-append "Easy notes: " 184 | (string-join (map symbol->string (world-easy-notes w)) ", ")) 185 | 15 "black") 186 | (text "Press any key to add current note" 15 "black")) 187 | 5 5 "left" "top" 188 | (show-note (world-note w)))) 189 | 190 | (define (go) 191 | (big-bang (world (random-choice NOTES) 0 EASY-NOTES) 192 | (on-tick next-note TICK-RATE) 193 | (on-key easy-note) 194 | (to-draw render-scene))) 195 | 196 | (go) -------------------------------------------------------------------------------- /learn-music4.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | Show notes, then play them, see if you get them right! 5 | Press any key if you find the note easy, you'll then 6 | get less time to play this note next time. 7 | 8 | Challenge: How to avoid practicing mistakes or quick 9 | corrections, wait for the player to remember first? 10 | 11 | DONE: 12 | - Blue colouring for easy notes only considers default set 13 | - Play easy-notes less often 14 | - Show the note played, on the last play 15 | 16 | TODO: 17 | - Merge in updates from learn-music-phrases code 18 | - Fix display of extenders that should be hidden by 19 | stave lines 20 | - Sort easy-notes for better display, or show them on 21 | the stave? 22 | - Save easy-notes for next time, so that the player 23 | doesn't need to edit the source code 24 | |# 25 | 26 | (require srfi/1) 27 | (require 2htdp/universe 2htdp/image) 28 | (require 2htdp/image) 29 | (require rsound) 30 | (require rsound/piano-tones) 31 | 32 | ;; What notes do we want to practice? 33 | (define NOTES 34 | '(e2 f2 g2 a3 b3 c3 d3 e3 f3 g3 a4 b4 c4 d4 e4 f4 g4)) 35 | ;; We need MIDI numbers to play them, these are the standard set 36 | (define PIANO-MIDI-NOTES 37 | '(52 53 55 57 59 60 62 64 65 67 69 71 72 74 76 77 79)) 38 | ;; Guitar midi notes are one octave lower 39 | (define MIDI-NOTES 40 | (map (λ (x) (- x 12)) PIANO-MIDI-NOTES)) 41 | 42 | ;; We want to show the open string notes differently 43 | (define OPEN-STRINGS 44 | '(e2 a3 d3 g3 b4 e4)) 45 | ;; The initial set of easy notes for *me* to play - change this 46 | ;; to suit your needs 47 | ;; When recalling note names: '(a3 c4 g4 e4 c3 a4 b4 f3) 48 | (define EASY-NOTES 49 | '()) 50 | ;; '(a3 c4 g4 e4 c3 a4 b4 f3)) 51 | ;; How likely to skip easy phrases (0-1)? 52 | (define SKIP-EASY-NOTES 1) 53 | 54 | ;; The canvas 55 | (define WIDTH 400) 56 | (define HEIGHT 300) 57 | (define G-CLEF (bitmap "GClef.png")) 58 | 59 | ;; How many seconds between notes? Change this to suit your needs 60 | (define TICK-RATE 2) 61 | 62 | (define PIX-PER-NOTE 11) 63 | (define PIX-BETWEEN-LINES (* 2 PIX-PER-NOTE)) 64 | 65 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 66 | 67 | (define-syntax-rule (times-repeat n fn) 68 | (for/list ([i (in-range n)]) 69 | fn)) 70 | 71 | (define (random-choice list) 72 | (list-ref list (random (length list)))) 73 | 74 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 75 | 76 | (define (note-index a-note) 77 | (list-index (curry equal? a-note) NOTES)) 78 | 79 | (define above/align-left 80 | ((curry above/align) "left")) 81 | 82 | (define (stave) 83 | (apply above/align-left 84 | (cons (line 300 0 "black") 85 | (times-repeat 4 86 | (above/align-left 87 | (line 0 20 "black") 88 | (line 300 0 "black") 89 | ))))) 90 | 91 | (define (note-pos-relative-b4 a-note) 92 | ;; b4 is the middle of the stave 93 | ;; b4 = 0, a4 = -1, c4 = 1, etc 94 | (- (note-index a-note) PIX-PER-NOTE)) 95 | 96 | (define (note-y-pos a-note) 97 | (* PIX-PER-NOTE (note-pos-relative-b4 a-note))) 98 | 99 | (define (extender-line) 100 | (line 30 0 "black")) 101 | 102 | (define (extenders a-note-pos) 103 | ;; Draw extenders from b4 up or down to note 104 | ;; the first few will be obscured by the 5 stave lines 105 | 106 | ;; Use absolute value of note pos: 107 | (if (< a-note-pos 0) (extenders (- 0 a-note-pos)) 108 | (cond 109 | [(= a-note-pos 0) (extender-line)] 110 | ;; No lines at odd note positions 111 | [(odd? a-note-pos) 112 | (extenders (sub1 a-note-pos))] 113 | [(overlay/align/offset 114 | "left" "top" 115 | (extender-line) 116 | 0 PIX-BETWEEN-LINES 117 | (extenders (sub1 a-note-pos)))]))) 118 | 119 | (define (extenders-above a-note) 120 | ;; Are the extenders above the stave (or below)? 121 | (>= (note-pos-relative-b4 a-note) 0)) 122 | 123 | (define (note-img a-note) 124 | ;; A note, with a hint for open strings 125 | (circle 10 126 | "solid" 127 | (if (member a-note OPEN-STRINGS) "darkgreen" "black"))) 128 | 129 | (define (show-note a-note) 130 | ;; Show the note on the stave with extenders and the G-Clef 131 | (overlay/offset 132 | (scale 0.53 G-CLEF) 133 | 120 -6 134 | (place-image/align 135 | (extenders (note-pos-relative-b4 a-note)) 136 | (/ WIDTH 2) (/ HEIGHT 2) "middle" 137 | (if (extenders-above a-note) "bottom" "top") 138 | (overlay/offset 139 | (note-img a-note) 140 | 0 (note-y-pos a-note) 141 | (overlay 142 | (stave) (empty-scene WIDTH HEIGHT "white")))))) 143 | 144 | (define (play-note a-note) 145 | (play (piano-tone 146 | (list-ref MIDI-NOTES (note-index a-note))))) 147 | 148 | (define (play-and-show-note a-note) 149 | (play-note a-note) 150 | (show-note a-note)) 151 | 152 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 153 | ;; big-bang world 154 | 155 | (struct world (note plays easy-notes) #:transparent) 156 | 157 | (define (next-random-note last-note easy-notes) 158 | ;; Next random note, but not last-note 159 | ;; also play easy-notes less often 160 | (define note (random-choice NOTES)) 161 | (if (or (eq? note last-note) 162 | (and (member note easy-notes) 163 | (< (random) SKIP-EASY-NOTES))) 164 | (next-random-note last-note easy-notes) 165 | note)) 166 | 167 | (define (play-note-times a-note easy-notes) 168 | (if (member a-note easy-notes) 2 4)) 169 | 170 | (define (next-note w) 171 | ;; Play the next note, but first check if we've finished 172 | ;; playing this note. If we have, pick a new one. 173 | (cond 174 | [(zero? (world-plays w)) 175 | (let* ((note (next-random-note (world-note w) (world-easy-notes w))) 176 | (plays (play-note-times note (world-easy-notes w)))) 177 | (next-note (world note plays (world-easy-notes w))))] 178 | [else 179 | (play-note (world-note w)) 180 | (world (world-note w) (sub1 (world-plays w)) (world-easy-notes w))])) 181 | 182 | (define (easy-note w a-key) 183 | ;; The user finds the current note easy - stop playing it 184 | ;; and add it to the set 185 | (let ((note (world-note w)) 186 | (easy-notes (world-easy-notes w))) 187 | (world note 0 188 | (if (member note easy-notes) 189 | easy-notes 190 | (cons note easy-notes))))) 191 | 192 | (define (render-scene w) 193 | (define scene 194 | (place-image/align 195 | (above/align "left" 196 | (text (string-append "Easy notes: " 197 | (string-join (map symbol->string (world-easy-notes w)) ", ")) 198 | 15 "black") 199 | (text "Press any key to add current note" 15 "black")) 200 | 5 5 "left" "top" 201 | (show-note (world-note w)))) 202 | (if (= 0 (world-plays w)) 203 | (place-image/align 204 | (text (symbol->string (world-note w)) 50 "black") 205 | (- WIDTH 8) HEIGHT "right" "bottom" 206 | scene) 207 | scene)) 208 | 209 | (define (go) 210 | (big-bang (world (random-choice NOTES) 0 EASY-NOTES) 211 | (on-tick next-note TICK-RATE) 212 | (on-key easy-note) 213 | (to-draw render-scene))) 214 | 215 | (go) -------------------------------------------------------------------------------- /stars.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 2htdp/universe 2htdp/image) 4 | (require "util.rkt") 5 | 6 | (define WIDTH 600) 7 | (define HEIGHT 600) 8 | 9 | ;; 0,0 is centre, so... 10 | (define MAXX (/ WIDTH 2)) 11 | (define MAXY (/ HEIGHT 2)) 12 | 13 | (define MAX-STARS 100) 14 | (define TICK-RATE 1/25) 15 | (define ACCEL 1.05) 16 | 17 | (struct starfield (stars) #:transparent) 18 | (struct astar (x y) #:transparent) 19 | 20 | (define (start-space) 21 | (big-bang (starfield (times-repeat MAX-STARS (new-star))) 22 | (on-tick fly TICK-RATE) 23 | (to-draw render-space) 24 | (stop-when end-flight))) 25 | 26 | (define (screen-x x) (+ x MAXX)) 27 | (define (screen-y y) (+ y MAXY)) 28 | 29 | (define (new-star) 30 | ;; 0,0 is centre of screen 31 | (astar (- (random WIDTH) MAXX) 32 | (- (random HEIGHT) MAXY))) 33 | 34 | (define (move-star s) 35 | (astar (* (astar-x s) ACCEL) (* (astar-y s) ACCEL))) 36 | 37 | (define (stars-in-view stars) 38 | (define (replace-star s) 39 | (if (star-out-of-view? s) (new-star) s)) 40 | (map replace-star stars)) 41 | 42 | (define (star-out-of-view? s) 43 | (or 44 | (> (astar-x s) MAXX) 45 | (< (astar-x s) (- 0 MAXX)) 46 | (> (astar-y s) MAXY) 47 | (< (astar-y s) (- 0 MAXY)))) 48 | 49 | (define (fly w) 50 | (starfield (map move-star (stars-in-view (starfield-stars w))))) 51 | 52 | (define (stars+scene stars scene) 53 | (foldl (λ (s scene) 54 | (place-image (circle 2 "solid" "black") 55 | (screen-x (astar-x s)) 56 | (screen-y (astar-y s)) 57 | scene)) 58 | scene stars)) 59 | 60 | (define (render-space w) 61 | (stars+scene (starfield-stars w) (empty-scene WIDTH HEIGHT))) 62 | 63 | (define (end-flight w) #f) 64 | 65 | (start-space) -------------------------------------------------------------------------------- /stars2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; Version 2, in 3D 4 | 5 | (require 2htdp/universe 2htdp/image) 6 | (require "util.rkt") 7 | 8 | ;; Screen size 9 | (define WIDTH 600) 10 | (define HEIGHT 600) 11 | 12 | ;; - to + of this value for new stars 13 | (define MAX-STAR-XY 25000) 14 | 15 | (define MAX-STARS 100) 16 | (define TICK-RATE 1/25) 17 | (define ACCEL 1) 18 | (define START-Z 100) 19 | 20 | ;; ----------------------------------------------------------- 21 | 22 | (struct starfield (stars) #:transparent) 23 | (struct astar (x y z) #:transparent) 24 | 25 | (define (start-space) 26 | (big-bang (starfield (times-repeat MAX-STARS (new-star))) 27 | (on-tick fly TICK-RATE) 28 | (to-draw render-space) 29 | (stop-when end-flight))) 30 | 31 | (define (screen-x s) (+ (/ (astar-x s) (astar-z s)) (/ WIDTH 2))) 32 | (define (screen-y s) (+ (/ (astar-y s) (astar-z s)) (/ HEIGHT 2))) 33 | (define (random-star-xy) (- (random MAX-STAR-XY) (/ MAX-STAR-XY 2))) 34 | 35 | (define (new-star) 36 | (astar (random-star-xy) 37 | (random-star-xy) 38 | (+ (random START-Z) 10))) 39 | 40 | (define (move-star s) 41 | (astar (astar-x s) (astar-y s) (- (astar-z s) ACCEL))) 42 | 43 | (define (stars-in-view stars) 44 | (define (replace-star s) 45 | (if (star-out-of-view? s) (new-star) s)) 46 | (map replace-star stars)) 47 | 48 | (define (star-out-of-view? s) 49 | (<= (astar-z s) 1)) 50 | 51 | (define (fly w) 52 | (starfield (map move-star (stars-in-view (starfield-stars w))))) 53 | 54 | ;; ----------------------------------------------------------- 55 | 56 | (define (render-space w) 57 | (stars+scene (starfield-stars w) (empty-scene WIDTH HEIGHT "black"))) 58 | 59 | (define (stars+scene stars scene) 60 | (foldl (λ (s scene) 61 | (place-image (circle (star-size s) "solid" (star-colour s)) 62 | (screen-x s) 63 | (screen-y s) 64 | scene)) 65 | scene stars)) 66 | 67 | (define (star-size s) 68 | (define z (astar-z s)) 69 | (cond [(> z 75) 1] 70 | [else (+ 1 (/ (- 75 z) 20)) ])) 71 | 72 | (define (star-colour s) 73 | (define z (astar-z s)) 74 | (cond [(> z 90) (color 255 255 255 20)] 75 | [else (color 255 255 255 (+ 20 (* 2 (- 90 z))))])) 76 | 77 | (define (end-flight w) #f) 78 | 79 | ;;(start-space) -------------------------------------------------------------------------------- /stars3.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; Version 2, in 3D 4 | ;; Version 3, now with Aliens! 5 | 6 | (require 2htdp/universe 2htdp/image) 7 | (require "util.rkt") 8 | 9 | ;; Screen size 10 | (define WIDTH 1000) 11 | (define HEIGHT 600) 12 | 13 | ;; - to + of this value for new stars 14 | (define MAX-STAR-XY 25000) 15 | 16 | (define MAX-STARS 200) 17 | (define MAX-ALIENS 10) 18 | (define ALIEN-SIZE 80) 19 | 20 | (define TICK-RATE 1/50) 21 | (define ACCEL 1) 22 | (define START-Z 100) 23 | 24 | ;; ----------------------------------------------------------- 25 | 26 | (struct starfield (stars aliens) #:transparent) 27 | (struct pos (x y z) #:transparent) 28 | (struct astar (pos) #:transparent) 29 | (struct alien (pos speed colour) #:transparent) 30 | 31 | (define (start-space) 32 | (big-bang (init-world) 33 | (on-tick fly TICK-RATE) 34 | (to-draw render-space) 35 | (stop-when end-flight))) 36 | 37 | (define (init-world) 38 | (starfield (times-repeat MAX-STARS (new-star)) 39 | (times-repeat MAX-ALIENS (new-alien)))) 40 | 41 | (define (screen-x p) (+ (/ (pos-x p) (pos-z p)) (/ WIDTH 2))) 42 | (define (screen-y p) (+ (/ (pos-y p) (pos-z p)) (/ HEIGHT 2))) 43 | (define (screen-size s p) 44 | ;; How big does s appear at pos p? 45 | (/ s (pos-z p))) 46 | (define (random-star-xy) (- (random MAX-STAR-XY) (/ MAX-STAR-XY 2))) 47 | 48 | (define (new-star) 49 | (astar (pos (random-star-xy) 50 | (random-star-xy) 51 | (+ (random START-Z) 10)))) 52 | 53 | (define (move-star s) 54 | (define p (astar-pos s)) 55 | (astar (pos (pos-x p) (pos-y p) (- (pos-z p) ACCEL)))) 56 | 57 | (define (stars-in-view stars) 58 | (define (replace-star s) 59 | (if (star-out-of-view? s) (new-star) s)) 60 | (map replace-star stars)) 61 | 62 | (define (star-out-of-view? s) 63 | (<= (pos-z (astar-pos s)) 1)) 64 | 65 | (define (new-alien) 66 | (alien (pos (random-range -100 100) (random-range -100 100) 50) 67 | (pos (random-range -10 10) (random-range -10 10) (/ (random-range -4 -1) 4.0)) 68 | (color (random-range 100 255) 69 | (random-range 100 255) 70 | (random-range 100 255)))) 71 | 72 | (define (move-alien a) 73 | (define p (alien-pos a)) 74 | (define s (alien-speed a)) 75 | (define x (+ (pos-x p) (pos-x s))) 76 | (define y (+ (pos-y p) (pos-y s))) 77 | (define z (+ (pos-z p) (pos-z s))) 78 | (alien (pos x y z) s (alien-colour a))) 79 | 80 | (define (aliens-in-view aliens) 81 | (define (replace-alien s) 82 | (if (alien-out-of-view? s) (new-alien) s)) 83 | (map replace-alien aliens)) 84 | 85 | (define (alien-out-of-view? s) 86 | (<= (pos-z (alien-pos s)) 1)) 87 | 88 | (define (fly w) 89 | (starfield (map move-star (stars-in-view (starfield-stars w))) 90 | (map move-alien (aliens-in-view (starfield-aliens w))))) 91 | 92 | ;; ----------------------------------------------------------- 93 | 94 | (define (render-space w) 95 | (aliens+scene (starfield-aliens w) 96 | (stars+scene (starfield-stars w) (empty-scene WIDTH HEIGHT "black")))) 97 | 98 | (define (stars+scene stars scene) 99 | (foldl (λ (s scene) 100 | (place-image (circle (star-size s) "solid" (star-colour s)) 101 | (screen-x (astar-pos s)) 102 | (screen-y (astar-pos s)) 103 | scene)) 104 | scene stars)) 105 | 106 | (define (star-size s) 107 | (define z (pos-z (astar-pos s))) 108 | (cond [(> z 75) 1] 109 | [else (+ 1 (/ (- 75 z) 20)) ])) 110 | 111 | (define (star-colour s) 112 | (define z (pos-z (astar-pos s))) 113 | (cond [(> z 90) (color 255 255 255 20)] 114 | [else (color 255 255 255 (+ 20 (* 2 (- 90 z))))])) 115 | 116 | (define (aliens+scene aliens scene) 117 | (foldl (λ (a scene) 118 | (place-image (alien-image a) 119 | (screen-x (alien-pos a)) 120 | (screen-y (alien-pos a)) 121 | scene)) 122 | scene aliens)) 123 | 124 | (define (alien-image a) 125 | (radial-star 12 (screen-size ALIEN-SIZE (alien-pos a)) 126 | (screen-size (* ALIEN-SIZE 0.5) (alien-pos a)) 127 | "solid" (alien-colour a))) 128 | 129 | ;; ----------------------------------------------------------- 130 | 131 | (define (end-flight w) #f) 132 | 133 | ;;(start-space) -------------------------------------------------------------------------------- /stars4.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; Version 2, in 3D 4 | ;; Version 3, now with aliens! 5 | ;; Version 4, with shooting aliens 6 | 7 | ;; What next? 8 | ;; Score . Speed controls . more interesting paths for aliens 9 | ;; Missiles, visible shooting 10 | ;; Move the spaceship around 11 | 12 | (require 2htdp/universe 2htdp/image) 13 | (require "util.rkt") 14 | 15 | ;; Screen size 16 | (define WIDTH 1000) 17 | (define HEIGHT 600) 18 | 19 | ;; - to + of this value for new stars 20 | (define MAX-STAR-XY 25000) 21 | 22 | (define MAX-STARS 200) 23 | (define MAX-ALIENS 10) 24 | (define ALIEN-SIZE 150) 25 | 26 | (define TICK-RATE 1/50) 27 | (define ACCEL 1) 28 | (define START-Z 100) 29 | 30 | (define (screen-x p) (+ (/ (xyz-x p) (xyz-z p)) (/ WIDTH 2))) 31 | (define (screen-y p) (+ (/ (xyz-y p) (xyz-z p)) (/ HEIGHT 2))) 32 | (define (screen-size s p) 33 | ;; How big does s appear at pos p? 34 | (/ s (xyz-z p))) 35 | (define (random-star-xy) (- (random MAX-STAR-XY) (/ MAX-STAR-XY 2))) 36 | 37 | ;; ----------------------------------------------------------- 38 | ;; The world and init 39 | 40 | (struct starfield (stars aliens) #:transparent) 41 | (struct xyz (x y z) #:transparent) 42 | (struct astar (pos) #:transparent) 43 | (struct alien (pos speed colour) #:transparent) 44 | 45 | (define (start-space) 46 | (big-bang (init-world) 47 | (on-tick fly TICK-RATE) 48 | (on-mouse mouse-event) 49 | (to-draw render-space) 50 | (stop-when end-flight))) 51 | 52 | (define (init-world) 53 | (starfield (times-repeat MAX-STARS (new-star)) 54 | (times-repeat MAX-ALIENS (new-alien)))) 55 | 56 | ;; ----------------------------------------------------------- 57 | ;; Stars and Aliens 58 | 59 | (define (new-star) 60 | (astar (xyz (random-star-xy) 61 | (random-star-xy) 62 | (+ (random START-Z) 10)))) 63 | 64 | (define (move-star s) 65 | (define p (astar-pos s)) 66 | (astar (xyz (xyz-x p) (xyz-y p) (- (xyz-z p) ACCEL)))) 67 | 68 | (define (stars-in-view stars) 69 | (define (replace-star s) 70 | (if (star-out-of-view? s) (new-star) s)) 71 | (map replace-star stars)) 72 | 73 | (define (star-out-of-view? s) 74 | (<= (xyz-z (astar-pos s)) 1)) 75 | 76 | ;; ........................................................... 77 | 78 | (define (new-alien) 79 | (alien 80 | ;; Initial position 81 | (xyz (random-range -100 100) (random-range -100 100) 50) 82 | ;; Initial speed 83 | (xyz (random-range -10 10) (random-range -10 10) (/ (random-range -3 -1) 5.0)) 84 | (color (random-range 100 255) 85 | (random-range 100 255) 86 | (random-range 100 255)))) 87 | 88 | (define (move-alien a) 89 | (define p (alien-pos a)) 90 | (define s (alien-speed a)) 91 | (define x (+ (xyz-x p) (xyz-x s))) 92 | (define y (+ (xyz-y p) (xyz-y s))) 93 | (define z (+ (xyz-z p) (xyz-z s))) 94 | (alien (xyz x y z) s (alien-colour a))) 95 | 96 | (define (aliens-in-view aliens) 97 | ;; Replace any aliens out of view with new ones 98 | (define (replace-alien s) 99 | (if (alien-out-of-view? s) (new-alien) s)) 100 | (map replace-alien aliens)) 101 | 102 | (define (alien-out-of-view? s) 103 | (<= (xyz-z (alien-pos s)) 1)) 104 | 105 | (define (fly w) 106 | (starfield (map move-star (stars-in-view (starfield-stars w))) 107 | (map move-alien (aliens-in-view (starfield-aliens w))))) 108 | 109 | ;; ----------------------------------------------------------- 110 | ;; Input events 111 | 112 | (define (mouse-event w x y event) 113 | (define (kill-alien a) 114 | ;; If mouse pos x,y is inside the shape of the alien 115 | ;; then kill it, replacing it with a new one, otherwise leave it as it 116 | (define pos (alien-pos a)) 117 | (define size (screen-size ALIEN-SIZE pos)) 118 | (if (and (>= x (- (screen-x pos) size)) 119 | (<= x (+ (screen-x pos) size)) 120 | (>= y (- (screen-y pos) size)) 121 | (<= y (+ (screen-y pos) size))) 122 | (new-alien) a)) 123 | 124 | (cond [(eq? event "button-down") 125 | (starfield (starfield-stars w) 126 | (map kill-alien (starfield-aliens w)))] 127 | [else w])) 128 | 129 | ;; ----------------------------------------------------------- 130 | ;; Rendering space, stars and aliens 131 | 132 | (define (render-space w) 133 | (aliens+scene (starfield-aliens w) 134 | (stars+scene (starfield-stars w) 135 | (empty-scene WIDTH HEIGHT "black")))) 136 | 137 | (define (stars+scene stars scene) 138 | ;; Place the stars on the scene 139 | (foldl (λ (s scene) 140 | (place-image (circle (star-size s) "solid" (star-colour s)) 141 | (screen-x (astar-pos s)) 142 | (screen-y (astar-pos s)) 143 | scene)) 144 | scene stars)) 145 | 146 | (define (star-size s) 147 | (define z (xyz-z (astar-pos s))) 148 | (cond [(> z 75) 1] 149 | [else (+ 1 (/ (- 75 z) 20)) ])) 150 | 151 | (define (star-colour s) 152 | (define z (xyz-z (astar-pos s))) 153 | (cond [(> z 90) (color 255 255 255 20)] 154 | [else (color 255 255 255 (+ 20 (* 2 (- 90 z))))])) 155 | 156 | (define (aliens+scene aliens scene) 157 | ;; Place the aliens on the scene 158 | (foldl (λ (a scene) 159 | (place-image (alien-image a) 160 | (screen-x (alien-pos a)) 161 | (screen-y (alien-pos a)) 162 | scene)) 163 | scene aliens)) 164 | 165 | (define (alien-image a) 166 | (radial-star 12 (screen-size ALIEN-SIZE (alien-pos a)) 167 | (screen-size (* ALIEN-SIZE 0.5) (alien-pos a)) 168 | "solid" (alien-colour a))) 169 | 170 | ;; ----------------------------------------------------------- 171 | 172 | (define (end-flight w) 173 | ;; No end! 174 | #f) 175 | 176 | ;;(start-space) -------------------------------------------------------------------------------- /stars5.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; Version 2, in 3D 4 | ;; Version 3, now with aliens! 5 | ;; Version 4, with shooting aliens 6 | ;; Version 5, with more interesting paths for aliens 7 | 8 | ;; What next? 9 | ;; Score . Speed controls . more interesting paths for aliens 10 | ;; Missiles, visible shooting 11 | ;; Move the spaceship around 12 | 13 | (require 2htdp/universe 2htdp/image) 14 | (require "util.rkt") 15 | (require "3d.rkt") 16 | 17 | ;; - to + of this value for new stars 18 | (define MAX-STAR-XY 25000) 19 | 20 | (define MAX-STARS 100) 21 | (define MAX-ALIENS 10) 22 | (define ALIEN-SIZE 150) 23 | 24 | (define TICK-RATE 1/50) 25 | (define ACCEL 1) 26 | (define START-Z 100) 27 | 28 | (define (random-star-xy) (- (random MAX-STAR-XY) (/ MAX-STAR-XY 2))) 29 | (define (random-angle) (* (random) 2 pi)) 30 | 31 | ;; ----------------------------------------------------------- 32 | ;; The world and init 33 | 34 | (struct starfield (stars aliens) #:transparent) 35 | (struct astar (pos) #:transparent) 36 | (struct alien (pos direction dirchange speed colour) #:transparent) 37 | 38 | 39 | (define (start-space) 40 | (big-bang (init-world) 41 | (on-tick fly TICK-RATE) 42 | (on-mouse mouse-event) 43 | (to-draw render-space) 44 | (stop-when end-flight))) 45 | 46 | (define (init-world) 47 | (starfield (times-repeat MAX-STARS (new-star)) 48 | (times-repeat MAX-ALIENS (new-alien)))) 49 | 50 | ;; ----------------------------------------------------------- 51 | ;; Stars and Aliens 52 | 53 | (define (new-star) 54 | (astar (point (random-star-xy) 55 | (random-star-xy) 56 | (+ (random START-Z) 10)))) 57 | 58 | (define (move-star s) 59 | (define p (astar-pos s)) 60 | (astar (point (point-x p) (point-y p) (- (point-z p) ACCEL)))) 61 | 62 | (define (stars-in-view stars) 63 | (define (replace-star s) 64 | (if (star-out-of-view? s) (new-star) s)) 65 | (map replace-star stars)) 66 | 67 | (define (star-out-of-view? s) 68 | (<= (point-z (astar-pos s)) 1)) 69 | 70 | ;; ........................................................... 71 | 72 | (define (new-alien) 73 | (define path (random-choice '(one two))) 74 | (define adirection 75 | ;; direction is: inclination, azimuth 76 | ;; azimuth - 1.570 (pi/2) is left or right, no forward/backwards 77 | (if (eq? path 'one) 78 | (direction 0 1.575) 79 | (direction 1.575 1.571))) 80 | (define achdirection 81 | ;; Change in direction angles: inclination, azimuth 82 | (if (eq? path 'one) 83 | (direction (random-sign (/ (random) 10)) 0) 84 | (direction (random-sign 0.09) 0.0002))) 85 | 86 | (alien 87 | (point 0 0 20) adirection achdirection 88 | ;; Speed 89 | (+ 15 (random 15)) 90 | 91 | (color (random-range 100 255) 92 | (random-range 100 255) 93 | (random-range 100 255)))) 94 | 95 | (define (move-alien a) 96 | (alien (move-point (alien-pos a) (alien-direction a) (alien-speed a)) 97 | (change-direction (alien-direction a) (alien-dirchange a)) 98 | (alien-dirchange a) 99 | (alien-speed a) 100 | (alien-colour a))) 101 | 102 | (define (aliens-in-view aliens) 103 | ;; Replace any aliens out of view with new ones 104 | (define (replace-alien s) 105 | (if (alien-out-of-view? s) (new-alien) s)) 106 | (map replace-alien aliens)) 107 | 108 | (define (alien-out-of-view? s) 109 | (or (<= (point-z (alien-pos s)) 1) 110 | (> (point-z (alien-pos s)) 100))) 111 | 112 | (define (fly w) 113 | (starfield (map move-star (stars-in-view (starfield-stars w))) 114 | (map move-alien (aliens-in-view (starfield-aliens w))))) 115 | 116 | ;; ----------------------------------------------------------- 117 | ;; Input events 118 | 119 | (define (mouse-event w x y event) 120 | (define (kill-alien a) 121 | ;; If mouse pos x,y is inside the shape of the alien 122 | ;; then kill it, replacing it with a new one, otherwise leave it as it 123 | (define pos (alien-pos a)) 124 | (define size (screen-size ALIEN-SIZE pos)) 125 | (if (and (>= x (- (screen-x pos) size)) 126 | (<= x (+ (screen-x pos) size)) 127 | (>= y (- (screen-y pos) size)) 128 | (<= y (+ (screen-y pos) size))) 129 | (new-alien) a)) 130 | 131 | (cond [(eq? event "button-down") 132 | (starfield (starfield-stars w) 133 | (map kill-alien (starfield-aliens w)))] 134 | [else w])) 135 | 136 | ;; ----------------------------------------------------------- 137 | ;; Rendering space, stars and aliens 138 | 139 | (define (render-space w) 140 | (aliens+scene (starfield-aliens w) 141 | (stars+scene (starfield-stars w) 142 | (empty-scene WIDTH HEIGHT "black")))) 143 | 144 | (define (stars+scene stars scene) 145 | ;; Place the stars on the scene 146 | (foldl (λ (s scene) 147 | (place-image (circle (star-size s) "solid" (star-colour s)) 148 | (screen-x (astar-pos s)) 149 | (screen-y (astar-pos s)) 150 | scene)) 151 | scene stars)) 152 | 153 | (define (star-size s) 154 | (define z (point-z (astar-pos s))) 155 | (cond [(> z 75) 1] 156 | [else (+ 1 (/ (- 75 z) 20)) ])) 157 | 158 | (define (star-colour s) 159 | (define z (point-z (astar-pos s))) 160 | (cond [(> z 90) (color 255 255 255 20)] 161 | [else (color 255 255 255 (+ 20 (* 2 (- 90 z))))])) 162 | 163 | (define (aliens+scene aliens scene) 164 | ;; Place the aliens on the scene 165 | (foldl (λ (a scene) 166 | (place-image (alien-image a) 167 | (screen-x (alien-pos a)) 168 | (screen-y (alien-pos a)) 169 | scene)) 170 | scene 171 | ;; Do the closest aliens last 172 | (sort aliens > #:key (λ (a) (point-z (alien-pos a)))))) 173 | 174 | (define (alien-image a) 175 | (radial-star 12 (screen-size ALIEN-SIZE (alien-pos a)) 176 | (screen-size (* ALIEN-SIZE 0.5) (alien-pos a)) 177 | "solid" (alien-colour a))) 178 | 179 | ;; ----------------------------------------------------------- 180 | 181 | (define (end-flight w) 182 | ;; No end! 183 | #f) 184 | 185 | ;;(start-space) -------------------------------------------------------------------------------- /stars6.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; Version 2, in 3D 4 | ;; Version 3, now with aliens! 5 | ;; Version 4, with shooting aliens 6 | ;; Version 5, with more interesting paths for aliens 7 | ;; Version 6, with speed control 8 | 9 | ;; What next? 10 | ;; Score . more interesting paths for aliens 11 | ;; Missiles, visible shooting 12 | ;; Move the spaceship around 13 | 14 | (require 2htdp/universe 2htdp/image) 15 | (require "util.rkt") 16 | (require "3d.rkt") 17 | 18 | (require unstable/debug) 19 | 20 | ;; - to + of this value for new stars 21 | (define MAX-STAR-XY 25000) 22 | 23 | (define MAX-STARS 100) 24 | (define MAX-ALIENS 10) 25 | (define ALIEN-SIZE 150) 26 | 27 | (define TICK-RATE 1/50) 28 | (define START-Z 100) 29 | 30 | ;; User controllable speed 31 | (define speed 0.1) 32 | (define MAX-SPEED 2.9) 33 | 34 | (define (random-star-xy) (- (random MAX-STAR-XY) (/ MAX-STAR-XY 2))) 35 | (define (random-angle) (* (random) 2 pi)) 36 | 37 | ;; ----------------------------------------------------------- 38 | ;; The world and init 39 | 40 | (struct starfield (stars aliens) #:transparent) 41 | (struct astar (pos) #:transparent) 42 | (struct alien (pos direction dirchange speed colour) #:transparent) 43 | 44 | 45 | (define (start-space) 46 | (big-bang (init-world) 47 | (on-tick fly TICK-RATE) 48 | (on-mouse mouse-event) 49 | (on-key key-event) 50 | (to-draw render-space) 51 | (stop-when end-flight))) 52 | 53 | (define (init-world) 54 | (starfield (times-repeat MAX-STARS (new-star)) 55 | (times-repeat MAX-ALIENS (new-alien)))) 56 | 57 | ;; ----------------------------------------------------------- 58 | ;; Stars and Aliens 59 | 60 | (define (new-star) 61 | (astar (point (random-star-xy) 62 | (random-star-xy) 63 | (+ (random START-Z) 10)))) 64 | 65 | (define (move-star s) 66 | (define p (astar-pos s)) 67 | (astar (point (point-x p) (point-y p) (- (point-z p) speed)))) 68 | 69 | (define (stars-in-view stars) 70 | (define (replace-star s) 71 | (if (star-out-of-view? s) (new-star) s)) 72 | (map replace-star stars)) 73 | 74 | (define (star-out-of-view? s) 75 | (or 76 | (<= (point-z (astar-pos s)) 1) 77 | (> (point-z (astar-pos s)) 200))) 78 | 79 | ;; ........................................................... 80 | 81 | (define (new-alien) 82 | (define path (random-choice '(one two))) 83 | ;; direction is: inclination, azimuth 84 | ;; azimuth - 1.570 (pi/2) is left or right, no forward/backwards 85 | (define adirection 86 | (cond [(eq? path 'one) (direction 0 1.575)] 87 | [(eq? path 'two) (direction 1.575 1.571)] 88 | )) 89 | ;; Change in direction angles: inclination, azimuth 90 | (define achdirection 91 | (cond [(eq? path 'one) (direction (random-sign (/ (random) 10)) 0)] 92 | [(eq? path 'two) (direction (random-sign 0.09) 0.0002)] 93 | )) 94 | (define speed (+ 15 (random 15))) 95 | 96 | (alien 97 | (point 0 0 50) adirection achdirection speed 98 | (color (random-range 100 255) 99 | (random-range 100 255) 100 | (random-range 100 255)))) 101 | 102 | (define (move-alien a) 103 | (alien (add-points (move-point (alien-pos a) (alien-direction a) (alien-speed a)) 104 | (point 0 0 (- 0 speed))) 105 | (change-direction (alien-direction a) (alien-dirchange a)) 106 | (alien-dirchange a) 107 | (alien-speed a) 108 | (alien-colour a))) 109 | 110 | (define (aliens-in-view aliens) 111 | ;; Replace any aliens out of view with new ones 112 | (define (replace-alien s) 113 | (if (alien-out-of-view? s) (new-alien) s)) 114 | (map replace-alien aliens)) 115 | 116 | (define (alien-out-of-view? s) 117 | (or (<= (point-z (alien-pos s)) 1) 118 | (> (point-z (alien-pos s)) 100))) 119 | 120 | (define (fly w) 121 | (starfield (map move-star (stars-in-view (starfield-stars w))) 122 | (map move-alien (aliens-in-view (starfield-aliens w))))) 123 | 124 | ;; ----------------------------------------------------------- 125 | ;; Input events 126 | 127 | (define (mouse-event w x y event) 128 | (define (kill-alien a) 129 | ;; If mouse pos x,y is inside the shape of the alien 130 | ;; then kill it, replacing it with a new one, otherwise leave it as it 131 | (define pos (alien-pos a)) 132 | (define size (screen-size ALIEN-SIZE pos)) 133 | (if (and (>= x (- (screen-x pos) size)) 134 | (<= x (+ (screen-x pos) size)) 135 | (>= y (- (screen-y pos) size)) 136 | (<= y (+ (screen-y pos) size))) 137 | (new-alien) a)) 138 | 139 | (cond [(eq? event "button-down") 140 | (starfield (starfield-stars w) 141 | (map kill-alien (starfield-aliens w)))] 142 | [else w])) 143 | 144 | (define (key-event w akey) 145 | (cond 146 | [(key=? akey "up") (set! speed (min (+ speed 0.1) MAX-SPEED))] 147 | [(key=? akey "down") (set! speed (max (- speed 0.1) (- 0 MAX-SPEED)))]) 148 | w) 149 | 150 | ;; ----------------------------------------------------------- 151 | ;; Rendering space, stars and aliens 152 | 153 | (define (render-space w) 154 | (aliens+scene (starfield-aliens w) 155 | (stars+scene (starfield-stars w) 156 | (empty-scene WIDTH HEIGHT "black")))) 157 | 158 | (define (stars+scene stars scene) 159 | ;; Place the stars on the scene 160 | (foldl (λ (s scene) 161 | (place-image (circle (star-size s) "solid" (star-colour s)) 162 | (screen-x (astar-pos s)) 163 | (screen-y (astar-pos s)) 164 | scene)) 165 | scene stars)) 166 | 167 | (define (star-size s) 168 | (define z (round (point-z (astar-pos s)))) 169 | (cond [(> z 75) 1] 170 | [else (+ 1 (/ (- 75 z) 20)) ])) 171 | 172 | (define (star-colour s) 173 | (define z (round (point-z (astar-pos s)))) 174 | (cond [(> z 90) (color 255 255 255 20)] 175 | [else 176 | (define alph (min (+ 20 (* 2 (- 90 z))) 177 | 255)) 178 | (color 255 255 255 alph)])) 179 | 180 | (define (aliens+scene aliens scene) 181 | ;; Place the aliens on the scene 182 | (foldl (λ (a scene) 183 | (place-image (alien-image a) 184 | (screen-x (alien-pos a)) 185 | (screen-y (alien-pos a)) 186 | scene)) 187 | scene 188 | ;; Do the closest aliens last 189 | (sort aliens > #:key (λ (a) (point-z (alien-pos a)))))) 190 | 191 | (define (alien-image a) 192 | (radial-star 12 (screen-size ALIEN-SIZE (alien-pos a)) 193 | (screen-size (* ALIEN-SIZE 0.5) (alien-pos a)) 194 | "solid" (alien-colour a))) 195 | 196 | ;; ----------------------------------------------------------- 197 | 198 | (define (end-flight w) 199 | ;; No end! 200 | #f) 201 | 202 | ;;(start-space) -------------------------------------------------------------------------------- /stars7.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; Version 2, in 3D 4 | ;; Version 3, now with aliens! 5 | ;; Version 4, with shooting aliens 6 | ;; Version 5, with more interesting paths for aliens 7 | ;; Version 6, with speed control 8 | ;; Version 7, score and visible shooting? 9 | 10 | ;; What next? 11 | ;; Score . more interesting paths for aliens 12 | ;; Missiles, visible shooting 13 | ;; Move the spaceship around 14 | 15 | (require 2htdp/universe 2htdp/image) 16 | (require "util.rkt") 17 | (require "3d.rkt") 18 | 19 | (require unstable/debug) 20 | 21 | ;; - to + of this value for new stars 22 | (define MAX-STAR-XY 25000) 23 | 24 | (define MAX-STARS 100) 25 | (define MAX-ALIENS 10) 26 | (define ALIEN-SIZE 150) 27 | 28 | (define TICK-RATE 1/50) 29 | (define START-Z 100) 30 | 31 | ;; User controllable speed 32 | (define speed 0.1) 33 | (define MAX-SPEED 2.9) 34 | 35 | (define score 0) 36 | 37 | (define (random-star-xy) (- (random MAX-STAR-XY) (/ MAX-STAR-XY 2))) 38 | (define (random-angle) (* (random) 2 pi)) 39 | 40 | ;; ----------------------------------------------------------- 41 | ;; The world and init 42 | 43 | (struct starfield (stars aliens) #:transparent) 44 | (struct astar (pos) #:transparent) 45 | (struct alien (pos direction dirchange speed colour) #:transparent) 46 | 47 | 48 | (define (start-space) 49 | (big-bang (init-world) 50 | (on-tick fly TICK-RATE) 51 | (on-mouse mouse-event) 52 | (on-key key-event) 53 | (to-draw render-space) 54 | (stop-when end-flight))) 55 | 56 | (define (init-world) 57 | (starfield (times-repeat MAX-STARS (new-star)) 58 | (times-repeat MAX-ALIENS (new-alien)))) 59 | 60 | ;; ----------------------------------------------------------- 61 | ;; Stars and Aliens 62 | 63 | (define (new-star) 64 | (astar (point (random-star-xy) 65 | (random-star-xy) 66 | (+ (random START-Z) 10)))) 67 | 68 | (define (move-star s) 69 | (define p (astar-pos s)) 70 | (astar (point (point-x p) (point-y p) (- (point-z p) speed)))) 71 | 72 | (define (stars-in-view stars) 73 | (define (replace-star s) 74 | (if (star-out-of-view? s) (new-star) s)) 75 | (map replace-star stars)) 76 | 77 | (define (star-out-of-view? s) 78 | (or 79 | (<= (point-z (astar-pos s)) 1) 80 | (> (point-z (astar-pos s)) 200))) 81 | 82 | ;; ........................................................... 83 | 84 | (define (new-alien) 85 | (define path (random-choice '(one two))) 86 | ;; direction is: inclination, azimuth 87 | ;; azimuth - 1.570 (pi/2) is left or right, no forward/backwards 88 | (define adirection 89 | (cond [(eq? path 'one) (direction 0 1.573)] 90 | [(eq? path 'two) (direction 1.573 1.571)] 91 | )) 92 | ;; Change in direction angles: inclination, azimuth 93 | (define achdirection 94 | (cond [(eq? path 'one) (direction (random-sign (/ (random) 10)) 0)] 95 | [(eq? path 'two) (direction (random-sign 0.09) 0.0002)] 96 | )) 97 | (define speed (+ 15 (random 15))) 98 | 99 | (alien 100 | (point 0 0 50) adirection achdirection speed 101 | (color (random-range 100 255) 102 | (random-range 100 255) 103 | (random-range 100 255)))) 104 | 105 | (define (move-alien a) 106 | (alien (add-points (move-point (alien-pos a) (alien-direction a) (alien-speed a)) 107 | (point 0 0 (- 0 speed))) 108 | (change-direction (alien-direction a) (alien-dirchange a)) 109 | (alien-dirchange a) 110 | (alien-speed a) 111 | (alien-colour a))) 112 | 113 | (define (aliens-in-view aliens) 114 | ;; Replace any aliens out of view with new ones 115 | (define (replace-alien s) 116 | (if (alien-out-of-view? s) (new-alien) s)) 117 | (map replace-alien aliens)) 118 | 119 | (define (alien-out-of-view? s) 120 | (or (<= (point-z (alien-pos s)) 1) 121 | (> (point-z (alien-pos s)) 100))) 122 | 123 | (define (fly w) 124 | (starfield (map move-star (stars-in-view (starfield-stars w))) 125 | (map move-alien (aliens-in-view (starfield-aliens w))))) 126 | 127 | ;; ----------------------------------------------------------- 128 | ;; Input events 129 | 130 | (define (mouse-event w x y event) 131 | (define (kill-alien a) 132 | ;; If mouse pos x,y is inside the shape of the alien 133 | ;; then kill it, replacing it with a new one, otherwise leave it as it 134 | (define pos (alien-pos a)) 135 | (define size (screen-size ALIEN-SIZE pos)) 136 | (if (and (>= x (- (screen-x pos) size)) 137 | (<= x (+ (screen-x pos) size)) 138 | (>= y (- (screen-y pos) size)) 139 | (<= y (+ (screen-y pos) size))) 140 | (begin 141 | (set! score (add1 score)) 142 | (new-alien)) 143 | a)) 144 | 145 | (cond [(eq? event "button-down") 146 | (starfield (starfield-stars w) 147 | (map kill-alien (starfield-aliens w)))] 148 | [else w])) 149 | 150 | (define (key-event w akey) 151 | (cond 152 | [(key=? akey "up") (set! speed (min (+ speed 0.1) MAX-SPEED))] 153 | [(key=? akey "down") (set! speed (max (- speed 0.1) (- 0 MAX-SPEED)))]) 154 | w) 155 | 156 | ;; ----------------------------------------------------------- 157 | ;; Rendering space, stars and aliens 158 | 159 | (define (render-space w) 160 | (score+scene 161 | (aliens+scene (starfield-aliens w) 162 | (stars+scene (starfield-stars w) 163 | (empty-scene WIDTH HEIGHT "black"))))) 164 | 165 | (define (score+scene scene) 166 | (place-image 167 | (text (format "score : ~s" score) 24 "white") 168 | 60 20 169 | scene)) 170 | 171 | (define (stars+scene stars scene) 172 | ;; Place the stars on the scene 173 | (foldl (λ (s scene) 174 | (place-image (circle (star-size s) "solid" (star-colour s)) 175 | (screen-x (astar-pos s)) 176 | (screen-y (astar-pos s)) 177 | scene)) 178 | scene stars)) 179 | 180 | (define (star-size s) 181 | (define z (round (point-z (astar-pos s)))) 182 | (cond [(> z 75) 1] 183 | [else (+ 1 (/ (- 75 z) 20)) ])) 184 | 185 | (define (star-colour s) 186 | (define z (round (point-z (astar-pos s)))) 187 | (cond [(> z 90) (color 255 255 255 20)] 188 | [else 189 | (define alph (min (+ 20 (* 2 (- 90 z))) 190 | 255)) 191 | (color 255 255 255 alph)])) 192 | 193 | (define (aliens+scene aliens scene) 194 | ;; Place the aliens on the scene 195 | (foldl (λ (a scene) 196 | (place-image (alien-image a) 197 | (screen-x (alien-pos a)) 198 | (screen-y (alien-pos a)) 199 | scene)) 200 | scene 201 | ;; Do the closest aliens last 202 | (sort aliens > #:key (λ (a) (point-z (alien-pos a)))))) 203 | 204 | (define (alien-image a) 205 | (radial-star 12 (screen-size ALIEN-SIZE (alien-pos a)) 206 | (screen-size (* ALIEN-SIZE 0.5) (alien-pos a)) 207 | "solid" (alien-colour a))) 208 | 209 | ;; ----------------------------------------------------------- 210 | 211 | (define (end-flight w) 212 | ;; No end! 213 | #f) 214 | 215 | (start-space) -------------------------------------------------------------------------------- /thrust-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require rackunit) 4 | (require/expose "thrust1.rkt" (pos pos-x pos-y move-pos add-direction-speeds 5 | inside-circle? inside-rect? between?)) 6 | 7 | (define (check-equal-pos? pos1 pos2) 8 | (check-= (pos-x pos1) (pos-x pos2) 0.01) 9 | (check-= (pos-y pos1) (pos-y pos2) 0.01)) 10 | 11 | (test-case 12 | "move-pos tests" 13 | (check-equal-pos? (move-pos (pos 0 0) 90 5) 14 | (pos 0.0 5.0)) 15 | (check-equal-pos? (move-pos (pos 0 0) 180 5) 16 | (pos -5.0 0.0)) 17 | (check-equal-pos? (move-pos (pos 0 0) 270 5) 18 | (pos -0.0 -5.0)) 19 | (check-equal-pos? (move-pos (pos 0 0) 0 5) 20 | (pos 5 0)) 21 | ) 22 | 23 | (define (check-equal-list? list1 list2) 24 | (check-= (first list1) (first list2) 0.01) 25 | (check-= (second list1) (second list2) 0.01)) 26 | 27 | (test-case 28 | "tests for add-direction-speeds" 29 | (check-equal-list? (add-direction-speeds 0 0 90 5) 30 | (list 90.0 5.0)) 31 | (check-equal-list? (add-direction-speeds 0 0 180 5) 32 | (list 180.0 5.0)) 33 | (check-equal-list? (add-direction-speeds 0 0 270 5) 34 | (list -90.0 5.0)) 35 | (check-equal-list? (add-direction-speeds 0 0 0 5) 36 | (list 0 5)) 37 | 38 | (check-equal-list? (add-direction-speeds 0 0 45 5) 39 | (list 45.0 5.0)) 40 | (check-equal-list? (add-direction-speeds 0 0 135 5) 41 | (list 135.0 5.0)) 42 | (check-equal-list? (add-direction-speeds 0 0 225 5) 43 | (list -135 5.0)) 44 | (check-equal-list? (add-direction-speeds 0 0 295 5) 45 | (list -65 5.0)) 46 | 47 | ) 48 | -------------------------------------------------------------------------------- /thrust1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | 5 | Thrust - (go) to run. 6 | 7 | Left / right to rotate 8 | Up to thrust 9 | Space to fire. 10 | 11 | DONE: 12 | - Display landscape 13 | - Collision detection 14 | - Scroll around as you fly 15 | 16 | |# 17 | 18 | (require 2htdp/universe 2htdp/image lang/posn) 19 | (require "util.rkt") 20 | (require "2d.rkt") 21 | 22 | ;; Debug 23 | (require racket/trace) 24 | 25 | (struct world (landscape asteroids ship bullets score level) #:transparent) 26 | (struct ship (pos facing-direction speed travel-direction) #:transparent) 27 | (struct asteroid (pos direction speed size) #:transparent) 28 | (struct bullet (pos direction speed) #:transparent) 29 | 30 | (define LEVEL1 (list 31 | (list (pos 0 0) (pos 800 0) (pos 200 250)) 32 | (list (pos 500 500) (pos 800 500) (pos 800 600)))) 33 | (define BIG-ASTEROID 50) 34 | (define NUM-ASTEROIDS 1) 35 | (define BULLET-SPEED 5) 36 | (define SHIP-SIZE 30) 37 | (define MAX-BULLETS 15) 38 | (define ASTEROID-IMG (bitmap "images/space-pizza.png")) 39 | (define SPACESHIP-IMG (bitmap "images/spaceship2.png")) 40 | 41 | (define TICK-RATE 1/30) 42 | (define WIDTH 800) 43 | (define HEIGHT 600) 44 | 45 | (define KEY-STATE (make-hash)) 46 | 47 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 48 | 49 | (define (wrap-pos a-pos a-size) 50 | (define x (pos-x a-pos)) 51 | (define y (pos-y a-pos)) 52 | (pos (cond 53 | [(> x (+ WIDTH a-size)) (- 0 a-size)] 54 | [(< x (- 0 a-size)) (+ WIDTH a-size)] 55 | [else x]) 56 | (cond 57 | [(> y (+ HEIGHT a-size)) (- 0 a-size)] 58 | [(< y (- 0 a-size)) (+ HEIGHT a-size)] 59 | [else y]))) 60 | 61 | (define (new-asteroid) 62 | (asteroid (pos (random WIDTH) (random HEIGHT)) 63 | (random 360) (+ 1 (random 2)) BIG-ASTEROID)) 64 | 65 | (define (bullet-in-range a-bullet) 66 | (define x (pos-x (bullet-pos a-bullet))) 67 | (define y (pos-y (bullet-pos a-bullet))) 68 | (and (> x 0) (< x WIDTH) (> y 0) (< y HEIGHT))) 69 | 70 | (define (move-asteroid a) 71 | (asteroid (wrap-pos 72 | (move-pos (asteroid-pos a) (asteroid-direction a) (asteroid-speed a)) 73 | (asteroid-size a)) 74 | (asteroid-direction a) 75 | (asteroid-speed a) 76 | (asteroid-size a))) 77 | 78 | (define (new-bullet a-ship) 79 | (bullet (ship-pos a-ship) 80 | (ship-facing-direction a-ship) 81 | (+ (ship-speed a-ship) BULLET-SPEED))) 82 | 83 | (define (move-bullet b) 84 | (bullet (move-pos (bullet-pos b) (bullet-direction b) (bullet-speed b)) 85 | (bullet-direction b) 86 | (bullet-speed b))) 87 | 88 | (define (hit-asteroids asteroids bullets) 89 | ;; If any asteroids have been hit, split them in half. 90 | ;; Asteroids that are too small are deleted. 91 | 92 | ;; A list like this (a a a a a) will result in a list 93 | ;; like this (a a (a a) a a) on hit, we use flatten 94 | ;; to return the right thing. 95 | 96 | (define (hit-asteroid? a bullets) 97 | ;; Has this asteroid been hit by any of the bullets? 98 | (cond 99 | [(empty? bullets) #f] 100 | [(inside-circle? (asteroid-pos a) (asteroid-size a) 101 | (bullet-pos (car bullets))) #t] 102 | [else 103 | (hit-asteroid? a (cdr bullets))])) 104 | 105 | (define (split-asteroid a) 106 | (list (asteroid (asteroid-pos a) (- (asteroid-direction a) 90) 107 | (asteroid-speed a) (/ (asteroid-size a) 2)) 108 | (asteroid (asteroid-pos a) (+ (asteroid-direction a) 90) 109 | (asteroid-speed a) (/ (asteroid-size a) 2)))) 110 | 111 | (define (bullets-hit-asteroid a) 112 | (if (hit-asteroid? a bullets) 113 | (split-asteroid a) 114 | a)) 115 | 116 | (define (big-enough a) 117 | (> (asteroid-size a) 5)) 118 | 119 | (filter big-enough (flatten (map bullets-hit-asteroid asteroids)))) 120 | 121 | (define (asteroids-diff prev-asteroids next-asteroids) 122 | ;; +1 point each time the number of asteroids decreases 123 | ;; regardless of size 124 | (define diff (- (length prev-asteroids) 125 | (length next-asteroids))) 126 | (if (> diff 0) diff 0)) 127 | 128 | 129 | (define (live-bullets asteroids landscape bullets) 130 | ;; Like hit-asteroids, but returns only bullets that 131 | ;; have not hit an asteroid or the landscape 132 | 133 | (define (bullet-hit-asteroid? b asteroids) 134 | (cond 135 | [(empty? asteroids) #f] 136 | [(inside-circle? (asteroid-pos (car asteroids)) 137 | (asteroid-size (car asteroids)) 138 | (bullet-pos b)) #t] 139 | [else (bullet-hit-asteroid? b (cdr asteroids))])) 140 | (define (bullet-hit-landscape? b landscape) 141 | (cond 142 | [(empty? landscape) #f] 143 | [(inside-triangle? (car landscape) (bullet-pos b)) #t] 144 | [else (bullet-hit-landscape? b (cdr landscape))])) 145 | 146 | (define (bullet-hit-nothing? b) 147 | (not (or (bullet-hit-asteroid? b asteroids) 148 | (bullet-hit-landscape? b landscape)))) 149 | 150 | (filter bullet-hit-nothing? bullets)) 151 | 152 | (define (move-ship a-ship) 153 | (ship (wrap-pos 154 | (move-pos (ship-pos a-ship) (ship-travel-direction a-ship) (ship-speed a-ship)) 155 | SHIP-SIZE) 156 | (ship-facing-direction a-ship) 157 | (ship-speed a-ship) 158 | (ship-travel-direction a-ship))) 159 | 160 | (define (next-world w) 161 | (move-world (direct-ship w))) 162 | 163 | (define (move-world w) 164 | (define next-asteroids (hit-asteroids (world-asteroids w) (world-bullets w))) 165 | (define next-bullets (live-bullets (world-asteroids w) (world-landscape w) 166 | (world-bullets w))) 167 | (define add-score (asteroids-diff (world-asteroids w) next-asteroids)) 168 | 169 | (world (world-landscape w) 170 | (map move-asteroid next-asteroids) 171 | (move-ship (world-ship w)) 172 | (filter bullet-in-range (map move-bullet next-bullets)) 173 | (+ add-score (world-score w)) 174 | (world-level w))) 175 | 176 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 177 | ;; Rendering 178 | 179 | (define (img+scene pos img scene) 180 | (place-image img (pos-x pos) (pos-y pos) scene)) 181 | 182 | (define (ship-img a-direction) 183 | (rotate (- 0 a-direction) 184 | (scale 3 SPACESHIP-IMG))) 185 | 186 | (define (ship+scene a-ship scene) 187 | (img+scene (ship-pos a-ship) 188 | (ship-img (ship-facing-direction a-ship)) 189 | scene)) 190 | 191 | (define (landscape+scene landscape scene) 192 | (foldl (λ (points scene) 193 | (scene+polygon scene 194 | (pos->posn points) "solid" "gray")) 195 | scene landscape)) 196 | 197 | (define (asteroids+scene asteroids scene) 198 | (foldl (λ (a scene) 199 | (img+scene (asteroid-pos a) 200 | (scale (/ (asteroid-size a) 11) 201 | ASTEROID-IMG) 202 | scene)) 203 | scene asteroids)) 204 | 205 | (define (bullets+scene bullets scene) 206 | (foldl (λ (b scene) 207 | (img+scene (bullet-pos b) 208 | (circle 2 "solid" "yellow") 209 | scene)) 210 | scene bullets)) 211 | 212 | (define (score+scene score level scene) 213 | (place-image 214 | (above/align "left" 215 | (text (string-append "Score: " (number->string score)) 216 | 24 "white") 217 | (text (string-append "Level: " (number->string level)) 218 | 24 "white")) 219 | 55 35 220 | scene)) 221 | 222 | (define (render-world w) 223 | (score+scene (world-score w) (world-level w) 224 | (ship+scene (world-ship w) 225 | (asteroids+scene (world-asteroids w) 226 | (bullets+scene (world-bullets w) 227 | (landscape+scene (world-landscape w) 228 | (empty-scene WIDTH HEIGHT "black"))))))) 229 | 230 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 231 | 232 | (define (key-down w a-key) 233 | (hash-set! KEY-STATE a-key #t) 234 | w) 235 | 236 | (define (key-up w a-key) 237 | (hash-remove! KEY-STATE a-key) 238 | w) 239 | 240 | (define (key-pressed? a-key) 241 | (hash-ref KEY-STATE a-key #f)) 242 | 243 | (define (direct-ship w) 244 | (let* ([a-ship (world-ship w)] 245 | [new-facing-direction (+ (ship-facing-direction a-ship) 246 | (cond 247 | [(key-pressed? "left") -5] 248 | [(key-pressed? "a") -5] 249 | [(key-pressed? "right") 5] 250 | [(key-pressed? "s") 5] 251 | [else 0]))] 252 | 253 | [new-direction-speed (add-direction-speeds 254 | (ship-travel-direction a-ship) 255 | (ship-speed a-ship) 256 | new-facing-direction 257 | (if (or (key-pressed? "up") 258 | (key-pressed? "t")) 259 | 1 0))] 260 | [bullets 261 | (cond 262 | [(and (key-pressed? " ") 263 | (< (length (world-bullets w)) MAX-BULLETS)) 264 | (cons (new-bullet a-ship) (world-bullets w))] 265 | [else (world-bullets w)])]) 266 | (world (world-landscape w) 267 | (world-asteroids w) 268 | (ship (ship-pos a-ship) new-facing-direction 269 | (second new-direction-speed) 270 | (first new-direction-speed)) 271 | bullets 272 | (world-score w) 273 | (world-level w)))) 274 | 275 | (define (ship-crashed? w) 276 | (define a-ship (world-ship w)) 277 | (define (ship-hit-asteroids? asteroids) 278 | (cond 279 | [(empty? asteroids) #f] 280 | [(inside-circle? (asteroid-pos (car asteroids)) 281 | (+ (asteroid-size (car asteroids)) 282 | (/ SHIP-SIZE 2)) 283 | (ship-pos a-ship)) #t] 284 | [else (ship-hit-asteroids? (cdr asteroids))])) 285 | (define (ship-hit-landscape? landscape) 286 | (cond 287 | [(empty? landscape) #f] 288 | [(inside-triangle? (car landscape) (ship-pos a-ship)) #t] 289 | [else (ship-hit-landscape? (cdr landscape))])) 290 | 291 | (or (ship-hit-asteroids? (world-asteroids w)) 292 | (ship-hit-landscape? (world-landscape w)))) 293 | 294 | (define (new-world) 295 | ;; Produce a world in which the ship has not just crashed 296 | (define asteroids (times-repeat NUM-ASTEROIDS (new-asteroid))) 297 | (define a-ship (ship (pos (/ WIDTH 2) (/ HEIGHT 2)) 0 0 0)) 298 | (define a-world 299 | (world LEVEL1 asteroids a-ship '() 0 1)) 300 | (if (ship-crashed? a-world) 301 | (new-world) 302 | a-world)) 303 | 304 | (define (go) 305 | (hash-clear! KEY-STATE) 306 | (big-bang (new-world) 307 | (on-tick next-world TICK-RATE) 308 | (on-key key-down) 309 | (on-release key-up) 310 | (to-draw render-world) 311 | (stop-when ship-crashed?))) 312 | -------------------------------------------------------------------------------- /thrust2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | 5 | Thrust - (go) to run. 6 | 7 | Left / right to rotate 8 | Up to thrust 9 | Space to fire. 10 | 11 | TO DO: 12 | - What's wrong with the little triangle and collisions? 13 | - Refactor 2d stuff with vectors 14 | - Scroll around as you fly 15 | 16 | 17 | DONE: 18 | - Asteroids bounce don't travel through triangles 19 | - Gravity 20 | - Better collision detection, not just centre of ship 21 | 22 | |# 23 | 24 | (require 2htdp/universe 2htdp/image lang/posn) 25 | (require "util.rkt") 26 | (require "2d.rkt") 27 | 28 | ;; Debug 29 | (require racket/trace) 30 | 31 | (struct world (landscape asteroids ship bullets score level) #:transparent) 32 | (struct ship (pos facing-direction speed travel-direction) #:transparent) 33 | (struct asteroid (pos direction speed size) #:transparent) 34 | (struct bullet (pos direction speed) #:transparent) 35 | 36 | ;; Each level is a list of triangles that represent the landscape 37 | (define LEVEL1 (list 38 | (list (pos 0 0) (pos 800 0) (pos 200 50)) 39 | (list (pos 500 500) (pos 800 500) (pos 800 600)) 40 | (list (pos 0 400) (pos 300 300) (pos 0 550)) 41 | (list (pos 600 300) (pos 700 350) (pos 650 375)) 42 | )) 43 | 44 | (define LEVEL2 (list 45 | (list (pos 0 0) (pos 800 0) (pos 200 150)) 46 | (list (pos 500 500) (pos 800 500) (pos 800 600)) 47 | (list (pos 0 400) (pos 500 300) (pos 0 550)) 48 | (list (pos 600 300) (pos 700 350) (pos 650 375)) 49 | )) 50 | 51 | (define BIG-ASTEROID 50) 52 | (define NUM-ASTEROIDS 3) 53 | (define BULLET-SPEED 5) 54 | (define SHIP-SIZE 30) 55 | (define MAX-BULLETS 15) 56 | (define ASTEROID-IMG (bitmap "images/space-pizza.png")) 57 | (define SPACESHIP-IMG (bitmap "images/spaceship2.png")) 58 | (define GRAVITY-DIR 90) 59 | (define GRAVITY-MAG .01) 60 | 61 | (define TICK-RATE 1/30) 62 | (define WIDTH 800) 63 | (define HEIGHT 600) 64 | 65 | (define KEY-STATE (make-hash)) 66 | 67 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 68 | 69 | (define (wrap-pos a-pos a-size) 70 | (define x (pos-x a-pos)) 71 | (define y (pos-y a-pos)) 72 | (pos (cond 73 | [(> x (+ WIDTH a-size)) (- 0 a-size)] 74 | [(< x (- 0 a-size)) (+ WIDTH a-size)] 75 | [else x]) 76 | (cond 77 | [(> y (+ HEIGHT a-size)) (- 0 a-size)] 78 | [(< y (- 0 a-size)) (+ HEIGHT a-size)] 79 | [else y]))) 80 | 81 | (define (new-asteroid) 82 | (asteroid (pos (random WIDTH) (random HEIGHT)) 83 | (random 360) (+ 1 (random 2)) BIG-ASTEROID)) 84 | 85 | (define (bullet-in-range a-bullet) 86 | (define x (pos-x (bullet-pos a-bullet))) 87 | (define y (pos-y (bullet-pos a-bullet))) 88 | (and (> x 0) (< x WIDTH) (> y 0) (< y HEIGHT))) 89 | 90 | (define (move-asteroid a landscape) 91 | (let* ([new-pos (wrap-pos 92 | (move-pos (asteroid-pos a) (asteroid-direction a) (asteroid-speed a)) 93 | (asteroid-size a))] 94 | [new-pos-a-hit? (thing-hit-landscape? (list new-pos) landscape)]) 95 | (if new-pos-a-hit? 96 | ;; bounce 97 | (asteroid (asteroid-pos a) 98 | (- (asteroid-direction a) 180) 99 | (asteroid-speed a) 100 | (asteroid-size a)) 101 | (asteroid new-pos 102 | (asteroid-direction a) 103 | (asteroid-speed a) 104 | (asteroid-size a))))) 105 | 106 | (define (new-bullet a-ship) 107 | (bullet (ship-pos a-ship) 108 | (ship-facing-direction a-ship) 109 | (+ (ship-speed a-ship) BULLET-SPEED))) 110 | 111 | (define (move-bullet b) 112 | (bullet (move-pos (bullet-pos b) (bullet-direction b) (bullet-speed b)) 113 | (bullet-direction b) 114 | (bullet-speed b))) 115 | 116 | (define (hit-asteroids asteroids bullets) 117 | ;; If any asteroids have been hit, split them in half. 118 | ;; Asteroids that are too small are deleted. 119 | 120 | ;; A list like this (a a a a a) will result in a list 121 | ;; like this (a a (a a) a a) on hit, we use flatten 122 | ;; to return the right thing. 123 | 124 | (define (hit-asteroid? a bullets) 125 | ;; Has this asteroid been hit by any of the bullets? 126 | (cond 127 | [(empty? bullets) #f] 128 | [(inside-circle? (asteroid-pos a) (asteroid-size a) 129 | (bullet-pos (car bullets))) #t] 130 | [else 131 | (hit-asteroid? a (cdr bullets))])) 132 | 133 | (define (split-asteroid a) 134 | (list (asteroid (asteroid-pos a) (- (asteroid-direction a) 90) 135 | (asteroid-speed a) (/ (asteroid-size a) 2)) 136 | (asteroid (asteroid-pos a) (+ (asteroid-direction a) 90) 137 | (asteroid-speed a) (/ (asteroid-size a) 2)))) 138 | 139 | (define (bullets-hit-asteroid a) 140 | (if (hit-asteroid? a bullets) 141 | (split-asteroid a) 142 | a)) 143 | 144 | (define (big-enough a) 145 | (> (asteroid-size a) 5)) 146 | 147 | (filter big-enough (flatten (map bullets-hit-asteroid asteroids)))) 148 | 149 | (define (asteroids-diff prev-asteroids next-asteroids) 150 | ;; +1 point each time the number of asteroids decreases 151 | ;; regardless of size 152 | (define diff (- (length prev-asteroids) 153 | (length next-asteroids))) 154 | (if (> diff 0) diff 0)) 155 | 156 | 157 | (define (live-bullets asteroids landscape bullets) 158 | ;; Like hit-asteroids, but returns only bullets that 159 | ;; have not hit an asteroid or the landscape 160 | 161 | (define (bullet-hit-asteroid? b asteroids) 162 | (cond 163 | [(empty? asteroids) #f] 164 | [(inside-circle? (asteroid-pos (car asteroids)) 165 | (asteroid-size (car asteroids)) 166 | (bullet-pos b)) #t] 167 | [else (bullet-hit-asteroid? b (cdr asteroids))])) 168 | (define (bullet-hit-landscape? b landscape) 169 | (cond 170 | [(empty? landscape) #f] 171 | [(inside-triangle? (car landscape) (bullet-pos b)) #t] 172 | [else (bullet-hit-landscape? b (cdr landscape))])) 173 | 174 | (define (bullet-hit-nothing? b) 175 | (not (or (bullet-hit-asteroid? b asteroids) 176 | (bullet-hit-landscape? b landscape)))) 177 | 178 | (filter bullet-hit-nothing? bullets)) 179 | 180 | (define (move-ship a-ship) 181 | (ship (wrap-pos 182 | (move-pos (ship-pos a-ship) (ship-travel-direction a-ship) (ship-speed a-ship)) 183 | SHIP-SIZE) 184 | (ship-facing-direction a-ship) 185 | (ship-speed a-ship) 186 | (ship-travel-direction a-ship))) 187 | 188 | (define (next-world w) 189 | (move-world (direct-ship w))) 190 | 191 | (define (move-world w) 192 | (define next-asteroids (hit-asteroids (world-asteroids w) (world-bullets w))) 193 | (define next-bullets (live-bullets (world-asteroids w) (world-landscape w) 194 | (world-bullets w))) 195 | (define add-score (asteroids-diff (world-asteroids w) next-asteroids)) 196 | 197 | (world (world-landscape w) 198 | (map (λ (a) (move-asteroid a (world-landscape w))) next-asteroids) 199 | (move-ship (world-ship w)) 200 | (filter bullet-in-range (map move-bullet next-bullets)) 201 | (+ add-score (world-score w)) 202 | (world-level w))) 203 | 204 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 205 | ;; Rendering 206 | 207 | (define (img+scene pos img scene) 208 | (place-image img (pos-x pos) (pos-y pos) scene)) 209 | 210 | (define (ship-img a-direction) 211 | (rotate (- 0 a-direction) 212 | (scale 2 SPACESHIP-IMG))) 213 | 214 | (define (ship+scene a-ship scene) 215 | (img+scene (ship-pos a-ship) 216 | (ship-img (ship-facing-direction a-ship)) 217 | scene)) 218 | 219 | (define (landscape+scene landscape scene) 220 | (foldl (λ (points scene) 221 | (scene+polygon scene 222 | (pos->posn points) "solid" "gray")) 223 | scene landscape)) 224 | 225 | (define (asteroids+scene asteroids scene) 226 | (foldl (λ (a scene) 227 | (img+scene (asteroid-pos a) 228 | (scale (/ (asteroid-size a) 11) 229 | ASTEROID-IMG) 230 | scene)) 231 | scene asteroids)) 232 | 233 | (define (bullets+scene bullets scene) 234 | (foldl (λ (b scene) 235 | (img+scene (bullet-pos b) 236 | (circle 2 "solid" "yellow") 237 | scene)) 238 | scene bullets)) 239 | 240 | (define (score+scene score level scene) 241 | (place-image 242 | (above/align "left" 243 | (text (string-append "Score: " (number->string score)) 244 | 24 "white") 245 | (text (string-append "Level: " (number->string level)) 246 | 24 "white")) 247 | 55 35 248 | scene)) 249 | 250 | (define (render-world w) 251 | (score+scene (world-score w) (world-level w) 252 | (ship+scene (world-ship w) 253 | (asteroids+scene (world-asteroids w) 254 | (bullets+scene (world-bullets w) 255 | (landscape+scene (world-landscape w) 256 | (empty-scene WIDTH HEIGHT "black"))))))) 257 | 258 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 259 | 260 | (define (key-down w a-key) 261 | (hash-set! KEY-STATE a-key #t) 262 | w) 263 | 264 | (define (key-up w a-key) 265 | (hash-remove! KEY-STATE a-key) 266 | w) 267 | 268 | (define (key-pressed? a-key) 269 | (hash-ref KEY-STATE a-key #f)) 270 | 271 | (define (direct-ship w) 272 | (let* ([a-ship (world-ship w)] 273 | [new-facing-direction (+ (ship-facing-direction a-ship) 274 | (cond 275 | [(key-pressed? "left") -5] 276 | [(key-pressed? "a") -5] 277 | [(key-pressed? "right") 5] 278 | [(key-pressed? "s") 5] 279 | [else 0]))] 280 | 281 | [new-direction-speed (add-direction-speeds 282 | (ship-travel-direction a-ship) 283 | (ship-speed a-ship) 284 | new-facing-direction 285 | (if (or (key-pressed? "up") 286 | (key-pressed? "t")) 287 | 0.5 0))] 288 | [new-direction-speed-w-gravity (add-direction-speeds 289 | (first new-direction-speed) 290 | (second new-direction-speed) 291 | GRAVITY-DIR GRAVITY-MAG)] 292 | [bullets 293 | (cond 294 | [(and (key-pressed? " ") 295 | (< (length (world-bullets w)) MAX-BULLETS)) 296 | (cons (new-bullet a-ship) (world-bullets w))] 297 | [else (world-bullets w)])]) 298 | (world (world-landscape w) 299 | (world-asteroids w) 300 | (ship (ship-pos a-ship) new-facing-direction 301 | (second new-direction-speed-w-gravity) 302 | (first new-direction-speed-w-gravity)) 303 | bullets 304 | (world-score w) 305 | (world-level w)))) 306 | 307 | (define (ship-points a-ship) 308 | ;; The most important points that make up the ship, for collision detection 309 | (points-around-centre (ship-pos a-ship) (/ SHIP-SIZE 2) 30)) 310 | 311 | (define (thing-hit-landscape? thing-points landscape) 312 | (cond 313 | [(empty? landscape) #f] 314 | [(ormap (λ (p) (inside-triangle? (car landscape) p)) 315 | thing-points) #t] 316 | [else (thing-hit-landscape? thing-points (cdr landscape))])) 317 | 318 | (define (ship-crashed? w) 319 | (define a-ship (world-ship w)) 320 | (define (ship-hit-asteroids? asteroids) 321 | (cond 322 | [(empty? asteroids) #f] 323 | [(inside-circle? (asteroid-pos (car asteroids)) 324 | (+ (asteroid-size (car asteroids)) 325 | (/ SHIP-SIZE 2)) 326 | (ship-pos a-ship)) #t] 327 | [else (ship-hit-asteroids? (cdr asteroids))])) 328 | 329 | (or (ship-hit-asteroids? (world-asteroids w)) 330 | (thing-hit-landscape? (ship-points a-ship) (world-landscape w)))) 331 | 332 | ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 333 | 334 | (define (new-world) 335 | ;; Produce a world in which the ship has not just crashed 336 | (define asteroids (times-repeat NUM-ASTEROIDS (new-asteroid))) 337 | (define a-ship (ship (pos 400 200) 0 0 0)) 338 | (define a-world 339 | (world LEVEL1 asteroids a-ship '() 0 1)) 340 | (if (ship-crashed? a-world) 341 | (new-world) 342 | a-world)) 343 | 344 | (define (go) 345 | (hash-clear! KEY-STATE) 346 | (big-bang (new-world) 347 | (on-tick next-world TICK-RATE) 348 | (on-key key-down) 349 | (on-release key-up) 350 | (to-draw render-world) 351 | (stop-when ship-crashed?))) 352 | -------------------------------------------------------------------------------- /tree1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | Draw a fractal tree 5 | 6 | TODO: 7 | - Make the branches join up! 8 | |# 9 | 10 | 11 | (require 2htdp/image) 12 | 13 | (define BRANCH-COLOUR "white") 14 | (define MIN-SIZE 5) 15 | (define DS 0.7) 16 | (define DA 30) 17 | 18 | (define (tree size angle) 19 | (if (> size MIN-SIZE) 20 | (let* ([a (degrees->radians angle)] 21 | [x (* (cos a) size)] 22 | [y (* (sin a) size)]) 23 | (above 24 | (beside 25 | (tree (* size DS) (- angle DA)) 26 | (tree (* size DS) (+ angle DA))) 27 | (line x y BRANCH-COLOUR))) 28 | (empty-scene 0 0 "black"))) 29 | 30 | ;; (tree 50 90) -------------------------------------------------------------------------------- /tree1b.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | Draw a fractal tree 5 | 6 | DONE: 7 | - Refactored recursion 8 | 9 | TODO: 10 | - Separate out generating branches from drawing tree 11 | - Get rid of constants and make a tree-maker function 12 | to create trees of a family 13 | |# 14 | 15 | 16 | (require 2htdp/image) 17 | (require racket/trace) 18 | (require "util.rkt") 19 | 20 | (define BRANCH-COLOUR "green") 21 | (define BG-COLOUR "black") 22 | 23 | (struct point (x y) #:transparent) 24 | (struct branch (start end) #:transparent) 25 | 26 | (define (translate-point p length angle) 27 | (let ([a (degrees->radians angle)]) 28 | (point (+ (point-x p) (* (cos a) length)) 29 | (+ (point-y p) (* (sin a) length))))) 30 | 31 | (define (tree p length num-branches angle angle-delta) 32 | ;; Return a list of branches representing a tree 33 | (let ([end-point (translate-point p length angle)]) 34 | (list 35 | (branch p end-point) 36 | (if (> length 10) 37 | (for/list ([b (range num-branches)]) 38 | (tree end-point (* length 0.6) num-branches 39 | (+ angle (* (- (/ num-branches 2) b) angle-delta)) 40 | angle-delta)) 41 | '() 42 | )))) 43 | 44 | (define (scene+branch b scene) 45 | (scene+line scene (point-x (branch-start b)) (point-y (branch-start b)) 46 | (point-x (branch-end b)) (point-y (branch-end b)) 47 | BRANCH-COLOUR)) 48 | 49 | (define (scene+tree t scene) 50 | (foldl scene+branch 51 | scene 52 | (flatten t))) 53 | 54 | (define (draw-tree size) 55 | ;; Guess at width and height 56 | (let* ([width (* size 5)] 57 | [height (* size 5)]) 58 | (scene+tree 59 | (tree 60 | (point (/ width 2) (- height 10)) 61 | size 62 | 4 ;; branches 63 | 270 ;; up 64 | 35 ;; angle between branches 65 | ) 66 | (empty-scene width height BG-COLOUR) 67 | ))) 68 | 69 | (draw-tree 100) -------------------------------------------------------------------------------- /tree2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | Draw a fractal tree 5 | 6 | DONE: 7 | - Make the branches join up! 8 | 9 | TODO: 10 | - Have more than 2 branches 11 | - Vary stem thickness 12 | - Introduce some randomness 13 | |# 14 | 15 | 16 | (require 2htdp/image) 17 | (require racket/trace) 18 | 19 | (define BRANCH-COLOUR "white") 20 | (define MIN-SIZE 3) 21 | (define DS 0.6) 22 | (define DA 30) 23 | 24 | (define (tree scene x y size angle) 25 | ;; Return a new scene with a tree on it 26 | (if (< size MIN-SIZE) 27 | scene 28 | (let* ([a (degrees->radians angle)] 29 | [x2 (+ x (* (cos a) size))] 30 | [y2 (+ y (* (sin a) size))] 31 | [next-size (* size DS)] 32 | [next-angle-1 (+ angle DA)] 33 | [next-angle-2 (- angle DA)]) 34 | (tree 35 | (tree 36 | (add-line scene x y x2 y2 BRANCH-COLOUR) 37 | x2 y2 next-size next-angle-1) 38 | x2 y2 next-size next-angle-2)))) 39 | 40 | ;; (tree (empty-scene 0 0 "black") 0 0 50 90) 41 | ;; (tree (empty-scene 200 200 "blue") 100 190 50 270) -------------------------------------------------------------------------------- /tree2b.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | Draw a fractal tree 5 | 6 | DONE: 7 | - Split out generating tree (branches) from drawing it 8 | 9 | TODO: 10 | - Vary branch width according to length 11 | - Draw sub-branches along branch rather than at end? 12 | |# 13 | 14 | 15 | (require 2htdp/image) 16 | (require racket/trace) 17 | (require (planet williams/science/random-distributions/gaussian)) 18 | 19 | (require "util.rkt") 20 | 21 | (define BRANCH-COLOUR "white") 22 | (define BG-COLOUR "black") 23 | 24 | (struct point (x y) #:transparent) 25 | (struct branch (start end) #:transparent) 26 | 27 | (define (translate-point p length angle) 28 | (let ([a (degrees->radians angle)]) 29 | (point (+ (point-x p) (* (cos a) length)) 30 | (+ (point-y p) (* (sin a) length))))) 31 | 32 | (define (random-adjust mean stddev factor) 33 | ;; Scale stddev by factor (0,1) before returning a random number 34 | (let ([stddev2 (* stddev factor)]) 35 | (random-gaussian mean stddev2))) 36 | 37 | (define (tree p length num-branches angle angle-between-branches randomness) 38 | ;; Return a list of branches representing a tree starting at point p 39 | ;; angle is the direction of the trunk 40 | ;; randomness is 0 to 1, with 1 creating variation with stddev = mean 41 | (let* ([random-length (random-adjust length length randomness)] 42 | [random-angle (random-adjust angle angle-between-branches randomness)] 43 | [end-point (translate-point p random-length random-angle)]) 44 | (list 45 | (branch p end-point) 46 | (if (> length 10) 47 | (for/list ([b (range num-branches)]) 48 | (tree end-point (* length 0.6) num-branches 49 | (+ angle (* (- (/ num-branches 2) b) angle-between-branches)) 50 | angle-between-branches randomness)) 51 | '() 52 | )))) 53 | 54 | (define (scene+branch b scene) 55 | (scene+line scene (point-x (branch-start b)) (point-y (branch-start b)) 56 | (point-x (branch-end b)) (point-y (branch-end b)) 57 | BRANCH-COLOUR)) 58 | 59 | (define (scene+tree t scene) 60 | (foldl scene+branch 61 | scene 62 | (flatten t))) 63 | 64 | (define (draw-tree size num-branches angle-between-branches randomness) 65 | ;; Guess at width and height 66 | (let* ([width (* size 3)] 67 | [height (* size 3)]) 68 | (scene+tree 69 | (tree 70 | (point (/ width 2) (- height 10)) 71 | size 72 | num-branches 73 | 270 ;; up 74 | angle-between-branches 75 | randomness 76 | ) 77 | (empty-scene width height BG-COLOUR) 78 | ))) 79 | 80 | (draw-tree 100 3 60 0.2) 81 | (draw-tree 75 4 20 0.3) -------------------------------------------------------------------------------- /tree3.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | Draw a fractal tree 5 | 6 | DONE: 7 | - Have more than 2 branches 8 | - Vary stem thickness 9 | - Introduce some randomness 10 | 11 | TODO: 12 | - Randomise colour a bit 13 | - Make tree a bit more symmetrical 14 | - Get rid of constants and make a tree-maker function 15 | to create trees of a family 16 | |# 17 | 18 | 19 | (require 2htdp/image) 20 | (require racket/trace) 21 | (require "util.rkt") 22 | 23 | (define BRANCH-COLOUR "green") 24 | (define NUM-BRANCHES 4) 25 | (define MIN-SIZE 10) 26 | (define DS 0.7) 27 | (define DA 30) 28 | (define BG-COLOUR "black") 29 | 30 | 31 | ;; How likely we have a different num of branches? 32 | (define RAND-BRANCHES 0.5) 33 | ;; And how many more / less? 34 | (define RAND-BRANCHES-SCALE 1) 35 | ;; How likely we have different branch lengths? 36 | (define RAND-SIZE 0.2) 37 | ;; And how much bigger / smaller? 38 | (define RAND-SIZE-SCALE 0.3) 39 | ;; How likely we have different angles? 40 | (define RAND-ANGLE 0.4) 41 | ;; And how much bigger / smaller? 42 | (define RAND-ANGLE-SCALE 0.1) 43 | 44 | (define (randomise n scale likely) 45 | ;; increase or decrease n by up to scale randomly 46 | ;; depending on likely (0 = never, 1 = always) 47 | (if (< (random) likely) 48 | (let ([range (exact-round (abs (+ 1 (* 2 scale))))]) 49 | (+ n (- scale (random range)))) 50 | n)) 51 | 52 | (define (branches scene n x y size angle) 53 | ;; Draw n branches (trees) on scene 54 | (if (= n 0) 55 | scene 56 | (branches 57 | (scene+tree scene x y size angle) 58 | (sub1 n) x y size (+ angle DA)))) 59 | 60 | (define (scene+tree scene x y size angle) 61 | ;; Return a new scene with a tree on it 62 | (if (< size MIN-SIZE) 63 | scene 64 | (let* ([rsize (randomise size (* size RAND-SIZE-SCALE) RAND-SIZE)] 65 | [rangle (randomise angle (* angle RAND-ANGLE-SCALE) RAND-ANGLE)] 66 | [a (degrees->radians rangle)] 67 | [x2 (+ x (* (cos a) rsize))] 68 | [y2 (+ y (* (sin a) rsize))] 69 | [pen-width (floor (+ 1 (/ rsize 30)))] 70 | [a-pen (pen BRANCH-COLOUR pen-width "solid" "round" "round")] 71 | [next-size (* size DS)] 72 | [num-branches (randomise NUM-BRANCHES RAND-BRANCHES-SCALE RAND-BRANCHES)] 73 | [next-angle (- angle (* DA (/ num-branches 2)))]) 74 | (branches 75 | (scene+line scene x y x2 y2 a-pen) 76 | num-branches x2 y2 next-size next-angle)))) 77 | 78 | (define (tree size angle) 79 | (let* ([width (* size 5)] 80 | [height (* size 5)]) 81 | (scene+tree 82 | (empty-scene width height BG-COLOUR) 83 | (/ width 2) (- height 10) 84 | size angle 85 | ))) 86 | 87 | (tree 80 270) -------------------------------------------------------------------------------- /util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/list) 4 | 5 | (define-syntax-rule (times-repeat n fn) 6 | (for/list ([i (in-range n)]) 7 | fn)) 8 | 9 | (define (random-range a b) 10 | (+ a (random (+ 1 (- b a))))) 11 | 12 | (define (random-choice list) 13 | (if (empty? list) 14 | #f 15 | (list-ref list (random (length list))))) 16 | 17 | (define (random-sign exp) 18 | ;; Randomly return +exp or -exp 19 | (* exp (random-choice (list -1 1)))) 20 | 21 | (define (every-other list) 22 | (cond 23 | [(empty? list) '()] 24 | [(= (length list) 1) list] 25 | [else 26 | (cons (car list) (every-other (cddr list)))])) 27 | 28 | (provide times-repeat random-range random-choice random-sign 29 | every-other) --------------------------------------------------------------------------------