vectometry/box-text.lisp

   1 ;;;; boxtext.lisp
   2
   3 (in-package #:vectometry)
   4
   5 (defparameter *horizontal-alignments*
   6   #(:before :left :center :right :after))
   7
   8 (defparameter *vertical-alignments*
   9   #(:below :bottom :middle :top :atop))
  10
  11 (defun rotate-alignment (horizontal vertical rotation)
  12   (let ((h (position horizontal *horizontal-alignments*))
  13         (v (position vertical *vertical-alignments*)))
  14     (flet ((invert (i)
  15              (- (length *horizontal-alignments*) i 1)))
  16       (unless h
  17         (error "Invalid horizontal alignment ~S" horizontal))
  18       (unless v
  19         (error "Invalid vertical alignment ~S" vertical))
  20       (ecase rotation
  21         (:none)
  22         (:right
  23          (psetf h (invert v) v h))
  24         (:left
  25          (psetf v (invert h) h v))
  26         (:invert
  27          (psetf h (invert h) v (invert v))))
  28       (values (aref *horizontal-alignments* h)
  29               (aref *vertical-alignments* v)))))
  30
  31 (defun draw-box-text (box text &key size loader
  32                                  (horizontal :left) (vertical :bottom)
  33                                  (rotation :none))
  34   (let ((stringbox (string-bounding-box text size loader))
  35         (x (xmin box))
  36         (y (ymin box))
  37         (center (centerpoint box)))
  38     (flet ((handle-rotation (point degrees h v)
  39              (with-graphics-state
  40                (translate point)
  41                (rotate-degrees degrees)
  42                (let ((box* (if (= degrees 180)
  43                                box
  44                                (transpose box))))
  45                  (setf box* (displace box* (neg (minpoint box))))
  46                  (return-from draw-box-text
  47                    (draw-box-text box* text :size size :loader loader
  48                             :horizontal h :vertical v
  49                             :rotation :none))))))
  50       (ecase rotation
  51         (:none)
  52         (:left
  53          (multiple-value-bind (h v)
  54              (rotate-alignment horizontal vertical rotation)
  55            (handle-rotation (bottom-right box) 90 h v)))
  56         (:right
  57          (multiple-value-bind (h v)
  58              (rotate-alignment horizontal vertical rotation)
  59            (handle-rotation (top-left box) -90 h v)))
  60         (:invert
  61          (multiple-value-bind (h v)
  62              (rotate-alignment horizontal vertical rotation)
  63            (handle-rotation (maxpoint box) 180 h v))))
  64       (ecase horizontal
  65         (:before (setf x (- (xmin box) (width stringbox))))
  66         (:left)
  67         (:center (setf x (- (x center) (/ (width stringbox) 2))))
  68         (:right (setf x (- (xmax box) (xmax stringbox))))
  69         (:after (setf x (xmax box))))
  70       (ecase vertical
  71         (:atop (setf y (ymax box)))
  72         (:top (setf y (- (ymax box) size)))
  73         (:middle (setf y (- (y center) (/ size 2))))
  74         (:bottom)
  75         (:below (setf y (- (ymin box) size))))
  76       (let ((origin (point x y)))
  77         (draw-string origin text)))))
  78
  79 #+nil
  80 (defun testo (file)
  81   (with-box-canvas (box 0 0 800 800)
  82     (let ((tbox (box 50 50 700 500))
  83           (font (get-font "~/Documents/Marydale.ttf")))
  84       (set-font font 18)
  85       (set-stroke-color (hsv-color 1 1 1))
  86       (rectangle tbox)
  87       (stroke)
  88       (draw-box-text tbox "CENTER ATOP" :size 18 :loader font
  89                      :horizontal :center
  90                      :vertical :atop
  91                      :rotation :invert)
  92       (draw-box-text tbox "AFTER BELOW" :size 18 :loader font
  93                      :horizontal :after
  94                      :vertical :below)
  95       (save-png file))))
  96