Better state merging

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 <fixture-attribute> (<object>)
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 <state-assignment> (<object>)
+
+  (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 <state-assignment>) (b <state-assignment>))
+  (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 <state-assignment>
+                  #: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 <state-assignment>
+          #: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 <state-assignment>
+          #:fixture fix
+          #:attribute 'intensity
+          #:value-func (lambda () square-wave hz))))
 
-(define (flash hz fixture)
-  (list (list fixture 'intensity (lambda () (square-wave hz)))))