Commit | Line | Data |
---|---|---|
fa726f85 CE |
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))) |