zpb-ttf/test.lisp at master · xach/zpb-ttf · GitHub

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
(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))))