From aba0801bf1c874e20d2698be8a3929ac6e29560a Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Mon, 24 Aug 2020 14:19:44 -0400
Subject: scripting: Add custom polling support.

---
 chickadee/scripting.scm        | 16 ++++++++++++++--
 chickadee/scripting/agenda.scm | 24 +++++++++++++++++++-----
 doc/api.texi                   | 20 ++++++++++++++++++++
 3 files changed, 53 insertions(+), 7 deletions(-)

diff --git a/chickadee/scripting.scm b/chickadee/scripting.scm
index ff65e86..f8c859d 100644
--- a/chickadee/scripting.scm
+++ b/chickadee/scripting.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
@@ -24,6 +24,7 @@
   #:export (forever
             repeat
             sleep
+            wait-until
             tween)
   #:replace (sleep))
 
@@ -57,7 +58,18 @@
     (yield
      (lambda (cont)
        (with-agenda agenda
-         (schedule-after duration cont))))))
+                    (schedule-after duration cont))))))
+
+(define-syntax-rule (wait-until condition)
+  "Pause current script until CONDITION has been met."
+  ;; Don't pause if the condition is already met.
+  (unless condition
+    (let ((agenda (current-agenda)))
+      (yield
+       (lambda (cont)
+         (with-agenda agenda
+                      (call-when (lambda () condition)
+                                 cont)))))))
 
 (define* (tween duration start end proc #:key
                 (step 1)
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 ...)))
 
diff --git a/doc/api.texi b/doc/api.texi
index 9cfa26a..446460e 100644
--- a/doc/api.texi
+++ b/doc/api.texi
@@ -3985,6 +3985,15 @@ Schedule @var{body} to be evaluated every @var{interval} amount of
 time.  Repeat this @var{n} times, or indefinitely if not specified.
 @end deffn
 
+It is also possible to schedule things that are not dependent on how
+much time passes.  The agenda will periodically poll to see if any
+registered conditions are met.
+
+@deffn {Procedure} call-when pred thunk
+Call @var{thunk} sometime in the future when @var{pred} is satisfied
+(returns a value other than @code{#f}.)
+@end deffn
+
 @node Scripts
 @subsection Scripts
 
@@ -4070,6 +4079,17 @@ procedure @var{handler}.
 Wait @var{duration} before resuming the current script.
 @end deffn
 
+@deffn {Syntax} wait-until condition
+Wait until @var{condition} is met before resuming the current script.
+
+@example
+(script
+  (wait-until (key-pressed? 'z))
+  (display "you pressed the Z key!\n"))
+@end example
+
+@end deffn
+
 @deffn {Syntax} forever body @dots{}
 Evaluate @var{body} in an endless loop.
 @end deffn
-- 
cgit v1.2.3