Add script scheduler and pre/post visual effects system.

This commit is contained in:
David Thompson 2024-05-23 11:43:59 -04:00
parent 67c25d93cb
commit 98ae464ab9
6 changed files with 260 additions and 10 deletions

View file

@ -7,6 +7,7 @@ modules = \
modules/dom/media.scm \ modules/dom/media.scm \
modules/dom/window.scm \ modules/dom/window.scm \
modules/game/actors.scm \ modules/game/actors.scm \
modules/game/effects.scm \
modules/game/level.scm \ modules/game/level.scm \
modules/game/tileset.scm \ modules/game/tileset.scm \
modules/goblins/abstract-types.scm \ modules/goblins/abstract-types.scm \

View file

@ -67,7 +67,8 @@ window.addEventListener("load", async () => {
fillRect: (ctx, x, y, w, h) => ctx.fillRect(x, y, w, h), fillRect: (ctx, x, y, w, h) => ctx.fillRect(x, y, w, h),
fillText: (ctx, text, x, y) => ctx.fillText(text, x, y), fillText: (ctx, text, x, y) => ctx.fillText(text, x, y),
drawImage: (ctx, image, sx, sy, sw, sh, dx, dy, dw, dh) => ctx.drawImage(image, sx, sy, sw, sh, dx, dy, dw, dh), drawImage: (ctx, image, sx, sy, sw, sh, dx, dy, dw, dh) => ctx.drawImage(image, sx, sy, sw, sh, dx, dy, dw, dh),
setScale: (ctx, sx, sy) => ctx.scale(sx, sy), scale: (ctx, sx, sy) => ctx.scale(sx, sy),
translate: (ctx, x, y) => ctx.translate(x, y),
setTransform: (ctx, a, b, c, d, e, f) => ctx.setTransform(a, b, c, d, e, f), setTransform: (ctx, a, b, c, d, e, f) => ctx.setTransform(a, b, c, d, e, f),
setImageSmoothingEnabled: (ctx, enabled) => ctx.imageSmoothingEnabled = (enabled == 1) setImageSmoothingEnabled: (ctx, enabled) => ctx.imageSmoothingEnabled = (enabled == 1)
}, },

View file

