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