diff options
Diffstat (limited to 'guile/starlet/colours.scm')
| -rw-r--r-- | guile/starlet/colours.scm | 77 |
1 files changed, 23 insertions, 54 deletions
diff --git a/guile/starlet/colours.scm b/guile/starlet/colours.scm index c7d1de0..2162322 100644 --- a/guile/starlet/colours.scm +++ b/guile/starlet/colours.scm @@ -23,10 +23,11 @@ #:use-module (ice-9 exceptions) #:export (<colour> colour? - make-colour-cmy - make-colour-rgb + cmy + rgb colour-as-cmy colour-as-rgb + colour-as-rgbw cyan magenta @@ -36,13 +37,7 @@ blue interpolate-colour - white - - <colour-component-id> - colour-component-id? - colour-component-id - get-colour-component - extract-colour-component)) + white)) (define-class <colour> (<object>) @@ -74,29 +69,31 @@ (colour-type col) (colour-value col))) +(define (three-sf n) + (/ (round (* (exact->inexact n) 10)) 10)) (define-method (write (col <colour>) port) (let ((cmy (colour-as-cmy col))) - (format port "(make-colour-cmy ~a ~a ~a)" - (cyan cmy) - (magenta cmy) - (yellow cmy)))) + (format port "(cmy ~a ~a ~a)" + (three-sf (cyan cmy)) + (three-sf (magenta cmy)) + (three-sf (yellow cmy))))) -(define (make-colour-cmy c m y) +(define (cmy c m y) (make <colour> #:type 'cmy #:value (list c m y))) -(define (make-colour-rgb r g b) +(define (rgb r g b) (make <colour> #:type 'rgb #:value (list r g b))) (define white - (make-colour-cmy 0 0 0)) + (cmy 0 0 0)) (define (colour-as-rgb col) @@ -117,6 +114,15 @@ (make-exception-with-irritants (colour-type col)))))))) +(define (colour-as-rgbw col) + (let ((rgb (colour-as-rgb col))) + (let ((w (apply min rgb))) + (list (- (red rgb) w) + (- (green rgb) w) + (- (blue rgb) w) + w)))) + + (define (colour-as-cmy col) (let ((val (colour-value col))) (case (colour-type col) @@ -138,7 +144,7 @@ (define (interpolate-cmy a b frac) (let ((cmy1 (colour-as-cmy a)) (cmy2 (colour-as-cmy b))) - (make-colour-cmy + (cmy (+ (cyan cmy1) (* frac (- (cyan cmy2) (cyan cmy1)))) (+ (magenta cmy1) (* frac (- (magenta cmy2) (magenta cmy1)))) (+ (yellow cmy1) (* frac (- (yellow cmy2) (yellow cmy1))))))) @@ -155,40 +161,3 @@ (make-exception-with-message "Unrecognised colour interpolation type") (make-exception-with-irritants interpolation-type)))))) - - -(define-class <colour-component-id> (<object>) - (component - #:init-form (error "Colour component must be specified") - #:init-keyword #:component - #:getter get-colour-component)) - - -(define (colour-component-id? a) - (is-a? a <colour-component-id>)) - - -(define (colour-component-id a) - (make <colour-component-id> - #:component a)) - - -(define (extract-colour-component col component-id) - (cond - ((eq? (get-colour-component component-id) 'cyan) - (cyan (colour-as-cmy col))) - ((eq? (get-colour-component component-id) 'magenta) - (magenta (colour-as-cmy col))) - ((eq? (get-colour-component component-id) 'yellow) - (yellow (colour-as-cmy col))) - ((eq? (get-colour-component component-id) 'red) - (red (colour-as-rgb col))) - ((eq? (get-colour-component component-id) 'green) - (green (colour-as-rgb col))) - ((eq? (get-colour-component component-id) 'blue) - (blue (colour-as-rgb col))) - (else (raise-exception (make-exception - (make-exception-with-message - "Invalid colour component ID") - (make-exception-with-irritants - (get-colour-component component-id))))))) |