main.scm (12786B)
1 ;;; SPDX-FileCopyrightText: 2023 Yuval Langer <yuvallangerontheroad@gmail.com> 2 ;;; 3 ;;; SPDX-License-Identifier: AGPL-3.0-or-later 4 5 ;;; Utility procedures: 6 (define (alert message) 7 (%inline "alert" message)) 8 9 (define (a) (alert "aaaaa")) 10 11 (define (random) 12 (%inline "Math.random")) 13 14 (define (lerp t start end) 15 (+ start 16 (* (- end start) 17 t))) 18 19 (define (random-uniform start end) 20 (lerp (random) start end)) 21 22 (define (randint n) 23 "Random integer [0, n)." 24 (inexact->exact 25 (floor 26 (* (random) n)))) 27 28 (define (filter predicate our-list) 29 (cond 30 ((null? our-list) '()) 31 ((predicate (car our-list)) 32 (cons (car our-list) 33 (filter predicate 34 (cdr our-list)))) 35 (else (filter predicate 36 (cdr our-list))))) 37 38 (define (assq-replace alist key value) 39 (cons (cons key value) 40 (filter (o not 41 (cut eq? key <>) 42 car) 43 alist))) 44 45 (define (assq-ref alist key) 46 (let ((result (assq key alist))) 47 (if result 48 (cdr result) 49 #f)) 50 #;(alist-ref key alist eq?) 51 ;; No alist-ref :( 52 ;; https://api.call-cc.org/5/doc/chicken/base/alist-ref 53 ) 54 55 (define (assq-set! alist key value) 56 (let ((pair (assq key alist))) 57 (set-cdr! pair 58 value))) 59 ;;; END Utility procedures. 60 61 (define canvas 62 (%inline "document.getElementById" "canvas")) 63 64 (define ctx 65 (%inline ".getContext" canvas "2d")) 66 67 ;;; Constants: 68 (define background-fill-style "hsla(0, 0%, 0%, .2)") 69 (define player-fill-style "rgb(200, 0, 0)") 70 (define good-brick-fill-style "rgb(50, 100, 0)") 71 (define bad-brick-fill-style "rgb(200, 0, 0)") 72 (define cloud-fill-style "#DDE7EE") 73 (define cloud-fill-style "#bbb") 74 (define number-of-lanes 3) 75 (define brick-width (/ (.width canvas) number-of-lanes)) 76 (define brick-half-width (/ brick-width 2)) 77 (define brick-height 40) 78 (define brick-half-height (/ brick-height 2)) 79 (define player-half-width 20) 80 (define player-width (* 2 player-half-width)) 81 (define player-half-height 10) 82 (define player-height (* 2 player-half-height)) 83 (define player-speed-x 0.7) 84 (define cloud-half-width 75) 85 (define cloud-width (* 2 cloud-half-width)) 86 (define cloud-half-height 37) 87 (define cloud-height (* 2 cloud-half-height)) 88 ;;; END Constants. 89 90 (define (draw-player player) 91 (set! (.fillStyle ctx) player-fill-style) 92 (draw-rect (- (element-center-x player) player-half-width) 93 (- (element-center-y player) player-half-height) 94 player-width 95 player-height)) 96 97 (define (draw-rect x y width height) 98 (%inline ".fillRect" 99 ctx 100 x 101 y 102 width 103 height)) 104 105 (define (clear-rect) 106 #;(set! (.fillStyle ctx) background-fill-style) 107 (%inline ".clearRect" 108 ctx 109 0 110 0 111 (.width canvas) 112 (.height canvas))) 113 114 (define (cursor-x cursor) 115 (car cursor)) 116 117 ;;; Makers: 118 119 (define (make-player) 120 `((center-x . ,(/ (.width canvas) 121 2)) 122 (center-y . ,(- (.height canvas) 123 50)) 124 (half-width . ,player-half-width) 125 (half-height . ,player-half-height) 126 (velocity-x . 0) 127 (velocity-y . 0))) 128 129 (define (make-new-cloud) 130 (let* ((cloud-y (random-uniform 10 131 (/ (.height canvas) 132 5)))) 133 `((center-x . ,(* -0.999 cloud-width)) 134 (center-y . ,cloud-y) 135 (half-width . ,cloud-half-width) 136 (half-height . ,cloud-half-height) 137 (velocity-x . 0.05) 138 (velocity-y . 0) 139 (idspispopd . #f)))) 140 141 (define (make-new-falling-brick) 142 (let* ((zero-one-or-two (randint number-of-lanes))) 143 `((center-x . ,(* zero-one-or-two 144 (/ (.width canvas) 145 3))) 146 (center-y . ,(/ (.height canvas) 147 10)) 148 (half-width . ,brick-half-width) 149 (half-height . ,brick-half-height) 150 (velocity-x . 0) 151 (velocity-y . 0.25) 152 (idspispopd . #f) 153 (is-good . ,(if (= (randint 2) 0) 154 #t 155 #f))))) 156 157 ;;; END Makers. 158 159 ;;; Getters: 160 161 (define (element-center-x element) (assq-ref element 'center-x)) 162 (define (element-left element) 163 (- (element-center-x element) 164 (element-half-width element))) 165 (define (element-right element) 166 (+ (element-center-x element) 167 (element-half-width element))) 168 (define (element-center-y element) (assq-ref element 'center-y)) 169 (define (element-top element) 170 (- (element-center-y element) 171 (element-half-height element))) 172 (define (element-bottom element) 173 (+ (element-center-y element) 174 (element-half-height element))) 175 (define (element-velocity-x element) (assq-ref element 'velocity-x)) 176 (define (element-velocity-y element) (assq-ref element 'velocity-y)) 177 (define (element-width element) (* 2 (element-half-width element))) 178 (define (element-half-width element) (assq-ref element 'half-width)) 179 (define (element-height element) (* 2 (element-half-height element))) 180 (define (element-half-height element) (assq-ref element 'half-height)) 181 182 ;;; END Getters. 183 184 185 ;;; Setters: 186 187 (define (set-element-center-x! element value) 188 (assq-set! element 'center-x value)) 189 (define (set-element-center-y! element value) 190 (assq-set! element 'center-y value)) 191 (define (set-element-left! element value) 192 (assq-set! element 193 'center-x 194 (+ (element-center-x element) 195 (element-half-width element)))) 196 (define (set-element-top! element value) 197 (assq-set! element 198 'center-y 199 (+ (element-center-y element) 200 (element-half-height element)))) 201 (define (set-element-velocity-x! element value) 202 (assq-set! element 'velocity-x value)) 203 (define (set-element-velocity-y! element value) 204 (assq-set! element 'velocity-y value)) 205 (define (set-element-idspispopd! element value) 206 (assq-set! element 'idspispopd value)) 207 208 ;;; END Setters. 209 210 ;;; Predicates: 211 212 (define (element-is-good? element) (assq-ref element 'is-good)) 213 214 (define (element-idspispopd? element) (assq-ref element 'idspispopd)) 215 216 (define (element-inside-canvas? element) 217 (and (<= 0 (element-right element)) 218 (<= (element-left) (.width canvas)) 219 (<= 0 (element-bottom element)) 220 (<= (element-top element) (.height canvas)))) 221 222 (define (collision? element-a element-b) 223 (not (or (element-idspispopd? element-b) 224 (< (element-right element-a) 225 (element-left element-b)) 226 (< (element-right element-b) 227 (element-left element-a)) 228 (< (element-bottom element-a) 229 (element-top element-b)) 230 (< (element-bottom element-b) 231 (element-top element-a))))) 232 233 (define (clip-overshoot target-position old-position new-position) 234 (cond 235 ((<= old-position target-position new-position) 236 target-position) 237 ((<= new-position target-position old-position) 238 target-position) 239 (else 240 new-position))) 241 242 ;;; END Predicates. 243 244 ;;; Global variables: (~_~) 245 (define last-loop-time 0) 246 (define falling-bricks '()) 247 (define next-brickfall-time 0) 248 (define clouds '()) 249 (define next-cloud-time 0) 250 (define cursor (cons (/ (.width canvas) 2) 251 (/ (.height canvas) 2))) 252 (define player (make-player)) 253 (define score 0) 254 ;;; END Global variables. 255 256 ;;; Drawers: 257 258 (define (draw-clouds clouds) 259 (set! (.fillStyle ctx) cloud-fill-style) 260 (for-each (lambda (cloud) 261 (draw-rect (element-center-x cloud) 262 (element-center-y cloud) 263 (element-width cloud) 264 (element-height cloud))) 265 clouds)) 266 267 (define (draw-falling-bricks bricks) 268 (for-each (lambda (brick) 269 (if (element-is-good? brick) 270 (set! (.fillStyle ctx) good-brick-fill-style) 271 (set! (.fillStyle ctx) bad-brick-fill-style)) 272 (draw-rect (element-center-x brick) 273 (element-center-y brick) 274 (element-width brick) 275 (element-height brick))) 276 bricks)) 277 278 (define (draw-text) 279 (set! (.font ctx) "30px monospace") 280 (if (< score 0) 281 (set! (.fillStyle ctx) bad-brick-fill-style) 282 (set! (.fillStyle ctx) good-brick-fill-style)) 283 (%inline ".fillText" 284 ctx 285 score 286 10 287 50)) 288 289 (define (draw) 290 (clear-rect) 291 (draw-clouds clouds) 292 (draw-player player) 293 (draw-falling-bricks falling-bricks) 294 (draw-text)) 295 296 ;;; END Drawers. 297 298 (define (clip-low-high value low high) 299 ((o (cut min <> high) 300 (cut max <> low)) 301 value)) 302 303 (define (move-axis dt center velocity) 304 (+ center (* velocity dt))) 305 306 (define (move-elements! dt elements) 307 (for-each (lambda (element) 308 (set-element-center-x! element 309 (move-axis dt 310 (element-center-x element) 311 (element-velocity-x element))) 312 (set-element-center-y! element 313 (move-axis dt 314 (element-center-y element) 315 (element-velocity-y element)))) 316 elements)) 317 318 (define (filter-out-of-canvas-elements elements) 319 (filter element-inside-canvas? 320 elements)) 321 322 (define (get-collided-bricks player bricks) 323 (filter (cut collision? player <>) 324 bricks)) 325 326 (define (sum our-list) 327 (let loop ((our-list our-list) 328 (our-sum 0)) 329 (cond 330 ((null? our-list) 331 our-sum) 332 (else 333 (loop (cdr our-list) 334 (+ our-sum 335 (car our-list))))))) 336 337 (define (loop time) 338 (let* ((dt (- time last-loop-time))) 339 (set! last-loop-time time) 340 341 (move-elements! dt falling-bricks) 342 (move-elements! dt clouds) 343 344 ;; Periodically create a new cloud: 345 (when (< next-cloud-time 346 time) 347 (set! clouds (cons (make-new-cloud) 348 clouds)) 349 (set! next-cloud-time (+ time 350 (random-uniform 5000 8000)))) 351 352 ;; Periodically create a new falling brick: 353 (when (< next-brickfall-time 354 time) 355 (set! falling-bricks (cons (make-new-falling-brick) 356 falling-bricks)) 357 (set! next-brickfall-time (+ time 358 (random-uniform 750 1000)))) 359 360 ;; Get input: 361 (let* ((wanted-player-center-x (cursor-x cursor)) 362 (previous-player-center-x (element-center-x player)) 363 (player-direction-x (if (< previous-player-center-x 364 wanted-player-center-x) 365 1 366 -1)) 367 (new-player-velocity-x (* player-direction-x 368 player-speed-x))) 369 (set-element-velocity-x! player 370 new-player-velocity-x)) 371 372 ;; Move player: 373 (let* ((old-center-x (element-center-x player)) 374 (new-center-x (move-axis dt 375 (element-center-x player) 376 (element-velocity-x player))) 377 (new-center-x (clip-overshoot (cursor-x cursor) 378 old-center-x 379 new-center-x)) 380 (new-center-x (clip-low-high new-center-x 381 (element-half-width player) 382 (- (.width canvas) 383 (element-half-width player))))) 384 (set-element-center-x! player 385 new-center-x)) 386 387 (set! falling-bricks (filter-out-of-canvas-elements falling-bricks)) 388 (set! clouds (filter-out-of-canvas-elements clouds)) 389 390 (let ((bricks-collided (get-collided-bricks player 391 falling-bricks))) 392 (for-each (lambda (brick) 393 (set-element-idspispopd! brick #t) 394 (if (element-is-good? brick) 395 (begin 396 (set! score (+ score 1))) 397 (begin 398 (set! score (- score 1))))) 399 bricks-collided)) 400 401 (draw) 402 403 (%inline "window.requestAnimationFrame" (callback loop)))) 404 405 (%inline "window.requestAnimationFrame" (callback loop)) 406 407 (for-each (lambda (event-name) 408 (%inline ".addEventListener" 409 canvas 410 event-name 411 (callback (lambda (e) 412 (set! cursor 413 (cons (.offsetX e) 414 (.offsetY e))))))) 415 '("pointerdown" 416 "pointermove"))