led-controller: improve driver loop
[clinton/scratch.git] / led-controller.scm
CommitLineData
fa726f85
CE
1;;; Led Controller,
2;;; Copyright (c) 2014 Clinton Ebadi <clinton@unknownlamer.org>
3
4;;; This program is free software: you can redistribute it and/or modify
5;;; it under the terms of the GNU General Public License as published by
6;;; the Free Software Foundation, either version 3 of the License, or
7;;; (at your option) any later version.
8
9;;; This program is distributed in the hope that it will be useful,
10;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12;;; GNU General Public License for more details.
13
14;;; You should have received a copy of the GNU General Public License
15;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
16
17(use-modules (ice-9 getopt-long)
18 (ice-9 rdelim)
19 (ice-9 match)
20 (ice-9 receive)
21 (ice-9 threads)
22 (rnrs io ports)
23 (srfi srfi-1)
24 (srfi srfi-4)
87f0622b 25 (srfi srfi-26)
fa726f85
CE
26 (ice-9 format)
27
28
29 (web server)
30 (web request)
31 (web response)
32 (web uri))
33
34;;; stty is less of a pain, just be evil and system
35(system "stty -F /dev/ttyACM0 cs8 115200 ignbrk -brkint -icrnl -imaxbel -opost -onlcr -isig -icanon -iexten -echo -echoe -echok -echoctl -echoke noflsh -ixon -crtscts")
87f0622b
CE
36(set-current-error-port (open-file "/tmp/led.log" "w0"))
37(sleep 1) ; wait for arduino to finish booting
fa726f85
CE
38
39(set! *random-state* (random-state-from-platform))
40
41(define serial-out (open-file "/dev/ttyACM0" "w0"))
42(define serial-in (open-file "/dev/ttyACM0" "r"))
43
44(define color-lock (make-mutex 'recursive))
45(define current-color (vector 0.0 1.0 1.0))
e732331a 46(define pwm-resolution (1- (expt 2 16)))
fa726f85
CE
47
48(define serial-lock (make-mutex))
49
50(define pi 3.141592653589793)
87f0622b 51(define tau (* 2 pi))
fa726f85
CE
52
53(define (deg->rad degrees)
54 (* degrees (/ pi 180)))
55
56(define (hsv->rgb h s v)
57 (let* ((chroma (* v s))
58 (hue' (/ h (/ pi 3)))
59 (x (* chroma (- 1 (abs (- (euclidean-remainder hue' 2) 1)))))
60 (m (- v chroma)))
61 (receive (r₁ g₁ b₁)
62 (case (inexact->exact (truncate hue'))
63 ((0) (values chroma x 0))
64 ((1) (values x chroma 0))
65 ((2) (values 0 chroma x))
66 ((3) (values 0 x chroma))
67 ((4) (values x 0 chroma))
68 ((5) (values chroma 0 x))
69 (else => (lambda (x) (error "Bad hue" h hue' x))))
70 (values (+ r₁ m) (+ g₁ m) (+ b₁ m)))))
71
72(define (set-led-color/primitive! r g b)
87f0622b
CE
73 (call-with-blocked-asyncs (lambda ()
74 (with-mutex serial-lock
75 (format serial-out "~A,~A,~A~c" r g b #\return)
76 (read-line serial-in 'concat)))))
fa726f85
CE
77
78(define (set-led-hsv! h s v)
79 (with-mutex color-lock
80 (set! current-color (vector h s v))
81 (receive (r g b)
82 (hsv->rgb h s v)
87f0622b
CE
83 (let ((r' (inexact->exact (truncate (* (* r 1) pwm-resolution))))
84 (g' (inexact->exact (truncate (* (* g 1) pwm-resolution))))
85 (b' (inexact->exact (truncate (* (* b 1) pwm-resolution)))))
fa726f85
CE
86 (set-led-color/primitive! r' g' b')))))
87
88(define zzz (if (and (> (length (command-line)) 1)
89 (number? (string->number (second (command-line)))))
90 (string->number (second (command-line)))
87f0622b 91 4500))
fa726f85
CE
92
93(display (command-line))
94
87f0622b 95#;(let ((zone-out (format #f "hey man i'm getting zzzzzzzzzzooooned out ~A~%" zzz)))
fa726f85
CE
96 (display zone-out)
97 (system (format #f "echo \"~A\" | festival --tts" zone-out)))
98
87f0622b
CE
99(define (rgb-test)
100 (letrec ((loop (lambda (i fn)
101 (cond ((= i pwm-resolution) #t)
102 (else (display (fn i))
103 (usleep zzz)
104 (loop (1+ i) fn))))))
105 (while #t
106 (loop 0 (cut set-led-color/primitive! <> 0 0))
107 (loop 0 (cut set-led-color/primitive! 0 <> 0))
108 (loop 0 (cut set-led-color/primitive! 0 0 <>)))))
fa726f85
CE
109
110;;; Multi-processing is for hep cats
111
112(define running-fx #f)
113(define server-thread #f)
114
115(define (kill-fx)
116 (with-mutex serial-lock
117 (cancel-thread running-fx)))
118
119(define (run-fx fx)
120 (when running-fx
121 (kill-fx))
122 (set! running-fx (make-thread fx)))
123
fa726f85
CE
124(define (led-command-handler request body)
125 (match (split-and-decode-uri-path (uri-path (request-uri request)))
126 (("set" "rgb" r g b)
127 (set-led-color/primitive! (string->number r)
128 (string->number g)
129 (string->number b))
130 (display "Set rgb\n")
131 (values '((content-type . (text/plain)))
132 "rad\n"))
133 (("set" "hsv" h s v)
134 (set-led-hsv! (string->number h )
135 (string->number s)
136 (string->number v))
137 (display "Set hsv\n")
138 (values '((content-type . (text/plain)))
139 "rad\n"))
140 (("fx" "kill") (kill-fx))
141 (("fx" "run" "hsv-fade") (run-fx hsv-fade))
142 (_
143 (display "nada\n")
144 (values '((content-type . (text/plain)))
145 "luser\n"))))
146
87f0622b 147
fa726f85
CE
148
149(define (start-led-server)
150 (set! server-thread (make-thread (lambda () (run-server led-command-handler 'http '(#:port 58080))))))
87f0622b
CE
151
152(define (current-time/usec)
153 (let ((now (gettimeofday)))
154 (+ (* (car now) (expt 10 6)) (cdr now))))
155
156(define (fx-driver fx)
157 (let loop ((t (current-time/usec))
158 (dt 0))
159 ;; We live a moment in the past
160 (receive (h s v)
161 (fx t dt)
162 (display (set-led-hsv! h s v) (current-error-port)))
163 (let ((now (current-time/usec)))
164 (loop now (- now t)))))
165
166(define (hsv-fx t dt)
167 (define tick-increment (/ (deg->rad 1280) (expt 10 6)))
168 (with-mutex color-lock
169 (match current-color
170 (#(h s v)
171 (let ((h (euclidean-remainder (+ h (* tick-increment dt)) tau)))
172 (values h s v))))))
173
174