| 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)))))) |