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               (if b
  42                   (path-extend path (make-bezier-curve (list pb)) pc)
  43                   (path-extend path (make-straight-line) pc))
  44               (setf last-point pc)))
  45           (when (minusp (* scale-x scale-y))
  46             (path-reverse path))
  47           (push path result)))
  48       (setq result (nreverse result))
  49       (when auto-orient
  50         (path-orient (car result) auto-orient (cdr result)))
  51       result)))
  52
  53 (defun paths-from-string (font-loader text &key (offset (make-point 0 0))
  54                                                 (scale-x 1.0) (scale-y 1.0)
  55                                                 (kerning t) (auto-orient nil))
  56   "Extract paths from a string."
  57   (let (result)
  58     (loop
  59        for previous-char = nil then char
  60        for char across text
  61        for previous-glyph = nil then glyph
  62        for glyph = (find-glyph char font-loader)
  63        do (when previous-char
  64             (setf offset
  65                   (paths::p+ offset
  66                              (make-point (* scale-x
  67                                             (+ (advance-width previous-glyph)
  68                                                (if kerning
  69                                                    (kerning-offset previous-char
  70                                                                    char
  71                                                                    font-loader)
  72                                                    0)))
  73                                          0))))
  74        (let ((glyph-paths (paths-from-glyph glyph
  75                                             :offset offset :auto-orient auto-orient
  76                                             :scale-x scale-x :scale-y scale-y)))
  77          (push glyph-paths result)))
  78     (apply #'nconc (nreverse result))))
  79
  80 (defun make-string-path (font-loader text &key (position (make-point 0 0)) (size 12)
  81                                                (halign :left) (valign :baseline)
  82                                                (inverted t) (kerning t))
  83   (let* ((em (units/em font-loader))
  84          (scale (/ size em))
  85          (scale-x scale)
  86          (scale-y scale))
  87     (when inverted
  88       (setf scale-y (- scale-y)))
  89     (let ((bb (string-bounding-box text font-loader :kerning kerning)))
  90       (setf position (p- position
  91                          (p* (make-point
  92                               (ecase halign
  93                                 (:none
  94                                  0)
  95                                 (:left
  96                                  (aref bb 0))
  97                                 (:right
  98                                  (aref bb 2))
  99                                 (:center
 100                                  (/ (+ (aref bb 0) (aref bb 2)) 2.0)))
 101                               (ecase valign
 102                                 (:baseline
 103                                  0)
 104                                 (:top
 105                                  (aref bb 1))
 106                                 (:bottom
 107                                  (aref bb 3))
 108                                 (:center
 109                                  (/ (+ (aref bb 1) (aref bb 3)) 2.0))))
 110                              scale))))
 111     (paths-from-string font-loader text :offset position
 112                        :scale-x scale-x :scale-y scale-y
 113                        :kerning kerning
 114                        :auto-orient :cw)))