paths-ttf.lisp

   1 ;;;; cl-vectors -- Rasterizer and paths manipulation library
   2 ;;;; Copyright (C) 2007  Frédéric Jolliton <frederic@jolliton.com>
   3 ;;;;
   4 ;;;; This library is free software; you can redistribute it and/or
   5 ;;;; modify it under the terms of the Lisp Lesser GNU Public License
   6 ;;;; (http://opensource.franz.com/preamble.html), known as the LLGPL.
   7 ;;;;
   8 ;;;; This library is distributed in the hope that it will be useful, but
   9 ;;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the Lisp
  11 ;;;; Lesser GNU Public License for more details.
  12
  13 (defpackage #:net.tuxee.paths-ttf
  14   (:use #:cl #:net.tuxee.paths #:zpb-ttf)
  15   (:nicknames #:paths-ttf)
  16   (:export #:paths-from-glyph
  17            #:paths-from-string
  18            #:make-string-path))
  19
  20 (in-package #:net.tuxee.paths-ttf)
  21
  22 (defun paths-from-glyph (glyph &key (offset (make-point 0 0))
  23                                     (scale-x 1.0) (scale-y 1.0)
  24                                     (auto-orient nil))
  25   "Extract paths from a glyph."
  26   (flet ((point (p) (p+ (make-point (* (x p) scale-x)
  27                                     (* (y p) scale-y))
  28                         offset)))
  29     (let (result)
  30       (do-contours (contour glyph)
  31         (let ((path (create-path :polygon))
  32               (last-point nil))
  33           (do-contour-segments (a b c) contour
  34             (let ((pa (point a))
  35                   (pb (when b (point b)))
  36                   (pc (point c)))
  37               (if last-point
  38                   (assert (and (= (point-x last-point) (point-x pa))
  39                                (= (point-y last-point) (point-y pa))))
  40                   (path-reset path pa))
  41               (path-extend path
  42                            (if b
  43                                (make-bezier-curve (list pb))
  44                                (make-straight-line))
  45                            pc)
  46               (setq last-point pc)))
  47           (when (minusp (* scale-x scale-y))
  48             (path-reverse path))
  49           (push path result)))
  50       (setq result (nreverse result))
  51       (when (and auto-orient result)
  52         (path-orient (car result) auto-orient (cdr result)))
  53       result)))
  54
  55 (defun paths-from-string (font-loader text &key (offset (make-point 0 0))
  56                                                 (scale-x 1.0) (scale-y 1.0)
  57                                                 (kerning t) (auto-orient nil))
  58   "Extract paths from a string."
  59   (let (result)
  60     (loop
  61        for previous-char = nil then char
  62        for char across text
  63        for previous-glyph = nil then glyph
  64        for glyph = (find-glyph char font-loader)
  65        do (when previous-char
  66             (setf offset
  67                   (p+ offset
  68                       (make-point (* scale-x
  69                                      (+ (advance-width previous-glyph)
  70                                         (if kerning
  71                                             (kerning-offset previous-char
  72                                                             char
  73                                                             font-loader)
  74                                             0)))
  75                                   0))))
  76        (let ((glyph-paths (paths-from-glyph glyph
  77                                             :offset offset :auto-orient auto-orient
  78                                             :scale-x scale-x :scale-y scale-y)))
  79          (push glyph-paths result)))
  80     (apply #'nconc (nreverse result))))
  81
  82 (defun make-string-path (font-loader text &key (position (make-point 0 0)) (size 12)
  83                                                (halign :left) (valign :baseline)
  84                                                (inverted t) (kerning t))
  85   (let* ((em (units/em font-loader))
  86          (scale (/ size em))
  87          (scale-x scale)
  88          (scale-y scale))
  89     (when inverted
  90       (setq scale-y (- scale-y)))
  91     (let ((bb (string-bounding-box text font-loader :kerning kerning)))
  92       (setq position (p- position
  93                          (p* (make-point
  94                               (ecase halign
  95                                 (:none
  96                                  0)
  97                                 (:left
  98                                  (aref bb 0))
  99                                 (:right
 100                                  (aref bb 2))
 101                                 (:center
 102                                  (/ (+ (aref bb 0) (aref bb 2)) 2.0)))
 103                               (ecase valign
 104                                 (:baseline
 105                                  0)
 106                                 (:top
 107                                  (aref bb 1))
 108                                 (:bottom
 109                                  (aref bb 3))
 110                                 (:center
 111                                  (/ (+ (aref bb 1) (aref bb 3)) 2.0))))
 112                              scale))))
 113     (paths-from-string font-loader text :offset position
 114                        :scale-x scale-x :scale-y scale-y
 115                        :kerning kerning
 116                        :auto-orient :cw)))