| 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))))))) |