PageRenderTime 21ms CodeModel.GetById 17ms app.highlight 3ms RepoModel.GetById 0ms app.codeStats 0ms

/ext/color/hsva/hsva.scm

http://github.com/dharmatech/abstracting
Scheme | 51 lines | 34 code | 17 blank | 0 comment | 0 complexity | ac915817762212d5c24c6dd2cc3c583a MD5 | raw file
Possible License(s): BSD-3-Clause
 1
 2(define (hsva hue saturation value alpha)
 3
 4  (let ((to-rgba
 5         
 6         (lambda ()
 7
 8           (let ((hue        (inexact hue))
 9                 (saturation (inexact saturation))
10                 (value      (inexact value))
11                 (alpha      (inexact alpha)))
12
13             (let ((Hi (mod (floor (/ hue 60.0)) 6.0)))
14
15               (let ((f (- (/ hue 60.0) Hi))
16                     (p (* (- 1.0 saturation) value)))
17
18                 (let ((q (* (- 1.0 (*      f  saturation)) value))
19                       (t (* (- 1.0 (* (- 1.0 f) saturation)) value)))
20                   
21                   (case (exact Hi)
22                     ((0) (rgba value t   p   alpha))
23                     ((1) (rgba q   value p   alpha))
24                     ((2) (rgba p   value t   alpha))
25                     ((3) (rgba p   q   value alpha))
26                     ((4) (rgba t   p   value alpha))
27                     ((5) (rgba value p   q   alpha))))))))))
28
29    (let ((message-handler
30
31           (lambda (msg)
32
33             (case msg
34
35               ((hue)        (lambda () hue))
36               ((saturation) (lambda () saturation))
37               ((value)      (lambda () value))
38               ((alpha)      (lambda () alpha))
39
40               ((hue!)        (lambda (new) (set! hue        new)))
41               ((saturation!) (lambda (new) (set! saturation new)))
42               ((value!)      (lambda (new) (set! value      new)))
43               ((alpha!)      (lambda (new) (set! alpha      new)))
44
45               ((clone) (hsva hue saturation value alpha))
46
47               ((rgba) to-rgba)
48
49               ((raw) (vector hue saturation value alpha))))))
50
51      (vector 'hsva #f message-handler))))