vectometry/vectometry.lisp

   1 ;;;; vectometry.lisp
   2
   3 (in-package #:vectometry)
   4
   5 (defun move-to (p)
   6   (vecto:move-to (x p) (y p)))
   7
   8 (defun line-to (p)
   9   (vecto:line-to (x p) (y p)))
  10
  11 (defun curve-to (control1 control2 end)
  12   (vecto:curve-to (x control1) (y control1)
  13                   (x control2) (y control2)
  14                   (x end)      (y end)))
  15
  16 (defun quadratic-to (control end)
  17   (vecto:quadratic-to (x control) (y control)
  18                       (x end)     (y end)))
  19
  20 (defun draw-string (p string)
  21   (vecto:draw-string (x p) (y p) string))
  22
  23 (defun draw-centered-string (p string)
  24   (vecto:draw-centered-string (x p) (y p) string))
  25
  26 (defun string-paths (p string)
  27   (vecto:string-paths (x p) (y p) string))
  28
  29 (defun string-bounding-box (string size loader)
  30   (bbox-box (vecto:string-bounding-box string size loader)))
  31
  32 (defun arc (center radius theta1 theta2)
  33   (vecto:arc (x center) (y center) radius theta1 theta2))
  34
  35 (defun arcn (center radius theta1 theta2)
  36   (vecto:arcn (x center) (y center) radius theta1 theta2))
  37
  38 (defun rectangle (box)
  39   (vecto:rectangle (xmin box) (ymin box) (width box) (height box)))
  40
  41 (defun rounded-rectangle (box rx ry)
  42   (vecto:rounded-rectangle (xmin box) (ymin box)
  43                            (width box) (height box)
  44                            rx ry))
  45
  46 (defun centered-ellipse-path (center rx ry)
  47   (vecto:centered-ellipse-path (x center) (y center) rx ry))
  48
  49 (defun centered-circle-path (center radius)
  50   (vecto:centered-circle-path (x center) (y center) radius))
  51
  52 (defun translate (point)
  53   (vecto:translate (x point) (y point)))
  54
  55 (defmacro with-box-canvas (box &body body)
  56   (let ((box* (gensym "BOX")))
  57     `(let* ((,box* ,box))
  58        (with-canvas (:width (ceiling (width ,box*))
  59                             :height (ceiling (height ,box*)))
  60          (let ((p (neg (minpoint ,box*))))
  61            (translate (point (ceiling (x p))
  62                              (ceiling (y p)))))
  63          ,@body))))
  64
  65
  66 (defgeneric top-left (object)
  67   (:method (object)
  68     (let ((box (bounding-box object)))
  69       (point (xmin box) (ymax box)))))
  70
  71 (defgeneric top-right (object)
  72   (:method (object)
  73     (maxpoint (bounding-box object))))
  74
  75 (defgeneric bottom-left (object)
  76   (:method (object)
  77     (minpoint (bounding-box object))))
  78
  79 (defgeneric bottom-right (object)
  80   (:method (object)
  81     (let ((box (bounding-box object)))
  82       (point (xmax box) (ymin box)))))
  83
  84 (macrolet ((compass-point-method (name component1 &optional component2)
  85              (if component2
  86                  `(defgeneric ,name (object)
  87                     (:method (object)
  88                       (midpoint (,component1 object)
  89                                 (,component2 object))))
  90                  `(defgeneric ,name (object)
  91                     (:method (object)
  92                       (,component1 object))))))
  93   (compass-point-method northpoint top-left top-right)
  94   (compass-point-method northeastpoint top-right)
  95   (compass-point-method eastpoint top-right bottom-right)
  96   (compass-point-method southeastpoint bottom-right)
  97   (compass-point-method southpoint bottom-left bottom-right)
  98   (compass-point-method southwestpoint bottom-left)
  99   (compass-point-method westpoint bottom-left top-left)
 100   (compass-point-method northwestpoint top-left))
 101
 102
 103 (defun set-gradient-fill (p1 c1 p2 c2
 104                           &key (extend-start t) (extend-end t)
 105                           (domain-function 'vecto:linear-domain))
 106   (vecto:set-gradient-fill (x p1) (y p1)
 107                            (red c1) (green c1) (blue c1) (alpha c1)
 108                            (x p2) (y p2)
 109                            (red c2) (green c2) (blue c2) (alpha c2)
 110                            :extend-start extend-start
 111                            :extend-end extend-end
 112                            :domain-function domain-function))
 113
 114
 115 (defmethod bounding-box ((glyph zpb-ttf::glyph))
 116   (bbox-box (zpb-ttf:bounding-box glyph)))