start GPOS

pitfall/fontkit/GPOS-test.rkt

@@ -0,0 +1,7 @@
+#lang fontkit/racket
+(require "font.rkt" "directory.rkt" "gpos.rkt")
+
+(define f (openSync fira-path))
+(define ds (send f _getTableStream 'GPOS))
+
+(send GPOS decode ds)

pitfall/fontkit/GPOS.rkt

@@ -0,0 +1,195 @@
+#lang fontkit/racket
+(require restructure br/cond "opentype.rkt")
+(provide (all-defined-out))
+
+#|
+approximates
+https://github.com/mbutterick/fontkit/blob/master/src/tables/GPOS.js
+|#
+
+(define ValueFormat (+Bitfield uint16be '(xPlacement yPlacement xAdvance yAdvance xPlaDevice yPlaDevice xAdvDevice yAdvDevice)))
+
+(define types
+  (mhash
+   'xPlacement int16be
+   'yPlacement int16be
+   'xAdvance int16be
+   'yAdvance int16be
+   'xPlaDevice uint16be ;; pointer
+   'yPlaDevice uint16be ;; pointer
+   'xAdvDevice uint16be ;; pointer
+   'yAdvDevice uint16be)) ;; pointer
+
+(define-subclass RestructureBase (ValueRecord [key 'valueFormat])
+
+  (define/public (buildStruct parent)
+    (define struct parent)
+    (while (and (not (hash-ref struct (· this key))) (hash-ref struct parent))
+           (hash-set! struct (hash-ref struct parent)))
+
+    (cond
+      [(not (hash-ref struct (· this key))) (void)]
+      [else (define fields (mhash))
+            (hash-set! fields 'rel (λ () (hash-ref struct (error '_startOffset-not-available))))
+
+            (define format (hash-ref struct (· this key)))
+            (for ([key (in-list format)])
+                 (when (hash-ref format key)
+                   (hash-set! fields key (hash-ref types key))))
+            (+Struct fields)]))
+
+  (define/override (size val ctx)
+    (send (buildStruct ctx) size val ctx))
+
+  
+  (define/override (decode stream parent)
+    (define res (send (buildStruct parent) decode stream parent))
+    (hash-remove! res 'rel)
+    res)
+
+  (define/override (encode . args)
+    (error 'GPOS-encode-not-implemented)))
+
+(define PairValueRecord (+Struct
+                         (dictify
+                          'secondGlyph uint16be
+                          'value1 (+ValueRecord 'valueFormat1)
+                          'value2 (+ValueRecord 'valueFormat2))))
+
+(define PairSet (+Array PairValueRecord uint16be))
+
+(define Class2Record (+Struct
+                      (dictify
+                       'value1 (+ValueRecord 'valueFormat1)
+                       'value2 (+ValueRecord 'valueFormat2))))
+
+(define Anchor (+VersionedStruct uint16be
+                                 (dictify
+                                  ;; Design units only
+                                  1 (dictify 'xCoordinate int16be
+                                             'yCoordinate int16be)
+
+                                  ;; Design units plus contour point
+                                  2 (dictify 'xCoordinate int16be
+                                             'yCoordinate int16be
+                                             'anchorPoint uint16be)
+                                  ;; Design units plus Device tables
+                                  3 (dictify 'xCoordinate int16be
+                                             'yCoordinate int16be
+                                             'xDeviceTable uint16be  ; pointer
+                                             'yDeviceTable uint16be)))) ; pointer
+
+(define EntryExitRecord (+Struct
+                         (dictify 'entryAnchor uint16be ; pointer
+                                  'exitAnchor uint16be))) ; pointer
+
+(define MarkRecord (+Struct
+                    (dictify 'class uint16be
+                             'markAnchor uint16be)))
+
+(define MarkArray (+Array MarkRecord uint16be))
+
+(define BaseRecord (+Array uint16be)) ; pointer
+
+(define BaseArray (+Array BaseRecord uint16be))
+
+(define ComponentRecord (+Array uint16be)) ; pointer
+(define LigatureAttach (+Array ComponentRecord uint16be))
+(define LigatureArray (+Array uint16be uint16be)) ; pointer
+
+(define-subclass VersionedStruct (GPOSLookup-VersionedStruct))
+(define GPOSLookup
+  (+GPOSLookup-VersionedStruct
+   (λ (parent) (· parent lookupType))
+   (dictify
+    ;; Single Adjustment
+    1 (+VersionedStruct uint16be
+                        (dictify
+                         ;; Single positioning value
+                         1 (dictify
+                            'coverage uint16be ; pointer
+                            'valueFormat ValueFormat
+                            'value (+ValueRecord))
+                         2 (dictify
+                            'coverage uint16be ; pointer
+                            'valueFormat ValueFormat
+                            'valueCount uint16be
+                            'values (+LazyArray (+ValueRecord) 'valueCount))))
+    ;; Pair Adjustment Positioning
+    2 (+VersionedStruct uint16be
+                        (dictify
+                         ;; Adjustments for glyph pairs
+                         1 (dictify
+                            'coverage uint16be ; pointer
+                            'valueFormat1 ValueFormat
+                            'valueFormat2 ValueFormat
+                            'pairSetCount uint16be
+                            'pairSets (+LazyArray uint16be 'pairSetCount)) ; pointer
+
+                         ;; Class pair adjustment
+                         2 (dictify
+                            'coverage uint16be ; pointer
+                            'valueFormat1 ValueFormat
+                            'valueFormat2 ValueFormat
+                            'classDef1 uint16be ; pointer
+                            'classDef2 uint16be ; pointer
+                            'class1Count uint16be
+                            'class2Count uint16be
+                            'classRecords (+LazyArray (+LazyArray Class2Record 'class2Count) 'class1Count))))
+
+    ;; Cursive Attachment Positioning
+    3 (dictify
+       'format uint16be
+       'coverage uint16be ; pointer
+       'entryExitCount uint16be
+       'entryExitRecords (+Array EntryExitRecord 'entryExitCount))
+
+    ;; MarkToBase Attachment Positioning
+    4 (dictify
+       'format uint16be
+       'markCoverage uint16be ; pointer
+       'baseCoverage uint16be ; pointer
+       'classCount uint16be
+       'markArray uint16be ; pointer
+       'baseArray uint16be) ; pointer
+
+    ;; MarkToLigature Attachment Positioning
+    5 (dictify
+       'format uint16be
+       'markCoverage uint16be ; pointer
+       'ligatureCoverage uint16be ; pointer
+       'classCount uint16be
+       'markArray uint16be ; pointer
+       'ligatureArray uint16be)
+
+    ;; MarkToMark Attachment Positioning
+    6 (dictify
+       'format uint16be
+       'mark1Coverage uint16be ; pointer
+       'mark2Coverage uint16be ; pointer
+       'classCount uint16be
+       'mark1Array uint16be ; pointer
+       'mark2Array uint16be) ; pointer
+
+    7 Context ;; Contextual positioning
+    8 ChainingContext ;; Chaining contextual positioning
+
+    ;; Extension positioning
+    9 (dictify
+       'posFormat uint16be
+       'lookupType uint16be ;; cannot also be 9
+       'extension uint32be) ; pointer
+    )))
+
+;; Fix circular reference
+;; GPOSLookup.versions[9].extension.type = GPOSLookup;
+
+(define gpos-common-dict (dictify 'scriptList uint16be ; pointer
+                                  'featureList uint16be ; pointer
+                                  'lookupList uint16be)) ; pointer
+
+(define-subclass VersionedStruct (GPOS-VersionedStruct))
+(define GPOS (+GPOS-VersionedStruct uint32be
+                               (dictify
+                                #x00010000 gpos-common-dict
+                                #x00010001 (append gpos-common-dict (dictify 'featureVariations uint32be))))) ; pointer

pitfall/fontkit/font.rkt

@@ -282,8 +282,9 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
 
 
 
-(define/contract (openSync filename [postscriptName #f])
-  ((string?) ((option/c string?)) . ->* . TTFFont?)
+(define/contract (openSync str-or-path [postscriptName #f])
+  (((or/c path? string?)) ((option/c string?)) . ->* . TTFFont?)
+  (define filename (if (path? str-or-path) (path->string str-or-path) str-or-path))
   (define buffer (file->bytes filename))
   (create buffer filename postscriptName))
 

pitfall/fontkit/opentype.rkt

@@ -0,0 +1,62 @@
+#lang fontkit/racket
+(require restructure)
+(provide (all-defined-out))
+
+(define LookupRecord (+Struct
+                      (dictify
+                       'sequenceIndex uint16be
+                       'lookupListIndex uint16be)))
+
+(define Context
+  (+VersionedStruct
+   uint16be
+   (dictify
+    ;; Simple context
+    1 (dictify
+       'coverage uint16be ; pointer
+       'ruleSetCount uint16be
+       'ruleSets (+Array uint16be 'ruleSetCount)) ; pointer
+
+    ;; Class-based context
+    2 (dictify
+       'coverage uint16be ; pointer
+       'classDef uint16be ; pointer
+       'classSetCnt uint16be
+       'classSet (+Array uint16be 'classSetCnt)) ; pointer
+
+    3 (dictify
+       'glyphCount uint16be
+       'lookupCount uint16be
+       'coverages (+Array uint16be 'glyphCount) ; pointer
+       'lookupRecords (+Array LookupRecord 'lookupCount)))))
+
+
+(define ChainingContext
+  (+VersionedStruct
+   uint16be
+   (dictify
+    ;; Simple context glyph substitution
+    1 (dictify
+       'coverage uint16be ; pointer
+       'chainCount uint16be
+       'chainRuelSets (+Array uint16be 'chainCount)) ; pointer
+
+    ;; Class-based chaining context
+    2 (dictify
+       'coverage uint16be ; pointer
+       'backtrackClassDef uint16be ; pointer
+       'inputClassDef uint16be ; pointer
+       'lookaheadClassDef uint16be ; pointer
+       'chainCount uint16be
+       'chainClassSet (+Array uint16be 'chainCount)) ; pointer
+
+    ;; Coverage-based chaining context
+    3 (dictify
+       'backtrackGlyphCount uint16be
+       'backtrackCoverage (+Array uint16be 'backtrackGlyphCount) ; pointer 
+       'inputGlyphCount uint16be
+       'inputCoverage (+Array uint16be 'inputGlyphCount) ; pointer
+       'lookaheadGlyphCount uint16be
+       'lookaheadCoverage (+Array uint16be 'lookaheadGlyphCount) ; pointer
+       'lookupCount uint16be
+       'lookupRecords (+Array LookupRecord 'lookupCount)))))

pitfall/restructure/base.rkt

@@ -0,0 +1,14 @@
+#lang racket/base
+(require racket/class)
+(provide (all-defined-out))
+
+(define RestructureBase
+  (class object%
+    (super-new)    
+    (abstract decode)
+    (abstract encode)
+    (abstract size)
+    (define/public (process . args) (void))
+    (define/public (preEncode . args) (void))))
+
+(define (RestructureBase? x) (is-a? x RestructureBase))

pitfall/restructure/helper.rkt

@@ -1,17 +1,6 @@
 #lang racket/base
-(require (for-syntax racket/base br/syntax) racket/class br/define)
-(provide (all-defined-out))
-
-(define RestructureBase
-  (class object%
-    (super-new)    
-    (abstract decode)
-    (abstract encode)
-    (abstract size)
-    (define/public (process . args) (void))
-    (define/public (preEncode . args) (void))))
-
-(define (RestructureBase? x) (is-a? x RestructureBase))
+(require (for-syntax racket/base br/syntax) racket/class br/define "base.rkt")
+(provide (all-defined-out) (all-from-out "base.rkt"))
 
 
 (define-macro (test-module . EXPRS)

pitfall/restructure/main.rkt

@@ -1,6 +1,7 @@
 #lang restructure/racket
 
-(r+p "number.rkt"
+(r+p "base.rkt"
+     "number.rkt"
      "struct.rkt"
      "string.rkt"
      "array.rkt"

pitfall/restructure/struct.rkt

@@ -108,8 +108,8 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
 (define-subclass Struct (VersionedStruct version-resolver [versions (dictify)])
   (unless ((disjoin integer? procedure? RestructureBase?) version-resolver)
     (raise-argument-error 'VersionedStruct "integer, function, or Restructure object" version-resolver))
-  (unless (and (dict? versions) (andmap dict? (map cdr versions)))
-    (raise-argument-error 'VersionedStruct "dict of dicts" versions))
+  (unless (and (dict? versions) (andmap (λ (val) (or (dict? val) (Struct? val))) (map cdr versions)))
+    (raise-argument-error 'VersionedStruct "dict of dicts or Structs" versions))
   (inherit-field fields key-index)
   (field [forced-version #f])
   

pitfall/sugar/contract.rkt

@@ -1,5 +1,25 @@
 #lang racket/base
-(require racket/contract)
+(require racket/contract racket/class)
 (provide (all-defined-out))
 
-(define (option/c x) (or/c #f x)) 
+(define (option/c x) (or/c #f x))
+
+(module+ main
+
+  (define-syntax-rule (define/public/contract (ID . ARGS) CONTRACT . BODY)
+    (define/public (ID . ARGS)
+      (define/contract (ID . ARGS)
+        CONTRACT . BODY)
+      (ID . ARGS)))
+
+  (define c% (class object%
+               (super-new)
+             
+               (define/public/contract (add x y)
+                 (integer? integer? . -> . integer?)
+                 (+ x y))))
+
+
+  (define c (make-object c%))
+
+  (send c add 12 21))