led-controller: improve driver loop
[clinton/scratch.git] / led-controller.scm
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)
25 (srfi srfi-26)
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")
36 (set-current-error-port (open-file "/tmp/led.log" "w0"))
37 (sleep 1) ; wait for arduino to finish booting
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))
46 (define pwm-resolution (1- (expt 2 16)))
47
48 (define serial-lock (make-mutex))
49
50 (define pi 3.141592653589793)
51 (define tau (* 2 pi))
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)
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)))))
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)
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)))))
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)))
91 4500))
92
93 (display (command-line))
94
95 #;(let ((zone-out (format #f "hey man i'm getting zzzzzzzzzzooooned out ~A~%" zzz)))
96 (display zone-out)
97 (system (format #f "echo \"~A\" | festival --tts" zone-out)))
98
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 <>)))))
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
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
147
148
149 (define (start-led-server)
150 (set! server-thread (make-thread (lambda () (run-server led-command-handler 'http '(#:port 58080))))))
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