aboutsummaryrefslogtreecommitdiffhomepage
path: root/src/canvas-language.lisp
blob: fb3b6796439b1a9f44b8c7de38b30bc8351591de (plain)
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
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
;;;; canvas-language.lisp  -- a drawing api for canvas instances

(in-package #:wheelwork)

(defvar *current-canvas* nil)
(defvar *current-pen-color* '(0 0 0 255))
(defvar *current-pen-width* 1)
(defvar *current-pen-position* '(0 0))
(defvar *saved-state* nil)

(defmacro with-current-pen-state ( &body body)
  "Saves the current pen state (color width position) so that it can
   be restored from using (restore-pen-state) from within the BODY.
   After BODY executes the state is restored to whatever it was
   before WITH-CURRENT-PEN-STATE was evaluated."
  `(let 
       ((*saved-state*
          (list *current-pen-width*
                *current-pen-position*
                *current-pen-color*)))
     ,@body))

(defmacro with-pen ((&key position (color nil color-supplied-p) width) &body body)
  "Like WITH-CURRENT-PEN-STATE, but lets you set the state of the pen
  EXECUTION BODY.  After BODY executes, the state is restored to
  whatever it was before WITH-PEN-STATE was evaluated."
  `(let ((*current-pen-position* ,(if position nil '*current-pen-position*))
         (*current-pen-color* ,(if color-supplied-p nil '*current-pen-color*))
         (*current-pen-width* ,(if width nil '*current-pen-width*)))
     ,(when position
        `(move-to ,@position))
     ,(when color-supplied-p
        `(canvas-pen-color ,color))
     ,(when width
        `(canvas-pen-width ,width))
     (with-current-pen-state
       ,@body)))

(defmacro with-pen-color (list-or-fn &body body)
  "Temporarily bind pen color to the value of LIST-OR-FN and execute BODY."
  `(let ((*current-pen-color* nil))
     (canvas-pen-color ,list-or-fn)
     ,@body))


(defmacro with-canvas (canvas &body body)
  "Perform drawing commands in BODY using the value of CANVAS as the
   target of any drawing operations."
  `(let ((*current-canvas* ,canvas)
         (*current-pen-width* 1)
         (*current-pen-position* (list 0 0))
         (*current-pen-color* (list 0 0 0 255)))
     (with-current-pen-state 
       ,@body)))

(defun restore-pen ()
  "Restore the state of the pan (width position color) as previously
saved by WITH-PEN-STATE"
  (destructuring-bind (pw pp pc) *saved-state*
    (setf *current-pen-width* pw
          *current-pen-position* pp
          *current-pen-color* pc)))


(defun colfix (c)
  (round (clamp 0 c 255)))

(defun canvas-pen-color (&optional newpen)
  "Set the pens color in the current context. NEWPEN, if supplied, can be one of:

  NIL - set the color to black.
 
  A list of four unsigned 8 bit integers that looks like (R G B A).
 
  A function (or symbol naming a function) that accepts the
  coordinates X Y of the pixel being drawn and returns a list as in
  the above case.

  All RGBA component values obtained from a pen (either from the
  return of a functional pen or as members of a list value) are
  clamped between 0 and 255."
  (setf *current-pen-color* 
        (etypecase newpen
          (null nil)
          ((or symbol function)
           (lambda (x y)
             (mapcar #'colfix (funcall newpen x y))))
          (list
           (mapcar #'colfix newpen)))))

(defun canvas-pen-width (n)
  "Set the cavnas pen width. This is approximately how many pixels
wide a line drawn with the pen will be.  If N is not a positive
integer."
  (setf *current-pen-width* n))

(defun can-fill-canvas-at-p (x y)
  (with-slots (pixel-width pixel-height) *current-canvas*
    (and (< -1 x pixel-width)
         (< -1 y pixel-height))))

(defun rel-to-current-pos (path)
  (destructuring-bind (cx cy) *current-pen-position* 
    (loop for (x y) in path collect (list (+ cx x) (+ cy y)))))

(defun move-to (x y)
  "Sets the pen's position without drawing. "
  (setf *current-pen-position* (list x y)))

(defun move-rel (dx dy)
  "Moves the current pen by dx dy."
  (setf *current-pen-position*
        (mapcar #'+ *current-pen-position* (list dx dy))))

(defun apply-pen-at (x y)
  "Draws the pen onto the canvas at the location X Y. If the pen width
is 1 the just one pixel is drawn. If 2 then 4 are drawn, and so on. "
  (let ((w
          (max 0 (1- *current-pen-width*))))
    (destructuring-bind
        (cr cg cb ca)
        (etypecase *current-pen-color*
          (null (list 0 0 0 255))
          (list *current-pen-color*)
          (function (funcall *current-pen-color* x y))) 
      (with-grid-rect (rx ry) (x y (+ x w) (+ y w))
        (when (can-fill-canvas-at-p rx ry) 
          (with-pixel (r g b a) (pixel *current-canvas* rx ry)
            (setf r cr g cg b cb a ca)))))))

(defun stroke-to (ex ey)
  "Draw a line from the current pen position to EX EY."
  (destructuring-bind (sx sy) *current-pen-position* 
    (with-grid-line (x y) (sx sy) (ex ey)
      (apply-pen-at x y)))
  (setf *current-pen-position* (list ex ey)))

(defun stroke-rel (dx dy)
  "Draw a line from the current pen position to a distance DX DY away."
  (apply #'stroke-to (mapcar #'+ *current-pen-position* (list dx dy))))

(defun stroke-path (path)
  "Draw a path. PATH is a list of (X Y) points. The pen is moved to
the first point and then each point is connnected. At last, the pen's
position is set to the last point. "
  (with-grid-path (x y) (path) (apply-pen-at x y))
  (setf *current-pen-position* (copy-list (first (last path)))))

(defun stroke-rel-path (path)
  "Draw a path starting at the current point. PATH is a list of DX DY
values, each of which is relative to the current position of the PEN.

If you are looking for a function where each subsequent point moves
the pen relative to its antecedent, look at STROKE-STEPS"
  (stroke-path
   (cons *current-pen-position*
         (rel-to-current-pos path))))

(defun steps-to-concrete-points (steps)
  (loop
    with (cx cy) = *current-pen-position*
    for (dx dy) in steps
    do (incf cx dx)
       (incf cy dy)
    collect (list cx cy)))

(defun stroke-steps (steps)
  "STEPS is a list of (dx dy) steps. The pen starts at the current
positoin and draws a path, each step on the path moves the pen dx dy
from its then current location."
  (stroke-path
   (cons *current-pen-position*
         (steps-to-concrete-points steps))))



(defun fill-path (path)
  "Draws path as a closed polygon (implicitly connecting the first and
last points in PATH)."
  (let ((*current-pen-width* 1)) 
    (with-grid-path (x y) (path :interiorp t)
      (apply-pen-at x y))))

(defun fill-steps (steps)
  "Like STROKE-STEPS but implicitly connects the first and last points
  to be drawn and fills the resulting polygon in with the current pen."
  (fill-path
   (cons *current-pen-position*
         (steps-to-concrete-points steps))))

(defun fill-rel-path (path)
  "See STROKE-REL-PATH."
  (fill-path
   (cons *current-pen-position*
         (rel-to-current-pos path))))

(defun stroke-rect (left bottom right top)
  "Draws a rectangle."
  (stroke-path (list (list left bottom)
                     (list left top)
                     (list right top)
                     (list right bottom)
                     (list left bottom))))

(defun stroke-rel-rect (dx dy)
  "Draws a rectangle relative to the current position."
  (destructuring-bind (sx sy) *current-pen-position*
    (let ((left
            (if (plusp dx) sx (+ sx dx)))
          (right
            (if (plusp dx) (+ sx dx) sx))
          (bottom
            (if (plusp dy) sy (+ sy dy)))
          (top
            (if (plusp dy) (+ sy dy) sy)))
      (stroke-rect left bottom right top))))

(defun fill-rect (left bottom right top)
  "Fills in a rectangle."
  (let ((*current-pen-width* 1))
    (with-grid-rect (x y) (left bottom right top)
      (apply-pen-at x y)))
  (setf *current-pen-position* (list left bottom)))

(defun fill-rel-rect (dx dy)
  "Fills in a rectangle relative to current position."
  (destructuring-bind (sx sy) *current-pen-position*
    (let ((left
            (if (plusp dx) sx (+ sx dx)))
          (right
            (if (plusp dx) (+ sx dx) sx))
          (bottom
            (if (plusp dy) sy (+ sy dy)))
          (top
            (if (plusp dy) (+ sy dy) sy)))
      (fill-rect left bottom right top))))

(defun stroke-bezier (control-pts &optional (curve-samples 10))
  "Draws a bezier curve with control points CONTROL-PTS. CURVE-SAMPLES
is the number of points on the 'real bezier curve' that will be
connected by straight lines to form an approximate curve. Use a higher
value for smoother looking curves."
  (let (path)
    (with-grid-bezier (x y) (control-pts :count curve-samples)
      (push (list x y) path))
    (stroke-path (reverse path))))

(defun stroke-rel-bezier (rel-control-points &optional (curve-samples 10))
  "Like STROKE-BEZIER but REL-CONTROL-POINTS are (DX DY) that
represent the position of control points relative to the current pen
position."
  (stroke-bezier (cons *current-pen-position*
                       (rel-to-current-pos rel-control-points))
                 curve-samples))

(defun fill-bezier (control-pts &optional (curve-samples 10))
  "Like STROKE-BEZIER but will implicitly connect the first and last
curve sample points and fill in the resulting polygon."
  (let (path)
    (with-grid-bezier (x y) (control-pts :count curve-samples)
      (push (list x y) path))
    (fill-path (reverse path))))

(defun fill-rel-bezier (rel-control-points &optional (curve-samples 10))
  "Like STROKE-REL-BEZIER and FILL-BEZIER."
  (fill-bezier (cons *current-pen-position*
                     (rel-to-current-pos rel-control-points))
               curve-samples))