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
|
(defpackage #:zpb-ttf-test
(:use :cl)
(:import-from :zpb-ttf
#:on-curve-p
#:x #:y
#:do-contour-segments*
#:do-contour-segments
#:explicit-contour-points)
(:local-nicknames (:z :zpb-ttf)))
(in-package #:zpb-ttf-test)
(defmacro contour (&rest points)
`(make-array ,(length points)
:initial-contents
(list ,@ (loop for (x y c) in points
collect `(z::make-control-point ,x ,y ,c)))))
(defun point= (a b)
(or (and (not a) (not b))
(and (typep a 'z::control-point)
(typep b 'z::control-point)
(eql (on-curve-p a) (on-curve-p b))
(eql (x a) (x b))
(eql (y a) (y b)))))
(defun contour= (a b)
(and (= (length a) (length b))
(loop for a across a
for b across b
always (point= a b))))
(defmacro check-dcs* (contour &body points)
`(let ((contour ,contour)
(points ',points))
(flet ((next-point ()
(let ((x (pop points)))
(when x
(destructuring-bind (x y &optional c) x
(z::make-control-point x y c ))))))
(do-contour-segments* (b c) contour
(assert (point= b (next-point)))
(assert (point= c (next-point))))
(assert (null points)))
t))
(check-dcs* #())
;; normal contour
(check-dcs* (contour (0 0 t) (1 2) (3 4 t) (5 6))
(1 2) (3 4 t)
(5 6) (0 0 t))
;; starts on control point
(check-dcs* (contour (1 2) (3 4 t) (5 6) (0 0 t))
(1 2) (3 4 t)
(5 6) (0 0 t))
;; only control points
(check-dcs* (contour (0 0) (2 2) (4 0) (2 -2))
(0 0) (1 1 t)
(2 2) (3 1 t)
(4 0) (3 -1 t)
(2 -2) (1 -1 t))
(defmacro check-dcs (contour &body points)
`(let ((contour ,contour)
(points ',points))
(flet ((next-point ()
(let ((x (pop points)))
(when x
(destructuring-bind (x y &optional c) x
(z::make-control-point x y c ))))))
(do-contour-segments (a b c) contour
(assert (point= a (next-point)))
(assert (point= b (next-point)))
(assert (point= c (next-point))))
(assert (null points)))
t))
(check-dcs #())
;; normal contour
(check-dcs (contour (0 0 t) (1 2) (3 4 t) (5 6))
(0 0 t) (1 2) (3 4 t)
(3 4 t) (5 6) (0 0 t))
;; starts on control point
(check-dcs (contour (1 2) (3 4 t) (5 6) (0 0 t))
(0 0 t) (1 2) (3 4 t)
(3 4 t) (5 6) (0 0 t))
;; only control points
(check-dcs (contour (0 0) (2 2) (4 0) (2 -2))
(1 -1 t) (0 0) (1 1 t)
(1 1 t) (2 2) (3 1 t)
(3 1 t) (4 0) (3 -1 t)
(3 -1 t) (2 -2) (1 -1 t))
(assert (contour= (contour (0 1) (2 3 t))
(contour (0 1) (2 3 t))))
(assert (not (contour= (contour (0 1 t) (2 3 t))
(contour (0 1) (2 3 t)))))
(assert (not (contour= (contour (0 1))
(contour (0 1) (2 3 t)))))
(assert (equalp (explicit-contour-points #()) #()))
(assert
(contour= (explicit-contour-points (contour (0 0 t) (1 2) (3 4 t) (5 6)))
(contour (0 0 t) (1 2) (3 4 t) (5 6))))
(assert
(contour= (explicit-contour-points (contour (1 2) (3 4 t) (5 6) (0 0 t)))
(contour (1 2) (3 4 t) (5 6) (0 0 t))))
(assert
(contour= (explicit-contour-points (contour (0 0) (2 2) (4 0) (2 -2)))
(contour (0 0) (1 1 t)
(2 2) (3 1 t)
(4 0) (3 -1 t)
(2 -2) (1 -1 t))))
|
