blob: 899f5101a70abe24c9a93ae73e1f0c1b7198bbc6 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
(use-modules (srfi srfi-1))
(define set-level
(lambda (fix level)
(cond
[(list? fix) (for-each (lambda (q)
(set-level q level))
fix)]
[(symbol? fix) (set-intensity
(find-fixture fixtures fix)
level)]
[else (set-intensity fix level)])))
(define find-fixture
(lambda (fixtures name)
(cond
[(null? fixtures) #f]
[(eq? (fixture-name (car fixtures)) name) (car fixtures)]
[else (find-fixture (cdr fixtures) name)])))
(define find-fixture-class
(lambda (fixture-classes name)
(cond
[(null? fixture-classes) #f]
[(string-ci=? (fixture-class-name (car fixture-classes)) name) (car fixture-classes)]
[else (find-fixture-class (cdr fixture-classes) name)])))
(define patch-many
(lambda (fixcls prefix n universe start-addr)
(define f (lambda (i)
(patch-fixture (symbol-append prefix (string->symbol (number->string i)))
fixcls universe (+ start-addr (- i 1)))
(if (< i n)
(f (+ i 1)))))
(if fixcls
(f 1)
(display "Fixture class not available\n"))))
(define (find-fixture-attr fixture attr state)
(find (lambda (a) (and
(eq? (car a) fixture)
(eq? (cadr a) attr)))
state))
; 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)))
; 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 (print-state st)
(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)))
(for-each print-statelet st))
; Helper functions
(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))
|
