From a906fb1c134a2114e6c5b3325c3c84435ea89b26 Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 11:09:20 -0400 Subject: [PATCH 01/36] blend: optional gamma-space glyph compositing (*blend-gamma*) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit blend-coverage composites in linear light — correct for images/gradients, but it leaves dark-on-light TEXT edges washed-out (~188 vs 127 grey at half coverage), much lighter than a browser. Browsers blend glyphs in an intermediate gamma (between linear ~2.2 and naive sRGB 1.0). Add *blend-gamma*: NIL keeps the exact sRGB-LUT linear path (default — image/gradient rendering byte-unchanged); a number G composites in power-G space so a text consumer can match browser weight. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/blend.lisp | 40 ++++++++++++++++++++++++++++++++-------- 1 file changed, 32 insertions(+), 8 deletions(-) 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))) From 5b9a303976c9687eb7d093a720153a1d484658ba Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 13:40:34 -0400 Subject: [PATCH 02/36] hinting: plan doc + Phase-0 FreeType point-oracle Start of TrueType bytecode hinting (docs/HINTING.md): interpret the font's own instructions to grid-fit small text, validated at the point level against FreeType. inspect/hint-oracle.py dumps FreeType's hinted outline (native bytecode hinter, classic interpreter v35, F26Dot6 points per contour) as ground truth. Verified: LiberationSans 'l'@12px hints to a ~1px stem, y 0.00->9.00. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- docs/HINTING.md | 68 ++++++++++++++++++++++++++++++++++++++++++ inspect/hint-oracle.py | 41 +++++++++++++++++++++++++ 2 files changed, 109 insertions(+) create mode 100644 docs/HINTING.md create mode 100644 inspect/hint-oracle.py diff --git a/docs/HINTING.md b/docs/HINTING.md new file mode 100644 index 0000000..d490d4d --- /dev/null +++ b/docs/HINTING.md @@ -0,0 +1,68 @@ +# 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. 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)})) From b716c3a5859cf4c48f3cf3e444602f9c648b434d Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 13:52:10 -0400 Subject: [PATCH 03/36] =?UTF-8?q?hinting:=20interpreter=20core=20=E2=80=94?= =?UTF-8?q?=20runs=20Liberation=20fpgm+prep=20clean=20(WIP)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The TrueType bytecode VM: F26.6/F2.14 fixed point, the rounding engine, graphics state, stack/storage/CVT, ~85 opcodes (push, arith/logic, flow with IF/ELSE/EIF + JMPR/JROT/JROF, FDEF/CALL/LOOPCALL, storage, CVT r/w, GETINFO, ROUND family, DELTAC/DELTAP, all the GS + rounding-state setters). make-hinter sizes stack/ storage from maxp and scales the CVT to the target ppem. Milestone: runs LiberationSans-Regular's full fpgm (71 functions) AND prep at 12px with a balanced stack and no unimplemented opcode — the fixed-point core is proven on real font programs. Still WIP: the glyph pipeline (zones, phantom points) and the point-mover opcodes (MDAP/MIAP/MDRP/MIRP/IP/IUP/…) needed to hint an actual glyph and diff it against the FreeType point-oracle. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- scribe.asd | 1 + src/hint.lisp | 327 ++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 328 insertions(+) create mode 100644 src/hint.lisp 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/hint.lisp b/src/hint.lisp new file mode 100644 index 0000000..dcfbc5a --- /dev/null +++ b/src/hint.lisp @@ -0,0 +1,327 @@ +;;;; 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)))))))) + +;;; ---- 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)) + +(defun run-fpgm-prep (h) + "Run the font program (defines functions) then the control-value program (sets +graphics state / CVT for this ppem)." + (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)))) + +;;; ------------------------------------------------------------- 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." + (if (zerop c) 0 + (let* ((s (if (minusp (* a b)) -1 1)) (n (+ (abs (* a b)) (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) (+ (mul2.14 ax bx) (mul2.14 ay by))) + +;;; ------------------------------------------------------------- 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 + (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) + +(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, preserving sign and (per +spec) never rounding a nonzero distance to zero." + (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 (if (zerop r) per 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." + (let* ((fx (hs-fx h)) (fy (hs-fy h)) + ;; distance along freedom vector so its projection == DIST + (fdotp (dot14 fx fy (hs-px h) (hs-py h)))) + (unless (zerop fdotp) + (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 ---- +(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 (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 (muldiv a b 64)))) ; DIV +(def-op #x63 (h) (let ((b (hpop h)) (a (hpop h))) (hpush h (muldiv a b 64)))) ; MUL +(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)))))) +(defun do-deltac (h base-off) + (let ((n (hpop h)) (base (+ (hs-delta-base h) base-off))) + (dotimes (i n) + (let ((arg (hpop h)) (idx (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 ((arg (hpop h)) (pt (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] +(def-op #x02 (h) (setf (hs-px h) 16384 (hs-py h) 0 (hs-dpx h) 16384 (hs-dpy h) 0)) ; SPVTCA[x] +(def-op #x03 (h) (setf (hs-px h) 0 (hs-py h) 16384 (hs-dpx h) 0 (hs-dpy h) 16384)) ; SPVTCA[y] +(def-op #x04 (h) (setf (hs-fx h) 16384 (hs-fy h) 0)) ; SFVTCA[x] +(def-op #x05 (h) (setf (hs-fx h) 0 (hs-fy h) 16384)) ; SFVTCA[y] +(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 64)) ; RUTG (up) +(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 + (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 From fd662fe7b89428b7424b9605fec36af1aac24608 Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 15:25:04 -0400 Subject: [PATCH 04/36] =?UTF-8?q?hinting:=20glyph=20pipeline=20+=20point-m?= =?UTF-8?q?overs=20=E2=80=94=20hints=20'l'=20to=20within=20~0.1px=20(WIP)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Full end-to-end hinting: load-glyph-zone scales a glyph's points into zone 1, appends the 4 phantom points (origin/advance/top from hmtx+bbox), sets up the twilight zone; hint-glyph resets per-glyph graphics state, runs the glyph program, and extracts the moved points. Point-movers implemented: MDAP, MIAP, MDRP/MIRP (all 32 flag variants each), IP, IUP[x/y], SHP, ALIGNRP, GC, MD, SCFS, CINDEX/MINDEX, the SPVFS/SFVFS/GPV/GFV vector ops, and hmtx-metrics. Milestone: the interpreter runs LiberationSans 'l' at 12px end-to-end and produces a recognizable grid-fit stem — x within ~0.1px of FreeType, stem HEIGHT exact (y 0->9). Remaining to bit-exact: the IUP interpolation (one baseline point lands wrong) and the sub-pixel cut-in/rounding details. This proves the approach: a from-scratch fixed-point TT interpreter hints real glyphs; the rest is oracle-driven debugging. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 215 +++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 214 insertions(+), 1 deletion(-) diff --git a/src/hint.lisp b/src/hint.lisp index dcfbc5a..7b18cc1 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -35,6 +35,13 @@ (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." @@ -90,7 +97,9 @@ graphics state / CVT for this ppem)." (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) + 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)) @@ -325,3 +334,207 @@ stop the skip at depth 0 (0x59 EIF, and optionally 0x1B ELSE)." (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 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))) + (when (>= ncont 0) + (let* ((p (+ g 10 (* 2 ncont))) (ilen (u16 d p))) + (when (plusp ilen) (subseq d (+ p 2) (+ p 2 ilen))))))))) + +;;; ================================================================ glyph hinting +;;; ---- coordinate helpers (all F26.6) ---- +(declaim (inline gc-cur gc-org)) +(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)))) +(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." + (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)) (ncont (s16 d g))) + (when (< ncont 0) (return-from load-glyph-zone :composite)) + (multiple-value-bind (xs ys flags endpts) (%simple-glyph d g ncont) + (let* ((np (if (zerop ncont) 0 (1+ (aref endpts (1- ncont))))) + (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)) + (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) + (let ((sx (hscale h (aref xs i))) (sy (hscale h (aref ys i)))) + (setf (aref cx i) sx (aref ox i) sx (aref cy i) sy (aref oy i) sy + (aref on i) (if (logbitp 0 (aref flags i)) 1 0)))) + ;; 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) (setf (aref cx i) x (aref ox i) x (aref cy i) y (aref oy i) y (aref on i) 1))) + (setp np p1x 0) (setp (+ np 1) p2x 0) (setp (+ np 2) 0 p3y) (setp (+ np 3) 0 0)))) + (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 :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) + :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 (keep prep's round-state/cut-ins; reset the rest)." + (setf (hs-fx h) 16384 (hs-fy h) 0 (hs-px h) 16384 (hs-py h) 0 (hs-dpx h) 16384 (hs-dpy 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)) + +(defun hint-glyph (h gid) + "Grid-fit GID at the hinter's ppem; return the hinted contours as lists of +(x y on) in px (or NIL for empty / :composite for unsupported composites)." + (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 + (let* ((z (zone h 1)) (ends (hs-glyph-ends h)) (out '()) (start 0)) + (dotimes (c (length ends) (nreverse out)) + (let ((end (aref ends c)) (pts '())) + (loop for i from start to end do + (push (list (/ (aref (hz-cur-x z) 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))))))) + +;;; ---- 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 mdrp (h op) + (let* ((p (hpop h)) (org (- (gc-org h (hs-zp1 h) p) (gc-org h (hs-zp0 h) (hs-rp0 h)))) + (dist (if (logbitp 3 op) (hround h org) org))) + (when (logbitp 2 op) ; min distance + (when (< (abs dist) (hs-min-dist h)) (setf dist (if (minusp org) (- (hs-min-dist h)) (hs-min-dist h))))) + (let ((cur-rp0 (gc-cur h (hs-zp0 h) (hs-rp0 h)))) + (move h (hs-zp1 h) p (- (+ cur-rp0 dist) (gc-cur h (hs-zp1 h) p)))) + (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) + (let* ((n (hpop h)) (p (hpop h)) (cvt (aref (hs-cvt h) n)) + (org (- (gc-org h (hs-zp1 h) p) (gc-org h (hs-zp0 h) (hs-rp0 h))))) + (when (/= (hs-zp1 h) 0) ; cut-in (non-twilight) + (when (> (abs (- cvt org)) (hs-cvt-cut-in h)) (setf cvt org))) + (let ((dist (if (logbitp 3 op) (hround h cvt) cvt))) + (when (minusp org) (setf dist (- (abs dist))) ) ; sign follows original + (unless (minusp org) (setf dist (abs dist))) + (when (logbitp 2 op) + (when (< (abs dist) (hs-min-dist h)) (setf dist (if (minusp org) (- (hs-min-dist h)) (hs-min-dist h))))) + (let ((cur-rp0 (gc-cur h (hs-zp0 h) (hs-rp0 h)))) + (move h (hs-zp1 h) p (- (+ cur-rp0 dist) (gc-cur h (hs-zp1 h) p)))) + (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 + +(def-op #x39 (h) ; IP + (let* ((ra (hs-rp1 h)) (rb (hs-rp2 h)) + (oa (gc-org h (hs-zp0 h) ra)) (ob (gc-org h (hs-zp1 h) rb)) + (ca (gc-cur h (hs-zp0 h) ra)) (cb (gc-cur h (hs-zp1 h) rb))) + (dotimes (k (hs-loop h)) + (let* ((p (hpop h)) (op (gc-org h (hs-zp2 h) p)) (cp (gc-cur h (hs-zp2 h) p)) + (new (if (= oa ob) (+ ca (- op oa)) (+ ca (muldiv (- op oa) (- cb ca) (- ob oa)))))) + (move h (hs-zp2 h) p (- new cp)))) + (setf (hs-loop h) 1))) + +(defun shp (h op) ; SHP[a] + (multiple-value-bind (rp zref) (if (logbitp 0 op) (values (hs-rp1 h) (hs-zp0 h)) (values (hs-rp2 h) (hs-zp1 h))) + (let ((disp (- (gc-cur h zref rp) (gc-org h zref rp)))) + (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)) + +(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 (- (gc-cur h (hs-zp0 h) rp0) (gc-cur h (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 (- (gc-cur h (hs-zp0 h) a) (gc-cur h (hs-zp1 h) b))))) +(def-op #x4A (h) (let ((b (hpop h)) (a (hpop h))) ; MD[1] original distance + (hpush h (- (gc-org h (hs-zp0 h) a) (gc-org h (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) + "Interpolate untouched (in TOUCHBIT) points of each contour along CUR/ORG accessors." + (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 + (let ((oa (funcall org a)) (ob (funcall org b)) (oi (funcall org i)) + (ca (funcall cur a)) (cb (funcall cur b))) + (funcall cur i + (cond ((and (<= (min oa ob) oi) (<= oi (max oa ob))) + (if (= oa ob) ca (+ ca (muldiv (- oi oa) (- cb ca) (- ob oa))))) + ((<= oi (min oa ob)) (+ oi (- (if (< oa ob) ca cb) (if (< oa ob) oa ob)))) + (t (+ oi (- (if (> oa ob) ca cb) (if (> oa ob) oa ob))))))))) + (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))))) ; 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)))))) ; IUP[x] + +;;; ---- vector setters that need points (SPVTL/SFVTL) + misc ---- +(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))) From 79112b8dd41b025787d8d1c5fd706ca0b72dfca7 Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 16:04:41 -0400 Subject: [PATCH 05/36] =?UTF-8?q?hinting:=20'l'=20bit-exact=20vs=20FreeTyp?= =?UTF-8?q?e=20=E2=80=94=20three=20fixed-point=20bugs=20fixed=20(M1)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Driving M1 to bit-exact. Three bugs found via point-level diff against the FreeType oracle: 1. muldiv (FT_MulDiv) ignored the divisor's sign — result sign is sign(a*b*c), not sign(a*b). Corrupted every projected interpolation (IUP put a baseline point at y=17). 2. hround applied the "don't collapse to zero" rule to a ZERO input, so round(0) returned 1px — the baseline landed at y=1. That rule is min-distance (MDRP/MIRP), not the round function. 3. Phantom points weren't grid-fit: the advance point stayed at 2.67px, so IP couldn't shift a stem when the advance rounds to 3.00. FT_PIX_ROUND the phantoms' CURRENT position (ORG stays unrounded for correct measurement). Result: LiberationSans 'l' @12px hints BIT-EXACT vs FreeType — (0.91,0)(0.91,9)(1.95,9)(1.95,0), matching the oracle to the F26.6 unit. This proves the whole pipeline: fixed-point VM + phantom points + MIAP/IP/SHP/IUP. Other glyphs are within ~1px; the residual is cap/x-height blue-zone snapping in the MDAP path (FT rounds an 8.25px cap up to 9 via the font's alignment zones), the next debug target. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/src/hint.lisp b/src/hint.lisp index 7b18cc1..a7c709b 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -70,9 +70,11 @@ graphics state / CVT for this ppem)." (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." + "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* ((s (if (minusp (* a b)) -1 1)) (n (+ (abs (* a b)) (floor (abs c) 2)))) + (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 @@ -112,14 +114,15 @@ graphics state / CVT for this ppem)." ;;; ---- rounding engine (round-state -> round an F26.6 distance) ---- (defun hround (h dist) - "Round F26.6 DIST per the graphics-state round mode, preserving sign and (per -spec) never rounding a nonzero distance to zero." + "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 (if (zerop r) per r))))) + (* 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)) @@ -380,7 +383,12 @@ stop the skip at depth 0 (0x59 EIF, and optionally 0x1B ELSE)." (let* ((p1x (hscale h (- xmin lsb))) (p2x (hscale h (+ (- xmin lsb) adv))) (p3y (hscale h ymax))) (flet ((setp (i x y) (setf (aref cx i) x (aref ox i) x (aref cy i) y (aref oy i) y (aref on i) 1))) - (setp np p1x 0) (setp (+ np 1) p2x 0) (setp (+ np 2) 0 p3y) (setp (+ np 3) 0 0)))) + (setp np p1x 0) (setp (+ np 1) p2x 0) (setp (+ np 2) 0 p3y) (setp (+ np 3) 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 :on on :touch tc)) (mtw (max 4 (1+ (or (getf (parse-maxp1 font) :max-twilight) 4))))) From 370156964c01054139972c8313fb097bbfd76b76 Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 16:12:36 -0400 Subject: [PATCH 06/36] hinting: record M1 status in plan doc (l bit-exact; blue-zone the open item) Bank the checkpoint: P0-P3 done, M1 proof achieved (l bit-exact vs FreeType), remaining glyphs ~1px off pending cap/x-height blue-zone snapping. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- docs/HINTING.md | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/docs/HINTING.md b/docs/HINTING.md index d490d4d..7d418be 100644 --- a/docs/HINTING.md +++ b/docs/HINTING.md @@ -66,3 +66,19 @@ opcode. (Verified: `l`@12px → stem y 0.00→9.00, ~1px wide.) 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 remaining**: `i/H/o/…` within ~1px. Root cause isolated: **cap/x-height + blue-zone snapping** — FT rounds `H`'s cap (funit 1409 → 8.25px) UP to 9 via the + alignment zones; our MDAP path rounds to nearest (8). All x-hinting is already + exact. Next: crack the blue-zone rounding (likely fixes i/H/o/n/e together), + then M2/M3 per above. +- Comparison harness: `/tmp/weftdump.lisp` + oracle diff (per-point, any glyphs). From 3b3e1893853f5cbbd04d601bd098abd3ba818aed Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 16:27:56 -0400 Subject: [PATCH 07/36] hinting: close M1 (l bit-exact), open M2 with the cap-CVT diagnosis MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit M1 closed on the proof: LiberationSans 'l' hints bit-exact vs FreeType. M2's first task is sharply scoped: H's cap MIAPs to cvt[3]=528 (8.25px)->rounds to 8, but FreeType yields 9, so its post-prep CVT differs — a prep-correctness issue (alignment-zone CVT adjustment), not a mover bug (all x-hinting is already exact). Next: diff FreeType's post-prep CVT against ours at 12px. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- docs/HINTING.md | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/docs/HINTING.md b/docs/HINTING.md index 7d418be..ea7180f 100644 --- a/docs/HINTING.md +++ b/docs/HINTING.md @@ -76,9 +76,18 @@ Bit-exact fixed-point rounding (engine compensation, SROUND); DELTA exceptions - **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 remaining**: `i/H/o/…` within ~1px. Root cause isolated: **cap/x-height - blue-zone snapping** — FT rounds `H`'s cap (funit 1409 → 8.25px) UP to 9 via the - alignment zones; our MDAP path rounds to nearest (8). All x-hinting is already - exact. Next: crack the blue-zone rounding (likely fixes i/H/o/n/e together), - then M2/M3 per above. +- **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 — opening task (sharp diagnosis) +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. From c516ab7f1e5642b5e555f72f223df5a0e4bb9f15 Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 17:09:00 -0400 Subject: [PATCH 08/36] hinting: vendor the point-diff harness (hint-weftdump + hint-diff) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Durable oracle-diff tooling for M2 (out of /tmp): hint-weftdump.lisp dumps weft's hinted F26.6 points (or the post-prep CVT with "cvt"); hint-diff.py runs it beside the FreeType oracle and reports EXACT / max-Δ per glyph. Bit-exact gate for the interpreter work. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- inspect/hint-diff.py | 26 ++++++++++++++++++++++++++ inspect/hint-weftdump.lisp | 21 +++++++++++++++++++++ 2 files changed, 47 insertions(+) create mode 100755 inspect/hint-diff.py create mode 100644 inspect/hint-weftdump.lisp 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-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)))))) From ac43c91d65fd57c536a04b789578fa8594708d95 Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 17:35:13 -0400 Subject: [PATCH 09/36] =?UTF-8?q?hinting:=20fix=20RUTG=20ceil=20+=20DELTAC?= =?UTF-8?q?/DELTAP=20pair=20order=20=E2=80=94=20post-prep=20CVT=20now=20bi?= =?UTF-8?q?t-exact?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Two fixed-point/opcode bugs in prep were pushing the cap/x-height CVTs (and hence H/o/i/n/e/a) off by up to a full pixel vertically: 1. RUTG (round-up-to-grid) used threshold=64 in the super-round formula, so hround(0) returned 64 instead of 0 (an exact-grid value wrongly gained a pixel). Round-up = ceil, whose super-round threshold is period-1 = 63. 2. DELTAC/DELTAP popped the exception spec before the cvt/point index. Per the TrueType spec the stack after n is "... arg1 idx1 n" with the index nearer the top, so the index must be popped first. With the swap every per-ppem exception targeted the wrong entry / never matched ppem, so the cap-height and x-height CVT deltas at 12px never fired. ('l' stayed exact because no DELTA fires for it at 12px.) Post-prep CVT for LiberationSans @12px now matches FreeType's classic v35 interpreter bit-for-bit (verified by reading the scaled cvt array out of TT_Size via /proc/self/mem). Point error on the cap group collapses: H 64->4, i 64->1, o 78->14, n 76->12, e 78->14, a 77->19 (F26.6). 'l' still exact; scribe suite still 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/hint.lisp b/src/hint.lisp index a7c709b..66ae7aa 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -233,16 +233,18 @@ rule is min-distance, applied by MDRP/MIRP — not here.)" (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 ((arg (hpop h)) (idx (hpop h))) + (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 ((arg (hpop h)) (pt (hpop h))) + (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 @@ -287,7 +289,7 @@ rule is min-distance, applied by MDRP/MIRP — not here.)" (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 64)) ; RUTG (up) +(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 ---- From 9dd226e8ce5af20fedbe90798c8bec2cae30e8d1 Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 17:47:16 -0400 Subject: [PATCH 10/36] hinting: IP uses orus (font units) + fix MDRP/MIRP round/min-dist bits Two more systematic errors that kept every glyph ~1 subpixel off: 1. IP measured original distances from the scaled `org` coords, losing precision (font-unit 136 vs 137 both scale to 51 @12px), so interpolated stems landed a unit off. FreeType's IP ratio uses `orus` (original UNSCALED font-unit coords). Added orus-x/orus-y to the zone, populate for real + phantom points, and use them (dual-projected) for IP's range/dist ratio. 2. MDRP/MIRP had the round and keep-minimum-distance flag bits swapped: the spec (and FreeType) use bit2 (0x04)=round, bit3 (0x08)=min-distance. We used bit3 for round, so e.g. the i-dot MDRP[01001] (min-dist, no round) was wrongly rounding the dot height (511->512). LiberationSans @12px: l H i now bit-exact; o n e a down to 1/64px. Suite 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 38 ++++++++++++++++++++++++++------------ 1 file changed, 26 insertions(+), 12 deletions(-) diff --git a/src/hint.lisp b/src/hint.lisp index 66ae7aa..7f98792 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -84,6 +84,7 @@ result sign is sign(a*b*c): dividing by a negative c flips it." (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) @@ -352,9 +353,12 @@ stop the skip at depth 0 (0x59 EIF, and optionally 0x1B ELSE)." ;;; ================================================================ glyph hinting ;;; ---- coordinate helpers (all F26.6) ---- -(declaim (inline gc-cur gc-org)) +(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)))) (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))) @@ -374,29 +378,34 @@ stop the skip at depth 0 (0x59 EIF, and optionally 0x1B ELSE)." (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) (let ((sx (hscale h (aref xs i))) (sy (hscale h (aref ys i)))) (setf (aref cx i) sx (aref ox i) sx (aref cy i) sy (aref oy i) sy + (aref ux i) (aref xs i) (aref uy i) (aref ys i) ; unscaled (font units) (aref on i) (if (logbitp 0 (aref flags i)) 1 0)))) ;; 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) (setf (aref cx i) x (aref ox i) x (aref cy i) y (aref oy i) y (aref on i) 1))) - (setp np p1x 0) (setp (+ np 1) p2x 0) (setp (+ np 2) 0 p3y) (setp (+ np 3) 0 0)) + (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 :on on :touch tc)) + (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)))))) @@ -444,9 +453,10 @@ stop the skip at depth 0 (0x59 EIF, and optionally 0x1B ELSE)." (def-op #x3F (h) (miap h t)) ; MIAP[1] (defun mdrp (h op) + ;; flags: bit2 (0x04) round, bit3 (0x08) keep-min-distance, bit4 (0x10) set rp0. (let* ((p (hpop h)) (org (- (gc-org h (hs-zp1 h) p) (gc-org h (hs-zp0 h) (hs-rp0 h)))) - (dist (if (logbitp 3 op) (hround h org) org))) - (when (logbitp 2 op) ; min distance + (dist (if (logbitp 2 op) (hround h org) org))) + (when (logbitp 3 op) ; min distance (when (< (abs dist) (hs-min-dist h)) (setf dist (if (minusp org) (- (hs-min-dist h)) (hs-min-dist h))))) (let ((cur-rp0 (gc-cur h (hs-zp0 h) (hs-rp0 h)))) (move h (hs-zp1 h) p (- (+ cur-rp0 dist) (gc-cur h (hs-zp1 h) p)))) @@ -458,10 +468,10 @@ stop the skip at depth 0 (0x59 EIF, and optionally 0x1B ELSE)." (org (- (gc-org h (hs-zp1 h) p) (gc-org h (hs-zp0 h) (hs-rp0 h))))) (when (/= (hs-zp1 h) 0) ; cut-in (non-twilight) (when (> (abs (- cvt org)) (hs-cvt-cut-in h)) (setf cvt org))) - (let ((dist (if (logbitp 3 op) (hround h cvt) cvt))) + (let ((dist (if (logbitp 2 op) (hround h cvt) cvt))) ; bit2 round, bit3 min-dist (when (minusp org) (setf dist (- (abs dist))) ) ; sign follows original (unless (minusp org) (setf dist (abs dist))) - (when (logbitp 2 op) + (when (logbitp 3 op) (when (< (abs dist) (hs-min-dist h)) (setf dist (if (minusp org) (- (hs-min-dist h)) (hs-min-dist h))))) (let ((cur-rp0 (gc-cur h (hs-zp0 h) (hs-rp0 h)))) (move h (hs-zp1 h) p (- (+ cur-rp0 dist) (gc-cur h (hs-zp1 h) p)))) @@ -469,12 +479,16 @@ stop the skip at depth 0 (0x59 EIF, and optionally 0x1B ELSE)." (dotimes (i 32) (setf (aref *ops* (+ #xE0 i)) (lambda (h op) (mirp h op)))) ; MIRP (def-op #x39 (h) ; IP + ;; original ranges/distances use ORUS (font units) like FreeType, so the ratio + ;; keeps full precision; current uses the scaled cur coords. Base = rp1. (let* ((ra (hs-rp1 h)) (rb (hs-rp2 h)) - (oa (gc-org h (hs-zp0 h) ra)) (ob (gc-org h (hs-zp1 h) rb)) - (ca (gc-cur h (hs-zp0 h) ra)) (cb (gc-cur h (hs-zp1 h) rb))) + (oa (gc-orus h (hs-zp0 h) ra)) (ob (gc-orus h (hs-zp1 h) rb)) + (ca (gc-cur h (hs-zp0 h) ra)) (cb (gc-cur h (hs-zp1 h) rb)) + (old-range (- ob oa)) (cur-range (- cb ca))) (dotimes (k (hs-loop h)) - (let* ((p (hpop h)) (op (gc-org h (hs-zp2 h) p)) (cp (gc-cur h (hs-zp2 h) p)) - (new (if (= oa ob) (+ ca (- op oa)) (+ ca (muldiv (- op oa) (- cb ca) (- ob oa)))))) + (let* ((p (hpop h)) (op (gc-orus h (hs-zp2 h) p)) (cp (gc-cur h (hs-zp2 h) p)) + (org-dist (- op oa)) + (new (+ ca (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))) From 49435f47985d960404243bec5458017605614e84 Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 17:51:12 -0400 Subject: [PATCH 11/36] hinting: IUP interior interpolation uses orus (font units) FreeType's IUP interpolates untouched interior points using the orus (original font-unit) ratio, not the scaled org, so sub-pixel spacing is preserved; points outside the touched span still shift rigidly by the nearest touched delta (scaled org). Switched iup-axis to take an orus accessor and use it for the interior case + range test. LiberationSans @12px: o, n now bit-exact. Printable-ASCII exact counts jump to ppem7 69/94, ppem10 43/94, ppem12 26/94, ppem16 25/94. Suite 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/src/hint.lisp b/src/hint.lisp index 7f98792..dd4c6bf 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -515,8 +515,10 @@ stop the skip at depth 0 (0x59 EIF, and optionally 0x1B ELSE)." (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) - "Interpolate untouched (in TOUCHBIT) points of each contour along CUR/ORG accessors." +(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)))) @@ -527,13 +529,14 @@ stop the skip at depth 0 (0x59 EIF, and optionally 0x1B ELSE)." (setf touched (nreverse touched)) (when touched (flet ((interp (i a b) ; move untouched i between touched a,b - (let ((oa (funcall org a)) (ob (funcall org b)) (oi (funcall org i)) + (let ((ua (funcall orus a)) (ub (funcall orus b)) (ui (funcall orus i)) (ca (funcall cur a)) (cb (funcall cur b))) (funcall cur i - (cond ((and (<= (min oa ob) oi) (<= oi (max oa ob))) - (if (= oa ob) ca (+ ca (muldiv (- oi oa) (- cb ca) (- ob oa))))) - ((<= oi (min oa ob)) (+ oi (- (if (< oa ob) ca cb) (if (< oa ob) oa ob)))) - (t (+ oi (- (if (> oa ob) ca cb) (if (> oa ob) oa ob))))))))) + (cond ((and (<= (min ua ub) ui) (<= ui (max ua ub))) + (if (= ua ub) ca (+ ca (muldiv (- ui ua) (- cb ca) (- ub ua))))) + ((<= ui (min ua ub)) + (+ (funcall org i) (- (if (< ua ub) ca cb) (funcall org (if (< ua ub) a b))))) + (t (+ (funcall org i) (- (if (> ua ub) ca cb) (funcall org (if (> ua ub) a b)))))))))) (if (= 1 (length touched)) ;; single touched point: shift whole contour by its delta (let* ((a (car touched)) (delta (- (funcall cur a) (funcall org a)))) @@ -549,9 +552,11 @@ stop the skip at depth 0 (0x59 EIF, and optionally 0x1B ELSE)." (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))))) ; IUP[y] + (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)))))) ; IUP[x] + (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 ---- (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 From efc4e910d55a7e63bb80021b4e8a1d124d538c3b Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 17:54:32 -0400 Subject: [PATCH 12/36] hinting: restore full post-prep graphics state before each glyph reset-glyph-gs only reset the vectors/rp/zp/loop, leaking a glyph program's round mode / SMD / SDB / cut-in changes into the next glyph (e.g. 'c' after 'b' went 0.95px off). Snapshot the whole GS after prep and restore it before every glyph, matching FreeType. 'c' and 'g' fixed. ppem12 26->31/94 exact. 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 28 +++++++++++++++++++++++----- 1 file changed, 23 insertions(+), 5 deletions(-) diff --git a/src/hint.lisp b/src/hint.lisp index dd4c6bf..5336be3 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -59,11 +59,27 @@ scaled to F26.6). Call RUN-FPGM-PREP before hinting glyphs." (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)." +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)))) + (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). @@ -411,9 +427,11 @@ stop the skip at depth 0 (0x59 EIF, and optionally 0x1B ELSE)." t)))))) (defun reset-glyph-gs (h) - "Per-glyph graphics-state reset (keep prep's round-state/cut-ins; reset the rest)." - (setf (hs-fx h) 16384 (hs-fy h) 0 (hs-px h) 16384 (hs-py h) 0 (hs-dpx h) 16384 (hs-dpy 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)) + "Per-glyph graphics-state reset: restore the whole post-prep GS (FreeType does the +same), so no glyph program's state changes leak into the next glyph." + (if (hs-gs-default h) (restore-gs h) + (setf (hs-fx h) 16384 (hs-fy h) 0 (hs-px h) 16384 (hs-py h) 0 (hs-dpx h) 16384 (hs-dpy 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))) (defun hint-glyph (h gid) "Grid-fit GID at the hinter's ppem; return the hinted contours as lists of From c1caada00d8a839d9c6a50c6032dea94a7f65b54 Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 18:00:26 -0400 Subject: [PATCH 13/36] hinting: MDRP/MIRP measure original distance from orus (scaled once) FreeType's MDRP/MIRP compute the original distance by scaling the ORUS (font-unit) difference between the two points once (MulFix), not by subtracting two independently-rounded scaled coords. The latter double-rounds and lands ~1/64px off on unrounded (MDRP no-round / min-distance) moves. Added orus-dist and use it for both movers (twilight still falls back to scaled org). ppem exact counts: 7 70->78, 10 47->73, 12 31->54, 16 28->38 (of 94). Suite 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/src/hint.lisp b/src/hint.lisp index 5336be3..c67b472 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -375,6 +375,16 @@ stop the skip at depth 0 (0x59 EIF, and optionally 0x1B ELSE)." ;; 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)))) +(defun orus-dist (h zp1 p zp0 rp0) + "Original projected distance (p relative to rp0) as FreeType's MDRP/MIRP measure it: +scale the ORUS (font-unit) difference ONCE, then dual-project — avoids the extra +rounding of subtracting two independently-scaled coords. Twilight falls back to org." + (if (or (zerop zp0) (zerop zp1)) + (- (gc-org h zp1 p) (gc-org h zp0 rp0)) + (let* ((z1 (zone h zp1)) (z0 (zone h zp0)) + (dx (- (aref (hz-orus-x z1) p) (aref (hz-orus-x z0) rp0))) + (dy (- (aref (hz-orus-y z1) p) (aref (hz-orus-y z0) rp0)))) + (dot14 (hscale h dx) (hscale h dy) (hs-dpx h) (hs-dpy h))))) (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))) @@ -472,7 +482,7 @@ same), so no glyph program's state changes leak into the next glyph." (defun mdrp (h op) ;; flags: bit2 (0x04) round, bit3 (0x08) keep-min-distance, bit4 (0x10) set rp0. - (let* ((p (hpop h)) (org (- (gc-org h (hs-zp1 h) p) (gc-org h (hs-zp0 h) (hs-rp0 h)))) + (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) ; min distance (when (< (abs dist) (hs-min-dist h)) (setf dist (if (minusp org) (- (hs-min-dist h)) (hs-min-dist h))))) @@ -483,7 +493,7 @@ same), so no glyph program's state changes leak into the next glyph." (defun mirp (h op) (let* ((n (hpop h)) (p (hpop h)) (cvt (aref (hs-cvt h) n)) - (org (- (gc-org h (hs-zp1 h) p) (gc-org h (hs-zp0 h) (hs-rp0 h))))) + (org (orus-dist h (hs-zp1 h) p (hs-zp0 h) (hs-rp0 h)))) (when (/= (hs-zp1 h) 0) ; cut-in (non-twilight) (when (> (abs (- cvt org)) (hs-cvt-cut-in h)) (setf cvt org))) (let ((dist (if (logbitp 2 op) (hround h cvt) cvt))) ; bit2 round, bit3 min-dist From ef7e528b1f68bcb70ab4f172b335b42debaac610 Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 18:21:48 -0400 Subject: [PATCH 14/36] hinting: per-glyph reset vectors to x-axis default + fix SPVTCA/SFVTCA axis bits MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Two bugs, both hit glyphs whose programs act before their first SVTCA: 1. reset-glyph-gs restored the vectors/rp/zp/loop from the post-prep snapshot, but FreeType resets those to the FIXED default (projection=freedom=dual=x-axis, zone 1, rp 0, loop 1) every glyph, keeping only the policy fields (round mode, cut-ins, delta, ...) from prep. This font's prep leaves the vectors on the y axis, so glyphs that DELTAP the advance phantom before any SVTCA (v, M, A, y, z, m, s, w, ...) moved it in y instead of x — the advance and every IP-referenced point came out ~1px wide. Now bit-exact. 2. SPVTCA/SFVTCA (0x02-0x05) had their axis bit inverted (only SVTCA was right); opcode&1 selects the axis (1=x, 0=y). ppem exact: 7 78->84, 10 73->81, 12 54->62, 16 38->55 (of 94). Suite 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/src/hint.lisp b/src/hint.lisp index c67b472..e114c4b 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -276,10 +276,11 @@ rule is min-distance, applied by MDRP/MIRP — not here.)" (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] -(def-op #x02 (h) (setf (hs-px h) 16384 (hs-py h) 0 (hs-dpx h) 16384 (hs-dpy h) 0)) ; SPVTCA[x] -(def-op #x03 (h) (setf (hs-px h) 0 (hs-py h) 16384 (hs-dpx h) 0 (hs-dpy h) 16384)) ; SPVTCA[y] -(def-op #x04 (h) (setf (hs-fx h) 16384 (hs-fy h) 0)) ; SFVTCA[x] -(def-op #x05 (h) (setf (hs-fx h) 0 (hs-fy h) 16384)) ; SFVTCA[y] +;; 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 @@ -437,11 +438,14 @@ rounding of subtracting two independently-scaled coords. Twilight falls back to t)))))) (defun reset-glyph-gs (h) - "Per-glyph graphics-state reset: restore the whole post-prep GS (FreeType does the -same), so no glyph program's state changes leak into the next glyph." - (if (hs-gs-default h) (restore-gs h) - (setf (hs-fx h) 16384 (hs-fy h) 0 (hs-px h) 16384 (hs-py h) 0 (hs-dpx h) 16384 (hs-dpy 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))) + "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)) (defun hint-glyph (h gid) "Grid-fit GID at the hinter's ppem; return the hinted contours as lists of From 2177719bacefa8bee2a2600d198f640de384452e Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 18:28:15 -0400 Subject: [PATCH 15/36] hinting: implement SHPIX (0x38) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit '$' (and other glyphs) call a fpgm function using SHPIX, which was unimplemented and trapped — crashing the dump and making every later glyph look composite. SHPIX shifts each of the loop points by a pixel amount along the freedom vector. ppem exact (of 94 printable ASCII): 7 84, 10 82, 12 62->89, 16 55->79. 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/hint.lisp b/src/hint.lisp index e114c4b..033f643 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -531,6 +531,16 @@ glyph — NOT to whatever prep happened to leave them at." (setf (hs-loop h) 1)))) (def-op #x32 (h op) (shp h op)) (def-op #x33 (h op) (shp 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)) From f2e61edbab62a8ba3e08190b8e3c9a32b549088b Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 18:31:33 -0400 Subject: [PATCH 16/36] hinting: IUP interior interpolates from the smaller-orus reference FreeType bases the interior interpolation on the endpoint with the smaller orus coordinate; using the contour-order endpoint rounds the single MulDiv differently (off by 1/64). Base on the smaller-orus reference to match. ppem exact (of 94): 7 87, 10 83, 12 90, 16 90. Suite 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/hint.lisp b/src/hint.lisp index 033f643..9df6b98 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -574,8 +574,12 @@ by the nearest touched point's delta (scaled ORG)." (let ((ua (funcall orus a)) (ub (funcall orus b)) (ui (funcall orus i)) (ca (funcall cur a)) (cb (funcall cur b))) (funcall cur i + ;; interior: base on the SMALLER-orus reference (as + ;; FreeType does) so the single MulDiv rounds identically. (cond ((and (<= (min ua ub) ui) (<= ui (max ua ub))) - (if (= ua ub) ca (+ ca (muldiv (- ui ua) (- cb ca) (- ub ua))))) + (cond ((= ua ub) ca) + ((<= ua ub) (+ ca (muldiv (- ui ua) (- cb ca) (- ub ua)))) + (t (+ cb (muldiv (- ui ub) (- ca cb) (- ua ub)))))) ((<= ui (min ua ub)) (+ (funcall org i) (- (if (< ua ub) ca cb) (funcall org (if (< ua ub) a b))))) (t (+ (funcall org i) (- (if (> ua ub) ca cb) (funcall org (if (> ua ub) a b)))))))))) From fd1ba96b7c441879e8a29d07d94755fe277a86b5 Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 18:46:00 -0400 Subject: [PATCH 17/36] hinting: implement SPVTL/SFVTL, ISECT, SHC, SHZ (diagonal + zone/contour movers) DejaVu Sans exercises opcodes Liberation didn't: SPVTL/SFVTL (0x06-0x09, set projection/freedom vector along or perpendicular to a line of two points, with FreeType-style unit-vector normalization), ISECT (0x0F, move a point to the intersection of two lines), and SHC/SHZ (0x34-0x37, shift a whole contour / zone by a reference point's displacement). Each was trapping and aborting the dump. DejaVuSans printable-ASCII exact: ppem 7 64, 10 63, 12 65, 16 63 (was 2, crashing on SPVTL). LiberationSans unchanged (90/94 @12). Suite 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 60 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 60 insertions(+) diff --git a/src/hint.lisp b/src/hint.lisp index 9df6b98..ad4c04b 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -531,6 +531,23 @@ glyph — NOT to whatever prep happened to leave them at." (setf (hs-loop h) 1)))) (def-op #x32 (h op) (shp h op)) (def-op #x33 (h op) (shp h op)) +(defun sh-ref (h op) + "The (displacement . zone-of-ref) for SHC/SHZ: like SHP, rp1/zp0 (odd) or rp2/zp1." + (multiple-value-bind (rp zref) (if (logbitp 0 op) (values (hs-rp1 h) (hs-zp0 h)) (values (hs-rp2 h) (hs-zp1 h))) + (values (- (gc-cur h zref rp) (gc-org h zref rp)) rp zref))) +(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))) @@ -605,6 +622,49 @@ by the nearest touched point's delta (scaled ORG)." (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) + "Normalize (vx,vy) F26.6 to an F2.14 unit vector (FreeType Normalize)." + (cond ((and (zerop vx) (zerop vy)) (values 16384 0)) + ((zerop vx) (values 0 (if (minusp vy) -16384 16384))) + ((zerop vy) (values (if (minusp vx) -16384 16384) 0)) + (t (let ((w (isqrt (+ (* vx vx) (* vy vy))))) + (values (muldiv vx 16384 w) (muldiv vy 16384 w)))))) +(defun sxvtl (h op set-proj) + "SPVTL/SFVTL: vector along (parallel, opcode odd) or perpendicular (even) to the +line from point A (zp2) to point B (zp1), in current coords. Sets proj+dual (and +also freedom for 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 (evenp op) (psetf dx (- dy) dy dx)) ; perpendicular + (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] (perpendicular) +(def-op #x07 (h op) (sxvtl h op t)) ; SPVTL[1] (parallel) +(def-op #x08 (h op) (sxvtl h op nil)) ; SFVTL[0] (perpendicular) +(def-op #x09 (h op) (sxvtl h op nil)) ; SFVTL[1] (parallel) +(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 From 85e71c420a254ac3f49f1238b8ef77aa01dfd313 Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 19:02:37 -0400 Subject: [PATCH 18/36] =?UTF-8?q?hinting:=20composite=20glyphs=20(P4)=20?= =?UTF-8?q?=E2=80=94=20per-component=20hinting=20+=20placement=20+=20MSIRP?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Implemented composite-glyph hinting: each component is hinted standalone (its own zone + instructions, via hint-subglyph), then transformed (2x2 F2.14) and offset into the parent (xy offsets grid-fit per ROUND_XY_TO_GRID), components merged, and the composite's own instruction stream run on the assembled outline. parse- composite-components + composite-aware glyph-instructions added; load-glyph-zone routes both simple and composite through glyph-points. Also implemented MSIRP (0x3A/0x3B, move stack indirect relative point), used by accented glyphs. LiberationSans: accented Latin-1 29/52 bit-exact @12px (bases always exact; some accents 1px off on the component offset — refinement pending). ASCII unchanged (90/94 @12). Suite 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 126 ++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 113 insertions(+), 13 deletions(-) diff --git a/src/hint.lisp b/src/hint.lisp index ad4c04b..c933224 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -360,13 +360,79 @@ stop the skip at depth 0 (0x59 EIF, and optionally 0x1B ELSE)." ;;; ------------------------------------------------------- glyph loading (defun glyph-instructions (font gid) - "The per-glyph instruction byte stream (or NIL) for a simple glyph." + "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))) - (when (>= ncont 0) - (let* ((p (+ g 10 (* 2 ncont))) (ilen (u16 d p))) - (when (plusp ilen) (subseq d (+ p 2) (+ p 2 ilen))))))))) + (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) ---- @@ -394,14 +460,14 @@ rounding of subtracting two independently-scaled coords. Twilight falls back to ;;; ---- 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." + "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)) (ncont (s16 d g))) - (when (< ncont 0) (return-from load-glyph-zone :composite)) - (multiple-value-bind (xs ys flags endpts) (%simple-glyph d g ncont) - (let* ((np (if (zerop ncont) 0 (1+ (aref endpts (1- ncont))))) + (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)) @@ -409,10 +475,10 @@ rounding of subtracting two independently-scaled coords. Twilight falls back to (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) - (let ((sx (hscale h (aref xs i))) (sy (hscale h (aref ys i)))) - (setf (aref cx i) sx (aref ox i) sx (aref cy i) sy (aref oy i) sy - (aref ux i) (aref xs i) (aref uy i) (aref ys i) ; unscaled (font units) - (aref on i) (if (logbitp 0 (aref flags i)) 1 0)))) + (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))) @@ -463,6 +529,26 @@ glyph — NOT to whatever prep happened to leave them at." (push (list (/ (aref (hz-cur-x z) 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))))))) +(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))) @@ -510,6 +596,20 @@ glyph — NOT to whatever prep happened to leave them at." (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)))) + (let ((cur-dist (- (gc-cur h (hs-zp1 h) point) (gc-cur h (hs-zp0 h) (hs-rp0 h))))) + (move h (hs-zp1 h) point (- distance cur-dist))) + (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 ;; original ranges/distances use ORUS (font units) like FreeType, so the ratio ;; keeps full precision; current uses the scaled cur coords. Base = rp1. From ef24a48564cbb13982585b0bd32911599a76ad40 Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 19:06:45 -0400 Subject: [PATCH 19/36] hinting: record M2 status in plan doc (full ASCII exact; composites; DejaVu) Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- docs/HINTING.md | 43 ++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 42 insertions(+), 1 deletion(-) diff --git a/docs/HINTING.md b/docs/HINTING.md index ea7180f..e8e54c1 100644 --- a/docs/HINTING.md +++ b/docs/HINTING.md @@ -80,7 +80,48 @@ Bit-exact fixed-point rounding (engine compensation, SROUND); DELTA exceptions gap is the first task of M2. - Comparison harness: `/tmp/weftdump.lisp` + oracle diff (per-point, any glyphs). -## M2 — opening task (sharp diagnosis) +## 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] From 1a6431a067c7ba20fd270ec587f3245bcedc04b5 Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 20:34:56 -0400 Subject: [PATCH 20/36] hinting: record round-2 diagnostic notes (diagonals, 1/64 tail, accents) No bit-exact fix landed this round; documenting the precise root-cause analysis of the three remaining residual classes so the next pass can resume without redoing the investigation. Key results: DejaVu post-prep CVT confirmed bit-exact vs FreeType; the diagonal blow-up is a projection-amplified MIRP whose divergence needs FreeType interpreter introspection; the LiberationSans 1/64 misses and the composite-accent 1px offsets both trace to the same IUP interior interpolation edge. Suite 10/10; Liberation ASCII unchanged (87/90/90 @7/12/16), DejaVu ~63-65/94. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- docs/HINTING.md | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/docs/HINTING.md b/docs/HINTING.md index e8e54c1..53a752f 100644 --- a/docs/HINTING.md +++ b/docs/HINTING.md @@ -80,6 +80,33 @@ Bit-exact fixed-point rounding (engine compensation, SROUND); DELTA exceptions gap is the first task of M2. - Comparison harness: `/tmp/weftdump.lisp` + oracle diff (per-point, any glyphs). +## M2 round-2 open items (diagnostic notes for the next pass) +Three residuals remain, all now precisely characterized (no bit-exact fix landed +this round — they sit at the 1-unit / projection-amplified frontier): +- **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 From f5b6e77751fdbd214c3a7c592582ec2815c40265 Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 21:54:20 -0400 Subject: [PATCH 21/36] hinting: fix SPVTL/SFVTL parallel-vs-perpendicular (diagonals no longer blow up) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Found by per-instruction execution diff against a trace-enabled FreeType (see inspect/hint-fttrace.md): at DejaVu '/'s first diagonal MIRP, weft's projection after SPVTL was FreeType's rotated 90° — (4734,15697) vs (-15686,4730). The parallel/perpendicular bit was inverted: FreeType rotates when `opcode & 1` (SPVTL[1]/0x07 = perpendicular), weft rotated on the EVEN opcode. So weft built a near-vertical projection where FreeType's is near-horizontal, and the freedom-x MIRP move amplified ×(16384/4734)=3.46 → '/' pt0 landed at -937 vs FT 189. Fix: rotate on the odd opcode. DejaVu '/' \\ A y: 17.6px off -> 1/64px; DejaVu ASCII @12 65 -> 69/94; LiberationSans unchanged (its diagonals already used the even/parallel path). Adds the weft-side per-instruction STATE trace (env WEFT_HINT_TRACE) mirroring the patched FreeType build, for execution diffs. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- inspect/hint-fttrace.md | 33 +++++++++++++++++++++++++++++++++ src/hint.lisp | 37 ++++++++++++++++++++++++++++--------- 2 files changed, 61 insertions(+), 9 deletions(-) create mode 100644 inspect/hint-fttrace.md 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/src/hint.lisp b/src/hint.lisp index c933224..d166d7f 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -171,10 +171,28 @@ rule is min-distance, applied by MDRP/MIRP — not here.)" (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 (step-op h))) + (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))) @@ -730,20 +748,21 @@ by the nearest touched point's delta (scaled ORG)." (t (let ((w (isqrt (+ (* vx vx) (* vy vy))))) (values (muldiv vx 16384 w) (muldiv vy 16384 w)))))) (defun sxvtl (h op set-proj) - "SPVTL/SFVTL: vector along (parallel, opcode odd) or perpendicular (even) to the -line from point A (zp2) to point B (zp1), in current coords. Sets proj+dual (and -also freedom for SFVTL forms)." + "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 (evenp op) (psetf dx (- dy) dy dx)) ; perpendicular + (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] (perpendicular) -(def-op #x07 (h op) (sxvtl h op t)) ; SPVTL[1] (parallel) -(def-op #x08 (h op) (sxvtl h op nil)) ; SFVTL[0] (perpendicular) -(def-op #x09 (h op) (sxvtl h op nil)) ; SFVTL[1] (parallel) +(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))) From ee5b000aa4a087cf1d74ea17b0b7c99db181b6bd Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 22:23:05 -0400 Subject: [PATCH 22/36] hinting: exact FT_Vector_NormLen port for SPVTL/SFVTL vector normalization MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit norm14 used isqrt, giving projection vectors ~9/16384 too long; that cascaded into 1-unit MIRP errors on diagonal glyphs (DejaVu / \ A y off by 1/64 even after the SPVTL parallel/perp fix). Ported FreeType's Normalize + FT_Vector_NormLen exactly (Newton-Raphson normalize to 0x10000, then /4) so projection vectors match bit-for-bit — verified via the per-instruction STATE trace (weft proj (15721,-4643) -> FreeType's (15713,-4640)). DejaVu V, X now bit-exact; / \ A y down to 1/64. Also trace into CALL'd fpgm functions (weft's call-fn now emits STATE) so the per-instruction diff aligns with FreeType. Liberation unchanged (90/94 @12); 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 34 ++++++++++++++++++++++++++++------ 1 file changed, 28 insertions(+), 6 deletions(-) diff --git a/src/hint.lisp b/src/hint.lisp index d166d7f..a08d02c 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -371,6 +371,7 @@ stop the skip at depth 0 (0x59 EIF, and optionally 0x1B ELSE)." (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 @@ -741,12 +742,33 @@ by the nearest touched point's delta (scaled ORG)." ;;; ---- vector setters that need points (SPVTL/SFVTL) + misc ---- (defun norm14 (vx vy) - "Normalize (vx,vy) F26.6 to an F2.14 unit vector (FreeType Normalize)." - (cond ((and (zerop vx) (zerop vy)) (values 16384 0)) - ((zerop vx) (values 0 (if (minusp vy) -16384 16384))) - ((zerop vy) (values (if (minusp vx) -16384 16384) 0)) - (t (let ((w (isqrt (+ (* vx vx) (* vy vy))))) - (values (muldiv vx 16384 w) (muldiv vy 16384 w)))))) + "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. From 8c3fc5fe6615aff60dbd7a43370c4c1ec5e61734 Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 22:28:18 -0400 Subject: [PATCH 23/36] hinting: dot14 rounds once (FreeType TT_DotFix14), not per-term The projection dot product summed two mul2.14 results, rounding each term separately; FreeType's TT_DotFix14 sums ax*bx + ay*by and rounds ONCE. The double rounding differed by 1 on diagonal projections (e.g. pt1 of DejaVu '/': 83 vs FreeType's 82), cascading into 1-unit MIRP moves. Found via the per-instruction STATE trace. DejaVu ASCII @12 70->75, @16 68->77; 'w' now bit-exact; Liberation unchanged (90/94 @12). Suite 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/hint.lisp b/src/hint.lisp index a08d02c..5ebdbee 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -94,7 +94,12 @@ result sign is sign(a*b*c): dividing by a negative c flips it." (* 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) (+ (mul2.14 ax bx) (mul2.14 ay by))) +(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 From 5bbd76621a765092193978a4947c5a49332e7bed Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 22:41:48 -0400 Subject: [PATCH 24/36] hinting: MDRP/MIRP measure current distance by projecting the difference vector MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit FreeType's MDRP/MIRP compute cur_dist = PROJECT(cur[point] - cur[rp0]) — projecting the difference vector once — whereas weft subtracted two independently projected points (project(p) - project(rp0)), which differs by a rounding unit on diagonals (DejaVu '/': -60 vs -61) and cascaded into 1-unit mover errors. Added cur-dist (and org-dist) helpers and rewrote the MDRP/MIRP move as (distance - cur_dist). Root-caused via the per-instruction STATE trace. DejaVu ASCII @7/12/16: 71/75/77 -> 90/88/88 ('/' '\' A w y V X now bit-exact). LiberationSans unchanged (87/90/90). Suite 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 34 ++++++++++++++++++++++------------ 1 file changed, 22 insertions(+), 12 deletions(-) diff --git a/src/hint.lisp b/src/hint.lisp index 5ebdbee..72212ec 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -466,16 +466,28 @@ per ROUND_XY_TO_GRID); components recurse + carry the 2x2 transform." ;; 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-dist (h zp1 p zp0 rp0) - "Original projected distance (p relative to rp0) as FreeType's MDRP/MIRP measure it: -scale the ORUS (font-unit) difference ONCE, then dual-project — avoids the extra -rounding of subtracting two independently-scaled coords. Twilight falls back to org." + "Original projected distance from the ORUS (font-unit) difference, scaled once then +dual-projected. Twilight falls back to scaled org." (if (or (zerop zp0) (zerop zp1)) - (- (gc-org h zp1 p) (gc-org h zp0 rp0)) - (let* ((z1 (zone h zp1)) (z0 (zone h zp0)) - (dx (- (aref (hz-orus-x z1) p) (aref (hz-orus-x z0) rp0))) - (dy (- (aref (hz-orus-y z1) p) (aref (hz-orus-y z0) rp0)))) - (dot14 (hscale h dx) (hscale h dy) (hs-dpx h) (hs-dpy h))))) + (org-dist h zp1 p zp0 rp0) + (let ((z1 (zone h zp1)) (z0 (zone h zp0))) + (dot14 (hscale h (- (aref (hz-orus-x z1) p) (aref (hz-orus-x z0) rp0))) + (hscale h (- (aref (hz-orus-y z1) p) (aref (hz-orus-y z0) rp0))) + (hs-dpx h) (hs-dpy h))))) (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))) @@ -600,8 +612,7 @@ Saves/restores the shared VM's zone + program state so it can nest." (dist (if (logbitp 2 op) (hround h org) org))) (when (logbitp 3 op) ; min distance (when (< (abs dist) (hs-min-dist h)) (setf dist (if (minusp org) (- (hs-min-dist h)) (hs-min-dist h))))) - (let ((cur-rp0 (gc-cur h (hs-zp0 h) (hs-rp0 h)))) - (move h (hs-zp1 h) p (- (+ cur-rp0 dist) (gc-cur h (hs-zp1 h) p)))) + (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 @@ -615,8 +626,7 @@ Saves/restores the shared VM's zone + program state so it can nest." (unless (minusp org) (setf dist (abs dist))) (when (logbitp 3 op) (when (< (abs dist) (hs-min-dist h)) (setf dist (if (minusp org) (- (hs-min-dist h)) (hs-min-dist h))))) - (let ((cur-rp0 (gc-cur h (hs-zp0 h) (hs-rp0 h)))) - (move h (hs-zp1 h) p (- (+ cur-rp0 dist) (gc-cur h (hs-zp1 h) p)))) + (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 From 15cf5c1dbde7e93be59a8798592b9ccedf833501 Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 22:45:53 -0400 Subject: [PATCH 25/36] hinting: IP/MD/ALIGNRP/MSIRP also measure via difference-vector projection Applied the same PROJECT/DUALPROJ-of-the-difference fix to the remaining distance ops: IP's ranges/dists, MD[0]/MD[1], ALIGNRP, and MSIRP now project the difference vector once (org via ORUS font units, current via scaled cur) instead of subtracting two independently-projected points. Added orus-diff helper. DejaVu ASCII @7/12/16: 90/88/88 -> 92/93/92. LiberationSans unchanged (87/90/90). Suite 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 31 ++++++++++++++++++------------- 1 file changed, 18 insertions(+), 13 deletions(-) diff --git a/src/hint.lisp b/src/hint.lisp index 72212ec..a712c26 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -479,6 +479,11 @@ per ROUND_XY_TO_GRID); components recurse + carry the 2x2 transform." (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 from the ORUS (font-unit) difference, scaled once then dual-projected. Twilight falls back to scaled org." @@ -638,23 +643,23 @@ Saves/restores the shared VM's zone + program state so it can nest." (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)))) - (let ((cur-dist (- (gc-cur h (hs-zp1 h) point) (gc-cur h (hs-zp0 h) (hs-rp0 h))))) - (move h (hs-zp1 h) point (- distance cur-dist))) + (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 - ;; original ranges/distances use ORUS (font units) like FreeType, so the ratio - ;; keeps full precision; current uses the scaled cur coords. Base = rp1. + ;; 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)) - (oa (gc-orus h (hs-zp0 h) ra)) (ob (gc-orus h (hs-zp1 h) rb)) - (ca (gc-cur h (hs-zp0 h) ra)) (cb (gc-cur h (hs-zp1 h) rb)) - (old-range (- ob oa)) (cur-range (- cb ca))) + (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)) (op (gc-orus h (hs-zp2 h) p)) (cp (gc-cur h (hs-zp2 h) p)) - (org-dist (- op oa)) - (new (+ ca (if (zerop old-range) 0 (muldiv org-dist cur-range old-range))))) + (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))) @@ -695,15 +700,15 @@ Saves/restores the shared VM's zone + program state so it can nest." (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 (- (gc-cur h (hs-zp0 h) rp0) (gc-cur h (hs-zp1 h) p))))) + (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 (- (gc-cur h (hs-zp0 h) a) (gc-cur h (hs-zp1 h) b))))) + (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 (- (gc-org h (hs-zp0 h) a) (gc-org h (hs-zp1 h) b))))) + (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))))) From d232903bc00ff8cb171681cd10867dbcdb774fbe Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 22:50:08 -0400 Subject: [PATCH 26/36] =?UTF-8?q?hinting:=20exact=20IUP=20port=20=E2=80=94?= =?UTF-8?q?=20scaled-org=20boundary=20+=20orus=20interior=20ratio?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit FreeType's iup_worker_interpolate_ is a hybrid: it sorts the two touched refs by ORUS, but classifies each untouched point (below ref1 / above ref2 / interior) using the SCALED org coordinate, while the interior interpolation ratio uses ORUS (font units) via DivFix->MulFix. weft used orus for the boundary too, so a point sharing a ref's scaled position (e.g. b pt6: orus 316 vs ref 318, but both scale to 119) was interpolated instead of shifting with the ref -> off by 1/64. Ported FreeType's routine exactly. LiberationSans ASCII @7/12/16: 87/90/90 -> 94/94/93 (b g % & now bit-exact); DejaVuSans 92/93/92 -> 93/93/94. Suite 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 29 +++++++++++++++++------------ 1 file changed, 17 insertions(+), 12 deletions(-) diff --git a/src/hint.lisp b/src/hint.lisp index a712c26..cced97e 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -727,18 +727,23 @@ by the nearest touched point's delta (scaled ORG)." (setf touched (nreverse touched)) (when touched (flet ((interp (i a b) ; move untouched i between touched a,b - (let ((ua (funcall orus a)) (ub (funcall orus b)) (ui (funcall orus i)) - (ca (funcall cur a)) (cb (funcall cur b))) - (funcall cur i - ;; interior: base on the SMALLER-orus reference (as - ;; FreeType does) so the single MulDiv rounds identically. - (cond ((and (<= (min ua ub) ui) (<= ui (max ua ub))) - (cond ((= ua ub) ca) - ((<= ua ub) (+ ca (muldiv (- ui ua) (- cb ca) (- ub ua)))) - (t (+ cb (muldiv (- ui ub) (- ca cb) (- ua ub)))))) - ((<= ui (min ua ub)) - (+ (funcall org i) (- (if (< ua ub) ca cb) (funcall org (if (< ua ub) a b))))) - (t (+ (funcall org i) (- (if (> ua ub) ca cb) (funcall org (if (> ua ub) 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)))) From a77f441e6eccc379b273b152b4cc69189717e17c Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 22:56:46 -0400 Subject: [PATCH 27/36] hinting: MIRP auto-flips cvt before the cut-in test (FreeType order) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit MIRP applied the control-value cut-in using the un-flipped cvt, so a cvt and org of opposite sign (|cvt-org| huge) wrongly triggered the cut-in (cvt=org) — e.g. LiberationSans '%'@16 pt22 came out 1px low. FreeType auto-flips cvt to org's sign FIRST, then tests the cut-in (same-zone) on the flipped value. Reordered to match, and switched MDRP/MIRP min-distance to FreeType's asymmetric clamp (min-distance helper). Kept orus-dist for the original distance. LiberationSans ASCII now 94/94 at every ppem 7-16. Suite 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 27 ++++++++++++++++++--------- 1 file changed, 18 insertions(+), 9 deletions(-) diff --git a/src/hint.lisp b/src/hint.lisp index cced97e..7267f53 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -611,26 +611,35 @@ Saves/restores the shared VM's zone + program state so it can nest." (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) ; min distance - (when (< (abs dist) (hs-min-dist h)) (setf dist (if (minusp org) (- (hs-min-dist h)) (hs-min-dist h))))) + (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 (/= (hs-zp1 h) 0) ; cut-in (non-twilight) - (when (> (abs (- cvt org)) (hs-cvt-cut-in h)) (setf cvt org))) - (let ((dist (if (logbitp 2 op) (hround h cvt) cvt))) ; bit2 round, bit3 min-dist - (when (minusp org) (setf dist (- (abs dist))) ) ; sign follows original - (unless (minusp org) (setf dist (abs dist))) - (when (logbitp 3 op) - (when (< (abs dist) (hs-min-dist h)) (setf dist (if (minusp org) (- (hs-min-dist h)) (hs-min-dist 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 From 3066e9fdb96564e84c7e3c07413304e059ea087b Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 23:01:19 -0400 Subject: [PATCH 28/36] hinting: orus-dist dual-projects before scaling (FreeType MulFix(DUALPROJ,scale)) FreeType's MDRP/MIRP/IP original distance dual-projects the ORUS (font-unit) difference first, then scales (MulFix by x_scale, for x_scale==y_scale); weft scaled each component before dual-projecting, which rounds differently for diagonal projection vectors. Now uses hscale(orus-diff). No count change but FreeType-exact; Liberation 94/94 all ppem, suite 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/hint.lisp b/src/hint.lisp index 7267f53..5457654 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -485,14 +485,13 @@ per ROUND_XY_TO_GRID); components recurse + carry the 2x2 transform." (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 from the ORUS (font-unit) difference, scaled once then -dual-projected. Twilight falls back to scaled org." + "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) - (let ((z1 (zone h zp1)) (z0 (zone h zp0))) - (dot14 (hscale h (- (aref (hz-orus-x z1) p) (aref (hz-orus-x z0) rp0))) - (hscale h (- (aref (hz-orus-y z1) p) (aref (hz-orus-y z0) rp0))) - (hs-dpx h) (hs-dpy h))))) + (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))) From 0bb729b77dbb9db17f19dd5c1ee6c1b86bc0d9b3 Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 23:04:42 -0400 Subject: [PATCH 29/36] hinting: SHP/SHC/SHZ displacement = PROJECT(cur[ref]-org[ref]) FreeType's Compute_Point_Displacement projects the reference point's (cur - org) difference with the PROJECTION vector; weft computed project(cur) - dualproj(org) (mixing projection/dual and subtracting two projections), off by 1 on diagonals. Fixed sh-ref to dot14(cur-org, projVector). DejaVuSans ASCII @10/12: 93 -> 94/94. Liberation 94/94 all ppem. Suite 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/src/hint.lisp b/src/hint.lisp index 5457654..e909fa7 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -671,17 +671,21 @@ direction (asymmetric — based on ORG's sign, not |dist|)." (move h (hs-zp2 h) p (- new cp)))) (setf (hs-loop h) 1))) -(defun shp (h op) ; SHP[a] - (multiple-value-bind (rp zref) (if (logbitp 0 op) (values (hs-rp1 h) (hs-zp0 h)) (values (hs-rp2 h) (hs-zp1 h))) - (let ((disp (- (gc-cur h zref rp) (gc-org h zref rp)))) - (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 sh-ref (h op) - "The (displacement . zone-of-ref) for SHC/SHZ: like SHP, rp1/zp0 (odd) or rp2/zp1." + "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))) - (values (- (gc-cur h zref rp) (gc-org h zref rp)) rp zref))) + (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)) From e19f04c9452f6f7a78ba7710335887079780d878 Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 23:09:01 -0400 Subject: [PATCH 30/36] hinting: clamp F_dot_P when freedom is near-perpendicular to projection When the freedom and projection vectors are near-perpendicular, F_dot_P (their dot product) is ~0; FreeType's Compute_Funcs clamps |F_dot_P| < 0x400 to 0x4000 and still moves. weft skipped the move when fdotp was 0, so a diagonal MIRP with freedom perpendicular to the projection (DejaVu '$' @7px) didn't move the point (off by 1px). Added the clamp. DejaVuSans ASCII @7 -> 94/94. Liberation 94/94 all ppem. Suite 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/hint.lisp b/src/hint.lisp index e909fa7..41419dd 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -159,15 +159,17 @@ rule is min-distance, applied by MDRP/MIRP — not here.)" (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." + "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)) - ;; distance along freedom vector so its projection == DIST (fdotp (dot14 fx fy (hs-px h) (hs-py h)))) - (unless (zerop fdotp) - (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)))))) + (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)) From f614563aa1d83a3072ba8011219a1c835adfbf71 Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 23:19:35 -0400 Subject: [PATCH 31/36] hinting: fix DIV opcode (was computing MUL) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit DIV (0x62) used muldiv(a,b,64) — identical to MUL — instead of TrueType's (n1*64)/n2 = muldiv(a,64,b). This corrupted any fpgm arithmetic using DIV; found via the STATE trace on LiberationSans 'é', whose accent-alignment function branched the wrong way (a DIV gave -46 vs FreeType's -12), leaving the accent 1px off. LiberationSans accented Latin-1 now 53/53 bit-exact at ppem 7/12/16 (composites fully exact). Printable ASCII still 94/94 both fonts. Suite 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/hint.lisp b/src/hint.lisp index 41419dd..e67a800 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -225,8 +225,8 @@ FreeType's trace build (ftbuild) for line-by-line execution diffs.") (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 (muldiv a b 64)))) ; DIV -(def-op #x63 (h) (let ((b (hpop h)) (a (hpop h))) (hpush h (muldiv a b 64)))) ; MUL +(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 From 6f4e6843451a7d6cf469fb0577fbe833389906bd Mon Sep 17 00:00:00 2001 From: ynniv Date: Thu, 2 Jul 2026 23:24:37 -0400 Subject: [PATCH 32/36] =?UTF-8?q?hinting:=20record=20M2=20completion=20?= =?UTF-8?q?=E2=80=94=20full=20ASCII=20bit-exact=20on=20both=20fonts?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- docs/HINTING.md | 32 +++++++++++++++++++++++++++++--- 1 file changed, 29 insertions(+), 3 deletions(-) diff --git a/docs/HINTING.md b/docs/HINTING.md index 53a752f..8a5a43f 100644 --- a/docs/HINTING.md +++ b/docs/HINTING.md @@ -80,9 +80,35 @@ Bit-exact fixed-point rounding (engine compensation, SROUND); DELTA exceptions gap is the first task of M2. - Comparison harness: `/tmp/weftdump.lisp` + oracle diff (per-point, any glyphs). -## M2 round-2 open items (diagnostic notes for the next pass) -Three residuals remain, all now precisely characterized (no bit-exact fix landed -this round — they sit at the 1-unit / projection-amplified frontier): +## 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`; From 37c2188267178518f70621e96c02ef0357329de0 Mon Sep 17 00:00:00 2001 From: ynniv Date: Fri, 3 Jul 2026 03:21:54 -0400 Subject: [PATCH 33/36] hinting: wire into rasterize-glyph (*hinting*) with grid-fit advances + caching (M3) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit rasterize-glyph gains a hinted path: when *hinting* applies (T = all sizes, or a number N = only ppem<=N), the glyph is grid-fit via the bytecode interpreter and rasterized at scale 1 on the integer pixel grid, with the grid-fit (integer) advance so painted widths stay even — no sub-pixel drift. Falls back to the geometric path for composites we can't hint, variations, or any error. - hint-glyph now also returns the hinted advance (phantom pp2-pp1). - hinted-segments / hinted-advance: memoized per (font,gid,ppem) over a per- (font,ppem) hinter cache (fpgm+prep run once); installed into raster via the *hinted-segments-fn* hook so raster.lisp needn't depend on the interpreter. - Default *hinting* nil: the geometric path and the whole suite are unchanged (10/10). Small text renders crisp: stems/baseline land on pixel boundaries instead of smearing across fractional rows. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 74 +++++++++++++++++++++++++++++++++++++++++++++---- src/raster.lisp | 71 +++++++++++++++++++++++++++++++++++------------ 2 files changed, 122 insertions(+), 23 deletions(-) diff --git a/src/hint.lisp b/src/hint.lisp index e67a800..a81f9be 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -556,20 +556,24 @@ glyph — NOT to whatever prep happened to leave them at." (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)) (defun hint-glyph (h gid) - "Grid-fit GID at the hinter's ppem; return the hinted contours as lists of -(x y on) in px (or NIL for empty / :composite for unsupported composites)." + "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." (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 - (let* ((z (zone h 1)) (ends (hs-glyph-ends h)) (out '()) (start 0)) - (dotimes (c (length ends) (nreverse out)) + ;; extract hinted contour points + the hinted advance (phantom pp1..pp2) + (let* ((z (zone h 1)) (ends (hs-glyph-ends h)) (np (hs-glyph-npts h)) (out '()) (start 0)) + (dotimes (c (length ends)) (let ((end (aref ends c)) (pts '())) (loop for i from start to end do (push (list (/ (aref (hz-cur-x z) 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))))))) + (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 @@ -853,3 +857,61 @@ Perpendicular is a 90° CCW rotation, matching FreeType's Ins_SxVTL. Sets proj+ (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))) + (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/raster.lisp b/src/raster.lisp index a34a038..240fe69 100644 --- a/src/raster.lisp +++ b/src/raster.lisp @@ -151,28 +151,65 @@ (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 and + ;; advance by the grid-fit (integer) advance so the pen stays on the pixel grid. + (multiple-value-bind (hinted hadv) + (if (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) + (values nil nil)) + (cond + ((eq hinted :empty) (values nil 0 0 0 0 (float hadv 1d0))) + (hinted ; grid-fit px segments, no sub-pixel shift + (multiple-value-bind (minx miny maxx maxy) (%outline-bbox hinted) + (declare (ignore miny maxx)) + (multiple-value-bind (cov w h) + (rasterize-outline hinted 1d0 :origin-x minx :origin-y maxy) + (values cov w h (floor minx) (- (ceiling maxy)) (float hadv 1d0))))) + (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." From b06a9fd4ef84ce9c1b33fc7461d725023f5acde5 Mon Sep 17 00:00:00 2001 From: ynniv Date: Fri, 3 Jul 2026 04:24:56 -0400 Subject: [PATCH 34/36] =?UTF-8?q?hinting:=20sub-pixel=20x=20for=20hinted?= =?UTF-8?q?=20glyphs=20(fractional=20advances)=20=E2=80=94=20smooth=20spac?= =?UTF-8?q?ing?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The first M3 cut used integer advances + integer placement for hinted glyphs, which quantized inter-glyph spacing and read as bad kerning at small sizes. Match the browser instead: keep the grid-fit (it matters vertically — crisp stems/baseline) but rasterize the hinted outline with the sub-pixel x-shift and advance by the fractional (geometric) advance, so horizontal spacing stays smooth. hint-glyph's advance value is no longer used by the raster path. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/raster.lisp | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/src/raster.lisp b/src/raster.lisp index 240fe69..c0287ec 100644 --- a/src/raster.lisp +++ b/src/raster.lisp @@ -183,21 +183,22 @@ later-loaded interpreter.") (scale (/ (float ppem 1d0) upem)) (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 and - ;; advance by the grid-fit (integer) advance so the pen stays on the pixel grid. - (multiple-value-bind (hinted hadv) - (if (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) - (values nil nil)) + ;; 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 (float hadv 1d0))) - (hinted ; grid-fit px segments, no sub-pixel shift + ((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 :origin-x minx :origin-y maxy) - (values cov w h (floor minx) (- (ceiling maxy)) (float hadv 1d0))))) + (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) From 9b3d5c167bc32424eaae02108b1aec056ff414de Mon Sep 17 00:00:00 2001 From: ynniv Date: Fri, 3 Jul 2026 05:05:16 -0400 Subject: [PATCH 35/36] otl: cache GSUB/GPOS lookup indices on the font (per tag . features) otl-lookup-indices reparsed the script/feature/lookup tables on every call; shaping a page word-by-word made that quadratic. Split into a cached wrapper + core, keyed by (tag . features) on a new font %otl slot (like %gdef/%cmap). Shape a page's lookups once, not once per word. Suite 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/font.lisp | 3 ++- src/otl.lisp | 18 +++++++++++++++--- 2 files changed, 17 insertions(+), 4 deletions(-) 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/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))) From c8e25f9da8c4a3ea5c3b0b9f064afca4e4ea5e9e Mon Sep 17 00:00:00 2001 From: ynniv Date: Fri, 3 Jul 2026 05:25:02 -0400 Subject: [PATCH 36/36] =?UTF-8?q?hinting:=20add=20light=20(Y-only)=20mode?= =?UTF-8?q?=20=E2=80=94=20grid-fit=20vertically,=20keep=20fractional=20X?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit *hint-light* returns the outline with hinted Y but the original (unhinted) scaled X, so baseline/x-height/stem heights snap crisp while horizontal stems stay sub-pixel. Full hinting's X grid-fit is crisp but choppy — uneven inter-letter rhythm; light matches the browser's default Linux rendering. Measured on a controlled sample vs Chromium, light halves the per-pair ink-width error (21 -> 12 over 30 kern pairs). Default nil (full); the hinted-glyph cache keys on the mode. Suite 10/10. Co-Authored-By: Claude Opus 4.8 (1M context) Claude-Session: https://claude.ai/code/session_01JA1saK7BkgavHNeurmK65k --- src/hint.lisp | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/src/hint.lisp b/src/hint.lisp index a81f9be..97497f9 100644 --- a/src/hint.lisp +++ b/src/hint.lisp @@ -555,22 +555,30 @@ glyph — NOT to whatever prep happened to leave them at." (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." +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) - (let* ((z (zone h 1)) (ends (hs-glyph-ends h)) (np (hs-glyph-npts h)) (out '()) (start 0)) + ;; 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 (hz-cur-x z) i) 64.0) (/ (aref (hz-cur-y z) i) 64.0) (= 1 (aref (hz-on z) i))) pts)) + (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))))) @@ -882,7 +890,7 @@ font has no working hint programs." 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))) + (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)))