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