dirty as hell

pitfall/fontkit/directory.rkt

@@ -7,32 +7,74 @@
 https://github.com/mbutterick/fontkit/blob/master/src/tables/directory.js
 |#
 
-(define TableEntry (make-object Struct
-                     (dictify 'tag (+String 4)
-                              'checkSum uint32be
-                              'offset uint32be
-                              'length uint32be)))
+(define-subclass Struct (RTableEntry)
+  (define/override (preEncode this-val stream)
+    (when (eq? (hash-ref this-val 'tag) 'cvt)
+        (hash-set! this-val 'tag '|cvt |))))
+
+(define TableEntry (+RTableEntry
+                    (dictify 'tag (+String 4)
+                             'checkSum uint32be
+                             'offset uint32be
+                             'length uint32be)))
+
+(define (pad-to-32bit bstr)
+  (define mod (modulo (bytes-length bstr) 4))
+  (if (positive? mod)
+      (bytes-append bstr (make-bytes (- 4 mod) 0))
+      bstr))
 
 (define-subclass Struct (RDirectory)
   (define/override (process this-res stream)
     ;; in `restructure` `process` method, `res` is aliased as `this`
     (define new-tables-val (mhash))
     (for ([table (in-list (· this-res tables))])
-      (hash-set! new-tables-val (string->symbol (string-trim (· table tag))) table))
+         (hash-set! new-tables-val (string->symbol (string-trim (· table tag))) table))
     (hash-set! this-res 'tables new-tables-val))
 
   (define/override (preEncode this-val stream)
-    (define tables empty)
-    (for ([(tag table) (in-hash (· this-val tables))])
-      (when table
-        (push-end! tables
-                   (mhash
-                    'tag tag
-                    'checkSum 0
-                    'offset 16909060 ; todo \1\2\3\4 octal-be
-                    'length (let ([tag (hash-ref table-decoders tag (λ () (raise-argument-error 'directory:preEncode "valid table tag" tag)))])
-                              (send tag size table))))))
-    (define numTables (length tables))
+    
+    (define offset-ks (mhash))
+    (define table-header-hash (mhash))
+    (for ([(tag table) (in-hash (· this-val tables))]
+          [i (in-naturals)]
+          #:unless (hash-has-key? table-header-hash i))
+         (hash-set! table-header-hash i
+                    (let/cc k
+                              (hash-set! offset-ks i k)
+                              (mhash
+                               'tag tag))))
+
+    (define table-headers (for/list ([i (in-range (length (hash-keys table-header-hash)))])
+                                    (hash-ref table-header-hash i)))
+    (define table-header-size (+ 12 (* (length table-headers) (send TableEntry size))))
+
+    (define data-hash (mhash))
+    (for/fold ([current-offset table-header-size])
+              ([(table-header i) (in-indexed table-headers)])
+      (define tag (· table-header tag))
+      (define bstr (hash-ref! data-hash i
+                              (λ ()
+                                (define es (+EncodeStream))
+                                (define tag-codec (hash-ref table-codecs tag (λ () (raise-argument-error 'directory:preEncode "valid table tag" tag))))
+                                (send tag-codec encode es (hash-ref (· this-val tables) tag))
+                                (send es dump))))
+      (define 32-bit-bstr (pad-to-32bit bstr))
+
+      (cond
+        [(hash-ref offset-ks i #f) => (λ (k) (hash-remove! offset-ks i)
+                                        (k (mhash
+                                            'tag (· table-header tag)
+                                            'checkSum 0
+                                            'offset current-offset
+                                            'length (bytes-length bstr))))]
+        [else
+         (+ (bytes-length 32-bit-bstr) current-offset)]))
+    
+    (hash-set! this-val 'data (for/list ([i (in-range (length (hash-keys data-hash)))])
+                                        (pad-to-32bit (hash-ref data-hash i))))
+
+    (define numTables (length table-headers))
     (define searchRange (* (floor (log (/ numTables (log 2)))) 16))
     (define entrySelector (floor (/ searchRange (log 2))))
     (define rangeShift (- (* numTables 16) searchRange))
@@ -40,29 +82,32 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/directory.js
     (hash-set*! this-val
                 'tag "true"
                 'numTables numTables
-                'tables tables
+                'tables table-headers
                 'searchRange searchRange
                 'entrySelector rangeShift
-                'rangeShift rangeShift)
-    ))
+                'rangeShift rangeShift)))
       
 
-(define Directory (make-object RDirectory
-                    (dictify 'tag (+String 4)
-                             'numTables uint16be
-                             'searchRange uint16be
-                             'entrySelector uint16be
-                             'rangeShift uint16be
-                             'tables (+Array TableEntry 'numTables))))
+(define Directory (+RDirectory
+                   (dictify 'tag (+String 4)
+                            'numTables uint16be
+                            'searchRange uint16be
+                            'entrySelector uint16be
+                            'rangeShift uint16be
+                            'tables (+Array TableEntry 'numTables)
+                            
+                            ;; we don't know what tables we might get
+                            ;; so we represent as generic Buffer type,
+                            ;; and convert the tables to bytes manually in preEncode
+                            'data (+Array (+Buffer)))))
 
 (define (directory-decode ip [options (mhash)])
   (send Directory decode (+DecodeStream (port->bytes ip))))
 
-
-(test-module
- (define ip (open-input-file charter-path))
- (define decoded-dir (deserialize (read (open-input-file charter-directory-path))))
- (check-equal? (directory-decode ip) decoded-dir)
- (define es (+EncodeStream))
- ;(send Directory encode es decoded-dir)
- )
+#;(test-module
+   (define ip (open-input-file charter-path))
+   (define decoded-dir (deserialize (read (open-input-file charter-directory-path))))
+   (check-equal? (directory-decode ip) decoded-dir)
+   (define es (+EncodeStream))
+   ;(send Directory encode es decoded-dir)
+   )

pitfall/fontkit/font.rkt

@@ -32,7 +32,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
     (hash-ref! _tables table-tag (_decodeTable table-tag))) ; get table from cache, load if not there
 
   (define/public (_decodeTable table-tag)
-    (define table-decoder (hash-ref table-decoders table-tag
+    (define table-decoder (hash-ref table-codecs table-tag
                                     (λ () (raise-argument-error '_decodeTable "decodable table" table-tag))))
     (define offset (· (hash-ref (· directory tables) table-tag) offset))
     (define len (· (hash-ref (· directory tables) table-tag) length))
@@ -280,6 +280,8 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
  (check-exn exn:fail:contract? (λ () (send f _getTable 'nonexistent-table-tag)))
  #;(send f _getTable 'maxp)
  (define subset (make-object TTFSubset f))
- (send subset encode (+EncodeStream))
-(file->bytes "../pitfall/test/out.bin")
+ (define es (+EncodeStream))
+ (send subset encode es)
+ (define ds (+DecodeStream (send es dump)))
+ (send Directory decode ds)
  )

pitfall/fontkit/subset.rkt

@@ -67,7 +67,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/subset/TTFSubset.js
 
   ;; include all the glyphs used in the document
   (for ([gid (in-list (· this glyphs))])
-    (send this _addGlyph gid))
+       (send this _addGlyph gid))
 
   (define maxp (cloneDeep (send (· this font) _getTable 'maxp)))
   (hash-set! maxp 'numGlyphs (length (· this glyf)))
@@ -87,7 +87,6 @@ https://github.com/mbutterick/fontkit/blob/master/src/subset/TTFSubset.js
         (mhash 'tables
                (mhash
                 'head head
-                #|
                 'hhea hhea
                 'loca (· this loca)
                 'maxp maxp
@@ -96,12 +95,11 @@ https://github.com/mbutterick/fontkit/blob/master/src/subset/TTFSubset.js
                 'glyf (· this glyf)
                 'hmtx (· this hmtx)
                 'fpgm (send (· this font) _getTable 'fpgm)
-|#
                 )))
 
-  (report* (bytes-length (send stream dump)) (send stream dump))
+  #;(report* (bytes-length (send stream dump)) (send stream dump))
   
-  (unfinished)
+  (void)
   )
 
 

pitfall/fontkit/tables.rkt

@@ -9,4 +9,4 @@
                     (test-module (require (submod TABLE-ID-STRING test) ...))
                     (define ID (make-hasheq (map cons (list 'TABLE-ID ...) (list TABLE-ID ...)))))))
 
-(define-table-decoders table-decoders maxp hhea head loca prep fpgm hmtx cvt glyf)
+(define-table-decoders table-codecs maxp hhea head loca prep fpgm hmtx cvt glyf)

pitfall/restructure/buffer.rkt

@@ -1,5 +1,5 @@
 #lang restructure/racket
-(require "number.rkt" "utils.rkt")
+(require "number.rkt" "utils.rkt" "stream.rkt")
 (provide (all-defined-out))
 
 #|
@@ -19,11 +19,16 @@ https://github.com/mbutterick/restructure/blob/master/src/Buffer.coffee
         (bytes-length val)
         (resolveLength _length val parent)))
 
-  (define/override (encode stream buf parent)
+  (define/override (encode stream buf [parent #f])
     (when (Number? _length)
       (send _length encode stream (bytes-length buf)))
     (send stream writeBuffer buf)))
 
+(define (bytes->Buffer bstr)
+  (define b (+Buffer (bytes-length bstr)))
+  (send b decode (+DecodeStream bstr))
+  b)
+
 
 #;(test-module
  (require "stream.rkt")

pitfall/restructure/string.rkt

@@ -29,7 +29,8 @@ https://github.com/mbutterick/restructure/blob/master/src/String.coffee
     
     (send stream write bytes))
 
-  (define/override (size str)
+  (define/override (size [str-in #f])
+    (define str (or str-in (make-string strlen #\x)))
     (define es (+EncodeStream))
     (encode es str)
     (bytes-length (send es dump))))