| 1 | ;;; Load GIMP Gradients. Kind of. |
| 2 | ;;; 2014 |
| 3 | |
| 4 | (use-modules (ice-9 match) |
| 5 | (ice-9 rdelim) |
| 6 | |
| 7 | (rnrs enums) |
| 8 | (srfi srfi-9) |
| 9 | (srfi srfi-26)) |
| 10 | |
| 11 | (define +default-steps+ 1024) |
| 12 | |
| 13 | |
| 14 | ;; returna list of ((#(left-pos r g b) #(right-pos r g b))) |
| 15 | ;; ignore alpha, blending function, midpoint... whatever, for now. |
| 16 | (define (parse-gradient file-name) |
| 17 | (call-with-input-file file-name |
| 18 | (lambda (instream) |
| 19 | (read-line instream) ; Gimp Gradient |
| 20 | (let* ((name (read-line instream)) |
| 21 | (segments (string->number (read-line instream)))) |
| 22 | (let loop ((next-line (read-line instream)) |
| 23 | (segments (list))) |
| 24 | (if (eof-object? next-line) |
| 25 | (reverse segments) |
| 26 | (let ((bits (string-split next-line #\space))) |
| 27 | (format #t "bits (~A): ~A~%" (length bits) bits) |
| 28 | (match (map string->number bits) |
| 29 | ((left-stop mid right-stop lr lg lb la rr rg rb ra blend color) |
| 30 | (loop (read-line instream) |
| 31 | (cons (list (vector left-stop lr lg lb) |
| 32 | #;(vector mid mr mg mb) |
| 33 | (vector right-stop rr rg rb)) |
| 34 | segments))))))))))) |
| 35 | |
| 36 | (define (segment->rgb segment total-steps) |
| 37 | (match segment |
| 38 | ((#(l lr lg lb) #(r rr rg rb)) |
| 39 | (linear-blend lr lg lb rr rg rb |
| 40 | (inexact->exact (floor (* total-steps (- r l)))))))) |
| 41 | |
| 42 | (define (segments->rgb segments total-steps) |
| 43 | (apply append (map (cut segment->rgb <> total-steps) segments))) |
| 44 | |
| 45 | (define* (linear-blend r1 g1 b1 r2 g2 b2 steps) |
| 46 | (let ((rd (/ (- r2 r1) steps)) |
| 47 | (gd (/ (- g2 g1) steps)) |
| 48 | (bd (/ (- g2 g1) steps))) |
| 49 | (let loop ((remaining steps) |
| 50 | (colors (list))) |
| 51 | (if (= remaining 0) |
| 52 | (reverse colors) |
| 53 | (let ((step (- steps remaining))) |
| 54 | (loop (1- remaining) |
| 55 | (cons (vector (+ r1 (* rd step)) |
| 56 | (+ g1 (* gd step)) |
| 57 | (+ b1 (* bd step))) |
| 58 | colors))))))) |
| 59 | |
| 60 | |
| 61 | (use-modules (ice-9 rdelim) |
| 62 | (ice-9 match) |
| 63 | (ice-9 receive) |
| 64 | (srfi srfi-1) |
| 65 | (ice-9 format)) |
| 66 | |
| 67 | (system "stty -F /dev/ttyACM0 cs8 115200 ignbrk -brkint -icrnl -imaxbel -opost -onlcr -isig -icanon -iexten -echo -echoe -echok -echoctl -echoke noflsh -ixon -crtscts") |
| 68 | |
| 69 | (set! *random-state* (random-state-from-platform)) |
| 70 | |
| 71 | (define out (open-file "/dev/ttyACM0" "w0+")) |
| 72 | |
| 73 | (define pi 3.14159) |
| 74 | |
| 75 | (define (deg->rad degrees) |
| 76 | (* degrees (/ pi 180))) |
| 77 | |
| 78 | (define (hsv->rgb h s v) |
| 79 | (let* ((chroma (* v s)) |
| 80 | (hue' (/ h (/ pi 3))) |
| 81 | (x (* chroma (- 1 (abs (- (euclidean-remainder hue' 2) 1))))) |
| 82 | (m (- v chroma))) |
| 83 | (receive (r₁ g₁ b₁) |
| 84 | (case (inexact->exact (floor hue')) |
| 85 | ((0) (values chroma x 0)) |
| 86 | ((1) (values x chroma 0)) |
| 87 | ((2) (values 0 chroma x)) |
| 88 | ((3) (values 0 x chroma)) |
| 89 | ((4) (values x 0 chroma)) |
| 90 | ((5) (values chroma 0 x))) |
| 91 | (values (+ r₁ m) (+ g₁ m) (+ b₁ m))))) |
| 92 | |
| 93 | ;; (define ts (make-termios-struct)) |
| 94 | ;; ;; Get the current setings of the serial-device. |
| 95 | ;; (tc-get-attr! out ts) |
| 96 | ;; (cf-set-speed! ts termios-B9600) |
| 97 | ;; (tc-set-attr out ts) |
| 98 | |
| 99 | (sleep 3) |
| 100 | |
| 101 | (define tick-increment (/ (* 2 pi) (* 360 1))) |
| 102 | |
| 103 | (define (random-ticks n) (* tick-increment (random n))) |
| 104 | |
| 105 | (define last-pulse (car (gettimeofday))) |
| 106 | |
| 107 | |
| 108 | (while #t |
| 109 | (for-each (lambda (color) |
| 110 | (match color |
| 111 | (#(r g b) |
| 112 | (let ((r' (inexact->exact (round (* r 255)))) |
| 113 | (g' (inexact->exact (round (* g 255)))) |
| 114 | (b' (inexact->exact (round (* b 255))))) |
| 115 | (format out "~A,~A,~A,0~c" r' g' b' #\return) |
| 116 | (format out "~A,~A,~A,1~c" r' g' b' #\return) |
| 117 | (usleep 450000))))) |
| 118 | (segments->rgb (parse-gradient "/usr/share/gimp/2.0/gradients/Cold_Steel.ggr") 1024))) |