-
-
Notifications
You must be signed in to change notification settings - Fork 2
/
type.lisp
123 lines (102 loc) · 4.57 KB
/
type.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
(in-package #:org.shirakumo.alloy.colored)
(defgeneric convert (color target-type &key &allow-other-keys))
(defgeneric channels (color))
(defgeneric 2color= (a b))
(defgeneric 2color-equal (a b))
(defstruct (color
(:constructor _color (a))
(:conc-name NIL)
(:predicate NIL)
(:copier NIL))
(a 1.0f0 :type single-float :read-only T))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmethod channels ((_ color)) NIL)
(defmethod channels ((_ (eql 'color))) NIL))
(defmacro define-color-type (name fields &optional (super 'color))
(macrolet ((ftransform (transform)
`(loop for field in fields
collect ,transform)))
(let ((%name (intern (format NIL "%~a" name)))
(sfields (channels super)))
`(progn
(declaim (inline ,%name))
(defstruct (,name
(:include ,super)
(:constructor ,%name (,@fields a))
(:conc-name NIL)
(:predicate NIL)
(:copier NIL))
,@(loop for field in fields
unless (find field sfields)
collect `(,field 0.0f0 :type single-float :read-only T)))
(defmethod print-object ((color ,name) stream)
(format stream "~s" (list ',name ,@(ftransform `(,field color)) (a color))))
(defmethod make-load-form ((color ,name) &optional env)
(declare (ignore env))
(list ',%name ,@(ftransform `(,field color)) (a color)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmethod channels ((_ ,name)) ',fields)
(defmethod channels ((_ (eql ',name))) ',fields))
(defun ,name (,@fields &optional (a 1.0f0))
(,%name ,@(ftransform `(float ,field 0f0))
(float a 0f0)))
(define-compiler-macro ,name (,@fields &optional (a 1f0) &environment env)
(flet ((fold (arg)
(if (constantp arg env)
`(load-time-value (float ,arg 0f0))
`(float ,arg 0f0))))
(if (and ,@(ftransform `(constantp ,field env)) (constantp a env))
(list 'load-time-value (list ',%name ,@(ftransform ``(float ,,field 0f0)) `(float ,a 0f0)))
(list ',%name ,@(ftransform `(fold ,field)) (fold a)))))
(defmethod convert ((color ,name) (_ (eql ',name)) &key) color)
(defmethod 2color= ((a ,name) (b ,name))
(and ,@(ftransform `(= (,field a) (,field b)))
(= (a a) (a b))))
(defmethod 2color-equal ((a ,name) (b ,name))
(and ,@(ftransform `(= (,field a) (,field b)))))))))
(define-color-type rgb (r g b))
(define-color-type srgb (r g b) rgb)
(define-color-type hue-type (h s))
(define-color-type hsv (h s v) hue-type)
(define-color-type hsl (h s l) hue-type)
(define-color-type hsi (h s i) hue-type)
(define-color-type cmyk (c m y k))
(define-color-type xyz (x* y* z*))
(define-color-type lab (l* a* b*))
(define-color-type oklab (l* a* b*) lab)
(defun color (r g b &optional (a 1f0))
(%rgb (float r 0f0) (float g 0f0) (float b 0f0) (float a 0f0)))
(define-compiler-macro color (r g b &optional (a 1.0) &environment env)
(flet ((fold (arg)
(if (constantp arg env)
`(load-time-value (float ,arg 0.0))
`(float ,arg 0.0))))
(if (and (constantp r env) (constantp g env) (constantp b env) (constantp a env))
(list 'load-time-value
(list '%rgb `(float ,r 0.0) `(float ,g 0.0) `(float ,b 0.0)
`(float ,a 0.0)))
(list '%rgb (fold r) (fold g) (fold b) (fold a)))))
(defun color= (color &rest more)
(loop for other in more
always (2color= color other)))
(define-compiler-macro color= (color &rest more)
(if more
(let ((colorg (gensym "COLOR")))
`(let ((,colorg ,color))
(and ,@(loop for other in more
collect `(2color= ,colorg ,other)))))
T))
(defun color-equal (color &rest more)
(loop for other in more
always (2color-equal color other)))
(define-compiler-macro color-equal (color &rest more)
(if more
(let ((colorg (gensym "COLOR")))
`(let ((,colorg ,color))
(and ,@(loop for other in more
collect `(2color-equal ,colorg ,other)))))
T))
;; TODO: ICC Color space conversions http://www.color.org/specification/ICC1v43_2010-12.pdf
;; This would also include CMYK colors and the conversion between RGB<->CMYK.
;; TODO: YUV, YCbCr mappings
;; TODO: Test suite