diff options
| -rw-r--r-- | 2d/signal.scm | 228 | ||||
| -rw-r--r-- | 2d/signals.scm | 247 |
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)) |