shaping up

pitfall/fontkit/default-shaper.rkt

@@ -15,6 +15,7 @@
 (define-subclass object% (DefaultShaper)
   
   (define/public (plan plan_ glyphs features)
+    (report*/file plan_ glyphs features)
     ;; Plan the features we want to apply
     (planPreprocessing plan_)
     (planFeatures plan_)
@@ -36,7 +37,10 @@
     (void))
   
 (define/public (planPostprocessing plan userFeatures)
-    (send plan add (append COMMON_FEATURES HORIZONTAL_FEATURES userFeatures)))
+  (when userFeatures
+    (unless (and (list? userFeatures) (andmap symbol? userFeatures))
+                       (raise-argument-error 'DefaultShaper:planPostprocessing "list of features" userFeatures)))
+    (send plan add (append COMMON_FEATURES HORIZONTAL_FEATURES (or userFeatures empty))))
 
   (define/public (assignFeatures plan glyphs)
     ;; todo: Enable contextual fractions

pitfall/fontkit/gpos-processor.rkt

@@ -7,5 +7,5 @@ https://github.com/mbutterick/fontkit/blob/master/src/opentype/GPOSProcessor.js
 |#
 
 (define-subclass OTProcessor (GPOSProcessor)
-
+  
   )

pitfall/fontkit/layout-engine.rkt

@@ -52,8 +52,11 @@ https://github.com/mbutterick/fontkit/blob/master/src/layout/LayoutEngine.js
        (send (· this engine) setup glyphs features script language))
 
      ;; Substitute and position the glyphs
-     (set! glyphs (send this substitute glyphs features script language))
+     ;; todo: glyph substitution
+     #;(set! glyphs (send this substitute glyphs features script language))
+     (report/file 'ready-position)
      (define positions (send this position glyphs features script language))
+     (report/file 'fired-position)
 
      ;; Let the layout engine clean up any state it might have
      (when (and (· this engine) #;(·? this engine cleanup))
@@ -69,25 +72,31 @@ https://github.com/mbutterick/fontkit/blob/master/src/layout/LayoutEngine.js
   glyphs)
 
 
-(define (position this glyphs features script language)
+(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))))
-  #|
+                      (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: implement unicodelayoutengine
-
+  ;; 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: implement kerning
-|#
+  ;; 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
   )
 
@@ -97,15 +106,15 @@ https://github.com/mbutterick/fontkit/blob/master/src/layout/LayoutEngine.js
   (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)])))
+      ([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))
 

pitfall/fontkit/ot-layout-engine.rkt

@@ -21,7 +21,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/opentype/OTLayoutEngine.js
   
   (report* 'dingdong!-starting-gpos)
   (when (· font has-gpos-table?)
-      (set-field! GPOSProcessor this (+GPOSProcessor font (· font GPOS))))
+    (set-field! GPOSProcessor this (+GPOSProcessor font (· font GPOS))))
 
 
   (define/public (setup glyphs features script language)
@@ -32,5 +32,39 @@ https://github.com/mbutterick/fontkit/blob/master/src/opentype/OTLayoutEngine.js
     ;; 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))
-    (send (· this shaper) plan (· this plan) (· this glyphInfos) features)))
+    (set! plan (+ShapingPlan (· this font) script language))
+    (report/file shaper)
+    (send (make-object shaper) plan (· this plan) (· this glyphInfos) features))
+
+  (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))))
+
+
+  (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)))
+
+  )

pitfall/fontkit/shapers.rkt

@@ -2,6 +2,11 @@
 (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

pitfall/fontkit/shaping-plan.rkt

@@ -1,9 +1,91 @@
 #lang fontkit/racket
+(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))
+
+  ;; 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)
+    (report*/file 'shaping-plan-process processor)
+    (send processor selectScript (· this script) (· this language))
+
+    (report/file stages)
+    (for ([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)
+         (send processor applyFeatures stage glyphs positions)]))))
+  
+