starting to decode

pitfall/binparser/main.rkt

@@ -31,18 +31,24 @@
     (raise (binary-problem (format "byte string length ~a" count) bs)))
   bs)
 
-(define (bytes->integer len x)
+(define (bytes->integer len x #:endian [big-endian? #f])
   (when (< (bytes-length x) len) (raise-argument-error 'bytes->integer "too short" x))
   (cond
     [(= len 1) (bytes-ref x 0)]
-    [else (integer-bytes->integer x #f #f)]))
+    [else (define signed #f)
+          (integer-bytes->integer x signed big-endian?)]))
 
-(define (integer->bytes len x)
+(define (integer->bytes len x #:endian [big-endian? #f])
   (case len
     [(1) (bytes x)]
-    [(2 4 8) (integer->integer-bytes x len #f #f)]
+    [(2 4 8) (define signed #f)
+          (integer->integer-bytes x len signed big-endian?)]
     [else (raise-argument-error 'integer->bytes "byte length 1 2 4 8" len)]))
 
+(define integer/be? #t)
+(define (integer/be->bytes len x) (integer->bytes len x #:endian #t))
+(define (bytes->integer/be len x) (bytes->integer len x #:endian #t))
+
 (require racket/format)
 (define (hex? x) (and (list? x) (andmap string? x)))
 (define (int->hex int) (~r int #:base 16 #:min-width 2 #:pad-string "0"))
@@ -134,6 +140,8 @@
    (λ (x)
      (define-values (input-proc output-proc)
        (case-proc type
+                  [integer/be? (values (curry bytes->integer/be count)
+                                    (curry integer/be->bytes count))]
                   [integer? (values (curry bytes->integer count)
                                     (curry integer->bytes count))]
                   [string/ascii? (values bytes->ascii ascii->bytes)]

pitfall/pitfall/clone.rkt

@@ -0,0 +1,6 @@
+#lang racket
+(provide cloneDeep)
+
+(define (cloneDeep val)
+  (parameterize ([print-graph #t])
+    (read (open-input-string (~s val)))))

pitfall/pitfall/directory.rkt

@@ -1,5 +1,60 @@
 #lang pitfall/racket
 (provide (all-defined-out))
 
-(define (directory-decode . xs)
-  'boom)
+(require binparser)
+
+(define uint32be (:bytes 4 #:type integer/be?))
+(define uint16be (:bytes 2 #:type integer/be?))
+(define hexbytes (:bytes 4 #:type hex?))
+(define (string-rule count) (:bytes count #:type string/ascii?))
+
+(define-macro (:seq ([ID BINDING] ...) . BODY)
+  #'(λ (p) (let* ([ID (BINDING p)] ...) (begin . BODY) (list (cons 'ID ID) ...))))
+
+(define TableEntry (:seq
+                    ([tag (string-rule 4)]
+                     [checkSum uint32be]
+                     [offset uint32be]
+                     [length uint32be])))
+
+(define Directory (:seq
+                   ([tag hexbytes]
+                    [numTables uint16be]
+                    [searchRange uint16be]
+                    [entrySelector uint16be]
+                    [rangeShift uint16be]
+                    [tables (:repeat numTables TableEntry)])
+                   (unless (equal? tag "00 01 00 00")
+                     (error 'epic-fail))))
+
+(define (directory-decode ip [options (mhash)])
+  (Directory ip))
+
+
+(define ip (open-input-file "test/assets/Charter.ttf"))
+(directory-decode ip (mhash '_startOffset 0))
+(module+ test
+  (require rackunit)
+  (define ip (open-input-file "test/assets/Charter.ttf"))
+  (check-equal?
+   (directory-decode ip (mhash '_startOffset 0))
+   '((tag . "00 01 00 00")
+     (numTables . 14)
+     (searchRange . 128)
+     (entrySelector . 3)
+     (rangeShift . 96)
+     (tables
+      ((tag . "OS/2") (checkSum . 2351070438) (offset . 360) (length . 96))
+      ((tag . "VDMX") (checkSum . 1887795202) (offset . 1372) (length . 1504))
+      ((tag . "cmap") (checkSum . 1723761408) (offset . 2876) (length . 1262))
+      ((tag . "cvt ") (checkSum . 10290865) (offset . 4592) (length . 26))
+      ((tag . "fpgm") (checkSum . 106535991) (offset . 4140) (length . 371))
+      ((tag . "glyf") (checkSum . 1143629849) (offset . 4620) (length . 34072))
+      ((tag . "head") (checkSum . 4281190895) (offset . 236) (length . 54))
+      ((tag . "hhea") (checkSum . 132056097) (offset . 292) (length . 36))
+      ((tag . "hmtx") (checkSum . 3982043058) (offset . 456) (length . 916))
+      ((tag . "loca") (checkSum . 2795817194) (offset . 38692) (length . 460))
+      ((tag . "maxp") (checkSum . 50135594) (offset . 328) (length . 32))
+      ((tag . "name") (checkSum . 2629707307) (offset . 39152) (length . 2367))
+      ((tag . "post") (checkSum . 1670855689) (offset . 41520) (length . 514))
+      ((tag . "prep") (checkSum . 490862356) (offset . 4512) (length . 78))))))

pitfall/pitfall/fontkit.rkt

@@ -13,6 +13,8 @@
   (super-new)
   (when stream (unless (input-port? stream)
                  (raise-argument-error 'TTFFont "input port" stream)))
+  (port-count-lines! stream)
+  ;; skip variationCoords
   (field [_directoryPos (let-values ([(l c p) (port-next-location stream)])
                           p)]
          [_tables (mhash)]
@@ -22,6 +24,16 @@
   (field [directory #f])
   (send this _decodeDirectory)
 
+  #;(define/public (_getTable tag)
+    (unless (member (· directory  tag) _tables)
+      (raise-argument-error '_getTable "table that exists" (· table tag)))
+    (hash-set! _tables (· table tag) (_decodeTable table)))
+
+  (define/public (_decodeTable table)
+    (define-values (l c p) (port-next-location stream))
+    (displayln 'whee)
+    (set-port-next-location! stream l c p))
+
   (define/public (_decodeDirectory)
     (set! directory (directory-decode stream (mhash '_startOffset 0)))
     directory)
@@ -264,6 +276,8 @@
   (check-false (· f has-gpos-table?))
   (check-true (send f has-table? #"cmap"))
   (check-equal? (· f lineGap) 0)
+  f
+  #;(send f _getTable 'maxp)
   #;(· f createSubset)
   
 

pitfall/pitfall/helper.rkt

@@ -1,5 +1,5 @@
 #lang racket/base
-(require (for-syntax racket/base racket/syntax) racket/class sugar/list racket/list (only-in br/list push! pop!) racket/string racket/format racket/contract)
+(require (for-syntax racket/base racket/syntax br/syntax) br/define racket/class sugar/list racket/list (only-in br/list push! pop!) racket/string racket/format racket/contract)
 (provide (all-defined-out) push! pop!)
 
 (define-syntax (· stx)
@@ -42,7 +42,7 @@
 
 (define (listify kvs)
   (for/list ([slice (in-list (slice-at kvs 2))])
-    (cons (first slice) (second slice))))
+            (cons (first slice) (second slice))))
 (define-syntax-rule (define-hashifier id hasher) (define (id . kvs) (hasher (listify kvs))))
 (define-hashifier mhash make-hash)
 (define-hashifier mhasheq make-hasheq)
@@ -185,4 +185,29 @@
 (define (layout? x)
   (and (hash? x) (hash-has-key? x 'glyphs) (hash-has-key? x 'positions)))
 
-(define index? (and/c (not/c negative?) integer?))
+(define index? (and/c (not/c negative?) integer?))
+
+
+(define-macro (define-stub-stop ID)
+  (with-pattern ([ERROR-ID (suffix-id (prefix-id (syntax-source #'this) ":" #'ID) ":not-implemented")])
+                #'(define (ID . args)
+                    (error 'ERROR-ID))))
+
+(provide (rename-out [define-stub-stop define-stub]))
+
+(define-macro (define-stub-go ID)
+  (with-pattern ([ERROR-ID (suffix-id (prefix-id (syntax-source #'this) ":" #'ID) ":not-implemented")])
+                #'(define (ID . args)
+                    (displayln 'ERROR-ID))))
+
+(define-macro (define-unfinished (ID . ARGS) . BODY)
+  (with-pattern ([ID-UNFINISHED (suffix-id (prefix-id (syntax-source #'this) ":" #'ID) ":unfinished")])
+                #'(define (ID . ARGS)
+                    (begin . BODY)
+                    (error 'ID-UNFINISHED))))
+
+
+(define-macro (unfinished)
+  (with-pattern ([ID-UNFINISHED (prefix-id (syntax-source caller-stx) ":" (syntax-line caller-stx) ":" #'unfinished)])
+                #'(error 'ID-UNFINISHED)))
+  

pitfall/pitfall/racket.rkt

@@ -1,4 +1,6 @@
 #lang racket/base
+(require (for-syntax racket/base br/syntax))
+(provide (for-syntax (all-from-out racket/base br/syntax)))
 (provide (all-from-out racket/base) r+p)
 
 (define-syntax-rule (r+p id ...) (begin (require id ...) (provide (all-from-out id ...))))
@@ -15,7 +17,8 @@
      racket/contract
      racket/list
      racket/port
-     racket/function)
+     racket/function
+     br/define)
 
 (module reader syntax/module-reader
   #:language 'pitfall/racket

pitfall/pitfall/subset.rkt

@@ -1,4 +1,5 @@
 #lang pitfall/racket
+(require "clone.rkt" "ttfglyphencoder.rkt")
 (provide Subset CFFSubset TTFSubset)
 
 ;; approximates
@@ -6,7 +7,7 @@
 
 (define-subclass object% (Subset font)
   (super-new)
-  (field [glyphs empty] ; list of glyphs in the subset
+  (field [glyphs empty] ; list of glyph ids in the subset
          [mapping (mhash)] ; mapping of glyph ids to indexes in `glyphs`
          )
 
@@ -36,11 +37,39 @@
 
 (define-subclass Subset (TTFSubset)
   (super-new)
+  (field [glyphEncoder (make-object TTFGlyphEncoder)])
+  (field [glyf #f]
+         [offset #f]
+         [loca #f]
+         [hmtx #f])
 
   (as-methods
+   _addGlyph
    encode)
+
+  
   )
 
+(define-stub-go _addGlyph)
+
+;; tables required by PDF spec:
+;; head, hhea, loca, maxp, cvt, prep, glyf, hmtx, fpgm
+;; additional tables required for standalone fonts:
+;; name, cmap, OS/2, post
+
 (define/contract (encode this)
   (->m input-port?)
-  (· this font stream))
+  (set-field! glyf this empty)
+  (set-field! offset this 0)
+  (set-field! loca this (mhash 'offsets empty))
+  (set-field! hmtx this (mhash 'metrics empty 'bearings empty))
+
+  ;; include all the glyphs used in the document
+  (for ([gid (in-list (· this glyphs))])
+       (send this _addGlyph gid))
+
+  (define maxp (cloneDeep (· this font maxp)))
+
+  (unfinished)
+  )
+

pitfall/pitfall/ttfglyphencoder.rkt

@@ -0,0 +1,13 @@
+#lang pitfall/racket
+(provide TTFGlyphEncoder)
+
+(define-subclass object% (TTFGlyphEncoder)
+  (super-new)
+
+  (as-methods
+   encodeSimple
+   _encodePoint))
+
+(define-stub encodeSimple)
+
+(define-stub _encodePoint)