1 files changed, 19 insertions, 5 deletions
diff --git a/chickadee/scripting/agenda.scm b/chickadee/scripting/agenda.scm
index 83cb4b7..a5097dc 100644
--- a/chickadee/scripting/agenda.scm
+++ b/chickadee/scripting/agenda.scm
@@ -1,5 +1,5 @@
 ;;; Chickadee Game Toolkit
-;;; Copyright © 2017 David Thompson <davet@gnu.org>
+;;; Copyright © 2017, 2020 David Thompson <davet@gnu.org>
 ;;;
 ;;; Chickadee is free software: you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published
@@ -30,28 +30,33 @@
             schedule-at
             schedule-after
             schedule-every
+            call-when
             at
             after
             every))
 
 (define-record-type <agenda>
-  (%make-agenda time queue)
+  (%make-agenda time queue poll-set)
   agenda?
   (time %agenda-time set-agenda-time!)
-  (queue agenda-queue))
+  (queue agenda-queue)
+  (poll-set agenda-poll-set))
 
 (define (task< a b)
   (< (car a) (car b)))
 
 (define (make-agenda)
   "Return a new task scheduler."
-  (%make-agenda 0 (make-heap task<)))
+  (%make-agenda 0 (make-heap task<) (make-hash-table)))
 
 (define (schedule agenda time thunk)
   (when (<= time (%agenda-time agenda))
     (error "cannot schedule in the past" time))
   (heap-insert! (agenda-queue agenda) (cons time thunk)))
 
+(define (poll agenda pred thunk)
+  (hashq-set! (agenda-poll-set agenda) pred thunk))
+
 (define (%agenda-clear! agenda)
   (heap-clear! (agenda-queue agenda))
   (set-agenda-time! agenda 0)
@@ -59,6 +64,7 @@
 
 (define (%update-agenda agenda dt)
   (let ((queue (agenda-queue agenda))
+        (poll-set (agenda-poll-set agenda))
         (time (+ (%agenda-time agenda) dt)))
     (set-agenda-time! agenda time)
     (let loop ()
@@ -68,7 +74,12 @@
            (when (<= task-time time)
              (heap-remove! queue)
              (thunk)
-             (loop))))))))
+             (loop))))))
+    (hash-for-each (lambda (pred thunk)
+                     (when (pred)
+                       (hashq-remove! poll-set pred)
+                       (thunk)))
+                   poll-set)))
 
 (define current-agenda (make-parameter (make-agenda)))
 
@@ -115,6 +126,9 @@ times, or indefinitely if not specified."
                       (thunk)
                       (schedule-every interval thunk (- n 1)))))))
 
+(define (call-when pred thunk)
+  (poll (current-agenda) pred thunk))
+
 (define-syntax-rule (at time body ...)
   (schedule-at time (lambda () body ...)))