Untitled

; 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)