Commit | Line | Data |
---|---|---|
9eaf9046 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 | (define-enumeration blend-function | |
14 | (linear curved sinusoidal spherical-increasing spherical-decreaing) | |
15 | blend-functions) | |
16 | ||
17 | (define-enumeration color-model | |
18 | (rgb hsv-counter hsv-clockwise) | |
19 | color-models) | |
20 | ||
21 | ;; Gradients are just a list of gradient-segment | |
22 | #;(define-record-type <gradient-segment> | |
23 | (make-gradient-segment left-pos left-color mid-pos mid-color right-pos right-color) | |
24 | gradient-segment? | |
25 | (left-position )) | |
26 | ||
27 | ||
28 | ;; returna list of ((#(left-pos r g b) #(right-pos r g b))) | |
29 | ;; ignore alpha, blending function, midpoint... whatever, for now. | |
30 | (define (parse-gradient file-name) | |
31 | (call-with-input-file file-name | |
32 | (lambda (instream) | |
33 | (read-line instream) ; Gimp Gradient | |
34 | (let* ((name (read-line instream)) | |
35 | (segments (string->number (read-line instream)))) | |
36 | (let loop ((next-line (read-line instream)) | |
37 | (segments (list))) | |
38 | (if (eof-object? next-line) | |
39 | (reverse segments) | |
40 | (let ((bits (string-split next-line #\space))) | |
41 | (format #t "bits (~A): ~A~%" (length bits) bits) | |
42 | (match (map string->number bits) | |
43 | ((left-stop mid right-stop lr lg lb la rr rg rb ra blend color) | |
44 | (loop (read-line instream) | |
45 | (cons (list (vector left-stop lr lg lb) | |
46 | #;(vector mid mr mg mb) | |
47 | (vector right-stop rr rg rb)) | |
48 | segments))))))))))) | |
49 | ||
50 | (define (segment->rgb segment total-steps) | |
51 | (match segment | |
52 | ((#(l lr lg lb) #(r rr rg rb)) | |
53 | (linear-blend lr lg lb rr rg rb | |
54 | (inexact->exact (floor (* total-steps (- r l)))))))) | |
55 | ||
56 | (define (segments->rgb segments total-steps) | |
57 | (apply append (map (cut segment->rgb <> total-steps) segments))) | |
58 | ||
59 | (define* (linear-blend r1 g1 b1 r2 g2 b2 steps) | |
60 | (let ((rd (/ (- r2 r1) steps)) | |
61 | (gd (/ (- g2 g1) steps)) | |
62 | (bd (/ (- g2 g1) steps))) | |
63 | (let loop ((remaining steps) | |
64 | (colors (list))) | |
65 | (if (= remaining 0) | |
66 | (reverse colors) | |
67 | (let ((step (- steps remaining))) | |
68 | (loop (1- remaining) | |
69 | (cons (vector (+ r1 (* rd step)) | |
70 | (+ g1 (* gd step)) | |
71 | (+ b1 (* bd step))) | |
72 | colors))))))) |