A FRP Implementation for Guile Scheme a la FrTime

frp-test.scm

#!/usr/bin/guile -s
!#

(use-modules (gnome-2)
             (srfi srfi-1)
             (imi frp)
             (imi frp-standard))
(use-modules (gnome gtk)
             (imi frp-gobject))



(define (in-range minimum value maximum)
  (max minimum
       (min value maximum)))


(define (container cont . widgets)
  (container* cont widgets))

(define (container* cont widgets)
  (for-each (lambda (widget)
              (gtk-container-add cont widget))
            widgets)
  cont)


(define (vbox . widgets) (vbox* widgets))
(define (vbox* widgets)
  (container* (gtk-vbox-new) widgets))


(define (hbox . widgets) (hbox* widgets))
(define (hbox* widgets)
  (container* (gtk-hbox-new) widgets))

(define (label text . widgets)
  (label* text widgets))

(define (label* text widgets)
  (hbox* (cons (gtk-label-new text)
               widgets)))


(define durationrange (gtk-hscale-new-with-range 10 100 5))
(define progressbar (gtk-progress-bar-new))
(define progresstext (gtk-label-new ""))
(define btn-toggle (gtk-button-new-with-label "start"))
(define btn-reset (gtk-button-new-with-label "reset"))

(define window
  (container (gtk-window-new)
    (vbox
      (label "Duration:" durationrange)
      (label "Progress:" progressbar progresstext)
      (hbox btn-toggle btn-reset))))



