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