;;; 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)))))))