Font-family matching (match-font) + cmap parse-once cache

FONT-LICENSES.md

@@ -0,0 +1,22 @@
+# Shipped font licenses
+
+The fonts in `fonts/` are **shipped with scribe** as the default face set for
+`match-font` (the CSS font-matching service). They are the metric-compatible
+substitutes browsers use on Linux for Arial/Helvetica, Times, and Courier, so a
+consumer that asks for those families gets browser-accurate text metrics.
+
+scribe itself (the code) is MIT — see the top-level `LICENSE`. The fonts keep
+their own licenses, reproduced/identified below.
+
+## Liberation Sans / Serif / Mono (Regular, Bold, Italic, BoldItalic)
+**Liberation Fonts** — metric-compatible with Arial/Helvetica (Sans),
+Times New Roman (Serif), and Courier New (Mono). Licensed under the
+**SIL Open Font License, Version 1.1** (with the original Liberation builds also
+having been distributed under the GPL v2 with a font-embedding exception). The
+SIL OFL permits use, study, modification, embedding, and redistribution,
+including bundling with software, provided the fonts are not sold on their own
+and — if modified — are not distributed under the reserved "Liberation" name.
+
+Copyright © 2012 Red Hat, Inc., with Liberation being a trademark of Red Hat.
+Upstream: https://github.com/liberationfonts/liberation-fonts
+Full license text: `fonts/LICENSE-Liberation.txt`.

fonts/LICENSE-Liberation.txt

@@ -0,0 +1,104 @@
+Liberation Fonts
+
+Digitized data copyright (c) 2010 Google Corporation with Reserved Font Arimo, Tinos and Cousine.
+Copyright (c) 2012 Red Hat, Inc. with Reserved Font Name Liberation.
+
+Upstream: https://github.com/liberationfonts/liberation-fonts
+
+This Font Software is licensed under the SIL Open Font License,
+Version 1.1.
+
+This license is copied below, and is also available with a FAQ at:
+http://scripts.sil.org/OFL
+
+SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007
+
+PREAMBLE The goals of the Open Font License (OFL) are to stimulate
+worldwide development of collaborative font projects, to support the font
+creation efforts of academic and linguistic communities, and to provide
+a free and open framework in which fonts may be shared and improved in
+partnership with others.
+
+The OFL allows the licensed fonts to be used, studied, modified and
+redistributed freely as long as they are not sold by themselves.
+The fonts, including any derivative works, can be bundled, embedded,
+redistributed and/or sold with any software provided that any reserved
+names are not used by derivative works.  The fonts and derivatives,
+however, cannot be released under any other type of license.  The
+requirement for fonts to remain under this license does not apply to
+any document created using the fonts or their derivatives.
+
+
+
+DEFINITIONS
+"Font Software" refers to the set of files released by the Copyright
+Holder(s) under this license and clearly marked as such.
+This may include source files, build scripts and documentation.
+
+"Reserved Font Name" refers to any names specified as such after the
+copyright statement(s).
+
+"Original Version" refers to the collection of Font Software components
+as distributed by the Copyright Holder(s).
+
+"Modified Version" refers to any derivative made by adding to, deleting,
+or substituting — in part or in whole —
+any of the components of the Original Version, by changing formats or
+by porting the Font Software to a new environment.
+
+"Author" refers to any designer, engineer, programmer, technical writer
+or other person who contributed to the Font Software.
+
+
+PERMISSION & CONDITIONS
+
+Permission is hereby granted, free of charge, to any person obtaining a
+copy of the Font Software, to use, study, copy, merge, embed, modify,
+redistribute, and sell modified and unmodified copies of the Font
+Software, subject to the following conditions:
+
+1) Neither the Font Software nor any of its individual components,in
+   Original or Modified Versions, may be sold by itself.
+
+2) Original or Modified Versions of the Font Software may be bundled,
+   redistributed and/or sold with any software, provided that each copy
+   contains the above copyright notice and this license. These can be
+   included either as stand-alone text files, human-readable headers or
+   in the appropriate machine-readable metadata fields within text or
+   binary files as long as those fields can be easily viewed by the user.
+
+3) No Modified Version of the Font Software may use the Reserved Font
+   Name(s) unless explicit written permission is granted by the
+   corresponding Copyright Holder. This restriction only applies to the
+   primary font name as presented to the users.
+
+4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font
+   Software shall not be used to promote, endorse or advertise any
+   Modified Version, except to acknowledge the contribution(s) of the
+   Copyright Holder(s) and the Author(s) or with their explicit written
+   permission.
+
+5) The Font Software, modified or unmodified, in part or in whole, must
+   be distributed entirely under this license, and must not be distributed
+   under any other license. The requirement for fonts to remain under
+   this license does not apply to any document created using the Font
+   Software.
+
+
+
+TERMINATION
+This license becomes null and void if any of the above conditions are not met.
+
+
+
+DISCLAIMER
+THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT
+OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT.  IN NO EVENT SHALL THE
+COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
+DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM OTHER
+DEALINGS IN THE FONT SOFTWARE.
+

