progress

pitfall/fontkit/glyph-iterator.rkt

@@ -0,0 +1,61 @@
+#lang fontkit/racket
+(require br/cond)
+(provide (all-defined-out))
+
+#|
+approximates
+https://github.com/mbutterick/fontkit/blob/master/src/opentype/GlyphIterator.js
+|#
+
+(define-subclass object%
+  (GlyphIterator glyphs [flags (mhasheq)])
+  (field [index #f])
+  (reset flags)
+
+  (define/public (reset flags)
+    (set-field! flags this flags)
+    (set-field! index this 0))
+
+  (define/public (cur)
+    (and (< (· this index) (length (· this glyphs)))
+         (list-ref (· this glyphs) (· this index))))
+
+  (define/public (shouldIgnore glyph flags)
+    (or (and (· flags ignoreMarks) (· glyph isMark))
+        (and (· flags ignoreBaseGlyphs) (not (· glyph isMark)))
+        (and (· flags ignoreLigatures) (· glyph isLigature))))
+
+  (define/public (move dir)
+    (increment-field! index this dir)
+    (while (and (<= 0 (· this index))
+                (< (· this index) (length (· this glyphs)))
+                (send this shouldIgnore (list-ref (· this glyphs) (· this index)) (· this flags)))
+           (increment-field! index this dir))
+
+    (if (or (> 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 ([i (in-range (abs count))])
+      (send this move (if (negative? count) -1 1)))
+    (list-ref (· this glyphs) (· this index))))
+                

pitfall/fontkit/gpos-processor.rkt

@@ -8,8 +8,81 @@ https://github.com/mbutterick/fontkit/blob/master/src/opentype/GPOSProcessor.js
 
 (define-subclass OTProcessor (GPOSProcessor)
 
+  (define/override (applyLookup lookupType table)
+    (report/file 'starting-applyLookup)
+    (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 (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 'pair-adjustment)
+       (define nextGlyph (· this glyphIterator peek))
+       (report/file nextGlyph)
+       (cond
+         [(not nextGlyph) #f]
+         [else
+          (define index (send this coverageIndex (· table coverage)))
+          (report/file index)
+          (cond
+            [(= index -1) #f]
+            [else
+             (case (· table version)
+               [(1) ;; Adjustments for glyph pairs
+                (report/file '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)
+       (error)]
+      [(4) ;; Mark to base positioning
+       (report/file 'mark-to-base-positioning-unimplemented)
+       (error)]
+      [(5) ;; Mark to ligature positioning
+       (report/file 'mark-to-ligature-positioning-unimplemented)
+       (error)]
+      [(6) ;; Mark to mark positioning
+       (report/file 'mark-to-mark-positioning-unimplemented)
+       (error)]
+      [(7) ;; Contextual positioning
+       (report/file 'contextual-positioning-unimplemented)
+       (error)]
+      [(8) ;; Chaining contextual positioning
+       (report/file 'chaining-contextual-positioning-unimplemented)
+       (error)]
+      [(9) ;; Extension positioning
+       (report/file 'extension-contextual-positioning-unimplemented)
+       (error)]
+      [else
+       (raise-argument-error 'GPOSProcessor:applyLookup "supported GPOS table" lookupType)]))
+       
+
+       
+
   (define/override (applyFeatures userFeatures glyphs advances)
-    (error 'gpos-processor-applyFeatures-not-implemented)
-    (super applyFeatures userFeatures glyphs advances))
-  
+    (super applyFeatures userFeatures glyphs advances)
+    (for ([i (in-range (length (· this glyphs)))])
+      (send this fixCursiveAttachment i))
+    (send this fixMarkAttachment))
+
+ 
   )

pitfall/fontkit/ot-processor.rkt

@@ -1,5 +1,5 @@
 #lang fontkit/racket
-(require (prefix-in Script- "script.rkt"))
+(require (prefix-in Script- "script.rkt") br/cond "glyph-iterator.rkt")
 (provide (all-defined-out))
 
 #|
@@ -16,7 +16,8 @@ https://github.com/mbutterick/fontkit/blob/master/src/opentype/OTProcessor.js
          [languageTag #f]
          [features (mhash)]
          [lookups (mhash)]
-         [direction #f]) ; appears below
+         [direction #f]
+         [glyphIterator #f]) ; appears below
 
   ;; initialize to default script + language
   (selectScript)
@@ -32,7 +33,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/opentype/OTProcessor.js
            (for*/first ([entry (in-list (· this table scriptList))]
                         [s (in-list scripts)]
                         #:when (eq? (· entry tag) s))
-                       entry))))
+             entry))))
 
 
   (define/public (selectScript [script #f] [language #f])
@@ -56,9 +57,9 @@ https://github.com/mbutterick/fontkit/blob/master/src/opentype/OTProcessor.js
       (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)))
+          (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)))
@@ -68,10 +69,62 @@ https://github.com/mbutterick/fontkit/blob/master/src/opentype/OTProcessor.js
         (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 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 (report/file (· 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) (report*/file (· i index)))))
+      
 
   (define/public (applyFeatures userFeatures glyphs advances)
-    (error 'ot-processor-applyFeatures-not-implemented)))
+    (report/file 'ot-proc:applyFeatures-part1)
+    (define lookups (send this lookupsForFeatures userFeatures))
+    (report/file 'ot-proc:applyFeatures-part2)
+    (send this applyLookups lookups glyphs advances))
 
+  
+  (define/public (applyLookups lookups glyphs positions)
+    (set-field! glyphs this glyphs)
+    (set-field! positions this positions)
+    (report/file 'ot-proc:applyLookups)
+    (set-field! glyphIterator this (+GlyphIterator glyphs))
+    (for* ([lookup-entry (in-list lookups)])
+      (define feature (dict-ref lookup-entry 'feature))
+      (define lookup (dict-ref lookup-entry 'lookup))
+      (send (· this glyphIterator) reset (· lookup flags))
+      (while (< (· this glyphIterator index) (length glyphs))
+             (when (dict-has-key? (· this glyphIterator cur features)  feature)
+               (for/first ([table (in-list (· lookup subTables))])
+                 (send this applyLookup (· lookup lookupType) table)))
+             (send (· this glyphIterator) next))))
+
+  (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))
+                       
+
+  )