Add simple scripting system.

* chickadee/scripting.scm: New file.
* chickadee/scripting/agenda.scm: New file.
* chickadee/scripting/coroutine.scm: New file.
* Makefile.am (SOURCES): Add them.

4 files changed, 315 insertions, 0 deletions

diff --git a/chickadee/scripting.scm b/chickadee/scripting.scm
new file mode 100644
index 0000000..7a661bb
--- /dev/null
+++ b/chickadee/scripting.scm
@@ -0,0 +1,53 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2017 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
+;;; by the Free Software Foundation, either version 3 of the License,
+;;; or (at your option) any later version.
+;;;
+;;; Chickadee is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (chickadee scripting)
+  #:use-module (chickadee scripting agenda)
+  #:use-module (chickadee scripting channel)
+  #:use-module (chickadee scripting coroutine)
+  #:export (forever
+            wait
+            tween))
+
+;; Export public bindings from other modules.
+(eval-when (eval load compile)
+  (begin
+    (define %public-modules
+      '(agenda channel coroutine))
+    (for-each (let ((i (module-public-interface (current-module))))
+                (lambda (m)
+                  (module-use! i (resolve-interface
+                                  `(chickadee scripting ,m)))))
+              %public-modules)))
+
+(define-syntax-rule (forever body ...)
+  "Evaluate BODY in an endless loop."
+  (while #t body ...))
+
+(define (wait duration)
+  "Wait DURATION before resuming the current coroutine."
+  (yield (lambda (cont) (schedule-after duration cont))))
+
+(define (tween duration start end ease proc)
+  (let loop ((t 0))
+    (if (= t duration)
+        (proc end)
+        (let ((alpha (/ t duration)))
+          (proc (+ (* start (- 1 alpha))
+                   (* end alpha)))
+          (wait 1)
+          (loop (1+ t))))))
diff --git a/chickadee/scripting/agenda.scm b/chickadee/scripting/agenda.scm
new file mode 100644
index 0000000..c815afa
--- /dev/null
+++ b/chickadee/scripting/agenda.scm
@@ -0,0 +1,100 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2017 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
+;;; by the Free Software Foundation, either version 3 of the License,
+;;; or (at your option) any later version.
+;;;
+;;; Chickadee is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (chickadee scripting agenda)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-9)
+  #:use-module (chickadee heap)
+  #:export (make-agenda
+            agenda?
+            current-agenda
+            with-agenda
+            agenda-time
+            update-agenda
+            clear-agenda
+            schedule-at
+            schedule-after
+            at
+            after))
+
+(define-record-type <agenda>
+  (%make-agenda time queue)
+  agenda?
+  (time %agenda-time set-agenda-time!)
+  (queue agenda-queue))
+
+(define (task< a b)
+  (< (car a) (car b)))
+
+(define (make-agenda)
+  "Return a new task scheduler."
+  (%make-agenda 0 (make-heap task<)))
+
+(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 (%agenda-clear! agenda)
+  (heap-clear! (agenda-queue agenda))
+  (set-agenda-time! agenda 0)
+  *unspecified*)
+
+(define (%update-agenda agenda dt)
+  (let ((queue (agenda-queue agenda))
+        (time (+ (%agenda-time agenda) dt)))
+    (set-agenda-time! agenda time)
+    (let loop ()
+      (when (not (heap-empty? queue))
+        (match (heap-min queue)
+          ((task-time . thunk)
+           (when (<= task-time time)
+             (heap-remove! queue)
+             (thunk)
+             (loop))))))))
+
+(define current-agenda (make-parameter (make-agenda)))
+
+(define-syntax-rule (with-agenda agenda body ...)
+  (parameterize ((current-agenda agenda))
+    body ...))
+
+(define (agenda-time)
+  "Return the current agenda time."
+  (%agenda-time (current-agenda)))
+
+(define (clear-agenda)
+  "Remove all scheduled tasks from the current agenda."
+  (%agenda-clear! (current-agenda)))
+
+(define (update-agenda dt)
+  "Advance the current agenda by DT."
+  (%update-agenda (current-agenda) dt))
+
+(define (schedule-at time thunk)
+  "Schedule THUNK to be run at TIME."
+  (schedule (current-agenda) time thunk))
+
+(define (schedule-after delay thunk)
+  "Schedule THUNK to be run after DELAY."
+  (schedule (current-agenda) (+ (agenda-time) delay) thunk))
+
+(define-syntax-rule (at time body ...)
+  (schedule-at time (lambda () body ...)))
+
+(define-syntax-rule (after delay body ...)
+  (schedule-after delay (lambda () body ...)))
diff --git a/chickadee/scripting/channel.scm b/chickadee/scripting/channel.scm
new file mode 100644
index 0000000..0c78ffa
--- /dev/null
+++ b/chickadee/scripting/channel.scm
@@ -0,0 +1,74 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2017 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
+;;; by the Free Software Foundation, either version 3 of the License,
+;;; or (at your option) any later version.
+;;;
+;;; Chickadee is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (chickadee scripting channel)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-11)
+  #:use-module (chickadee queue)
+  #:use-module (chickadee scripting coroutine)
+  #:export (make-channel
+            channel?
+            channel-get
+            channel-put))
+
+;; A very simplified notion of channels compared to guile-fibers.  In
+;; our case, everything is cooperative and on the same thread, so we
+;; have less to worry about.
+(define-record-type <channel>
+  (%make-channel get-queue put-queue)
+  channel?
+  (get-queue channel-get-queue)
+  (put-queue channel-put-queue))
+
+(define (display-channel channel port)
+  (display "<channel>" port))
+
+(set-record-type-printer! <channel> display-channel)
+
+(define (make-channel)
+  "Return a new channel."
+  (%make-channel (make-queue) (make-queue)))
+
+(define (maybe-deliver channel)
+  (let ((getq (channel-get-queue channel))
+        (putq (channel-put-queue channel)))
+    (if (and (not (queue-empty? getq))
+             (not (queue-empty? putq)))
+        (match (dequeue! putq)
+          ((data . put-cont)
+           (let ((get-cont (dequeue! getq)))
+             (get-cont data)
+             (put-cont)))))))
+
+(define (channel-get channel)
+  "Retrieve a value from CHANNEL.  The current coroutine suspends
+until a value is available."
+  (yield
+   (lambda (cont)
+     (enqueue! (channel-get-queue channel) cont)
+     (maybe-deliver channel))))
+
+(define (channel-put channel data)
+  "Send DATA to CHANNEL.  The current coroutine suspends until another
+coroutine is available to retrieve the value."
+  (yield
+   (lambda (cont)
+     (enqueue! (channel-put-queue channel) (cons data cont))
+     (maybe-deliver channel))))
diff --git a/chickadee/scripting/coroutine.scm b/chickadee/scripting/coroutine.scm
new file mode 100644
index 0000000..38f0da0
--- /dev/null
+++ b/chickadee/scripting/coroutine.scm
@@ -0,0 +1,88 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2017 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
+;;; by the Free Software Foundation, either version 3 of the License,
+;;; or (at your option) any later version.
+;;;
+;;; Chickadee is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (chickadee scripting coroutine)
+  #:use-module (ice-9 format)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:export (coroutine?
+            coroutine-cancelled?
+            coroutine-running?
+            coroutine-complete?
+            spawn-coroutine
+            coroutine
+            cancel-coroutine
+            yield)
+  #:replace (yield))
+
+(define-record-type <coroutine>
+  (make-coroutine status)
+  coroutine?
+  (status coroutine-status set-coroutine-status!))
+
+(define (display-coroutine co port)
+  (format port "<coroutine status: ~a>" (coroutine-status co)))
+
+(set-record-type-printer! <coroutine> display-coroutine)
+
+(define (coroutine-cancelled? co)
+  "Return #t if CO has been cancelled."
+  (eq? 'cancelled (coroutine-status co)))
+
+(define (coroutine-running? co)
+  "Return #t if CO has not yet terminated or been cancelled."
+  (eq? 'cancelled (coroutine-status co)))
+
+(define (coroutine-complete? co)
+  "Return #t if CO has terminated."
+  (eq? 'cancelled (coroutine-status co)))
+
+(define (cancel-coroutine co)
+  "Prevent further execution of CO."
+  (set-coroutine-status! co 'cancelled)
+  *unspecified*)
+
+(define coroutine-prompt (make-prompt-tag 'coroutine))
+
+(define (spawn-coroutine thunk)
+  "Apply THUNK as a coroutine."
+  (let ((co (make-coroutine 'running)))
+    (define (handler cont callback . args)
+      (define (resume . args)
+        ;; Call continuation that resumes the procedure, unless, of
+        ;; course, the coroutine has been cancelled in the meantime.
+        (unless (coroutine-cancelled? co)
+          (call-with-prompt coroutine-prompt
+            (lambda () (apply cont args))
+            handler)))
+      (when (procedure? callback)
+        (apply callback resume args)))
+    (define (task)
+      (thunk)
+      (set-coroutine-status! co 'complete))
+    ;; Start the coroutine.
+    (call-with-prompt coroutine-prompt task handler)
+    co))
+
+(define-syntax-rule (coroutine body ...)
+  "Evaluate BODY in a coroutine."
+  (spawn-coroutine (lambda () body ...)))
+
+(define (yield handler)
+  "Suspend the current coroutine and pass its continuation to the
+procedure HANDLER."
+  (abort-to-prompt coroutine-prompt handler))