; SPDX-FileCopyrightText: In 2019, Chris Pressey, the original author of this work, placed it into the public domain.
; SPDX-License-Identifier: Unlicense
; For more information, please refer to <https://unlicense.org/>
;
; Runnable example code, in R5RS Scheme, to accompany the article
; about Nested Modal Transducer Assemblages.
;
; Example usage: install Chicken Scheme, then run
; csi -q -b nested-modal-transducers.scm
; to run all the tests. All tests passed if the output is only `()`'s.
;
(define expect
(lambda (pairs)
(if (null? pairs)
'()
(let* ((pair (car pairs))
(fst (car pair))
(snd (cdr pair)))
(if (equal? fst snd)
(expect (cdr pairs))
pair)))))
;
; Purely functional definition of a simple transducer.
;
(define light-transducer
(lambda (mode input)
(let* ((transition (list mode input)))
(cond
((equal? transition '(on turn-off))
(list 'off '()))
((equal? transition '(off turn-on))
(list 'on '(ring-bell)))
(else
(list mode '()))))))
;
; Purely functional test harness for transducers:
; Determine what state and outputs it will produce, given a sequence of inputs.
; You can think of it as having a type like:
;
; rehearse :: Transducer -> State -> [Input] -> (State, [Output])
;
(define rehearse
(lambda (t state inputs)
(if (null? inputs)
(list state '())
(let* ((input (car inputs))
(result1 (t state input))
(state1 (car result1))
(outputs1 (cadr result1))
(result2 (rehearse t (car result1) (cdr inputs)))
(state2 (car result2))
(outputs2 (cadr result2)))
(list state2 (append outputs1 outputs2))))))
(display (expect (list
(cons
(rehearse light-transducer 'on '(turn-off))
'(off ())
)
(cons
(rehearse light-transducer 'off '(turn-off))
'(off ())
)
(cons
(rehearse light-transducer 'off '(turn-on turn-on turn-off))
'(off (ring-bell))
)
(cons
(rehearse light-transducer 'on '(turn-on turn-on turn-off))
'(off ())
)
)))
(newline)
;
; ---- ---- ---- ----
;
(define combine-transducers
(lambda (ta tb)
(lambda (state input)
(let* ((state-a (car state))
(result-a (ta state-a input))
(newstate-a (car result-a))
(outputs-a (cadr result-a))
(state-b (cdr state))
(result-b (tb state-b input))
(newstate-b (car result-b))
(outputs-b (cadr result-b)))
(list (cons newstate-a newstate-b) (append outputs-a outputs-b))))))
(define two-light-transducer (combine-transducers light-transducer light-transducer))
(display (expect (list
(cons
(rehearse two-light-transducer '(on . off) '(turn-off))
'((off . off) ())
)
(cons
(rehearse two-light-transducer '(on . off) '(turn-off turn-on))
'((on . on) (ring-bell ring-bell))
)
)))
(newline)
;
; ---- ---- ---- ----
;
(define counting-light-transducer
(lambda (config input)
(let* ((mode (car config))
(count (cadr config))
(transition (list mode input)))
(cond
((equal? transition '(on turn-off))
(list (list 'off count) '()))
((equal? transition '(off turn-on))
(list (list 'on (+ count 1)) '(ring-bell)))
(else
(list config '()))))))
(display (expect (list
(cons
(rehearse counting-light-transducer '(off 0) '(turn-on))
'((on 1) (ring-bell))
)
(cons
(rehearse counting-light-transducer '(off 0) '(turn-on turn-on))
'((on 1) (ring-bell))
)
(cons
(rehearse counting-light-transducer '(off 0) '(turn-on turn-on turn-off))
'((off 1) (ring-bell))
)
(cons
(rehearse counting-light-transducer '(off 0) '(turn-on turn-on turn-off turn-on))
'((on 2) (ring-bell ring-bell))
)
)))
(newline)
;
; Nested state machine. The light is now in a room, behind a door.
; It can only be turned on or off when the door is open.
;
(define door-transducer
(lambda (config input)
(let* ((mode (car config))
(light-config (cadr config))
(transition (list mode input)))
(cond
((equal? transition '(closed open))
(list (list 'opened light-config) '()))
((equal? transition '(opened close))
(list (list 'closed light-config) '()))
((equal? mode 'opened)
(let* ((inner-result (counting-light-transducer light-config input))
(new-light-config (car inner-result))
(light-outputs (cadr inner-result)))
(list (list mode new-light-config) light-outputs)))
(else
(list config '()))))))
(display (expect (list
(cons
(rehearse door-transducer '(closed (off 0)) '(open))
'((opened (off 0)) ())
)
(cons
(rehearse door-transducer '(closed (off 0)) '(turn-on))
'((closed (off 0)) ())
)
(cons
(rehearse door-transducer '(closed (off 0)) '(open turn-on close))
'((closed (on 1)) (ring-bell))
)
)))
(newline)
;
; Array of orthogonal regions - a list of lights are behind a barn door.
;
(define transduce-all
(lambda (t input configs acc)
(if (null? configs)
(list (reverse (car acc)) (cadr acc))
(let* ((config (car configs))
(rest-configs (cdr configs))
(acc-configs (car acc))
(acc-outputs (cadr acc))
(result (t config input))
(new-config (car result))
(these-outputs (cadr result))
(new-acc (list (cons new-config acc-configs) (append these-outputs acc-outputs))))
(transduce-all t input rest-configs new-acc)))))
(define barn-transducer
(lambda (config input)
(let* ((mode (car config))
(light-configs (cadr config))
(transition (list mode input)))
(cond
((equal? transition '(closed open))
(list (list 'opened light-configs) '()))
((equal? transition '(opened close))
(list (list 'closed light-configs) '()))
((equal? mode 'opened)
(let* ((inner-results (transduce-all counting-light-transducer input light-configs '(() ())))
(new-light-configs (car inner-results))
(light-outputs (cadr inner-results)))
(list (list mode new-light-configs) light-outputs)))
(else
(list config '()))))))
(display (expect (list
(cons
(rehearse barn-transducer '(closed ((off 0) (on 0)) ) '(open))
'( (opened ((off 0) (on 0)) ) ())
)
(cons
(rehearse barn-transducer '(closed ((off 0) (on 0)) ) '(turn-on))
'( (closed ((off 0) (on 0)) ) ())
)
(cons
(rehearse barn-transducer '(closed ((off 0) (on 0)) ) '(open turn-on close))
'( (closed ((on 1) (on 0)) ) (ring-bell))
)
(cons
(rehearse barn-transducer '(closed ((off 0) (off 0)) ) '(open turn-on close))
'( (closed ((on 1) (on 1)) ) (ring-bell ring-bell))
)
)))
(newline)
;
; Entry and exit actions
;
; Like the article says, we don't pretend to have a good solution, we only
; want to show that it is possible.
;
; door-transducer-2 is the same as door-transducer except that the
; counting-light-transducer nested within it, is decorated with
; add-entry-exit-outputs.
;
(define add-entry-exit-outputs
(lambda (t config input)
(let* ((old-mode (car config))
(result (t config input))
(new-config (car result))
(new-mode (car new-config))
(new-data (cadr new-config))
(outputs (cadr result))
(exit-outputs (if (equal? old-mode 'off) '(buzz-buzzer) '()))
(entry-outputs (if (equal? new-mode 'closed) '(blow-horn) '()))
(new-outputs (append exit-outputs outputs entry-outputs)))
(list new-config new-outputs))))
(define door-transducer-2
(lambda (config input)
(let* ((mode (car config))
(light-config (cadr config))
(transition (list mode input)))
(cond
((equal? transition '(closed open))
(list (list 'opened light-config) '()))
((equal? transition '(opened close))
(list (list 'closed light-config) '()))
((equal? mode 'opened)
(let* ((inner-result (add-entry-exit-outputs counting-light-transducer light-config input))
(new-light-config (car inner-result))
(light-outputs (cadr inner-result)))
(list (list mode new-light-config) light-outputs)))
(else
(list config '()))))))
(define deco-door-transducer
(lambda (config input)
(add-entry-exit-outputs door-transducer-2 config input)))
(display (expect (list
(cons
(rehearse deco-door-transducer '(closed (off 0)) '(open))
'((opened (off 0)) ())
)
(cons
(rehearse deco-door-transducer '(closed (off 0)) '(turn-on))
'((closed (off 0)) (blow-horn))
)
(cons
(rehearse deco-door-transducer '(closed (off 0)) '(open turn-on close))
'((closed (on 1)) (buzz-buzzer ring-bell blow-horn))
)
)))
(newline)
;
; Synthesized events
;
(define make-gui-input-synthesizing-transducer
(lambda (t)
(lambda (config input)
(let* ((mode (car config)))
(cond
((and (equal? mode 'mouse-down) (list? input) (equal? (car input) 'mouse-move))
(t config (list 'drag (cadr input) (caddr input))))
(else
(t config input)))))))
(define base-gui-transducer
(lambda (config input)
(let* ((mode (car config))
(x (cadr config))
(y (caddr config))
(transition (list mode input)))
(cond
((equal? transition '(mouse-down mouse-release))
(list (list 'mouse-up x y) '()))
((equal? transition '(mouse-up mouse-press))
(list (list 'mouse-down x y) (list (list 'show-click x y))))
((equal? (car input) 'mouse-move)
(let* ((new-x (cadr input)) (new-y (caddr input)))
(list (list mode new-x new-y) '())))
((equal? (car input) 'drag)
(let* ((new-x (cadr input)) (new-y (caddr input)))
(list (list mode new-x new-y) (list (list 'show-hand new-x new-y)))))
(else
(list (list mode x y) '()))))))
(define gui-transducer (make-gui-input-synthesizing-transducer base-gui-transducer))
(display (expect (list
(cons
(rehearse gui-transducer '(mouse-up 0 0) '((mouse-move 10 10) mouse-press mouse-release))
'((mouse-up 10 10) ((show-click 10 10)))
)
(cons
(rehearse gui-transducer '(mouse-up 0 0) '(mouse-press (mouse-move 10 10) mouse-release))
'((mouse-up 10 10) ((show-click 0 0) (show-hand 10 10)))
)
)))
(newline)