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