-
-
Notifications
You must be signed in to change notification settings - Fork 0
/
sampler.lisp
193 lines (176 loc) · 6.9 KB
/
sampler.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
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
(in-package #:org.shirakumo.raster)
(deftype sampler ()
'(function (index index) color))
(deftype transform ()
'(simple-array single-float (6)))
(defun make-transform (&rest args)
(map-into (make-array 6 :element-type 'single-float)
(lambda (x) (float x 0f0))
(or args '(1 0 0 0 1 0))))
(defun bilinear (bl br tl tr x y)
(declare (type color bl br tl tr))
(declare (type (single-float 0.0 1.0) x y))
(lerp-color
(lerp-color bl br x)
(lerp-color tl tr x)
y))
(defun sample-color/repeat (buffer x y w h)
(declare (type index w h))
(declare (type coordinate x y))
(let ((x (mod x w))
(y (mod y h)))
(multiple-value-bind (x- xt) (floor x)
(multiple-value-bind (y- yt) (floor y)
(let ((yl (* y- w)))
(if (and (= 0 xt) (= 0 yt))
(color-ref buffer (+ x- yl))
(let* ((x+ (mod (+ x- 1) w))
(y+ (mod (+ y- 1) h))
(bl (color-ref buffer (+ x- yl)))
(br (color-ref buffer (+ x+ yl)))
(tl (color-ref buffer (+ x- (* y+ h))))
(tr (color-ref buffer (+ x+ (* y+ h)))))
(bilinear bl br tl tr xt yt))))))))
(defun sample-color/clamp (buffer x y w h)
(declare (type index w h))
(declare (type coordinate x y))
(let ((x (max 0f0 (min x (float (1- w) 0f0))))
(y (max 0f0 (min y (float (1- h) 0f0)))))
(multiple-value-bind (x- xt) (floor x)
(multiple-value-bind (y- yt) (floor y)
(let ((yl (* y- w)))
(if (and (= 0 xt) (= 0 yt))
(color-ref buffer (+ x- yl))
(let* ((bl (color-ref buffer (+ x- yl)))
(br (if (< (1+ x-) w) (color-ref buffer (+ x- 1 yl)) bl))
(tl (if (< (1+ y-) h) (color-ref buffer (+ x- yl w)) bl))
(tr (if (and (< (1+ x-) w) (< (1+ y-) h)) (color-ref buffer (+ x- 1 yl w)) tl)))
(bilinear bl br tl tr xt yt))))))))
(defun sample-color/border (buffer x y w h border)
(declare (type index w h))
(declare (type coordinate x y))
(declare (type color border))
(if (or (< x 0) (< y 0)
(<= w x) (<= h y))
border
(multiple-value-bind (x- xt) (floor x)
(multiple-value-bind (y- yt) (floor y)
(let ((yl (* y- w)))
(if (and (= 0 xt) (= 0 yt))
(color-ref buffer (+ x- yl))
(let* ((bl (color-ref buffer (+ x- yl)))
(br (if (< (1+ x-) w) (color-ref buffer (+ x- 1 yl)) border))
(tl (if (< (1+ y-) h) (color-ref buffer (+ x- yl w)) border))
(tr (if (and (< (1+ x-) w) (< (1+ y-) h)) (color-ref buffer (+ x- 1 yl w)) border)))
(bilinear bl br tl tr xt yt))))))))
(defun sample-color (buffer x y w h &key (border :clamp))
(let ((x (coordinate x))
(y (coordinate y)))
(etypecase border
((eql :repeat) (sample-color/repeat buffer x y w h))
((eql :clamp) (sample-color/clamp buffer x y w h))
(color (sample-color/border buffer x y w h border)))))
(defun sampler (buffer w h &key (border :clamp) transform)
(declare (type buffer buffer))
(declare (type index w h))
(etypecase transform
(transform
(etypecase border
((eql :repeat)
(lambda (nx ny)
(declare (type index nx ny))
(let ((x (+ (* (aref transform 0) nx) (* (aref transform 1) ny) (aref transform 2)))
(y (+ (* (aref transform 3) nx) (* (aref transform 4) ny) (aref transform 5))))
(sample-color/repeat buffer x y w h))))
((eql :clamp)
(lambda (nx ny)
(declare (type index nx ny))
(let ((x (+ (* (aref transform 0) nx) (* (aref transform 1) ny) (aref transform 2)))
(y (+ (* (aref transform 3) nx) (* (aref transform 4) ny) (aref transform 5))))
(sample-color/clamp buffer x y w h))))
(color
(lambda (nx ny)
(declare (type index nx ny))
(let ((x (+ (* (aref transform 0) nx) (* (aref transform 1) ny) (aref transform 2)))
(y (+ (* (aref transform 3) nx) (* (aref transform 4) ny) (aref transform 5))))
(sample-color/border buffer x y w h border))))))
(null
(lambda (nx ny)
(declare (type index nx ny))
(color-ref* buffer nx ny w h :border border)))))
(defun solid-color (r g b &optional (a 255))
(let ((c (encode-color r g b a)))
(lambda (x y)
(declare (ignore x y))
c)))
(declaim (inline evaluate-gradient))
(defun evaluate-gradient (stops i)
(declare (type single-float i))
;; TODO: optimise via binary search
(loop for last-stop = 0.0 then next-stop
for last-color = (second (first stops)) then next-color
for (next-stop next-color) in stops
do (when (< i next-stop)
(return (lerp-color last-color next-color (/ (- i last-stop) (- next-stop last-stop)))))
finally (return next-color)))
(defun radial-gradient (stops x y)
(declare (type index x y))
(lambda (nx ny)
(declare (type index nx ny))
(let ((i (sqrt (+ (expt (- nx x) 2) (expt (- ny y) 2)))))
(declare (type single-float i))
(evaluate-gradient stops i))))
(defun linear-gradient (stops ax ay bx by)
(declare (type index ax ay bx by))
(let* ((abx (- bx ax))
(aby (- by ay))
(s (float (/ (+ (* abx abx) (* aby aby))) 0f0)))
(lambda (x y)
(declare (type index x y))
(let* ((acx (- x ax))
(acy (- y ay))
(i (* (+ (* abx acx) (* aby acy)) s)))
(declare (type single-float i))
(evaluate-gradient stops i)))))
(defun bilinear-gradient (stops ax ay bx by)
(declare (type index ax ay bx by))
(let* ((abx (- bx ax))
(aby (- by ay))
(s (float (/ (+ (* abx abx) (* aby aby))) 0f0)))
(lambda (x y)
(declare (type index x y))
(let* ((acx (- x ax))
(acy (- y ay))
(i (abs (* (+ (* abx acx) (* aby acy)) s))))
(declare (type single-float i))
(evaluate-gradient stops i)))))
(defun diamond-gradient (stops x y)
(declare (type index x y))
(lambda (nx ny)
(declare (type index nx ny))
(let ((i (float (min (- ny y) (- nx x)) 0f0)))
(declare (type single-float i))
(evaluate-gradient stops i))))
(defun conical-gradient (stops x y)
(declare (type index x y))
(lambda (nx ny)
(declare (type index nx ny))
(let ((i (mod (atan (- ny y) (- nx x)) (float (* 2 PI) 0f0))))
(declare (type single-float i))
(evaluate-gradient stops i))))
(declaim (inline ensure-sampler))
(defun ensure-sampler (sampler)
(etypecase sampler
(function
sampler)
(color
(lambda (x y)
(declare (ignore x y))
sampler))
(image
(sampler (image-buffer sampler) (image-width sampler) (image-height sampler) :border :repeat))
(null
(load-time-value
(lambda (x y)
(declare (ignore x y))
(encode-color 0 0 0))))))