foss-mmo/modules/game/scripts.scm

158 lines
4.9 KiB
Scheme
Raw Normal View History

2024-05-26 12:52:03 -04:00
;;; Copyright (C) 2024 David Thompson <dave@spritely.institute>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
(define-module (game scripts)
#:export (make-scheduler
current-scheduler
scheduler-tick!
scheduler-reset!
script?
run-script
script-cancel!
yield
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 proc)
(proc (lambda () (run k))))
(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))))))
(define (run-script thunk)
(let ((script (make-script thunk)))
(script-run! script)
script))
(define (yield proc)
(abort-to-prompt %script-tag proc))
(define (wait delay)
(yield
(lambda (thunk)
(scheduler-add! (current-scheduler) thunk 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)))))))