(define toggle-click (frp-callback btn-toggle 'clicked))
(define reset-click (frp-callback btn-reset 'clicked))
(define sectick (msec-tick 1000))
(define duration-changed (frp-callback durationrange 'value-changed))


(define running
  (event-fold (lambda (click state)
                (not state))
              #f
              toggle-click))

(set-slot btn-toggle 'label
          (behavior-process
            (lambda (running?)
              (if running? "pause" "start"))
            running))


(define running-time
  (event-fold (lambda (running? sec)
                (if running?
                    (1+ sec)
                    sec))
              0
              (event-map second (event-snapshot sectick running))))

(define start-time
  (event-hold (event-map second (event-snapshot reset-click running-time))
              0))

(define durationb
  (event-hold (event-map (lambda (ev)
                           (round
                             (gtk-range-get-value durationrange)))
                         duration-changed)
              (gtk-range-get-value durationrange)))

(define passed-time
  (behavior-process (lambda (current start duration)
                      (let ((passed (- current start)))
                        (in-range 0 passed duration)))
                    running-time
                    start-time
                    durationb))


(define passed-time-text
  (behavior-process (lambda (passed-time duration)
                      (format #f "~s/~s sec" passed-time duration))
                    passed-time
                    durationb))

(set-slot progresstext 'label passed-time-text)

(define passed-fraction
  (behavior-process (lambda (passed-time duration)
                      (/ passed-time duration))
                    passed-time
                    durationb))

(set-slot progressbar 'fraction passed-fraction)


(event-use (frp-event window 'delete-event)
           (lambda (ev)
             (gtk-widget-hide window)
             (gtk-main-quit)))

(gtk-widget-show-all window)

(gtk-main)

imi-frp-gobject.scm

(define-module (imi frp-gobject)
  #:use-module (srfi srfi-1)
  #:use-module (imi frp)
  #:use-module (oop goops)
  #:use-module (gnome glib)
  #:use-module (gnome gobject)
  #:use-module (gnome gobject gsignal)
  #:export (frp-event frp-callback
            msec-tick set-slot))


(define *gobject-signal-cache* '())

(define (gobject-signal gobj signal-name)
  (or (find (lambda (signal)
              (and (eq? gobj (car signal))
                   (eq? signal-name (cdr signal))))
            *gobject-signal-cache*)
      (let ((signal (cons gobj signal-name)))
        (set! *gobject-signal-cache*
              (cons signal *gobject-signal-cache*))
        signal)))


(define *gobject-event-cache* (make-hash-table))

(define (create-gobject-event gobj signal-name)
  (make-event
    (lambda (frp-event)
      (connect gobj signal-name
        (lambda (widget gsignal-event)
          (event-trigger frp-event gsignal-event)
          #t)))
    (lambda (handler-id)
      (disconnect gobj handler-id))))

(define (create-gobject-callback gobj signal-name)
  (make-event
    (lambda (frp-event)
      (connect gobj signal-name
        (lambda (widget)
          (event-trigger frp-event #t)
          #t)))
    (lambda (handler-id)
      (disconnect gobj handler-id))))

(define (gobject-event gobj signal-name creator)
  (let ((name (gobject-signal gobj signal-name)))
    (cdr (or (hashq-get-handle *gobject-event-cache* name)
             (hashq-create-handle! *gobject-event-cache*
                                   name
                                   (creator gobj signal-name))))))


(define-method (frp-event (gobj <gobject>) signal-name)
  (gobject-event gobj signal-name create-gobject-event))

(define-method (frp-callback (gobj <gobject>) signal-name)
  (gobject-event gobj signal-name create-gobject-callback))


(define (msec-tick msecs)
  (make-event
    (lambda (frp-event)
      (g-timeout-add msecs
        (lambda ()
          (event-trigger frp-event #t)
          #t)))
    (lambda (source-id)
      (g-source-remove source-id))))



(define (set-slot gobj slot value-b)
  (set gobj slot (behavior-value value-b))
  (behavior-use value-b (lambda (new-v) (set gobj slot new-v))))

imi-frp.scm

(define-module (imi frp)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-31)
  #:export (<event> make-event
                    event?
                    event-trigger
                    event-use
                    event-unuse
                    event-process
                    event-map
                    event-map-filter
                    event-filter
                    event-snapshot
                    event-fold
                    event-hold
            <behavior> make-behavior
                       behavior?
                       behavior-value
                       behavior-change
                       behavior-use
                       behavior-unuse
                       behavior-process
            ))

(define-record-type <event>
  (%make-event userid activation activator deactivator users)
  event?
  (userid event-userid event-userid-set!)
  (activation event-activation event-activation-set!)
  (activator event-activator)
  (deactivator event-deactivator)
  (users event-users))

(define make-event
  (case-lambda
    ((activator deactivator)
     (%make-event 0 #f activator deactivator (make-hash-table)))
    (() (make-event (lambda (e) #t) (lambda (act) #t)))))

(define (event-activated? e)
  (and (event-activation e) #t))


(define (event-activate! e)
  (event-activation-set!
    e
    ((event-activator e) e)))

(define (event-deactivate! e)
  (and ((event-deactivator e) (event-activation e))
       (event-activation-set! e #f)))



(define (event-user-count e)
  (hash-fold (lambda (key value count)
               (1+ count))
             0
             (event-users e)))

(define (event-use e user-proc)
  (unless (event-activation e)
    (event-activate! e))
  (let ((id (event-userid e)))
    (hashq-set! (event-users e)
                id
                user-proc)
    (event-userid-set! e (1+ id))
    id))

(define (event-unuse e userid)
  (hashq-remove! (event-users e) userid)
  (if (zero? (event-user-count e))
      (event-deactivate! e)))


(define (event-trigger e v)
  (hash-for-each (lambda (userid user-proc)
                   (and user-proc
                        (user-proc v)))
                 (event-users e)))


(define (event-process e user-proc)
  (define (activate new-event)
    (event-use e (user-proc new-event)))
  (define (deactivate userid)
    (event-unuse e userid)
    #t)
  (make-event activate deactivate))


(define (event-map proc e)
  (event-process e
    (lambda (new-event)
      (lambda (v)
        (event-trigger new-event (proc v))))))

(define (event-map-filter proc e)
  (event-process e
    (lambda (new-event)
      (lambda (v)
        (and=> (proc v)
               (lambda (new-v)
                 (event-trigger new-event new-v)))))))

(define (event-filter pred e)
  (event-process e
    (lambda (new-event)
      (lambda (v)
        (and (pred v)
             (event-trigger new-event v))))))


(define (event-snapshot event . behaviors)
  (define (activate new-event)
    (cons (event-use event
            (lambda (ev)
              (event-trigger new-event
                             (cons ev (map behavior-value behaviors)))))
          (map (lambda (b) (behavior-use b #f)) behaviors)))
  (define (deactivate activations)
    (event-unuse event (car activations))
    (for-each (lambda (b b-userid)
                (behavior-unuse b b-userid))
              behaviors
              (cdr activations))
    #t)
  (make-event activate deactivate))




(define-record-type <behavior>
  (%make-behavior value-proc event)
  behavior?
  (value-proc behavior-value-proc)
  (event behavior-event))


(define (event-fold proc init event)
  (let ((bvalue init))
    (rec new-behavior
      (%make-behavior (lambda () bvalue)
                      (event-process event
                        (lambda (change-event)
                          (lambda (ev)
                            (let* ((old-v bvalue)
                                   (new-v (proc ev old-v)))
                              (unless (eqv? old-v new-v)
                                (set! bvalue new-v)
                                (behavior-changed new-behavior))))))))))

(define (event-hold event init)
  (let ((bvalue init))
    (rec new-behavior
      (%make-behavior (lambda () bvalue)
                      (event-process event
                        (lambda (change-event)
                          (lambda (ev)
                            (set! bvalue ev)
                            (behavior-changed new-behavior))))))))



(define make-behavior
  (case-lambda
    ((value-proc activator deactivator)
     (%make-behavior value-proc (make-event activator deactivator)))
    ((value-proc)
     (%make-behavior value-proc (make-event)))))


(define (behavior-value b)
  ((behavior-value-proc b)))

(define (behavior-changed b)
  (event-trigger (behavior-event b) (behavior-value b)))


(define (behavior-use b user-proc)
  (event-use (behavior-event b) user-proc))

(define (behavior-unuse b user-id)
  (event-unuse (behavior-event b) user-id))


(define (behavior-process proc . behaviors)
  (rec new-behavior
    (make-behavior (lambda () (apply proc (map behavior-value behaviors)))
                   (lambda (change-event)
                     (map (lambda (b)
                            (behavior-use b
                              (lambda (new-v)
                                (behavior-changed new-behavior))))
                          behaviors))
                   (lambda (user-ids)
                     (for-each (lambda (b user-id)
                                 (behavior-unuse b user-id))
                               behaviors
                               user-ids)
                     #t))))