From 7bb9b86ff3bf8363c6757c26a79c5097a7b39167 Mon Sep 17 00:00:00 2001 From: Thomas White Date: Thu, 4 Jun 2020 18:02:52 +0200 Subject: Better state merging --- guile/nanolight/fixture.scm | 3 +- guile/nanolight/state.scm | 195 ++++++++++++++++++++++++++++++-------------- 2 files changed, 134 insertions(+), 64 deletions(-) diff --git a/guile/nanolight/fixture.scm b/guile/nanolight/fixture.scm index 7a9ad98..6eb3c29 100644 --- a/guile/nanolight/fixture.scm +++ b/guile/nanolight/fixture.scm @@ -5,7 +5,8 @@ make-output patch-fixture show-state fixture-string get-address-string - percent->dmxval)) + percent->dmxval + get-start-addr get-universe)) (define-class () diff --git a/guile/nanolight/state.scm b/guile/nanolight/state.scm index b12d91a..a005685 100644 --- a/guile/nanolight/state.scm +++ b/guile/nanolight/state.scm @@ -1,68 +1,130 @@ (define-module (nanolight state) - #:export (combine-states print-state int flash)) + #:use-module (oop goops) + #:export (print-state define-state + merge-states merge-rule-htp merge-rule-ltp + merge-htp merge-ltp + int flash pan tilt)) (use-modules (nanolight fixture)) (use-modules (srfi srfi-1)) -(define (find-fixture-attr fixture attr state) - (find (lambda (a) (and - (eq? (car a) fixture) - (eq? (cadr a) attr))) - state)) +(define-class () + + (fixture + #:init-value #f + #:init-keyword #:fixture + #:getter fixture) + + (attribute + #:init-value #f + #:init-keyword #:attribute + #:getter attribute) + + (value-func + #:init-value #f + #:init-keyword #:value-func + #:getter value-func) + + (state-assignment-string + #:init-value #f + #:allocation #:virtual + #:getter state-assignment-string + #:slot-ref (lambda (a) + (string-append + (fixture-string (fixture a)) + " / " + (symbol->string (attribute a)) + " ---> " + (number->string ((value-func a))))) + #:slot-set! (lambda (a s) #f))) + + +; Return #t if the two state assignments target the same parameter +; (i.e. in the same fixture) +(define-method (same-attr (a ) (b )) + (and + (eq? (fixture a) (fixture b)) + (eq? (attribute a) (attribute b)))) + + +; Convenience functions +(define merge-htp + (lambda a + (apply merge-states merge-rule-htp a))) + + +(define merge-ltp + (lambda a + (apply merge-states merge-rule-ltp a))) + + +; Highest takes precedence: for intensity (only), create a new function +; which returns the highest value from the two inputs +; Otherwise, revert to LTP +(define (merge-rule-htp a b) + (let ( + (funca (value-func a)) + (funcb (value-func b))) + (if (eq? (attribute a) 'intensity) + (lambda () (max (funca) (funcb))) + funcb))) + + +; Latest takes precedence: just take whichever one comes last +(define (merge-rule-ltp a b) + (value-func b)) + + +; Merge states according to rule 'merge-rule' +(define (merge-states merge-rule . list-of-states) + (fold + (lambda (assignment-to-add combined-state) + (let ((assignment-in-state (find + (lambda (a) + (same-attr assignment-to-add a)) + combined-state))) + (cons (if assignment-in-state + (make + #:fixture (fixture assignment-to-add) + #:attribute (attribute assignment-to-add) + #:value-func (merge-rule + assignment-in-state + assignment-to-add)) + assignment-to-add) + (delq assignment-in-state combined-state)))) + '() (apply append list-of-states))) + + +(define (compare-addr a b) + (or + (< (get-universe (fixture a)) (get-universe (fixture b))) + (and + (eq? (get-universe (fixture a)) (get-universe (fixture b))) + (< (get-start-addr (fixture a)) (get-start-addr (fixture b)))))) + + +(define (sort-by-dmx-addr state) + (stable-sort state compare-addr)) -; Combine two states. Return combined list -(define (merge-states a b) - (let ((c '())) - - (define (add-to-state add) - - ; Already in state? - (let ((attr (find-fixture-attr (car add) (cadr add) c))) - (if attr - (set-cdr! (last-pair attr) (cddr add)) ; add to existing list - (set! c (cons add c))))) ; add fixture+attr to state - - (for-each add-to-state a) - (for-each add-to-state b) - - c)) - - -; Combine the first two states in the list -; Return a new list, one shorter than the input -(define (merge-first-two-states a) - (cons (merge-states (car a) (cadr a)) (cddr a))) +(define (print-state st) + (for-each + (lambda (a) + (display (state-assignment-string a)) + (newline)) + (sort-by-dmx-addr st))) -; Each argument is a "state", i.e. a list of these: (fixture attr function) -; Returns a combined state, with non-unique fixtures combined -(define (combine-states . a) - (cond - [(= (length a) 0) '()] - [(= (length a) 1) (car a)] - [else (apply combine-states (merge-first-two-states a))])) +(define-syntax define-state + (syntax-rules () + [(_) #f] -(define (print-state st) + [(_ n) (define n '())] - (define (print-statelet a) - (if (eq? (car a) #f) - (display "(oops! nothing)")) - (display (fixture-string (car a))) - (display " / ") - (display (cadr a)) - (newline) - (for-each (lambda (b) - (display " ") - (display b) - (display " ---> ") - (display (b)) - (newline)) - (cddr a))) - - (for-each print-statelet st)) + [(_ n st ...) (define n + (merge-states merge-rule-htp st ...))])) ; Helper functions @@ -75,25 +137,32 @@ (cdr a) 1000000)))) -(define pi 3.141592653589793) +(define pi (* 2 (acos 0))) (define (square-wave hz) (if (> (sin (* 2 pi hz (hirestime))) 0) 100 0)) -(define (static-value attr value fixture) - (list (list fixture attr (lambda () value)))) +(define (static-value attr value fix) + (list (make + #:fixture fix + #:attribute attr + #:value-func (lambda () value)))) ; Useful source functions -(define (int value fixture) - (static-value 'intensity value fixture)) +(define (int value fix) + (static-value 'intensity value fix)) + +(define (pan value fix) + (static-value 'pan value fix)) -(define (pan value fixture) - (static-value 'pan value fixture)) +(define (tilt value fix) + (static-value 'tilt value fix)) -(define (tilt value fixture) - (static-value 'tilt value fixture)) +(define (flash hz fix) + (list (make + #:fixture fix + #:attribute 'intensity + #:value-func (lambda () square-wave hz)))) -(define (flash hz fixture) - (list (list fixture 'intensity (lambda () (square-wave hz))))) -- cgit v1.2.3