├── .gitignore ├── .travis.yml ├── README.md ├── ai.rkt ├── collision-helper.rkt ├── component-util.rkt ├── components.rkt ├── components ├── after-time.rkt ├── animated-sprite.rkt ├── backdrop.rkt ├── backpack.rkt ├── counter.rkt ├── detect-collide.rkt ├── detect-edge.rkt ├── dialog.rkt ├── direction.rkt ├── do-every.rkt ├── every-tick.rkt ├── follow.rkt ├── health.rkt ├── key-animator.rkt ├── key-movement.rkt ├── lock-to.rkt ├── observe-change.rkt ├── on-edge.rkt ├── on-key.rkt ├── on-mouse.rkt ├── on-rule.rkt ├── on-start.rkt ├── producer-of.rkt ├── rotation-style.rkt ├── sound-stream.rkt ├── spawn-dialog.rkt ├── spawn-once.rkt ├── speed.rkt ├── stop-on-edge.rkt ├── storage.rkt └── wrap-around.rkt ├── engine ├── component-struct.rkt ├── core.rkt ├── core │ └── scribblings │ │ └── .core.scrbl.swp ├── extensions │ ├── sound.rkt │ └── sound │ │ ├── fake-rsound.rkt │ │ └── rsound.rkt └── rendering.rkt ├── entity-helpers ├── backpack-util.rkt ├── carry-util.rkt ├── cutscene-util.rkt ├── dialog-util.rkt ├── mini-map.rkt ├── mouse-util.rkt ├── movement-util.rkt ├── particles.rkt ├── player-util.rkt ├── render-util.rkt ├── rgb-hsb.rkt ├── sprite-util.rkt ├── text-util.rkt ├── time-manager.rkt └── ui-util.rkt ├── game-engine.rkt ├── game-entities.rkt ├── info.rkt ├── main.rkt ├── pre-install.rkt ├── scribblings └── game-engine.scrbl └── test ├── a-bunch-of-features.rkt ├── main.rkt └── run-tests.sh /.gitignore: -------------------------------------------------------------------------------- 1 | compiled/* 2 | **/compiled/* 3 | */compiled/* 4 | *~ 5 | .DS_Store 6 | *.bak 7 | doc/* 8 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | # Based from: https://github.com/greghendershott/travis-racket 4 | 5 | # Optional: Remove to use Travis CI's older infrastructure. 6 | sudo: false 7 | 8 | env: 9 | global: 10 | # Supply a global RACKET_DIR environment variable. This is where 11 | # Racket will be installed. A good idea is to use ~/racket because 12 | # that doesn't require sudo to install and is therefore compatible 13 | # with Travis CI's newer container infrastructure. 14 | - RACKET_DIR=~/racket 15 | matrix: 16 | # Supply at least one RACKET_VERSION environment variable. This is 17 | # used by the install-racket.sh script (run at before_install, 18 | # below) to select the version of Racket to download and install. 19 | # 20 | # Supply more than one RACKET_VERSION (as in the example below) to 21 | # create a Travis-CI build matrix to test against multiple Racket 22 | # versions. 23 | - RACKET_VERSION=7.0 24 | 25 | matrix: 26 | allow_failures: 27 | # - env: RACKET_VERSION=HEAD 28 | fast_finish: true 29 | 30 | before_install: 31 | - git clone https://github.com/thoughtstem/travis-racket.git ~/travis-racket 32 | - cat ~/travis-racket/install-racket.sh | bash # pipe to bash not sh! 33 | - export PATH="${RACKET_DIR}/bin:${PATH}" #install-racket.sh can't set for us 34 | 35 | install: 36 | - git clone https://github.com/thoughtstem/travis-build-process 37 | 38 | before_script: 39 | 40 | # Here supply steps such as raco make, raco test, etc. You can run 41 | # `raco pkg install --deps search-auto` to install any required 42 | # packages without it getting stuck on a confirmation prompt. 43 | script: 44 | - cd travis-build-process/GE && bash build.sh 45 | 46 | 47 | after_success: 48 | - raco setup --check-pkg-deps --pkgs ts-all-dev 49 | - raco pkg install --deps search-auto cover cover-coveralls 50 | - raco cover -b -f coveralls -d $TRAVIS_BUILD_DIR/coverage . 51 | - bash host-docs.sh 52 | 53 | notifications: 54 | email: 55 | recipients: 56 | - stephen@thoughtstem.com 57 | - jason@thoughtstem.com 58 | - sonny@thoughtstem.com 59 | - sara@thoughtstem.com 60 | on_success: always 61 | on_failure: always 62 | 63 | 64 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # game-engine 2 | 3 | This is an educational game engine for 2D games. 4 | 5 | It uses an entity/component architecture. This means that a game 6 | is defined as a set of entities (with components). These entities may 7 | come and go. Their components may change. But at any given time, 8 | the state of the game is fully defined by its entities and their components. 9 | 10 | In fact, the notion of entity is really just: a bundle of components. 11 | You can easily construct new entities from existing components. 12 | 13 | -------------------------------------------------------------------------------- /ai.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (module+ test 4 | (require rackunit 5 | "./components/storage.rkt") 6 | 7 | (define e (sprite->entity empty-image 8 | #:name "player" 9 | #:position (posn 0 0))) 10 | 11 | 12 | (let () 13 | 14 | (define c-a (counter 5)) 15 | (define a (make-state 'a c-a)) 16 | 17 | (define c-b (counter 10)) 18 | (define b (make-state 'b c-b)) 19 | 20 | (check-equal? c-a 21 | (first (state-components a))) 22 | 23 | (define e-with-a (add-components-from-state e a)) 24 | 25 | (check-equal? (get-component e-with-a counter?) 26 | c-a) 27 | 28 | (define e-with-updated-a ((change-counter-by 10) #f e-with-a)) 29 | 30 | 31 | ;Check that removing components from state B does not remove the counter from state A 32 | (check component-eq? 33 | (get-component (remove-components-from-state e-with-updated-a b) counter?) 34 | c-a) 35 | 36 | 37 | (define e-without-a (remove-components-from-state e-with-updated-a a)) 38 | 39 | (check-equal? (get-component e-without-a counter?) 40 | #f) 41 | 42 | ) 43 | 44 | (let () 45 | 46 | (define not-boss (make-state 'not-boss 47 | (storage "aggression" 0) 48 | (storage "boss-mode" "No"))) 49 | 50 | (define boss (make-state 'boss 51 | (storage "aggression" 100) 52 | (storage "boss-mode" "Yes"))) 53 | 54 | (define not-boss->boss (make-transition #:rule (λ(g e) 55 | (= 1 (get-counter e))) 56 | not-boss boss)) 57 | 58 | (define e2 (add-component 59 | (entity-add-machine e 60 | (state-machine not-boss 61 | (list not-boss boss) 62 | (list not-boss->boss))) 63 | (counter 0))) 64 | 65 | (check-equal? (get-entity-current-state e2) 66 | not-boss) 67 | 68 | (define game:pre-boss (tick #:ticks 20 ;Nothing should really happen 69 | (initialize-game (list e2)))) 70 | 71 | (define entity:pre-boss (get-entity "player" game:pre-boss)) 72 | 73 | (check-equal? (get-entity-current-state entity:pre-boss) 74 | not-boss) 75 | 76 | (check-equal? (get-storage-data "boss-mode" entity:pre-boss) 77 | "No") 78 | 79 | (define game:right-before-boss (game-replace-entity game:pre-boss 80 | (update-entity entity:pre-boss 81 | counter? 82 | (counter 1)))) 83 | 84 | (define game:after-boss (tick #:ticks 1 85 | game:right-before-boss)) 86 | 87 | (define entity:after-boss (get-entity "player" game:after-boss)) 88 | 89 | (check-equal? (get-entity-current-state entity:after-boss) 90 | boss) 91 | 92 | (check-equal? (get-storage-data "boss-mode" entity:after-boss) 93 | "Yes") 94 | 95 | (check-equal? (get-storage-data "aggression" entity:after-boss) 96 | 100) 97 | 98 | ) 99 | 100 | 101 | (let () 102 | 103 | (define a (make-state 'a 104 | (counter 0) 105 | (every-tick (change-counter-by 1)))) 106 | 107 | (define b (make-state 'b 108 | (counter 5) 109 | (every-tick (change-counter-by 1)))) 110 | 111 | (define a->b (make-transition #:rule (λ(g e) 112 | (eq? 'b (get-storage-data "current-counter" e))) 113 | a b)) 114 | 115 | (define b->a (make-transition #:rule (λ(g e) 116 | (eq? 'a (get-storage-data "current-counter" e))) 117 | b a)) 118 | 119 | (define starting-e (add-component 120 | (entity-add-machine e 121 | (state-machine a 122 | (list a b) 123 | (list a->b b->a))) 124 | (storage "current-counter" 'a))) 125 | 126 | 127 | 128 | (define game:a=20 (tick #:ticks 20 129 | (initialize-game (list starting-e)))) 130 | 131 | (define entity:a=20 (get-entity "player" game:a=20)) 132 | 133 | (check-equal? (get-entity-current-state entity:a=20) 134 | a) 135 | 136 | 137 | (check-equal? (get-entity-current-state entity:a=20) a) 138 | (check-equal? (get-counter entity:a=20) 20) 139 | 140 | 141 | (define game:b=5 (tick #:ticks 1 142 | (game-replace-entity game:a=20 143 | (set-storage "current-counter" entity:a=20 'b)))) 144 | 145 | 146 | (define entity:b=5 (get-entity "player" game:b=5)) 147 | 148 | 149 | (check-equal? (get-entity-current-state entity:b=5) b) 150 | 151 | 152 | (check-equal? (get-counter entity:b=5) 6) ;Started at 5, we've done 1 tick since transitioning 153 | 154 | (define game:b=25 (tick #:ticks 19 game:b=5)) 155 | 156 | (define entity:b=25 (get-entity "player" game:b=25)) 157 | 158 | (check-equal? (get-counter entity:b=25) 159 | 25))) 160 | 161 | (provide move-up-and-down 162 | move-left 163 | move-right 164 | move-up 165 | move-down 166 | move-random 167 | move-dir-spd 168 | move 169 | move-up-down 170 | move-left-right 171 | spin 172 | 173 | (rename-out [make-state state]) 174 | (rename-out [make-transition transition]) 175 | (rename-out [make-state-machine state-machine]) 176 | entity-add-machine 177 | 178 | move-sprite 179 | ) 180 | 181 | (require posn) 182 | (require "./game-entities.rkt") 183 | (require 2htdp/image threading) 184 | (require "./components/animated-sprite.rkt") 185 | (require "./components/direction.rkt") 186 | (require "./components/speed.rkt") 187 | (require "./components/every-tick.rkt") 188 | (require "./components/counter.rkt") 189 | 190 | (struct state (name components) #:transparent) 191 | (struct transition (rule source target) #:transparent) 192 | 193 | (struct state-machine (current states transitions) #:transparent) 194 | 195 | (define/contract (make-state name . components) 196 | (->* (any/c) #:rest (listof component?) state?) 197 | (state name components)) 198 | 199 | (define (make-transition source target #:rule rule) 200 | (transition rule source target)) 201 | 202 | (define (make-state-machine start states transitions) 203 | (state-machine start states transitions)) 204 | 205 | 206 | (define (get-entity-current-state e) 207 | (state-machine-current (get-component e state-machine?))) 208 | 209 | (define (is-out-going-from? current t) 210 | (eq? current 211 | (transition-source t))) 212 | 213 | (define (should-trigger? g e t) 214 | ((transition-rule t) g e)) 215 | 216 | (define (transition-if-necessary g entity-with-machine machine) 217 | (match-define 218 | (state-machine current states transitions) 219 | machine) 220 | 221 | (define outgoing-edges (filter (curry is-out-going-from? current) transitions)) 222 | 223 | (define triggered-edges (filter (curry should-trigger? g entity-with-machine) outgoing-edges)) 224 | 225 | 226 | (if (empty? triggered-edges) 227 | machine 228 | (begin 229 | (state-machine (transition-target (first triggered-edges)) 230 | states 231 | transitions))) ) 232 | 233 | 234 | 235 | (define (remove-components-from-state e s) 236 | (define components (state-components s)) 237 | 238 | (foldl 239 | (λ(n a) 240 | (remove-component a (curry component-eq? n))) 241 | e 242 | components)) 243 | 244 | (define (add-components-from-state e s) 245 | (define components (state-components s)) 246 | 247 | (add-components e components)) 248 | 249 | (define (entity-add-machine e m) 250 | (~> e 251 | (add-component _ m) 252 | (add-components-from-state _ (state-machine-current m)))) 253 | 254 | (define (entity-switch-machine e new-machine) 255 | (define old-state (get-entity-current-state e)) 256 | (define new-state (state-machine-current new-machine)) 257 | 258 | (~> e 259 | (update-entity _ state-machine? new-machine) 260 | (remove-components-from-state _ old-state) 261 | (add-components-from-state _ new-state))) 262 | 263 | (define (update-state-machine g e c) 264 | (define new-machine (transition-if-necessary g e c)) 265 | 266 | (if (eq? c new-machine) 267 | e 268 | (entity-switch-machine e new-machine))) 269 | 270 | 271 | (new-component state-machine? 272 | update-state-machine) 273 | 274 | 275 | 276 | ;A Lot of these could be implemented better (less stateful?) 277 | ; Or go full state machine? 278 | ; Waypoint system? 279 | 280 | ;Everything feels a bit cobbled together at the moment. 281 | 282 | (define (move-up-and-down #:min min #:max max #:speed s) 283 | (define f (curry + s)) 284 | (lambda (g e) 285 | (define current-pos-y (posn-y (get-component e posn?))) 286 | (define current-pos-x (posn-x (get-component e posn?))) 287 | (if (>= current-pos-y max) 288 | (set! f (curryr - s)) 289 | (void)) 290 | (if (<= current-pos-y min) 291 | (set! f (curry + s)) 292 | (void)) 293 | (update-entity e posn? (posn current-pos-x 294 | (f current-pos-y))))) 295 | 296 | (define (move-left #:speed s) 297 | (lambda (g e) 298 | (define current-pos-y (posn-y (get-component e posn?))) 299 | (define current-pos-x (posn-x (get-component e posn?))) 300 | (update-entity e posn? (posn (- current-pos-x s) 301 | current-pos-y)))) 302 | 303 | (define (move-right #:speed s) 304 | (lambda (g e) 305 | (define current-pos-y (posn-y (get-component e posn?))) 306 | (define current-pos-x (posn-x (get-component e posn?))) 307 | (update-entity e posn? (posn (+ current-pos-x s) 308 | current-pos-y)))) 309 | 310 | (define (move-up #:speed s) 311 | (lambda (g e) 312 | (define current-pos-y (posn-y (get-component e posn?))) 313 | (define current-pos-x (posn-x (get-component e posn?))) 314 | (update-entity e posn? (posn current-pos-x 315 | (- current-pos-y s))))) 316 | 317 | (define (move-down #:speed s) 318 | (lambda (g e) 319 | (define current-pos-y (posn-y (get-component e posn?))) 320 | (define current-pos-x (posn-x (get-component e posn?))) 321 | (update-entity e posn? (posn current-pos-x 322 | (+ current-pos-y s))))) 323 | 324 | (define (move-random #:speed s) 325 | (define rx (* s (random -1 2))) 326 | (define ry (* s (random -1 2))) 327 | (lambda (g e) 328 | (define current-pos-y (posn-y (get-component e posn?))) 329 | (define current-pos-x (posn-x (get-component e posn?))) 330 | (update-entity e posn? (posn (+ rx current-pos-x) 331 | (+ ry current-pos-y))))) 332 | 333 | (define (move-dir-spd #:dir d #:speed s) 334 | (lambda (g e) 335 | (define current-pos-y (posn-y (get-component e posn?))) 336 | (define current-pos-x (posn-x (get-component e posn?))) 337 | (define x-vel (* (cos (degrees->radians d)) s)) 338 | (define y-vel (* (sin (degrees->radians d)) s)) 339 | (update-entity e posn? (posn (+ current-pos-x x-vel) 340 | (+ current-pos-y y-vel))))) 341 | (define (move) 342 | (lambda (g e) 343 | (define d (get-direction e)) 344 | (define s (get-ai-speed e)) 345 | (define current-pos-y (posn-y (get-component e posn?))) 346 | (define current-pos-x (posn-x (get-component e posn?))) 347 | (define x-vel (* (cos (degrees->radians d)) s)) 348 | (define y-vel (* (sin (degrees->radians d)) s)) 349 | (update-entity e posn? (posn (+ current-pos-x x-vel) 350 | (+ current-pos-y y-vel))))) 351 | 352 | (define (move-sprite as #:direction [d 0] #:speed [s 0]) 353 | (define current-pos-x (get-x-offset as)) 354 | (define current-pos-y (get-y-offset as)) 355 | (define x-vel (* (cos (degrees->radians d)) s)) 356 | (define y-vel (* (sin (degrees->radians d)) s)) 357 | (~> as 358 | (set-x-offset (+ current-pos-x x-vel) _) 359 | (set-y-offset (+ current-pos-y y-vel) _))) 360 | 361 | (define (spin #:speed s) 362 | (lambda (g e) 363 | (define f (λ(i) (rotate s i))) 364 | (update-entity e animated-sprite? (curry sprite-map f)))) 365 | 366 | (define (move-up-down #:min min #:max max) 367 | (lambda (g e) 368 | (define d (get-direction e)) 369 | (define s (get-ai-speed e)) 370 | (define current-pos-y (posn-y (get-component e posn?))) 371 | (define current-pos-x (posn-x (get-component e posn?))) 372 | (define x-vel (* (cos (degrees->radians d)) s)) 373 | (define y-vel (* (sin (degrees->radians d)) s)) 374 | (update-entity (cond [(>= current-pos-y max) (update-entity e direction? (direction 270))] 375 | [(<= current-pos-y min) (update-entity e direction? (direction 90))] 376 | [else e]) 377 | posn? (posn (+ current-pos-x x-vel) 378 | (+ current-pos-y y-vel))))) 379 | 380 | 381 | (define (move-left-right #:min min #:max max) 382 | (lambda (g e) 383 | (define d (get-direction e)) 384 | (define s (get-ai-speed e)) 385 | (define current-pos-y (posn-y (get-component e posn?))) 386 | (define current-pos-x (posn-x (get-component e posn?))) 387 | (define x-vel (* (cos (degrees->radians d)) s)) 388 | (define y-vel (* (sin (degrees->radians d)) s)) 389 | (update-entity (cond [(>= current-pos-x max) (update-entity e direction? (direction 180))] 390 | [(<= current-pos-x min) (update-entity e direction? (direction 0))] 391 | [else e]) 392 | posn? (posn (+ current-pos-x x-vel) 393 | (+ current-pos-y y-vel))))) 394 | 395 | -------------------------------------------------------------------------------- /collision-helper.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require posn) 3 | 4 | (define (posn-dot posn-a posn-b) 5 | (match-define 6 | (list px py) 7 | (list (- (posn-x posn-b) (posn-x posn-a)) 8 | (- (posn-y posn-b) (posn-y posn-a)))) 9 | (+ (* px px) (* py py))) 10 | 11 | (define (perpendicular-point point-a point-b point-p) 12 | (match-define 13 | (list (posn x1 y1) 14 | (posn x2 y2) 15 | (posn x3 y3)) 16 | (list point-a 17 | point-b 18 | point-p)) 19 | (match-define 20 | (list px py) 21 | (list (- x2 x1) (- y2 y1))) 22 | (define dot-ab (posn-dot point-a point-b)) 23 | (define x-part (* (- x3 x1) px)) 24 | (define y-part (* (- y3 y1) py)) 25 | (define u (/ (+ x-part y-part) dot-ab)) 26 | (define x (+ x1 (* px u))) 27 | (define y (+ y1 (* py u))) 28 | (posn x y)) 29 | 30 | (define (posn-in-rect? lp-p lp-a lp-b) 31 | (and (n-between? (posn-x lp-p) (posn-x lp-a) (posn-x lp-b)) 32 | (n-between? (posn-y lp-p) (posn-y lp-a) (posn-y lp-b)))) 33 | 34 | (define (n-between? n na nb) 35 | (< (n-min na nb) n (n-max na nb))) 36 | 37 | (define (n-max n1 n2) 38 | (if (> n1 n2) n1 n2)) 39 | 40 | (define (n-min n1 n2) 41 | (if (< n1 n2) n1 n2)) 42 | 43 | (define (sqr-mag pos) 44 | (+ (* (posn-x pos) (posn-x pos)) 45 | (* (posn-y pos) (posn-y pos)))) 46 | 47 | (define (mag pos) 48 | (sqrt (sqr-mag pos))) 49 | 50 | (define (posn-diff point-a point-b) 51 | (posn (- (posn-x point-a) (posn-x point-b)) 52 | (- (posn-y point-a) (posn-y point-b)))) 53 | 54 | (define (posn-add point-a point-b) 55 | (posn (+ (posn-x point-a) (posn-x point-b)) 56 | (+ (posn-y point-a) (posn-y point-b)))) 57 | 58 | (define (circle-hits-line? circle-p circle-radius point-a point-b) 59 | (define perp-point (perpendicular-point point-a point-b circle-p)) 60 | (or (> circle-radius (mag (posn-diff circle-p point-a))) 61 | (> circle-radius (mag (posn-diff circle-p point-b))) 62 | (and (posn-in-rect? perp-point point-a point-b) 63 | (< mag (posn-diff circle-p perp-point)) 64 | circle-radius))) 65 | 66 | 67 | (define (circle-hits-rect? circle-p circle-radius point-a point-b point-c point-d) 68 | ;(displayln "circle hits rect?\n") 69 | (or (posn-in-rect? circle-p point-a point-c) 70 | (circle-hits-line? circle-p circle-radius point-a point-b) 71 | (circle-hits-line? circle-p circle-radius point-b point-c) 72 | (circle-hits-line? circle-p circle-radius point-c point-d) 73 | (circle-hits-line? circle-p circle-radius point-d point-a))) 74 | 75 | 76 | (define (rect-hits-rect? r1-p r1-w r1-h r2-p r2-w r2-h) 77 | ;(displayln "rect hits rect?\n") 78 | (match-define (posn e1-x e1-y) r1-p) 79 | (match-define (posn e2-x e2-y) r2-p) 80 | 81 | (define overlap 4) 82 | 83 | (define pad (if (and (<= overlap (/ r1-w 2)) 84 | (<= overlap (/ r1-h 2)) 85 | (<= overlap (/ r2-w 2)) 86 | (<= overlap (/ r2-h 2))) 87 | overlap 88 | 0)) 89 | 90 | (if (and (>= (- e1-x e2-x) (- (- (+ (/ r1-w 2) (/ r2-w 2)) pad))) 91 | (<= (- e1-x e2-x) (- (+ (/ r1-w 2) (/ r2-w 2)) pad)) 92 | (>= (- e1-y e2-y) (- (- (+ (/ r1-h 2) (/ r2-h 2)) pad))) 93 | (<= (- e1-y e2-y) (- (+ (/ r1-h 2) (/ r2-h 2)) pad))) 94 | #t 95 | #f)) 96 | 97 | 98 | (define (circle-hits-circle? circle-p circle-radius circle-p2 circle-radius2) 99 | ;(displayln "circle hits circle?\n") 100 | (define directions (posn-diff circle-p circle-p2)) 101 | (define proximity-max (+ circle-radius circle-radius2)) 102 | (< (sqr-mag directions) (* proximity-max proximity-max))) 103 | 104 | (provide rect-hits-rect? 105 | circle-hits-rect? 106 | circle-hits-circle?) 107 | 108 | ;(circle-hits-line? (posn 0 0) 1 (posn 1 1) (posn 3 1)) 109 | 110 | -------------------------------------------------------------------------------- /component-util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide do-many 4 | loose-component? 5 | component-or-system? 6 | 7 | not-particle-remove? 8 | not-toast-remove? 9 | 10 | not-particle-sprite? 11 | not-toast-sprite?) 12 | 13 | (require "./game-entities.rkt" 14 | "./components/observe-change.rkt" 15 | "./components/storage.rkt") 16 | 17 | (define (do-many . funs) 18 | (lambda (g e) 19 | (foldl (lambda (next accum) 20 | (next g accum)) e funs))) 21 | 22 | ;TODO: Add other simple structs to this list or convert all simple structs 23 | (define loose-component? 24 | (or/c component? #f)) 25 | 26 | (define (component-or-system? c-or-list) 27 | ((or/c loose-component? (listof loose-component?)) (flatten c-or-list))) 28 | 29 | ; COMPONENT PREDICATES 30 | (define (not-particle-sprite? e) 31 | (define particle-storages (map storage-data (get-storages-with-prefix "particle-" e))) 32 | (define particle-sprites (and (not (empty? particle-storages)) 33 | (flatten (map first particle-storages)))) 34 | (define particle-sprite? 35 | (if particle-sprites 36 | (λ (c) (member c particle-sprites component-eq?)) 37 | (λ (c) #f))) 38 | 39 | (if particle-sprites 40 | (not/c particle-sprite?) 41 | (λ (c) #t))) 42 | 43 | (define (not-particle-remove? e) 44 | (define particle-storages (map storage-data (get-storages-with-prefix "particle-" e))) 45 | (define particle-remove-components (and (not (empty? particle-storages)) 46 | (map second particle-storages))) 47 | 48 | (define particle-remove? 49 | (if particle-remove-components 50 | ;(apply or/c (map (curry component-eq?) particle-remove-components)) 51 | (λ (c) (member c particle-remove-components component-eq?)) 52 | (λ (c) #f))) 53 | 54 | (if particle-remove-components 55 | (not/c particle-remove?) 56 | (λ (c) #t))) 57 | 58 | (define (not-toast-sprite? e) 59 | (define toast-storages (map storage-data (get-storages-with-prefix "toast-" e))) 60 | (define toast-sprites (and (not (empty? toast-storages)) 61 | (flatten (list (map first toast-storages) ;main sprites 62 | (map second toast-storages))))) ;shadow sprites 63 | (define toast-sprite? 64 | (if toast-sprites 65 | (λ (c) (member c toast-sprites component-eq?)) 66 | (λ (c) #f))) 67 | 68 | (if toast-sprites 69 | (not/c toast-sprite?) 70 | (λ (c) #t))) 71 | 72 | (define (not-toast-remove? e) 73 | (define toast-storages (map storage-data (get-storages-with-prefix "toast-" e))) 74 | (define toast-remove-components (and (not (empty? toast-storages)) 75 | (map third toast-storages))) 76 | 77 | (define toast-remove? 78 | (if toast-remove-components 79 | ;(apply or/c (map (curry component-eq?) toast-remove-components)) 80 | (λ (c) (member c toast-remove-components component-eq?)) 81 | (λ (c) #f))) 82 | 83 | (if toast-remove-components 84 | (not/c toast-remove?) 85 | (λ (c) #t))) 86 | -------------------------------------------------------------------------------- /components.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | -------------------------------------------------------------------------------- /components/after-time.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | (require posn) 5 | 6 | (provide (rename-out (make-after-time after-time)) 7 | (except-out (struct-out after-time) after-time) 8 | do-after-time 9 | set-after-time-delay 10 | set-after-time-func) 11 | 12 | (component after-time (accum speed func)) 13 | 14 | (define (make-after-time ticks func) 15 | (new-after-time 0 ticks func)) 16 | 17 | (define (inc-after-time a) 18 | (struct-copy after-time a 19 | [accum (add1 (after-time-accum a))])) 20 | 21 | (define (after-time-ready? a) 22 | (>= (after-time-accum a) 23 | (after-time-speed a))) 24 | 25 | (define (set-after-time-delay a delay) 26 | (struct-copy after-time a 27 | [speed delay])) 28 | 29 | (define (set-after-time-func a f) 30 | (struct-copy after-time a 31 | [func f])) 32 | 33 | (define (update-after-time g e c) 34 | (if (after-time-ready? c) 35 | (remove-component ((after-time-func c) g e) (is-component? c)) 36 | (update-entity e (is-component? c) inc-after-time))) 37 | 38 | (new-component after-time? 39 | update-after-time) 40 | 41 | (define (do-after-time time f) 42 | (lambda (g e) 43 | (add-component e (make-after-time time f)))) -------------------------------------------------------------------------------- /components/backpack.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | 4 | 5 | 6 | (require "../game-entities.rkt") 7 | (require "../entity-helpers/sprite-util.rkt") 8 | (require "../entity-helpers/movement-util.rkt") 9 | (require "../entity-helpers/dialog-util.rkt") 10 | (require "../entity-helpers/ui-util.rkt") 11 | (require "../entity-helpers/render-util.rkt") 12 | 13 | (require "./animated-sprite.rkt") 14 | (require "./on-start.rkt") 15 | (require "./sound-stream.rkt") 16 | (require "./on-key.rkt") 17 | (require "./storage.rkt") 18 | (require "./lock-to.rkt") 19 | (require "../component-util.rkt") 20 | 21 | (require 2htdp/image 22 | threading) 23 | 24 | (require posn) 25 | (provide (except-out (struct-out backpack) backpack) 26 | (rename-out (make-backpack backpack)) 27 | ;entity->item ; provided for dev only 28 | ;item->entity ; provided for dev only 29 | get-items 30 | set-items 31 | add-item 32 | remove-item 33 | remove-item-by-name 34 | get-last-item 35 | display-items 36 | store-item 37 | store-nearby-item 38 | (struct-out item) 39 | (except-out (struct-out storable) storable) 40 | (rename-out (new-storable storable)) 41 | stored? 42 | storable-items-nearby? 43 | backpack-not-open? 44 | backpack-not-empty? 45 | backpack-is-empty? 46 | in-backpack? 47 | set-backpack-entities 48 | get-backpack-entities 49 | draw-backpack 50 | update-backpack-sprite 51 | backpack-changed? 52 | update-backpack 53 | draw-backpack-bg 54 | in-game-by-id? 55 | in-backpack-by-id? 56 | ) 57 | 58 | (struct item (entity amount)) 59 | 60 | (component backpack (items)) 61 | 62 | (define/contract (entity->item e) 63 | (-> entity? item?) 64 | (item e 1)) 65 | 66 | (define/contract (item->entity i) 67 | (-> item? entity?) 68 | (item-entity i)) 69 | 70 | (define/contract (make-backpack . entities) 71 | (->* () () #:rest (or/c (listof entity?) empty?) backpack?) 72 | (define new-items (map (lambda (e) (item e 1)) entities)) 73 | (new-backpack new-items)) 74 | 75 | ;(define (update-backpack g e c) e) 76 | 77 | ;(new-component backpack? 78 | ; update-backpack) 79 | 80 | (component storable ()) 81 | 82 | (define (stored? g e) 83 | (define items (map item-entity (get-items (get-entity "player" g)))) 84 | (member e items entity-eq?)) 85 | 86 | (define (update-storable g e c) 87 | (if (stored? g e) 88 | (die g e) 89 | e)) 90 | 91 | (new-component storable? 92 | update-storable) 93 | 94 | (define (set-backpack-entities entity-with-backpack entities-for-backpack) 95 | (update-entity entity-with-backpack 96 | backpack? 97 | (new-backpack (map entity->item entities-for-backpack)))) 98 | 99 | (define (get-backpack-entities e) 100 | (map item-entity (get-items e))) 101 | 102 | (define (get-items e) 103 | (backpack-items (get-component e backpack?))) 104 | 105 | (define (get-last-item e) 106 | (item-entity (last (get-items e)))) 107 | 108 | (define/contract (add-item ent [amount 1]) 109 | (->* (entity?) (number?) procedure?) 110 | (lambda (g e) 111 | (define old-items (get-items e)) 112 | (define new-items (append old-items (list (item ent amount)))) 113 | (update-entity e backpack? (new-backpack new-items)) 114 | )) 115 | 116 | (define (store-item name) 117 | (lambda (g e) 118 | (define item-entity (get-entity name g)) 119 | ((add-item item-entity) g e))) 120 | 121 | (define (maybe-add-physical-collider e) 122 | (if (get-storage "physical-collider" e) 123 | (~> e 124 | (add-components _ (get-storage-data "physical-collider" e)) 125 | (remove-storage "physical-collider" _)) 126 | e)) 127 | 128 | (define (remove-lock-to-player e) 129 | (define (lock-to-player-component? c) 130 | (and (lock-to? c) 131 | (eq? (lock-to-name c) "player"))) 132 | (~> e 133 | (remove-components _ lock-to-player-component?) 134 | (maybe-add-physical-collider _))) 135 | 136 | (define (store-nearby-item [name #f] #:auto-select? [auto-select? #f]) 137 | (lambda (g e) 138 | (define (not-disabled-and-storable? ent) 139 | (and (not (get-component ent disabled?)) 140 | (get-component ent storable?))) 141 | (define (name-eq? name e) 142 | (eq? (get-name e) name)) 143 | (define nearby-ents (if name 144 | (filter (curry name-eq? name) (filter not-disabled-and-storable? (get-entities-near e g))) 145 | (filter not-disabled-and-storable? (get-entities-near e g)) 146 | )) 147 | (displayln (map get-name nearby-ents)) 148 | (if (empty? nearby-ents) 149 | e 150 | (~> e 151 | ((set-storage-named "Selected Weapon" (get-name (first nearby-ents))) g _) 152 | ((add-item (remove-lock-to-player (first nearby-ents))) g _))) 153 | )) 154 | 155 | 156 | 157 | 158 | (define (get-item-name item) 159 | (get-name (item-entity item))) 160 | 161 | (define (item-eq? item1 item2) 162 | (displayln (~a "Item1: " (get-id (item-entity item1)) 163 | " Item2: " (get-id (item-entity item2)))) 164 | (entity-eq? (item-entity item1) 165 | (item-entity item2))) 166 | 167 | (define/contract (remove-item ent [amount 1]) 168 | (->* (entity?) (number?) procedure?) 169 | (lambda (g e) 170 | (define old-items (get-items e)) 171 | (define new-items (remove (item ent amount) old-items item-eq?)) 172 | (update-entity e backpack? (new-backpack new-items)))) 173 | 174 | (define (set-items . items) 175 | (lambda (g e) 176 | (define (enity->item e) 177 | (item e 1)) 178 | (define new-items (map enity->item items)) 179 | (update-entity e backpack? (new-backpack new-items)))) 180 | 181 | (define (display-items) 182 | (lambda (g e) 183 | (displayln (~a (map get-id (map item-entity (get-items e))))) 184 | e)) 185 | 186 | (define (storable-items-nearby? g e) 187 | (define (not-disabled-and-storable? ent) 188 | (and (not (get-component ent disabled?)) 189 | (get-component ent storable?))) 190 | (define nearby-storable-items (filter not-disabled-and-storable? (get-entities-near e g))) 191 | (not (empty? nearby-storable-items))) 192 | 193 | (define (backpack-not-open? g e) 194 | (not (get-entity "backpack" g))) 195 | 196 | (define (backpack-not-empty? g e) 197 | (not (empty? (get-items e)))) 198 | 199 | (define (backpack-is-empty? g e) 200 | (empty? (get-items e))) 201 | 202 | (define (draw-backpack image-list) 203 | (define (scale-and-pad image) (pad (scale-to-fit image 40) 2 2)) 204 | (define scaled-list (map scale-and-pad image-list)) 205 | (define num-of-items (length image-list)) 206 | (define backpack-items (cond [(> num-of-items 1) (apply above scaled-list)] 207 | [(= num-of-items 1) (first scaled-list)] 208 | [(= num-of-items 0) (rectangle 32 32 "solid" "transparent")])) 209 | (overlay backpack-items 210 | (rectangle (+ 0 (image-width backpack-items)) 211 | (+ 0 (image-height backpack-items)) 212 | 'solid 'black) 213 | 214 | #;(rectangle (+ 12 (image-width backpack-items)) (+ 12 (image-height backpack-items)) "outline" (pen "white" 2 "solid" "butt" "bevel")) 215 | #;(rectangle (+ 16 (image-width backpack-items)) (+ 16 (image-height backpack-items)) "solid" (make-color 20 20 20 150)))) 216 | 217 | 218 | (define (draw-backpack-bg n) 219 | (define ITEM-SIZE 40) 220 | 221 | (overlay 222 | (rectangle (+ 12 ITEM-SIZE) (+ 12 (* n ITEM-SIZE)) "outline" (pen "white" 2 "solid" "butt" "bevel")) 223 | (rectangle (+ 16 ITEM-SIZE) (+ 16 (* n ITEM-SIZE)) "solid" (make-color 20 20 20 150)))) 224 | 225 | 226 | (define (update-backpack-sprite g e) 227 | (define IMAGE-HEIGHT 228 | 36) 229 | 230 | ;(define bg-sprite (get-component e animated-sprite?)) 231 | 232 | (define (clone-sprite s) 233 | (struct-copy animated-sprite s)) 234 | 235 | (define (clone-sprites s-list) 236 | (map clone-sprite s-list)) 237 | 238 | ;sprites-list is a list of list of sprites 239 | (define sprite-list (map (compose clone-sprites 240 | (curryr get-components animated-sprite?) 241 | item-entity) 242 | (get-items (get-entity "player" g)))) 243 | (define name-list (map (compose get-name 244 | item-entity) 245 | (get-items (get-entity "player" g)))) 246 | 247 | (define num-items (length sprite-list)) 248 | (define selected-item-index (if (and (get-storage-data "Selected Weapon" (get-entity "player" g)) 249 | (not (eq? (get-storage-data "Selected Weapon" (get-entity "player" g)) "None"))) 250 | (index-of name-list (get-storage-data "Selected Weapon" (get-entity "player" g))) ;returns #f if not found 251 | (sub1 num-items))) 252 | 253 | (define new-height (* IMAGE-HEIGHT num-items)) 254 | 255 | (define offset-sprite-list 256 | (flatten (for/list ([ls sprite-list] 257 | [i (range (length sprite-list))]) 258 | (map (λ (s) 259 | (~> s 260 | (set-y-offset (+ (/ IMAGE-HEIGHT 2) 261 | (- (* i IMAGE-HEIGHT) 262 | (/ new-height 2)) 263 | (get-y-offset s)) _) 264 | (scale-xy (if (> (image-width (draw-sprite (first ls))) 265 | (image-height (draw-sprite (first ls)))) 266 | (/ IMAGE-HEIGHT 267 | (image-width (draw-sprite (first ls)))) 268 | (/ IMAGE-HEIGHT 269 | (image-height (draw-sprite (first ls))))) 270 | _))) 271 | ls) 272 | 273 | ))) 274 | 275 | (define selection-box-offset (if (= num-items 0) 276 | 0 277 | (+ (/ IMAGE-HEIGHT 2) 278 | (- (* (or selected-item-index 0) IMAGE-HEIGHT) 279 | (/ new-height 2))))) 280 | 281 | (define selection-image (square 1 'solid (color 0 255 255 100))) 282 | ;(precompile! selection-image) 283 | 284 | (define selection-box-sprite (new-sprite selection-image 285 | #:x-scale 44 286 | #:y-scale 40 287 | #:y-offset selection-box-offset)) 288 | 289 | (~> e 290 | (remove-components _ animated-sprite?) ; removes all animated-sprites 291 | 292 | ;Adjust the bg size by picking the right animation frame for the background 293 | ;Adjust its offset a tiny bit. 294 | #;(add-component _ (~> bg-sprite 295 | (set-x-scale 44 _) 296 | (set-y-scale new-height _))) 297 | 298 | ;Add in the actual animated sprites of the entities 299 | (add-components _ (reverse (bordered-box-sprite 50 (if (= num-items 0) 300 | 50 301 | (+ new-height 10)))) 302 | selection-box-sprite 303 | offset-sprite-list))) 304 | 305 | (define (in-backpack? name) 306 | (lambda (g e) 307 | (define items (get-items (get-entity "player" g))) 308 | (define entity-list (map item-entity items)) 309 | (define name-list (map get-name entity-list)) 310 | (not (not (member name name-list))))) 311 | 312 | (define/contract (remove-item-by-name name [amount 1]) 313 | (->* (string?) (number?) procedure?) 314 | (lambda (g e) 315 | (define old-items (get-items e)) 316 | (define target-ent (sprite->entity empty-image 317 | #:name name 318 | #:position (posn 0 0))) 319 | (define new-items (remove (entity->item target-ent) old-items item-name-eq?)) 320 | ;(define new-entity-list (map item->entity new-items)) ; warning: loses amount data 321 | ;(update-entity e backpack? (apply backpack new-entity-list)) 322 | (update-entity e backpack? (new-backpack new-items)) 323 | )) 324 | 325 | (define (item-name-eq? item1 item2) 326 | (displayln (~a "Item1: " (get-name (item->entity item1)) 327 | " Item2: " (get-name (item->entity item2)))) 328 | (entity-name-eq? (item->entity item1) 329 | (item->entity item2))) 330 | 331 | (define (backpack-changed? g e) 332 | (length (get-items (get-entity "player" g)))) 333 | 334 | (define (update-backpack g e1 e2) 335 | (if (void? e1) 336 | e2 337 | (begin 338 | (~> e2 339 | (update-backpack-sprite g _) 340 | ((go-to-pos-inside 'top-right) g _))))) 341 | 342 | (define (in-game-by-id? item-id) 343 | (lambda (g e) 344 | (define item-ids (map (curry get-storage-data "item-id") 345 | (filter (curry get-storage "item-id") (game-entities g)))) 346 | (if (member item-id item-ids) #t #f))) 347 | 348 | (define (in-backpack-by-id? item-id) 349 | (lambda (g e) 350 | (define item-ids (map (compose (curry get-storage-data "item-id") 351 | item-entity) 352 | (get-items (get-entity "player" g)))) 353 | (if (member item-id item-ids) #t #f))) 354 | -------------------------------------------------------------------------------- /components/counter.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | (require "./animated-sprite.rkt") 5 | (require 2htdp/image) 6 | 7 | (require posn) 8 | (provide (except-out (struct-out counter) counter) 9 | (rename-out [make-counter counter]) 10 | set-counter 11 | get-counter 12 | change-counter-by 13 | draw-counter 14 | draw-other-counter 15 | random-counter) 16 | 17 | (component counter (count)) 18 | 19 | (define (make-counter c) 20 | (new-counter c)) 21 | 22 | (define (update-counter g e c) e) 23 | 24 | (define (set-counter num) 25 | (lambda (g e) 26 | (update-entity e counter? (struct-copy counter (get-component e counter?) 27 | [count num])))) 28 | 29 | (define (get-counter e) 30 | (counter-count (get-component e counter?))) 31 | 32 | (define (change-counter-by inc) 33 | (lambda (g e) 34 | (define num (get-counter e)) 35 | (update-entity e counter? 36 | (struct-copy counter (get-component e counter?) 37 | [count (+ num inc)]) 38 | ))) 39 | 40 | (define (draw-counter label size color) 41 | (lambda (g e) 42 | (define count (get-counter e)) 43 | (update-entity e animated-sprite? (new-sprite (text (~a label count) size color) 1)))) 44 | 45 | (define (draw-other-counter name label size color) 46 | (lambda (g e) 47 | (define count (get-counter (get-entity name g))) 48 | (update-entity e animated-sprite? (new-sprite (text (~a label count) size color) 1)))) 49 | 50 | (define (random-counter min max) 51 | (lambda (g e) 52 | (update-entity e counter? (new-counter (random min (add1 max)))))) 53 | 54 | (new-component counter? update-counter) 55 | 56 | ; === SIMPLE STRUCTS === 57 | (component hue-val (hue)) 58 | (component size-val (size)) 59 | 60 | ;(define (make-hue-val hue) 61 | ; (new-hue-val hue)) 62 | 63 | ;(define (make-size-val size) 64 | ; (new-hue-val size)) 65 | 66 | (define (set-hue-val num) 67 | (lambda (g e) 68 | (update-entity e hue-val? (new-hue-val num)))) 69 | 70 | (define (get-hue-val e) 71 | (define hue-comp (get-component e hue-val?)) 72 | (if hue-comp 73 | (hue-val-hue hue-comp) 74 | #f)) 75 | 76 | (define (change-hue-val-by inc) 77 | (lambda (g e) 78 | (define num (get-hue-val e)) 79 | (update-entity e hue-val? (new-hue-val (+ num inc))))) 80 | 81 | (define (set-size-val num) 82 | (lambda (g e) 83 | (update-entity e size-val? (new-size-val num)))) 84 | 85 | (define (get-size-val e) 86 | (define size-comp (get-component e size-val?)) 87 | (if size-comp 88 | (size-val-size size-comp) 89 | #f)) 90 | 91 | (define (multiply-size-val-by inc) 92 | (lambda (g e) 93 | (define num (get-size-val e)) 94 | (update-entity e size-val? (new-size-val (* num inc))))) 95 | 96 | (provide (except-out (struct-out hue-val) hue-val) 97 | (except-out (struct-out size-val) size-val) 98 | (rename-out (new-hue-val hue-val)) 99 | (rename-out (new-size-val size-val)) 100 | get-hue-val 101 | change-hue-val-by 102 | set-size-val 103 | get-size-val 104 | multiply-size-val-by) -------------------------------------------------------------------------------- /components/detect-collide.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | (require posn) 5 | 6 | (provide (except-out (struct-out detect-collide) detect-collide) 7 | (rename-out (new-detect-collide detect-collide))) 8 | 9 | (component detect-collide (name1 name2 func)) 10 | 11 | ; is make-detect-collide needed if there are no changes? 12 | ;(define (make-detect-collide name1 name2 func) 13 | ; (new-detect-collide name1 name2 func)) 14 | 15 | (define (update-detect-collide g e c) 16 | (if (is-colliding-by-name? (detect-collide-name1 c) (detect-collide-name2 c) g) 17 | ((detect-collide-func c) g e) 18 | e)) 19 | 20 | (new-component detect-collide? 21 | update-detect-collide) 22 | -------------------------------------------------------------------------------- /components/detect-edge.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | (require posn) 5 | 6 | (provide (except-out (struct-out detect-edge) detect-edge) 7 | (rename-out (new-detect-edge detect-edge))) 8 | 9 | (component detect-edge (name pos func)) 10 | 11 | (define (update-detect-edge g e c) 12 | (define WIDTH (game-width g)) 13 | (define HEIGHT (game-height g)) 14 | (define p (get-component (get-entity (detect-edge-name c) g) posn?)) 15 | (define pos-x (posn-x p)) 16 | (define pos-y (posn-y p)) 17 | (define target-edge (detect-edge-pos c)) 18 | (cond [(eq? target-edge 'left) (if (<= pos-x 0) ((detect-edge-func c) g e) e)] 19 | [(eq? target-edge 'right) (if (>= pos-x WIDTH) ((detect-edge-func c) g e) e)] 20 | [(eq? target-edge 'top) (if (<= pos-y 0) ((detect-edge-func c) g e) e)] 21 | [(eq? target-edge 'bottom) (if (>= pos-y HEIGHT) ((detect-edge-func c) g e) e)])) 22 | 23 | (new-component detect-edge? 24 | update-detect-edge) 25 | -------------------------------------------------------------------------------- /components/dialog.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | (require "./animated-sprite.rkt") 5 | (require 2htdp/image) 6 | 7 | (require posn) 8 | 9 | (provide (except-out (struct-out dialog) dialog) 10 | (rename-out (new-dialog dialog)) 11 | set-dialog-index 12 | get-dialog-index 13 | get-dialog-sprites 14 | ) 15 | 16 | (component dialog (sprites index)) 17 | 18 | (define (update-dialog g e c) e) 19 | 20 | (new-component dialog? 21 | update-dialog) 22 | 23 | 24 | (define (set-dialog-index num) 25 | (lambda (g e) 26 | (update-entity e dialog? (struct-copy dialog (get-component e dialog?) 27 | [index num])))) 28 | 29 | (define (get-dialog-index e) 30 | (dialog-index (get-component e dialog?))) 31 | 32 | (define (get-dialog-sprites e) 33 | (dialog-sprites (get-component e dialog?))) 34 | 35 | #|(define (current-dialog dialog) 36 | (define simple-dialog? (animated-sprite? (first (dialog-sprites dialog)))) 37 | (define player-dialog-index (get-counter (get-entity "player" g))) ;(get-dialog-index (get-entity "player" g))) 38 | (if simple-dialog? 39 | (list-ref (dialog-sprites dialog) ( 40 | |# 41 | -------------------------------------------------------------------------------- /components/direction.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | (require posn) 5 | 6 | (provide (except-out (struct-out direction) direction) 7 | (rename-out [new-direction direction]) 8 | set-direction 9 | get-direction 10 | change-direction-by 11 | change-direction-by-random 12 | random-direction 13 | bounce-back) 14 | 15 | (component direction (dir)) 16 | 17 | ;(define (make-direction c) 18 | ; (new-direction c)) 19 | 20 | (define (update-direction g e c) e) 21 | 22 | (define (set-direction d) 23 | (lambda (g e) 24 | (update-entity e direction? (new-direction (modulo (round d) 360))))) 25 | 26 | (define (get-direction e) 27 | (direction-dir (get-component e direction?))) 28 | 29 | (define (change-direction-by inc) 30 | (lambda (g e) 31 | (define d (get-direction e)) 32 | (update-entity e direction? (new-direction (modulo (round (+ d inc)) 360))))) 33 | 34 | (define (change-direction-by-random min max) 35 | (lambda (g e) 36 | (define d (get-direction e)) 37 | (update-entity e direction? (new-direction (modulo (round (+ d (random min (add1 max)))) 360))))) 38 | 39 | (define (random-direction [min 0] [max 360]) 40 | (lambda (g e) 41 | (update-entity e direction? (new-direction (modulo (random min (add1 max)) 360))))) 42 | 43 | (define (bounce-back) 44 | (lambda (g e) 45 | (define dir (get-direction e)) 46 | (define new-dir (+ dir 180)) 47 | (update-entity e direction? (new-direction (modulo (round new-dir) 360))))) 48 | 49 | (new-component direction? 50 | update-direction) -------------------------------------------------------------------------------- /components/do-every.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | (require posn) 5 | 6 | (provide (rename-out (make-do-every do-every) 7 | 8 | (do-every struct-do-every) 9 | (do-every-rule struct-do-every-rule) 10 | (do-every-func struct-do-every-func) 11 | (do-every-speed struct-do-every-speed) 12 | 13 | ) 14 | (except-out (struct-out do-every) do-every) 15 | set-do-every-speed) 16 | 17 | (component do-every (accum speed rule func)) 18 | 19 | 20 | (define (make-do-every ticks #:rule [rule (lambda (g e) #t)] func) 21 | (new-do-every 0 ticks rule func)) 22 | 23 | (define (reset-do-every a) 24 | (struct-copy do-every a 25 | [accum 0])) 26 | 27 | (define (inc-do-every a) 28 | (struct-copy do-every a 29 | [accum (add1 (do-every-accum a))])) 30 | 31 | (define (do-every-ready? a) 32 | (>= (do-every-accum a) 33 | (do-every-speed a))) 34 | 35 | (define (update-do-every g e c) 36 | (if (and (do-every-ready? c) 37 | ((do-every-rule c) g e)) 38 | (update-entity ((do-every-func c) g e) (is-component? c) reset-do-every) 39 | (update-entity e (is-component? c) inc-do-every))) 40 | 41 | (define (set-do-every-speed c n) 42 | (struct-copy do-every c [speed n])) 43 | 44 | (new-component do-every? 45 | update-do-every) 46 | 47 | -------------------------------------------------------------------------------- /components/every-tick.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | (require posn) 5 | 6 | (provide (rename-out [new-every-tick every-tick]) 7 | (except-out (struct-out every-tick) every-tick)) 8 | 9 | (component every-tick (func)) 10 | 11 | (define (update-every-tick g e c) 12 | ((every-tick-func c) g e)) 13 | 14 | (new-component every-tick? 15 | update-every-tick) -------------------------------------------------------------------------------- /components/follow.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | (require "./direction.rkt") 5 | (require posn) 6 | 7 | (provide (rename-out (make-follow follow)) 8 | (except-out (struct-out follow) follow)) 9 | 10 | ;(provide (struct-out do-every)) 11 | 12 | (component follow (accum name speed)) 13 | 14 | (define (make-follow name [ticks 1]) 15 | (new-follow 0 name ticks)) 16 | 17 | (define (reset-follow a) 18 | (struct-copy follow a 19 | [accum 0])) 20 | 21 | (define (inc-follow a) 22 | (struct-copy follow a 23 | [accum (add1 (follow-accum a))])) 24 | 25 | (define (follow-ready? a) 26 | (>= (follow-accum a) 27 | (follow-speed a))) 28 | 29 | (define (update-follow g e c) 30 | (define target? (get-entity (follow-name c) g)) 31 | (define target-x (unless (eq? target? #f) (posn-x (get-component target? posn?)))) 32 | (define target-y (unless (eq? target? #f) (posn-y (get-component target? posn?)))) 33 | (define x (posn-x (get-component e posn?))) 34 | (define y (posn-y (get-component e posn?))) 35 | (define new-dir (unless (eq? target? #f)(radians->degrees (atan (- target-y y) (- target-x x))))) 36 | (cond 37 | [(and (follow-ready? c) target?) 38 | (update-entity (update-entity e direction? (direction (if (negative? new-dir) 39 | (+ 360 new-dir) 40 | new-dir))) 41 | follow? reset-follow)] 42 | [(and (not (follow-ready? c)) target?) 43 | (update-entity e follow? inc-follow)] 44 | [else e])) 45 | 46 | (new-component follow? 47 | update-follow) 48 | 49 | -------------------------------------------------------------------------------- /components/health.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | (require posn) 5 | 6 | (provide (except-out (struct-out health) health) 7 | (rename-out (new-health health)) 8 | ;get-health 9 | ;set-health 10 | ;change-health-by 11 | ) 12 | 13 | ; This component is obsolete and here for compatibility 14 | ; the new stat system should be used instead 15 | 16 | (component health (amount)) 17 | 18 | (define (update-health g e c) 19 | (if (<= (health-amount c) 0) 20 | (die g e) 21 | e)) 22 | 23 | (new-component health? 24 | update-health) 25 | 26 | #|(define (get-health e) 27 | (health-amount (get-component e health?))) 28 | 29 | ; === HANDLERS === 30 | (define (set-health amt) 31 | (lambda (g e) 32 | (update-entity e health? (new-health amt)))) 33 | 34 | (define (change-health-by amt) 35 | (lambda (g e) 36 | (update-entity e health? (new-health (+ (get-health e) amt)))))|# -------------------------------------------------------------------------------- /components/key-animator.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | (require "./animated-sprite.rkt") 5 | (require posn) 6 | (require threading) 7 | 8 | 9 | (provide (except-out (struct-out key-animator) key-animator) 10 | (rename-out (new-key-animator key-animator))) 11 | 12 | (component key-animator (current animation)) 13 | 14 | (define (update-key-animator g e c) 15 | (define pdir (velocity-from-buttons (game-input g) 16 | 5)) 17 | (define new-dir (cond 18 | [(= 0 (posn-x pdir) (posn-y pdir)) 'none] 19 | [(> (posn-x pdir) 0) 'right] 20 | [(< (posn-x pdir) 0) 'left] 21 | [(< (posn-y pdir) 0) 'up] 22 | [(> (posn-y pdir) 0) 'down])) 23 | 24 | (define current-dir (key-animator-current c)) 25 | (if (equal? new-dir current-dir) 26 | e 27 | (~> e 28 | (update-entity _ key-animator? 29 | (new-key-animator new-dir (key-animator-animation c))) 30 | (update-entity _ animated-sprite? 31 | ((key-animator-animation c) new-dir))))) 32 | 33 | 34 | 35 | (define/contract (velocity-from-buttons btn-states speed) 36 | (-> hash? number? posn?) 37 | (define leftVel (if (button-down? 'left btn-states) (- speed) 0)) 38 | (define rightVel (if (button-down? 'right btn-states) speed 0)) 39 | (define upVel (if (button-down? 'up btn-states) (- speed) 0)) 40 | (define downVel (if (button-down? 'down btn-states) speed 0)) 41 | (posn (+ leftVel rightVel) 42 | (+ upVel downVel))) 43 | 44 | 45 | (new-component key-animator? 46 | update-key-animator) 47 | 48 | 49 | -------------------------------------------------------------------------------- /components/key-movement.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | (require "./after-time.rkt") 5 | (require "../component-util.rkt") 6 | (require posn 7 | threading) 8 | 9 | (provide (except-out (struct-out key-movement) key-movement) 10 | (rename-out (make-key-movement key-movement)) 11 | key-movement? 12 | set-speed-to 13 | change-speed-by 14 | multiply-speed-by 15 | get-speed 16 | (struct-out on-no-key-movement) 17 | (struct-out on-key-movement) 18 | set-player-speed 19 | moving? 20 | player-is-moving? 21 | stop-movement 22 | get-current-velocity 23 | get-key-mode 24 | remove-key-movement 25 | ) 26 | 27 | (component key-movement (speed mode rule?)) 28 | 29 | ;This just puts the units we usually use into units that Chimpmunk physics understands. 30 | (define MAGIC-SPEED-MULTIPLIER 50) 31 | 32 | (define (make-key-movement speed #:mode [mode 'arrow-keys] #:rule [rule? (lambda (g e) #t)]) 33 | (new-key-movement speed mode rule?)) 34 | 35 | (define (update-key-movement g e c) 36 | (define rule? (key-movement-rule? c)) 37 | (if ((key-movement-rule? c) g e) 38 | (set-velocity e 39 | (velocity-from-buttons g 40 | (* MAGIC-SPEED-MULTIPLIER (key-movement-speed c)) 41 | (key-movement-mode c))) 42 | e)) 43 | 44 | (define/contract (velocity-from-buttons game speed mode) 45 | (-> game? number? symbol? posn?) 46 | (define key-list 47 | (cond [(eq? mode 'arrow-keys) (list 'left 'right 'up 'down)] 48 | [(eq? mode 'wasd) (list 'a 'd 'w 's)] 49 | [else (list 'left 'right 'up 'down)])) 50 | (define leftVel (if (button-down? (first key-list) game) (- speed) 0)) 51 | (define rightVel (if (button-down? (second key-list) game) speed 0)) 52 | (define upVel (if (button-down? (third key-list) game) (- speed) 0)) 53 | (define downVel (if (button-down? (fourth key-list) game) speed 0)) 54 | (posn (+ leftVel rightVel) 55 | (+ upVel downVel))) 56 | 57 | ;Not clear either... Move or simplify with better API 58 | 59 | (define (not-after-time-die? c) 60 | (not (eq? (after-time-func c) die))) 61 | 62 | (define (set-speed-to n #:for [d #f]) 63 | (lambda (g e) 64 | (define original (get-component e key-movement?)) 65 | 66 | (define (revert-speed g e) 67 | (update-entity e key-movement? original)) 68 | 69 | (define increase (lambda (k) 70 | (struct-copy key-movement k 71 | [speed n]))) 72 | (define (update-revert dur) 73 | (define old-func (after-time-func (get-component e (and/c after-time? 74 | not-after-time-die? 75 | (not-particle-remove? e) 76 | (not-toast-remove? e) 77 | )))) 78 | (if dur ;if it has a duration, assume it's a stackable power-up type 79 | (λ (c) 80 | (after-time dur (do-many revert-speed 81 | old-func))) 82 | #f)) 83 | 84 | ;if there is an after-time, update it or remove it, else add it or add #f 85 | (if (get-component e (and/c after-time? 86 | not-after-time-die? 87 | (not-particle-remove? e) 88 | (not-toast-remove? e) 89 | )) 90 | (~> e 91 | (update-entity _ key-movement? increase) 92 | (update-entity _ (and/c after-time? 93 | not-after-time-die? 94 | (not-particle-remove? e) 95 | (not-toast-remove? e) 96 | ) (update-revert d))) 97 | (~> e 98 | (update-entity _ key-movement? increase) 99 | (add-components _ (if d (after-time d revert-speed) '()))) 100 | ) 101 | )) 102 | 103 | (define (change-speed-by n #:for [d #f]) 104 | (lambda (g e) 105 | (define original (get-component e key-movement?)) 106 | (define (revert-speed g e) 107 | (update-entity e key-movement? original)) 108 | (define increase (lambda (k) 109 | (struct-copy key-movement k 110 | [speed (+ (key-movement-speed k) n)]))) 111 | (define (update-revert dur) 112 | (define old-func (after-time-func (get-component e (and/c after-time? 113 | not-after-time-die? 114 | (not-particle-remove? e) 115 | (not-toast-remove? e) 116 | )))) 117 | (if dur ;if it has a duration, assume it's a stackable power-up type 118 | (λ (c) 119 | (after-time dur (do-many revert-speed 120 | old-func))) 121 | #f)) 122 | 123 | ;if there is an after-time, update it or remove it, else add it or add #f 124 | (if (get-component e (and/c after-time? 125 | not-after-time-die? 126 | (not-particle-remove? e) 127 | (not-toast-remove? e) 128 | )) 129 | (~> e 130 | (update-entity _ key-movement? increase) 131 | (update-entity _ (and/c after-time? 132 | not-after-time-die? 133 | (not-particle-remove? e) 134 | (not-toast-remove? e) 135 | ) (update-revert d))) 136 | (~> e 137 | (update-entity _ key-movement? increase) 138 | (add-components _ (if d (after-time d revert-speed) '()))) 139 | ) 140 | )) 141 | 142 | (define (multiply-speed-by n #:for [d #f]) 143 | (lambda (g e) 144 | (define original (get-component e key-movement?)) 145 | (define (revert-speed g e) 146 | (update-entity e key-movement? original)) 147 | (define increase (lambda (k) 148 | (struct-copy key-movement k 149 | [speed (* (key-movement-speed k) n)]))) 150 | (define (update-revert dur) 151 | (define old-func (after-time-func (get-component e (and/c after-time? 152 | not-after-time-die? 153 | (not-particle-remove? e) 154 | (not-toast-remove? e) 155 | )))) 156 | (if dur ;if it has a duration, assume it's a stackable power-up type 157 | (λ (c) 158 | (after-time dur (do-many revert-speed 159 | old-func))) 160 | #f)) 161 | 162 | ;if there is an after-time, update it or remove it, else add it or add #f 163 | (if (get-component e (and/c after-time? 164 | not-after-time-die? 165 | (not-particle-remove? e) 166 | (not-toast-remove? e) 167 | )) 168 | (~> e 169 | (update-entity _ key-movement? increase) 170 | (update-entity _ (and/c after-time? 171 | not-after-time-die? 172 | (not-particle-remove? e) 173 | (not-toast-remove? e) 174 | ) (update-revert d))) 175 | (~> e 176 | (update-entity _ key-movement? increase) 177 | (add-components _ (if d (after-time d revert-speed) '()))) 178 | ) 179 | )) 180 | 181 | (define (get-speed e) 182 | (key-movement-speed (get-component e key-movement?))) 183 | 184 | (define (get-key-mode e) 185 | (key-movement-mode (get-component e key-movement?))) 186 | 187 | (define (get-current-velocity g e) 188 | (velocity-from-buttons g (get-speed e) (get-key-mode e))) 189 | 190 | 191 | (new-component key-movement? 192 | update-key-movement) 193 | 194 | 195 | (struct on-no-key-movement (f)) 196 | 197 | (define (update-on-stopped g e c) 198 | (define v (get-current-velocity g e)) 199 | (if (equal? (posn 0 0) v) 200 | ((on-no-key-movement-f c) g e) 201 | e)) 202 | 203 | (new-component on-no-key-movement? 204 | update-on-stopped) 205 | 206 | 207 | (struct on-key-movement (f)) 208 | 209 | (define (update-on-moved g e c) 210 | (define v (get-current-velocity g e)) 211 | (if (equal? (posn 0 0) v) 212 | e 213 | ((on-key-movement-f c) g e))) 214 | 215 | (new-component on-key-movement? 216 | update-on-moved) 217 | 218 | (define (set-player-speed n) 219 | (lambda (g e) 220 | (update-entity e key-movement? (new-key-movement n)))) 221 | 222 | (define (stop-movement) 223 | (lambda (g e) 224 | (set-velocity e (posn 0 0)))) 225 | 226 | (define (moving? g e) 227 | (define vel (get-current-velocity g e)) 228 | (not (equal? vel (posn 0 0)))) 229 | 230 | (define (player-is-moving? g e) 231 | (define vel (get-current-velocity g (get-entity "player" g))) 232 | (not (equal? vel (posn 0 0)))) 233 | 234 | (define (remove-key-movement g e) 235 | (remove-component e key-movement?)) -------------------------------------------------------------------------------- /components/lock-to.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | (require posn) 5 | 6 | (provide (except-out (struct-out lock-to) lock-to) 7 | (rename-out (make-lock-to lock-to)) 8 | ;lock-to-name 9 | ;lock-to? 10 | other-entity-locked-to?) 11 | 12 | (component lock-to (name offset)) 13 | 14 | (define (make-lock-to name #:offset [offset (posn 0 0)]) 15 | ;(displayln (~a "LOCKING TO: " name)) 16 | (new-lock-to name offset)) 17 | 18 | (define (update-lock-to g e c) 19 | (define target-e 20 | (cond [(string? (lock-to-name c)) (get-entity (lock-to-name c) g)] 21 | [(procedure? (lock-to-name c)) ((lock-to-name c) g)] 22 | [else (error "What is this?")])) 23 | 24 | (define target-pos (if target-e 25 | (get-component target-e posn?) 26 | (posn 0 0))) 27 | (define offset-pos (lock-to-offset c)) 28 | (define new-posn (posn (+ (posn-x target-pos) (posn-x offset-pos)) 29 | (+ (posn-y target-pos) (posn-y offset-pos)))) 30 | (if target-e 31 | (update-entity e posn? new-posn) 32 | e)) 33 | 34 | (new-component lock-to? 35 | update-lock-to) 36 | 37 | (define (other-entity-locked-to? s #:filter [f identity]) 38 | (λ(g e) 39 | (define other-lock-tos 40 | (filter identity 41 | (map (λ(e) (get-component e lock-to?)) 42 | (filter f (game-entities g))))) 43 | 44 | (member s (map lock-to-name other-lock-tos)) )) 45 | -------------------------------------------------------------------------------- /components/observe-change.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (except-out (struct-out observe-change) observe-change) 4 | (rename-out [make-observe-change observe-change]) 5 | if/r) 6 | 7 | (require "../game-entities.rkt" 8 | ;"../component-util.rkt" 9 | posn) 10 | 11 | (component observe-change (rule last-val previous-entity on-change)) ;DON'T MAKE THIS TRANSPARENT FOR SOME REASON 12 | 13 | 14 | 15 | (define (make-observe-change rule on-change) 16 | (new-observe-change rule (void) (void) on-change)) 17 | 18 | 19 | #;(observe-change carried? 20 | (λ(g e) 21 | (if (carried? e) 22 | (displayln "Picked up") 23 | (displayln "Dropped")) 24 | e)) 25 | 26 | (define (update-observe-change g e c) 27 | (define current-val ((observe-change-rule c) g e)) 28 | 29 | (define last-val (observe-change-last-val c)) 30 | 31 | (define new-c (struct-copy observe-change c 32 | [last-val current-val] 33 | [previous-entity e])) 34 | 35 | (define new-e (update-entity e (λ(x) (eq? x c)) new-c)) 36 | (define prev-e (observe-change-previous-entity c)) 37 | 38 | (if (eq? current-val last-val) 39 | new-e 40 | ((observe-change-on-change c) g prev-e new-e))) 41 | 42 | (new-component observe-change? 43 | update-observe-change) 44 | 45 | 46 | (define (if/r rule do-func [else-func (λ (g e) e)]) 47 | (lambda (g e1 e2) 48 | (if (void? e1) 49 | e2 50 | (if (rule g e2) 51 | (do-func g e2) 52 | (else-func g e2))))) 53 | 54 | 55 | -------------------------------------------------------------------------------- /components/on-edge.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | (require posn) 5 | 6 | ;(provide (struct-out on-edge)) 7 | 8 | (provide (except-out (struct-out on-edge) on-edge) 9 | (rename-out (make-on-edge on-edge))) 10 | 11 | (component on-edge (pos offset rule? func)) 12 | 13 | (define (make-on-edge pos #:rule [rule? (lambda (g e) #t)] #:offset [offset 0] func) 14 | (new-on-edge pos offset rule? func)) 15 | 16 | (define (update-on-edge g e c) 17 | (define WIDTH (game-width g)) 18 | (define HEIGHT (game-height g)) 19 | (define p (get-component e posn?)) 20 | (define pos-x (posn-x p)) 21 | (define pos-y (posn-y p)) 22 | (define target-edge (on-edge-pos c)) 23 | (define offset (on-edge-offset c)) 24 | (if ((on-edge-rule? c) g e) 25 | (cond [(eq? target-edge 'left) (if (<= pos-x (+ offset 0)) ((on-edge-func c) g e) e)] 26 | [(eq? target-edge 'right) (if (>= pos-x (+ offset WIDTH)) ((on-edge-func c) g e) e)] 27 | [(eq? target-edge 'top) (if (<= pos-y (+ offset 0)) ((on-edge-func c) g e) e)] 28 | [(eq? target-edge 'bottom) (if (>= pos-y (+ offset HEIGHT)) ((on-edge-func c) g e) e)]) 29 | e)) 30 | 31 | (new-component on-edge? 32 | update-on-edge) 33 | -------------------------------------------------------------------------------- /components/on-key.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | 5 | 6 | (provide (except-out (struct-out on-key) on-key) 7 | (rename-out (make-on-key on-key) 8 | (on-key struct-on-key) 9 | (on-key-rule struct-on-key-rule) 10 | (on-key-f struct-on-key-f) 11 | )) 12 | 13 | (component on-key (key rule f)) 14 | 15 | (define (make-on-key key #:rule [rule (lambda (g e) #t)] f) 16 | (new-on-key key rule f)) 17 | 18 | (define (update-on-key g e c) 19 | (if (and (button-change-down? (on-key-key c) g) 20 | ((on-key-rule c) g e)) 21 | ((on-key-f c) g e) 22 | e)) 23 | 24 | (new-component on-key? 25 | update-on-key) -------------------------------------------------------------------------------- /components/on-mouse.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | 5 | 6 | (provide (except-out (struct-out on-mouse) on-mouse) 7 | (rename-out (make-on-mouse on-mouse)) 8 | (except-out (struct-out on-mouse-hold) on-mouse-hold) 9 | (rename-out (make-on-mouse-hold on-mouse-hold)) 10 | (rename-out (on-mouse struct-on-mouse) 11 | (on-mouse-rule struct-on-mouse-rule) 12 | (on-mouse-f struct-on-mouse-f)) 13 | get-on-mouse-button) 14 | 15 | (component on-mouse (button rule f)) 16 | 17 | (define (make-on-mouse button #:rule [rule (lambda (g e) #t)] f) 18 | (new-on-mouse button rule f)) 19 | 20 | (define (update-on-mouse g e c) 21 | (if (and (mouse-button-change-down? (on-mouse-button c) g) 22 | ((on-mouse-rule c) g e)) 23 | ((on-mouse-f c) g e) 24 | e)) 25 | 26 | (new-component on-mouse? 27 | update-on-mouse) 28 | 29 | ; ==== on-mouse-hold ==== 30 | (component on-mouse-hold (button rule f)) 31 | 32 | (define (make-on-mouse-hold button #:rule [rule (lambda (g e) #t)] f) 33 | (new-on-mouse-hold button rule f)) 34 | 35 | (define (update-on-mouse-hold g e c) 36 | (if (and (mouse-button-down? (on-mouse-hold-button c) g) 37 | ((on-mouse-hold-rule c) g e)) 38 | ((on-mouse-hold-f c) g e) 39 | e)) 40 | 41 | (new-component on-mouse-hold? 42 | update-on-mouse-hold) 43 | 44 | (define (get-on-mouse-button e) 45 | (on-mouse-button (get-component e on-mouse?))) -------------------------------------------------------------------------------- /components/on-rule.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | 5 | (provide (except-out (struct-out on-rule) on-rule) 6 | (rename-out (new-on-rule on-rule)) 7 | remove-rule) 8 | 9 | (component on-rule (rule? func)) 10 | 11 | (define (update-on-rule g e c) 12 | (if ((on-rule-rule? c) g e) 13 | ((on-rule-func c) g e) 14 | e)) 15 | 16 | (define (remove-rule) 17 | (lambda (g e) 18 | (remove-component e on-rule?))) 19 | 20 | (new-component on-rule? 21 | update-on-rule) 22 | -------------------------------------------------------------------------------- /components/on-start.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | ;(require "../components/after-time.rkt") 5 | (require posn) 6 | 7 | ;(displayln "LOADING ON START") 8 | 9 | (provide (except-out (struct-out on-start) on-start) 10 | (rename-out (make-on-start on-start))) 11 | 12 | (component on-start (rule func)) 13 | 14 | (define (make-on-start #:rule [rule (λ (g e) #t)] func) 15 | (new-on-start rule func)) 16 | 17 | (define (update-on-start g e c) 18 | ;(displayln (list "UPDATING ON START" e)) 19 | (define updated-ent (if ((on-start-rule c) g e) 20 | ((on-start-func c) g e) 21 | e)) 22 | (remove-component 23 | updated-ent (is-component? c))) 24 | 25 | (new-component on-start? 26 | update-on-start) -------------------------------------------------------------------------------- /components/rotation-style.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | (require "./direction.rkt") 5 | (require "./animated-sprite.rkt") 6 | (require posn) 7 | (require 2htdp/image) 8 | (require threading) 9 | 10 | (provide (except-out (struct-out rotation-style) rotation-style) 11 | (rename-out (new-rotation-style rotation-style)) 12 | set-rotation-style 13 | horizontal-flip-sprite 14 | vertical-flip-sprite) 15 | 16 | (component rotation-style (mode)) 17 | 18 | (define (switch-animations-if-necessary c e) 19 | (define mode (rotation-style-mode c)) 20 | (define dir (get-direction e)) 21 | (define old-x-scale (get-x-scale (get-component e animated-sprite?))) 22 | ;(define x-scale (abs (get-x-scale (get-component e animated-sprite?)))) 23 | (define e-with-new-animation 24 | (cond 25 | [(eq? mode 'left-right) 26 | (cond 27 | [(and (< dir 270) (> dir 90) (positive? old-x-scale)) 28 | (update-entity e animated-sprite? 29 | (curry set-x-scale (- (abs old-x-scale)))) 30 | ] 31 | [(and (or (> dir 270) (< dir 90)) (negative? old-x-scale)) 32 | (update-entity e animated-sprite? 33 | (curry set-x-scale (abs old-x-scale))) 34 | ] 35 | [else e])] 36 | [(and (eq? mode 'face-direction) (not (= dir (get-rotation (get-component e animated-sprite?))))) 37 | (update-entity e animated-sprite? 38 | (curry set-angle dir)) 39 | ] 40 | [else e])) 41 | 42 | ;(update-entity e-with-new-animation rotation-style? c) 43 | e-with-new-animation 44 | ) 45 | 46 | (define (update-rotation-style g e c) 47 | (switch-animations-if-necessary c e)) 48 | 49 | (new-component rotation-style? 50 | update-rotation-style) 51 | 52 | (define (get-rotation-style e) 53 | (rotation-style-mode (get-component e rotation-style?))) 54 | 55 | 56 | ; ==== HANDLERS ==== 57 | (define (set-rotation-style mode) 58 | (lambda (g e) 59 | ;(displayln (~a "Current rotation-style: " (get-rotation-style e))) 60 | ;(displayln (~a "Attempt rotation-style change: " mode)) 61 | (update-entity e rotation-style? (new-rotation-style mode)))) 62 | 63 | (define (horizontal-flip-sprite) 64 | (lambda (g e) 65 | (define x-scale (get-x-scale (get-component e animated-sprite?))) 66 | (update-entity e animated-sprite? 67 | (curry set-x-scale (- x-scale))))) 68 | 69 | (define (vertical-flip-sprite) 70 | (lambda (g e) 71 | (define y-scale (get-y-scale (get-component e animated-sprite?))) 72 | (update-entity e animated-sprite? 73 | (curry set-y-scale (- y-scale))))) -------------------------------------------------------------------------------- /components/sound-stream.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | 5 | (require "../engine/extensions/sound.rkt") 6 | 7 | (provide (except-out (struct-out sound-stream) sound-stream) 8 | (rename-out (construct-sound-stream sound-stream)) 9 | (rename-out ( sound make-sound)) 10 | set-sound-stream 11 | get-sound-stream 12 | play-sound 13 | play-sound-from 14 | stop-all-sounds 15 | stop-sound-streams 16 | rsound?) 17 | 18 | 19 | (component sound-stream (ps)) 20 | 21 | (define (update-sound-stream g e c) e) 22 | 23 | (define (construct-sound-stream) 24 | (with-handlers ([exn:fail? (thunk* (displayln "Error creating sound stream"))]) 25 | (new-sound-stream 26 | (make-sound-stream)))) 27 | 28 | (define (set-sound-stream ps) 29 | (lambda (g e) 30 | (update-entity e sound-stream? (new-sound-stream ps)))) 31 | 32 | (define (get-sound-stream e) 33 | (sound-stream-ps (get-component e sound-stream?))) 34 | 35 | (define (play-sound rs) 36 | (with-handlers ([exn:fail? (thunk* (displayln "Error while playing sound"))]) 37 | (lambda (g e) 38 | (if (and (sound? rs) 39 | (get-component e sound-stream?)) 40 | (begin 41 | (play (get-sound-stream e) rs) 42 | e) 43 | (begin 44 | ;(displayln "WARNING: Missing sound-stream component. Sound will not play.") 45 | e) 46 | )))) 47 | 48 | (define (play-sound-from entity-name rs) 49 | (lambda (g e) 50 | (define source-e (get-entity entity-name g)) 51 | ((play-sound rs) g source-e) 52 | e)) 53 | 54 | (define (stop-all-sounds) 55 | (lambda (g e) 56 | (stop-sound-streams) 57 | e)) 58 | 59 | (define (stop-sound-streams) 60 | ;'() 61 | (stop-sound-streams) 62 | 63 | ) 64 | 65 | (new-component sound-stream? 66 | update-sound-stream) 67 | -------------------------------------------------------------------------------- /components/spawn-dialog.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | ;(require "../components/after-time.rkt") 5 | (require "./direction.rkt") 6 | (require "./rotation-style.rkt") 7 | (require "./spawn-once.rkt") 8 | (require posn) 9 | 10 | ;(displayln "LOADING ON START") 11 | 12 | (provide spawn-dialog) 13 | 14 | (define (spawn-dialog e) 15 | (spawn-once e #:relative? #f)) -------------------------------------------------------------------------------- /components/spawn-once.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | ;(require "../components/after-time.rkt") 5 | (require "./direction.rkt") 6 | (require "./rotation-style.rkt") 7 | (require "./animated-sprite.rkt") 8 | (require posn 9 | threading) 10 | 11 | ;(displayln "LOADING ON START") 12 | 13 | (provide spawn-many-from 14 | spawn-once-inc 15 | update-what-will-spawn 16 | spawn-once-ready? 17 | spawn-once-almost-ready? 18 | (except-out (struct-out spawn-once) spawn-once) 19 | (rename-out [make-spawn-once spawn-once])) 20 | 21 | (component spawn-once (spawn speed accum next relative?)) 22 | 23 | (define (make-spawn-once spawn #:relative? [relative? #t]) 24 | (new-spawn-once spawn 1 0 #f relative?)) 25 | 26 | (define (update-what-will-spawn so f) 27 | (struct-copy spawn-once so 28 | [spawn (f (spawn-once-spawn so))])) 29 | 30 | (define (spawn-once-ready? s) 31 | (>= (spawn-once-accum s) 32 | (spawn-once-speed s))) 33 | 34 | (define (spawn-once-almost-ready? s) 35 | (= (spawn-once-accum s) 36 | (sub1 (spawn-once-speed s)))) 37 | 38 | (define (spawn-once-reset s) 39 | (struct-copy spawn-once s 40 | [accum 0] 41 | [next #f])) 42 | 43 | (define (next-spawn s) 44 | (define s2 (spawn-once-spawn s)) 45 | (if (procedure? s2) 46 | (s2) 47 | s2)) 48 | 49 | (define (spawn-once-do-spawn e) 50 | (lambda (s) 51 | 52 | (define to-spawn (next-spawn s)) 53 | (define relative? (spawn-once-relative? s #;(get-component e spawn-once?))) 54 | ;(displayln (~a "Spawning from: " (get-name e) ", Relative: " relative?)) 55 | (define pos (get-component e posn?)) 56 | (define dir (if (get-component e direction?) 57 | (get-direction e) 58 | #f)) 59 | (define offset (get-component to-spawn posn?)) 60 | (define rot-offset (unless (eq? dir #f) 61 | (posn-rotate-origin-ccw (modulo (exact-round dir) 360) offset))) 62 | (define rs? (get-component e rotation-style?)) 63 | (define m (if rs? 64 | (rotation-style-mode rs?) 65 | #f)) 66 | 67 | 68 | (define facing-right? 69 | (if (eq? m 'left-right) 70 | (positive? (animated-sprite-x-scale (get-component e animated-sprite?))) 71 | #t)) 72 | 73 | 74 | (define new-posn (cond 75 | [(and (eq? m 'left-right) (eq? facing-right? #t)) (posn (+ (posn-x pos) (posn-x offset)) 76 | (+ (posn-y pos) (posn-y offset)))] 77 | [(and (eq? m 'left-right) (eq? facing-right? #f)) (posn (- (posn-x pos) (posn-x offset)) 78 | (+ (posn-y pos) (posn-y offset)))] 79 | [(eq? m 'face-direction) (posn (+ (posn-x pos) (posn-x rot-offset)) 80 | (+ (posn-y pos) (posn-y rot-offset)))] 81 | [else (posn (+ (posn-x pos) (posn-x offset)) 82 | (+ (posn-y pos) (posn-y offset)))])) 83 | 84 | (define new-entity (if (and (get-component to-spawn direction?) 85 | (get-component e direction?)) 86 | (~> to-spawn 87 | (update-entity _ posn? new-posn) 88 | (update-entity _ direction? (direction dir))) 89 | (update-entity to-spawn posn? 90 | new-posn))) 91 | 92 | (if relative? 93 | (struct-copy spawn-once s 94 | [next new-entity]) 95 | (struct-copy spawn-once s 96 | [next to-spawn])))) 97 | 98 | (define (spawn-once-inc s) 99 | (struct-copy spawn-once s 100 | [accum (add1 (spawn-once-accum s))])) 101 | 102 | (define (update-spawn-once g e c) 103 | (define new-c (spawn-once-inc c)) 104 | (if (spawn-once-ready? new-c) 105 | (update-entity e 106 | (component-is? c) 107 | ((spawn-once-do-spawn e) new-c)) 108 | e)) 109 | 110 | (define/contract (collect-spawn-once es) 111 | (-> (listof entity?) (listof entity?)) 112 | (define spawn-onces (flatten (map (curryr get-components spawn-once?) es))) ;get-components? 113 | (filter identity (map spawn-once-next spawn-onces))) 114 | 115 | (define (reset-spawn-once es) 116 | (map (λ(x) 117 | (define s (get-component x spawn-once?)) 118 | (if (and s (spawn-once-ready? s)) 119 | (remove-component x (and/c 120 | ;(component-is? s) 121 | spawn-once? 122 | spawn-once-ready?)) 123 | x)) 124 | es)) 125 | 126 | (define (handle-spawn-once g) 127 | (define es (game-entities g)) 128 | (define new-es (collect-spawn-once es)) 129 | 130 | #;(and (not (empty? new-es)) 131 | (displayln (~a "Spawning: " (map get-name new-es)))) 132 | 133 | (define all (append #;new-es 134 | (map (curry uniqify-id g) new-es) 135 | (reset-spawn-once es))) 136 | 137 | (struct-copy game g 138 | [entities all])) 139 | 140 | 141 | (define (spawn-many-from source to-spawn #:relative (r #t)) 142 | (add-components source (map (curry make-spawn-once #:relative? r) to-spawn))) 143 | 144 | 145 | (new-component spawn-once? 146 | update-spawn-once) 147 | 148 | (new-game-function handle-spawn-once) 149 | 150 | 151 | 152 | -------------------------------------------------------------------------------- /components/speed.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | (require posn) 5 | 6 | (provide (except-out (struct-out speed) speed) 7 | (rename-out [new-speed speed]) 8 | set-speed 9 | get-ai-speed 10 | change-ai-speed-by 11 | random-speed) 12 | 13 | (component speed (spd)) 14 | 15 | (define (update-speed g e c) e) 16 | 17 | (define (set-speed d) 18 | (lambda (g e) 19 | (update-entity e speed? (struct-copy speed 20 | (get-component e speed?) 21 | [spd d])))) 22 | 23 | (define (get-ai-speed e) 24 | (speed-spd (get-component e speed?))) 25 | 26 | (define (change-ai-speed-by inc) 27 | (lambda (g e) 28 | (define s (get-ai-speed e)) 29 | (update-entity e speed? (new-speed (+ s inc))))) 30 | 31 | (define (random-speed min max) 32 | (lambda (g e) 33 | (define new-min (exact-round (* min 100))) 34 | (define new-max (exact-round (* max 100))) 35 | (update-entity e speed? (new-speed (/ (random new-min (add1 new-max)) 100))))) 36 | 37 | (new-component speed? 38 | update-speed) -------------------------------------------------------------------------------- /components/stop-on-edge.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | (require "../entity-helpers/movement-util.rkt") 5 | (require posn) 6 | 7 | ;(provide (struct-out stop-on-edge)) 8 | (provide (except-out (struct-out stop-on-edge) stop-on-edge) 9 | (rename-out (make-stop-on-edge stop-on-edge))) 10 | 11 | (component stop-on-edge (left right top bottom)) 12 | 13 | (define (make-stop-on-edge . args) 14 | ;(define sorted-args (sort (map symbol->string args) stringsymbol sorted-args) 16 | 17 | (define edges (hash 'bottom #f 'top #f 'left #f 'right #f )) 18 | 19 | (if (empty? args) 20 | (set! edges (hash 'bottom #t 'top #t 'left #t 'right #t )) 21 | (begin (set! edges (if (member 'left args ) 22 | (hash-set edges 'left #t) 23 | (hash-set edges 'left #f))) 24 | 25 | (set! edges (if (member 'right args ) 26 | (hash-set edges 'right #t) 27 | (hash-set edges 'right #f))) 28 | 29 | (set! edges (if (member 'top args ) 30 | (hash-set edges 'top #t) 31 | (hash-set edges 'top #f))) 32 | 33 | (set! edges (if (member 'bottom args ) 34 | (hash-set edges 'bottom #t) 35 | (hash-set edges 'bottom #f))))) 36 | 37 | (new-stop-on-edge (hash-ref edges 'left) 38 | (hash-ref edges 'right) 39 | (hash-ref edges 'top) 40 | (hash-ref edges 'bottom)) 41 | ) 42 | 43 | (define (update-stop-on-edge g e c) 44 | (define WIDTH (game-width g)) 45 | (define HEIGHT (game-height g)) 46 | (define p (get-component e posn?)) 47 | (define pos-x (posn-x p)) 48 | (define pos-y (posn-y p)) 49 | (define left? (stop-on-edge-left c)) 50 | (define right? (stop-on-edge-right c)) 51 | (define top? (stop-on-edge-top c)) 52 | (define bottom? (stop-on-edge-bottom c)) 53 | (cond [(and left? (< pos-x 0)) (update-entity e posn? (posn 0 pos-y))] 54 | [(and right? (> pos-x WIDTH)) (update-entity e posn? (posn WIDTH pos-y))] 55 | [(and top? (< pos-y 0)) (update-entity e posn? (posn pos-x 0))] 56 | [(and bottom? (> pos-y HEIGHT)) (update-entity e posn? (posn pos-x HEIGHT))] 57 | [else e])) 58 | 59 | (new-component stop-on-edge? 60 | update-stop-on-edge) 61 | -------------------------------------------------------------------------------- /components/storage.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (except-out (struct-out storage) storage) 4 | (rename-out [new-storage storage]) 5 | 6 | get-storage 7 | get-storage-data 8 | 9 | get-storages-with-prefix 10 | 11 | set-storage 12 | set-storage-named 13 | 14 | remove-storage 15 | remove-storage-named 16 | 17 | entity-with-storage) 18 | 19 | (require "../game-entities.rkt") 20 | 21 | 22 | (component storage (name data)) 23 | 24 | (define (storage-with-name? n) 25 | (lambda (s) 26 | (and (storage? s) 27 | (string=? n (storage-name s))))) 28 | 29 | (define (storage-with-name-prefix? n) 30 | (lambda (s) 31 | (and (storage? s) 32 | (string-prefix? (storage-name s) n)))) 33 | 34 | (define (get-storage name e) 35 | (and e 36 | (get-component e (storage-with-name? name) ))) 37 | 38 | (define (get-storages-with-prefix prefix e) 39 | (and e 40 | (get-components e (storage-with-name-prefix? prefix)))) 41 | 42 | (define (set-storage name e v) 43 | (update-entity e 44 | (storage-with-name? name) 45 | (new-storage name v))) 46 | 47 | (define (remove-storage name e) 48 | (remove-component e (storage-with-name? name))) 49 | 50 | (define (get-storage-data name e) 51 | (if (get-storage name e) 52 | (storage-data 53 | (get-storage name e)) 54 | #f)) 55 | 56 | 57 | (define (entity-with-storage key val g) 58 | (findf 59 | (λ(e) 60 | (and 61 | (get-storage key e) 62 | (equal? val (get-storage-data key e)))) 63 | (game-entities g))) 64 | 65 | 66 | ; ==== λ (g e) HANDLERS ==== 67 | (define (set-storage-named key-name data) 68 | (lambda (g e) 69 | (set-storage key-name e data))) 70 | 71 | (define (remove-storage-named name) 72 | (lambda (g e) 73 | (remove-storage name e))) -------------------------------------------------------------------------------- /components/wrap-around.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt") 4 | (require "../entity-helpers/movement-util.rkt") 5 | (require posn) 6 | 7 | (provide (except-out (struct-out wrap-around) wrap-around) 8 | (rename-out (make-wrap-around wrap-around))) 9 | 10 | (component wrap-around (mode)) 11 | 12 | (define (make-wrap-around [mode 'all-edges]) 13 | (new-wrap-around mode)) 14 | 15 | (define (update-wrap-around g e c) 16 | (define WIDTH (game-width g)) 17 | (define HEIGHT (game-height g)) 18 | (define p (get-component e posn?)) 19 | (define pos-x (posn-x p)) 20 | (define pos-y (posn-y p)) 21 | (define mode (wrap-around-mode c)) 22 | (cond [(eq? mode 'all-edges) 23 | (cond [(< pos-x 0) (update-entity e posn? (posn WIDTH pos-y))] 24 | [(> pos-x WIDTH) (update-entity e posn? (posn 0 pos-y))] 25 | [(< pos-y 0) (update-entity e posn? (posn pos-x HEIGHT))] 26 | [(> pos-y HEIGHT) (update-entity e posn? (posn pos-x 0))] 27 | [else e])] 28 | [(eq? mode 'left-right) 29 | (cond [(< pos-x 0) (update-entity e posn? (posn WIDTH pos-y))] 30 | [(> pos-x WIDTH) (update-entity e posn? (posn 0 pos-y))] 31 | [else e])] 32 | [(eq? mode 'top-bottom) 33 | (cond [(< pos-y 0) (update-entity e posn? (posn pos-x HEIGHT))] 34 | [(> pos-y HEIGHT) (update-entity e posn? (posn pos-x 0))] 35 | [else e])])) 36 | 37 | (new-component wrap-around? 38 | update-wrap-around) 39 | -------------------------------------------------------------------------------- /engine/component-struct.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (struct-out component-struct)) 4 | 5 | (struct component-struct (cid)) -------------------------------------------------------------------------------- /engine/core/scribblings/.core.scrbl.swp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thoughtstem/game-engine/98c4b9e9b8c071818e564ef7efb55465cff487a8/engine/core/scribblings/.core.scrbl.swp -------------------------------------------------------------------------------- /engine/extensions/sound.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;For real rsound, put this in 4 | ;(provide (all-from-out "./sound/rsound.rkt")) 5 | ;(require "./sound/rsound.rkt") 6 | 7 | ;For fake rsound (i.e. no sound), use this: 8 | (displayln "Using fake sound") 9 | (provide (all-from-out "./sound/fake-rsound.rkt")) 10 | (require "./sound/fake-rsound.rkt") 11 | 12 | -------------------------------------------------------------------------------- /engine/extensions/sound/fake-rsound.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide sound? 4 | rsound? 5 | sound 6 | make-sound-stream 7 | play 8 | stop-sound-streams) 9 | 10 | (define (sound? s) 11 | #t) 12 | 13 | (define rsound? sound?) 14 | 15 | (define (sound path-to-sound) 16 | #t) 17 | 18 | (define (make-sound-stream) 19 | #t) 20 | 21 | (define (play stream sound) 22 | (display (~a "Not playing sound: " sound)) 23 | #t) 24 | 25 | (define (stop-sound-streams) 26 | #t) 27 | -------------------------------------------------------------------------------- /engine/extensions/sound/rsound.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #; 4 | ( 5 | 6 | 7 | (provide sound? 8 | rsound? 9 | sound 10 | make-sound-stream 11 | play 12 | stop-sound-streams) 13 | 14 | (require (prefix-in r: rsound)) 15 | 16 | (r:default-sample-rate 48000) 17 | 18 | 19 | (define (sound? s) 20 | (r:rsound? s)) 21 | 22 | (define rsound? sound?) 23 | 24 | (define (sound path-to-sound) 25 | (r:resample-to-rate 48000 (r:rs-read path-to-sound))) 26 | 27 | (define (make-sound-stream) 28 | (r:make-pstream)) 29 | 30 | (define (play stream sound) 31 | (r:pstream-play stream sound)) 32 | 33 | (define (stop-sound-streams) 34 | (r:stop)) 35 | 36 | 37 | 38 | ) 39 | -------------------------------------------------------------------------------- /entity-helpers/backpack-util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (module+ test 4 | (require rackunit 5 | 2htdp/image 6 | threading 7 | "./render-util.rkt") 8 | 9 | (let () 10 | 11 | (define item (sprite->entity (star 10 'solid 'gold) 12 | #:name "star" 13 | #:position (posn 0 0))) 14 | 15 | (define item2 (sprite->entity (star 10 'solid 'red) 16 | #:name "star" 17 | #:position (posn 0 0))) 18 | 19 | (define b (sprite->entity (circle 10 'solid 'red) 20 | #:name "player" 21 | #:position (posn 0 0) 22 | #:components 23 | (backpack-system #:components (observe-change backpack-changed? update-backpack)) 24 | (on-key 'i (add-item item)) 25 | (on-key 'o (add-item item2)) 26 | )) 27 | 28 | (define g (initialize-game (list b))) 29 | 30 | 31 | (define ticked-g-no-item 32 | (~> g 33 | (tick _ #:ticks 10) ; Not necessary, but why not run for a few ticks? 34 | (handle-key-down _ "b") 35 | (tick _) 36 | (tick _))) 37 | 38 | (define ticked-g 39 | (~> ticked-g-no-item 40 | (handle-key-down _ "i") 41 | (tick _) 42 | (tick _) 43 | (handle-key-down _ "o") 44 | (tick _) 45 | (tick _) 46 | 47 | )) 48 | 49 | (check-equal? (not (not (get-entity "backpack" ticked-g))) 50 | #t 51 | "There should be a backpack entity in the game by now") 52 | 53 | (check-equal? (get-backpack-entities (get-entity "player" ticked-g)) 54 | (list item item2) 55 | "There should be two items in the backpack at this time") 56 | 57 | 58 | (check-equal? (> (image-height (draw-entity (get-entity "backpack" ticked-g))) 59 | (image-height (draw-entity (get-entity "backpack" ticked-g-no-item)))) 60 | #t 61 | "Backpack should expand verticially when you add things to it") 62 | )) 63 | 64 | (provide drop-last-item 65 | backpack-system) 66 | 67 | ;(require 2htdp/image) 68 | (require "../game-entities.rkt") 69 | (require "../components/backpack.rkt") 70 | (require "../components/backdrop.rkt") 71 | (require "./sprite-util.rkt") 72 | (require "./movement-util.rkt") 73 | (require "./ui-util.rkt") 74 | (require "../component-util.rkt") 75 | (require "../components/on-key.rkt") 76 | (require "../components/on-start.rkt") 77 | (require "../components/sound-stream.rkt") 78 | (require "../components/observe-change.rkt") 79 | (require "../components/animated-sprite.rkt") 80 | (require "../components/storage.rkt") 81 | (require "../components/lock-to.rkt") 82 | (require posn 2htdp/image) 83 | 84 | (define (drop-last-item) 85 | (lambda (g e) 86 | ;(displayln "DROPPING LAST ITEM") 87 | (define target-ent (get-last-item e)) 88 | (define current-tile (game->current-tile g)) 89 | (if (not (empty? (get-items e))) 90 | (let ([new-entity (update-entity 91 | (update-entity 92 | target-ent 93 | active-on-bg? (active-on-bg current-tile)) 94 | posn? (posn 0 0))]) 95 | ((spawn new-entity #:relative? #t) g 96 | ((remove-item target-ent) g e))) 97 | e))) 98 | 99 | ; ==== SYSTEMS ==== 100 | (define (backpack-system #:storable-items [storable-item-list #f] 101 | #:store-key [store-key "z"] 102 | #:drop-key [drop-key "x"] 103 | #:backpack-key [backpack-key "b"] 104 | #:pickup-sound [pickup-sound #f] 105 | #:drop-sound [drop-sound #f] 106 | #:backpack-sound [backpack-sound #f] 107 | #:max-items [max-items 10] 108 | #:pickup-rule [rule (λ (g e) #t)] 109 | #:components [c #f] 110 | . custom-components) 111 | (define selection-image (square 1 'solid (color 0 255 255 100))) 112 | (precompile! selection-image) 113 | (define (weapon-changed? g e) 114 | (get-storage-data "Selected Weapon" (get-entity "player" g))) 115 | (define backpack-entity 116 | (sprite->entity (bordered-box-sprite 50 50) ;(new-sprite bg-image#:animate #f) 117 | #:name "backpack" 118 | #:position (posn 0 0) ;(posn 12 (/ HEIGHT 2)) 119 | #:components (static) 120 | (hidden) 121 | (layer "ui") 122 | (on-start (do-many update-backpack-sprite 123 | (go-to-pos-inside 'top-right) 124 | show)) 125 | ;(on-key store-key die) 126 | ;(on-key drop-key die) 127 | (on-key backpack-key die) 128 | (observe-change backpack-changed? update-backpack) 129 | (observe-change weapon-changed? update-backpack) 130 | (cons c custom-components))) 131 | 132 | (define (backpack-is-full? g e) 133 | (define num-items-in-backpack (length (get-backpack-entities e))) 134 | (>= num-items-in-backpack max-items)) 135 | 136 | (define (open-backpack-if-closed) 137 | (lambda (g e) 138 | (if (backpack-not-open? g e) 139 | ((spawn #:relative? #f backpack-entity) g e) 140 | e))) 141 | 142 | (define (storable-item item-name key) 143 | (on-key key #:rule (and/r storable-items-nearby? 144 | (not/r backpack-is-full?) 145 | rule) (if pickup-sound 146 | (do-many (store-nearby-item item-name) 147 | (open-backpack-if-closed) 148 | (play-sound pickup-sound)) 149 | (do-many (store-nearby-item item-name) 150 | (open-backpack-if-closed) 151 | )))) 152 | 153 | (append (list (backpack) 154 | (on-key backpack-key #:rule backpack-not-open? (if backpack-sound 155 | (do-many (display-items) 156 | (spawn #:relative? #f backpack-entity) 157 | (play-sound backpack-sound)) 158 | (do-many (display-items) 159 | (spawn #:relative? #f backpack-entity)))) 160 | (on-key drop-key #:rule (and/r backpack-not-empty? 161 | ; the line below prevents holding two crafted items in hand. 162 | (not/r (other-entity-locked-to? "player" #:filter (and/c (has-component? on-key?) 163 | not-sky? 164 | not-ui?)))) 165 | (if drop-sound 166 | (do-many (drop-last-item) 167 | (open-backpack-if-closed) 168 | (play-sound drop-sound)) 169 | (do-many (drop-last-item) 170 | (open-backpack-if-closed))))) 171 | (if storable-item-list 172 | (map (curryr storable-item store-key) storable-item-list) 173 | (list (on-key store-key #:rule (and/r storable-items-nearby? 174 | (not/r backpack-is-full?) 175 | rule) 176 | (if pickup-sound 177 | (do-many (store-nearby-item) 178 | (open-backpack-if-closed) 179 | (play-sound pickup-sound)) 180 | (do-many (store-nearby-item) 181 | (open-backpack-if-closed) 182 | ))))))) -------------------------------------------------------------------------------- /entity-helpers/carry-util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide movable 4 | nearest-to-player? 5 | nearest-entity-to-player-is? 6 | near-player? 7 | get-carry-offset-x 8 | get-carry-offset-y 9 | carried? 10 | carried-by) 11 | 12 | (require "../game-entities.rkt" 13 | "../components/backdrop.rkt" 14 | "../components/lock-to.rkt" 15 | "../entity-helpers/movement-util.rkt" 16 | (only-in "../entity-helpers/dialog-util.rkt" 17 | draw-dialog) 18 | "../components/animated-sprite.rkt" 19 | "../components/on-key.rkt" 20 | "../components/observe-change.rkt" 21 | "../components/spawn-once.rkt" 22 | "../components/counter.rkt" 23 | "../components/storage.rkt" 24 | "../component-util.rkt" 25 | "../entity-helpers/render-util.rkt" 26 | posn 27 | 2htdp/image 28 | threading) 29 | 30 | ; === GENENRIC RULES AND HELPERS === 31 | ; TODO: add to game engine 32 | (define (remove-active-on-bg) 33 | (lambda (g e) 34 | (remove-component e active-on-bg?))) 35 | 36 | (define (add-active-on-bg) 37 | (lambda (g e) 38 | (define current-tile (game->current-tile g)) 39 | (add-component e (active-on-bg current-tile)))) 40 | 41 | (define (add-lock-to name #:offset [offset (posn 10 0)]) 42 | (lambda (g e) 43 | (if (get-component e lock-to?) 44 | e 45 | (add-component (remove-component e physical-collider?) 46 | (lock-to name #:offset offset))))) 47 | 48 | (define (maybe-add-physical-collider e) 49 | (if (get-storage "physical-collider" e) 50 | (~> e 51 | (add-components _ (get-storage-data "physical-collider" e)) 52 | (remove-storage "physical-collider" _)) 53 | e)) 54 | 55 | (define (remove-lock-to) 56 | (lambda (g e) 57 | ;(add-component (remove-component e lock-to?) (physical-collider)) 58 | (~> e 59 | (remove-component _ lock-to?) 60 | (maybe-add-physical-collider _)) 61 | )) 62 | 63 | (define (near-player? g e) 64 | (define player (entity-with-name "player" g)) 65 | (define e-width (image-width (render (get-component e animated-sprite?)))) 66 | ;(define e-height (image-height (render (get-component e animated-sprite?)))) 67 | (define p-width (image-width (render (get-component player animated-sprite?)))) 68 | ;(define p-height (image-height (render (get-component player animated-sprite?)))) 69 | (define range (+ (/ e-width 2) (/ p-width 2) 20)) 70 | ;(displayln (~a "MIN RANGE: " range)) 71 | ((near? "player" range) g e)) 72 | 73 | (define (nearest-to-player? #:filter [f identity]) 74 | (lambda (g e) 75 | (define all-es (filter f (game-entities g))) 76 | 77 | (define player (entity-with-name "player" g)) 78 | 79 | (define all-but-me-and-player 80 | (~> all-es 81 | (remove player _ entity-eq?) 82 | (remove e _ entity-eq?) 83 | (filter normal-entity? _))) 84 | 85 | (define my-dist (distance-between (get-posn e) 86 | (get-posn player))) 87 | 88 | (define other-distances (map (curry distance-between (get-posn player)) 89 | (map get-posn all-but-me-and-player))) 90 | 91 | #;(displayln (list (get-name e) (get-id e) my-dist other-distances)) 92 | 93 | (or (empty? other-distances) 94 | (< my-dist (apply min other-distances))))) 95 | 96 | (define (nearest-entity-to-player-is? name #:filter [f identity]) 97 | (lambda (g e) 98 | (define all-es (filter f (game-entities g))) 99 | 100 | (define player (entity-with-name "player" g)) 101 | 102 | (define all-but-me-and-player 103 | (~> all-es 104 | (remove player _ entity-eq?) 105 | (remove e _ entity-eq?) 106 | (filter normal-entity? _))) 107 | 108 | (define (closer-to-player? e1 e2) 109 | (< (distance-between (get-posn e1) (get-posn player)) 110 | (distance-between (get-posn e2) (get-posn player)))) 111 | 112 | (define sorted-list (sort all-but-me-and-player 113 | closer-to-player?)) 114 | 115 | (displayln (~a "NEAREST ENTITY TO PLAYER: " (if (empty? sorted-list) 116 | "NONE" 117 | (get-name (first sorted-list))))) 118 | 119 | (and (not (empty? sorted-list)) 120 | (eq? (get-name (first sorted-list)) name)))) 121 | 122 | (define (carried? g e) 123 | (get-component e lock-to?)) 124 | 125 | ;added optional location of a carried sprite: 'left or 'right(default) 126 | (define (get-carry-offset-x player-sprite item-sprite 127 | #:item-location [item-loc 'right]) 128 | (define p-img (render player-sprite)) 129 | (define i-img (render item-sprite)) 130 | (define pos-x (cond [(eq? item-loc 'right) (+ (/ (image-width p-img) 2) (/ (image-width i-img) 2))] 131 | [(eq? item-loc 'left) (- (+ (/ (image-width p-img) 2) (/ (image-width i-img) 2)))])) 132 | (define pos-y 0) 133 | (posn pos-x pos-y)) 134 | 135 | ;added optional location for a carried sprite: 'top or 'bottom(default) 136 | (define (get-carry-offset-y player-sprite item-sprite 137 | #:item-location [item-loc 'bottom]) 138 | (define p-img (render player-sprite)) 139 | (define i-img (render item-sprite)) 140 | (define pos-x 0) 141 | (define pos-y (cond [(eq? item-loc 'bottom) (+ (/ (image-height p-img) 2) (/ (image-height i-img) 2))] 142 | [(eq? item-loc 'top) (- (+ (/ (image-height p-img) 2) (/ (image-height i-img) 2)))])) 143 | (posn pos-x pos-y)) 144 | 145 | 146 | 147 | (component carriable ()) 148 | 149 | (define (display-entity e) 150 | (define i (draw-entity e)) 151 | (define p (get-posn e)) 152 | (define a (get-component e active-on-bg?)) 153 | 154 | (displayln i) 155 | (displayln (~a "(posn " 156 | (exact-round (posn-x p)) 157 | " " 158 | (exact-round (posn-y p)) 159 | ")")) 160 | (displayln (~a "(active-on-bg " 161 | (first (active-on-bg-bg-list a)) 162 | ")")) 163 | 164 | e) 165 | 166 | (define (draw-info g e1 e2) 167 | (define e2-pos (get-component e2 posn?)) 168 | (define pos-x (exact-floor (posn-x e2-pos))) 169 | (define pos-y (exact-floor (posn-y e2-pos))) 170 | (define current-tile (game->current-tile g)) 171 | (define e2-height (image-height (render (get-component e2 animated-sprite?)))) 172 | (define hue (get-hue-val e2)) 173 | (define size (get-size-val e2)) 174 | (define info-entity 175 | (sprite->entity (draw-dialog (~a "(posn " pos-x " " pos-y ")" 176 | "\nTile: " current-tile 177 | (if hue (~a "\nHue: " (modulo hue 360)) "") 178 | (if size (~a "\nSize: " size) ""))) 179 | #:position (posn 0 (+ 10 (/ e2-height 2))) 180 | #:name "info" 181 | #:components (static) 182 | (active-on-bg current-tile) 183 | (on-key "z" die))) 184 | (if (carried? g e2) 185 | (begin 186 | (displayln "Picked up") 187 | e2) 188 | (begin (displayln "Dropped") 189 | (if (void? e1) 190 | e2 191 | (add-component e2 (spawn-once info-entity)))) 192 | )) 193 | 194 | ; === GENERIC SYSTEM === 195 | ; TODO: only carry one at a time option 196 | ; calculate offset from game entities, use struct? 197 | 198 | 199 | (define (active-on-bg-twiddle on-drop) 200 | (λ(g e1 e2) 201 | (if (carried? g e2) 202 | (begin 203 | (remove-component e2 active-on-bg?)) 204 | (on-drop 205 | (if (void? e1) 206 | e2 207 | (add-component e2 (active-on-bg (game->current-tile g)))))))) 208 | 209 | 210 | (define (movable #:carry-offset [offset (posn 0 0)] 211 | #:storable-items [movable-item-list #f] 212 | #:pickup-key [pickup-key "z"] 213 | #:drop-key [drop-key "x"] 214 | #:pickup-sound [pickup-sound #f] 215 | #:drop-sound [drop-sound #f] 216 | #:show-info? [show-info? #f] 217 | #:on-drop [on-drop display-entity]) 218 | (list (new-carriable) 219 | (on-key pickup-key #:rule (and/r (nearest-to-player? #:filter (has-component? on-key?)) 220 | near-player? 221 | (not/r carried?) 222 | (not/r (other-entity-locked-to? "player"))) 223 | (add-lock-to "player" #:offset offset)) 224 | (on-key drop-key #:rule carried? (remove-lock-to)) 225 | 226 | (observe-change carried? 227 | (active-on-bg-twiddle on-drop)) 228 | (if show-info? 229 | (observe-change carried? draw-info) 230 | #f))) 231 | 232 | 233 | (define (carried-by g e) 234 | (define target-name (lock-to-name (get-component e lock-to?))) 235 | 236 | (entity-with-name target-name g)) 237 | 238 | -------------------------------------------------------------------------------- /entity-helpers/mini-map.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide open-mini-map 4 | mini-map) 5 | 6 | (require "../game-entities.rkt" 7 | "../component-util.rkt" 8 | "../components/animated-sprite.rkt" 9 | ;"../components/detect-edge.rkt" 10 | ;"../components/on-edge.rkt" 11 | "../components/on-rule.rkt" 12 | "../components/backdrop.rkt" 13 | "../components/on-start.rkt" 14 | "../components/spawn-once.rkt" 15 | "../components/on-key.rkt" 16 | ;"../components/after-time.rkt" 17 | "../components/counter.rkt" 18 | "../components/observe-change.rkt" 19 | "../entity-helpers/sprite-util.rkt" 20 | "../entity-helpers/movement-util.rkt" 21 | 2htdp/image 22 | posn 23 | memoize 24 | threading) 25 | 26 | (define handler-function? (-> game? entity? entity?)) 27 | (define rule? (-> game? entity? boolean?)) 28 | 29 | ; You can specify mini-map scale and frame width here 30 | (define mini-map-scale 0.075) 31 | (define frame-width 6) 32 | 33 | 34 | ; ========== MINI-MAP REFACTOR ============= 35 | 36 | (define/contract (draw-mini-map backdrop x-scale y-scale) 37 | (-> backdrop? number? number? image?) 38 | (define tiles (backdrop-tiles backdrop)) 39 | (define columns (backdrop-columns backdrop)) 40 | (define rows (/ (length tiles) columns)) 41 | 42 | (define tile-width (image-width (first tiles))) 43 | (define tile-height (image-height (first tiles))) 44 | 45 | (define mini-map (scale/xy x-scale y-scale 46 | (mini-map-base tiles 47 | columns rows 48 | tile-width tile-height 49 | (length tiles)))) 50 | 51 | (frame-mini-map (scale mini-map-scale mini-map))) 52 | 53 | (define (map-frame-x tile backdrop) 54 | (define tiles (backdrop-tiles backdrop)) 55 | (define columns (backdrop-columns backdrop)) 56 | (- (modulo tile columns) (/ (sub1 columns) 2))) 57 | 58 | (define (map-frame-y tile backdrop) 59 | (define tiles (backdrop-tiles backdrop)) 60 | (define columns (backdrop-columns backdrop)) 61 | (define rows (/ (length tiles) columns)) 62 | (- (quotient tile columns) (/ (sub1 rows) 2))) 63 | 64 | (define/contract (mini-map-frame-sprite backdrop tile-index map-base) 65 | (-> backdrop? integer? image? sprite?) 66 | 67 | (define map-width (- (image-width map-base) frame-width)) 68 | (define map-height (- (image-height map-base) frame-width)) 69 | 70 | (define tiles (backdrop-tiles backdrop)) 71 | (define columns (backdrop-columns backdrop)) 72 | (define rows (/ (length tiles) columns)) 73 | 74 | (define tile-width (/ map-width columns)) 75 | (define tile-height (/ map-height rows)) 76 | 77 | (define frame-x (map-frame-x tile-index backdrop)) 78 | (define frame-y (map-frame-y tile-index backdrop)) 79 | 80 | (define frame (overlay (rectangle tile-width tile-height 'outline 'red) 81 | (rectangle (+ 2 tile-width) (+ 2 tile-height) 'solid 'transparent))) 82 | (new-sprite frame 83 | #:x-offset (* frame-x tile-width) 84 | #:y-offset (* frame-y tile-height))) 85 | 86 | (define (mini-map bg-ent #:close-key close-key) 87 | (define bg-as (get-component bg-ent animated-sprite?)) 88 | (define backdrop (get-component bg-ent backdrop?)) 89 | (define bg-x-scale (get-x-scale bg-as)) 90 | (define bg-y-scale (get-y-scale bg-as)) 91 | (define tile-index (backdrop-current-tile backdrop)) 92 | 93 | (define map-base-image (draw-mini-map backdrop bg-x-scale bg-y-scale)) 94 | (define map-base-sprite (new-sprite map-base-image)) 95 | (define map-frame-sprite (mini-map-frame-sprite backdrop tile-index map-base-image)) 96 | 97 | (define id (backdrop-id backdrop)) 98 | 99 | (define mini-map-offset-x (* -0.05 (width bg-ent))) 100 | (define mini-map-offset-y (* -0.05 (height bg-ent))) 101 | 102 | (define (update-mini-map-frame g e) 103 | (define as (get-component e (curry component-eq? map-frame-sprite))) 104 | (define backdrop (get-component (game->tracking-entity g) backdrop?)) 105 | (define tile (backdrop-current-tile backdrop)) 106 | (define frame-image (render as)) 107 | (define tile-width (- (image-width frame-image) 2)) 108 | (define tile-height (- (image-height frame-image) 2)) 109 | 110 | (define new-x-offset (* tile-width (map-frame-x tile backdrop))) 111 | (define new-y-offset (* tile-height (map-frame-y tile backdrop))) 112 | (define new-as (~> as 113 | (set-x-offset new-x-offset _) 114 | (set-y-offset new-y-offset _))) 115 | (update-entity e (curry component-eq? as) new-as)) 116 | 117 | (define (update-mini-map g e) 118 | (define old-map-as (get-component e (curry component-eq? map-base-sprite))) 119 | 120 | (define new-backdrop (get-component (game->tracking-entity g) backdrop?)) 121 | (define new-bg-as (get-component bg-ent animated-sprite?)) 122 | (define new-bg-x-scale (get-x-scale bg-as)) 123 | (define new-bg-y-scale (get-y-scale bg-as)) 124 | (define new-map-base (draw-mini-map new-backdrop bg-x-scale bg-y-scale)) 125 | (define new-frames (vector (fast-image new-map-base))) 126 | (define new-map-as (struct-copy animated-sprite old-map-as 127 | [frames new-frames] 128 | [o-frames new-frames])) 129 | (update-entity e (curry component-eq? old-map-as) new-map-as)) 130 | 131 | (sprite->entity (list map-frame-sprite 132 | map-base-sprite) 133 | #:name "mini-map" 134 | #:position (posn 0 0) 135 | #:components (hidden) 136 | (static) 137 | (layer "ui") 138 | (counter id) 139 | (on-start (do-many (go-to-pos-inside 'bottom-right 140 | #:posn-offset (posn mini-map-offset-x 141 | mini-map-offset-y)) 142 | show)) 143 | (on-key close-key die) 144 | (on-rule tile-changed? update-mini-map-frame) 145 | (observe-change backdrop-changed? (if/r backdrop-changed? 146 | (do-many (λ (g e)(displayln "==== BACKDROP CHANGED ====") e) 147 | update-mini-map) 148 | )) 149 | )) 150 | 151 | ; allows to add mini-map entity to the game. 152 | ; Requires game to have an entity with a backdrop component. 153 | ; Can be called from any entity: (on-key "m" (open-mini-map #:close-key 'o)) 154 | (define (open-mini-map #:close-key close-key) 155 | (-> #:close-key (or/c symbol? string?) handler-function?) 156 | (lambda (g e) 157 | (define bg-ent (game->tracking-entity g)) 158 | (define mini-map-entity (mini-map bg-ent #:close-key close-key)) 159 | (if (get-entity "mini-map" g) 160 | e 161 | (add-components e (spawn-once mini-map-entity #:relative? #f))))) 162 | 163 | (define (backdrop-changed? g e) 164 | (backdrop-id (get-component (game->tracking-entity g) backdrop?))) 165 | 166 | ; ========== END OF MINI-MAP REFACTOR =========== 167 | 168 | #| 169 | ; allows to add mini-map entity to the game. 170 | ; Requires game to have an entity with a backdrop component. 171 | ; Can be called from any entity: (on-key "m" (open-mini-map #:close-key 'o)) 172 | (define/contract (open-mini-map #:close-key close-key) 173 | (-> #:close-key (or/c symbol? string?) handler-function?) 174 | (lambda (g e) 175 | (define backdrop (get-component (game->tracking-entity g) backdrop?)) 176 | (define tile-index (backdrop-current-tile backdrop)) 177 | 178 | (define mini-map-l (mini-map-layout backdrop tile-index)) 179 | (define mini-map-f (mini-map-frame backdrop tile-index mini-map-l)) 180 | 181 | (define id (backdrop-id backdrop)) 182 | 183 | (define mini-map-offset-x (* -0.05 (game-width g))) 184 | (define mini-map-offset-y (* -0.05 (game-height g))) 185 | 186 | (define mini-map-layout-entity 187 | (sprite->entity mini-map-l 188 | #:name "mini-map-layout" 189 | #:position (posn 0 0) 190 | #:components (hidden) 191 | (static) 192 | (counter id) 193 | (on-start (do-many (go-to-pos-inside 'bottom-right) 194 | (change-x-by mini-map-offset-x) 195 | (change-y-by mini-map-offset-y) 196 | show)) 197 | (on-key close-key die) 198 | (observe-change backdrop-r? (λ(g e1 e2) 199 | ;(get-component (game->tracking-entity g) backdrop?) 200 | ;(define tile-index (backdrop-current-tile backdrop)) 201 | (define backdrop (get-component (game->tracking-entity g) backdrop?)) 202 | (define current-tile (backdrop-current-tile backdrop)) 203 | (if (backdrop-r? g e2) 204 | (update-entity e2 animated-sprite? (new-sprite (mini-map-layout backdrop current-tile))) 205 | (if (void? e1) 206 | e2 207 | (update-entity e2 animated-sprite? (new-sprite (mini-map-layout backdrop current-tile))))))))) 208 | (define mini-map-frame-entity 209 | (sprite->entity mini-map-f 210 | #:name "mini-map-frame" 211 | #:position (posn 0 0) 212 | #:components (hidden) 213 | (static) 214 | (on-start (do-many (go-to-pos-inside 'bottom-right) 215 | (change-x-by (+ (/ frame-width -2) mini-map-offset-x)) 216 | (change-y-by (+ (/ frame-width -2) mini-map-offset-y)) 217 | show)) 218 | (on-key close-key die) 219 | (on-rule tile-changed? (update-mini-map-frame mini-map-l)) 220 | )) 221 | 222 | (if (get-entity "mini-map-layout" g) 223 | e 224 | (add-components e (spawn-once mini-map-layout-entity #:relative? #f) 225 | (spawn-once mini-map-frame-entity #:relative? #f))))) 226 | 227 | ; create an image for a mini-map entity animated-sprite 228 | (define/contract (mini-map-layout backdrop tile-index) 229 | (-> backdrop? integer? image?) 230 | (define tiles (backdrop-tiles backdrop)) 231 | (define columns (backdrop-columns backdrop)) 232 | (define rows (/ (length tiles) columns)) 233 | 234 | (define tile-width (image-width (first tiles))) 235 | (define tile-height (image-height (first tiles))) 236 | 237 | (define frame-x (modulo tile-index columns)) 238 | (define frame-y (quotient tile-index columns)) 239 | 240 | (define frame (rectangle tile-width tile-height "outline" "red")) 241 | (define mini-map (mini-map-base tiles 242 | columns rows 243 | tile-width tile-height 244 | (length tiles))) 245 | 246 | (frame-mini-map (scale mini-map-scale mini-map))) 247 | 248 | (define/contract (mini-map-frame backdrop tile-index layout) 249 | (-> backdrop? integer? image? image?) 250 | (define empty-image (rectangle (+ (- frame-width) (image-width layout)) (+ (- frame-width) (image-height layout)) "solid" (make-color 0 0 0 0))) 251 | 252 | (define tiles (backdrop-tiles backdrop)) 253 | (define columns (backdrop-columns backdrop)) 254 | (define rows (/ (length tiles) columns)) 255 | 256 | (define tile-width (/ (image-width empty-image) columns)) 257 | (define tile-height (/ (image-height empty-image) rows)) 258 | 259 | (define frame-x (modulo tile-index columns)) 260 | (define frame-y (quotient tile-index columns)) 261 | 262 | (define frame (rectangle (+ -1 tile-width) (+ -1 tile-height) "outline" "red")) 263 | 264 | (underlay/xy empty-image 265 | (* frame-x tile-width) 266 | (* frame-y tile-height) 267 | frame)) 268 | 269 | |# 270 | 271 | ; puts all tiles from list together 272 | (define/memo (mini-map-base tiles columns rows tile-width tile-height total-tiles) 273 | ;(-> list? integer? integer? integer? integer? integer? image?) 274 | (define x (modulo (- total-tiles (length tiles)) columns)) 275 | (define y (quotient (- total-tiles (length tiles)) columns)) 276 | (if (empty? tiles) (rectangle (* tile-width columns) 277 | (* tile-height rows) "outline" "black") 278 | (freeze (underlay/xy (mini-map-base (rest tiles) columns rows tile-width tile-height total-tiles) 279 | (* x tile-width) (* y tile-height) 280 | (first tiles))))) 281 | 282 | ; add frame to mini-map 283 | (define/contract (frame-mini-map img) 284 | (-> image? image?) 285 | (underlay 286 | (underlay/align "middle" "middle" 287 | (rectangle (+ frame-width (image-width img)) 288 | (+ frame-width (image-height img)) 289 | "solid" (make-color 190 190 190)) 290 | (rectangle (+ (+ -1 frame-width) (image-width img)) 291 | (+ (+ -1 frame-width) (image-height img)) 292 | "solid" (make-color 255 255 255)) 293 | (rectangle (+ (+ -4 frame-width) (image-width img)) 294 | (+ (+ -4 frame-width) (image-height img)) 295 | "solid" (make-color 190 190 190))) 296 | img 297 | (rectangle (+ frame-width (image-width img)) 298 | (+ frame-width (image-height img)) 299 | "solid" (make-color 198 174 138 80)))) 300 | 301 | #| 302 | ; update mini-map entitiy sprite based on next backdrop tile index for a given direction 303 | (define/contract (update-mini-map-frame layout) 304 | (-> image? handler-function?) 305 | (lambda (g e) 306 | ;(get-component (game->tracking-entity g) backdrop?) 307 | ;(define tile-index (backdrop-current-tile backdrop)) 308 | (define backdrop (get-component (game->tracking-entity g) backdrop?)) 309 | (define current-tile (backdrop-current-tile backdrop)) 310 | (if current-tile 311 | (update-entity e animated-sprite? (new-sprite (mini-map-frame backdrop current-tile layout))) 312 | e) 313 | )) 314 | 315 | ; update mini-map entitiy sprite based on next backdrop tile index for a given direction 316 | (define/contract (update-mini-map-layout) 317 | (-> handler-function?) 318 | (lambda (g e) 319 | (define backdrop (get-component (game->tracking-entity g) backdrop?)) 320 | (define current-tile (game->current-tile g)) 321 | (if current-tile 322 | (update-entity e animated-sprite? (new-sprite (mini-map-layout backdrop current-tile))) 323 | e) 324 | )) 325 | 326 | ; returns next tile index in direction 327 | (define/contract (next-backdrop-index direction total-tiles col current-backdrop-index) 328 | (-> symbol? integer? integer? integer? (or/c integer? boolean?)) 329 | (define left-edge-list (range 0 total-tiles col)) 330 | (define right-edge-list (range (sub1 col) total-tiles col)) 331 | (define top-edge-list (range 0 col)) 332 | (define bottom-edge-list (range (- total-tiles col) total-tiles)) 333 | (cond [(eq? direction 'left) (if (member current-backdrop-index left-edge-list) 334 | #f 335 | (sub1 current-backdrop-index))] 336 | [(eq? direction 'right) (if (member current-backdrop-index right-edge-list) 337 | #f 338 | (add1 current-backdrop-index))] 339 | [(eq? direction 'top) (if (member current-backdrop-index top-edge-list) 340 | #f 341 | (- current-backdrop-index col))] 342 | [(eq? direction 'bottom) (if (member current-backdrop-index bottom-edge-list) 343 | #f 344 | (+ current-backdrop-index col))])) 345 | 346 | ; Function for observe-rule change in backdrop id 347 | (define (backdrop-r? g e) 348 | ;(get-component (game->tracking-entity g) backdrop?) 349 | ;(define tile-index (backdrop-current-tile backdrop)) 350 | (backdrop-id (get-component (game->tracking-entity g) backdrop?))) 351 | |# -------------------------------------------------------------------------------- /entity-helpers/mouse-util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide show-mouse-state 4 | point-to-mouse 5 | mouse-in-game? 6 | mouse-button-is-down? 7 | get-mouse-pos 8 | CROSSHAIR-IMG 9 | POINTER-IMG 10 | go-to-mouse 11 | touching-pointer? 12 | on-sprite-click 13 | sprite->cursor-sprite 14 | ) 15 | 16 | (require "../game-entities.rkt" 17 | "./movement-util.rkt" 18 | "../components/on-mouse.rkt" 19 | "../components/animated-sprite.rkt" 20 | posn 21 | 2htdp/image 22 | threading 23 | ) 24 | 25 | (define (mouse-in-game? g e) 26 | (define m-pos (get-mouse-pos g)) 27 | (not (equal? m-pos (posn 0 0))) 28 | ) 29 | 30 | (define (get-mouse-pos g) 31 | (define get-backing-scale (dynamic-require 'racket/gui/base 'get-display-backing-scale)) 32 | (define display-scale (get-backing-scale)) 33 | 34 | (define raw-posn (get-raw-mouse-pos g)) 35 | (define raw-x (posn-x raw-posn)) 36 | (define raw-y (posn-y raw-posn)) 37 | 38 | (if ml-scale-info 39 | (let ([scale-x (first (second ml-scale-info))] 40 | [scale-y (second (second ml-scale-info))] 41 | [scale-w (first (third ml-scale-info))] 42 | [scale-h (second (third ml-scale-info))] 43 | [window-w (first (fifth ml-scale-info))] 44 | [window-h (second (fifth ml-scale-info))]) 45 | (posn (/ (- (* raw-x display-scale) (/ (- window-w scale-w) 2)) scale-x display-scale) 46 | (/ (- (* raw-y display-scale) (/ (- window-h scale-h) 2)) scale-y display-scale) 47 | )) 48 | raw-posn)) 49 | 50 | (define (show-mouse-state g e) 51 | (define m-pos (get-mouse-pos g)) 52 | (define mouse-x (posn-x m-pos)) 53 | (define mouse-y (posn-y m-pos)) 54 | (displayln (~a "SHOWING MOUSE STATE: " mouse-x " " mouse-y)) 55 | e) 56 | 57 | (define (point-to-mouse g e) 58 | (define target-pos (get-mouse-pos g)) 59 | 60 | ((point-to-posn target-pos) g e) 61 | ) 62 | 63 | (define (mouse-button-is-down? button) 64 | (lambda (g e) 65 | (mouse-button-down? button g))) 66 | 67 | (define CROSSHAIR-IMG (overlay (line 0 26 'red) 68 | (line 26 0 'red) 69 | (circle 10 'outline 'red))) 70 | 71 | (define POINTER-IMG (overlay (circle 2 'solid 'blue) 72 | (circle 8 'outline 'yellow) 73 | (circle 10 'outline 'red) 74 | (square 24 'solid 'transparent))) 75 | 76 | (define (go-to-mouse g e) 77 | (update-entity e posn? (get-mouse-pos g))) 78 | 79 | (define (touching-pointer? g e) 80 | (define pos (get-posn e)) 81 | (define m-pos (get-mouse-pos g)) 82 | (define x (posn-x pos)) 83 | (define y (posn-y pos)) 84 | (define w (bb-w (get-component e bb?))) 85 | (define h (bb-h (get-component e bb?))) 86 | (define mx (posn-x m-pos)) 87 | (define my (posn-y m-pos)) 88 | (and (> mx (- x (/ w 2))) 89 | (< mx (+ x (/ w 2))) 90 | (> my (- y (/ h 2))) 91 | (< my (+ y (/ h 2))))) 92 | 93 | (define (on-sprite-click #:rule [rule (λ (g e) #t)] #:key [key 'left] func) 94 | (on-mouse key #:rule (and/r rule 95 | touching-pointer?) func)) 96 | 97 | (define (sprite->cursor-sprite s [hot-spot-x 0] [hot-spot-y 0]) 98 | (define sprite (ensure-sprite s)) 99 | (define w (sprite-width sprite)) 100 | (define h (sprite-height sprite)) 101 | (define new-x-offset (- (/ w 2) hot-spot-x)) 102 | (define new-y-offset (- (/ h 2) hot-spot-y)) 103 | (~> sprite 104 | (set-x-offset new-x-offset _) 105 | (set-y-offset new-y-offset _))) 106 | 107 | -------------------------------------------------------------------------------- /entity-helpers/movement-util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide randomly-relocate-me 4 | go-to-random 5 | go-to 6 | go-to-pos 7 | go-to-pos-inside 8 | go-to-entity 9 | respawn 10 | move-with-speed 11 | move-random-speed 12 | point-to 13 | point-to-posn 14 | bounce 15 | change-x-by 16 | change-y-by 17 | change-x-by-random 18 | change-y-by-random 19 | freeze-entity 20 | un-freeze-entity 21 | distance-between 22 | get-entities-near 23 | near? 24 | player-is-near? 25 | get-nearest-entity-to 26 | entities-are-touching?) 27 | 28 | (require "../game-entities.rkt" 29 | "../components/direction.rkt" 30 | "../components/every-tick.rkt" 31 | "../components/animated-sprite.rkt" 32 | "../components/storage.rkt" 33 | "../component-util.rkt" 34 | "../ai.rkt" 35 | 2htdp/image 36 | posn 37 | threading) 38 | 39 | (define (randomly-relocate-me min-x max-x min-y max-y) 40 | (lambda (g e) 41 | (update-entity e posn? (posn (random min-x max-x) 42 | (random min-y max-y))))) 43 | 44 | (define (go-to-random min-x max-x min-y max-y) 45 | (lambda (g e) 46 | (update-entity e posn? (posn (random min-x (add1 max-x)) 47 | (random min-y (add1 max-y)))))) 48 | 49 | (define (go-to pos-x pos-y) 50 | (lambda (g e) 51 | (update-entity e posn? (posn pos-x pos-y)))) 52 | 53 | 54 | (define alignment? (or/c 'left 'right 'top 'bottom 55 | 'top-left 'top-right 'bottom-left 'bottom-right 56 | 'left-center 'right-center 'top-center 'bottom-center 57 | 'center)) 58 | 59 | (define/contract (go-to-pos pos #:offset [offset 0] #:posn-offset (posn-offset (posn 0 0))) 60 | (->* (alignment?) (#:offset number? #:posn-offset posn?) procedure?) 61 | (lambda (g e) 62 | (define WIDTH (game-width g)) 63 | (define HEIGHT (game-height g)) 64 | (define p (get-component e posn?)) 65 | (define pos-x (posn-x p)) 66 | (define pos-y (posn-y p)) 67 | (update-entity e posn? 68 | 69 | (posn-add 70 | posn-offset 71 | (cond 72 | [(eq? pos 'left) (posn offset pos-y)] 73 | [(eq? pos 'right) (posn (+ WIDTH offset) pos-y)] 74 | [(eq? pos 'top) (posn pos-x offset)] 75 | [(eq? pos 'bottom) (posn pos-x (+ HEIGHT offset))] 76 | [(eq? pos 'top-left) (posn 0 0)] 77 | [(eq? pos 'top-right) (posn WIDTH 0)] 78 | [(eq? pos 'bottom-left) (posn 0 HEIGHT)] 79 | [(eq? pos 'bottom-right) (posn WIDTH HEIGHT)] 80 | [(eq? pos 'left-center) (posn offset (/ HEIGHT 2))] 81 | [(eq? pos 'right-center) (posn (+ WIDTH offset) (/ HEIGHT 2))] 82 | [(eq? pos 'top-center) (posn (/ WIDTH 2) offset)] 83 | [(eq? pos 'bottom-center)(posn (/ WIDTH 2) (+ HEIGHT offset))] 84 | [(eq? pos 'center) (posn (/ WIDTH 2) (/ HEIGHT 2))])) 85 | ))) 86 | 87 | (define/contract (go-to-pos-inside pos #:offset [offset 0] #:posn-offset (posn-offset (posn 0 0))) 88 | (->* ((and/c alignment? (not/c 'center))) (#:offset number? #:posn-offset posn?) procedure?) 89 | (lambda (g e) 90 | (define WIDTH (game-width g)) 91 | (define HEIGHT (game-height g)) 92 | (define p (get-component e posn?)) 93 | ;(match-define (bb e-w e-h) (get-component e bb?)) 94 | ;(define hw (/ e-w 2)) ;(+ (/ e-w 2) 2)) ; Not sure why 2 was added 95 | ;(define hh (/ e-h 2)) ;(+ (/ e-h 2) 2)) ; Not sure why 2 was added 96 | (define as (get-component e animated-sprite?)) 97 | (define hw (/ (image-width (render as)) 2)) 98 | (define hh (/ (image-height (render as)) 2)) 99 | (define pos-x (posn-x p)) 100 | (define pos-y (posn-y p)) 101 | (update-entity e posn? 102 | (posn-add 103 | posn-offset 104 | (cond 105 | [(eq? pos 'left) (posn (+ offset hw) pos-y)] 106 | [(eq? pos 'right) (posn (+ (- WIDTH hw) offset) pos-y)] 107 | [(eq? pos 'top) (posn pos-x (+ offset hh))] 108 | [(eq? pos 'bottom) (posn pos-x (+ (- HEIGHT hh) offset))] 109 | [(eq? pos 'top-left) (posn hw hh)] 110 | [(eq? pos 'top-right) (posn (- WIDTH hw) hh)] 111 | [(eq? pos 'bottom-left) (posn hw (- HEIGHT hh))] 112 | [(eq? pos 'bottom-right) (posn (- WIDTH hw) (- HEIGHT hh))] 113 | [(eq? pos 'left-center) (posn (+ hw offset) (/ HEIGHT 2))] 114 | [(eq? pos 'right-center) (posn (+ (- WIDTH hw) offset) (/ HEIGHT 2))] 115 | [(eq? pos 'top-center) (posn (/ WIDTH 2) (+ hh offset))] 116 | [(eq? pos 'bottom-center)(posn (/ WIDTH 2) (+ (- HEIGHT hh) offset))]))))) 117 | 118 | (define (go-to-entity name #:offset [offset (posn 0 0)]) 119 | (lambda (g e) 120 | (define target? (get-entity name g)) 121 | (if target? 122 | (update-entity e posn? (posn-add (get-component target? posn?) offset)) 123 | e))) 124 | 125 | (define (respawn edge #:offset [offset 0]) 126 | (lambda (g e) 127 | (define HEIGHT (game-height g)) 128 | (define WIDTH (game-width g)) 129 | ((cond 130 | [(eq? edge 'left) (go-to offset (random 0 HEIGHT))] 131 | [(eq? edge 'right) (go-to (+ WIDTH offset) (random 0 HEIGHT))] 132 | [(eq? edge 'top) (go-to (random 0 WIDTH) offset)] 133 | [(eq? edge 'bottom) (go-to (random 0 WIDTH) (+ HEIGHT offset))] 134 | [(eq? edge 'anywhere) (go-to (random offset (- WIDTH offset)) (random offset (- HEIGHT offset)))]) 135 | g e))) 136 | 137 | (define (move-with-speed spd) 138 | (lambda (g e) 139 | (define dir (get-direction e)) 140 | (update-entity e every-tick? 141 | (every-tick (move-dir-spd #:dir dir #:speed spd))))) 142 | 143 | (define (move-random-speed min max) 144 | (lambda (g e) 145 | (define dir (get-direction e)) 146 | (update-entity e every-tick? 147 | (every-tick (move-dir-spd #:dir dir #:speed (random min (add1 max))))))) 148 | 149 | 150 | (define (point-to name) 151 | (lambda (g e) 152 | (define target? (get-entity name g)) 153 | (define target-x (unless (eq? target? #f) (posn-x (get-component target? posn?)))) 154 | (define target-y (unless (eq? target? #f) (posn-y (get-component target? posn?)))) 155 | (define x (posn-x (get-component e posn?))) 156 | (define y (posn-y (get-component e posn?))) 157 | (define new-dir (unless (eq? target? #f)(radians->degrees (atan (- target-y y) (- target-x x))))) 158 | (if target? 159 | (update-entity e direction? (direction (modulo (exact-round new-dir) 360))) 160 | e))) 161 | 162 | (define (point-to-posn target-pos) 163 | (lambda (g e) 164 | (define target-x (posn-x target-pos)) 165 | (define target-y (posn-y target-pos)) 166 | (define x (posn-x (get-component e posn?))) 167 | (define y (posn-y (get-component e posn?))) 168 | (define new-dir (radians->degrees (atan (- target-y y) (- target-x x)))) 169 | (update-entity e direction? (direction (modulo (exact-round new-dir) 360))))) 170 | 171 | (define (bounce) 172 | (lambda (g e) 173 | (update-entity e direction? (direction (modulo (+ (get-direction e) 180) 360))))) 174 | 175 | (define (change-x-by amount) 176 | (lambda (g e) 177 | (define p (get-component e posn?)) 178 | (update-entity e posn? (posn (+ (posn-x p) amount) (posn-y p))))) 179 | 180 | (define (change-y-by amount) 181 | (lambda (g e) 182 | (define p (get-component e posn?)) 183 | (update-entity e posn? (posn (posn-x p) (+ (posn-y p) amount))))) 184 | 185 | (define (change-x-by-random min max) 186 | (lambda (g e) 187 | (define p (get-component e posn?)) 188 | (update-entity e posn? (posn (+ (posn-x p) (random min (add1 max))) (posn-y p))))) 189 | 190 | (define (change-y-by-random min max) 191 | (lambda (g e) 192 | (define p (get-component e posn?)) 193 | (update-entity e posn? (posn (posn-x p) (+ (posn-y p) (random min (add1 max))))))) 194 | 195 | ; UPDATE: This now stores any existing every-tick component 196 | (define (freeze-entity) 197 | (lambda (g e) 198 | (define p (get-component e posn?)) 199 | (define old-components (get-components e every-tick?)) 200 | (~> e 201 | (remove-components _ every-tick?) 202 | (add-components _ (storage "stored-components" old-components) 203 | (every-tick (do-many (go-to (posn-x p) (posn-y p)) 204 | #;(set-direction 0))))))) 205 | 206 | ;UPDATE: This now restores any existing every-tick component 207 | (define (un-freeze-entity) 208 | (lambda (g e) 209 | (define old-components (and (get-storage "stored-components" e) 210 | (get-storage-data "stored-components" e))) 211 | (if (and old-components 212 | (not (empty? old-components))) 213 | (~> e 214 | (remove-components _ every-tick?) 215 | (remove-storage "stored-components" _) 216 | (add-components _ old-components)) 217 | (remove-components e every-tick?)))) 218 | 219 | (define (distance-between pos1 pos2) 220 | (define p (posn-subtract pos2 pos1)) 221 | (sqrt (+ (expt (posn-x p) 2) (expt (posn-y p) 2)))) 222 | 223 | (define (close? range source-e target-e) 224 | (define source-pos (get-component source-e posn?)) 225 | (define target-pos (get-component target-e posn?)) 226 | (< (distance-between target-pos source-pos) range)) 227 | 228 | (define (get-entities-near e g [range 80]) 229 | (filter (curry close? range e) (game-entities g))) 230 | 231 | (define (near? name [range 80]) 232 | (lambda (g e) 233 | (define (name-eq? name e) 234 | (eq? (get-name e) name)) 235 | (define nearby-ents (filter (curry name-eq? name) (get-entities-near e g range))) 236 | (not (empty? nearby-ents)))) 237 | 238 | (define (player-is-near? name [range 80]) 239 | (lambda (g e) 240 | (define player (get-entity "player" g)) 241 | (define p-width (image-width (render (get-component player animated-sprite?)))) 242 | (define target (get-entity name g)) 243 | (define target-width (if target 244 | (image-width (render (get-component target animated-sprite?))) 245 | 0)) 246 | (define set-range (+ (/ target-width 2) (/ p-width 2) 20)) 247 | ((near? name set-range) g player))) 248 | 249 | ; touch check without chipmunk 250 | (define (entities-are-touching? e1 e2) 251 | (define e1-pos (get-posn e1)) 252 | (define e1-x (posn-x e1-pos)) 253 | (define e1-y (posn-y e1-pos)) 254 | 255 | (define e2-pos (get-posn e2)) 256 | (define e2-x (posn-x e2-pos)) 257 | (define e2-y (posn-y e2-pos)) 258 | 259 | (define e1-w (width e1)) 260 | (define e1-h (height e1)) 261 | (define e2-w (width e2)) 262 | (define e2-h (height e2)) 263 | 264 | (define overlap 4) 265 | 266 | (define pad (if (and (<= overlap (/ e1-w 2)) 267 | (<= overlap (/ e1-h 2)) 268 | (<= overlap (/ e2-w 2)) 269 | (<= overlap (/ e2-h 2))) 270 | overlap 271 | 0)) 272 | (if (and (>= (- e1-x e2-x) (- (- (+ (/ e1-w 2) (/ e2-w 2)) pad))) 273 | (<= (- e1-x e2-x) (- (+ (/ e1-w 2) (/ e2-w 2)) pad)) 274 | (>= (- e1-y e2-y) (- (- (+ (/ e1-h 2) (/ e2-h 2)) pad))) 275 | (<= (- e1-y e2-y) (- (+ (/ e1-h 2) (/ e2-h 2)) pad))) 276 | #t 277 | #f)) 278 | 279 | (define (get-nearest-entity-to e g #:filter [f identity]) 280 | (define all-es (filter f (game-entities g))) 281 | (define (ui? e) 282 | (and ((has-component? layer?) e) 283 | (eq? (get-layer e) "ui"))) 284 | 285 | (define (not-ui? e) 286 | (not (ui? e))) 287 | 288 | (define all-but-me-and-player 289 | (~> all-es 290 | (remove e _ entity-eq?) 291 | (filter not-ui? _))) 292 | 293 | (define (closer-to-player? e1 e2) 294 | (< (distance-between (get-posn e1) (get-posn e)) 295 | (distance-between (get-posn e2) (get-posn e)))) 296 | 297 | (define sorted-list (sort all-but-me-and-player 298 | closer-to-player?)) 299 | 300 | #;(displayln (~a "NEAREST ENTITY: " (if (empty? sorted-list) 301 | "NONE" 302 | (get-name (first sorted-list))))) 303 | 304 | (first sorted-list)) 305 | 306 | -------------------------------------------------------------------------------- /entity-helpers/particles.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../game-entities.rkt" 4 | "../components/every-tick.rkt" 5 | "../components/after-time.rkt" 6 | "../components/do-every.rkt" 7 | "../components/animated-sprite.rkt" 8 | "../components/speed.rkt" 9 | "../components/direction.rkt" 10 | "../components/on-start.rkt" 11 | "../components/on-edge.rkt" 12 | "../components/backdrop.rkt" 13 | "../components/storage.rkt" 14 | "../component-util.rkt" 15 | "../ai.rkt" 16 | "./sprite-util.rkt" 17 | 2htdp/image 18 | posn 19 | threading) 20 | 21 | (provide ;custom-particles 22 | (rename-out (custom-particle-system custom-particles)) 23 | particle-system) 24 | 25 | (define green-star (star 5 'solid 'black)) 26 | 27 | (define (custom-particles 28 | #:sprite (sprite green-star) 29 | #:speed (s 5) 30 | #:scale-each-tick (scale-each-tick 1.01) 31 | #:direction-min-max (dir '(0 360)) 32 | #:particle-time-to-live (ttl 25) 33 | #:system-time-to-live (sttl 10)) 34 | 35 | (precompile! sprite) 36 | (define (randomize-color) 37 | (lambda (g e) 38 | (define as (get-component e animated-sprite?)) 39 | (define new-c (first (shuffle (list 'red 'orange 'yellow 'green 'blue 'indigo 'violet)))) 40 | (update-entity e animated-sprite? (struct-copy animated-sprite as 41 | [color new-c])))) 42 | (define particle 43 | (sprite->entity sprite 44 | #:position (posn 0 0) 45 | #:name "particle" 46 | #:components 47 | (speed s) 48 | (direction 0) 49 | (every-tick (do-many 50 | (randomize-color) 51 | (scale-sprite scale-each-tick) 52 | (change-direction-by-random -15 15) 53 | (move) 54 | )) 55 | (on-start (do-many (randomize-color) 56 | (random-direction (first dir) 57 | (second dir)))) 58 | (after-time ttl die) 59 | (on-edge 'left die) 60 | (on-edge 'right die) 61 | (on-edge 'top die) 62 | (on-edge 'bottom die))) 63 | 64 | (sprite->entity empty-image 65 | #:position (posn 0 0) 66 | #:name "particle-system" 67 | #:components 68 | ;(every-tick (spawn-on-current-tile particle)) 69 | (on-start (do-many (spawn-on-current-tile particle) 70 | (spawn-on-current-tile particle) 71 | (spawn-on-current-tile particle) 72 | (spawn-on-current-tile particle) 73 | (spawn-on-current-tile particle))) 74 | (do-every 5 (do-many (spawn-on-current-tile particle) 75 | (spawn-on-current-tile particle) 76 | (spawn-on-current-tile particle) 77 | (spawn-on-current-tile particle) 78 | (spawn-on-current-tile particle))) 79 | (after-time sttl die))) 80 | 81 | ; Returns a single entity with multiple particle sprites that shoot outwards randomly 82 | ; Todo: add option to create sprites over time. 83 | (define (custom-particle-system 84 | #:sprite [sprite green-star] 85 | #:color [col 'rainbow] 86 | #:amount-of-particles [amount 10] 87 | #:speed [spd 5] 88 | #:scale-each-tick [scale-each-tick 1.01] 89 | #:direction-min-max [dir '(0 360)] 90 | #:particle-time-to-live [ttl 25] 91 | #:system-time-to-live [sttl 35]) ; do we really need spawning over time? 92 | 93 | (precompile! sprite) 94 | 95 | (define (particle-sprite) 96 | (set-sprite-color (cond [(eq? col 'rainbow) (first (shuffle (list 'red 'orange 'yellow 'green 'blue 'indigo 'violet)))] 97 | [(eq? col 'none) 'black] 98 | [(eq? col #f) 'black] 99 | [else col]) sprite)) 100 | 101 | (define particle-sprites 102 | (map (λ(x) (particle-sprite)) (range amount))) 103 | 104 | (define pid-list (map component-id particle-sprites)) 105 | 106 | (define starting-directions 107 | (map (λ(x) 0) (range amount))) 108 | 109 | (define particle-id (random 1000000)) 110 | 111 | (define (do-particle-fx g e) 112 | (define starting-directions (second (get-storage-data (~a "particle-" particle-id) e))) 113 | (define current-particle-sprites (get-components e (λ(c) (member (component-id c) pid-list)))) 114 | ;random color, scale sprite, changes direction by -15 to 15, and move 115 | (define new-particle-sprites 116 | (map (λ (s d) 117 | (~> s 118 | (move-sprite #:direction (+ d (random -45 46)) #:speed spd) 119 | (ml-set-color (cond [(eq? col 'rainbow) (first (shuffle (list 'red 'orange 'yellow 'green 'blue 'indigo 'violet)))] 120 | [(eq? col 'none) 'black] 121 | [(eq? col #f) 'black] 122 | [else col]) 123 | _) 124 | (scale-xy scale-each-tick _))) 125 | current-particle-sprites starting-directions)) 126 | (~> e 127 | (remove-components _ (λ(c) (member (component-id c) pid-list))) 128 | (add-components _ new-particle-sprites))) 129 | 130 | (define particle-fx-component (every-tick do-particle-fx)) 131 | 132 | (define (set-starting-directions g e) 133 | (define p-storage (get-storage-data (~a "particle-" particle-id) e)) 134 | (define new-random-directions 135 | (map (λ(x) (random (first dir) (second dir))) (range amount))) 136 | ;(displayln (~a "New Random Directions: " new-random-directions)) 137 | (set-storage (~a "particle-" particle-id) e (list particle-sprites new-random-directions))) 138 | 139 | ;(define (remove-particle-system g e) 140 | ; (~> e 141 | ; (remove-components _ (λ(c) (member (component-id c) pid-list))) 142 | ; (remove-components _ (curry component-eq? particle-fx-component)) 143 | ; (remove-storage (~a "particle-" particle-id) _))) 144 | 145 | (sprite->entity particle-sprites 146 | #:position (posn 0 0) 147 | #:name "particle-system" 148 | #:components (storage (~a "particle-" particle-id) (list particle-sprites starting-directions)) 149 | (on-start set-starting-directions) 150 | particle-fx-component 151 | ;(after-time ttl remove-particle-system) ;No need to remove system for now, just kill the entity 152 | (after-time ttl die) ;Todo: add particle sprites over time? 153 | ) 154 | ) 155 | 156 | ; This is only used for hit particles at the moment 157 | ; Creates 5 particles with random x and y offsets which change randomly every tick. 158 | ; Returns a system of components 159 | (define (particle-system #:sprite (sprite green-star) 160 | #:speed (s 5) 161 | #:scale-each-tick (scale-each-tick 1.01) 162 | #:direction-min-max (dir '(0 360)) 163 | #:particle-time-to-live (ttl 25) 164 | #:system-time-to-live (sttl 10)) 165 | (precompile! sprite) 166 | 167 | (define (particle-sprite) 168 | (~> (ensure-sprite sprite) 169 | (set-x-offset (random -5 6) _) 170 | (set-y-offset (random -5 6) _) 171 | (set-sprite-color (first (shuffle (list 'red 'orange 'yellow 'green 'blue 'indigo 'violet))) _))) 172 | 173 | (define particle-sprites 174 | (list (particle-sprite) 175 | (particle-sprite) 176 | (particle-sprite) 177 | (particle-sprite) 178 | (particle-sprite))) 179 | 180 | (define particle-id (random 1000000)) 181 | (define pid-list (map component-id particle-sprites)) 182 | 183 | (define (do-particle-fx g e) 184 | (define current-particle-sprites (get-components e (λ(c) (member (component-id c) pid-list)))) 185 | ;change x, y, and scale 186 | (define new-particle-sprites (map (λ (s) 187 | (~> s 188 | (change-x-offset (random -5 6) _) 189 | (change-y-offset (random -5 6) _) 190 | (scale-xy scale-each-tick _))) 191 | current-particle-sprites)) 192 | (~> e 193 | (remove-components _ (λ(c) (member (component-id c) pid-list))) 194 | (add-components _ new-particle-sprites))) 195 | 196 | (define particle-fx-component (every-tick do-particle-fx)) 197 | 198 | (define (remove-particle-system g e) 199 | (~> e 200 | (remove-components _ (λ(c) (member (component-id c) pid-list))) 201 | (remove-components _ (curry component-eq? particle-fx-component)) 202 | (remove-storage (~a "particle-" particle-id) _))) 203 | 204 | (define particle-remove-component (after-time ttl remove-particle-system)) 205 | 206 | (flatten (list particle-sprites 207 | (storage (~a "particle-" particle-id) (list particle-sprites particle-remove-component)) 208 | particle-fx-component 209 | particle-remove-component))) 210 | 211 | 212 | 213 | -------------------------------------------------------------------------------- /entity-helpers/player-util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide start-stop-animation 4 | key-animator-system 5 | player-info-closed? 6 | update-move-info 7 | show-move-info 8 | key-is-down? 9 | ) 10 | 11 | (require 2htdp/image 12 | posn) 13 | (require "../game-entities.rkt") 14 | (require "../component-util.rkt") 15 | (require "../components/animated-sprite.rkt") 16 | (require "../components/backdrop.rkt") 17 | (require "../components/key-movement.rkt") 18 | (require "../components/counter.rkt") 19 | (require "../components/direction.rkt") 20 | (require "../components/rotation-style.rkt") 21 | (require "../components/lock-to.rkt") 22 | (require "../components/on-key.rkt") 23 | (require "../components/observe-change.rkt") 24 | (require "../components/spawn-once.rkt") 25 | (require "../components/on-rule.rkt") 26 | (require "../entity-helpers/sprite-util.rkt") 27 | (require "../entity-helpers/dialog-util.rkt") 28 | (require "../entity-helpers/mouse-util.rkt") 29 | 30 | 31 | (define (start-stop-animation g e1 e2) 32 | (if (moving? g e2) 33 | ((start-animation) g e2) 34 | ((stop-animation) g e2))) 35 | 36 | (define (set-key-direction) 37 | (lambda (g e) 38 | (define vel (get-current-velocity g e)) 39 | (define new-dir (if (equal? vel (posn 0 0)) 40 | 0 41 | (radians->degrees (atan (posn-y vel) (posn-x vel))))) 42 | (update-entity e direction? (direction (modulo new-dir 360))))) 43 | 44 | (define (key-animator-system #:mode [mode 'arrow-keys] #:face-mouse? [face-mouse? #f]) 45 | (define key-list 46 | (cond [(eq? mode 'arrow-keys) (list 'left 'right 'up 'down)] 47 | [(eq? mode 'wasd) (list 'a 'd 'w 's)] 48 | [else (list 'left 'right 'up 'down)])) 49 | (list (direction 0) 50 | (if face-mouse? 51 | (on-rule mouse-in-game? point-to-mouse) 52 | (list (on-key (first key-list) (set-key-direction)) 53 | (on-key (second key-list) (set-key-direction)) 54 | (on-key (third key-list) (set-key-direction)) 55 | (on-key (fourth key-list) (set-key-direction)))) 56 | (observe-change moving? start-stop-animation) 57 | (rotation-style 'left-right) 58 | )) 59 | 60 | (define (player-info-closed? g e) 61 | (not (get-entity "player info" g))) 62 | 63 | (define (update-move-info) 64 | (lambda (g e) 65 | (define pos (get-component e posn?)) 66 | (define pos-x (exact-floor (posn-x pos))) 67 | (define pos-y (exact-floor (posn-y pos))) 68 | (define current-tile (game->current-tile g)) 69 | (define hue (get-hue-val e)) 70 | (define size (get-size-val e)) 71 | (define info-img (draw-dialog (~a "(posn " pos-x " " pos-y ")" 72 | "\nTile: " current-tile 73 | (if hue (~a "\nHue: " (modulo hue 360)) "") 74 | (if size (~a "\nSize: " size) "")))) 75 | ((change-sprite (new-sprite info-img)) g e))) 76 | 77 | (define (show-move-info g e) 78 | (define pos (get-component e posn?)) 79 | (define pos-x (exact-floor (posn-x pos))) 80 | (define pos-y (exact-floor (posn-y pos))) 81 | (define current-tile (game->current-tile g)) 82 | (define height (image-height (render (get-component e animated-sprite?)))) 83 | (define hue (get-hue-val e)) 84 | (define size (get-size-val e)) 85 | (define info-entity 86 | (sprite->entity (draw-dialog (~a "(posn " pos-x " " pos-y ")" 87 | "\nTile: " current-tile 88 | (if hue (~a "\nHue: " (modulo hue 360)) "") 89 | (if size (~a "\nSize: " size) ""))) 90 | #:position (posn 0 (+ 10 (/ height 2))) 91 | #:name "player info" 92 | #:components (static) 93 | (lock-to "player" #:offset (posn 0 (+ 10 (/ height 2)))) 94 | (on-key "o" die) 95 | (on-rule player-is-moving? (update-move-info)))) 96 | (add-component e (spawn-once info-entity))) 97 | 98 | (define (key-is-down? key) 99 | (lambda (g e) 100 | (button-down? key g))) 101 | -------------------------------------------------------------------------------- /entity-helpers/render-util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide get-sprites-with-top 4 | draw-sprite 5 | draw-entity 6 | draw-entities 7 | draw-game) 8 | 9 | (require 2htdp/image 10 | posn 11 | threading) 12 | (require "../game-entities.rkt") 13 | (require "../components/animated-sprite.rkt") 14 | (require "../components/storage.rkt") 15 | (require "../entity-helpers/rgb-hsb.rkt") 16 | 17 | 18 | (define (get-sprites-with-top e) 19 | (define all-as (get-components e animated-sprite?)) 20 | (define top-posn (if (get-storage "Top" e) 21 | (get-component (get-storage-data "Top" e) posn?) 22 | (posn 0 0))) 23 | (define updated-top-sprites 24 | (if (get-storage "Top" e) 25 | (let ([top-sprites (get-components (get-storage-data "Top" e) animated-sprite?)]) 26 | (map (compose (curry set-x-offset (posn-x top-posn)) 27 | (curry set-y-offset (posn-y top-posn))) top-sprites)) 28 | '())) 29 | (append all-as updated-top-sprites)) 30 | 31 | ; ==== Draw Functions for Documentation Only ==== 32 | (define/contract (draw-sprite s) 33 | (-> sprite? image?) 34 | (if (image? s) 35 | s 36 | (if (eq? (get-color s) 'black) 37 | (~> s 38 | (render _) 39 | (rotate (- (get-rotation s)) _)) 40 | (~> s 41 | (render _) 42 | (rotate (- (get-rotation s)) _) 43 | (tint-img (get-color s) _)) 44 | ))) 45 | 46 | (define (draw-entity e) 47 | (define ss (reverse (get-sprites-with-top e))) 48 | 49 | (if (empty? ss) 50 | empty-image 51 | (overlay-sprites ss))) 52 | 53 | (define/contract (overlay-sprites ss) 54 | (-> (listof animated-sprite?) 55 | image?) 56 | 57 | (define current-image 58 | (draw-sprite (first ss))) 59 | 60 | (if (= 1 (length ss)) 61 | current-image 62 | (overlay/offset 63 | current-image 64 | (- (animated-sprite-x-offset (first ss))) 65 | (- (animated-sprite-y-offset (first ss))) 66 | (overlay-sprites (rest ss))))) 67 | 68 | (define (draw-entities es) 69 | (if (= 1 (length es)) 70 | (draw-entity (first es)) 71 | (let* ([p (get-component (first es) posn?)] 72 | ;[p-top (if (get-storage "Top" (first es)) 73 | ; (get-component (get-storage-data "Top" (first es)) 74 | [x (posn-x p)] 75 | [y (posn-y p)]) 76 | (place-image (draw-entity (first es)) 77 | x y 78 | (draw-entities (rest es)))))) 79 | 80 | (define/contract (draw-game g) 81 | (-> game? image?) 82 | (define (not-hidden e) (and (not (get-component e hidden?)) 83 | (not (get-component e disabled?)))) 84 | (define not-hidden-entities (filter not-hidden (game-entities g))) 85 | (define regular-entities (filter not-ui? not-hidden-entities)) 86 | (define ui-entities (filter ui? not-hidden-entities)) 87 | (define entities (append ui-entities regular-entities)) 88 | (draw-entities entities)) 89 | 90 | ; ===================================================== 91 | -------------------------------------------------------------------------------- /entity-helpers/rgb-hsb.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide change-img-hue ; 0 to 360 4 | change-img-sat ; 0 to 100 5 | change-img-bright ; 0 to 100 6 | change-img-alpha ; 0 255 7 | 8 | set-img-hue ; 0 to 360 9 | set-img-sat ; 0 to 100 10 | set-img-bright ; 0 to 100 11 | set-img-alpha ; 0 to 255 12 | 13 | tint-img 14 | mask 15 | mask-pixel 16 | name->color 17 | name->color-hsb 18 | name->hue 19 | name->sat 20 | 21 | rgb->hue 22 | make-color-hue 23 | scale-to-fit 24 | iconify-img 25 | 26 | (struct-out color-hsb) 27 | make-color-hsb 28 | 29 | hsb->color 30 | 31 | has-color? 32 | set-img-color 33 | ) 34 | 35 | (require 2htdp/image) 36 | 37 | (define (name->color string) 38 | (first (image->color-list (square 1 "solid" string)))) 39 | 40 | (define (name->color-hsb string) 41 | (color->color-hsb (name->color string))) 42 | 43 | (define (name->hue string) 44 | (define c (name->color string)) 45 | (rgb->hue (color-red c) (color-green c) (color-blue c))) 46 | 47 | (define (name->sat string) 48 | (define c (name->color string)) 49 | (color-hsb-sat (color->color-hsb c))) 50 | 51 | (define (mask-pixel color1 color2) 52 | (if (eq? (color-alpha color1) 0) 53 | (make-color 0 0 0 0) 54 | color2)) 55 | 56 | (define (mask image1 image2) 57 | (define image1-list (image->color-list image1)) 58 | (define image2-list (image->color-list image2)) 59 | (color-list->bitmap (map mask-pixel image1-list image2-list) (image-width image1) (image-height image1))) 60 | 61 | 62 | (define (tint-img color img) 63 | (define c (name->color color)) 64 | (define tint-color (make-color (color-red c) (color-green c) (color-blue c) 128)) 65 | ;(displayln tint-color) 66 | (define tinted-image (overlay (rectangle (image-width img) (image-height img) "solid" tint-color) img)) 67 | (mask img tinted-image)) 68 | 69 | (provide (rename-out (make-color-hue color-from-hue))) 70 | 71 | #|(define/contract (make-color-hue hue [a 255]) 72 | (->* (number?) (number?) color?) 73 | (cond 74 | [(< hue 42.5) (make-color 255 75 | (* hue 6) 76 | 0 77 | a)] 78 | [(< hue 85) (make-color (- 255 (exact-round (* (- hue 42.5) 6))) 79 | 255 80 | 0 81 | a)] 82 | [(< hue 127.5) (make-color 0 83 | 255 84 | (exact-round (* (- hue 85) 6)) 85 | a)] 86 | [(< hue 170) (make-color 0 87 | (- 255 (exact-round (* (- hue 127.5) 6))) 88 | 255 89 | a)] 90 | [(< hue 212.5) (make-color (exact-round (* (- hue 170) 6)) 91 | 0 92 | 255 93 | a)] 94 | [else (make-color 255 95 | 0 96 | (- 255 (exact-round (* (- hue 212.5) 6))) 97 | a)]))|# 98 | 99 | (define/contract (make-color-hue hue [a 255]) 100 | (->* (number?) (number?) color?) 101 | (cond 102 | [(< hue 42.5) (make-color 255 103 | (* hue 6) 104 | 0 105 | a)] 106 | [(< hue 85) (make-color (- 255 (exact-round (* (- hue 42.5) 6))) 107 | 255 108 | 0 109 | a)] 110 | [(< hue 127.5) (make-color 0 111 | 255 112 | (exact-round (* (- hue 85) 6)) 113 | a)] 114 | [(< hue 170) (make-color 0 115 | (- 255 (exact-round (* (- hue 127.5) 6))) 116 | 255 117 | a)] 118 | [(< hue 212.5) (make-color (exact-round (* (- hue 170) 6)) 119 | 0 120 | 255 121 | a)] 122 | [else (make-color 255 123 | 0 124 | (- 255 (exact-round (* (- hue 212.5) 6))) 125 | a)])) 126 | 127 | (define/contract (make-color-hue-equal-brightness hue [a 255]) 128 | (->* (number?) (number?) color?) 129 | (cond 130 | [(< hue 85) (make-color (- 255 (* hue 3)) 131 | (* hue 3) 132 | 0 133 | a)] 134 | [(< hue 170) (make-color 0 135 | (- 255 (* (- hue 85) 3)) 136 | (* (- hue 85) 3) 137 | a)] 138 | [else (make-color (* (- hue 170) 3) 139 | 0 140 | (- 255 (* (- hue 170) 3)) 141 | a)])) 142 | 143 | (struct color-hsb 144 | (hue sat bright alpha)) 145 | 146 | (define (make-color-hsb hue [sat 100] [bright 100] [alpha 255]) 147 | (color-hsb hue sat bright alpha)) 148 | 149 | (define (color->color-hsb c) 150 | (define r (/ (color-red c) 255)) 151 | (define g (/ (color-green c) 255)) 152 | (define b (/ (color-blue c) 255)) 153 | (define a (color-alpha c)) 154 | (define mx (max r g b)) 155 | (define mn (min r g b)) 156 | (define d (- mx mn)) 157 | (define hue (cond 158 | [(= mx mn) (define h 0) 159 | (exact-round (* h 60))] 160 | [(= mx r) (define h (+ (/ (- g b) d) (if (< g b) 6 0))) 161 | (exact-round (* h 60))] 162 | [(= mx g) (define h (+ (/ (- b r) d) 2)) 163 | (exact-round (* h 60))] 164 | [(= mx b) (define h (+ (/ (- r g) d) 4)) 165 | (exact-round (* h 60))])) 166 | (define sat (if (= mx 0) 167 | 0 168 | (exact-round (* 100 (/ (- mx mn) mx))))) 169 | (define bright (exact-round (* (max r g b) 100))) 170 | (make-color-hsb hue sat bright a)) 171 | 172 | (define (rgb->hue red green blue) 173 | (define r (/ red 255)) 174 | (define g (/ green 255)) 175 | (define b (/ blue 255)) 176 | (define mx (max r g b)) 177 | (define mn (min r g b)) 178 | (define d (- mx mn)) 179 | (cond 180 | [(= mx mn) (define h 0) 181 | (exact-round (* h 60))] 182 | [(= mx r) (define h (+ (/ (- g b) d) (if (< g b) 6 0))) 183 | (exact-round (* h 60))] 184 | [(= mx g) (define h (+ (/ (- b r) d) 2)) 185 | (exact-round (* h 60))] 186 | [(= mx b) (define h (+ (/ (- r g) d) 4)) 187 | (exact-round (* h 60))])) 188 | 189 | 190 | (define (rgb->sat r g b) 191 | (define mx (max r g b)) 192 | (define mn (min r g b)) 193 | (if (= mx 0) 194 | 0 195 | (exact-round (* 100 (/ (- mx mn) mx))))) 196 | 197 | (define (rgb->bright r g b) 198 | (exact-round (* (/ (max r g b) 255) 100))) 199 | 200 | (define (hsb->color c) 201 | (define h (/ (color-hsb-hue c) 360)) 202 | (define s (/ (color-hsb-sat c) 100)) 203 | (define b (/ (color-hsb-bright c) 100)) 204 | (define a (color-hsb-alpha c)) 205 | (define i (exact-floor (* h 6))) 206 | (define f (- (* h 6) i)) 207 | (define p (* b (- 1 s))) 208 | (define q (* b (- 1 (* f s)))) 209 | (define t (* b (- 1 (* (- 1 f) s)))) 210 | (define B (exact-floor (* b 255))) 211 | (define P (exact-round (* p 255))) 212 | (define Q (exact-round (* q 255))) 213 | (define T (exact-round (* t 255))) 214 | (define case (remainder i 6)) 215 | (cond 216 | [(= case 0) (make-color B T P a)] 217 | [(= case 1) (make-color Q B P a)] 218 | [(= case 2) (make-color P B T a)] 219 | [(= case 3) (make-color P Q B a)] 220 | [(= case 4) (make-color T P B a)] 221 | [(= case 5) (make-color B P Q a)])) 222 | 223 | (define (change-hue amount c) 224 | ;(define hsb-c (color->color-hsb c)) 225 | ;(define new-hue (modulo (+ (color-hsb-hue hsb-c) amount) 360)) 226 | (if (= (color-alpha c) 0) 227 | c 228 | (let ([hsb-c (color->color-hsb c)]) 229 | (hsb->color (struct-copy color-hsb hsb-c 230 | [hue (modulo (+ (color-hsb-hue hsb-c) amount) 360)]))))) 231 | 232 | (define (change-sat amount c) 233 | ;(define hsb-c (color->color-hsb c)) 234 | ;(define new-sat (max 0 (min 100 (+ (color-hsb-sat hsb-c) amount)))) 235 | (if (= (color-alpha c) 0) 236 | c 237 | (let ([hsb-c (color->color-hsb c)]) 238 | (hsb->color (struct-copy color-hsb hsb-c 239 | [sat (max 0 (min 100 (+ (color-hsb-sat hsb-c) amount)))]))))) 240 | 241 | (define (change-bright amount c) 242 | ;(define hsb-c (color->color-hsb c)) 243 | ;(define new-bright (max 0 (min 100 (+ (color-hsb-bright hsb-c) amount)))) 244 | (if (= (color-alpha c) 0) 245 | c 246 | (let ([hsb-c (color->color-hsb c)]) 247 | (hsb->color (struct-copy color-hsb hsb-c 248 | [bright (max 0 (min 100 (+ (color-hsb-bright hsb-c) amount)))]))))) 249 | 250 | (define (change-alpha amount c) 251 | (if (= (color-alpha c) 0) 252 | c 253 | (struct-copy color c 254 | [alpha (max 0 (min 255 (+ (color-alpha c) amount)))]))) 255 | 256 | (define (set-hue amount c) 257 | (if (= (color-alpha c) 0) 258 | c 259 | (let ([hsb-c (color->color-hsb c)]) 260 | (hsb->color (struct-copy color-hsb hsb-c 261 | [hue (modulo amount 360)]))))) 262 | 263 | (define (set-sat amount c) 264 | (if (= (color-alpha c) 0) 265 | c 266 | (let ([hsb-c (color->color-hsb c)]) 267 | (hsb->color (struct-copy color-hsb hsb-c 268 | [sat (max 0 (min 100 amount))]))))) 269 | 270 | (define (set-bright amount c) 271 | (if (= (color-alpha c) 0) 272 | c 273 | (let ([hsb-c (color->color-hsb c)]) 274 | (hsb->color (struct-copy color-hsb hsb-c 275 | [bright (max 0 (min 100 amount))]))))) 276 | 277 | (define (set-alpha amount c) 278 | (if (= (color-alpha c) 0) 279 | c 280 | (struct-copy color c 281 | [alpha (max 0 (min 255 amount))]))) 282 | 283 | (define (change-img-hue amount image) 284 | (define image-list (image->color-list image)) 285 | (color-list->bitmap (map (curry change-hue amount) image-list) (image-width image) (image-height image))) 286 | 287 | (define (change-img-sat amount image) 288 | (define image-list (image->color-list image)) 289 | (color-list->bitmap (map (curry change-sat amount) image-list) (image-width image) (image-height image))) 290 | 291 | (define (change-img-bright amount image) 292 | (define image-list (image->color-list image)) 293 | (color-list->bitmap (map (curry change-bright amount) image-list) (image-width image) (image-height image))) 294 | 295 | (define (change-img-alpha amount image) 296 | (define image-list (image->color-list image)) 297 | (color-list->bitmap (map (curry change-alpha amount) image-list) (image-width image) (image-height image))) 298 | 299 | (define (set-img-hue amount image) 300 | (define image-list (image->color-list image)) 301 | (color-list->bitmap (map (curry set-hue amount) image-list) (image-width image) (image-height image))) 302 | 303 | (define (set-img-sat amount image) 304 | (define image-list (image->color-list image)) 305 | (color-list->bitmap (map (curry set-sat amount) image-list) (image-width image) (image-height image))) 306 | 307 | (define (set-img-bright amount image) 308 | (define image-list (image->color-list image)) 309 | (color-list->bitmap (map (curry set-bright amount) image-list) (image-width image) (image-height image))) 310 | 311 | (define (set-img-alpha amount image) 312 | (define image-list (image->color-list image)) 313 | (color-list->bitmap (map (curry set-alpha amount) image-list) (image-width image) (image-height image))) 314 | 315 | (define/contract (scale-to-fit i w) 316 | (-> image? number? image?) 317 | (define longer-side (if (> (image-width i) (image-height i)) 318 | (image-width i) 319 | (image-height i))) 320 | (scale (/ w longer-side) i)) 321 | 322 | (define (has-color? image [threshold 0.2]) 323 | (define (transparent-pixel? c) 324 | (= (color-alpha c) 0)) 325 | (define (color-pixel? hsb-color) 326 | (and (> (color-hsb-sat hsb-color) 50) 327 | (> (color-hsb-bright hsb-color) 50))) 328 | 329 | (define hsb-image-list (map color->color-hsb (filter-not transparent-pixel? (image->color-list image)))) 330 | 331 | (define color-list (filter color-pixel? hsb-image-list)) 332 | (>= (length color-list) (* (length hsb-image-list) threshold))) 333 | 334 | (define (set-img-color color-name image) 335 | (if (has-color? image) 336 | (let ([hue (color-hsb-hue (name->color-hsb color-name))]) 337 | (set-img-hue hue image)) 338 | (tint-img color-name image))) 339 | 340 | ;useful function! provide out or put elsewhere 341 | ;creates silhouettes of an image -- turning every pixel 342 | ;that is not 100% transparent to one solid color 343 | (define (iconify-img img [t-color 'black]) 344 | 345 | (define target-color (if (color? t-color) 346 | t-color 347 | (name->color t-color))) 348 | 349 | (define (maybe-color-pixel original-color) 350 | (mask-pixel original-color target-color)) 351 | 352 | (define original-list (image->color-list img)) 353 | (define final-list (map maybe-color-pixel original-list)) 354 | (color-list->bitmap final-list (image-width img) (image-height img))) 355 | 356 | ;(define (grayscale-img img) 357 | ; (define image-list (image->color-list img)) 358 | ; (color-list->bitmap (map (curry 359 | -------------------------------------------------------------------------------- /entity-helpers/sprite-util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide change-sprite 4 | set-size 5 | scale-sprite 6 | rotate-sprite 7 | random-dec 8 | random-size 9 | set-color 10 | change-color-by 11 | random-color 12 | random-tint 13 | spawn 14 | ;open-dialog 15 | hide 16 | show 17 | start-animation 18 | stop-animation 19 | stop-all-animations 20 | start-first-animation 21 | stop-first-animation 22 | simple-scale-sprite 23 | ml-set-color 24 | scale-and-crop-to) 25 | 26 | (provide (all-from-out "./rgb-hsb.rkt")) 27 | 28 | (require 2htdp/image) 29 | (require "../game-entities.rkt") 30 | (require "../components/animated-sprite.rkt") 31 | (require "../components/direction.rkt") 32 | (require "../components/rotation-style.rkt") 33 | (require "../components/spawn-once.rkt") 34 | (require "../components/spawn-dialog.rkt") 35 | (require "./rgb-hsb.rkt") 36 | (require "../components/after-time.rkt") 37 | (require "../component-util.rkt") 38 | (require "../engine/component-struct.rkt") 39 | ;(require "../ai.rkt") 40 | 41 | (require posn 42 | threading) 43 | 44 | #|(define (change-sprite sprite-or-func) 45 | (lambda (g e) 46 | (define sprite (if (procedure? sprite-or-func) 47 | (sprite-or-func) 48 | sprite-or-func)) 49 | (define new-bb (image->bb (render sprite))) 50 | (update-entity (update-entity e animated-sprite? sprite) 51 | bb? 52 | new-bb)))|# 53 | 54 | (define (change-sprite sprite-func-or-list) 55 | (lambda (g e) 56 | (define sprites-list (flatten (if (procedure? sprite-func-or-list) 57 | (sprite-func-or-list) 58 | sprite-func-or-list))) 59 | (~> e 60 | (remove-components _ animated-sprite?) 61 | (add-components _ (reverse sprites-list))))) 62 | 63 | (define (set-size amount) 64 | (lambda (g e) 65 | (update-entity e animated-sprite? 66 | (curry set-scale-xy amount)))) 67 | 68 | (define (not-after-time-die? c) 69 | (not (eq? (after-time-func c) die))) 70 | 71 | 72 | ; ONLY USE IF THE ENTITY HAS A SINGLE SPRITE 73 | (define (simple-scale-sprite amount) 74 | (lambda (g e) 75 | (define as (get-component e animated-sprite?)) 76 | (update-entity e animated-sprite? (scale-xy amount as)))) 77 | 78 | ;if there is a duration, assume it's a power-up and filter out TOASTS AND PARTICLES! 79 | ;DON'T USE THIS TO SCALE TOASTS OR PARTCILES! Use scale-xy instead 80 | (define (scale-sprite amount #:for [d #f]) 81 | (lambda (g e) 82 | (define all-sprites (get-components e (and/c animated-sprite? 83 | (not-toast-sprite? e) 84 | (not-particle-sprite? e)))) 85 | (define original-sprites (map (λ (as) (struct-copy animated-sprite as)) all-sprites)) 86 | 87 | (define (revert-back g e) 88 | (~> e 89 | (remove-components _ (and/c animated-sprite? 90 | (λ (c) 91 | (member c original-sprites component-eq?)))) ;This removes new sprites since original! 92 | (add-components _ original-sprites)) ;This adds toasts even when they should have been removed! 93 | ) 94 | 95 | (define (scale-a-sprite as) 96 | (define xs (get-x-scale as)) 97 | (define ys (get-y-scale as)) 98 | (define xo (get-x-offset as)) 99 | (define yo (get-y-offset as)) 100 | (struct-copy animated-sprite as 101 | [x-scale (* xs amount)] 102 | [y-scale (* ys amount)] 103 | [x-offset (* xo amount)] 104 | [y-offset (* yo amount)])) 105 | 106 | (define new-sprites (map scale-a-sprite original-sprites)) 107 | 108 | (define (update-revert dur) 109 | (define old-func (after-time-func (get-component e (and/c after-time? 110 | not-after-time-die? 111 | (not-particle-remove? e) 112 | (not-toast-remove? e) 113 | )))) 114 | (if dur 115 | (λ (c) 116 | (after-time dur (do-many revert-back 117 | old-func))) 118 | #f)) 119 | 120 | (if (get-component e (and/c after-time? 121 | not-after-time-die? 122 | (not-particle-remove? e) 123 | (not-toast-remove? e))) 124 | (~> e 125 | (remove-components _ (and/c animated-sprite? 126 | (not-toast-sprite? e) 127 | (not-particle-sprite? e))) 128 | (add-components _ new-sprites) 129 | 130 | ;this will break any non power up after-time component 131 | (update-entity _ (and/c after-time? 132 | not-after-time-die? 133 | (not-particle-remove? e) 134 | (not-toast-remove? e)) (update-revert d))) 135 | (~> e 136 | (remove-components _ (and/c animated-sprite? 137 | (not-toast-sprite? e) 138 | (not-particle-sprite? e))) 139 | (add-components _ new-sprites) 140 | (add-components _ (if d (after-time d revert-back) '())) 141 | ) 142 | ) 143 | )) 144 | 145 | ; This doesn't need a #:for feature unless we really want 146 | ; a power up that rotates you for some duration. 147 | ; Commenting out revert with #f because it breaks removal of particles on player death 148 | ; It's probably better to not use this handler internally. 149 | ; Use set-sprite-angle or change-sprite-angle-by instead 150 | (define (rotate-sprite amount #:for [d #f]) 151 | (lambda (g e) 152 | (define all-sprites (get-components e (and/c animated-sprite? 153 | (not-toast-sprite? e) 154 | (not-particle-sprite? e)))) 155 | (define original-sprites (map (λ (as) (struct-copy animated-sprite as)) all-sprites)) 156 | 157 | (define (revert-back g e) 158 | (~> e 159 | (remove-components _ (and/c animated-sprite? 160 | (λ (c) 161 | (member c original-sprites component-eq?)))) 162 | (add-components _ original-sprites)) 163 | ) 164 | 165 | (define (rotate-a-sprite as) 166 | (define rot (get-rotation as)) 167 | (struct-copy animated-sprite as 168 | [rotation (degrees->radians (+ rot amount))])) 169 | 170 | (define new-sprites (map rotate-a-sprite original-sprites)) 171 | 172 | (define (update-revert dur) 173 | (define old-func (after-time-func (get-component e (and/c after-time? 174 | not-after-time-die? 175 | (not-particle-remove? e) 176 | (not-toast-remove? e) 177 | )))) 178 | (if dur 179 | (λ (c) 180 | (after-time dur (do-many revert-back 181 | old-func))) 182 | (λ (c) c))) ;if dur is #f, leave the component alone! 183 | 184 | (if (get-component e (and/c after-time? 185 | not-after-time-die? 186 | (not-particle-remove? e) 187 | (not-toast-remove? e))) 188 | (~> e 189 | (remove-components _ (and/c animated-sprite? 190 | (not-toast-sprite? e) 191 | (not-particle-sprite? e))) 192 | (add-components _ new-sprites) 193 | 194 | ;this will break any non power up after-time component 195 | (update-entity _ (and/c after-time? 196 | not-after-time-die? 197 | (not-particle-remove? e) 198 | (not-toast-remove? e)) (update-revert d))) 199 | (~> e 200 | (remove-components _ (and/c animated-sprite? 201 | (not-toast-sprite? e) 202 | (not-particle-sprite? e))) 203 | (add-components _ new-sprites) 204 | (add-components _ (if d (after-time d revert-back) '()))) 205 | ) 206 | 207 | )) 208 | 209 | (define (random-dec min max) 210 | (define new-min (exact-round (* min 100))) 211 | (define new-max (exact-round (* max 100))) 212 | (/ (random new-min (add1 new-max)) 100)) 213 | 214 | (define (random-size min max) 215 | (lambda (g e) 216 | (update-entity e animated-sprite? 217 | (curry set-scale-xy (+ min (* (random) (- max min))))))) 218 | 219 | ;This is broken... 220 | ;Not broken anymore, but recompiles each color change. 221 | ;todo: use mode lambda for color changing 222 | (define (change-color-by amount) 223 | (lambda (g e) 224 | (define s (get-component e animated-sprite?)) 225 | (define frames (animated-sprite-o-frames s)) 226 | (define (ensure-image image-or-fast-image) 227 | (if (fast-image? image-or-fast-image) 228 | (fast-image-data image-or-fast-image) 229 | image-or-fast-image)) 230 | (define image-frames (map ensure-image (vector->list frames))) 231 | (define new-list (map fast-image (map (curry change-img-hue amount) image-frames))) 232 | (update-entity e animated-sprite? (struct-copy animated-sprite s 233 | [frames (list->vector new-list)] 234 | [o-frames (list->vector new-list)] 235 | )))) 236 | 237 | (define (set-color amount) 238 | (lambda (g e) 239 | (define s (get-component e animated-sprite?)) 240 | (define frames (animated-sprite-o-frames s)) 241 | (define new-list (map (curry change-img-hue amount) (vector->list frames))) 242 | (update-entity e animated-sprite? 243 | (struct-copy animated-sprite s [frames (list->vector new-list)])))) 244 | 245 | (define/contract (ml-set-color c as) 246 | (-> symbol? animated-sprite? animated-sprite?) 247 | (struct-copy animated-sprite as 248 | [color c])) 249 | 250 | (define (random-color min max) 251 | (lambda (g e) 252 | (define s (get-component e animated-sprite?)) 253 | (define frames (animated-sprite-o-frames s)) 254 | (define hue-change (random min max)) 255 | (define new-list (map (curry change-img-hue hue-change) (vector->list frames))) 256 | (update-entity e animated-sprite? (struct-copy animated-sprite s [frames (list->vector new-list)])))) 257 | 258 | (define (random-tint) 259 | (lambda (g e) 260 | (define s (get-component e animated-sprite?)) 261 | (define frames (animated-sprite-o-frames s)) 262 | (define random-color (make-color-hue (random 255) 255)) 263 | (define new-list (map (curry tint-img random-color) (vector->list frames))) 264 | (update-entity e animated-sprite? (struct-copy animated-sprite s [frames (list->vector new-list)])))) 265 | 266 | (define (spawn s #:relative? [relative? #t] #:rule [rule (λ (g e) #t)]) 267 | (lambda (g e) 268 | (if (rule g e) 269 | (add-component e (spawn-once s #:relative? relative?)) 270 | e))) 271 | 272 | ;(define (open-dialog s) 273 | ; (lambda (g e) 274 | ; (add-component e (spawn-dialog s)))) 275 | 276 | (define (hide g e) 277 | (add-component (remove-component e hidden?) (hidden))) 278 | 279 | (define (show g e) 280 | (remove-component e hidden?)) 281 | 282 | (define (start-animation) 283 | (lambda (g e) 284 | ;(displayln (~a (get-name e) ": STARTING ANIMATION")) 285 | (define as (get-component e animated-sprite?)) 286 | (update-entity e 287 | animated-sprite? 288 | (struct-copy animated-sprite as 289 | [animate? #t])))) 290 | 291 | (define (stop-animation) 292 | (lambda (g e) 293 | ;(displayln (~a (get-name e) ": STOPPING ANIMATION")) 294 | (define as (get-component e animated-sprite?)) 295 | (update-entity e 296 | animated-sprite? 297 | (struct-copy animated-sprite as 298 | [current-frame 0] 299 | [ticks 0] 300 | [animate? #f])))) 301 | 302 | (define (start-first-animation) 303 | (lambda (g e) 304 | ;(displayln (~a (get-name e) ": STARTING ANIMATION")) 305 | (define as (first (get-components e animated-sprite?))) 306 | (update-entity e 307 | animated-sprite? 308 | (struct-copy animated-sprite as 309 | [animate? #t])))) 310 | 311 | (define (stop-first-animation) 312 | (lambda (g e) 313 | ;(displayln (~a (get-name e) ": STOPPING ANIMATION")) 314 | (define as (first (get-components e animated-sprite?))) 315 | (update-entity e 316 | animated-sprite? 317 | (struct-copy animated-sprite as 318 | [current-frame 0] 319 | [ticks 0] 320 | [animate? #f])))) 321 | 322 | (define (stop-all-animations) 323 | (lambda (g e) 324 | ;(displayln (~a (get-name e) ": STOPPING ANIMATION")) 325 | (define all-sprites (get-components e animated-sprite?)) 326 | (define new-sprites (map (curry set-animate? #f) all-sprites)) 327 | (~> e 328 | (remove-components _ animated-sprite?) 329 | (add-components _ new-sprites)))) 330 | 331 | 332 | ; === MOVED FROM ANIMATED-SPRITE === 333 | (provide sheet->sprite 334 | row->sprite 335 | set-sprite-scale 336 | set-sprite-color 337 | set-sprite-angle 338 | set-sprite-x-offset 339 | set-sprite-y-offset 340 | set-sprite-layer) 341 | 342 | ;Convenience methods for going from sheets to sprites 343 | 344 | (define (sheet->sprite sheet #:rows (r 1) 345 | #:columns (c 1) 346 | #:row-number (n 1) 347 | #:speed (speed #f) 348 | #:delay (delay #f) 349 | #:animate? [animate? #t]) 350 | 351 | (define actual-delay (or delay speed 1)) 352 | 353 | (~> sheet 354 | (sheet->costume-list _ c r (* r c)) 355 | (drop _ (* (- n 1) c)) 356 | (take _ c) 357 | (new-sprite _ actual-delay #:animate animate?) 358 | )) 359 | 360 | 361 | (define (row->sprite sheet 362 | #:columns (c 4) 363 | #:row-number (n 1) 364 | #:delay (delay 1)) 365 | 366 | (sheet->sprite sheet 367 | #:rows 1 368 | #:columns c 369 | #:row-number n 370 | #:delay delay)) 371 | 372 | ; === SPRITE MODIFIERS === 373 | ; These are meant to be used at the top level and can take 374 | ; either an image or an animated sprite. These also perform 375 | ; a struct copy on the sprite. For internal usage, use the 376 | ; previous functions for faster performance. 377 | ; TODO: force new cid to ensure uniqueness? 378 | 379 | (define (uniqify-sprite as) 380 | (struct-copy animated-sprite as 381 | [cid #:parent component-struct (next-component-id)])) 382 | 383 | (define/contract (set-sprite-scale s as) 384 | (-> number? (or/c animated-sprite? image?) animated-sprite?) 385 | 386 | #|(define current-x (if (animated-sprite? as) 387 | (get-x-scale as) 388 | 1)) 389 | (define current-y (if (animated-sprite? as) 390 | (get-y-scale as) 391 | 1))|# 392 | (if (animated-sprite? as) 393 | (uniqify-sprite (scale-xy s as)) 394 | (new-sprite as #:scale s))) 395 | 396 | (define/contract (set-sprite-color c as) 397 | (-> symbol? (or/c animated-sprite? image?) animated-sprite?) 398 | 399 | (if (animated-sprite? as) 400 | (uniqify-sprite (struct-copy animated-sprite as 401 | [color c])) 402 | (new-sprite as #:color c)) 403 | ) 404 | 405 | (define/contract (set-sprite-angle v as) 406 | (-> number? (or/c animated-sprite? image?) animated-sprite?) 407 | 408 | (if (animated-sprite? as) 409 | (uniqify-sprite (set-angle v as)) 410 | (new-sprite as #:rotation v)) 411 | ) 412 | 413 | (define/contract (set-sprite-x-offset v as) 414 | (-> number? (or/c animated-sprite? image?) animated-sprite?) 415 | 416 | (if (animated-sprite? as) 417 | (uniqify-sprite (set-x-offset v as)) 418 | (new-sprite as #:x-offset v)) 419 | ) 420 | 421 | (define/contract (set-sprite-y-offset v as) 422 | (-> number? (or/c animated-sprite? image?) animated-sprite?) 423 | 424 | (if (animated-sprite? as) 425 | (uniqify-sprite (set-y-offset v as)) 426 | (new-sprite as #:y-offset v)) 427 | ) 428 | 429 | (define/contract (set-sprite-layer l as) 430 | (-> string? (or/c animated-sprite? image?) animated-sprite?) 431 | 432 | (if (animated-sprite? as) 433 | (uniqify-sprite (struct-copy animated-sprite as 434 | [layer l])) 435 | (new-sprite as #:layer l)) 436 | ) 437 | 438 | (define (scale-and-crop-to w h image [x-align "center"] [y-align "center"]) 439 | (define iw (image-width image)) 440 | (define ih (image-height image)) 441 | (define scale-val (if (> (/ iw ih) (/ w h)) 442 | (/ h ih) 443 | (/ w iw))) 444 | (crop/align x-align y-align w h (scale scale-val image))) 445 | -------------------------------------------------------------------------------- /entity-helpers/text-util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide text-sprite) 4 | 5 | (require "../game-entities.rkt") 6 | (require "../components/animated-sprite.rkt") 7 | 8 | (require 2htdp/image 9 | (only-in racket/draw make-font)) 10 | 11 | (define (text-sprite str-or-list 12 | #:scale [scale 1] 13 | #:font-size [f-size 13] 14 | #:font-face [f-face MONOSPACE-FONT-FACE] 15 | #:font-family [f-family 'modern] 16 | #:font-style [f-style 'normal] 17 | #:font-weight [f-weight 'normal] 18 | #:color [color 'yellow] 19 | #:blink-color [b-color 'red] 20 | #:mode [mode 'normal] 21 | #:delay [delay 20]) 22 | (define new-font (make-font #:size f-size 23 | #:face f-face 24 | #:family f-family 25 | #:style f-style 26 | #:weight f-weight)) 27 | (register-fonts! new-font) 28 | (define str-list (if (list? str-or-list) 29 | str-or-list 30 | (filter identity (list str-or-list 31 | (and (eq? mode 'blink) 32 | str-or-list)) 33 | ))) 34 | (define str-list-with-font-fx 35 | (for/list ([str str-list] 36 | [i (range (length str-list))]) 37 | (cond 38 | [(and (eq? mode 'blink) 39 | (odd? i)) (text-frame str #:font new-font #:color b-color)] 40 | [else (text-frame str #:font new-font #:color color)]))) 41 | (new-sprite str-list-with-font-fx delay)) 42 | -------------------------------------------------------------------------------- /entity-helpers/time-manager.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide time-manager-entity 4 | reached-game-count? 5 | stop-game-counter 6 | reached-multiple-of? 7 | start-stop-game-counter 8 | game-count-between?) 9 | 10 | (require "../game-entities.rkt" 11 | "../components/counter.rkt" 12 | "../components/every-tick.rkt" 13 | "../components/on-start.rkt" 14 | "./movement-util.rkt" 15 | 2htdp/image 16 | posn) 17 | 18 | (define (time-manager-entity #:components [c #f] 19 | . custom-components) 20 | (sprite->entity empty-image 21 | #:name "time manager" 22 | #:position (posn 0 0) 23 | #:components (counter 0) 24 | (layer "ui") 25 | (hidden) 26 | (on-start (go-to-pos 'center)) 27 | (every-tick (change-counter-by 1)) 28 | (cons c custom-components))) 29 | 30 | (define (reached-game-count? num) 31 | (lambda (g e) 32 | (define game-count (get-counter (get-entity "time manager" g))) 33 | (= game-count num))) 34 | 35 | (define (stop-game-counter) 36 | (lambda (g e) 37 | (remove-component e every-tick?))) 38 | 39 | (define (reached-multiple-of? num #:offset [offset 0]) 40 | (lambda (g e) 41 | (define game-count (get-counter (get-entity "time manager" g))) 42 | (= (- (modulo game-count num) offset) 0))) 43 | 44 | (define (start-stop-game-counter) 45 | (lambda (g e) 46 | (if (get-component e every-tick?) 47 | (remove-component e every-tick?) 48 | (add-components e (every-tick (change-counter-by 1)))))) 49 | 50 | (define (game-count-between? min max) 51 | (lambda (g e) 52 | (define game-count (get-counter (get-entity "time manager" g))) 53 | (and (>= game-count min) 54 | (<= game-count max)))) -------------------------------------------------------------------------------- /entity-helpers/ui-util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide bordered-box-sprite 4 | toast-entity 5 | toast-system 6 | ;player-toast-entity ;must remove provides from base langauges first 7 | game-toast-entity 8 | make-rounded-icon) 9 | 10 | (require "../game-entities.rkt" 11 | "../component-util.rkt" 12 | "../components/animated-sprite.rkt" 13 | "../components/direction.rkt" 14 | "../components/speed.rkt" 15 | "../components/on-start.rkt" 16 | "../components/every-tick.rkt" 17 | "../components/after-time.rkt" 18 | "../components/storage.rkt" 19 | "../ai.rkt" 20 | "./sprite-util.rkt" 21 | "./movement-util.rkt") 22 | 23 | (require 2htdp/image 24 | (only-in pict 25 | filled-rounded-rectangle 26 | inset 27 | pict->bitmap) 28 | posn 29 | threading) 30 | 31 | (define (bordered-box-sprite w h #:outer-border-color [outer-border-color 'black] 32 | #:border-color [border-color 'white] 33 | #:color [box-color 'dimgray]) 34 | (define outer-border-img (square 1 'solid outer-border-color)) 35 | (define inner-border-img (square 1 'solid border-color)) 36 | (define box-img (square 1 'solid box-color)) 37 | 38 | (precompile! outer-border-img 39 | inner-border-img 40 | box-img) 41 | 42 | (list (new-sprite box-img 43 | #:animate #f 44 | #:x-scale (- w 6) 45 | #:y-scale (- h 6)) 46 | (new-sprite inner-border-img 47 | #:animate #f 48 | #:x-scale (- w 2) 49 | #:y-scale (- h 2)) 50 | (new-sprite outer-border-img 51 | #:animate #f 52 | #:x-scale w 53 | #:y-scale h) 54 | )) 55 | 56 | (define (toast-entity message #:color [color "yellow"] 57 | #:position [p (posn 0 -20)] 58 | #:duration [dur 15] 59 | #:speed [spd 3]) 60 | (define color-symbol (if (string? color) 61 | (string->symbol color) 62 | color)) 63 | (sprite->entity (list (new-sprite message #:color color-symbol) 64 | (new-sprite message #:x-offset -1 #:y-offset 1 #:color 'black)) 65 | #:name "player toast" 66 | #:position p 67 | #:components (hidden) 68 | (layer "ui") 69 | 70 | (direction 270) 71 | (physical-collider) 72 | (speed spd) 73 | (on-start (do-many (random-direction 240 300) 74 | (random-speed (sub1 spd) (add1 spd)) 75 | show)) 76 | (every-tick (do-many (move) 77 | (scale-sprite 1.03))) 78 | (after-time dur die))) 79 | 80 | (define (toast-system message #:color [color "yellow"] 81 | #:position [p (posn 0 -20)] 82 | #:duration [dur 15] 83 | #:speed [spd 3]) 84 | (define color-symbol (if (string? color) 85 | (string->symbol color) 86 | color)) 87 | (define main-sprite (new-sprite message 88 | #:x-offset (posn-x p) 89 | #:y-offset (posn-y p) 90 | #:color color-symbol)) 91 | (define shadow-sprite (new-sprite message 92 | #:x-offset (+ (posn-x p) -1) 93 | #:y-offset (+ (posn-y p) 1) 94 | #:color 'black)) 95 | (define random-x (random -2 3)) 96 | (define random-y (random (sub1 (- spd)) (+ 2 (- spd)))) 97 | (define toast-id (random 1000000)) 98 | (define tid-list (map component-id (list main-sprite shadow-sprite))) 99 | 100 | (define (do-toast-fx g e) 101 | (define current-main-sprite (get-component e (λ(c) (eq? (component-id c) (first tid-list))))) 102 | (define current-shadow-sprite (get-component e (λ(c) (eq? (component-id c) (second tid-list))))) 103 | ;change x, y, and scale 104 | (define new-main-sprite (~> current-main-sprite 105 | (change-x-offset random-x _) 106 | (change-y-offset random-y _) 107 | (scale-xy 1.03 _))) 108 | (define new-shadow-sprite (~> current-shadow-sprite 109 | (set-x-offset (+ (get-x-offset new-main-sprite) -1) _) 110 | (set-y-offset (+ (get-y-offset new-main-sprite) 1) _) 111 | (scale-xy 1.03 _))) 112 | (~> e 113 | (update-entity _ (curry component-eq? current-main-sprite) new-main-sprite) 114 | (update-entity _ (curry component-eq? current-shadow-sprite) new-shadow-sprite))) 115 | 116 | (define toast-fx-component (every-tick do-toast-fx)) 117 | 118 | (define (remove-toast g e) 119 | (~> e 120 | (remove-components _ (or/c (λ(c) (eq? (component-id c) (first tid-list))) 121 | (λ(c) (eq? (component-id c) (second tid-list))) 122 | (curry component-eq? toast-fx-component))) 123 | (remove-storage (~a "toast-" toast-id) _))) 124 | 125 | (define toast-remove-component (after-time dur remove-toast)) 126 | 127 | (list shadow-sprite 128 | main-sprite 129 | (storage (~a "toast-" toast-id) (list main-sprite shadow-sprite toast-remove-component)) 130 | toast-fx-component 131 | toast-remove-component)) 132 | 133 | 134 | (define (player-toast-entity message #:color [color "yellow"]) 135 | (define color-symbol (if (string? color) 136 | (string->symbol color) 137 | color)) 138 | (sprite->entity (new-sprite message #:x-offset -1 #:y-offset 1 #:color 'black) 139 | #:name "player toast" 140 | #:position (posn 0 0) 141 | #:components (hidden) 142 | (layer "ui") 143 | (new-sprite message #:color color-symbol) 144 | (direction 270) 145 | (speed 3) 146 | (on-start (do-many (go-to-entity "player" #:offset (posn 0 -20)) 147 | (random-direction 240 300) 148 | (random-speed 2 4) 149 | show)) 150 | (every-tick (do-many (move) 151 | (scale-sprite 1.03))) 152 | (after-time 15 die))) 153 | 154 | (define (game-toast-entity message #:color [color "yellow"] 155 | #:position [pos 'bottom] 156 | #:duration [dur 100] 157 | #:speed [spd 0.8] 158 | #:scale [scale 1.0]) 159 | (define color-symbol (if (string? color) 160 | (string->symbol color) 161 | color)) 162 | (sprite->entity (list (new-sprite message #:color color-symbol #:scale scale) 163 | (new-sprite message #:x-offset -1 #:y-offset 1 #:color 'black #:scale scale)) 164 | #:name "player toast" 165 | #:position (posn 0 0) 166 | #:components (hidden) 167 | (layer "ui") 168 | (direction 270) 169 | (speed spd) 170 | (on-start (do-many (cond [(eq? pos 'bottom) (go-to-pos 'bottom-center #:offset -32)] 171 | [(eq? pos 'top) (go-to-pos 'top-center #:offset 32)] 172 | [(eq? pos 'center) (go-to-pos 'center)] 173 | [else (go-to-pos 'bottom-center #:offset -32)]) 174 | ;(random-speed (sub1 spd) (add1 spd)) 175 | show)) 176 | (every-tick (do-many (move) 177 | (random-direction))) 178 | (after-time dur die))) 179 | 180 | (define (make-rounded-icon i [fill-color "yellow"] [border-color "black"]) 181 | (overlay i 182 | (pict->bitmap (inset (filled-rounded-rectangle 32 32 #:color (~a fill-color) 183 | #:border-color (~a border-color) 184 | #:border-width 2) 2)))) 185 | 186 | -------------------------------------------------------------------------------- /game-engine.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide 4 | (all-from-out 2htdp/image) 5 | (all-from-out threading) 6 | (all-from-out posn) 7 | (all-from-out "game-entities.rkt") 8 | (all-from-out "components/key-movement.rkt") 9 | (all-from-out "components/after-time.rkt") 10 | (all-from-out "components/do-every.rkt") 11 | (all-from-out "components/animated-sprite.rkt") 12 | (all-from-out "components/health.rkt") 13 | (all-from-out "components/detect-collide.rkt") 14 | (all-from-out "components/every-tick.rkt") 15 | (all-from-out "components/on-start.rkt") 16 | (all-from-out "components/spawn-once.rkt") 17 | (all-from-out "components/key-animator.rkt") 18 | (all-from-out "components/direction.rkt") 19 | (all-from-out "components/speed.rkt") 20 | (all-from-out "components/counter.rkt") 21 | (all-from-out "components/on-key.rkt") 22 | (all-from-out "components/on-mouse.rkt") 23 | (all-from-out "components/stop-on-edge.rkt") 24 | (all-from-out "components/wrap-around.rkt") 25 | (all-from-out "components/on-edge.rkt") 26 | (all-from-out "components/on-rule.rkt") 27 | (all-from-out "components/detect-edge.rkt") 28 | (all-from-out "components/rotation-style.rkt") 29 | (all-from-out "components/follow.rkt") 30 | (all-from-out "components/sound-stream.rkt") 31 | (all-from-out "components/spawn-dialog.rkt") 32 | (all-from-out "components/lock-to.rkt") 33 | (all-from-out "components/backdrop.rkt") 34 | (all-from-out "components/dialog.rkt") 35 | (all-from-out "components/backpack.rkt") 36 | (all-from-out "components/observe-change.rkt") 37 | (all-from-out "components/producer-of.rkt") 38 | (all-from-out "components/storage.rkt") 39 | (all-from-out "component-util.rkt") 40 | (all-from-out "entity-helpers/movement-util.rkt") 41 | (all-from-out "entity-helpers/sprite-util.rkt") 42 | (all-from-out "entity-helpers/rgb-hsb.rkt") 43 | (all-from-out "entity-helpers/dialog-util.rkt") 44 | (all-from-out "entity-helpers/backpack-util.rkt") 45 | (all-from-out "entity-helpers/carry-util.rkt") 46 | (all-from-out "entity-helpers/player-util.rkt") 47 | (all-from-out "entity-helpers/mini-map.rkt") 48 | (all-from-out "entity-helpers/mouse-util.rkt") 49 | (all-from-out "ai.rkt") 50 | (all-from-out "entity-helpers/time-manager.rkt") 51 | (all-from-out "entity-helpers/particles.rkt") 52 | (all-from-out "entity-helpers/ui-util.rkt") 53 | (all-from-out "entity-helpers/render-util.rkt") 54 | (all-from-out "entity-helpers/text-util.rkt") 55 | (all-from-out "entity-helpers/cutscene-util.rkt") 56 | #%module-begin) 57 | 58 | 59 | (require racket) 60 | (require 2htdp/image) 61 | (require threading) 62 | (require posn) 63 | (require "game-entities.rkt") 64 | (require "components/key-movement.rkt") 65 | (require "components/after-time.rkt") 66 | (require "components/do-every.rkt") 67 | (require "components/animated-sprite.rkt") 68 | (require "components/health.rkt") 69 | (require "components/detect-collide.rkt") 70 | (require "components/every-tick.rkt") 71 | (require "components/on-start.rkt") 72 | (require "components/spawn-once.rkt") 73 | (require "components/key-animator.rkt") 74 | (require "components/direction.rkt") 75 | (require "components/counter.rkt") 76 | (require "components/speed.rkt") 77 | (require "components/on-key.rkt") 78 | (require "components/on-mouse.rkt") 79 | (require "components/stop-on-edge.rkt") 80 | (require "components/wrap-around.rkt") 81 | (require "components/on-edge.rkt") 82 | (require "components/on-rule.rkt") 83 | (require "components/detect-edge.rkt") 84 | (require "components/rotation-style.rkt") 85 | (require "components/follow.rkt") 86 | (require "components/sound-stream.rkt") 87 | (require "components/spawn-dialog.rkt") 88 | (require "components/lock-to.rkt") 89 | (require "components/backdrop.rkt") 90 | (require "components/dialog.rkt") 91 | (require "components/backpack.rkt") 92 | (require "components/observe-change.rkt") 93 | (require "components/producer-of.rkt") 94 | (require "components/storage.rkt") 95 | (require "component-util.rkt") 96 | (require "entity-helpers/movement-util.rkt") 97 | (require "entity-helpers/sprite-util.rkt") 98 | (require "entity-helpers/rgb-hsb.rkt") 99 | (require "entity-helpers/dialog-util.rkt") 100 | (require "entity-helpers/backpack-util.rkt") 101 | (require "entity-helpers/carry-util.rkt") 102 | (require "entity-helpers/player-util.rkt") 103 | (require "entity-helpers/mini-map.rkt") 104 | (require "entity-helpers/mouse-util.rkt") 105 | (require "ai.rkt") 106 | (require "entity-helpers/time-manager.rkt") 107 | (require "entity-helpers/particles.rkt") 108 | (require "entity-helpers/ui-util.rkt") 109 | (require "entity-helpers/render-util.rkt") 110 | (require "entity-helpers/text-util.rkt") 111 | (require "entity-helpers/cutscene-util.rkt") 112 | 113 | -------------------------------------------------------------------------------- /game-entities.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide start-game 4 | headless) 5 | 6 | (provide (all-from-out "./engine/core.rkt") 7 | (all-from-out "./engine/rendering.rkt")) 8 | 9 | (require "./engine/core.rkt") 10 | (require "./engine/rendering.rkt") 11 | (require "./engine/extensions/sound.rkt") 12 | 13 | (require threading 14 | posn) 15 | 16 | (define-syntax-rule (headless expr ...) 17 | (parameterize ([headless? #t]) 18 | expr 19 | ...)) 20 | 21 | (define headless? (make-parameter #f)) 22 | 23 | (define (start-game #:x [x 'center] #:y [y 'center] . entities) 24 | (if (headless?) 25 | (~> (filter identity entities) 26 | ;Filter identity to Remove any #f's. 27 | ;Kind of silly, but there's at least one psuedo-entity (asset-precompiler ...) that has a side effect and returns #f. 28 | ;But maybe one day it'll need to be a full-fledged entity. So that's why it passes its value into start game. 29 | 30 | ;Step 1: Preprocess the provided entities 31 | entities->game:preprocess-entities 32 | ;Step 2: Initialize physics 33 | game->game:start-physics) 34 | (~> (filter identity entities) 35 | ;Filter identity to Remove any #f's. 36 | ;Kind of silly, but there's at least one psuedo-entity (asset-precompiler ...) that has a side effect and returns #f. 37 | ;But maybe one day it'll need to be a full-fledged entity. So that's why it passes its value into start game. 38 | 39 | ;Step 1: Preprocess the provided entities 40 | entities->game:preprocess-entities 41 | ;Step 2: Initialize physics 42 | game->game:start-physics 43 | ;Step 3: Begin rendering. Player plays the game. Game is returned afterward 44 | (game->__->game++:start-game _ #:x x #:y y) 45 | ;Step 4: (Game is over), post-process the state before returning it to the caller of start-game 46 | game++->game:postprocess))) 47 | 48 | 49 | (define (entities->game:preprocess-entities entities) 50 | ;A bit of a hack. We've been assuming that the last entity is 51 | ; the background entity -- sets the width and height of the game. 52 | ; But we've also been assuming it's positioned by its top-left corner (posn 0 0). 53 | ; Everything else is positioned by its center. So we'll just hack it to have 54 | ; the right position here. 55 | (define bg (last entities)) 56 | (define adjusted-bg (update-entity bg posn? (posn (/ (w bg) 2) 57 | (/ (h bg) 2)))) 58 | 59 | (initialize-game (list-set entities (sub1 (length entities)) adjusted-bg))) 60 | 61 | (define (game->game:start-physics game) 62 | (physics-start (uniqify-ids game))) 63 | 64 | 65 | (define (game->__->game++:start-game game #:x [x 'center] #:y [y 'center]) 66 | (lux-start game #:x x #:y y)) 67 | 68 | (define (game++->game:postprocess lux-game) 69 | (displayln "=== CLEANING UP SOUND THREADS ===") 70 | (stop-sound-streams) ;need to add a try-catch to handle improper shutdowns. 71 | (kill-all-chipmunks (demo-state lux-game)) 72 | (cleanup-renderer!) 73 | 74 | ;(displayln "=== RESETTING ERROR PORT ===") 75 | (close-output-port error-out-port) 76 | ;(current-error-port default-error-port) 77 | ;(error-display-handler default-error-handler) 78 | ;(port-print-handler (current-error-port) default-error-print-handler) 79 | 80 | (final-state lux-game)) 81 | 82 | 83 | 84 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | ;(define collection 'multi) 4 | 5 | (define version "0.0.1") 6 | (define scribblings '(("scribblings/game-engine.scrbl" ()))) 7 | 8 | (define deps '("threading" 9 | "memoize" 10 | "https://github.com/jeapostrophe/mode-lambda.git#0858b6d" 11 | "drracket" 12 | "htdp-lib" 13 | "https://github.com/jeapostrophe/lux.git" ;was frozen at #f6edd2e 14 | "jack-posn" 15 | ; "rsound" 16 | "https://github.com/thoughtstem/racket-chipmunk.git#master" 17 | "base")) 18 | 19 | (define compile-omit-paths '( 20 | "test" 21 | )) 22 | 23 | (define pre-install-collection 24 | "./pre-install.rkt") 25 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-from-out "./game-engine.rkt") 4 | ;(all-from-out "./spaceship-game/main.rkt") 5 | ) 6 | 7 | (require "./game-engine.rkt") 8 | ;(require "./spaceship-game/main.rkt") 9 | -------------------------------------------------------------------------------- /pre-install.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide pre-installer) 4 | 5 | (require pkg/name pkg/lib pkg setup/setup) 6 | 7 | (define (pre-installer path) 8 | (when (installed? "racket-chipmunk") 9 | (pkg-update-command 10 | "https://github.com/thoughtstem/racket-chipmunk.git#master" 11 | #:deps 'search-auto #:no-setup #t))) 12 | 13 | (define (installed? s) 14 | (pkg-directory s)) 15 | -------------------------------------------------------------------------------- /test/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (module+ test 4 | ;Some speed benchmarks 5 | 6 | (avatar-crosses-screen-shooting-bullets #:ticks 10 7 | #:time 10) 8 | 9 | (avatar-crosses-screen-shooting-bullets #:ticks 100 10 | #:time 1000) 11 | 12 | ) 13 | 14 | 15 | 16 | (require rackunit 17 | "../main.rkt") 18 | 19 | 20 | ;====== A little language for doing tests on games ==== 21 | 22 | ;Gives better error messages. 23 | ; Plus lets us test our contracts... 24 | (define-syntax-rule (check-contract c v) 25 | (let () 26 | (define/contract (temp x) 27 | (-> c boolean?) 28 | #t) 29 | (check-pred temp v))) 30 | 31 | (define-syntax-rule (check-game-property pred g) 32 | (check-contract 33 | (game-has-property/c pred) 34 | g)) 35 | 36 | (define-syntax-rule (check-runs-in-under #:miliseconds m 37 | #:message msg 38 | expr) 39 | (let () 40 | (define start-time (current-inexact-milliseconds)) 41 | 42 | (define ret expr) 43 | 44 | (define end-time (current-inexact-milliseconds)) 45 | 46 | (check-pred (curryr < m) (- end-time start-time) msg) 47 | 48 | (displayln (~a "Benchmark ran in: " (- end-time start-time) "\n " msg)) 49 | (displayln "\n********") 50 | 51 | ret)) 52 | 53 | ;=========== 54 | ;Properties worth checking. Used across many tests. 55 | 56 | (define (has-#-entities? n) 57 | (λ(g) 58 | (= n (length (game-entities g))))) 59 | 60 | (define (has-a-player? g) 61 | ((game-has-entity-named/c "player") g)) 62 | 63 | (define (player-at? p) 64 | (λ(g) 65 | (define p2 (get-posn 66 | (get-entity "player" g))) 67 | (equal? p 68 | (posn (round (posn-x p2)) 69 | (round (posn-y p2))) 70 | ))) 71 | 72 | ;=========== 73 | 74 | ;Define benchmarks 75 | 76 | (define (avatar-crosses-screen-shooting-bullets 77 | #:time expected-time 78 | #:ticks (ticks 100) 79 | #:message (msg (~a "Avatar should cross screen shooting bullets for " ticks " ticks " 80 | "in under " expected-time " miliseconds"))) 81 | 82 | (define bg (sprite->entity (square 100 'solid 'red) 83 | #:name "bg" 84 | #:position (posn 0 0))) 85 | 86 | (define bullet (sprite->entity (circle 1 'solid 'black) 87 | #:name "bullet" 88 | #:position (posn 0 0) 89 | #:components 90 | (physical-collider))) 91 | 92 | (define player (sprite->entity (circle 10 'solid 'green) 93 | #:name "player" 94 | #:position (posn 0 50) 95 | #:components 96 | (speed 1) 97 | (direction 0) 98 | (every-tick (move)) 99 | (every-tick (spawn bullet)))) 100 | 101 | 102 | 103 | (define g 104 | (check-runs-in-under #:miliseconds expected-time 105 | #:message msg 106 | (~> (list player bg) 107 | (initialize-game _) 108 | (tick _ #:ticks ticks)))) 109 | 110 | 111 | (check-game-property (has-#-entities? (+ ticks 1)) g) ;100 ticks? 99 bullets + a player + a bg 112 | (check-game-property has-a-player? g) 113 | (check-game-property (player-at? (posn ticks 50)) g)) 114 | 115 | 116 | 117 | ;======== 118 | 119 | 120 | -------------------------------------------------------------------------------- /test/run-tests.sh: -------------------------------------------------------------------------------- 1 | racket test/main.rkt 2 | --------------------------------------------------------------------------------