mame-catver-filter: filter mame roms by category

[clinton/scratch.git] / led-controller.scm

;;; Led Controller,
;;; Copyright (c) 2014 Clinton Ebadi <clinton@unknownlamer.org>

;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.

;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.

;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(use-modules (ice-9 getopt-long)
	     (ice-9 rdelim)
	     (ice-9 match)
	     (ice-9 receive)
	     (ice-9 threads)
	     (rnrs io ports)
	     (srfi srfi-1)
	     (srfi srfi-4)
	     (srfi srfi-26)
             (ice-9 format)


	     (web server)
	     (web request)
	     (web response)
	     (web uri))

;;; stty is less of a pain, just be evil and system
(system "stty -F /dev/ttyACM0 cs8 115200 ignbrk -brkint -icrnl -imaxbel -opost -onlcr -isig -icanon -iexten -echo -echoe -echok -echoctl -echoke noflsh -ixon -crtscts")
(set-current-error-port (open-file "/tmp/led.log" "w0"))
(sleep 1) ; wait for arduino to finish booting

(set! *random-state* (random-state-from-platform))

(define serial-out (open-file "/dev/ttyACM0" "w0"))
(define serial-in  (open-file "/dev/ttyACM0" "r"))

(define color-lock (make-mutex 'recursive))
(define current-color (vector 0.0 1.0 1.0))
(define pwm-resolution (1- (expt 2 16)))

(define serial-lock (make-mutex))

(define pi 3.141592653589793)
(define tau (* 2 pi))

(define (deg->rad degrees)
  (* degrees (/ pi 180)))

(define (hsv->rgb h s v)
  (let* ((chroma (* v s))
	 (hue' (/ h (/ pi 3)))
	 (x (* chroma (- 1 (abs (- (euclidean-remainder hue' 2) 1)))))
	 (m (- v chroma)))
    (receive (r₁ g₁ b₁)
	(case (inexact->exact (truncate hue'))
	  ((0) (values chroma x 0))
	  ((1) (values x chroma 0))
	  ((2) (values 0 chroma x))
	  ((3) (values 0 x chroma))
	  ((4) (values x 0 chroma))
	  ((5) (values chroma 0 x))
	  (else => (lambda (x) (error "Bad hue" h hue' x))))
      (values (+ r₁ m) (+ g₁ m) (+ b₁ m)))))

(define (set-led-color/primitive! r g b)
  (call-with-blocked-asyncs (lambda ()
			      (with-mutex serial-lock
				(format serial-out "~A,~A,~A~c" r g b #\return)
				(read-line serial-in 'concat)))))

(define (set-led-hsv! h s v)
  (with-mutex color-lock
	      (set! current-color (vector h s v))
	      (receive (r g b)
		       (hsv->rgb h s v)
		       (let ((r' (inexact->exact (truncate (* (* r 1) pwm-resolution))))
			     (g' (inexact->exact (truncate (* (* g 1) pwm-resolution))))
			     (b' (inexact->exact (truncate (* (* b 1) pwm-resolution)))))
			 (set-led-color/primitive! r' g' b')))))

(define zzz (if (and (> (length (command-line)) 1)
		     (number? (string->number (second (command-line)))))
		(string->number (second (command-line)))
		4500))

(display (command-line))

#;(let ((zone-out (format #f "hey man i'm getting zzzzzzzzzzooooned out ~A~%" zzz)))
  (display zone-out)
  (system (format #f "echo \"~A\" | festival --tts" zone-out)))

(define (rgb-test)
  (letrec ((loop (lambda (i fn)
		   (cond ((= i pwm-resolution) #t)
			 (else (display (fn i))
			       (usleep zzz)
			       (loop (1+ i) fn))))))
    (while #t
	   (loop 0 (cut set-led-color/primitive! <> 0 0))
	   (loop 0 (cut set-led-color/primitive! 0 <> 0))
	   (loop 0 (cut set-led-color/primitive! 0 0 <>)))))

;;; Multi-processing is for hep cats

(define running-fx #f)
(define server-thread #f)

(define (kill-fx)
  (with-mutex serial-lock
     (cancel-thread running-fx)))

(define (run-fx fx)
  (when running-fx
    (kill-fx))
  (set! running-fx (make-thread fx)))

(define (led-command-handler request body)
  (match (split-and-decode-uri-path (uri-path (request-uri request)))
    (("set" "rgb" r g b)
     (set-led-color/primitive! (string->number r)
			       (string->number g)
			       (string->number b))
     (display "Set rgb\n")
     (values '((content-type . (text/plain)))
	     "rad\n"))
    (("set" "hsv" h s v)
     (set-led-hsv! (string->number h )
		   (string->number s)
		   (string->number v))
     (display "Set hsv\n")
     (values '((content-type . (text/plain)))
	     "rad\n"))
    (("fx" "kill") (kill-fx))
    (("fx" "run" "hsv-fade") (run-fx hsv-fade))
    (_
     (display "nada\n")
     (values '((content-type . (text/plain)))
	       "luser\n"))))



(define (start-led-server)
  (set! server-thread (make-thread (lambda ()  (run-server led-command-handler 'http '(#:port 58080))))))

(define (current-time/usec)
  (let ((now (gettimeofday)))
    (+ (* (car now) (expt 10 6)) (cdr now))))

(define (fx-driver fx)
  (let loop ((t (current-time/usec))
	     (dt 0))
    ;; We live a moment in the past
    (receive (h s v)
	(fx t dt)
      (display (set-led-hsv! h s v) (current-error-port)))
    (let ((now (current-time/usec)))
      (loop now (- now t)))))

(define (hsv-fx t dt)
  (define tick-increment (/ (deg->rad 1280) (expt 10 6)))
  (with-mutex color-lock
	      (match current-color
		(#(h s v)
		 (let ((h (euclidean-remainder (+ h (* tick-increment dt)) tau)))
		   (values h s v))))))