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
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
|
;;;; canvas.lisp
(in-package #:wheelwork)
(defclass/std pixels ()
((pixel-width pixel-height :std (error "pixel-width and pixel-height are required"))
(data :a :with :doc "Array of RGBA data representing an image of pixel-width X pixel-height")))
(defmethod initialize-instance :after ((pixels pixels) &key)
(with-slots (pixel-width pixel-height data) pixels
(setf data (make-array (* pixel-width pixel-height 4)
:element-type 'unsigned-byte
:initial-element 255))))
(defun pixel-offset (x y pixels)
(* 4 (+ x (* y (pixel-width pixels)))))
(let ((cached-pixel))
(defun pixel (pixels x y &optional (use-cached t))
"When USE-CACHED is NIL, return a fresh array displaced to
PIXELS. Otherwise, PIXEL resets the offset on an internal
displaced array and returns it.
I.E. If you are are wanting to manipulate more than one pixel at
a time, you should get those pixels with USE-CACHED set to NIL."
(let ((pixel-width (pixel-width pixels))
(data (pixels-data pixels)))
(cond
((and use-cached cached-pixel)
(adjust-array cached-pixel 4
:displaced-to data
:displaced-index-offset (* 4 (+ x (* pixel-width y)))))
(use-cached
(setf cached-pixel
(make-array 4
:displaced-to data
:displaced-index-offset (* 4 (+ x (* pixel-width y))))))
(t
(make-array 4
:displaced-to data
:displaced-index-offset (* 4 (+ x (* pixel-width y)))))))))
(defmacro with-pixel ((r g b a) pixel &body body)
"R G B and A are symbols that hold the components of the pixel being
manipulated for this operation.
PIXEL is any form that evaluates to a 4 element array of unsigned bytes"
(let ((pixel-var
(gensym)))
`(let ((,pixel-var ,pixel))
(symbol-macrolet ((,r (aref ,pixel-var 0))
(,g (aref ,pixel-var 1))
(,b (aref ,pixel-var 2))
(,a (aref ,pixel-var 3)))
,@body))))
(defmacro with-pixels-rect ((x y r g b a) (pixels &key left right top bottom) &body body)
"Executes BODY on all pixels in the box bounded by LEFT RIGHT TOP and BOTTOM of PIXELS.
If the any bound is NIL then its minimum (left and bottom) or
maximum (right and top) value is assumed.
Pixels is any expression that evaluates to an instance of PIXELS."
(with-gensyms (pxs px lv rv tv bv)
`(let* ((,pxs ,pixels)
(,px (make-array 4 :displaced-to (pixels-data ,pxs) :displaced-index-offset 0))
(,lv ,left)
(,rv ,right)
(,tv ,top)
(,bv ,bottom))
(symbol-macrolet ((,r (aref ,px 0))
(,g (aref ,px 1))
(,b (aref ,px 2))
(,a (aref ,px 3)))
(loop for ,x from (if ,lv ,lv 0) below (if ,rv ,rv (pixel-width ,pxs)) do
(loop for ,y from (if ,bv ,bv 0) below (if ,tv ,tv (pixel-height ,pxs))
do (progn
(setf ,px (adjust-array ,px 4
:displaced-to (pixels-data ,pxs)
:displaced-index-offset (pixel-offset ,x ,y ,pxs)))
,@body)))))))
(defun clear-canvas (canvas &key (r 0) (g 0) (b 0) (a 255))
(with-pixels-rect (x y pr pg pb pa) (canvas)
(setf pr r pg g pb b pa a)))
(defmacro with-pixels-line ((x y r g b a) (pixels start-x start-y end-x end-y) &body body)
"A convenience macro for doing something to a whole line of pixels -
e.g., drawing a line in a particular color."
(let ((pxs (gensym)))
`(let ((,pxs ,pixels))
(with-grid-line (,x ,y) (,start-x ,start-y) (,end-x ,end-y)
(with-pixel (,r ,g ,b ,a) (pixel ,pxs ,x ,y) ,@body)))))
(defvar *canvas-shader-program* nil)
(defvar *canvas-render-vao* nil)
(defun make-shared-canvas-gpu-objects ()
(setf
;; compile shader program
*canvas-shader-program*
(create-shader
'(:vertex
((vert :vec2))
((transform :mat4))
((values
(* transform (vari:vec4 vert 0.0 1.0))
vert)))
'(:fragment
((tc :vec2))
((tex :sampler-2d))
((let ((frag (vari:texture tex tc)))
frag))))
;; allocate vertex array
*canvas-render-vao*
(gl:gen-vertex-array))
(gl:program-uniformi
*canvas-shader-program*
(gl:get-uniform-location *canvas-shader-program* "TEX")
0)
(gl:bind-vertex-array *canvas-render-vao*)
(let ((vbo (gl:gen-buffer)))
(with-gl-array (verts :float
0.0 1.0
1.0 0.0
0.0 0.0
0.0 1.0
1.0 1.0
1.0 0.0 )
(gl:bind-buffer :array-buffer vbo)
(gl:buffer-data :array-buffer :static-draw verts)))
(gl:enable-vertex-attrib-array 0)
(gl:vertex-attrib-pointer 0 2 :float 0 (* +float-size+ 2) 0)
(gl:bind-buffer :array-buffer 0)
(gl:bind-vertex-array 0)
(unless (pre-exit-hook-exists-p :canvas-gpu-resources )
(pre-exit-hook :canvas-gpu-resources
(lambda ()
(when *canvas-render-vao*
(gl:delete-vertex-arrays (list *canvas-render-vao*)))
(when *canvas-shader-program*
(gl:delete-program *canvas-shader-program*))
(setf-many *canvas-fbo-vao*
*canvas-render-vao*
*canvas-shader-program*
nil)))))
(defclass/std canvas (unit interactive pixels)
((fbo :with :r :doc "framebuffer object for use in off-screen-rendering of this canvas to a texture")
(texture :with :a :doc "texture instance")))
(defmethod cleanup ((canvas canvas))
(cleanup (canvas-texture canvas))
(gl:delete-framebuffers (list (canvas-fbo canvas))))
(defmethod initialize-instance :after ((canvas canvas) &key)
(unless *canvas-shader-program*
(make-shared-canvas-gpu-objects))
(with-slots (texture fbo base-width base-height) canvas
(setf texture (make-instance
'texture
:width (pixel-width canvas)
:height (pixel-height canvas))
fbo (gl:gen-framebuffer)
base-width (pixel-width canvas)
base-height (pixel-height canvas))
(gl:bind-framebuffer :framebuffer fbo)
(with-slots
(width height id min-filter mag-filter internal-format image-format)
texture
(setf id (gl:gen-texture)
width (pixel-width canvas)
height (pixel-height canvas))
(gl:bind-texture :texture-2d id)
(gl:tex-parameter :texture-2d :texture-min-filter min-filter)
(gl:tex-parameter :texture-2d :texture-mag-filter mag-filter)
(gl:tex-image-2d :texture-2d
0
internal-format
width
height
0
image-format
:unsigned-byte
(pixels-data canvas)))
(gl:framebuffer-texture-2d
:framebuffer
:color-attachment0
:texture-2d
(texture-id texture)
0)
; (gl:bind-texture :texture-2d 0)
(gl:bind-framebuffer :framebuffer 0)))
(defun blit (canvas)
"Blits a canvas to the its texture"
(with-slots (fbo texture data pixel-width pixel-height) canvas
(gl:bind-framebuffer :framebuffer fbo)
(gl:bind-texture :texture-2d (texture-id texture))
(gl:tex-sub-image-2d :texture-2d 0 0 0 pixel-width pixel-height :rgba :unsigned-byte data)
(gl:bind-texture :texture-2d 0)
(gl:bind-framebuffer :framebuffer 0)))
(defmethod render ((canvas canvas))
(with-slots (texture) canvas
(gl:active-texture 0)
(gl:bind-texture :texture-2d (texture-id texture))
(gl:use-program *canvas-shader-program*)
(gl:program-uniform-matrix-4fv
*canvas-shader-program*
(gl:get-uniform-location *canvas-shader-program* "TRANSFORM")
(projected-matrix canvas))
(gl:bind-vertex-array *canvas-render-vao*)
(gl:draw-arrays :triangles 0 6)
(gl:bind-vertex-array 0)))
|
