New combine-states function

1 files changed, 88 insertions, 43 deletions

diff --git a/src/init.scm b/src/init.scm
index be9918c..899f510 100644
--- a/src/init.scm
+++ b/src/init.scm
@@ -1,3 +1,5 @@
+(use-modules (srfi srfi-1))
+
 (define set-level
   (lambda (fix level)
     (cond
@@ -38,65 +40,108 @@
       (display "Fixture class not available\n"))))
 
 
-(patch-many (find-fixture-class fixture-class-library "Robe Robin DL7S Profile Mode 1") 'mh 4 0 51)
-(patch-many (find-fixture-class fixture-class-library "Generic dimmer") 'dim 6 0 1)
+(define (find-fixture-attr fixture attr state)
+  (find (lambda (a) (and
+                       (eq? (car a) fixture)
+                       (eq? (cadr a) attr)))
+    state))
 
-; New version
 
-(define (make-fixture fixture-class)
-  (list (int 0) (pan 50) (tilt 50)))
+; Combine two states.  Return combined list
+(define (merge-states a b)
+  (let ((c '()))
 
-(define (at source sink)
-  (let ((attr (car source))
-         (val (cdr source)))
-    (set-cdr! (assq attr sink) val)))
+    (define (add-to-state add)
 
-(define (status fixture)
-  (for-each (lambda (a)
-              (format #t "~10@a:  ~a~%" (car a) ((cdr a))))
-    fixture))
+      ; 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
 
-; Useful source functions
+    (for-each add-to-state a)
+    (for-each add-to-state b)
+
+    c))
 
-(define (int value)
-  (cons 'intensity (lambda () value)))
 
-(define (pan value)
-  (cons 'pan (lambda () value)))
+; 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 (tilt value)
-  (cons 'tilt (lambda () value)))
+; 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 (flash sec)
-  (cons 'intensity (lambda ()
-                     (if (= 0 (remainder (current-time) sec))
-                       100 0))))
 
+(define (print-state st)
 
-(define-syntax define-state
-  (syntax-rules ()
-    ((_ name exp exp* ...)
-      (define name
-        (lambda () exp exp* ...)))))
+  (define (print-statelet a)
+    (display (car a))
+    (display " ")
+    (display (cadr a))
+    (newline)
+    (for-each (lambda (b)
+                (display "       ")
+                (display b)
+                (display "  --->  ")
+                (display (b))
+                (newline)) (cddr a)))
 
-; Demo
+  (for-each print-statelet st))
 
-(define mh1 (make-fixture "Robe Robin DL7S Profile Mode 1"))
-(define mh2 (make-fixture "Robe Robin DL7S Profile Mode 1"))
-(define mh3 (make-fixture "Robe Robin DL7S Profile Mode 1"))
-(define mh4 (make-fixture "Robe Robin DL7S Profile Mode 1"))
-(define dim1 (make-fixture "Generic dimmer"))
-(define dim2 (make-fixture "Generic dimmer"))
+; Helper functions
 
-(define-state exstate
-  (mh1 (flash 2))
-  (mh2 (int 0))
-  (mh3 (int (+ 30 30)))
-  (mh4 (int 32))
-  (dim1 (int 100))
-  (dim2 (int 12)))
+(define (hirestime)
+  (let ((a (gettimeofday)))
+    (+
+      (car a)
+      (/
+        (cdr a)
+        1000000))))
 
+(define pi 3.141592653589793)
+
+(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))))
+
+
+; Useful source functions
+
+(define (int value fixture)
+  (static-value 'intensity value fixture))
+
+(define (pan value fixture)
+  (static-value 'pan value fixture))
+
+(define (tilt value fixture)
+  (static-value 'tilt value fixture))
+
+(define (flash hz fixture)
+  (list (list fixture 'intensity (lambda () (square-wave hz)))))
+
+
+; ********** Demo **********
+
+(patch-many (find-fixture-class fixture-class-library "Robe Robin DL7S Profile Mode 1") 'mh 4 0 51)
+(patch-many (find-fixture-class fixture-class-library "Generic dimmer") 'dim 6 0 1)
 
+(define (exstate)
+  (combine-states
+    (flash 2 'mh1)
+    (int 0 'mh2)
+    (int (+ 30 30) 'mh3)
+    (int 32 'mh4)
+    (int 100 'dim1)
+    (int 12 'dim2)))
 
 ; (def-cue lx5.7
 ;  (xf 'up 10 'down 5 example-state))