diff options
author | David Thompson <dthompson2@worcester.edu> | 2014-06-28 18:46:16 -0400 |
---|---|---|
committer | David Thompson <dthompson2@worcester.edu> | 2014-06-28 18:46:16 -0400 |
commit | f47eb69a354188154731846dde8b384c2c2f39f6 (patch) | |
tree | 6aa1ccb9212836b7c941e771475eb995fa6df9f9 /sly/signal.scm | |
parent | df0f2a5f3f09394f1953abbc7e33e9a98204680e (diff) |
Rename guile-2d to Sly!
Massive find/replace job.
Diffstat (limited to 'sly/signal.scm')
-rw-r--r-- | sly/signal.scm | 292 |
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))) |