Rewrite FRP module to be dynamic and REPL friendly.

Signals are now boxed so that their contents can be overwritten at the
REPL and the signal graph will magically be updated.

* 2d/signal.scm: New module.
* 2d/signals.scm: Delete old module.

2 files changed, 228 insertions, 247 deletions

diff --git a/2d/signal.scm b/2d/signal.scm
new file mode 100644
index 0000000..ec971b0
--- /dev/null
+++ b/2d/signal.scm
@@ -0,0 +1,228 @@
+;;; guile-2d
+;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; Guile-2d is free software: you can redistribute it and/or modify it
+;;; under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; Guile-2d 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
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Simple functional reactive programming API.
+;;
+;;; Code:
+
+(define-module (2d signal)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
+  #:export (signal?
+            signal-box?
+            make-signal
+            make-boxed-signal
+            define-signal
+            %signal-ref
+            signal-ref
+            signal-ref-maybe
+            %signal-set!
+            signal-set!
+            signal-proc
+            signal-merge
+            signal-combine
+            signal-map
+            signal-fold
+            signal-filter
+            signal-reject
+            signal-constant
+            signal-count
+            signal-do))
+
+;;;
+;;; 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 outputs)
+  signal?
+  (value %signal-ref %%signal-set!)
+  (proc signal-proc)
+  (outputs signal-outputs))
+
+(define-record-type <signal-box>
+  (make-signal-box signal)
+  signal-box?
+  (signal signal-unbox signal-box-set!))
+
+(define (%make-signal init proc inputs)
+  "Create a new signal with initial value INIT."
+  (let ((signal (%%make-signal init proc (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 output)))
+                 (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! box-to box-from)
+  "Replace the contents of BOX-TO with the contents of BOX-FROM and
+transfer all output signals."
+  (when (signal-box? box-to)
+    (let ((outputs (signal-outputs (signal-unbox box-to))))
+      (hash-for-each (lambda (signal unused)
+                       (signal-connect! signal box-from))
+                     outputs))
+    (signal-box-set! box-to (signal-unbox box-from))))
+
+(define-syntax define-signal
+  (lambda (x)
+    "Define a variable that contains a signal, with the added bonus
+that if the variable already contains a signal then its outputs will
+be spliced into the new signal."
+    (syntax-case x ()
+      ((_ name (signal ...))
+       (defined? (syntax->datum #'name))
+       #'(begin
+           (splice-signals! name (signal ...))
+           (signal-propagate! (signal-unbox name))))
+      ((_ name (signal ...))
+       #'(define name (signal ...)))
+      ((_ name value)
+       #'(define name value)))))
+
+;;;
+;;; Higher Order Signals
+;;;
+
+(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-combine . 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-do 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))
diff --git a/2d/signals.scm b/2d/signals.scm
deleted file mode 100644
index aabc1c6..0000000
--- a/2d/signals.scm
+++ /dev/null
@@ -1,247 +0,0 @@
-;;; guile-2d
-;;; Copyright (C) 2013 David Thompson <dthompson2@worcester.edu>
-;;;
-;;; Guile-2d is free software: you can redistribute it and/or modify it
-;;; under the terms of the GNU Lesser General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; Guile-2d 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
-;;; Lesser General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Lesser General Public
-;;; License along with this program.  If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Simple functional reactive programming API.
-;;
-;;; Code:
-
-(define-module (2d signals)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-9)
-  #:use-module (srfi srfi-26)
-  #:export (<signal>
-            signal?
-            root-signal?
-            make-signal
-            make-root-signal
-            signal-ref
-            signal-ref-maybe
-            signal-receiver
-            signal-inputs
-            signal-outputs
-            signal-connect!
-            signal-disconnect!
-            signal-clear!
-            signal-set!
-            signal-merge
-            signal-combine
-            signal-do
-            signal-map
-            signal-fold
-            signal-filter
-            signal-reject
-            signal-constant
-            signal-count))
-
-;;;
-;;; 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 set-signal-inputs!)
-  (outputs signal-outputs set-signal-outputs!))
-
-(define (make-signal init proc inputs)
-  "Create a new signal with initial value INIT, a procedure PROC
-to transform incoming signal values and one or more signals to connect
-to."
-  (let ((signal (%make-signal init proc inputs '())))
-    (for-each (cut signal-connect! <> signal) inputs)
-    signal))
-
-(define (make-root-signal init)
-  "Create a new root level signal with initial value INIT."
-  (%make-signal init #f '() '()))
-
-(define (root-signal? signal)
-  "Returns true if a signal has no receiver procedure or false
-otherwise."
-  (not (signal-proc signal)))
-
-(define (signal-ref-maybe object)
-  "Retrieves the signal value from OBJECT if it is a signal and or
-simply returns OBJECT otherwise."
-  (if (signal? object)
-      (signal-ref object)
-      object))
-
-(define (signal-connect! signal-in signal-out)
-  "Attach SIGNAL-OUT to SIGNAL-IN. When the value of SIGNAL-IN
-changes, the value will be propagated to SIGNAL-OUT."
-  (if (root-signal? signal-out)
-      (error 'root-signal-error
-             "Cannot connect to a root signal"
-             signal-out)
-      (let ((outputs (signal-outputs signal-in)))
-        (set-signal-outputs! signal-in  (cons signal-out outputs)))))
-
-(define (signal-disconnect! signal-in signal-out)
-  "Detach SIGNAL-OUT from SIGNAL-IN."
-  (let ((inputs (signal-inputs signal-out))
-        (outputs (signal-outputs signal-in)))
-    (set-signal-inputs!  signal-out (delete signal-in  inputs  eq?))
-    (set-signal-outputs! signal-in  (delete signal-out outputs eq?))
-    ;; Disconnect all inputs when the input signal has no remaining
-    ;; outputs in order to prevent memory leaks and unnecessary
-    ;; computation.
-    (when (null? (signal-outputs signal-in))
-      (signal-clear-inputs! signal-in))))
-
-(define (signal-clear-outputs! signal)
-  "Disconnect all output signals from SIGNAL."
-  (for-each (cut signal-disconnect! signal <>)
-            (signal-outputs signal))
-  (set-signal-outputs! signal '()))
-
-(define (signal-clear-inputs! signal)
-  "Disconnect all inputs signals from SIGNAL."
-  (for-each (cut signal-disconnect! <> signal)
-            (signal-inputs signal))
-  (set-signal-inputs! signal '()))
-
-(define (signal-update! signal from)
-  "Re-evaluate the signal procedure for the signal SIGNAL as ordered
-by the signal FROM."
-  ((signal-proc signal) signal from))
-
-(define (signal-propagate! signal)
-  "Notify all output signals about the current value of SIGNAL."
-  (for-each (cut signal-update! <> signal)
-            (signal-outputs signal)))
-
-(define (signal-set! signal value)
-  "Change the current value of SIGNAL to VALUE and propagate SIGNAL to
-all connected signals."
-  (%signal-set! signal value)
-  (signal-propagate! signal))
-
-(define (splice-signals! old new)
-  "Remove the inputs and outputs from the signal OLD, connect the
-outputs to the signal NEW, and return NEW."
-  (when (signal? old)
-    (let ((outputs (signal-outputs old)))
-      (signal-clear-inputs! old)
-      (signal-clear-outputs! old)
-      (for-each (cut signal-connect! new <>) outputs))
-    (signal-propagate! new))
-  new)
-
-(define-syntax define-signal
-  (lambda (x)
-    (syntax-case x ()
-      ;; Splice in new signal if a signal with this name already
-      ;; exists.
-      ((_ name (signal ...))
-       (defined? (syntax->datum #'name))
-       #'(define name (splice-signals! name (signal ...))))
-      ((_ name (signal ...))
-       #'(define name (signal ...))))))
-
-;;;
-;;; Higher Order Signals
-;;;
-
-(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 ((signals (append (list signal1 signal2) rest)))
-    (make-signal (signal-ref (car signals))
-                 (lambda (self from)
-                   (signal-set! self (signal-ref from)))
-                 signals)))
-
-(define (signal-combine . signals)
-  "Create a new signal whose value is a list of the values stored in
-the given signals."
-  (define (update signals)
-    (map signal-ref signals))
-
-  (make-signal (update signals)
-               (lambda (self from)
-                 (signal-set! self (update (signal-inputs self))))
-               signals))
-
-(define (signal-map proc signal . signals)
-  "Create a new signal that applies PROC to the values stored in one
-or more SIGNALS."
-  (define (update signals)
-    (apply proc (map signal-ref signals)))
-
-  (let ((signals (cons signal signals)))
-    (make-signal (update signals)
-                 (lambda (self from)
-                   (signal-set! self (update (signal-inputs self))))
-                 signals)))
-
-(define (signal-fold proc init signal)
-  "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."
-  (make-signal init
-               (let ((previous init))
-                 (lambda (self from)
-                   (let ((value (proc (signal-ref from) previous)))
-                     (set! previous value)
-                     (signal-set! self value))))
-               (list signal)))
-
-(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-signal (if (predicate (signal-ref signal))
-                   (signal-ref signal)
-                   default)
-               (lambda (self signal)
-                 (when (predicate (signal-ref signal))
-                   (signal-set! self (signal-ref signal))))
-               (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-do 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))