scribe.asd

@@ -29,4 +29,5 @@ gamma-correct linear-light compositing. No FFI, no FreeType, no HarfBuzz."
      (:file "glyf")      ; DONE: glyf/loca outlines + cmap dispatch (strong-tier)
      (:file "raster")    ; DONE: analytic-coverage rasterizer (quad + cubic)
      (:file "shape")     ; glyph-pos struct
-     (:file "otl")))))   ; DONE: GSUB/GPOS shaping — kerning + ligatures (strong-tier)
+     (:file "otl")       ; DONE: GSUB/GPOS shaping — kerning + ligatures (strong-tier)
+     (:file "match")))))  ; DONE: CSS font-family matching over the shipped faces

src/font.lisp

@@ -23,7 +23,8 @@
   units-per-em num-glyphs num-h-metrics index-to-loc-format
   %cff            ; cached parsed CFF (lazy) for OTTO fonts
   %fvar %avar     ; cached variation axes + avar segment maps (lazy)
-  %gdef)          ; cached parsed GDEF (lazy); :none if absent
+  %gdef           ; cached parsed GDEF (lazy); :none if absent
+  %cmap)          ; cached parsed best cmap subtable (lazy): codepoint -> gid
 
 (defun font-table (font tag-str)
   "Return (values offset length) for TAG-STR, or NIL if absent."

src/glyf.lisp

@@ -132,18 +132,26 @@
     (nreverse out)))
 
 ;;; ---- cmap dispatch: pick the best Unicode subtable, map codepoint -> gid ----
