test.lisp

   1 (defpackage #:zpb-ttf-test
   2   (:use :cl)
   3   (:import-from :zpb-ttf
   4                 #:on-curve-p
   5                 #:x #:y
   6                 #:do-contour-segments*
   7                 #:do-contour-segments
   8                 #:explicit-contour-points)
   9   (:local-nicknames (:z :zpb-ttf)))
  10 (in-package #:zpb-ttf-test)
  11
  12 (defmacro contour (&rest points)
  13   `(make-array ,(length points)
  14                :initial-contents
  15                (list ,@ (loop for (x y c) in points
  16                               collect `(z::make-control-point ,x ,y ,c)))))
  17 (defun point= (a b)
  18   (or (and (not a) (not b))
  19       (and (typep a 'z::control-point)
  20            (typep b 'z::control-point)
  21            (eql (on-curve-p a) (on-curve-p b))
  22            (eql (x a) (x b))
  23            (eql (y a) (y b)))))
  24
  25 (defun contour= (a b)
  26   (and (= (length a) (length b))
  27        (loop for a across a
  28              for b across b
  29              always (point= a b))))
  30
  31 (defmacro check-dcs* (contour &body points)
  32   `(let ((contour ,contour)
  33          (points ',points))
  34      (flet ((next-point ()
  35               (let ((x (pop points)))
  36                 (when x
  37                   (destructuring-bind (x y &optional c) x
  38                     (z::make-control-point x y c ))))))
  39        (do-contour-segments* (b c) contour
  40          (assert (point= b (next-point)))
  41          (assert (point= c (next-point))))
  42        (assert (null points)))
  43      t))
  44
  45 (check-dcs* #())
  46 ;; normal contour
  47 (check-dcs* (contour (0 0 t) (1 2) (3 4 t) (5 6))
  48   (1 2) (3 4 t)
  49   (5 6) (0 0 t))
  50
  51 ;; starts on control point
  52 (check-dcs* (contour (1 2) (3 4 t) (5 6) (0 0 t))
  53   (1 2) (3 4 t)
  54   (5 6) (0 0 t))
  55
  56 ;; only control points
  57 (check-dcs* (contour (0 0) (2 2) (4 0) (2 -2))
  58   (0 0) (1 1 t)
  59   (2 2) (3 1 t)
  60   (4 0) (3 -1 t)
  61   (2 -2) (1 -1 t))
  62
  63 (defmacro check-dcs (contour &body points)
  64   `(let ((contour ,contour)
  65          (points ',points))
  66      (flet ((next-point ()
  67               (let ((x (pop points)))
  68                 (when x
  69                   (destructuring-bind (x y &optional c) x
  70                     (z::make-control-point x y c ))))))
  71        (do-contour-segments (a b c) contour
  72          (assert (point= a (next-point)))
  73          (assert (point= b (next-point)))
  74          (assert (point= c (next-point))))
  75        (assert (null points)))
  76      t))
  77
  78 (check-dcs #())
  79
  80 ;; normal contour
  81 (check-dcs (contour (0 0 t) (1 2) (3 4 t) (5 6))
  82   (0 0 t) (1 2) (3 4 t)
  83   (3 4 t) (5 6) (0 0 t))
  84
  85 ;; starts on control point
  86 (check-dcs (contour (1 2) (3 4 t) (5 6) (0 0 t))
  87   (0 0 t) (1 2) (3 4 t)
  88   (3 4 t) (5 6) (0 0 t))
  89
  90 ;; only control points
  91 (check-dcs (contour (0 0) (2 2) (4 0) (2 -2))
  92   (1 -1 t) (0 0) (1 1 t)
  93   (1 1 t) (2 2) (3 1 t)
  94   (3 1 t) (4 0) (3 -1 t)
  95   (3 -1 t) (2 -2) (1 -1 t))
  96
  97 (assert (contour= (contour (0 1) (2 3 t))
  98                   (contour (0 1) (2 3 t))))
  99
 100 (assert (not (contour= (contour (0 1 t) (2 3 t))
 101                        (contour (0 1) (2 3 t)))))
 102 (assert (not (contour= (contour (0 1))
 103                        (contour (0 1) (2 3 t)))))
 104
 105 (assert (equalp (explicit-contour-points #()) #()))
 106
 107 (assert
 108  (contour= (explicit-contour-points (contour (0 0 t) (1 2) (3 4 t) (5 6)))
 109            (contour (0 0 t) (1 2) (3 4 t) (5 6))))
 110
 111 (assert
 112  (contour= (explicit-contour-points (contour (1 2) (3 4 t) (5 6) (0 0 t)))
 113            (contour (1 2) (3 4 t) (5 6) (0 0 t))))
 114
 115 (assert
 116  (contour= (explicit-contour-points (contour (0 0) (2 2) (4 0) (2 -2)))
 117            (contour (0 0) (1 1 t)
 118                     (2 2) (3 1 t)
 119                     (4 0) (3 -1 t)
 120                     (2 -2) (1 -1 t))))
 121