a417fe2b83d5838564b40c116122201450cc75da
[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 (ice-9 format)
26
27
28 (web server)
29 (web request)
30 (web response)
31 (web uri))
32
33 ;;; stty is less of a pain, just be evil and system
34 (system "stty -F /dev/ttyACM0 cs8 115200 ignbrk -brkint -icrnl -imaxbel -opost -onlcr -isig -icanon -iexten -echo -echoe -echok -echoctl -echoke noflsh -ixon -crtscts")
35 (sleep 3) ; wait for arduino to finish booting
36
37 (set! *random-state* (random-state-from-platform))
38
39 (define serial-out (open-file "/dev/ttyACM0" "w0"))
40 (define serial-in (open-file "/dev/ttyACM0" "r"))
41
42 (define color-lock (make-mutex 'recursive))
43 (define current-color (vector 0.0 1.0 1.0))
44 (define pwm-resolution (1- (expt 2 16)))
45
46 (define serial-lock (make-mutex))
47
48 (define pi 3.141592653589793)
49
50 (define (deg->rad degrees)
51 (* degrees (/ pi 180)))
52
53 (define (hsv->rgb h s v)
54 (let* ((chroma (* v s))
55 (hue' (/ h (/ pi 3)))
56 (x (* chroma (- 1 (abs (- (euclidean-remainder hue' 2) 1)))))
57 (m (- v chroma)))
58 (receive (r₁ g₁ b₁)
59 (case (inexact->exact (truncate hue'))
60 ((0) (values chroma x 0))
61 ((1) (values x chroma 0))
62 ((2) (values 0 chroma x))
63 ((3) (values 0 x chroma))
64 ((4) (values x 0 chroma))
65 ((5) (values chroma 0 x))
66 (else => (lambda (x) (error "Bad hue" h hue' x))))
67 (values (+ r₁ m) (+ g₁ m) (+ b₁ m)))))
68
69 (define (set-led-color/primitive! r g b)
70 ;; if put-bytevector is not atomic, may need to have a writer thread
71 (with-mutex serial-lock
72 (put-bytevector serial-out (u8vector r g b))
73 (read-line serial-in 'concat)))
74
75 (define (set-led-hsv! h s v)
76 (with-mutex color-lock
77 (set! current-color (vector h s v))
78 (receive (r g b)
79 (hsv->rgb h s v)
80 (let ((r' (inexact->exact (truncate (* (* r 1) 255))))
81 (g' (inexact->exact (truncate (* (* g 1) 255))))
82 (b' (inexact->exact (truncate (* (* b 1) 255)))))
83 (set-led-color/primitive! r' g' b')))))
84
85 (define zzz (if (and (> (length (command-line)) 1)
86 (number? (string->number (second (command-line)))))
87 (string->number (second (command-line)))
88 45000))
89
90 (display (command-line))
91
92 (let ((zone-out (format #f "hey man i'm getting zzzzzzzzzzooooned out ~A~%" zzz)))
93 (display zone-out)
94 (system (format #f "echo \"~A\" | festival --tts" zone-out)))
95
96 (define tick-increment (/ (* 2 pi) (* 360 10)))
97
98 (define (random-ticks n) (* tick-increment (random n)))
99
100 (define (hsv-fade)
101 (let loop ()
102 (with-mutex color-lock
103 (match current-color
104 (#(h s v)
105 (let ((h (euclidean-remainder (+ h tick-increment) (* 2 pi))))
106 (display (set-led-hsv! h s v) (current-error-port))))))
107 (usleep zzz)
108 (loop))
109
110 #;
111 (let loop ((tick 0))
112 (let ((h (euclidean-remainder tick (* 2 pi))))
113 (display (set-led-hsv! h 1.0 1.0) (current-error-port))
114 (usleep zzz)
115 (loop (+ tick-increment tick)))))
116
117
118 ;;; Multi-processing is for hep cats
119
120 (define running-fx #f)
121 (define server-thread #f)
122
123 (define (kill-fx)
124 (with-mutex serial-lock
125 (cancel-thread running-fx)))
126
127 (define (run-fx fx)
128 (when running-fx
129 (kill-fx))
130 (set! running-fx (make-thread fx)))
131
132 (define (reverse-tick!)
133 (set! tick-increment (- tick-increment)))
134
135
136 (define (led-command-handler request body)
137 (match (split-and-decode-uri-path (uri-path (request-uri request)))
138 (("set" "rgb" r g b)
139 (set-led-color/primitive! (string->number r)
140 (string->number g)
141 (string->number b))
142 (display "Set rgb\n")
143 (values '((content-type . (text/plain)))
144 "rad\n"))
145 (("set" "hsv" h s v)
146 (set-led-hsv! (string->number h )
147 (string->number s)
148 (string->number v))
149 (display "Set hsv\n")
150 (values '((content-type . (text/plain)))
151 "rad\n"))
152 (("fx" "kill") (kill-fx))
153 (("fx" "run" "hsv-fade") (run-fx hsv-fade))
154 (_
155 (display "nada\n")
156 (values '((content-type . (text/plain)))
157 "luser\n"))))
158
159 (set-current-error-port (open-file "/tmp/led.log" "w0"))
160
161 (define (start-led-server)
162 (set! server-thread (make-thread (lambda () (run-server led-command-handler 'http '(#:port 58080))))))