Commit | Line | Data |
---|---|---|
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 |