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              (srfi srfi-26)
  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")
  36 (set-current-error-port (open-file "/tmp/led.log" "w0"))
  37 (sleep 1) ; wait for arduino to finish booting
  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))
  46 (define pwm-resolution (1- (expt 2 16)))
  47
  48 (define serial-lock (make-mutex))
  49
  50 (define pi 3.141592653589793)
  51 (define tau (* 2 pi))
  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)
  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)))))
  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)
  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)))))
  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)))
  91                 4500))
  92
  93 (display (command-line))
  94
  95 #;(let ((zone-out (format #f "hey man i'm getting zzzzzzzzzzooooned out ~A~%" zzz)))
  96   (display zone-out)
  97   (system (format #f "echo \"~A\" | festival --tts" zone-out)))
  98
  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 <>)))))
 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
 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
 147
 148
 149 (define (start-led-server)
 150   (set! server-thread (make-thread (lambda ()  (run-server led-command-handler 'http '(#:port 58080))))))
 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