diff --git a/fontland/fontland/font.rkt b/fontland/fontland/font.rkt index 7923acf7..84c2b273 100644 --- a/fontland/fontland/font.rkt +++ b/fontland/fontland/font.rkt @@ -1,6 +1,6 @@ #lang debug racket/base (require "racket.rkt") -(require "freetype-ffi.rkt" (except-in ffi/unsafe -> array?) racket/runtime-path "subset.rkt" "glyph.rkt" "layout-engine.rkt" "bbox.rkt" "glyphrun.rkt" "cmap-processor.rkt" "directory.rkt" xenomorph "tables.rkt" "ttfglyph.rkt") +(require "freetype-ffi.rkt" (except-in ffi/unsafe -> array?) racket/runtime-path "subset.rkt" "glyph.rkt" "bbox.rkt" "glyphrun.rkt" "cmap-processor.rkt" "directory.rkt" xenomorph "tables.rkt" "ttfglyph.rkt") (provide (all-defined-out)) #| @@ -263,13 +263,9 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js ;; Returns a GlyphRun object, which includes an array of Glyphs and GlyphPositions for the given string. (define/contract (layout this string [userFeatures #f] [script #f] [language #f]) ((string?) ((option/c (listof symbol?)) (option/c symbol?) (option/c symbol?)) . ->*m . GlyphRun?) - (unless (· this _layoutEngine) - (set-field! _layoutEngine this (+LayoutEngine this))) (define (get-layout string) (define key (list string (and userFeatures (sort userFeatures symbol 0 (· this index)) - (>= (· this index) (length (· this glyphs)))) - #f - (list-ref (· this glyphs) (· this index)))) - - (define/public (next) (move 1)) - - (define/public (prev) (move -1)) - - (define/public (peek [count 1]) - (define idx (· this index)) - (define res (send this increment count)) - (set-field! index this idx) - res) - - (define/public (peekIndex [count 1]) - (define idx (· this index)) - (send this increment count) - (define res (· this index)) - (set-field! index this idx) - res) - - (define/public (increment [count 1]) - (for/last ([i (in-range (abs count))]) - (send this move (if (negative? count) -1 1))))) - -(test-module - (define gi (+GlyphIterator '(a b c))) - (check-equal? (· gi index) 0) - (check-equal? (send gi cur) 'a) - (check-equal? (send gi move 1) 'b) - (check-equal? (send gi move 1) 'c) - (check-false (send gi move 1)) - (check-false (send gi cur)) - (check-equal? (send gi increment -3) 'a) - (check-equal? (send gi cur) 'a) - (check-equal? (send gi peek 1) 'b) - (check-equal? (send gi peek 2) 'c) - (check-equal? (send gi peek 3) #f) - (check-equal? (send gi cur) 'a) - - - ) diff --git a/fontland/fontland/gpos-processor-test.rkt b/fontland/fontland/gpos-processor-test.rkt deleted file mode 100644 index f23b572a..00000000 --- a/fontland/fontland/gpos-processor-test.rkt +++ /dev/null @@ -1,33 +0,0 @@ -#lang racket/base -(require "racket.rkt") - -(require fontland "gpos-processor.rkt" rackunit xenomorph racket/serialize describe) - -(define fira-path "assets/fira.ttf") -(define f (openSync fira-path)) -(define gpos (· f GPOS)) - -(define proc (+GPOSProcessor f gpos)) - -(check-equal? (dump (· proc features)) - '((cpsp (lookupCount . 1) (lookupListIndexes 0) (featureParams . 0)) - (mkmk (lookupCount . 5) (lookupListIndexes 8 9 10 11 12) (featureParams . 0)) - (mark (lookupCount . 3) (lookupListIndexes 5 6 7) (featureParams . 0)) - (kern (lookupCount . 4) (lookupListIndexes 1 2 3 4) (featureParams . 0)))) - -(check-equal? (dump (· proc script)) - '((count . 0) - (defaultLangSys (featureIndexes 0 14 28 42) - (reserved . 0) - (reqFeatureIndex . 65535) - (featureCount . 4)) - (langSysRecords))) -(check-equal? (dump (· proc scriptTag)) 'DFLT) -(check-equal? (dump (· proc language)) - '((featureIndexes 0 14 28 42) - (reserved . 0) - (reqFeatureIndex . 65535) - (featureCount . 4))) -(check-equal? (dump (· proc languageTag)) #f) -(check-equal? (dump (· proc lookups)) empty) -(check-equal? (dump (· proc direction)) 'ltr) diff --git a/fontland/fontland/gpos-processor.rkt b/fontland/fontland/gpos-processor.rkt deleted file mode 100644 index 186815a6..00000000 --- a/fontland/fontland/gpos-processor.rkt +++ /dev/null @@ -1,105 +0,0 @@ -#lang racket/base -(require "racket.rkt") - -(require "ot-processor.rkt") -(provide (all-defined-out)) - -#| -https://github.com/mbutterick/fontkit/blob/master/src/opentype/GPOSProcessor.js -|# - -(define-subclass OTProcessor (GPOSProcessor) - - (define/public (applyPositionValue sequenceIndex value) - (define position (list-ref (· this positions) (send (· this glyphIterator) peekIndex sequenceIndex))) - (when (· value xAdvance) - (increment-field! xAdvance position (or (· value xAdvance) 0))) - (when (· value yAdvance) - (increment-field! yAdvance position (· value yAdvance))) - (when (· value xPlacement) - (increment-field! xOffset position (· value xPlacement))) - (when (· value yPlacement) - (increment-field! yOffset position (· value yPlacement)))) - - (define/override (applyLookup lookupType table) - (case lookupType - [(1) ;; Single positioning value - #;(report/file 'single-positioning-value) - (define index (send this coverageIndex (· table coverage))) - #;(report/file index) - (cond - [(= index -1) #f] - [else #;(report (· table version)) - (case (· table version) - [(1) (send this applyPositionValue 0 (· table value))] - [(2) (send this applyPositionValue 0 (send (· table values) get index))]) - #t])] - [(2) ;; Pair Adjustment Positioning - #;(report/file 'applyLookup:pair-adjustment) - (define nextGlyph (· this glyphIterator peek)) - (cond - [(not nextGlyph) #f] - [else - #;(report 'getting-pair-coverage-for) - #;(report* (· this glyphIterator cur id) (· this glyphIterator peek id) (· table coverage)) - (define index (send this coverageIndex (· table coverage))) - #;(report index) - (cond - [(= index -1) #f] - [else - #;(report (· table version)) - (case (· table version) - [(1) ;; Adjustments for glyph pairs - #;(report 'glyph-pair) - (define set (send (· table pairSets) get index)) - (for/first ([pair (in-list set)] - #:when (= (· pair secondGlyph) (· nextGlyph id))) - (send this applyPositionValue 0 (· pair value1)) - (send this applyPositionValue 0 (· pair value2)))] - [(2) ;; Class pair adjustment - #;(report/file 'class-pair) - (define class1 (send this getClassID (· this glyphIterator cur id) (· table classDef1))) - (define class2 (send this getClassID (· nextGlyph id) (· table classDef2))) - (cond - [(or (= class1 -1) (= class2 -1)) #f] - [else (define pair (send (send (· table classRecords) get class1) get class2)) - (send this applyPositionValue 0 (· pair value1)) - (send this applyPositionValue 0 (· pair value2)) - #t])])])])] - [(3) ;; Cursive Attachment Positioning - #;(report/file 'cursive-attachment-positioning-unimplemented) - (void)] - [(4) ;; Mark to base positioning - #;(report/file 'mark-to-base-positioning-unimplemented) - (void)] - [(5) ;; Mark to ligature positioning - #;(report/file 'mark-to-ligature-positioning-unimplemented) - (void)] - [(6) ;; Mark to mark positioning - #;(report/file 'mark-to-mark-positioning-unimplemented) - (void)] - [(7) ;; Contextual positioning - #;(report/file 'contextual-positioning-unimplemented) - (void)] - [(8) ;; Chaining contextual positioning - #;(report/file 'chaining-contextual-positioning-unimplemented) - (void)] - [(9) ;; Extension positioning - #;(report/file 'extension-contextual-positioning-unimplemented) - (void)] - [else - (raise-argument-error 'GPOSProcessor:applyLookup "supported GPOS table" lookupType)])) - - - - - (define/override (applyFeatures userFeatures glyphs advances) - (super applyFeatures userFeatures glyphs advances) - #;(report/file 'fixCursiveAttachment-unimplemented) - #;(for ([i (in-range (length (· this glyphs)))]) - (send this fixCursiveAttachment i)) - #;(report/file 'fixMarkAttachment-unimplemented) - #;(send this fixMarkAttachment)) - - - ) \ No newline at end of file diff --git a/fontland/fontland/gsub-processor-test.rkt b/fontland/fontland/gsub-processor-test.rkt deleted file mode 100644 index a479398c..00000000 --- a/fontland/fontland/gsub-processor-test.rkt +++ /dev/null @@ -1,26 +0,0 @@ -#lang racket/base -(require "racket.rkt") - -(require fontland "gsub-processor.rkt" rackunit xenomorph racket/serialize describe) - -(define fira-path "assets/fira.ttf") -(define f (openSync fira-path)) -(define gsub (· f GSUB)) - -(define proc (+GSUBProcessor f gsub)) - -(check-equal? (map car (dump (· proc features))) - '(c2sc pnum liga tnum onum ss01 dlig lnum sups zero ss02 aalt subs ss03 ordn calt dnom smcp salt case numr frac mgrk)) - -(check-equal? (dict-ref (dump (· proc language)) 'featureIndexes) - '(0 14 28 42 56 70 84 98 112 136 150 164 178 192 206 220 234 248 262 276 290 304 318)) - -(check-equal? (dump (· proc scriptTag)) 'DFLT) - -(check-equal? (dict-ref (dump (· proc language)) 'featureIndexes) - '(0 14 28 42 56 70 84 98 112 136 150 164 178 192 206 220 234 248 262 276 290 304 318)) - -(check-equal? (dump (· proc languageTag)) #f) -(check-equal? (dump (· proc lookups)) empty) -(check-equal? (dump (· proc direction)) 'ltr) - diff --git a/fontland/fontland/gsub-processor.rkt b/fontland/fontland/gsub-processor.rkt deleted file mode 100644 index 330fd4a7..00000000 --- a/fontland/fontland/gsub-processor.rkt +++ /dev/null @@ -1,150 +0,0 @@ -#lang racket/base -(require "racket.rkt") - -(require "ot-processor.rkt" "glyphinfo.rkt" br/cond) -(provide (all-defined-out)) - -#| -approximates -https://github.com/mbutterick/fontkit/blob/master/src/opentype/GSUBProcessor.js -|# - -(define-subclass OTProcessor (GSUBProcessor) - - (define/override (applyLookup lookupType table) - #;(report lookupType 'GSUBProcessor:applyLookup) - (case lookupType - [(1) ;; Single Substitution - #;(report 'single-substitution) - (define index (send this coverageIndex (· table coverage))) - (cond - [(= index -1) #f] - [else (define glyph (· this glyphIterator cur)) - (send glyph id - (case (· table version) - [(1) (bitwise-and (+ (· glyph id) (· table deltaGlyphID)) #xffff)] - [(2) (send (· table substitute) get index)])) - #t])] - [(2) ;; Multiple Substitution - #;(report 'multiple-substitution) - (define index (send this coverageIndex (· table coverage))) - (cond - [(= index -1) #f] - [else (define sequence (send (· table sequences) get index)) - (send (· this glyphIterator cur) id (list-ref sequence 0)) - (set-field! ligatureComponent (· this glyphIterator cur) 0) - - (define features (· this glyphIterator cur features)) - (define curGlyph (· this glyphIterator cur)) - (define replacement (for/list ([(gid i) (in-indexed (cdr sequence))]) - (define glyph (+GlyphInfo (· this font) gid #f features)) - (set-field! shaperInfo glyph (· curGlyph shaperInfo)) - (set-field! isLigated glyph (· curGlyph isLigated)) - (set-field! ligatureComponent glyph (add1 i)) - (set-field! substituted glyph #t) - glyph)) - - (set-field! glyphs this (let-values ([(head tail) (split-at (· this glyphs) (add1 (· this glyphIterator index)))]) - (append head replacement tail))) - #t])] - - [(3) ;; Alternate substitution - #;(report 'alternate-substitution) - (define index (send this coverageIndex (· table coverage))) - (cond - [(= index -1) #f] - [else (define USER_INDEX 0) - (send (· this glyphIterator cur) id (list-ref (send (· table alternateSet) get index) USER_INDEX)) - #t])] - - [(4) ;; Ligature substitution - #;(report '---------------------------) - #;(report 'ligature-substitution) - #;(report* lookupType (· table coverage glyphs)) - (define index (send this coverageIndex (· table coverage))) - #;(report index 'forker) - (cond - [(= index -1) #f] - [(for*/or ([ligature (in-list (send (· table ligatureSets) get index))] - [matched (in-value (send this sequenceMatchIndices 1 (· ligature components)))] - #:when matched) - (define curGlyph (· this glyphIterator cur)) - - ;; Concatenate all of the characters the new ligature will represent - (define characters - (append (· curGlyph codePoints) - (append* (for/list ([index (in-list matched)]) - index - (get-field codePoints (list-ref (· this glyphs) index)))))) - - characters - ;; Create the replacement ligature glyph - (define ligatureGlyph (+GlyphInfo (· this font) (· ligature glyph) characters (· curGlyph features))) - (· ligatureGlyph id) - (set-field! shaperInfo ligatureGlyph (· curGlyph shaperInfo)) - (set-field! isLigated ligatureGlyph #t) - (set-field! substituted ligatureGlyph #t) - - (define isMarkLigature - (and (· curGlyph isMark) - (for/and ([match-idx (in-list matched)]) - (· (list-ref (· this glyphs) match-idx) isMark)))) - - (set-field! ligatureID ligatureGlyph (cond - [isMarkLigature #f] - [else (define id (· this ligatureID)) - (increment-field! ligatureID this) - id])) - - (define lastLigID (· curGlyph ligatureID)) - (define lastNumComps (length (· curGlyph codePoints))) - (define curComps lastNumComps) - (define idx (add1 (· this glyphIterator index))) - - ;; Set ligatureID and ligatureComponent on glyphs that were skipped in the matched sequence. - ;; This allows GPOS to attach marks to the correct ligature components. - (for ([matchIndex (in-list matched)]) - ;; Don't assign new ligature components for mark ligatures (see above) - (cond - [isMarkLigature (set! idx matchIndex)] - [else (while (< idx matchIndex) - (define ligatureComponent (+ curComps (- lastNumComps) (min (or (get-field ligatureComponent (list-ref (· this glyphs) idx)) 1) lastNumComps))) - (set-field! ligatureID (list-ref (· this glyphs) idx) (· ligatureGlyph ligatureID)) - (set-field! ligatureComponent (list-ref (· this glyphs) idx) ligatureComponent) - (increment! idx))]) - - (define lastLigID (· (list-ref (· this glyphs) idx) ligatureID)) - (define lastNumComps (length (· (list-ref (· this glyphs) idx) codePoints))) - (increment! curComps lastNumComps) - (increment! idx)) ;; skip base glyph - - ;; Adjust ligature components for any marks following - (when (and lastLigID (not isMarkLigature)) - (for ([i (in-range idx (length (· this glyphs)))] - #:when (= (· (list-ref (· this glyphs) idx) ligatureID) lastLigID)) - (define ligatureComponent (+ curComps (- lastNumComps) (min (or (get-field ligatureComponent (list-ref (· this glyphs) i)) 1) lastNumComps))) - (set-field! ligatureComponent (list-ref (· this glyphs) i) ligatureComponent))) - - ;; Delete the matched glyphs, and replace the current glyph with the ligature glyph - #;(report (for/list ([g (· this glyphs)]) (· g id)) 'step-a) - #;(report matched) - #;(report (· this glyphIterator index)) - (set-field! glyphs this (for*/list ([(glyph idx) (in-indexed (· this glyphs))] - [midx (in-list matched)] - #:unless (= idx midx)) - (if (= idx (· this glyphIterator index)) - ligatureGlyph - glyph))) - (set-field! glyphs (· this glyphIterator) (· this glyphs)) ; update glyph iterator to keep it in sync - #;(report (for/list ([g (· this glyphs)]) (· g id)) 'step-c) - #;(report (· this glyphIterator index)) - #t)] - [else #f])] - [(5) ;; Contextual Substitution - (send this applyContext table)] - [(6) ;; Chaining Contextual Substitution - (send this applyChainingContext table)] - [(7) ;; Extension Substitution - (send this applyLookup (· table lookupType) (· table extension))] - [else (error 'unimplemented-gsub-lookup)]))) - diff --git a/fontland/fontland/layout-engine.rkt b/fontland/fontland/layout-engine.rkt deleted file mode 100644 index 1fd57a4c..00000000 --- a/fontland/fontland/layout-engine.rkt +++ /dev/null @@ -1,131 +0,0 @@ -#lang racket/base -(require "racket.rkt") - -(require (prefix-in Script- "script.rkt") "glyph.rkt" "glyphrun.rkt" "glyph-position.rkt" "ot-layout-engine.rkt") -(provide (all-defined-out)) - -#| -approximates -https://github.com/mbutterick/fontkit/blob/master/src/layout/LayoutEngine.js -|# - -(define-subclass object% (LayoutEngine font) - (field [unicodeLayoutEngine #f] - [kernProcessor #f] - [engine - ;; Choose an advanced layout engine. - ;; We try the AAT morx table first since more - ;; scripts are currently supported because - ;; the shaping logic is built into the font. - (cond - [(· this font has-morx-table?) (error 'morx-layout-unimplemented)] - [(or (· this font has-gsub-table?) (· this font has-gpos-table?)) - #;(report/file 'starting-layout-engine) - (+OTLayoutEngine (· this font))] - [else #f])]) - - (as-methods - layout - substitute - position - hideDefaultIgnorables - isDefaultIgnorable)) - -(define/contract (layout this str-or-glyphs [features #f] - ;; Attempt to detect the script if not provided. - [script (if (string? str-or-glyphs) - (Script-forString str-or-glyphs) - (Script-forCodePoints (append-map (λ (g) (· g codePoints)) str-or-glyphs)))] - [language #f]) - (((or/c string? (listof Glyph?))) ((option/c list?) (option/c symbol?) (option/c symbol?)) . ->*m . GlyphRun?) - - (define glyphs - ;; Map string to glyphs if needed - (if (string? str-or-glyphs) - (send (· this font) glyphsForString str-or-glyphs) - str-or-glyphs)) - - #;(report*/file 'starting-layout-in-layout-engine glyphs) - (cond - [(empty? glyphs) (+GlyphRun glyphs empty)] ; Return early if there are no glyphs - [else - ;; Setup the advanced layout engine - (when (and (· this engine) #;(·? engine setup)) - (send (· this engine) setup glyphs features script language)) - - ;; Substitute and position the glyphs - (set! glyphs (send this substitute glyphs features script language)) - #;(report*/file 'end-sub glyphs) - #;(error 'stop) - #;(report/file 'ready-position) - #;(report (for/list ((g (in-list glyphs))) (· g id)) 'shecky) - (define positions (send this position glyphs features script language)) - #;(report (for/list ((p (in-list positions))) (list (· p xAdvance) (· p xOffset)))) - #;(report/file 'fired-position) - - ;; Let the layout engine clean up any state it might have - (when (and (· this engine) #;(·? this engine cleanup)) - (· this engine cleanup)) - (+GlyphRun glyphs positions)])) - - -(define (substitute this glyphs features script language) - #;((is-a?/c GlyphRun) . ->m . void?) - ;; Call the advanced layout engine to make substitutions - (when (and (· this engine) #;(· this engine substitute)) - (set! glyphs (send (· this engine) substitute glyphs features script language))) - #;(report/file glyphs) - glyphs) - - -(define/contract (position this glyphs features script language) - ((listof Glyph?) (option/c list?) (option/c symbol?) (option/c symbol?) . ->m . (listof GlyphPosition?)) - - (define positions (for/list ([glyph (in-list glyphs)]) - (make-object GlyphPosition (· glyph advanceWidth)))) - - ;; Call the advanced layout engine. Returns the features applied. - (define positioned - (and (· this engine) #;(· this engine position) - (send (· this engine) position glyphs positions features script language))) - - ;; if there is no GPOS table, use unicode properties to position marks. - ;; todo: unicode layout - #;(unless positioned - (unless (· this unicodeLayoutEngine) - (set! unicodeLayoutEngine (+UnicodeLayoutEngine (· this font)))) - (send unicodeLayoutEngine positionGlyphs glyphs positions)) - - ;; if kerning is not supported by GPOS, do kerning with the TrueType/AAT kern table - ;; todo: old style kern table - #;(when (and (or (not positioned) (not (· positioned kern))) (· this font kern)) - (unless kernProcessor - (set! kernProcessor (+KernProcessor (· this font)))) - (send kernProcessor process glyphs positions)) - - positions - ) - - -(define/contract (hideDefaultIgnorables this glyphRun) - ((is-a?/c GlyphRun) . ->m . void?) - (define space (send (· this font) glyphForCodePoint #x20)) - (define-values (new-glyphs new-positions) - (for/lists (ngs nps) - ([glyph (in-list (· glyphRun glyphs))] - [pos (in-list (· glyphRun positions))]) - (cond - [(send this isDefaultIgnorable (car (· glyph codePoints))) - (define new-pos pos) - (set-field! xAdvance new-pos 0) - (set-field! yAdvance new-pos 0) - (values space new-pos)] - [else (values glyph pos)]))) - (set-field! glyphs glyphRun new-glyphs) - (set-field! positions glyphRun new-positions)) - - -(define/contract (isDefaultIgnorable this codepoint) - (index? . ->m . boolean?) - #f ; todo: everything - ) diff --git a/fontland/fontland/ot-layout-engine.rkt b/fontland/fontland/ot-layout-engine.rkt deleted file mode 100644 index 52180821..00000000 --- a/fontland/fontland/ot-layout-engine.rkt +++ /dev/null @@ -1,86 +0,0 @@ -#lang racket/base -(require "racket.rkt") - -(require "gsub-processor.rkt" "gpos-processor.rkt" "glyphinfo.rkt" (prefix-in Shapers- "shapers.rkt") "shaping-plan.rkt") -(provide (all-defined-out)) - -#| -https://github.com/mbutterick/fontkit/blob/master/src/opentype/OTLayoutEngine.js -|# - -(define-subclass object% (OTLayoutEngine font) - (field [glyphInfos #f] - [shaper #f] - [plan #f] - [GSUBProcessor #f] - [GPOSProcessor #f]) - - #;(report/file 'starting-ot-layout-engine) - (when (· font has-gsub-table?) - (set-field! GSUBProcessor this (+GSUBProcessor font (or (· font GSUB) (error 'no-gsub-table))))) - - - (when (· font has-gpos-table?) - (set-field! GPOSProcessor this (+GPOSProcessor font (or (· font GPOS) (error 'no-gpos-table))))) - - - (define/public (setup glyphs features script language) - ;; Map glyphs to GlyphInfo objects so data can be passed between - ;; GSUB and GPOS without mutating the real (shared) Glyph objects. - (set! glyphInfos (map (λ (glyph) (+GlyphInfo (· this font) (· glyph id) (· glyph codePoints))) glyphs)) - - ;; Choose a shaper based on the script, and setup a shaping plan. - ;; This determines which features to apply to which glyphs. - (set! shaper (Shapers-choose script)) - (set! plan (+ShapingPlan (· this font) script language)) - #;(report/file shaper) - (send (make-object shaper) plan (· this plan) (· this glyphInfos) features)) - - (define/public (substitute glyphs . _) - (cond - [(· this GSUBProcessor) - #;(report/file (· this glyphInfos)) - (define new-glyphinfos - (send (· this plan) process (· this GSUBProcessor) (· this glyphInfos))) - (set! glyphInfos new-glyphinfos) ; update OTLayoutEngine state for positioning pass - #;(report/file new-glyphinfos) - ;; Map glyph infos back to normal Glyph objects - #;(report/file (for/list ([glyphInfo (in-list new-glyphinfos)]) - (send (· this font) getGlyph (· glyphInfo id) (· glyphInfo codePoints)))) - (for/list ([glyphInfo (in-list new-glyphinfos)]) - (send (· this font) getGlyph (· glyphInfo id) (· glyphInfo codePoints)))] - [else glyphs])) - - (define/public (position glyphs positions . _) - #;(report*/file glyphs positions shaper) - (define static-shaper (make-object shaper)) - (when (eq? (· static-shaper zeroMarkWidths) 'BEFORE_GPOS) - (zeroMarkAdvances positions)) - - (when GPOSProcessor - #;(report/file GPOSProcessor) - (send (· this plan) process GPOSProcessor glyphInfos positions)) - - (when (eq? (· static-shaper zeroMarkWidths) 'AFTER_GPOS) - (zeroMarkAdvances positions)) - - ;; Reverse the glyphs and positions if the script is right-to-left - (when (eq? (· this plan direction) 'rtl) - (set! glyphs (reverse glyphs)) - (set! positions (reverse positions))) - - #;(report/file (and GPOSProcessor (· GPOSProcessor features))) - (and GPOSProcessor (· GPOSProcessor features))) - - - (define/public (zeroMarkAdvances positions) - (set! positions - (for/list ([glyphInfo (in-list glyphInfos)] - [position (in-list positions)]) - (when (· glyphInfo isMark) - (dict-set*! position - 'xAdvance 0 - 'yAdvance 0)) - position))) - - ) \ No newline at end of file diff --git a/fontland/fontland/ot-processor.rkt b/fontland/fontland/ot-processor.rkt deleted file mode 100644 index ca933284..00000000 --- a/fontland/fontland/ot-processor.rkt +++ /dev/null @@ -1,252 +0,0 @@ -#lang racket/base -(require "racket.rkt") - -(require (prefix-in Script- "script.rkt") br/cond "glyph-iterator.rkt") -(provide (all-defined-out)) - -#| -https://github.com/mbutterick/fontkit/blob/master/src/opentype/OTProcessor.js -|# - - -(define DEFAULT_SCRIPTS '(DFLT dflt latn)) - -(define-subclass object% (OTProcessor font table) - (field [script #f] - [scriptTag #f] - [language #f] - [languageTag #f] - [features (mhash)] - [lookups (mhash)] - [direction #f] - [glyphIterator #f]) ; appears below - - ;; initialize to default script + language - (selectScript) - - ;; current context (set by applyFeatures) - (field [glyphs empty] - [positions empty] ; only used by GPOS - [ligatureID 1]) - - (define/public (findScript script-or-scripts) - (and (· this table scriptList) - (let ([scripts (if (pair? script-or-scripts) script-or-scripts (list script-or-scripts))]) - (for*/first ([entry (in-list (· this table scriptList))] - [s (in-list scripts)] - #:when (eq? (· entry tag) s)) - entry)))) - - - (define/public (selectScript [script #f] [language #f]) - (let/ec return! - (define changed #f) - (define entry #f) - (when (or (not (· this script)) (not (eq? script (· this scriptTag)))) - (set! entry (findScript script)) - (when script - (set! entry (findScript script))) ; ? why double dip - (when (not entry) - (set! entry (findScript DEFAULT_SCRIPTS))) - (when (not entry) - (return! (void))) - (set-field! scriptTag this (· entry tag)) - (set-field! script this (· entry script)) - (set-field! direction this (Script-direction script)) - (set-field! language this #f) - (set! changed #t)) - - (when (and (not language) (not (equal? language (· this languageTag)))) - (for/first ([lang (in-list (· this script langSysRecords))] - #:when (equal? (· lang tag) language)) - (set-field! language this (· lang langSys)) - (set-field! languageTag this (· lang tag)) - (set! changed #t))) - - (when (not (· this language)) - (set-field! language this (· this script defaultLangSys))) - - ;; Build a feature lookup table - (when changed - (set-field! features this (mhash)) - (when (· this language) - (for ([featureIndex (in-list (· this language featureIndexes))]) - (define record (list-ref (· this table featureList) featureIndex)) - (dict-set! (· this features) (· record tag) (· record feature))))))) - - - (define/public (lookupsForFeatures [userFeatures empty] [exclude #f]) - #;(report*/file 'ot-proc:lookupsForFeatures) - (sort (for*/list ([tag (in-list userFeatures)] - [feature (in-value (dict-ref (· this features) tag #f))] - #:when feature - [lookupIndex (in-list (· feature lookupListIndexes))] - #:unless (and exclude (index-of exclude lookupIndex))) - #;(report*/file tag lookupIndex) - (mhasheq 'feature tag - 'index lookupIndex - 'lookup (send (· this table lookupList) get lookupIndex))) - < #:key (λ (i) (· i index)))) - - - (define/public (applyFeatures userFeatures glyphs advances) - #;(report/file 'ot-proc:applyFeatures-part1) - (define lookups (send this lookupsForFeatures userFeatures)) - #;(report/file 'ot-proc:applyFeatures-part2) - #;(report/file (length glyphs)) - (send this applyLookups lookups glyphs advances) - #;(report*/file (length glyphs) (length (· this glyphs))) - (· this glyphs)) - - - (define/public (applyLookups lookups glyphs positions) - (set-field! glyphs this glyphs) - (set-field! positions this positions) - #;(report/file 'ot-proc:applyLookups) - #;(report (for/list ([g (· this glyphs)]) (· g id)) 'glyph-ids) - (set-field! glyphIterator this (+GlyphIterator glyphs)) - - (for* ([lookup-entry (in-list lookups)]) - (define feature (· lookup-entry feature)) - (define lookup (· lookup-entry lookup)) - #;(report 'resetting-iterator) - (send (· this glyphIterator) reset (· lookup flags)) - - (while (< (or (· this glyphIterator index) 0) (length (· this glyphs))) - #;(report/file 'start-while++++++++++++++++++) - #;(report (length (· this glyphs)) 'glyphs-length-top) - #;(report (for/list ([g (· this glyphs)]) (· g id)) 'gids-top) - #;(report (· this glyphIterator index) giterator-idx-top) - #;(report* feature (dict-keys (· this glyphIterator cur features))) - #;(report (dict-has-key? (· this glyphIterator cur features) feature)) - (cond - [(not (dict-has-key? (· this glyphIterator cur features) feature)) - (send (· this glyphIterator) next)] - [else - #;(report 'start-lookup-branch=================) - #;(report* (for/list ([g glyphs]) (· g id)) (for/list ([g (· this glyphs)]) (· g id)) (for/list ([g (· this glyphIterator glyphs)]) (· g id)) (· this glyphIterator index) (· this glyphIterator cur id) (· this glyphIterator peekIndex)) - (for/or ([table (in-list (· lookup subTables))]) - (send this applyLookup (· lookup lookupType) table)) - #;(report 'incrementing-iterator-at-bottom) - (send (· this glyphIterator) next) - #;(report* (· this glyphIterator cur) (· this glyphIterator index)) - (· this glyphIterator index)])))) - - (abstract applyLookup) - - (define/public (applyLookupList lookupRecords) - (report/file 'applyLookupList-not-implemented) - (error)) - - (define/public (coverageIndex coverage [glyph #f]) - (unless glyph (set! glyph (· this glyphIterator cur id))) - (or (case (· coverage version) - [(1) (index-of (· coverage glyphs) glyph)] - [(2) (for/first ([range (in-list (· coverage rangeRecords))] - #:when (<= (· range start) glyph (· range end))) - (+ (· range startCoverageIndex) glyph (- (· range start))))] - [else #f]) -1)) - - (define/public (match sequenceIndex sequence fn [matched #f]) - (define pos (· this glyphIterator index)) - (define glyph (send (· this glyphIterator) increment sequenceIndex)) - (define idx 0) - #;(report*/file (and (pair? sequence) (list-ref sequence idx)) glyph (and glyph (· glyph id))) - - (while (and (< idx (length sequence)) glyph (fn (list-ref sequence idx) (· glyph id))) - #;(report* 'in-match-loop idx (· glyph id)) - (when matched - (push-end! matched (· this glyphIterator index))) - (increment! idx) - (set! glyph (· this glyphIterator next))) - - (set-field! index (· this glyphIterator) pos) - (cond - [(< idx (length sequence)) #f] - [else (or matched #t)])) - - (define/public (sequenceMatchIndices sequenceIndex sequence) - (send this match sequenceIndex sequence (λ (component glyph) (= component glyph)) empty)) - - (define/public (coverageSequenceMatches sequenceIndex sequence) - #;(report 'in-coverageSequenceMatches) - (send this match sequenceIndex sequence (λ (coverage glyph) (>= (send this coverageIndex coverage glyph) 0)))) - - (define/public (getClassID glyph classDef) - (or - (case (· classDef version) - [(1) ;; Class array - (define i (- glyph (· classDef startGlyph))) - (and (>= i 0) - (< i (length (· classDef classValueArray))) - (list-ref (· classDef classValueArray) i))] - [(2) - (for/first ([range (in-list (· classDef classRangeRecord))] - #:when (<= (· range start) glyph (· range end))) - (· range class))]) - 0)) - - (define/public (applyContext table) - (report/file 'otproc:applyContext) - (case (· table version) - [(1) (define index (send this coverageIndex (· table coverage))) - (cond - [(= index -1) #f] - [else (define set (list-ref (· table ruleSets) index)) - (for/first ([rule (in-list set)] - #:when (send this sequenceMatches 1 (· rule input))) - (send this applyLookupList (· rule lookupRecords)))])] - [(2) (cond - [(= (send this coverageIndex (· table coverage)) -1) #f] - [else (define index - (send this getClassID (· this glyphIterator cur id) (· table classDef))) - (cond - [(- index -1) #f] - [else (define set (list-ref (· table classSet) index)) - (for/first ([rule (in-list set)] - #:when (send this sequenceMatches 1 (· rule classes) (· table classDef))) - (send this applyLookupList (· rule lookupRecords)))])])] - - [(3) (and (send this coverageSequenceMatches 0 (· table coverages)) - (send this applyLookupList (· table lookupRecords)))] - [else #f])) - -(define/public (applyChainingContext table) - #;(report/file 'otproc:applyChainingContext) - (case (· table version) - [(1) - #;(report 'case-1) - (define index (send this coverageIndex (· table coverage))) - (cond - [(= index -1) #f] - [else (define set (list-ref (· table chainRuleSets) index)) - (for/first ([rule (in-list set)] - #:when (and (send this sequenceMatches (- (length (· rule backtrack)) (· rule backtrack))) - (send this sequenceMatches 1 (· rule input)) - (send this sequenceMatches (add1 (length (· rule input))) (· rule lookahead)))) - (send this applyLookupList (· rule lookupRecords)))])] - [(2) - #;(report 'case-2) - (cond - [(= -1 (send this coverageIndex (· table coverage))) #f] - [else (define index (send this getClassID (· this glyphIterator cur id) (· table inputClassDef))) - (define rules (list-ref (· table chainClassSet) index)) - (cond - [(not rules) #f] - [else (for/first ([rule (in-list rules)] - #:when (and (send this classSequenceMatches (- (length (· rule backtrack)) (· rule backtrack) (· table backtrackClassDef))) - (send this classSequenceMatches 1 (· rule input) (· table inputClassDef)) - (send this classSequenceMatches (add1 (length (· rule input))) (· rule lookahead) (· table lookaheadClassDef)))) - (send this applyLookupList (· rule lookupRecords)))])])] - [(3) - #;(report 'case-3) - (and - (send this coverageSequenceMatches (- (· table backtrackGlyphCount)) (· table backtrackCoverage)) - (send this coverageSequenceMatches 0 (· table inputCoverage)) - (send this coverageSequenceMatches (· table inputGlyphCount) (· table lookaheadCoverage)) - (send this applyLookupList (· table lookupRecords)))] - [else #f])) - - ) - - \ No newline at end of file diff --git a/fontland/fontland/shapers.rkt b/fontland/fontland/shapers.rkt deleted file mode 100644 index cd45d8b3..00000000 --- a/fontland/fontland/shapers.rkt +++ /dev/null @@ -1,75 +0,0 @@ -#lang racket/base -(require "racket.rkt") - -(require "default-shaper.rkt") -(provide (all-defined-out)) - -#| -approximates -https://github.com/mbutterick/fontkit/blob/master/src/opentype/shapers/index.js -|# - -;; todo: alternative shapers -(define SHAPERS - (hasheq -; 'arab ArabicShaper ;; Arabic -; 'mong ArabicShaper ;; Mongolian -; 'syrc ArabicShaper ;; Syriac -; '|nko | ArabicShaper ;; N'Ko -; 'phag ArabicShaper ;; Phags Pa -; 'mand ArabicShaper ;; Mandaic -; 'mani ArabicShaper ;; Manichaean -; 'phlp ArabicShaper ;; Psalter Pahlavi -; -; 'hang HangulShaper ;; Hangul -; -; 'bali UniversalShaper ;; Balinese -; 'batk UniversalShaper ;; Batak -; 'brah UniversalShaper ;; Brahmi -; 'bugi UniversalShaper ;; Buginese -; 'buhd UniversalShaper ;; Buhid -; 'cakm UniversalShaper ;; Chakma -; 'cham UniversalShaper ;; Cham -; 'dupl UniversalShaper ;; Duployan -; 'egyp UniversalShaper ;; Egyptian Hieroglyphs -; 'gran UniversalShaper ;; Grantha -; 'hano UniversalShaper ;; Hanunoo -; 'java UniversalShaper ;; Javanese -; 'kthi UniversalShaper ;; Kaithi -; 'kali UniversalShaper ;; Kayah Li -; 'khar UniversalShaper ;; Kharoshthi -; 'khoj UniversalShaper ;; Khojki -; 'sind UniversalShaper ;; Khudawadi -; 'lepc UniversalShaper ;; Lepcha -; 'limb UniversalShaper ;; Limbu -; 'mahj UniversalShaper ;; Mahajani -; ';; mand UniversalShaper ;; Mandaic -; ';; mani UniversalShaper ;; Manichaean -; 'mtei UniversalShaper ;; Meitei Mayek -; 'modi UniversalShaper ;; Modi -; ';; mong UniversalShaper ;; Mongolian -; ';; 'nko ' UniversalShaper ;; N’Ko -; 'hmng UniversalShaper ;; Pahawh Hmong -; ';; phag UniversalShaper ;; Phags-pa -; ';; phlp UniversalShaper ;; Psalter Pahlavi -; 'rjng UniversalShaper ;; Rejang -; 'saur UniversalShaper ;; Saurashtra -; 'shrd UniversalShaper ;; Sharada -; 'sidd UniversalShaper ;; Siddham -; 'sinh UniversalShaper ;; Sinhala -; 'sund UniversalShaper ;; Sundanese -; 'sylo UniversalShaper ;; Syloti Nagri -; 'tglg UniversalShaper ;; Tagalog -; 'tagb UniversalShaper ;; Tagbanwa -; 'tale UniversalShaper ;; Tai Le -; 'lana UniversalShaper ;; Tai Tham -; 'tavt UniversalShaper ;; Tai Viet -; 'takr UniversalShaper ;; Takri -; 'tibt UniversalShaper ;; Tibetan -; 'tfng UniversalShaper ;; Tifinagh -; 'tirh UniversalShaper ;; Tirhuta - 'latn DefaultShaper ;; Latin - 'DFLT DefaultShaper)) ;; Default - -(define (choose script) - (dict-ref SHAPERS script DefaultShaper)) \ No newline at end of file diff --git a/fontland/fontland/shaping-plan.rkt b/fontland/fontland/shaping-plan.rkt deleted file mode 100644 index 798f442e..00000000 --- a/fontland/fontland/shaping-plan.rkt +++ /dev/null @@ -1,97 +0,0 @@ -#lang racket/base -(require "racket.rkt") - -(require (prefix-in Script- "script.rkt")) -(provide (all-defined-out)) - -#| -approximates -https://github.com/mbutterick/fontkit/blob/master/src/opentype/ShapingPlan.js -|# - -; * ShapingPlans are used by the OpenType shapers to store which -; * features should by applied, and in what order to apply them. -; * The features are applied in groups called stages. A feature -; * can be applied globally to all glyphs, or locally to only -; * specific glyphs. - -(define-subclass object% (ShapingPlan font script language) - (field [direction (Script-direction script)] - [stages empty] - [globalFeatures (mhasheq)] - [allFeatures (mhasheq)]) - - ;; Adds the given features to the last stage. - ;; Ignores features that have already been applied. - (define/public (_addFeatures features) - #;(report*/file 'stages-before stages) - (match-define (list head-stages ... last-stage) stages) - (set! stages - `(,@head-stages - ,(append last-stage - (for/list ([feature (in-list features)] - #:unless (dict-ref (· this allFeatures) feature #f)) - (dict-set! (· this allFeatures) feature #t) - feature)))) - #;(report*/file 'stages-after stages) - stages) - - ;; Adds the given features to the global list - (define/public (_addGlobal features) - (for ([feature (in-list features)]) - (dict-set! (· this globalFeatures) feature #t))) - - ;; Add features to the last stage - (define/public (add arg [global #t]) - (when (zero? (length (· this stages))) - (push-end-field! stages this empty)) - - (when (string? arg) - (set! arg (list arg))) - - (cond - [(list? arg) - (_addFeatures arg) - (when global (_addGlobal arg))] - [(dict? arg) - (define features (append (or (· arg global) empty) - (or (· arg local) empty))) - (_addFeatures features) - (when (· arg global) - (_addGlobal (· arg global)))] - [else (raise-argument-error 'ShapingPlan:add "valid arg" arg)])) - - ;; Add a new stage - (define/public (addStage arg global) - (cond - [(procedure? arg) - (push-end-field! stages this arg) - (push-end-field! stages this empty)] - [else (push-end-field! stages this empty) - (add arg global)])) - - ;; Assigns the global features to the given glyphs - (define/public (assignGlobalFeatures glyphs) - #;(report*/file glyphs (· this globalFeatures)) - (for* ([glyph (in-list glyphs)] - [feature (in-dict-keys (· this globalFeatures))]) - (dict-set! (· glyph features) feature #t))) - - ;; Executes the planned stages using the given OTProcessor - (define/public (process processor glyphs [positions #f]) - #;(report*/file 'shaping-plan-process processor) - (send processor selectScript (· this script) (· this language)) - - #;(report/file stages) - (for/fold ([glyphs glyphs]) - ([stage (in-list stages)]) - (cond - [(and (procedure? stage) (not positions)) - (stage (· this font) glyphs positions)] - [(> (length stage) 0) - #;(report*/file 'shaping-plan:applying-features processor) - #;(report/file positions) - #;(report/file (send processor applyFeatures stage glyphs positions)) - (send processor applyFeatures stage glyphs positions)])))) - -