Rename guile-2d to Sly!

Massive find/replace job.

1 files changed, 292 insertions, 0 deletions

diff --git a/sly/signal.scm b/sly/signal.scm
new file mode 100644
index 0000000..a77e3bb
--- /dev/null
+++ b/sly/signal.scm
@@ -0,0 +1,292 @@
+;;; Sly
+;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; This program 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.
+;;;
+;;; This program 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/>.
+
+;;; Commentary:
+;;
+;; Simple functional reactive programming API.
+;;
+;;; Code:
+
+(define-module (sly signal)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
+  #:use-module (sly agenda)
+  #:export (signal?
+            make-signal
+            define-signal
+            hook->signal
+            signal-ref
+            signal-ref-maybe
+            signal-set!
+            signal-proc
+            signal-merge
+            signal-zip
+            signal-map
+            signal-fold
+            signal-filter
+            signal-reject
+            signal-constant
+            signal-count
+            signal-tap
+            signal-sample
+            signal-delay
+            signal-throttle))
+
+;;;
+;;; Signals
+;;;
+
+;; Signals are time-varying values. For example, a signal could
+;; represent the mouse position at the current point in time. The
+;; signals API provides an abstraction over regular event-based
+;; programming. State mutation is hidden away and a functional,
+;; declarative interface is exposed.
+(define-record-type <signal>
+  (%%make-signal value proc inputs outputs)
+  %signal?
+  (value %signal-ref %%signal-set!)
+  (proc signal-proc)
+  (inputs signal-inputs)
+  (outputs signal-outputs))
+
+(define-record-type <signal-box>
+  (make-signal-box signal)
+  signal-box?
+  (signal signal-unbox signal-box-set!))
+
+;; Alternate spelling of signal-box? for the public API.
+(define signal? signal-box?)
+
+(define (%make-signal init proc inputs)
+  "Create a new signal with initial value INIT."
+  (let ((signal (%%make-signal init proc inputs (make-weak-key-hash-table))))
+    (for-each (cut signal-connect! signal <>) inputs)
+    signal))
+
+(define (make-signal init)
+  "Return a signal box with initial value INIT."
+  (make-signal-box (%make-signal init #f '())))
+
+(define (make-boxed-signal init proc inputs)
+  "Return a signal box containing a signal with value INIT, updating
+procedure PROC, and a list of INPUTS."
+  (make-signal-box (%make-signal init proc inputs)))
+
+(define (signal-connect! signal-out signal-box-in)
+  "Attach SIGNAL-OUT to SIGNAL-BOX-IN.  When the signal within
+SIGNAL-BOX-IN changes, the value will be propagated to SIGNAL-OUT."
+  (hashq-set! (signal-outputs (signal-unbox signal-box-in)) signal-out #f))
+
+(define (signal-ref signal-box)
+  "Return the current value of the signal contained within
+SIGNAL-BOX."
+  (%signal-ref (signal-unbox signal-box)))
+
+(define (signal-ref-maybe object)
+  "Retrieves the signal value from OBJECT if it is a signal and or
+simply returns OBJECT otherwise."
+  (if (signal-box? object)
+      (signal-ref object)
+      object))
+
+(define (signal-propagate! signal)
+  "Notify all output signals about the current value of SIGNAL."
+  (hash-for-each (lambda (output unused)
+                   ((signal-proc output) output (%signal-ref signal)))
+                 (signal-outputs signal)))
+
+(define (%signal-set! signal value)
+  "Change the current value of SIGNAL to VALUE and propagate VALUE to
+all output signals."
+  (%%signal-set! signal value)
+  (signal-propagate! signal)
+  *unspecified*)
+
+(define (signal-set! signal-box value)
+  "Change the current value contained within SIGNAL-BOX to VALUE."
+  (%signal-set! (signal-unbox signal-box) value))
+
+(define (splice-signals! to from)
+  "Replace the contents of the signal TO with the contents of the
+signal FROM and transfer all output signals."
+  (let ((outputs (signal-outputs (signal-unbox to))))
+    (hash-for-each (lambda (signal unused)
+                     (signal-connect! signal from))
+                   outputs)
+    (signal-box-set! to (signal-unbox from))))
+
+(define (make-signal-maybe value)
+  "Coerce VALUE into a signal.  Return VALUE unmodified if it is
+already a signal."
+  (if (signal? value)
+      value
+      (make-signal value)))
+
+(define-syntax define-signal
+  (lambda (x)
+    "Create a top-level signal variable.  If the named variable
+already exists and has a signal value then its outputs will be spliced
+into the new signal.  If the given value is not a signal then it will
+be coerced into one."
+    (syntax-case x ()
+      ((_ name (signal ...))
+       (defined? (syntax->datum #'name))
+       #'(let ((s (make-signal-maybe (signal ...))))
+           (if (signal? name)
+               (begin
+                 (splice-signals! name s)
+                 (signal-propagate! (signal-unbox name)))
+               (set! name s))))
+      ((_ name value)
+       (defined? (syntax->datum #'name))
+       #'(let ((s (make-signal-maybe value)))
+           (if (signal? name)
+               (begin
+                 (splice-signals! name s)
+                 (signal-propagate! (signal-unbox name)))
+               (set! name s))))
+      ((_ name (signal ...))
+       #'(define name (make-signal-maybe (signal ...))))
+      ((_ name value)
+       #'(define name (make-signal-maybe value))))))
+
+;;;
+;;; Higher Order Signals
+;;;
+
+(define (hook->signal hook init proc)
+  "Return a new signal whose initial value is INIT and has future
+values calculated by applying PROC to the arguments sent when HOOK is
+run."
+  (let ((signal (make-signal init)))
+    (add-hook! hook
+               (lambda args
+                 (signal-set! signal (apply proc args))))
+    signal))
+
+(define (signal-merge signal1 signal2 . rest)
+  "Create a new signal whose value is the that of the most recently
+changed signal in SIGNALs.  The initial value is that of the first
+signal in SIGNALS."
+  (let ((inputs (append (list signal1 signal2) rest)))
+    (make-boxed-signal (signal-ref (car inputs))
+                       (lambda (self value)
+                         (%signal-set! self value))
+                       inputs)))
+
+(define (signal-zip . signals)
+  "Create a new signal whose value is a list of the values stored in
+the given signals."
+  (define (current-value)
+    (map signal-ref signals))
+  (make-boxed-signal (current-value)
+                     (lambda (self value)
+                       (%signal-set! self (current-value)))
+                     signals))
+
+(define (signal-map proc signal . rest)
+  "Create a new signal that applies PROC to the values stored in one
+or more SIGNALS."
+  (let ((inputs (cons signal rest)))
+    (define (current-value)
+      (apply proc (map signal-ref inputs)))
+    (make-boxed-signal (current-value)
+                       (lambda (self value)
+                         (%signal-set! self (current-value)))
+                       inputs)))
+
+(define (signal-fold proc init signal . rest)
+  "Create a new signal that applies PROC to the values stored in
+SIGNAL. PROC is applied with the current value of SIGNAL and the
+previously computed value, or INIT for the first call."
+  (let ((inputs (cons signal rest)))
+    (make-boxed-signal init
+                       (let ((previous init))
+                         (lambda (self value)
+                           (let ((x (apply proc
+                                           (append (map signal-ref inputs)
+                                                   (list previous)))))
+                             (set! previous x)
+                             (%signal-set! self x))))
+                       inputs)))
+
+(define (signal-filter predicate default signal)
+  "Create a new signal that keeps an incoming value from SIGNAL when
+it satifies the procedure PREDICATE.  The value of the signal is
+DEFAULT when the predicate is never satisfied."
+  (make-boxed-signal (if (predicate (signal-ref signal))
+                         (signal-ref signal)
+                         default)
+                     (lambda (self value)
+                       (when (predicate value)
+                         (%signal-set! self value)))
+                     (list signal)))
+
+(define (signal-reject predicate default signal)
+  "Create a new signal that does not keep an incoming value from
+SIGNAL when it satisfies the procedure PREDICATE.  The value of the
+signal is DEFAULT when the predicate is never satisfied."
+  (signal-filter (lambda (x) (not (predicate x))) default signal))
+
+(define (signal-constant constant signal)
+  "Create a new signal whose value is always CONSTANT regardless of
+what the value received from SIGNAL."
+  (signal-map (lambda (value) constant) signal))
+
+(define (signal-count signal)
+  "Create a new signal that increments a counter every time a new
+value from SIGNAL is received."
+  (signal-fold + 0 (signal-constant 1 signal)))
+
+(define (signal-tap proc signal)
+  "Create a new signal that applies PROC when a new values is received
+from SIGNAL.  The value of the new signal will always be the value of
+SIGNAL.  This signal is a convenient way to sneak a procedure that has
+a side-effect into a signal chain."
+  (signal-map (lambda (x) (proc x) x) signal))
+
+(define (signal-sample delay signal)
+  "Create a new signal that emits the value contained within SIGNAL
+every DELAY ticks of the current agenda."
+  (let ((sampler (%make-signal (signal-ref signal) #f '())))
+    (define (tick)
+      (%signal-set! sampler (signal-ref signal)))
+    (schedule-interval tick delay)
+    (make-signal-box sampler)))
+
+(define (signal-delay delay signal)
+  "Create a new signal that delays propagation of SIGNAL by DELAY
+ticks of the current agenda."
+  (make-boxed-signal (signal-ref signal)
+                     (lambda (self value)
+                       (schedule
+                        (lambda ()
+                          (%signal-set! self value))
+                        delay))
+                     (list signal)))
+
+(define (signal-throttle delay signal)
+  "Return a new signal that propagates SIGNAL at most once every DELAY
+ticks of the current agenda."
+  (make-boxed-signal (signal-ref signal)
+                     (let ((last-time (agenda-time)))
+                       (lambda (self value)
+                         (when (>= (- (agenda-time) last-time) delay)
+                           (%signal-set! self value)
+                           (set! last-time (agenda-time)))))
+                     (list signal)))