summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--2d/signal.scm228
-rw-r--r--2d/signals.scm247
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))