Basic gimp gradient loader
[clinton/scratch.git] / gimp-gradient.scm
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)))))))