@ -27,11 +27,13 @@
(dom window) (dom window)
(game actors) (game actors)
(game audio) (game audio)
(game effects)
(game level) (game level)
(game levels level-1) (game levels level-1)
(game levels level-2) (game levels level-2)
(game levels level-3) (game levels level-3)
(game levels level-4) (game levels level-4)
(game scripts)
(game tileset) (game tileset)
(goblins core) (goblins core)
(hoot bytevectors) (hoot bytevectors)
@ -172,7 +174,11 @@
(if (< idx (vector-length levels)) (if (< idx (vector-length levels))
(begin (begin
(save-game!) (save-game!)
(load-level! idx)) (run-script
(lambda ()
(show-effect! (make-fade-out+in-effect 1.0))
(wait 30) ; ~half the effect time
(load-level! idx))))
(set! *state* 'win)))) (set! *state* 'win))))
;; Auto-save/load to local storage. ;; Auto-save/load to local storage.
@ -232,8 +238,11 @@
(set! *gems* (cons *level-idx* *gems*))) (set! *gems* (cons *level-idx* *gems*)))
(('emit x y) (('emit x y)
(play-sound-effect audio:emit)) (play-sound-effect audio:emit))
((or ('gate-open x y) ('gate-close x y)) (('gate-open x y)
(play-sound-effect audio:gate)) (play-sound-effect audio:gate))
(('gate-close x y)
(play-sound-effect audio:gate)
(show-effect! (make-screen-shake-effect 0.05)))
((or ('floor-switch-on x y) ('floor-switch-off x y)) ((or ('floor-switch-on x y) ('floor-switch-off x y))
(play-sound-effect audio:floor-switch)) (play-sound-effect audio:floor-switch))
(('electric-switch-on x y) (('electric-switch-on x y)
@ -252,11 +261,22 @@
(define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz (define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz
(define (update) (define (update)
;; TODO: what kind of work do we need to do each frame? (scheduler-tick! (current-scheduler))
(timeout update-callback dt)) (timeout update-callback dt))
(define update-callback (procedure->external update)) (define update-callback (procedure->external update))
;; Render loop ;; Render loop
(define *current-effect* #f)
(define (show-effect! effect)
(set! *current-effect* effect)
(effect-start! effect))
(define (draw-current-effect type)
(when (and *current-effect*
(eq? type (effect-type *current-effect*)))
(draw-effect context *current-effect*)
(unless (effect-started? *current-effect*)
(set! *current-effect* #f))))
(define number->string* (define number->string*
(let ((cache (make-eq-hashtable))) ; assuming fixnums only (let ((cache (make-eq-hashtable))) ; assuming fixnums only
(lambda (x) (lambda (x)
@ -362,6 +382,9 @@
(set-text-align! context "center") (set-text-align! context "center")
(fill-text context "OUCH... x_x" (/ game-width 2.0) (/ game-height 2.0))))) (fill-text context "OUCH... x_x" (/ game-width 2.0) (/ game-height 2.0)))))
(define (draw-interstitial)
(draw-level))
(define (draw-win) (define (draw-win)
(set-fill-color! context "#000000") (set-fill-color! context "#000000")
(set-text-align! context "left") (set-text-align! context "left")
@ -370,10 +393,12 @@
(define (draw prev-time) (define (draw prev-time)
(clear-rect context 0.0 0.0 *canvas-width* *canvas-height*) (clear-rect context 0.0 0.0 *canvas-width* *canvas-height*)
(set-transform! context 1.0 0.0 0.0 1.0 0.0 0.0) (set-transform! context 1.0 0.0 0.0 1.0 0.0 0.0)
(set-scale! context *canvas-scale* *canvas-scale*) (scale! context *canvas-scale* *canvas-scale*)
(draw-current-effect 'pre)
(match *state* (match *state*
('play (draw-level)) ((or 'play 'interstitial) (draw-level))
('win (draw-win))) ('win (draw-win)))
(draw-current-effect 'post)
(request-animation-frame draw-callback)) (request-animation-frame draw-callback))
(define draw-callback (procedure->external draw)) (define draw-callback (procedure->external draw))

View file

@ -31,7 +31,8 @@
fill-rect fill-rect
fill-text fill-text
draw-image draw-image
set-scale! scale!
translate!
set-transform! set-transform!
set-image-smoothing-enabled!)) set-image-smoothing-enabled!))
@ -65,8 +66,11 @@
(define-foreign draw-image (define-foreign draw-image
"canvas" "drawImage" "canvas" "drawImage"
(ref extern) (ref extern) f64 f64 f64 f64 f64 f64 f64 f64 -> none) (ref extern) (ref extern) f64 f64 f64 f64 f64 f64 f64 f64 -> none)
(define-foreign set-scale! (define-foreign scale!
"canvas" "setScale" "canvas" "scale"
(ref extern) f64 f64 -> none)
(define-foreign translate!
"canvas" "translate"
(ref extern) f64 f64 -> none) (ref extern) f64 f64 -> none)
(define-foreign set-transform! (define-foreign set-transform!
"canvas" "setTransform" "canvas" "setTransform"

76
modules/game/effects.scm Normal file
View file

@ -0,0 +1,76 @@
(define-module (game effects)
#:use-module (dom canvas)
#:use-module (ice-9 match)
#:use-module (math)
#:use-module (srfi srfi-9)
#:use-module (scheme time)
#:export (ease:smoothstep
ease:linear
make-effect
effect?
effect-started?
effect-type
effect-duration
effect-start!
draw-effect
make-fade-out+in-effect
make-screen-shake-effect))
(define (ease:smoothstep t)
(* t t (- 3 (* 2 t))))
(define (ease:linear t) t)
(define (current-time*)
(/ (exact->inexact (current-jiffy)) (jiffies-per-second)))
(define-record-type <effect>
(%make-effect type draw ease duration start)
effect?
(type effect-type)
(draw effect-draw)
(ease effect-ease)
(duration effect-duration)
(start effect-start set-effect-start!))
(define* (make-effect type duration draw #:optional (ease ease:smoothstep))
(%make-effect type draw ease duration #f))
(define (effect-started? effect)
(number? (effect-start effect)))
(define (effect-start! effect)
(set-effect-start! effect (current-time*)))
(define (draw-effect context effect)
(match effect
(($ <effect> type draw ease duration start)
(when (number? start)
(let ((dt (- (current-time*) start)))
(if (>= dt duration)
(set-effect-start! effect #f)
(let ((t (ease (/ dt duration))))
(draw context t))))))))
;; Duplicated from game.scm but gotta go fast!!
(define game-width 320.0)
(define game-height 240.0)
(define (make-fade-out+in-effect duration)
(define (draw context t)
(if (< t 0.5)
(set-global-alpha! context (pk 'alpha-out (* t 2.0)))
(set-global-alpha! context (pk 'alpha-in (- 1.0 (* (- t 0.5) 2.0)))))
(set-fill-color! context "#000000")
(fill-rect context 0.0 0.0 game-width game-height)
(set-global-alpha! context 1.0))
(make-effect 'post duration draw))
(define (make-screen-shake-effect duration)
(define (draw context t)
(let ((x (round (random)))
(y (round (random))))
(translate! context x y)))
(make-effect 'pre duration draw))

143
modules/game/scripts.scm Normal file
View file

@ -0,0 +1,143 @@
(define-module (game scripts)
#:export (make-scheduler
current-scheduler
scheduler-tick!
scheduler-reset!
script?
run-script
script-cancel!
wait
forever
tween)
#:use-module (ice-9 match)
#:use-module (srfi srfi-9))
(define-record-type <scheduler>
(%make-scheduler ticks num-tasks max-tasks tasks)
scheduler?
(ticks scheduler-ticks set-scheduler-ticks!)
(num-tasks scheduler-num-tasks set-scheduler-num-tasks!)
(max-tasks scheduler-max-tasks)
(tasks scheduler-tasks))
(define (make-scheduler max-tasks)
(%make-scheduler 0 0 max-tasks (make-vector max-tasks)))
(define (scheduler-add! scheduler thunk delay)
(match scheduler
(($ <scheduler> ticks num-tasks max-tasks tasks)
(unless (= num-tasks max-tasks)
(vector-set! tasks num-tasks (cons (+ ticks delay) thunk))
(set-scheduler-num-tasks! scheduler (+ num-tasks 1))))))
(define (scheduler-tick! scheduler)
(define (run-thunks thunks)
(for-each (lambda (thunk) (thunk)) thunks))
(run-thunks
(match scheduler
(($ <scheduler> ticks num-tasks max-tasks tasks)
(let ((t (+ ticks 1)))
(let loop ((i 0) (k num-tasks) (to-run '()))
(if (< i k)
(match (vector-ref tasks i)
((t* . thunk)
(if (<= t* t)
(let ((k* (- k 1)))
(vector-set! tasks i (vector-ref tasks k*))
(vector-set! tasks k* #f)
(loop i k* (cons thunk to-run)))
(loop (+ i 1) k to-run))))
(begin
(set-scheduler-ticks! scheduler t)
(set-scheduler-num-tasks! scheduler k)
to-run))))))))
(define (scheduler-reset! scheduler)
(match scheduler
(($ <scheduler> ticks num-tasks max-tasks tasks)
(set-scheduler-ticks! scheduler 0)
(set-scheduler-num-tasks! scheduler 0)
(do ((i 0 (+ i 1)))
((= i num-tasks))
(vector-set! tasks i #f)))))
(define *scheduler* (make-scheduler 100))
(define current-scheduler (make-parameter *scheduler*))
(define current-script (make-parameter #f))
(define %script-tag (make-prompt-tag "script"))
(define-record-type <script>
(%make-script scheduler state cont children)
script?
(scheduler script-scheduler set-script-scheduler!)
(state script-state set-script-state!)
(cont script-cont set-script-cont!)
(children script-children set-script-children!))
(define (make-script thunk)
(%make-script (current-scheduler) 'pending thunk '()))
(define (script-pending? script)
(eq? (script-state script) 'pending))
(define (script-running? script)
(eq? (script-state script) 'running))
(define (script-cancelled? script)
(eq? (script-state script) 'cancelled))
(define (script-cancel! script)
(set-script-state! script 'cancelled)
(for-each script-cancel! (script-children script)))
(define (script-run! script)
(define scheduler (script-scheduler script))
(define (run thunk)
(unless (script-cancelled? script)
(call-with-prompt %script-tag
(lambda ()
(parameterize ((current-script script)
(current-scheduler scheduler))
(thunk)))
handler)))
(define (handler k delay)
(when delay
(scheduler-add! scheduler (lambda () (run k)) delay)))
(when (script-pending? script)
(let ((parent (current-script)))
(when parent
(set-script-children! parent (cons script (script-children parent)))))
(run
(lambda ()
(set-script-state! script 'running)
((script-cont script))
;; Nasty hack: For some reason, falling through the prompt
;; thunk messes up the Scheme stack, resulting in an invalid
;; ref.cast somewhere. So, we *never* fall through. Instead,
;; we create a continuation that gets thrown away.
(abort-to-prompt %script-tag #f)))))
(define (run-script thunk)
(let ((script (make-script thunk)))
(script-run! script)
script))
(define (wait delay)
(abort-to-prompt %script-tag delay))
(define-syntax-rule (forever body ...)
(let loop ()
body ...
(loop)))
(define* (tween proc duration start end ease interpolate)
(let ((d (exact->inexact duration)))
(let loop ((t 0))
(if (= t duration)
(proc end)
(let ((alpha (ease (/ t d))))
(proc (interpolate start end alpha))
(wait 1)
(loop (+ t 1)))))))