Merge pull request #10 from phoe-trash/master
[vecto.git] / test.lisp
blobbdafda5f5e8fa771d9d739f976345798d660780b
2 (in-package #:vecto)
4 (defun test (output-file)
5 (with-canvas (:width 100 :height 100)
6 (set-line-width 5.0)
7 ;; red stroke
8 (set-rgb-stroke 1 0 0)
9 (move-to 10 10)
10 (line-to 90 90)
11 (stroke)
12 ;; green stroke
13 (set-rgb-stroke 0 1 0)
14 (move-to 10 90)
15 (line-to 90 10)
16 (stroke)
17 ;; blue+alpha transform stroke
18 (set-rgba-stroke 0 0 1 0.5)
19 (flet ((elbow (radians)
20 (with-graphics-state
21 (translate 50 50)
22 (rotate radians)
23 (scale 0.25 0.25)
24 (move-to 0 0)
25 (curve-to 0 100
26 0 100
27 100 100)
28 (set-line-width 10.0)
29 (stroke))))
30 (let* ((rotations 25)
31 (step (/ (* pi 2) rotations)))
32 (dotimes (i rotations)
33 (elbow (* i step)))))
34 (save-png output-file)))
37 (defun test-rotate (output-file)
38 (with-canvas (:width 100 :height 100)
39 (translate 50 50)
40 (move-to 0 0)
41 (line-to 0 10)
42 (rotate (- (/ pi 4)))
43 (set-line-width 15)
44 (stroke)
45 (save-png output-file)))
47 (defun test-skew (output-file)
48 (with-canvas (:width 100 :height 100)
49 (move-to 0 0)
50 (line-to 0 75)
51 (skew (- (/ pi 4)) (- (/ pi 4)))
52 (set-line-width 15)
53 (stroke)
54 (save-png output-file)))
56 (defun hole-test (file)
57 (with-canvas (:width 100 :height 100)
58 (translate 10 10)
59 (scale 50 50)
60 (set-line-width 0.1)
61 (move-to 0 0)
62 (line-to 0 1)
63 (line-to 1 1)
64 (line-to 1 0)
65 (line-to 0 0)
66 (move-to 0.1 0.8)
67 (line-to 0.1 0.1)
68 (line-to 0.8 0.1)
69 (line-to 0.8 0.8)
70 (line-to 0.1 0.8)
71 (fill-path)
72 (save-png file)))
74 (defun rectangle-test (file)
75 (with-canvas (:width 100 :height 100)
76 (rectangle 10 10 50 50)
77 (fill-path)
78 (save-png file)))
80 (defun rectangle-fill-test (file)
81 (with-canvas (:width 5 :height 5)
82 (set-rgba-fill 1 0 0 0.5)
83 (rectangle 0 0 5 5)
84 (fill-path)
85 (save-png file)))
87 (defun circle-test (string file)
88 (with-canvas (:width 250 :height 180)
89 (set-rgb-fill 1 1 1)
90 (set-line-width 1)
91 (translate 10 10)
92 (centered-circle-path 0 0 5)
93 (fill-and-stroke)
94 (translate 15 15)
95 (centered-circle-path 0 0 8)
96 (fill-and-stroke)
97 (translate 20 24)
98 (centered-circle-path 0 0 11)
99 (fill-and-stroke)
100 (centered-ellipse-path 75 60 100 40)
101 (fill-and-stroke)
102 (let ((font (get-font "/home/xach/.fonts/vagron.ttf")))
103 (set-font font 25)
104 (translate -5 50)
105 (let ((bbox (string-bounding-box string font)))
106 (set-line-width 1)
107 (set-rgba-fill 1 0 0 0.5)
108 (rectangle (xmin bbox) (ymin bbox)
109 (- (xmax bbox) (xmin bbox))
110 (- (ymax bbox) (ymin bbox)))
111 (fill-path))
112 (set-rgb-fill 0 1 0)
113 (draw-string string))
114 (save-png file)))
116 (defun center-test (string file)
117 (with-canvas (:width 200 :height 100)
118 (let ((font (get-font #p"times.ttf")))
119 (set-font font 36)
120 (draw-centered-string 100 25 string)
121 (set-rgba-fill 1 0 0 0.5)
122 (set-rgb-stroke 0 0 0)
123 (centered-circle-path 100 25 5)
124 (stroke)
125 (save-png file))))
127 (defun twittertext (string size font file)
128 (zpb-ttf:with-font-loader (loader font)
129 (let ((bbox (string-bounding-box string size loader)))
130 (with-canvas (:width (- (ceiling (xmax bbox)) (floor (xmin bbox)))
131 :height (- (ceiling (ymax bbox)) (floor (ymin bbox))))
132 (set-font loader size)
133 (set-rgba-fill 1 1 1 0.1)
134 (clear-canvas)
135 (set-rgb-fill 0 0 0)
136 (translate (- (xmin bbox)) (- (ymin bbox)))
137 (draw-string 0 0 string)
138 (save-png file)))))
140 (defun arc-to (center-x center-y radius start extent)
141 ;; An arc of extent zero will generate an error at bezarc (divide by zero).
142 ;; This case may be given by two aligned points in a polyline.
143 ;; Better do nothing.
144 (unless (zerop extent)
145 (if (<= (abs extent) (/ pi 2.0))
146 (multiple-value-bind (x1 y1 x2 y2 x3 y3)
147 (bezarc center-x center-y radius start extent)
148 (curve-to x1 y1 x2 y2 x3 y3))
149 (let ((half-extent (/ extent 2.0)))
150 (arc-to center-x center-y radius start half-extent)
151 (arc-to center-x center-y radius (+ start half-extent) half-extent)))))
153 (defun bezarc (center-x center-y radius start extent)
154 ;; start and extent should be in radians.
155 ;; Returns first-control-point-x first-control-point-y
156 ;; second-control-point-x second-control-point-y
157 ;; end-point-x end-point-y
158 (let* ((end (+ start extent))
159 (s-start (sin start)) (c-start (cos start))
160 (s-end (sin end)) (c-end (cos end))
161 (ang/2 (/ extent 2.0))
162 (kappa (* (/ 4.0 3.0)
163 (/ (- 1 (cos ang/2))
164 (sin ang/2))))
165 (x1 (- c-start (* kappa s-start)))
166 (y1 (+ s-start (* kappa c-start)))
167 (x2 (+ c-end (* kappa s-end)))
168 (y2 (- s-end (* kappa c-end))))
169 (values (+ (* x1 radius) center-x)(+ (* y1 radius) center-y)
170 (+ (* x2 radius) center-x)(+ (* y2 radius) center-y)
171 (+ (* c-end radius) center-x)(+ (* s-end radius) center-y))))
173 (defun degrees (degrees)
174 (* (/ pi 180) degrees))
176 (defun arc-test (file)
177 (with-canvas (:width 100 :height 100)
178 (rotate-degrees 15)
179 (translate 0 10)
180 (set-line-width 10)
181 (move-to 75 0)
182 (arc-to 0 0 75 0 (degrees 15))
183 (stroke)
184 (save-png file)))
187 (defun rect-test (file)
188 (with-canvas (:width 5 :height 5)
189 (set-rgba-fill 1 0 0 0.5)
190 (rectangle 0 0 5 5)
191 (fill-path)
192 (save-png file)))
194 (defun text-test (&key string size font file)
195 (with-canvas (:width 200 :height 200)
196 (let ((loader (get-font font)))
197 (set-rgb-fill 0.8 0.8 0.9)
198 (clear-canvas)
199 (set-font loader size)
200 (set-rgb-fill 0.0 0.0 0.3)
201 (scale 0.5 0.5)
202 (rotate (* 15 (/ pi 180)))
203 (draw-string 10 10 string)
204 (save-png file))))
207 (defun dash-test (file)
208 (with-canvas (:width 200 :height 200)
209 (rectangle 10 10 125 125)
210 (set-rgba-fill 0.3 0.5 0.9 0.5)
211 (set-line-width 4)
212 (set-dash-pattern #(10 10) 5)
213 (fill-and-stroke)
214 (save-png file)))
216 (defun sign-test (string font file &key
217 (font-size 72)
218 (outer-border 2)
219 (stripe-width 5)
220 (inner-border 2)
221 (corner-radius 10))
222 (zpb-ttf:with-font-loader (loader font)
223 (let* ((bbox (string-bounding-box string font-size loader))
224 (text-height (ceiling (- (ymax bbox) (ymin bbox))))
225 (text-width (ceiling (- (xmax bbox) (xmin bbox))))
226 (stripe/2 (/ stripe-width 2.0))
227 (b1 (+ outer-border stripe/2))
228 (b2 (+ inner-border stripe/2))
229 (x0 0)
230 (x1 (+ x0 b1))
231 (x2 (+ x1 b2))
232 (y0 0)
233 (y1 (+ y0 b1))
234 (y2 (+ y1 b2))
235 (width (truncate (+ text-width (* 2 (+ b1 b2)))))
236 (width1 (- width (* b1 2)))
237 (height (truncate (+ text-height (* 2 (+ b1 b2)))))
238 (height1 (- height (* b1 2))))
239 (with-canvas (:width width :height height)
240 (set-rgb-fill 0.0 0.43 0.33)
241 (set-rgb-stroke 0.95 0.95 0.95)
242 ;; Stripe shadow + stripe
243 (set-line-width stripe-width)
244 (with-graphics-state
245 (translate 2 -2)
246 (set-rgba-stroke 0.0 0.0 0.0 0.3)
247 (rounded-rectangle x1 y1
248 width1 height1
249 corner-radius corner-radius)
250 (fill-and-stroke))
251 (rounded-rectangle x1 y1
252 width1 height1
253 corner-radius corner-radius)
254 (set-dash-pattern #(10 20) 0)
255 (stroke)
256 ;; Text shadow & text
257 (set-font loader font-size)
258 (translate (- (xmin bbox)) (- (ymin bbox)))
259 (with-graphics-state
260 (translate 1 -1)
261 (set-rgba-fill 0.0 0.0 0.0 1.0)
262 (draw-string x2 y2 string))
263 (set-rgb-fill 0.95 0.95 0.95)
264 (draw-string x2 y2 string)
265 (save-png file)))))
276 (defun fill-test (file)
277 (with-canvas (:width 100 :height 100)
278 (set-rgb-stroke 1 0 0)
279 (set-rgb-fill 0 1 0)
280 (move-to 0 0)
281 (line-to 50 50)
282 (line-to 100 10)
283 (fill-and-stroke)
284 (save-png file)))
286 (defun circle-test (file)
287 (with-canvas (:width 1000 :height 1000)
288 (scale 5 10)
289 (set-line-width 3)
290 (centered-circle-path 50 50 45)
291 (set-rgb-fill 1 1 0)
292 (fill-and-stroke)
293 (save-png file)))
297 (defun test-gradient (file fun)
298 (with-canvas (:width 500 :height 500)
299 (with-graphics-state
300 (set-gradient 100 100 1 0 0 1
301 200 235 0 1 0 1
302 :domain-function fun)
303 (rectangle 0 0 500 500)
304 (fill-path))
305 (with-graphics-state
306 (set-rgba-stroke 1 1 1 0.5)
307 (set-dash-pattern #(10 10) 0)
308 (move-to 100 100)
309 (line-to 200 235)
310 (stroke))
311 (set-rgb-stroke 1 1 1)
312 (centered-circle-path 100 100 10)
313 (stroke)
314 (set-rgb-stroke 0 0 0)
315 (centered-circle-path 200 235 10)
316 (stroke)
317 (set-rgb-fill 1 1 1)
318 (let* ((font (get-font #p"~/.fonts/cour.ttf"))
319 (name (string-downcase fun))
320 (bbox (geometry:bbox-box (string-bounding-box name 24 font))))
321 (translate 200 300)
322 (set-font font 24)
323 (setf bbox (geometry:expand bbox 10))
324 (rectangle (geometry:xmin bbox) (geometry:ymin bbox)
325 (geometry:width bbox) (geometry:height bbox))
326 (fill-and-stroke)
327 (set-rgb-fill 0 0 0)
328 (draw-string 0 0 (string-downcase fun))
329 (fill-path)
330 (save-png file))))