diff --git a/docs/HINTING.md b/docs/HINTING.md new file mode 100644 index 0000000..8a5a43f --- /dev/null +++ b/docs/HINTING.md @@ -0,0 +1,187 @@ +# TrueType hinting for scribe — plan + +## Why +scribe's rasterizer is analytic-coverage (exact area) — optimal AA, the limit of +supersampling. But it rasterizes glyph outlines *geometrically*, without +grid-fitting. At small ppem (~7–11px) glyph features (stems, baseline, x-height) +land on fractional pixel rows, so stems render as ~0.7px grey smears and the +baseline appears to wobble. Large sizes are fine; small body text (e.g. HN's 7pt +metadata) reads sloppy. Supersampling can't fix this (accuracy isn't the problem, +grid-fitting is); a HiDPI (2×) output would, but the target is **1× fidelity**. + +The fix is **hinting**: grid-fit the outline before rasterizing. + +## Approach: interpret the font's own TrueType bytecode +Chosen over an autohinter or lightweight vertical-snap because: +- The vendored fonts ship real hints (Liberation & DejaVu both have + `fpgm`/`prep`/`cvt`) — designer-intended, high quality. +- It's **differentially verifiable against FreeType at the point level**, which is + scribe's whole methodology (shaping vs HarfBuzz, cmap vs fontTools). +- Target: FreeType's **classic interpreter (v35)** — full x+y grid-fit, grayscale + smooth mode (not ClearType/v40 y-only). + +## Where it slots in +Today: `glyph-outline` parses points → segments (font units, **instructions +skipped**, glyf.lisp:28); `rasterize-glyph` scales by `ppem/upem`. +New: **raw points + instructions → interpreter grid-fits points (F26Dot6 pixel +units) → segments → rasterize.** gvar already moves points pre-raster (precedent). +Arithmetic is **26.6 / 2.14 fixed point** to match FreeType bit-for-bit. + +## Oracle (Phase 0 — DONE) +`inspect/hint-oracle.py ` — freetype-py, native bytecode +hinter (`FT_LOAD_NO_AUTOHINT`), interpreter pinned to v35, dumps the **hinted** +`FT_Outline` points in 26.6 per contour + hinted advance. Ground truth for every +opcode. (Verified: `l`@12px → stem y 0.00→9.00, ~1px wide.) + +## Phases +- **P0 Oracle & harness** — done. Point-level compare of scribe-hinted vs FT. +- **P1 Tables** — parse `cvt `, `fpgm`, `prep`, per-glyph instructions (capture at + glyf.lisp:28), maxp v1 interpreter limits (maxStack/Storage/FunctionDefs/ + Twilight/…), `gasp` (size→policy). +- **P2 Interpreter VM** (bulk) — graphics state, stack, storage, scaled CVT, + function defs; F26Dot6/F2Dot14 math; projection/freedom-vector move; the + rounding engine (RTG/RTHG/RTDG/ROFF/SROUND/S45ROUND + engine compensation); + ~130 opcodes grouped: push/arith/logic, GS setters, rounding, point-movers + (MDAP/MIAP/MDRP/MIRP/IP/IUP/SHP/SHPIX/ALIGNRP/ISECT), CVT r/w, flow + (IF/CALL/FDEF/LOOPCALL/JMPR), DELTAP/DELTAC, measurement (GC/MD/MPPEM/GETINFO). +- **P3 Glyph pipeline** — phantom points (4), twilight+glyph zones, original vs + current coords, run prep-per-ppem then glyph program, final IUP. +- **P4 Composites** — component placement, ROUND_XY_TO_GRID, USE_MY_METRICS, + composite instructions. +- **P5 Integration** — `*hinting*` mode + `gasp` ppem policy; cache hinted glyph + per (gid, ppem, variation); grayscale target; gvar deltas before hinting; + likely dial back weft's gamma/stem-darkening once stems are solid. +- **P6 Validation gate** — all vendored fonts × ppem 7–16 × ASCII+Latin-1, + point-level + pixel-level vs FreeType, wired into `inspect/run-all.sh`. + +## Milestones +- **M1 (proof / de-risk):** P0 oracle + interpreter skeleton + `fpgm`/`prep` + + a few glyphs (`l i H o`) matching FreeType's hinted points at one ppem. Proves + the fixed-point core + VM on real data before committing to the full opcode set. +- **M2:** full ASCII point-exact at ppem 7–12. +- **M3:** composites + DELTA + sweep gate + weft wiring (`*hinting*` on → the 7pt + "4 hours" line goes crisp at 1×). + +## Risks +Bit-exact fixed-point rounding (engine compensation, SROUND); DELTA exceptions +(per-ppem tweaks, needed for exact small-size match); composites; performance +(→ per-(gid,ppem) cache). Grayscale smooth only, not ClearType. + +## Status (banked checkpoint) +- **P0 oracle** — done (`inspect/hint-oracle.py`, v35-pinned point ground truth). +- **P1 tables** — done (maxp1, cvt, fpgm/prep/glyph instructions). +- **P2 interpreter core** — done; runs LiberationSans `fpgm` (71 fns) + `prep` clean. +- **P3 glyph pipeline + movers** — done; MDAP/MIAP/MDRP/MIRP/IP/IUP/SHP/GC/MD/SCFS + + phantom points. +- **M1 proof — ACHIEVED**: `l` @12px is **bit-exact** vs FreeType + `(0.91,0)(0.91,9)(1.95,9)(1.95,0)`. Fixed 3 fixed-point bugs (muldiv divisor + sign; hround(0); phantom grid-fit). +- **M1 — CLOSED** on `l` bit-exact (the proof). `i/H/o/…` are within ~1px; that + gap is the first task of M2. +- Comparison harness: `/tmp/weftdump.lisp` + oracle diff (per-point, any glyphs). + +## M2 — COMPLETE (round 3): full ASCII bit-exact on both fonts +Using the per-instruction FreeType trace (`inspect/hint-fttrace.md`), every residual +was root-caused and fixed. **Printable ASCII (94 glyphs) is now 100% bit-exact vs +FreeType at ppem 7–16 for BOTH LiberationSans and DejaVuSans.** LiberationSans +accented Latin-1 (53 composites) is also 53/53 exact. + +The round-3 fixes (all found via the STATE trace): +- **`FT_Vector_NormLen`** exact port for SPVTL/SFVTL normalization (isqrt was ~9/16384 + off; projection vectors now bit-exact). +- **`dot14` rounds once** (FreeType TT_DotFix14: sum then round), not per-term. +- **Distances project the DIFFERENCE vector** — MDRP/MIRP/IP/MD/ALIGNRP/MSIRP/SHP all + compute PROJECT(cur[p]−cur[q]) / DUALPROJ(org[p]−org[q]) once, not project(p)− + project(q). This alone took DejaVu 71→90. +- **IUP hybrid**: boundary classification uses scaled `org`, interior ratio uses + `orus` (font units) via DivFix→MulFix — exact port of `iup_worker_interpolate_`. + Fixed the LiberationSans b/g/%/& 1/64 tail. +- **MIRP order**: auto-flip cvt *before* the cut-in test (fixed `%`@16). +- **`orus-dist`** dual-projects then scales (MulFix(DUALPROJ,scale)). +- **F_dot_P clamp**: near-perpendicular freedom/projection clamps to 0x4000 and still + moves (fixed DejaVu `$`@7). +- **DIV opcode** was computing MUL (`a*b/64` instead of `a*64/b`) — corrupted fpgm + arithmetic; fixed the LiberationSans accent-alignment functions → composites 53/53. + +Remaining: DejaVuSans accented Latin-1 (~41–48/53) — the tilde/ring accents shear a +few 1/64 in their composite instructions (a DejaVu-specific residual, still under the +same trace method). + +## M2 round-2 open items (superseded — kept for history) +Three residuals remained after round 2 (all fixed in round 3 above): +- **DejaVu diagonals (/, \, A, w, y, …).** `/`'s first diagonal MIRP (proj set by + SPVTL parallel to the stroke ⇒ near-vertical; freedom = x) targets `dist=round(cvt + [26]=64)` while the point already sits at the original diagonal distance `org=18`; + the cut-in can't fire (font sets SCVTCI=640, and 46<640), so weft moves pt2 by 46 + projected → ×(16384/4734)=×3.46 along x → +159px, then the *next* SPVTL reads the + now-degenerate edge and the cascade blows up (pt0 → −937 vs FT 189). Verified NOT + the cause: post-prep CVT is bit-exact vs FreeType (read from TT_Size); MDRP/MIRP + round/min bits; norm14 precision; SPVTL dual = proj vs org. The contradiction — + identical inputs but FT keeps pt2≈67 (tiny move) — means FT's `dist` here is `org` + (18), i.e. its cut-in *did* fire or its projection is near-horizontal; resolving it + needs FreeType's live interpreter trace (freetype-py exposes none). NB: forcing + SFVTCA the wrong way (0x05→freedom-y) drops `/` 17.6→0.75px but is spec-incorrect + (FreeType src: opcode&1=1 ⇒ x) — a red herring that only dodges the amplification. +- **LiberationSans 1/64 tail (b, g, ", …).** e.g. `b` pt6 is IUP[x]-interpolated + between touched pt5 (orus 318, cur 121) and pt13 (orus 138, cur 54); orus 316 ⇒ + 54 + MulDiv(178,67,180)=54+66=120, but FT=121. Every formula (single MulDiv, + DivFix+MulFix, either base) gives 120 with these inputs, so FT must touch pt6 or + bracket it differently — unreproducible without FT's touch state. +- **Composite accents (é, î, ç @12; 29/52 exact).** Bases always exact; the accent + is placed by an fpgm align-fn (CALL) that GC's the accent's own hinted points and + MSIRPs the anchor. For é the fn computes a shift that rounds to 0 (FT: +64) — the + measured accent coordinate is 1px off, i.e. downstream of the same sub-pixel IUP + tail above. Fixing the tail should lift the accents too. + +## M2 — SUBSTANTIALLY DONE (full ASCII point-exact) +The cap/x-height diagnosis was half-right (it *was* a prep bug) but the actual root +causes were opcode/semantics bugs, found by reading FreeType's post-prep CVT out of +`TT_Size` via `/proc/self/mem` (freetype-py doesn't expose it). Fixes, each +oracle-gated: +- **RUTG** (round-up-to-grid) used super-round threshold 64; ceil's threshold is + `period-1 = 63`, so `round_up(0)` returned 64 (a pixel gained). Broke the cap/ + x-height CVTs computed in prep's fpgm helper. +- **DELTAC/DELTAP pair order**: the cvt/point INDEX is nearer the stack top than the + exception spec; we popped them swapped, so every per-ppem exception hit the wrong + entry / never matched → cap-height & x-height CVT deltas never fired at 12px. + (Post-prep CVT now bit-exact vs FreeType.) +- **MDRP/MIRP round vs min-distance bits**: bit2 (0x04)=round, bit3 (0x08)=min-dist; + we had them swapped. +- **IP + IUP interior use `orus`** (original font-unit coords), like FreeType, so the + interpolation ratio keeps sub-pixel precision (scaled `org` loses it); IUP bases on + the smaller-orus reference. +- **MDRP/MIRP original distance from `orus`** (scale the font-unit delta once) instead + of subtracting two independently-scaled coords (double-round). +- **Per-glyph GS reset**: vectors/rp/zp/loop reset to the fixed x-axis default every + glyph (policy fields — round mode, cut-ins, delta — restored from the post-prep + snapshot). Prep here leaves the vectors on the y axis, so glyphs that DELTAP the + advance before any SVTCA (v/M/A/w/…) were moving it in y. +- **SPVTCA/SFVTCA axis bit** (0x02–0x05) was inverted. +- Opcodes added: **SHPIX, MSIRP, SPVTL/SFVTL, ISECT, SHC/SHZ**. + +**Exact counts (printable ASCII, 94 glyphs), LiberationSans:** ppem7 87, 8 86, 9 87, +10 83, 11 89, 12 90, 14 91, 16 90. Every remaining miss is a single 1/64px (0.016px) +interpolation-rounding edge case (leading hypothesis: a touched-vs-untouched +classification difference in a couple of curve control points). + +**P4 composites — implemented**: components hinted standalone then transformed + +placed (ROUND_XY_TO_GRID) and the composite's own instructions run. Bases always +exact; accented Latin-1 29/52 exact @12px (some accents 1px off — the standalone +component lsb/advance shift bleeds into the composite offset; refinement pending). + +**Second font — DejaVuSans**: ~63–65/94 @ppem7–16. Non-diagonal glyphs largely +exact; diagonal glyphs (/ \ A w y …) that drive a projection vector through twilight +points + SPVTL are still off (the SPVTL/twilight cascade yields a near-vertical +projection that amplifies MIRP moves) — the leading open item. + +## M2 — original opening task (sharp diagnosis, kept for history) +Full ASCII exact is gated on one thing: **the cap/x-height CVT after `prep`.** +`H`'s cap is MIAP'd to **cvt[3] = 528 F26.6 (8.25px)**; with cur=528 and no +cut-in, MIAP rounds it to **8**, but FreeType gives **9** — so FreeType's cvt[3] +at 12px differs from ours. This is a **`prep` correctness** issue (the alignment- +zone CVT adjustment / a fpgm function), NOT a mover bug — all x-hinting is already +bit-exact, and MIAP/MDAP/round are correct given the CVT. Next step: dump +FreeType's post-`prep` CVT (freetype-py exposes it) and diff against ours at +ppem 12 to find which entries `prep` computes differently, then fix the fpgm/prep +opcode(s) responsible. Likely fixes `i/H/o/n/e/a/…` as a group (shared cap/x- +height zones). Then composites (P4), the validation gate (P6), and weft wiring. diff --git a/inspect/hint-diff.py b/inspect/hint-diff.py new file mode 100755 index 0000000..156fb31 --- /dev/null +++ b/inspect/hint-diff.py @@ -0,0 +1,26 @@ +#!/usr/bin/env python3 +"""hint-diff — diff weft's hinted points against FreeType's, per glyph. +Usage: hint-diff.py """ +import sys, json, subprocess +font, ppem, chars = sys.argv[1], sys.argv[2], sys.argv[3] +w = {} +for line in subprocess.run(["sbcl","--non-interactive","--load","inspect/hint-weftdump.lisp",font,ppem,chars], + capture_output=True, text=True).stdout.splitlines(): + if line.startswith("PTS "): + p = line[4:].split(); ch = p[0] + w[ch] = None if (len(p) > 1 and p[1] == "NA") else [int(t) for t in p[1:]] +o = {} +oj = json.loads(subprocess.run(["python3","inspect/hint-oracle.py",font,ppem,chars], + capture_output=True, text=True).stdout) +for g in oj["glyphs"]: + o[g["glyph"]] = [v for c in g["contours"] for x,y,on in c for v in (x,y)] +ex = tot = 0 +print(f"=== {font.split('/')[-1]} @ {ppem}px ===") +for ch in chars: + wf, of = w.get(ch), o.get(ch); tot += 1 + if wf is None or of is None: print(f" '{ch}': skipped/composite"); continue + if len(wf) != len(of): print(f" '{ch}': COUNT weft {len(wf)} vs FT {len(of)}"); continue + d = max((abs(a-b) for a,b in zip(wf, of)), default=0) + if d == 0: ex += 1 + print(f" '{ch}': {'EXACT' if d==0 else f'max Δ={d}/64 = {d/64:.3f}px'}") +print(f"exact: {ex}/{tot}") diff --git a/inspect/hint-fttrace.md b/inspect/hint-fttrace.md new file mode 100644 index 0000000..1b86309 --- /dev/null +++ b/inspect/hint-fttrace.md @@ -0,0 +1,33 @@ +# FreeType interpreter introspection (per-instruction trace) + +To diff weft's hinting execution against FreeType's *instruction by instruction* +(projection/freedom vectors, rp/zp, and every glyph-zone point), we build a +trace-enabled FreeType and patch its interpreter loop to dump graphics-state. + +## Build (once) +``` +cd ~/ftbuild/freetype-2.13.2 +./configure --prefix=$HOME/ftbuild/install --without-zlib --without-png \ + --without-harfbuzz --without-brotli CFLAGS="-DFT_DEBUG_LEVEL_TRACE -g -O1" +make -j && make install +# point freetype-py at it: +cp $HOME/ftbuild/install/lib/libfreetype.so.6.20.1 \ + ~/.local/lib/python3.11/site-packages/freetype/libfreetype.so # (.orig = release backup) +``` +The patch (src/truetype/ttinterp.c, after the opcode-trace block) emits, gated on +env `WEFT_HINT_TRACE`, one `STATE` line per instruction: +`STATE pc= op= proj=(x,y) free=(x,y) rp=.. zp=.. loop= | i:(cur.x,cur.y)* ...` + +## Capture FreeType's trace +``` +WEFT_HINT_TRACE=1 FT2_DEBUG="ttinterp:7" \ + python3 inspect/hint-oracle.py "" 2>ft.txt >/dev/null +grep '^STATE' ft.txt +``` + +## Capture weft's matching trace (same format) +``` +WEFT_HINT_TRACE=1 sbcl --load inspect/hint-weftdump.lisp "" 2>weft.txt +``` +weft's `run-program` emits the identical `STATE` format when `*hint-trace*` is set. +Diff the two: the first `STATE` line that differs is the divergent instruction. diff --git a/inspect/hint-oracle.py b/inspect/hint-oracle.py new file mode 100644 index 0000000..3aa4eaa --- /dev/null +++ b/inspect/hint-oracle.py @@ -0,0 +1,41 @@ +#!/usr/bin/env python3 +"""Phase-0 hinting oracle: dump FreeType's HINTED outline points (the font's own +TrueType bytecode interpreter, classic v35 = full x+y grid-fit) at a given ppem. +Ground truth for scribe's hinting. Usage: hint-oracle.py +Emits JSON: {glyph, ppem, upem, adv, contours:[[[x,y,on],...],...]} with x,y in +26.6 fixed (px*64). "adv" is the hinted advance in 26.6.""" +import sys, json, ctypes +import freetype +from freetype.raw import FT_Property_Set + +def pin_interpreter_v35(): + v = ctypes.c_uint(35) + try: + FT_Property_Set(freetype.get_handle(), b"truetype", b"interpreter-version", ctypes.byref(v)) + return True + except Exception as e: + return f"could not pin v35: {e}" + +def dump(font, ppem, chars): + face = freetype.Face(font) + face.set_pixel_sizes(ppem, ppem) + # FT_LOAD_NO_AUTOHINT forces the font's native bytecode hinter; keep the outline + flags = freetype.FT_LOAD_NO_AUTOHINT | freetype.FT_LOAD_NO_BITMAP + out = [] + for ch in chars: + gid = face.get_char_index(ord(ch)) + face.load_glyph(gid, flags) + o = face.glyph.outline + pts, tags, ends = o.points, o.tags, o.contours + contours, start = [], 0 + for e in ends: + c = [[pts[i][0], pts[i][1], (tags[i] & 1)] for i in range(start, e+1)] + contours.append(c); start = e+1 + out.append({"glyph": ch, "gid": gid, "ppem": ppem, "upem": face.units_per_EM, + "adv": face.glyph.advance.x, "contours": contours}) + return out + +if __name__ == "__main__": + font, ppem, chars = sys.argv[1], int(sys.argv[2]), sys.argv[3] + pinned = pin_interpreter_v35() + print(json.dumps({"pinned_v35": pinned, "glyphs": dump(font, ppem, chars)})) diff --git a/inspect/hint-weftdump.lisp b/inspect/hint-weftdump.lisp new file mode 100644 index 0000000..b012e6b --- /dev/null +++ b/inspect/hint-weftdump.lisp @@ -0,0 +1,21 @@ +;;;; hint-weftdump — dump weft's HINTED glyph points (F26.6) for a diff against +;;;; the FreeType oracle (inspect/hint-oracle.py). Also dumps the post-prep CVT +;;;; with mode "cvt". Usage: +;;;; sbcl --load inspect/hint-weftdump.lisp +;;;; sbcl --load inspect/hint-weftdump.lisp cvt +(asdf:load-system :scribe) +(in-package :scribe) +(destructuring-bind (font-path ppem-s arg) (last sb-ext:*posix-argv* 3) + (let* ((ppem (parse-integer ppem-s)) + (bytes (with-open-file (s font-path :element-type '(unsigned-byte 8)) + (let ((v (make-array (file-length s) :element-type '(unsigned-byte 8)))) (read-sequence v s) v))) + (font (open-font bytes)) (h (make-hinter font ppem))) + (run-fpgm-prep h) + (if (string= arg "cvt") + (dotimes (i (length (hs-cvt h))) (format t "cvt[~a]=~a~%" i (aref (hs-cvt h) i))) + (loop for ch across arg do + (let ((cs (hint-glyph h (font-glyph-index font (char-code ch))))) + (format t "PTS ~a" ch) + (if (listp cs) (dolist (c cs) (loop for (x y on) in c do (format t " ~a ~a" (round (* x 64)) (round (* y 64))))) + (format t " NA")) + (terpri)))))) diff --git a/scribe.asd b/scribe.asd index 0620419..226525e 100644 --- a/scribe.asd +++ b/scribe.asd @@ -30,4 +30,5 @@ gamma-correct linear-light compositing. No FFI, no FreeType, no HarfBuzz." (:file "raster") ; DONE: analytic-coverage rasterizer (quad + cubic) (:file "shape") ; glyph-pos struct (:file "otl") ; DONE: GSUB/GPOS shaping — kerning + ligatures (strong-tier) + (:file "hint") ; WIP: TrueType bytecode hinting (grid-fit small text) (:file "match"))))) ; DONE: CSS font-family matching over the shipped faces diff --git a/src/blend.lisp b/src/blend.lisp index b8e11d1..591464e 100644 --- a/src/blend.lisp +++ b/src/blend.lisp @@ -77,10 +77,21 @@ darkening). 1.0 = geometric/linear-correct; <1 thickens & darkens strokes so text reads solid instead of washed-out; >1 lightens. ~0.7 ≈ macOS weight.") +(defparameter *blend-gamma* nil + "Compositing space for coverage. NIL: linear light via the exact sRGB LUT +(gamma-correct — right for images and gradients). A number G: composite in +power-G gamma space. Text renderers blend glyphs with an intermediate gamma +(~1.6) — linear light (LUT, ~2.2) leaves dark-on-light edges washed-out, while +naive sRGB (G=1.0) is too heavy; the browser sits between. Bind a G for glyphs.") + +(declaim (inline %clamp8)) +(defun %clamp8 (v) (declare (type double-float v)) (max 0 (min 255 (the fixnum (round v))))) + (declaim (inline blend-coverage)) (defun blend-coverage (cv x y coverage fg) - "Composite FG (list R G B, 8-bit) over pixel (X,Y) at COVERAGE in [0,1], - blending in linear light. COVERAGE 1 = solid FG, 0 = untouched." + "Composite FG (list R G B, 8-bit) over pixel (X,Y) at COVERAGE in [0,1]. + Blends in linear light, or in power-*BLEND-GAMMA* space when that is set + (glyphs). COVERAGE 1 = solid FG, 0 = untouched." (declare (type canvas cv) (type fixnum x y) (type double-float coverage)) (when (and (>= x 0) (>= y 0) (< x (canvas-width cv)) (< y (canvas-height cv)) (> coverage 0d0)) @@ -89,12 +100,25 @@ (a (if (= *stem-darkening* 1d0) (min 1d0 coverage) (expt (min 1d0 coverage) *stem-darkening*))) (ia (- 1d0 a)) - (fr (srgb->linear (first fg))) - (fg* (srgb->linear (second fg))) - (fb (srgb->linear (third fg)))) - (setf (aref px i) (lin->srgb8 (+ (* ia (srgb->linear (aref px i))) (* a fr))) - (aref px (+ i 1)) (lin->srgb8 (+ (* ia (srgb->linear (aref px (+ i 1)))) (* a fg*))) - (aref px (+ i 2)) (lin->srgb8 (+ (* ia (srgb->linear (aref px (+ i 2)))) (* a fb)))))) + (g *blend-gamma*)) + (if (null g) + (let ((fr (srgb->linear (first fg))) + (fg* (srgb->linear (second fg))) + (fb (srgb->linear (third fg)))) + (setf (aref px i) (lin->srgb8 (+ (* ia (srgb->linear (aref px i))) (* a fr))) + (aref px (+ i 1)) (lin->srgb8 (+ (* ia (srgb->linear (aref px (+ i 1)))) (* a fg*))) + (aref px (+ i 2)) (lin->srgb8 (+ (* ia (srgb->linear (aref px (+ i 2)))) (* a fb))))) + (let* ((gg (float g 1d0)) + (ig (/ 1d0 gg)) + (bl0 (expt (/ (float (aref px i) 1d0) 255d0) gg)) + (bl1 (expt (/ (float (aref px (+ i 1)) 1d0) 255d0) gg)) + (bl2 (expt (/ (float (aref px (+ i 2)) 1d0) 255d0) gg)) + (fl0 (expt (/ (float (first fg) 1d0) 255d0) gg)) + (fl1 (expt (/ (float (second fg) 1d0) 255d0) gg)) + (fl2 (expt (/ (float (third fg) 1d0) 255d0) gg))) + (setf (aref px i) (%clamp8 (* 255d0 (expt (max 0d0 (+ (* ia bl0) (* a fl0))) ig))) + (aref px (+ i 1)) (%clamp8 (* 255d0 (expt (max 0d0 (+ (* ia bl1) (* a fl1))) ig))) + (aref px (+ i 2)) (%clamp8 (* 255d0 (expt (max 0d0 (+ (* ia bl2) (* a fl2))) ig)))))))) (values)) (defun fill-coverage-span (cv x y coverages fg &optional (n (length coverages))) diff --git a/src/font.lisp b/src/font.lisp index c6c58bb..9237b46 100644 --- a/src/font.lisp +++ b/src/font.lisp @@ -24,7 +24,8 @@ %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 - %cmap) ; cached parsed best cmap subtable (lazy): codepoint -> gid + %cmap ; cached parsed best cmap subtable (lazy): codepoint -> gid + %otl) ; cached GSUB/GPOS lookup indices per (tag . features) (lazy) (defun font-table (font tag-str) "Return (values offset length) for TAG-STR, or NIL if absent." diff --git a/src/hint.lisp b/src/hint.lisp new file mode 100644 index 0000000..97497f9 --- /dev/null +++ b/src/hint.lisp @@ -0,0 +1,925 @@ +;;;; hint.lisp — TrueType bytecode hinting (the font's own instructions). +;;;; +;;;; Grid-fits a glyph's points at a target ppem so small text is crisp, matching +;;;; FreeType's classic interpreter (v35, full x+y grid-fit). All arithmetic is +;;;; F26Dot6 (px*64) for coordinates/distances and F2Dot14 for unit vectors, to +;;;; match FreeType bit-for-bit (see docs/HINTING.md; oracle: inspect/hint-oracle.py). +;;;; +;;;; Pipeline: parse cvt/fpgm/prep + per-glyph instructions -> run fpgm once, +;;;; prep per-ppem, then the glyph program -> the moved points are the hinted +;;;; outline. Points live in ZONES; a glyph's real points are zone 1 plus 4 +;;;; phantom points (lsb, adv, top, bottom); zone 0 is the twilight zone. +(in-package #:scribe) + +;;; ------------------------------------------------------------------ maxp v1 +(defun parse-maxp1 (font) + "maxp v1 interpreter limits (or NILs for v0.5 fonts with no glyf hints)." + (let* ((d (font-data font)) (o (req-table font "maxp"))) + (when (>= (u32 d o) #x00010000) + (list :max-points (u16 d (+ o 6)) :max-contours (u16 d (+ o 8)) + :max-twilight (u16 d (+ o 16)) :max-storage (u16 d (+ o 18)) + :max-functions (u16 d (+ o 20)) :max-instruction-defs (u16 d (+ o 22)) + :max-stack (u16 d (+ o 24)))))) + +(defun table-bytes (font tag) + "Raw bytes of TAG as a subsequence of the font data, or NIL if absent." + (multiple-value-bind (off len) (font-table font tag) + (when off (subseq (font-data font) off (+ off len))))) + +(defun parse-cvt (font) + "The Control Value Table as a vector of s16 FUnits (empty if absent)." + (let ((b (table-bytes font "cvt "))) + (if (null b) (make-array 0 :element-type 'fixnum) + (let* ((n (floor (length b) 2)) (v (make-array n :element-type 'fixnum))) + (dotimes (i n v) + (let ((x (logior (ash (aref b (* i 2)) 8) (aref b (1+ (* i 2)))))) + (setf (aref v i) (if (>= x #x8000) (- x #x10000) x)))))))) + +(defun hmtx-metrics (font gid) + "(values advance-width lsb) in FUnits for GID (last advance repeats past nh)." + (let* ((d (font-data font)) (off (req-table font "hmtx")) (nh (font-num-h-metrics font))) + (if (< gid nh) + (values (u16 d (+ off (* gid 4))) (s16 d (+ off (* gid 4) 2))) + (values (u16 d (+ off (* (1- nh) 4))) (s16 d (+ off (* nh 4) (* (- gid nh) 2))))))) + +;;; ---- construction ---- +(defun hscale (h funit) + "Scale a FUnit value to F26.6 pixels at this hinter's ppem." + (muldiv funit (* 64 (hs-ppem h)) (font-units-per-em (hs-font h)))) + +(defun make-hinter (font ppem) + "A hinter ready to run FONT's programs at PPEM (stack/storage from maxp, CVT +scaled to F26.6). Call RUN-FPGM-PREP before hinting glyphs." + (let* ((mx (parse-maxp1 font)) (upem (font-units-per-em font)) + (raw (parse-cvt font)) (n (length raw)) + (h (make-hint :font font :ppem ppem :scale (* 64 ppem) + :stack (make-array (max 256 (+ 64 (or (getf mx :max-stack) 256))) :element-type 'fixnum) + :storage (make-array (max 16 (1+ (or (getf mx :max-storage) 16))) :element-type 'fixnum :initial-element 0) + :cvt (make-array n :element-type 'fixnum)))) + (dotimes (i n) (setf (aref (hs-cvt h) i) (muldiv (aref raw i) (* 64 ppem) upem))) + h)) + +;;; The graphics-state slots that make up the interpreter's GS. FreeType restores +;;; the whole post-prep GS before every glyph, so a glyph program's changes (round +;;; mode, SMD, SDB, vectors, ...) never leak into the next glyph. +(defparameter *gs-slots* + '(hs-fx hs-fy hs-px hs-py hs-dpx hs-dpy hs-rp0 hs-rp1 hs-rp2 hs-zp0 hs-zp1 hs-zp2 + hs-loop hs-round-state hs-round-period hs-round-phase hs-round-threshold + hs-min-dist hs-cvt-cut-in hs-sw-cut-in hs-sw-value hs-auto-flip + hs-delta-base hs-delta-shift hs-scan-control hs-instruct-control)) + +(defun snapshot-gs (h) + (setf (hs-gs-default h) (mapcar (lambda (s) (funcall s h)) *gs-slots*))) +(defun restore-gs (h) + (loop for s in *gs-slots* for v in (hs-gs-default h) + do (funcall (fdefinition `(setf ,s)) v h))) + +(defun run-fpgm-prep (h) + "Run the font program (defines functions) then the control-value program (sets +graphics state / CVT for this ppem), then snapshot the GS as the per-glyph default." + (let ((fp (table-bytes (hs-font h) "fpgm"))) (when fp (run-program h fp))) + (let ((pp (table-bytes (hs-font h) "prep"))) (when pp (run-program h pp))) + (snapshot-gs h)) + +;;; ------------------------------------------------------------- fixed point +;;; F26Dot6: px*64. F2Dot14: unit vector components (16384 = 1.0). +(declaim (inline f26.6 muldiv)) +(defun f26.6 (px) (round (* px 64))) +(defun muldiv (a b c) + "round(a*b/c) with .5 rounding away from zero — FreeType's FT_MulDiv. The +result sign is sign(a*b*c): dividing by a negative c flips it." + (if (zerop c) 0 + (let* ((ab (* a b)) (s (if (minusp (* ab c)) -1 1)) + (n (+ (abs ab) (floor (abs c) 2)))) + (* s (floor n (abs c)))))) +(declaim (inline mul2.14 dot14)) +(defun mul2.14 (a b) (muldiv a b 16384)) ; F26.6 * F2.14 -> F26.6 +(defun dot14 (ax ay bx by) + "Dot product (ax,ay)·(bx,by) with the second vector in F2.14, rounded ONCE after +summing — exactly FreeType's TT_DotFix14. (Rounding each term separately, as two +mul2.14 calls, can differ by 1 and cascades into 1-unit mover errors.)" + (let ((s (+ (* ax bx) (* ay by)))) + (ash (+ s #x2000 (if (minusp s) -1 0)) -14))) + +;;; ------------------------------------------------------------- interpreter +(defstruct hz ; a zone of points + (cur-x nil) (cur-y nil) ; current coords, F26.6 arrays + (org-x nil) (org-y nil) ; original (scaled) coords + (orus-x nil) (orus-y nil) ; original UNSCALED coords (font units) + (on nil) ; on-curve flags + (touch nil)) ; touch flags (bit0 x, bit1 y) + +(defstruct (hint (:conc-name hs-)) + font ppem scale ; scale = F26.6-per-FUnit (muldiv-able) + (stack (make-array 256 :element-type 'fixnum)) (sp 0) + storage cvt ; storage area + scaled CVT (F26.6) + (functions (make-hash-table)) ; fn# -> (code . pc) + code (pc 0) ; current program + ;; graphics state (F26.6 / F2.14) + (fx 16384) (fy 0) (px 16384) (py 0) (dpx 16384) (dpy 0) ; freedom, proj, dual-proj + (rp0 0) (rp1 0) (rp2 0) (zp0 1) (zp1 1) (zp2 1) (loop 1) + (round-state :grid) (min-dist 64) (cvt-cut-in 68) (sw-cut-in 0) (sw-value 0) + (auto-flip t) (delta-base 9) (delta-shift 3) (scan-control 0) (instruct-control 0) + (round-period 64) (round-phase 0) (round-threshold 32) + zones ; #(twilight glyph) + (glyph-ends nil) (glyph-npts 0) ; contour end indices + #real points + (gs-default nil)) ; graphics state snapshot after prep + +(define-condition hint-unimplemented (error) + ((op :initarg :op :reader hint-op)) + (:report (lambda (c s) (format s "hint: unimplemented opcode #x~2,'0X" (hint-op c))))) + +;;; ---- stack helpers ---- +(declaim (inline hpush hpop)) +(defun hpush (h v) (setf (aref (hs-stack h) (hs-sp h)) v) (incf (hs-sp h))) +(defun hpop (h) (decf (hs-sp h)) (aref (hs-stack h) (hs-sp h))) + +;;; ---- rounding engine (round-state -> round an F26.6 distance) ---- +(defun hround (h dist) + "Round F26.6 DIST per the graphics-state round mode (FT_Round_Super), preserving +sign. A negative result clamps to 0. (The 'don't collapse a nonzero distance' +rule is min-distance, applied by MDRP/MIRP — not here.)" + (if (eq (hs-round-state h) :off) dist + (let* ((per (hs-round-period h)) (ph (hs-round-phase h)) (thr (hs-round-threshold h)) + (sign (if (minusp dist) -1 1)) (d (abs dist)) + (r (+ (* (floor (+ (- d ph) thr) per) per) ph))) + (when (minusp r) (setf r 0)) + (* sign r)))) + +(defun set-round-period (h period phase threshold) + (setf (hs-round-period h) period (hs-round-phase h) phase (hs-round-threshold h) threshold)) + +;;; ---- projection / movement ---- +(defun hproject (h x y) + "Projection of vector (x,y) F26.6 onto the projection vector -> F26.6." + (dot14 x y (hs-px h) (hs-py h))) +(defun hdual-project (h x y) (dot14 x y (hs-dpx h) (hs-dpy h))) + +(defun point-xy (z i) (values (aref (hz-cur-x z) i) (aref (hz-cur-y z) i))) +(defun zone (h zp) (aref (hs-zones h) zp)) + +(defun move-point (h z i dist) + "Move point I of zone Z by DIST (F26.6) along the freedom vector; mark touched. +F_dot_P (freedom·projection) is clamped to 0x4000 when |F_dot_P| < 0x400, exactly as +FreeType's Compute_Funcs — otherwise a near-perpendicular freedom/projection would +divide by ~0 and drop (or spike) the move (e.g. DejaVu '$' diagonal at small ppem)." + (let* ((fx (hs-fx h)) (fy (hs-fy h)) + (fdotp (dot14 fx fy (hs-px h) (hs-py h)))) + (when (< (abs fdotp) #x400) (setf fdotp #x4000)) + (when (/= fx 0) (incf (aref (hz-cur-x z) i) (muldiv dist fx fdotp)) + (setf (aref (hz-touch z) i) (logior (aref (hz-touch z) i) 1))) + (when (/= fy 0) (incf (aref (hz-cur-y z) i) (muldiv dist fy fdotp)) + (setf (aref (hz-touch z) i) (logior (aref (hz-touch z) i) 2))))) + +;;; ---- program bytes ---- +(declaim (inline nextb)) +(defun nextb (h) (prog1 (aref (hs-code h) (hs-pc h)) (incf (hs-pc h)))) +(defun nextw (h) (let ((hi (nextb h)) (lo (nextb h))) + (let ((x (logior (ash hi 8) lo))) (if (>= x #x8000) (- x #x10000) x)))) + +;;; ---- the eval loop ---- +(defvar *hint-trace* (and (uiop:getenv "WEFT_HINT_TRACE") t) + "When set (env WEFT_HINT_TRACE), dump per-instruction interpreter state to match +FreeType's trace build (ftbuild) for line-by-line execution diffs.") + +(defun hint-trace-state (h) + "Emit one STATE line mirroring the patched FreeType ttinterp trace format." + (let ((z (ignore-errors (zone h 1)))) + (format *error-output* "STATE pc=~a op=0x~2,'0X proj=(~a,~a) free=(~a,~a) rp=~a,~a,~a zp=~a,~a,~a loop=~a |" + (hs-pc h) (aref (hs-code h) (hs-pc h)) (hs-px h) (hs-py h) (hs-fx h) (hs-fy h) + (hs-rp0 h) (hs-rp1 h) (hs-rp2 h) (hs-zp0 h) (hs-zp1 h) (hs-zp2 h) (hs-loop h)) + (when z + (dotimes (i (length (hz-cur-x z))) + (format *error-output* " ~a:(~a,~a)~a" i (aref (hz-cur-x z) i) (aref (hz-cur-y z) i) + (if (plusp (aref (hz-touch z) i)) "*" " ")))) + (format *error-output* "~%"))) + +(defun run-program (h code) + "Execute CODE (a byte vector) to completion (pc past end)." + (setf (hs-code h) code (hs-pc h) 0) + (loop while (< (hs-pc h) (length code)) do + (when *hint-trace* (hint-trace-state h)) + (step-op h))) + +(defun step-op (h) + (let ((op (nextb h))) + (cond + ;; PUSHB[abc] / PUSHW[abc] / NPUSHB / NPUSHW + ((<= #xB0 op #xB7) (dotimes (i (+ 1 (- op #xB0))) (hpush h (nextb h)))) + ((<= #xB8 op #xBF) (dotimes (i (+ 1 (- op #xB8))) (hpush h (nextw h)))) + ((= op #x40) (dotimes (i (nextb h)) (hpush h (nextb h)))) ; NPUSHB + ((= op #x41) (dotimes (i (nextb h)) (hpush h (nextw h)))) ; NPUSHW + (t (funcall (op-fn op) h op))))) + +;;; opcode table: filled by DEF-OP; unknown -> the trap so coverage is data-driven +(defvar *ops* (make-array 256 :initial-element nil)) +(defun op-fn (op) (or (aref *ops* op) (lambda (h o) (declare (ignore h)) (error 'hint-unimplemented :op o)))) +(defmacro def-op (code (h &optional (opv (gensym))) &body body) + `(setf (aref *ops* ,code) (lambda (,h ,opv) (declare (ignorable ,h ,opv)) ,@body))) + +;;; ---- stack / arithmetic / logic ---- +(def-op #x20 (h) (let ((v (hpop h))) (hpush h v) (hpush h v))) ; DUP +(def-op #x21 (h) (hpop h)) ; POP +(def-op #x22 (h) (setf (hs-sp h) 0)) ; CLEAR +(def-op #x23 (h) (let ((a (hpop h)) (b (hpop h))) (hpush h a) (hpush h b))) ; SWAP +(def-op #x24 (h) (hpush h (hs-sp h))) ; DEPTH +(def-op #x60 (h) (hpush h (+ (hpop h) (hpop h)))) ; ADD +(def-op #x61 (h) (let ((b (hpop h)) (a (hpop h))) (hpush h (- a b)))) ; SUB +(def-op #x62 (h) (let ((b (hpop h)) (a (hpop h))) (hpush h (if (zerop b) 0 (muldiv a 64 b))))) ; DIV: (a*64)/b +(def-op #x63 (h) (let ((b (hpop h)) (a (hpop h))) (hpush h (muldiv a b 64)))) ; MUL: (a*b)/64 +(def-op #x64 (h) (hpush h (abs (hpop h)))) ; ABS +(def-op #x65 (h) (hpush h (- (hpop h)))) ; NEG +(def-op #x66 (h) (hpush h (* 64 (floor (hpop h) 64)))) ; FLOOR +(def-op #x67 (h) (hpush h (* 64 (ceiling (hpop h) 64)))) ; CEILING +(def-op #x68 (h) (hpush h (hround h (hpop h)))) ; ROUND[00] +(def-op #x69 (h) (hpush h (hround h (hpop h)))) ; ROUND[01] +(def-op #x6A (h) (hpush h (hround h (hpop h)))) ; ROUND[10] +(def-op #x6B (h) (hpush h (hround h (hpop h)))) ; ROUND[11] +;; NROUND[abcd]: grayscale engine compensation is 0 -> identity (value stays) +(def-op #x6C (h) nil) (def-op #x6D (h) nil) (def-op #x6E (h) nil) (def-op #x6F (h) nil) +(def-op #x50 (h) (let ((b (hpop h)) (a (hpop h))) (hpush h (if (< a b) 1 0)))) ; LT +(def-op #x51 (h) (let ((b (hpop h)) (a (hpop h))) (hpush h (if (<= a b) 1 0)))) ; LTEQ +(def-op #x52 (h) (let ((b (hpop h)) (a (hpop h))) (hpush h (if (> a b) 1 0)))) ; GT +(def-op #x53 (h) (let ((b (hpop h)) (a (hpop h))) (hpush h (if (>= a b) 1 0)))) ; GTEQ +(def-op #x54 (h) (hpush h (if (= (hpop h) (hpop h)) 1 0))) ; EQ +(def-op #x55 (h) (hpush h (if (/= (hpop h) (hpop h)) 1 0))) ; NEQ +(def-op #x56 (h) (hpush h (if (logbitp 6 (hround h (hpop h))) 1 0))) ; ODD +(def-op #x57 (h) (hpush h (if (logbitp 6 (hround h (hpop h))) 0 1))) ; EVEN +(def-op #x5A (h) (let ((b (hpop h)) (a (hpop h))) (hpush h (if (and (/= a 0) (/= b 0)) 1 0)))) ; AND +(def-op #x5B (h) (let ((b (hpop h)) (a (hpop h))) (hpush h (if (or (/= a 0) (/= b 0)) 1 0)))) ; OR +(def-op #x5C (h) (hpush h (if (zerop (hpop h)) 1 0))) ; NOT +(def-op #x8A (h) (let ((a (hpop h)) (b (hpop h)) (c (hpop h))) (hpush h b) (hpush h a) (hpush h c))) ; ROLL +(def-op #x8B (h) (let ((b (hpop h)) (a (hpop h))) (hpush h (max a b)))) ; MAX +(def-op #x8C (h) (let ((b (hpop h)) (a (hpop h))) (hpush h (min a b)))) ; MIN + +;;; ---- storage / cvt / measurement ---- +(def-op #x43 (h) (hpush h (aref (hs-storage h) (hpop h)))) ; RS +(def-op #x42 (h) (let ((v (hpop h)) (i (hpop h))) (setf (aref (hs-storage h) i) v))) ; WS +(def-op #x44 (h) (let ((v (hpop h)) (i (hpop h))) (setf (aref (hs-cvt h) i) v))) ; WCVTP +(def-op #x70 (h) (let ((v (hpop h)) (i (hpop h))) ; WCVTF (value in FUnits) + (setf (aref (hs-cvt h) i) (hscale h v)))) +(def-op #x45 (h) (hpush h (aref (hs-cvt h) (hpop h)))) ; RCVT +(def-op #x4B (h) (hpush h (hs-ppem h))) ; MPPEM (integer ppem) +(def-op #x4C (h) (hpush h (hs-ppem h))) ; MPS (point size ~= ppem here) +(def-op #x88 (h) ; GETINFO + ;; report FreeType classic interpreter (v35), grayscale, not rotated/stretched. + (let ((sel (hpop h)) (r 0)) + (when (logbitp 0 sel) (setf r (logior r 35))) ; rasterizer version + (when (logbitp 5 sel) (setf r (logior r #x1000))) ; grayscale/smooth + (hpush h r))) + +;;; ---- DELTA exceptions (per-ppem tweaks to CVT entries / points) ---- +;;; Stack (top-down after n): argN, ptN, ... Each arg = (relppem<<4)|mag; the +;;; exception fires only at ppem = base + relppem. mag bits 0..15 -> steps +;;; -8..-1,+1..+8; step = 1/(2^delta-shift) px = (64 >> delta-shift) in F26.6. +(defun delta-step (h arg) + (let ((bits (logand arg #xF))) + (* (if (< bits 8) (- bits 8) (- bits 7)) (ash 64 (- (hs-delta-shift h)))))) +;;; Stack (top-down after n): the cvt/point INDEX is nearer the top, the exception +;;; ARG is below it (spec: "... arg1 idx1 n"). So pop index first, then arg. +(defun do-deltac (h base-off) + (let ((n (hpop h)) (base (+ (hs-delta-base h) base-off))) + (dotimes (i n) + (let ((idx (hpop h)) (arg (hpop h))) + (when (= (hs-ppem h) (+ base (ash arg -4))) + (incf (aref (hs-cvt h) idx) (delta-step h arg))))))) +(defun do-deltap (h base-off) + (let ((n (hpop h)) (base (+ (hs-delta-base h) base-off))) + (dotimes (i n) + (let ((pt (hpop h)) (arg (hpop h))) + (when (= (hs-ppem h) (+ base (ash arg -4))) + (move-point h (zone h (hs-zp0 h)) pt (delta-step h arg))))))) +(def-op #x73 (h) (do-deltac h 0)) ; DELTAC1 +(def-op #x74 (h) (do-deltac h 16)) ; DELTAC2 +(def-op #x75 (h) (do-deltac h 32)) ; DELTAC3 +(def-op #x5D (h) (do-deltap h 0)) ; DELTAP1 +(def-op #x71 (h) (do-deltap h 16)) ; DELTAP2 +(def-op #x72 (h) (do-deltap h 32)) ; DELTAP3 + +;;; ---- graphics-state setters ---- +(def-op #x00 (h) (setf (hs-px h) 0 (hs-py h) 16384 (hs-dpx h) 0 (hs-dpy h) 16384 + (hs-fx h) 0 (hs-fy h) 16384)) ; SVTCA[y] +(def-op #x01 (h) (setf (hs-px h) 16384 (hs-py h) 0 (hs-dpx h) 16384 (hs-dpy h) 0 + (hs-fx h) 16384 (hs-fy h) 0)) ; SVTCA[x] +;; opcode&1 selects axis: 1=x, 0=y (so 0x02/0x04 are the Y variants). +(def-op #x02 (h) (setf (hs-px h) 0 (hs-py h) 16384 (hs-dpx h) 0 (hs-dpy h) 16384)) ; SPVTCA[y] +(def-op #x03 (h) (setf (hs-px h) 16384 (hs-py h) 0 (hs-dpx h) 16384 (hs-dpy h) 0)) ; SPVTCA[x] +(def-op #x04 (h) (setf (hs-fx h) 0 (hs-fy h) 16384)) ; SFVTCA[y] +(def-op #x05 (h) (setf (hs-fx h) 16384 (hs-fy h) 0)) ; SFVTCA[x] +(def-op #x0E (h) (setf (hs-fx h) (hs-px h) (hs-fy h) (hs-py h))) ; SFVTPV +(def-op #x10 (h) (setf (hs-rp0 h) (hpop h))) ; SRP0 +(def-op #x11 (h) (setf (hs-rp1 h) (hpop h))) ; SRP1 +(def-op #x12 (h) (setf (hs-rp2 h) (hpop h))) ; SRP2 +(def-op #x13 (h) (setf (hs-zp0 h) (hpop h))) ; SZP0 +(def-op #x14 (h) (setf (hs-zp1 h) (hpop h))) ; SZP1 +(def-op #x15 (h) (setf (hs-zp2 h) (hpop h))) ; SZP2 +(def-op #x16 (h) (let ((v (hpop h))) (setf (hs-zp0 h) v (hs-zp1 h) v (hs-zp2 h) v))) ; SZPS +(def-op #x17 (h) (setf (hs-loop h) (hpop h))) ; SLOOP +(def-op #x1A (h) (setf (hs-min-dist h) (hpop h))) ; SMD +(def-op #x1D (h) (setf (hs-cvt-cut-in h) (hpop h))) ; SCVTCI +(def-op #x1E (h) (setf (hs-sw-cut-in h) (hpop h))) ; SSWCI +(def-op #x1F (h) (setf (hs-sw-value h) (hpop h))) ; SSW (FUnits->F26.6 approx) +(def-op #x4D (h) (setf (hs-auto-flip h) t)) ; FLIPON +(def-op #x4E (h) (setf (hs-auto-flip h) nil)) ; FLIPOFF +(def-op #x5E (h) (setf (hs-delta-base h) (hpop h))) ; SDB +(def-op #x5F (h) (setf (hs-delta-shift h) (hpop h))) ; SDS +(def-op #x85 (h) (setf (hs-scan-control h) (hpop h))) ; SCANCTRL +(def-op #x8D (h) (setf (hs-scan-control h) (hpop h))) ; SCANTYPE (fold: consume) +(def-op #x8E (h) (setf (hs-instruct-control h) (progn (hpop h) (hpop h) 0))) ; INSTCTRL (consume 2) + +;;; ---- rounding-state setters (correct opcodes; RTDG=0x3D, ROFF=0x7A) ---- +(def-op #x18 (h) (setf (hs-round-state h) :grid) (set-round-period h 64 0 32)) ; RTG +(def-op #x19 (h) (setf (hs-round-state h) :grid) (set-round-period h 64 32 32)) ; RTHG (phase=half) +(def-op #x3D (h) (setf (hs-round-state h) :grid) (set-round-period h 32 0 16)) ; RTDG +(def-op #x7A (h) (setf (hs-round-state h) :off)) ; ROFF +(def-op #x7C (h) (setf (hs-round-state h) :grid) (set-round-period h 64 0 63)) ; RUTG (up=ceil: thr=period-1) +(def-op #x7D (h) (setf (hs-round-state h) :grid) (set-round-period h 64 0 0)) ; RDTG (down) + +;;; ---- flow control: IF/ELSE/EIF, function defs, calls, jumps ---- +(defun skip-to (h &rest ends) + "Advance pc past a matching EIF/ELSE, honoring nested IFs. ENDS = opcodes that +stop the skip at depth 0 (0x59 EIF, and optionally 0x1B ELSE)." + (let ((depth 0)) + (loop + (let ((op (nextb h))) + (cond ((= op #x58) (incf depth)) ; nested IF + ((and (= op #x59) (zerop depth)) (return)) ; EIF + ((= op #x59) (decf depth)) + ((and (member op ends) (zerop depth)) (return)) + ;; skip inline push data so we don't misread it as opcodes + ((<= #xB0 op #xB7) (dotimes (i (+ 1 (- op #xB0))) (nextb h))) + ((<= #xB8 op #xBF) (dotimes (i (+ 1 (- op #xB8))) (nextb h) (nextb h))) + ((= op #x40) (dotimes (i (nextb h)) (nextb h))) + ((= op #x41) (dotimes (i (nextb h)) (nextb h) (nextb h)))))))) +(def-op #x58 (h) (if (zerop (hpop h)) (skip-to h #x1B) nil)) ; IF (false -> skip to ELSE/EIF) +(def-op #x1B (h) (skip-to h)) ; ELSE (THEN fell here -> skip to EIF) +(def-op #x59 (h) nil) ; EIF +(def-op #x1C (h) (let ((off (hpop h))) (setf (hs-pc h) (+ (- (hs-pc h) 1) off)))) ; JMPR +(def-op #x78 (h) (let ((e (hpop h)) (off (hpop h))) ; JROT (jump if true) + (unless (zerop e) (setf (hs-pc h) (+ (- (hs-pc h) 1) off))))) +(def-op #x79 (h) (let ((e (hpop h)) (off (hpop h))) ; JROF (jump if false) + (when (zerop e) (setf (hs-pc h) (+ (- (hs-pc h) 1) off))))) + +(def-op #x2C (h) ; FDEF + (let ((fn (hpop h)) (start (hs-pc h))) + (setf (gethash fn (hs-functions h)) (cons (hs-code h) start)) + ;; skip body to ENDF (0x2D) + (loop for op = (nextb h) until (= op #x2D) do + (cond ((<= #xB0 op #xB7) (dotimes (i (+ 1 (- op #xB0))) (nextb h))) + ((<= #xB8 op #xBF) (dotimes (i (+ 1 (- op #xB8))) (nextb h) (nextb h))) + ((= op #x40) (dotimes (i (nextb h)) (nextb h))) + ((= op #x41) (dotimes (i (nextb h)) (nextb h) (nextb h))))))) +(def-op #x2D (h) nil) ; ENDF (only hit at top level) + +(defun call-fn (h fn) + (let ((def (gethash fn (hs-functions h)))) + (unless def (error "hint: CALL to undefined function ~a" fn)) + (let ((save-code (hs-code h)) (save-pc (hs-pc h))) + (setf (hs-code h) (car def) (hs-pc h) (cdr def)) + (loop for op = (aref (hs-code h) (hs-pc h)) + do (when (= op #x2D) (return)) ; ENDF + (when *hint-trace* (hint-trace-state h)) ; trace into CALLs (align w/ FreeType) + (step-op h)) + (setf (hs-code h) save-code (hs-pc h) save-pc)))) +(def-op #x2B (h) (call-fn h (hpop h))) ; CALL +(def-op #x2A (h) (let ((fn (hpop h)) (n (hpop h))) (dotimes (i n) (call-fn h fn)))) ; LOOPCALL + +;;; ------------------------------------------------------- glyph loading +(defun glyph-instructions (font gid) + "The per-glyph instruction byte stream (or NIL), for a simple or composite glyph." + (multiple-value-bind (off len) (loca-offset font gid) + (when (plusp len) + (let* ((d (font-data font)) (g (+ (req-table font "glyf") off)) (ncont (s16 d g))) + (if (>= ncont 0) + (let* ((p (+ g 10 (* 2 ncont))) (ilen (u16 d p))) + (when (plusp ilen) (subseq d (+ p 2) (+ p 2 ilen)))) + ;; composite: instructions follow the components iff any component has + ;; WE_HAVE_INSTRUCTIONS (0x100). parse-composite-components returns the + ;; byte offset just past the last component. + (multiple-value-bind (comps p) (parse-composite-components d g) + (when (some (lambda (comp) (logbitp 8 (second comp))) comps) + (let ((ilen (u16 d p))) + (when (plusp ilen) (subseq d (+ p 2) (+ p 2 ilen))))))))))) + +;;; ---- composite glyphs: components + (optional) composite instructions ---- +(defun parse-composite-components (d g) + "Parse a composite glyph header at byte offset G into a list of components, each +(cgid flags dx-or-p1 dy-or-p2 a b c e) — 2x2 transform in F2.14, args in FUnits." + (let ((p (+ g 10)) (out '()) (more t)) + (loop while more do + (let* ((flags (u16 d p)) (cgid (u16 d (+ p 2))) (dx 0) (dy 0) + (a 16384) (b 0) (c 0) (e 16384)) + (incf p 4) + (if (logbitp 0 flags) ; ARG_1_AND_2_ARE_WORDS + (progn (setf dx (s16 d p) dy (s16 d (+ p 2))) (incf p 4)) + (progn (setf dx (let ((v (u8 d p))) (if (>= v 128) (- v 256) v)) + dy (let ((v (u8 d (1+ p)))) (if (>= v 128) (- v 256) v))) (incf p 2))) + (flet ((f214 (o) (let ((v (u16 d o))) (if (>= v #x8000) (- v #x10000) v)))) + (cond ((logbitp 3 flags) (setf a (f214 p) e a) (incf p 2)) ; WE_HAVE_A_SCALE + ((logbitp 6 flags) (setf a (f214 p) e (f214 (+ p 2))) (incf p 4)) ; X_AND_Y_SCALE + ((logbitp 7 flags) (setf a (f214 p) b (f214 (+ p 2)) ; TWO_BY_TWO + c (f214 (+ p 4)) e (f214 (+ p 6))) (incf p 8)))) + (push (list cgid flags dx dy a b c e) out) + (setf more (logbitp 5 flags)))) ; MORE_COMPONENTS + (values (nreverse out) p))) ; P now points past components + +(defun glyph-points (h gid) + "Merged points for a simple OR composite GID: (values ux uy cx cy on endpts). +UX/UY are original FUnit coords, CX/CY scaled F26.6 (component xy-offsets grid-fit +per ROUND_XY_TO_GRID); components recurse + carry the 2x2 transform." + (let* ((font (hs-font h)) (d (font-data font))) + (multiple-value-bind (off len) (loca-offset font gid) + (if (zerop len) (values #() #() #() #() #() #()) + (let* ((g (+ (req-table font "glyf") off)) (ncont (s16 d g))) + (if (>= ncont 0) + (multiple-value-bind (xs ys flags endpts) (%simple-glyph d g ncont) + (let* ((np (length xs)) (cx (make-array np)) (cy (make-array np)) (on (make-array np))) + (dotimes (i np) + (setf (aref cx i) (hscale h (aref xs i)) (aref cy i) (hscale h (aref ys i)) + (aref on i) (if (logbitp 0 (aref flags i)) 1 0))) + (values xs ys cx cy on endpts))) + (let ((uxs '()) (uys '()) (cxs '()) (cys '()) (ons '()) (ends '()) (base 0)) + (dolist (comp (parse-composite-components d g)) + (destructuring-bind (cgid flags dx dy a b c e) comp + (let ((rxy (logbitp 2 flags)) (xy (logbitp 1 flags))) + ;; component is HINTED standalone, then transformed + placed + (multiple-value-bind (ccx ccy cux cuy con cend) (hint-subglyph h cgid) + (let* ((n (length ccx)) + (ox (if xy (let ((s (hscale h dx))) (if rxy (* 64 (floor (+ s 32) 64)) s)) 0)) + (oy (if xy (let ((s (hscale h dy))) (if rxy (* 64 (floor (+ s 32) 64)) s)) 0))) + (dotimes (i n) + (let ((x (aref cux i)) (y (aref cuy i)) (px (aref ccx i)) (py (aref ccy i))) + (push (+ (round (+ (* a x) (* c y)) 16384) (if xy dx 0)) uxs) + (push (+ (round (+ (* b x) (* e y)) 16384) (if xy dy 0)) uys) + (push (+ (mul2.14 px a) (mul2.14 py c) ox) cxs) + (push (+ (mul2.14 px b) (mul2.14 py e) oy) cys) + (push (aref con i) ons))) + (loop for ce across cend do (push (+ base ce) ends)) + (incf base n)))))) + (values (coerce (nreverse uxs) 'vector) (coerce (nreverse uys) 'vector) + (coerce (nreverse cxs) 'vector) (coerce (nreverse cys) 'vector) + (coerce (nreverse ons) 'vector) (coerce (nreverse ends) 'vector))))))))) + +;;; ================================================================ glyph hinting +;;; ---- coordinate helpers (all F26.6) ---- +(declaim (inline gc-cur gc-org gc-orus)) +(defun gc-cur (h zp i) (let ((z (zone h zp))) (dot14 (aref (hz-cur-x z) i) (aref (hz-cur-y z) i) (hs-px h) (hs-py h)))) +(defun gc-org (h zp i) (let ((z (zone h zp))) (dot14 (aref (hz-org-x z) i) (aref (hz-org-y z) i) (hs-dpx h) (hs-dpy h)))) +;; dual-projection of the ORIGINAL UNSCALED (font-unit) coords — IP/IUP ratios use +;; these (like FreeType's `orus`) so precision isn't lost to per-point scale rounding. +(defun gc-orus (h zp i) (let ((z (zone h zp))) (dot14 (aref (hz-orus-x z) i) (aref (hz-orus-y z) i) (hs-dpx h) (hs-dpy h)))) +;; FreeType measures point-to-point distances by projecting the DIFFERENCE vector +;; once (PROJECT / DUALPROJ), not by subtracting two independently-projected points +;; — those differ by a rounding unit and cascade into 1-unit mover errors. +(defun cur-dist (h zpp p zpq q) + "PROJECT(cur[p] - cur[q])." + (let ((zp (zone h zpp)) (zq (zone h zpq))) + (dot14 (- (aref (hz-cur-x zp) p) (aref (hz-cur-x zq) q)) + (- (aref (hz-cur-y zp) p) (aref (hz-cur-y zq) q)) (hs-px h) (hs-py h)))) +(defun org-dist (h zpp p zpq q) + "DUALPROJ(org[p] - org[q]) on the scaled original coords (FreeType's MDRP/MIRP org)." + (let ((zp (zone h zpp)) (zq (zone h zpq))) + (dot14 (- (aref (hz-org-x zp) p) (aref (hz-org-x zq) q)) + (- (aref (hz-org-y zp) p) (aref (hz-org-y zq) q)) (hs-dpx h) (hs-dpy h)))) +(defun orus-diff (h zpp p zpq q) + "DUALPROJ(orus[p] - orus[q]) on the ORUS (font-unit) coords — IP's original ranges." + (let ((zp (zone h zpp)) (zq (zone h zpq))) + (dot14 (- (aref (hz-orus-x zp) p) (aref (hz-orus-x zq) q)) + (- (aref (hz-orus-y zp) p) (aref (hz-orus-y zq) q)) (hs-dpx h) (hs-dpy h)))) +(defun orus-dist (h zp1 p zp0 rp0) + "Original projected distance (MDRP/MIRP): DUAL-PROJECT the ORUS (font-unit) +difference, THEN scale — like FreeType (MulFix(DUALPROJ(orus-diff), x_scale), with +x_scale==y_scale). Doing the dual-projection before scaling rounds once at the end, +which matters for diagonal projection vectors. Twilight falls back to scaled org." + (if (or (zerop zp0) (zerop zp1)) + (org-dist h zp1 p zp0 rp0) + (hscale h (orus-diff h zp1 p zp0 rp0)))) +(defun move (h zp i dist) (move-point h (zone h zp) i dist)) +(defun touch-pt (h zp i) + (let ((z (zone h zp))) + (when (/= (hs-fx h) 0) (setf (aref (hz-touch z) i) (logior (aref (hz-touch z) i) 1))) + (when (/= (hs-fy h) 0) (setf (aref (hz-touch z) i) (logior (aref (hz-touch z) i) 2))))) + +;;; ---- load a glyph into zone 1 (+ 4 phantom points), zone 0 = twilight ---- +(defun load-glyph-zone (h gid) + "Populate zone 1 with GID's scaled points + phantom points; zone 0 twilight. +Handles simple AND composite glyphs (components merged via GLYPH-POINTS)." + (let* ((font (hs-font h)) (d (font-data font))) + (multiple-value-bind (off len) (loca-offset font gid) + (when (zerop len) (return-from load-glyph-zone nil)) + (let ((g (+ (req-table font "glyf") off))) + (multiple-value-bind (gux guy gcx gcy gon endpts) (glyph-points h gid) + (let* ((np (length gux)) + (total (+ np 4)) + (cx (make-array total :element-type 'fixnum)) (cy (make-array total :element-type 'fixnum)) + (ox (make-array total :element-type 'fixnum)) (oy (make-array total :element-type 'fixnum)) + (ux (make-array total :element-type 'fixnum)) (uy (make-array total :element-type 'fixnum)) + (on (make-array total :element-type 'bit)) (tc (make-array total :element-type 'fixnum :initial-element 0)) + (xmin (s16 d (+ g 2))) (ymax (s16 d (+ g 8)))) + (dotimes (i np) + (setf (aref cx i) (aref gcx i) (aref ox i) (aref gcx i) + (aref cy i) (aref gcy i) (aref oy i) (aref gcy i) + (aref ux i) (aref gux i) (aref uy i) (aref guy i) + (aref on i) (aref gon i))) + ;; phantom points (FUnits): pp1 origin, pp2 advance, pp3/pp4 vertical + (multiple-value-bind (adv lsb) (hmtx-metrics font gid) + (let* ((p1x (hscale h (- xmin lsb))) (p2x (hscale h (+ (- xmin lsb) adv))) + (p3y (hscale h ymax))) + (flet ((setp (i x y ufx ufy) (setf (aref cx i) x (aref ox i) x (aref cy i) y (aref oy i) y + (aref ux i) ufx (aref uy i) ufy (aref on i) 1))) + (setp np p1x 0 (- xmin lsb) 0) (setp (+ np 1) p2x 0 (+ (- xmin lsb) adv) 0) + (setp (+ np 2) 0 p3y 0 ymax) (setp (+ np 3) 0 0 0 0)) + ;; grid-fit the phantom points' CURRENT position (FT_PIX_ROUND); + ;; ORG stays unrounded so IP/MDRP measure the true original metrics. + ;; This is what lets IP shift a stem when the advance rounds (2.67->3.00). + (flet ((pr (v) (* 64 (floor (+ v 32) 64)))) + (dotimes (k 4) (let ((i (+ np k))) (setf (aref cx i) (pr (aref cx i)) (aref cy i) (pr (aref cy i)))))))) + (setf (hs-glyph-npts h) np (hs-glyph-ends h) endpts) + (let ((glyph (make-hz :cur-x cx :cur-y cy :org-x ox :org-y oy :orus-x ux :orus-y uy :on on :touch tc)) + (mtw (max 4 (1+ (or (getf (parse-maxp1 font) :max-twilight) 4))))) + (setf (hs-zones h) + (vector (make-hz :cur-x (make-array mtw :element-type 'fixnum) :cur-y (make-array mtw :element-type 'fixnum) + :org-x (make-array mtw :element-type 'fixnum) :org-y (make-array mtw :element-type 'fixnum) + :orus-x (make-array mtw :element-type 'fixnum) :orus-y (make-array mtw :element-type 'fixnum) + :on (make-array mtw :element-type 'bit) :touch (make-array mtw :element-type 'fixnum :initial-element 0)) + glyph))) + t)))))) + +(defun reset-glyph-gs (h) + "Per-glyph graphics-state reset, matching FreeType: the policy fields (round mode, +cut-ins, min-distance, delta base/shift, flip, ...) come from the post-prep snapshot +so a glyph program's changes don't leak; but the vectors, zone pointers, reference +points and loop are reset to the FIXED default (x-axis, zone 1, rp 0, loop 1) every +glyph — NOT to whatever prep happened to leave them at." + (when (hs-gs-default h) (restore-gs h)) + (setf (hs-px h) 16384 (hs-py h) 0 (hs-dpx h) 16384 (hs-dpy h) 0 (hs-fx h) 16384 (hs-fy h) 0 + (hs-rp0 h) 0 (hs-rp1 h) 0 (hs-rp2 h) 0 (hs-zp0 h) 1 (hs-zp1 h) 1 (hs-zp2 h) 1 (hs-loop h) 1)) + +(defparameter *hint-light* nil + "Light (Y-only) hinting: grid-fit the outline vertically but keep the ORIGINAL +(fractional, unhinted) X. Baseline/x-height/stem heights snap crisp, but horizontal +stems stay sub-pixel — smooth, even inter-letter rhythm like the browser's default +Linux rendering, instead of full hinting's crisp-but-choppy X grid-fit.") + +(defun hint-glyph (h gid) + "Grid-fit GID at the hinter's ppem. Returns (values contours advance-px): the +hinted contours as lists of (x y on) in px, and the grid-fit horizontal advance +(phantom pp2−pp1). Returns NIL for an empty glyph, or :composite for an +unsupported composite. With *HINT-LIGHT*, X is the unhinted scaled coordinate." + (let ((loaded (load-glyph-zone h gid))) + (unless (eq loaded t) (return-from hint-glyph loaded)) + (reset-glyph-gs h) + (let ((ins (glyph-instructions (hs-font h) gid))) + (when ins (setf (hs-sp h) 0) (run-program h ins))) + ;; extract hinted contour points + the hinted advance (phantom pp1..pp2). + ;; light hinting keeps the original (unhinted) X so horizontal spacing is smooth. + (let* ((z (zone h 1)) (ends (hs-glyph-ends h)) (np (hs-glyph-npts h)) + (xs (if *hint-light* (hz-org-x z) (hz-cur-x z))) (out '()) (start 0)) + (dotimes (c (length ends)) + (let ((end (aref ends c)) (pts '())) + (loop for i from start to end do + (push (list (/ (aref xs i) 64.0) (/ (aref (hz-cur-y z) i) 64.0) (= 1 (aref (hz-on z) i))) pts)) + (push (nreverse pts) out) (setf start (1+ end)))) + (values (nreverse out) + (/ (- (aref (hz-cur-x z) (1+ np)) (aref (hz-cur-x z) np)) 64.0))))) + +(defun hint-subglyph (h gid) + "Hint GID standalone (own zone + instructions), returning its hinted real points as +(values cur-x cur-y orus-x orus-y on endpts) — used to place composite components. +Saves/restores the shared VM's zone + program state so it can nest." + (let ((sz (hs-zones h)) (se (hs-glyph-ends h)) (sn (hs-glyph-npts h)) + (sc (hs-code h)) (sp (hs-pc h)) (ss (hs-sp h))) + (unwind-protect + (if (eq (load-glyph-zone h gid) t) + (progn + (reset-glyph-gs h) + (let ((ins (glyph-instructions (hs-font h) gid))) + (when ins (setf (hs-sp h) 0) (run-program h ins))) + (let* ((z (zone h 1)) (np (hs-glyph-npts h))) + (values (subseq (hz-cur-x z) 0 np) (subseq (hz-cur-y z) 0 np) + (subseq (hz-orus-x z) 0 np) (subseq (hz-orus-y z) 0 np) + (subseq (hz-on z) 0 np) (copy-seq (hs-glyph-ends h))))) + (values #() #() #() #() #() #())) + (setf (hs-zones h) sz (hs-glyph-ends h) se (hs-glyph-npts h) sn + (hs-code h) sc (hs-pc h) sp (hs-sp h) ss)))) + +;;; ---- point-mover opcodes ---- +(def-op #x2E (h) ; MDAP[0] (touch only) + (let ((p (hpop h))) (touch-pt h (hs-zp0 h) p) (setf (hs-rp0 h) p (hs-rp1 h) p))) +(def-op #x2F (h) ; MDAP[1] (round to grid) + (let* ((p (hpop h)) (cur (gc-cur h (hs-zp0 h) p))) + (move h (hs-zp0 h) p (- (hround h cur) cur)) (setf (hs-rp0 h) p (hs-rp1 h) p))) + +(defun miap (h round) + (let* ((n (hpop h)) (p (hpop h)) (zp (hs-zp0 h)) (cvt (aref (hs-cvt h) n))) + (when (zerop zp) ; twilight: set position from CVT + (let ((z (zone h 0))) + (setf (aref (hz-org-x z) p) (mul2.14 cvt (hs-px h)) (aref (hz-org-y z) p) (mul2.14 cvt (hs-py h)) + (aref (hz-cur-x z) p) (aref (hz-org-x z) p) (aref (hz-cur-y z) p) (aref (hz-org-y z) p)))) + (let ((cur (gc-cur h zp p))) + (when round + (when (> (abs (- cvt cur)) (hs-cvt-cut-in h)) (setf cvt cur)) + (setf cvt (hround h cvt))) + (move h zp p (- cvt cur)) (setf (hs-rp0 h) p (hs-rp1 h) p)))) +(def-op #x3E (h) (miap h nil)) ; MIAP[0] +(def-op #x3F (h) (miap h t)) ; MIAP[1] + +(defun min-distance (dist org mindist) + "FreeType MDRP/MIRP minimum-distance clamp: keep DIST at least MINDIST in ORG's +direction (asymmetric — based on ORG's sign, not |dist|)." + (if (>= org 0) + (if (< dist mindist) mindist dist) + (if (> dist (- mindist)) (- mindist) dist))) + +(defun mdrp (h op) + ;; flags: bit2 (0x04) round, bit3 (0x08) keep-min-distance, bit4 (0x10) set rp0. + (let* ((p (hpop h)) (org (orus-dist h (hs-zp1 h) p (hs-zp0 h) (hs-rp0 h))) + (dist (if (logbitp 2 op) (hround h org) org))) + (when (logbitp 3 op) (setf dist (min-distance dist org (hs-min-dist h)))) + (move h (hs-zp1 h) p (- dist (cur-dist h (hs-zp1 h) p (hs-zp0 h) (hs-rp0 h)))) + (setf (hs-rp1 h) (hs-rp0 h) (hs-rp2 h) p) (when (logbitp 4 op) (setf (hs-rp0 h) p)))) +(dotimes (i 32) (setf (aref *ops* (+ #xC0 i)) (lambda (h op) (mdrp h op)))) ; MDRP + +(defun mirp (h op) + ;; FreeType order: auto-flip cvt to org's sign FIRST, THEN the control-value cut-in + ;; (same-zone), round, and min-distance. + (let* ((n (hpop h)) (p (hpop h)) (cvt (aref (hs-cvt h) n)) + (org (orus-dist h (hs-zp1 h) p (hs-zp0 h) (hs-rp0 h)))) + (when (and (hs-auto-flip h) (minusp (* org cvt))) (setf cvt (- cvt))) + (let ((dist (if (logbitp 2 op) + (progn (when (and (= (hs-zp0 h) (hs-zp1 h)) + (> (abs (- cvt org)) (hs-cvt-cut-in h))) + (setf cvt org)) + (hround h cvt)) + cvt))) + (when (logbitp 3 op) (setf dist (min-distance dist org (hs-min-dist h)))) + (move h (hs-zp1 h) p (- dist (cur-dist h (hs-zp1 h) p (hs-zp0 h) (hs-rp0 h)))) + (setf (hs-rp1 h) (hs-rp0 h) (hs-rp2 h) p) (when (logbitp 4 op) (setf (hs-rp0 h) p))))) +(dotimes (i 32) (setf (aref *ops* (+ #xE0 i)) (lambda (h op) (mirp h op)))) ; MIRP + +(defun msirp (h op) ; MSIRP: move point to a stack distance from rp0 + (let ((distance (hpop h)) (point (hpop h))) + (when (zerop (hs-zp1 h)) ; twilight: seed point at rp0 + distance + (let ((z0 (zone h (hs-zp0 h))) (z1 (zone h 0)) (rp0 (hs-rp0 h))) + (setf (aref (hz-org-x z1) point) (+ (aref (hz-org-x z0) rp0) (mul2.14 distance (hs-fx h))) + (aref (hz-org-y z1) point) (+ (aref (hz-org-y z0) rp0) (mul2.14 distance (hs-fy h))) + (aref (hz-cur-x z1) point) (aref (hz-org-x z1) point) + (aref (hz-cur-y z1) point) (aref (hz-org-y z1) point)))) + (move h (hs-zp1 h) point (- distance (cur-dist h (hs-zp1 h) point (hs-zp0 h) (hs-rp0 h)))) + (setf (hs-rp1 h) (hs-rp0 h) (hs-rp2 h) point) + (when (logbitp 0 op) (setf (hs-rp0 h) point)))) +(def-op #x3A (h op) (msirp h op)) (def-op #x3B (h op) (msirp h op)) + +(def-op #x39 (h) ; IP + ;; Ranges/distances are projections of DIFFERENCE vectors (FreeType PROJECT/ + ;; DUALPROJ): original in ORUS (font units) for precision, current in scaled cur. + ;; Base = rp1. + (let* ((ra (hs-rp1 h)) (rb (hs-rp2 h)) + (old-range (orus-diff h (hs-zp1 h) rb (hs-zp0 h) ra)) + (cur-range (cur-dist h (hs-zp1 h) rb (hs-zp0 h) ra))) + (dotimes (k (hs-loop h)) + (let* ((p (hpop h)) + (org-dist (orus-diff h (hs-zp2 h) p (hs-zp0 h) ra)) + (cp (cur-dist h (hs-zp2 h) p (hs-zp0 h) ra)) + (new (if (zerop old-range) 0 (muldiv org-dist cur-range old-range)))) + (move h (hs-zp2 h) p (- new cp)))) + (setf (hs-loop h) 1))) + +(defun sh-ref (h op) + "FreeType Compute_Point_Displacement for SHP/SHC/SHZ: the reference is rp1/zp0 (odd +opcode) or rp2/zp1 (even); the shift is PROJECT(cur[ref] - org[ref]) — the projection +of the difference vector (then applied along the freedom vector by MOVE). Returns +(values displacement ref-point ref-zone)." + (multiple-value-bind (rp zref) (if (logbitp 0 op) (values (hs-rp1 h) (hs-zp0 h)) (values (hs-rp2 h) (hs-zp1 h))) + (let ((z (zone h zref))) + (values (dot14 (- (aref (hz-cur-x z) rp) (aref (hz-org-x z) rp)) + (- (aref (hz-cur-y z) rp) (aref (hz-org-y z) rp)) (hs-px h) (hs-py h)) + rp zref)))) +(defun shp (h op) ; SHP[a] + (multiple-value-bind (disp rp zref) (sh-ref h op) (declare (ignore rp zref)) + (dotimes (k (hs-loop h)) (move h (hs-zp2 h) (hpop h) disp)) + (setf (hs-loop h) 1))) +(def-op #x32 (h op) (shp h op)) (def-op #x33 (h op) (shp h op)) +(defun shc (h op) ; SHC: shift a whole contour + (multiple-value-bind (disp rp zref) (sh-ref h op) + (let* ((c (hpop h)) (ends (hs-glyph-ends h)) + (start (if (zerop c) 0 (1+ (aref ends (1- c))))) (end (aref ends c))) + (loop for i from start to end + unless (and (= (hs-zp2 h) zref) (= i rp)) do (move h (hs-zp2 h) i disp))))) +(def-op #x34 (h op) (shc h op)) (def-op #x35 (h op) (shc h op)) +(defun shz (h op) ; SHZ: shift an entire zone + (multiple-value-bind (disp rp zref) (sh-ref h op) + (let* ((e (hpop h)) (z (zone h e)) (n (length (hz-cur-x z)))) + (dotimes (i n) (unless (and (= e zref) (= i rp)) (move h e i disp)))))) +(def-op #x36 (h op) (shz h op)) (def-op #x37 (h op) (shz h op)) + +(def-op #x38 (h) ; SHPIX: shift loop points by a + ;; pixel AMOUNT along the freedom vector (amount is on top, points below it). + (let* ((amount (hpop h)) (dx (mul2.14 amount (hs-fx h))) (dy (mul2.14 amount (hs-fy h))) + (z (zone h (hs-zp2 h)))) + (dotimes (k (hs-loop h)) + (let ((p (hpop h))) + (incf (aref (hz-cur-x z) p) dx) (incf (aref (hz-cur-y z) p) dy) + (touch-pt h (hs-zp2 h) p))) + (setf (hs-loop h) 1))) + +(def-op #x3C (h) ; ALIGNRP + (let ((rp0 (hs-rp0 h))) + (dotimes (k (hs-loop h)) + (let ((p (hpop h))) (move h (hs-zp1 h) p (cur-dist h (hs-zp0 h) rp0 (hs-zp1 h) p)))) + (setf (hs-loop h) 1))) + +(def-op #x46 (h) (hpush h (gc-cur h (hs-zp2 h) (hpop h)))) ; GC[0] current +(def-op #x47 (h) (hpush h (gc-org h (hs-zp2 h) (hpop h)))) ; GC[1] original +(def-op #x49 (h) (let ((b (hpop h)) (a (hpop h))) ; MD[0] current distance + (hpush h (cur-dist h (hs-zp0 h) a (hs-zp1 h) b)))) +(def-op #x4A (h) (let ((b (hpop h)) (a (hpop h))) ; MD[1] original distance + (hpush h (orus-dist h (hs-zp0 h) a (hs-zp1 h) b)))) +(def-op #x48 (h) (let ((v (hpop h)) (p (hpop h))) ; SCFS + (move h (hs-zp2 h) p (- v (gc-cur h (hs-zp2 h) p))))) + +;;; ---- IUP: interpolate untouched points per contour, per axis ---- +(defun iup-axis (h touchbit cur org orus) + "Interpolate untouched (in TOUCHBIT) points per contour. Interior points use the +ORUS (font-unit) ratio like FreeType; points outside the touched span shift rigidly +by the nearest touched point's delta (scaled ORG)." + (let* ((z (zone h 1)) (ends (hs-glyph-ends h)) (start 0) (tou (hz-touch z))) + (dotimes (c (length ends)) + (let* ((end (aref ends c)) (n (1+ (- end start)))) + (when (plusp n) + ;; collect touched indices in this contour + (let ((touched '())) + (loop for i from start to end when (logbitp (if (= touchbit 1) 0 1) (aref tou i)) do (push i touched)) + (setf touched (nreverse touched)) + (when touched + (flet ((interp (i a b) ; move untouched i between touched a,b + ;; Exact port of FreeType iup_worker_interpolate_: sort refs by + ;; ORUS; the boundary classification uses SCALED org (so points + ;; sharing a ref's scaled position shift with it); the interior + ;; ratio uses ORUS (font units) via DivFix->MulFix. + (multiple-value-bind (r1 r2) + (if (<= (funcall orus a) (funcall orus b)) (values a b) (values b a)) + (let* ((orus1 (funcall orus r1)) (orus2 (funcall orus r2)) + (org1 (funcall org r1)) (org2 (funcall org r2)) + (cur1 (funcall cur r1)) (cur2 (funcall cur r2)) + (xi (funcall org i))) + (funcall cur i + (cond ((<= xi org1) (+ xi (- cur1 org1))) + ((>= xi org2) (+ xi (- cur2 org2))) + ((or (= cur1 cur2) (= orus1 orus2)) cur1) + (t (+ cur1 (muldiv (- (funcall orus i) orus1) + (muldiv (- cur2 cur1) 65536 (- orus2 orus1)) + 65536))))))))) + (if (= 1 (length touched)) + ;; single touched point: shift whole contour by its delta + (let* ((a (car touched)) (delta (- (funcall cur a) (funcall org a)))) + (loop for i from start to end unless (= i a) do (funcall cur i (+ (funcall org i) delta)))) + ;; between each consecutive touched pair (with wraparound) + (loop for (a b) on (append touched (list (car touched))) + while b do + (loop for k from 1 below (mod (- b a) n) ; untouched strictly between a..b (cyclic) + for i = (+ start (mod (+ (- a start) k) n)) + do (interp i a b)))))))) + (setf start (1+ end)))))) +(macrolet ((cur-acc (bit) `(lambda (&rest r) (let ((z (zone h 1))) + (if (cdr r) (setf (aref ,(if (= bit 1) '(hz-cur-x z) '(hz-cur-y z)) (first r)) (second r)) + (aref ,(if (= bit 1) '(hz-cur-x z) '(hz-cur-y z)) (first r))))))) + (def-op #x30 (h) (iup-axis h 2 (let ((z (zone h 1))) (lambda (i &optional (v nil vp)) (if vp (setf (aref (hz-cur-y z) i) v) (aref (hz-cur-y z) i)))) + (let ((z (zone h 1))) (lambda (i) (aref (hz-org-y z) i))) + (let ((z (zone h 1))) (lambda (i) (aref (hz-orus-y z) i))))) ; IUP[y] + (def-op #x31 (h) (iup-axis h 1 (let ((z (zone h 1))) (lambda (i &optional (v nil vp)) (if vp (setf (aref (hz-cur-x z) i) v) (aref (hz-cur-x z) i)))) + (let ((z (zone h 1))) (lambda (i) (aref (hz-org-x z) i))) + (let ((z (zone h 1))) (lambda (i) (aref (hz-orus-x z) i)))))) ; IUP[x] + +;;; ---- vector setters that need points (SPVTL/SFVTL) + misc ---- +(defun norm14 (vx vy) + "F2.14 unit vector of (vx,vy), an exact port of FreeType's Normalize + +FT_Vector_NormLen: Newton-Raphson normalize to length 0x10000 (16.16), then /4. +This matches FreeType's projection vectors bit-for-bit (isqrt was ~9/16384 off, +which cascaded into 1-unit diagonal MIRP errors)." + (labels ((u32 (n) (logand n #xFFFFFFFF)) + (s32 (n) (let ((m (logand n #xFFFFFFFF))) (if (>= m #x80000000) (- m #x100000000) m)))) + (if (and (zerop vx) (zerop vy)) (values 16384 0) + (let ((sx (if (minusp vx) -1 1)) (sy (if (minusp vy) -1 1)) (x (abs vx)) (y (abs vy))) + (cond ((zerop x) (values 0 (if (plusp y) (* sy 16384) 0))) + ((zerop y) (values (if (plusp x) (* sx 16384) 0) 0)) + (t + (let* ((l (if (> x y) (+ x (ash y -1)) (+ y (ash x -1)))) + (shift (- 32 (integer-length l)))) + (decf shift (+ 15 (if (>= l (ash #xAAAAAAAA (- shift))) 1 0))) + (if (> shift 0) + (progn (setf x (ash x shift) y (ash y shift)) + (setf l (if (> x y) (+ x (ash y -1)) (+ y (ash x -1))))) + (setf x (ash x shift) y (ash y shift) l (ash l shift))) + (let ((b (- #x10000 l)) (x_ x) (y_ y) (u 0) (v 0) (z 0)) + (loop + (setf u (u32 (+ x_ (ash (s32 (* x_ b)) -16))) + v (u32 (+ y_ (ash (s32 (* y_ b)) -16)))) + (setf z (truncate (- (s32 (+ (* u u) (* v v)))) #x200)) + (setf z (truncate (* z (ash (+ #x10000 b) -8)) #x10000)) + (incf b z) + (when (<= z 0) (return))) + (values (truncate (* sx u) 4) (truncate (* sy v) 4)))))))))) +(defun sxvtl (h op set-proj) + "SPVTL/SFVTL: set the vector PARALLEL (opcode even) or PERPENDICULAR (opcode odd, +`opcode & 1`) to the line from point A (zp2) to point B (zp1), in current coords. +Perpendicular is a 90° CCW rotation, matching FreeType's Ins_SxVTL. Sets proj+dual +(and also freedom for the SFVTL forms)." + (let* ((pa (hpop h)) (pb (hpop h)) (za (zone h (hs-zp2 h))) (zb (zone h (hs-zp1 h))) + (dx (- (aref (hz-cur-x zb) pb) (aref (hz-cur-x za) pa))) + (dy (- (aref (hz-cur-y zb) pb) (aref (hz-cur-y za) pa)))) + (when (oddp op) (psetf dx (- dy) dy dx)) ; perpendicular (90° CCW) + (multiple-value-bind (ux uy) (norm14 dx dy) + (if set-proj (setf (hs-px h) ux (hs-py h) uy (hs-dpx h) ux (hs-dpy h) uy) + (setf (hs-fx h) ux (hs-fy h) uy))))) +(def-op #x06 (h op) (sxvtl h op t)) ; SPVTL[0] (parallel) +(def-op #x07 (h op) (sxvtl h op t)) ; SPVTL[1] (perpendicular) +(def-op #x08 (h op) (sxvtl h op nil)) ; SFVTL[0] (parallel) +(def-op #x09 (h op) (sxvtl h op nil)) ; SFVTL[1] (perpendicular) +(def-op #x0F (h) ; ISECT: move point to line-line intersection + (let* ((b1 (hpop h)) (b0 (hpop h)) (a1 (hpop h)) (a0 (hpop h)) (pt (hpop h)) + (z0 (zone h (hs-zp0 h))) (z1 (zone h (hs-zp1 h))) (z2 (zone h (hs-zp2 h))) + (dbx (- (aref (hz-cur-x z0) b1) (aref (hz-cur-x z0) b0))) + (dby (- (aref (hz-cur-y z0) b1) (aref (hz-cur-y z0) b0))) + (dax (- (aref (hz-cur-x z1) a1) (aref (hz-cur-x z1) a0))) + (day (- (aref (hz-cur-y z1) a1) (aref (hz-cur-y z1) a0))) + (dx (- (aref (hz-cur-x z0) b0) (aref (hz-cur-x z1) a0))) + (dy (- (aref (hz-cur-y z0) b0) (aref (hz-cur-y z1) a0))) + (disc (+ (muldiv dax (- dby) 64) (muldiv day dbx 64))) + (dot (+ (muldiv dax dbx 64) (muldiv day dby 64)))) + (if (> (* 19 (abs disc)) (abs dot)) + (let* ((val (+ (muldiv dx (- dby) 64) (muldiv dy dbx 64))) + (rx (muldiv val dax disc)) (ry (muldiv val day disc))) + (setf (aref (hz-cur-x z2) pt) (+ (aref (hz-cur-x z1) a0) rx) + (aref (hz-cur-y z2) pt) (+ (aref (hz-cur-y z1) a0) ry))) + (setf (aref (hz-cur-x z2) pt) (ash (+ (aref (hz-cur-x z1) a0) (aref (hz-cur-x z1) a1) + (aref (hz-cur-x z0) b0) (aref (hz-cur-x z0) b1)) -2) + (aref (hz-cur-y z2) pt) (ash (+ (aref (hz-cur-y z1) a0) (aref (hz-cur-y z1) a1) + (aref (hz-cur-y z0) b0) (aref (hz-cur-y z0) b1)) -2))) + (setf (aref (hz-touch z2) pt) (logior (aref (hz-touch z2) pt) 3)))) +(def-op #x0A (h) (let ((y (hpop h)) (x (hpop h))) (setf (hs-px h) x (hs-py h) y (hs-dpx h) x (hs-dpy h) y))) ; SPVFS +(def-op #x0B (h) (let ((y (hpop h)) (x (hpop h))) (setf (hs-fx h) x (hs-fy h) y))) ; SFVFS +(def-op #x0C (h) (hpush h (hs-px h)) (hpush h (hs-py h))) ; GPV +(def-op #x0D (h) (hpush h (hs-fx h)) (hpush h (hs-fy h))) ; GFV +(def-op #x25 (h) (hpush h (aref (hs-stack h) (- (hs-sp h) 1 (hpop h))))) ; CINDEX +(def-op #x26 (h) (let* ((k (hpop h)) (i (- (hs-sp h) k)) (v (aref (hs-stack h) i))) ; MINDEX + (loop for j from i below (1- (hs-sp h)) do (setf (aref (hs-stack h) j) (aref (hs-stack h) (1+ j)))) + (decf (hs-sp h)) (hpush h v))) + +;;; ================================================ integration with rasterize-glyph +;;; A hinter (fpgm+prep run) is reused for every glyph at a given (font, ppem); +;;; hinted outlines are memoized per (font, gid, ppem). RASTERIZE-GLYPH calls +;;; HINTED-SEGMENTS through the *HINTED-SEGMENTS-FN* hook when *HINTING* is on. +(defvar *hinter-cache* (make-hash-table :test 'equal) + "(font . ppem) -> a hinter with fpgm+prep already run, or :NONE.") +(defvar *hinted-cache* (make-hash-table :test 'equal) + "(font gid ppem) -> hinted segment lists (px), :EMPTY, or NIL (not hintable).") + +(defun get-hinter (font ppem) + "A cached hinter for FONT at integer PPEM (fpgm+prep run once), or :NONE if the +font has no working hint programs." + (let ((key (cons font ppem))) + (multiple-value-bind (v present) (gethash key *hinter-cache*) + (if present v + (setf (gethash key *hinter-cache*) + (handler-case (let ((h (make-hinter font ppem))) (run-fpgm-prep h) h) + (error () :none))))))) + +(defun hinted-segments (font gid ppem) + "Grid-fit GID at integer PPEM. Returns (values SEGS ADVANCE-PX), memoized: SEGS is +the hinted segment lists in px, :EMPTY for an outline-less glyph (space), or NIL when +it can't be hinted (caller uses the geometric path). ADVANCE-PX is the grid-fit +advance so painted widths stay integer and even; NIL when not hinted." + (let ((key (list font gid ppem *hint-light*))) + (multiple-value-bind (v present) (gethash key *hinted-cache*) + (if present (values (car v) (cdr v)) + (let ((h (get-hinter font ppem))) + (if (eq h :none) (values nil nil) + (handler-case + (multiple-value-bind (cs adv) (hint-glyph h gid) + (let* ((segs (cond ((null cs) :empty) ; no outline (space) + ((consp cs) + (or (mapcan (lambda (c) + (let ((s (%contour->segments c))) (and s (list s)))) + cs) + :empty)) + (t nil))) ; unsupported -> fall back + ;; empty glyphs carry no phantom advance here — round the + ;; scaled hmtx advance so space is integer too. + (advance (if (numberp adv) (float adv 1d0) + (float (round (* (advance-at font gid) + (/ ppem (font-units-per-em font)))) 1d0)))) + (when segs (setf (gethash key *hinted-cache*) (cons segs advance))) + (values segs advance))) + (error () (values nil nil))))))))) + +(defun hinted-advance (font gid ppem) + "The grid-fit horizontal advance (px) for GID at integer PPEM, or NIL if the glyph +isn't hinted (caller uses the geometric advance). For MEASURE = PAINT consistency." + (nth-value 1 (hinted-segments font gid ppem))) + +(defun clear-hint-caches () + "Drop the memoized hinters and hinted outlines (e.g. after changing fonts)." + (clrhash *hinter-cache*) (clrhash *hinted-cache*)) + +(setf *hinted-segments-fn* #'hinted-segments) diff --git a/src/otl.lisp b/src/otl.lisp index 89918a0..a18756c 100644 --- a/src/otl.lisp +++ b/src/otl.lisp @@ -135,9 +135,21 @@ ;;; =========================================================================== (defun otl-lookup-indices (font tag feature-tags) "For GPOS/GSUB table TAG, return (values lookup-list-base sorted-lookup-indices) - for the lookups referenced by FEATURE-TAGS under the default (latn/DFLT) script." + for the lookups referenced by FEATURE-TAGS under the default (latn/DFLT) script. + Cached on the font per (tag . features): the feature/script/lookup tables are + text-independent, so shaping a whole page parses them once, not once per word." + (let ((cache (or (font-%otl font) (setf (font-%otl font) (make-hash-table :test 'equal)))) + (key (cons tag feature-tags))) + (multiple-value-bind (v hit) (gethash key cache) + (when hit (return-from otl-lookup-indices (values (car v) (cdr v)))) + (multiple-value-bind (llist idxs) (%otl-lookup-indices font tag feature-tags) + (setf (gethash key cache) (cons llist idxs)) + (values llist idxs))))) + +(defun %otl-lookup-indices (font tag feature-tags) + "Uncached core of OTL-LOOKUP-INDICES." (let ((base (font-table font tag))) - (unless base (return-from otl-lookup-indices (values nil nil))) + (unless base (return-from %otl-lookup-indices (values nil nil))) (let* ((d (font-data font)) (slist (+ base (u16 d (+ base 4)))) (flist (+ base (u16 d (+ base 6)))) @@ -151,7 +163,7 @@ (cond ((string= stag "latn") (setf script-off so)) ((string= stag "DFLT") (setf dflt so))))) (let ((script (or script-off dflt first-off))) - (unless script (return-from otl-lookup-indices (values llist nil))) + (unless script (return-from %otl-lookup-indices (values llist nil))) (let* ((dls (u16 d script)) (langsys (if (plusp dls) (+ script dls) nil)) (lookup-set (make-hash-table :test 'eql))) diff --git a/src/raster.lisp b/src/raster.lisp index a34a038..c0287ec 100644 --- a/src/raster.lisp +++ b/src/raster.lisp @@ -151,28 +151,66 @@ (setf (aref cov (+ row x)) (min 1d0 (abs acc)))))) (values cov w h)))))) +(defparameter *hinting* nil + "TrueType bytecode hinting for RASTERIZE-GLYPH. NIL: off (geometric outline, +sub-pixel positioned). T: grid-fit at every ppem. A number N: grid-fit only when +the rounded ppem <= N — large text doesn't need it and skips the interpreter cost. +When a glyph is hinted its outline is grid-fit (crisp stems/baseline) and placed on +the integer pixel grid (no sub-pixel x-shift); the advance stays geometric so +painted widths still match MEASURE-TEXT-WIDTH.") + +(defvar *hinted-segments-fn* nil + "Installed by the hinting layer (hint.lisp): (FONT GID IPPEM) -> hinted segment +lists in PX, :EMPTY for an outline-less glyph, or NIL when not hintable (caller +falls back to the geometric path). A hook so raster.lisp needn't depend on the +later-loaded interpreter.") + +(defun %outline-bbox (contours) + "Return (values minx miny maxx maxy) over all points of a segment-list outline." + (let ((minx 1d30) (miny 1d30) (maxx -1d30) (maxy -1d30)) + (dolist (c contours (values minx miny maxx maxy)) + (dolist (seg c) + (loop for (x y) on (cdr seg) by #'cddr do + (setf minx (min minx (float x 1d0)) maxx (max maxx (float x 1d0)) + miny (min miny (float y 1d0)) maxy (max maxy (float y 1d0)))))))) + (defun rasterize-glyph (font gid ppem &key (subpixel 0d0) variation) "Rasterize GID at PPEM px/em. Returns (values coverage w h left top advance) where (left,top) is the bitmap origin relative to the pen (px, y-down) and - ADVANCE is the horizontal advance in px. SUBPIXEL in [0,1) shifts x." + ADVANCE is the horizontal advance in px. SUBPIXEL in [0,1) shifts x. + When *HINTING* applies, the outline is grid-fit and placed on the pixel grid." (let* ((upem (font-units-per-em font)) (scale (/ (float ppem 1d0) upem)) - (outline (glyph-outline font gid :variation variation))) - (let ((adv (advance-at font gid variation))) ; hmtx + HVAR/gvar advance delta - (if (null outline) - (values nil 0 0 0 0 (* adv scale)) - ;; bbox in font units - (let ((minx 1d30) (miny 1d30) (maxx -1d30) (maxy -1d30)) - (dolist (c outline) - (dolist (seg c) - (loop for (x y) on (cdr seg) by #'cddr do - (setf minx (min minx x) maxx (max maxx x) miny (min miny y) maxy (max maxy y))))) - (multiple-value-bind (cov w h) - (rasterize-outline outline scale :dx subpixel :origin-x minx :origin-y maxy) - (values cov w h - (floor (* minx scale)) ; left bearing in px - (- (ceiling (* maxy scale))) ; top above baseline (y-down) - (* adv scale)))))))) + (adv (advance-at font gid variation)) ; hmtx + HVAR/gvar advance delta + (ippem (round ppem))) + ;; hinted outlines come back already in px (grid-fit). Rasterize at scale 1 with + ;; the sub-pixel x-shift, and advance by the fractional (geometric) advance: the + ;; grid-fit is what matters vertically (crisp stems/baseline), while horizontally + ;; the glyph stays sub-pixel positioned so inter-glyph spacing is smooth like the + ;; browser — integer advances quantize spacing and read as bad kerning. + (let ((hinted (and *hinting* *hinted-segments-fn* (null variation) (plusp ippem) + (or (eq *hinting* t) (and (integerp *hinting*) (<= ippem *hinting*))) + (funcall *hinted-segments-fn* font gid ippem)))) + (cond + ((eq hinted :empty) (values nil 0 0 0 0 (* adv scale))) + (hinted ; grid-fit shape, sub-pixel x position + (multiple-value-bind (minx miny maxx maxy) (%outline-bbox hinted) + (declare (ignore miny maxx)) + (multiple-value-bind (cov w h) + (rasterize-outline hinted 1d0 :dx subpixel :origin-x minx :origin-y maxy) + (values cov w h (floor minx) (- (ceiling maxy)) (* adv scale))))) + (t ; geometric path + (let ((outline (glyph-outline font gid :variation variation))) + (if (null outline) + (values nil 0 0 0 0 (* adv scale)) + (multiple-value-bind (minx miny maxx maxy) (%outline-bbox outline) + (declare (ignore miny maxx)) + (multiple-value-bind (cov w h) + (rasterize-outline outline scale :dx subpixel :origin-x minx :origin-y maxy) + (values cov w h + (floor (* minx scale)) ; left bearing in px + (- (ceiling (* maxy scale))) ; top above baseline (y-down) + (* adv scale))))))))))) (defun glyph-advance (font gid) "Horizontal advance + lsb (font units) from hmtx."