+(defun font-cmap (font)
+  "The parsed best-available cmap subtable (codepoint -> gid), built once and
+cached on the font.  Rebuilding this per lookup — which the old code did — reads
+the whole cmap for every character measured, quadratic on text-heavy pages."
+  (or (font-%cmap font)
+      (setf (font-%cmap font)
+            (let ((subs (cmap-subtables font)) (d (font-data font)))
+              (flet ((find-sub (pid eid fmt) (find-if (lambda (s) (and (= (first s) pid) (= (second s) eid)
+                                                                       (= (third s) fmt))) subs)))
+                (let ((best (or (find-sub 3 10 12) (find-sub 0 10 12)   ; full Unicode
+                                (find-sub 3 1 4)   (find-sub 0 3 4)     ; BMP
+                                (find-sub 0 4 12)  (find-sub 0 6 12)
+                                (first subs))))
+                  (or (when best
+                        (ecase (third best)
+                          (4  (parse-cmap-4  d (fourth best)))
+                          (6  (parse-cmap-6  d (fourth best)))
+                          (12 (parse-cmap-12 d (fourth best)))))
+                      (make-hash-table :test 'eql))))))))   ; empty (no cmap) -> parsed once
+
 (defun font-glyph-index (font codepoint)
   "Map a Unicode CODEPOINT to a glyph id via the best available cmap subtable."
-  (let ((subs (cmap-subtables font)) (d (font-data font)))
-    (flet ((find-sub (pid eid fmt) (find-if (lambda (s) (and (= (first s) pid) (= (second s) eid)
-                                                             (= (third s) fmt))) subs)))
-      (let* ((best (or (find-sub 3 10 12) (find-sub 0 10 12)   ; full Unicode
-                       (find-sub 3 1 4)   (find-sub 0 3 4)     ; BMP
-                       (find-sub 0 4 12)  (find-sub 0 6 12)
-                       (first subs)))
-             (ht (when best
-                   (ecase (third best)
-                     (4  (parse-cmap-4  d (fourth best)))
-                     (6  (parse-cmap-6  d (fourth best)))
-                     (12 (parse-cmap-12 d (fourth best)))))))
-        (or (and ht (gethash codepoint ht)) 0)))))
+  (or (gethash codepoint (font-cmap font)) 0))

src/match.lisp

@@ -0,0 +1,171 @@
+;;;; match.lisp — CSS font-family matching over the shipped face set.
+;;;;
+;;;; A consumer (e.g. a web engine) resolves a CSS `font-family` list plus a
+;;;; weight and style into a concrete open-font.  scribe ships the Liberation
+;;;; faces — the metric-compatible substitutes browsers use on Linux for
+;;;; Arial/Helvetica (Sans), Times (Serif), and Courier (Mono) — so the widths a
+;;;; consumer measures match a real browser.
+;;;;
+;;;; match-font never returns NIL: an unknown family, a missing file, or any
+;;;; read error falls back through the family list and ultimately to
+;;;; LiberationSans-Regular, so a text path built on it can never crash.
+(in-package #:scribe)
+
+;;; ---- the shipped face table -------------------------------------------------
+;;; Keyed by (family-key weight-class style) where family-key is one of
+;;; :sans :serif :mono :dejavu-sans :dejavu-mono, weight-class is :regular|:bold,
+;;; and style is :roman|:italic.  Values are filenames under fonts/ (or the
+;;; test corpus for DejaVu).
+
+(defparameter *fonts-dir*
+  (asdf:system-relative-pathname "scribe" "fonts/")
+  "Directory holding the shipped Liberation faces.")
+
+(defparameter *corpus-dir*
+  (asdf:system-relative-pathname "scribe" "inspect/corpus/")
+  "Directory holding the test-corpus fonts (DejaVu), used when a consumer asks
+for DejaVu explicitly.")
+
+(defparameter *face-files*
+  '(((:sans  :regular :roman)  "LiberationSans-Regular.ttf")
+    ((:sans  :regular :italic) "LiberationSans-Italic.ttf")
+    ((:sans  :bold    :roman)  "LiberationSans-Bold.ttf")
+    ((:sans  :bold    :italic) "LiberationSans-BoldItalic.ttf")
+    ((:serif :regular :roman)  "LiberationSerif-Regular.ttf")
+    ((:serif :regular :italic) "LiberationSerif-Italic.ttf")
+    ((:serif :bold    :roman)  "LiberationSerif-Bold.ttf")
+    ((:serif :bold    :italic) "LiberationSerif-BoldItalic.ttf")
+    ((:mono  :regular :roman)  "LiberationMono-Regular.ttf")
+    ((:mono  :regular :italic) "LiberationMono-Italic.ttf")
+    ((:mono  :bold    :roman)  "LiberationMono-Bold.ttf")
+    ((:mono  :bold    :italic) "LiberationMono-BoldItalic.ttf"))
+  "Shipped (family weight style) -> filename under *FONTS-DIR*.")
+
+(defparameter *corpus-face-files*
+  '(((:dejavu-sans :regular :roman) "DejaVuSans.ttf")
+    ((:dejavu-mono :regular :roman) "DejaVuSansMono.ttf"))
+  "DejaVu faces under *CORPUS-DIR* (single weight/style each; bold/italic are
+synthesized by the caller's stem darkening / not distinguished here).")
+
+(defvar *font-cache* (make-hash-table :test 'equal)
+  "Cache of resolved key -> open-font (or :failed if the file could not be read).")
+
+;;; ---- CSS family -> family-key ----------------------------------------------
+;;; Case-insensitive.  Recognized aliases map the common Windows/macOS family
+;;; names browsers substitute to the matching Liberation face; generic families
+;;; (sans-serif/serif/monospace/system-ui) map to the obvious face.
+
+(defun family-key (name)
+  "Map a CSS family NAME (a string) to a face family key, or NIL if unknown."
+  (let ((n (string-downcase (string-trim '(#\Space #\Tab #\Newline #\Return) name))))
+    (cond
+      ;; sans-serif family and its common metric-compatible aliases
+      ((member n '("sans-serif" "arial" "helvetica" "helvetica neue" "verdana"
+                   "tahoma" "segoe ui" "segoe" "system-ui" "-apple-system"
+                   "blinkmacsystemfont" "roboto" "noto sans" "liberation sans"
+                   "arimo" "ui-sans-serif")
+               :test #'string=)
+       :sans)
+      ((and (>= (length n) 5) (string= (subseq n 0 5) "segoe")) :sans)
+      ;; serif family and aliases
+      ((member n '("serif" "times" "times new roman" "georgia" "garamond"
+                   "liberation serif" "tinos" "ui-serif")
+               :test #'string=)
+       :serif)
+      ((and (>= (length n) 5) (string= (subseq n 0 5) "times")) :serif)
+      ;; monospace family and aliases
+      ((member n '("monospace" "courier" "courier new" "consolas" "menlo"
+                   "monaco" "liberation mono" "cousine" "ui-monospace"
+                   "sf mono" "dejavu sans mono")
+               :test #'string=)
+       (if (string= n "dejavu sans mono") :dejavu-mono :mono))
+      ;; DejaVu kept available for consumers that ask for it by name
+      ((and (>= (length n) 6) (string= (subseq n 0 6) "dejavu"))
+       (if (search "mono" n) :dejavu-mono :dejavu-sans))
+      (t nil))))
+
+;;; ---- face lookup + lazy open ------------------------------------------------
+(defun %read-font-file (path)
+  "Read PATH into a byte vector and OPEN-FONT it, or NIL on any error."
+  (handler-case
+      (let ((bytes (with-open-file (s path :element-type '(unsigned-byte 8))
+                     (let ((v (make-array (file-length s)
+                                          :element-type '(unsigned-byte 8))))
+                       (read-sequence v s) v))))
+        (open-font bytes))
+    (error () nil)))
+
+(defun %face-filename+dir (key)
+  "Return (values filename directory) for a resolved face KEY (family weight
+style), or NIL if the key is not in the shipped/corpus tables."
+  (let ((shipped (assoc key *face-files* :test #'equal)))
+    (if shipped
+        (values (second shipped) *fonts-dir*)
+        ;; corpus DejaVu has only a regular roman face; normalize the key
+        (let* ((fam (first key))
+               (ckey (list fam :regular :roman))
+               (c (assoc ckey *corpus-face-files* :test #'equal)))
+          (when c (values (second c) *corpus-dir*))))))
+
+(defun %open-face (key)
+  "Open (or fetch from cache) the face for resolved KEY, or NIL if unavailable."
+  (multiple-value-bind (v present) (gethash key *font-cache*)
+    (if present
+        (unless (eq v :failed) v)
+        (multiple-value-bind (fname dir) (%face-filename+dir key)
+          (let ((font (and fname (%read-font-file (merge-pathnames fname dir)))))
+            (setf (gethash key *font-cache*) (or font :failed))
+            font)))))
+
+;;; ---- the public entry point -------------------------------------------------
+(defun match-font (family-list &key (weight 400) (style :normal))
+  "Resolve a CSS FAMILY-LIST (a list of family-name strings, or a single string)
+plus WEIGHT (100-900) and STYLE (:normal | :italic | :oblique) into an open
+font.  Walks the family list, using the first recognized family; falls back to
+sans-serif (LiberationSans) for an unknown/empty list.  NEVER returns NIL — a
+missing or unreadable face degrades to LiberationSans-Regular, then to any
+shipped face.
+
+WEIGHT >= 600 selects the Bold face; STYLE :italic/:oblique selects the Italic
+face; both select BoldItalic (for families that have those faces).  DejaVu faces
+have a single weight/style, so a bold/italic request on DejaVu returns its
+regular face (the caller may synthesize emphasis)."
+  (let* ((families (cond ((stringp family-list) (list family-list))
+                         ((listp family-list) family-list)
+                         (t nil)))
+         (fam-key (or (loop for f in families
+                            for k = (and (stringp f) (family-key f))
+                            when k return k)
+                      :sans))
+         (weight-class (if (and (integerp weight) (>= weight 600)) :bold :regular))
+         (slant (if (member style '(:italic :oblique)) :italic :roman)))
+    (or
+     ;; exact requested face
+     (%open-face (list fam-key weight-class slant))
+     ;; drop italic, keep weight
+     (%open-face (list fam-key weight-class :roman))
+     ;; drop weight, keep italic
+     (%open-face (list fam-key :regular slant))
+     ;; regular roman of the requested family
+     (%open-face (list fam-key :regular :roman))
+     ;; ultimate fallback: LiberationSans-Regular, then any shipped face
+     (%open-face '(:sans :regular :roman))
+     (loop for (k . nil) in *face-files*
+           for font = (%open-face k)
+           when font return font)
+     (error "scribe: match-font found no readable shipped face in ~a" *fonts-dir*))))
+
+;;; ---- metric accessors (for line-height computation) ------------------------
+;;; hhea ascent/descent/lineGap in font units; a consumer scales by ppem/upem.
+
+(defun font-ascent (font)
+  "hhea typographic ascent in font units (positive)."
+  (cdr (assoc "ascent" (parse-hhea font) :test #'string=)))
+
+(defun font-descent (font)
+  "hhea typographic descent in font units (negative, per the OpenType spec)."
+  (cdr (assoc "descent" (parse-hhea font) :test #'string=)))
+
+(defun font-line-gap (font)
+  "hhea line gap in font units (the recommended extra leading between lines)."
+  (cdr (assoc "lineGap" (parse-hhea font) :test #'string=)))

src/packages.lisp

@@ -10,4 +10,7 @@
    ;; (later) font.lisp / shape.lisp / raster.lisp / atlas.lisp contracts
    #:open-font #:font-glyph-index #:font-units-per-em
    #:shape-run
-   #:rasterize-glyph))
+   #:rasterize-glyph
+   ;; font matching + metric accessors (match.lisp)
+   #:match-font
+   #:font-ascent #:font-descent #:font-line-gap))