typesetting/pitfall/fontkit/subset.rkt

#lang fontkit/racket
(require "clone.rkt" "ttfglyphencoder.rkt" "loca.rkt" "directory.rkt" restructure)
(provide Subset CFFSubset TTFSubset)

#|
approximates
https://github.com/devongovett/fontkit/blob/master/src/subset/Subset.js
|#

(define-subclass object% (Subset font)
  (field [glyphs empty] ; list of glyph ids in the subset
         [mapping (mhash)] ; mapping of glyph ids to indexes in `glyphs`
         )

  (send this includeGlyph 0) ; always include the missing glyph in subset

  (define/public (encodeStream)
    (define s (+EncodeStream))
    (send this encode s)
    s)
  
  (as-methods
   includeGlyph))

(define/contract (includeGlyph this glyph)
  ((or/c object? index?) . ->m . index?)
  (let ([glyph (if (object? glyph) (· glyph id) glyph)])
    (hash-ref! (· this mapping) glyph
               (λ ()
                 ;; put the new glyph at the end of `glyphs`,
                 ;; and put its index in the mapping
                 (push-end-field! glyphs this glyph)
                 (sub1 (length (· this glyphs)))))))  


(define-subclass Subset (CFFSubset)
  (error 'cff-subset-unimplemented))


#|
approximates
https://github.com/mbutterick/fontkit/blob/master/src/subset/TTFSubset.js
|#

(define-subclass Subset (TTFSubset)
  (report 'in-ttf-subset)
  (field [glyphEncoder (make-object TTFGlyphEncoder)])
  (field [glyf #f]
         [offset #f]
         [loca #f]
         [hmtx #f])

  (as-methods
   _addGlyph
   encode)

  (report 'in-ttf-subset-end)
  )

(define/contract (_addGlyph this gid)
  (index? . ->m . index?)

  (report 'in-ttf-subset-addglyph)
  (define glyph (send (· this font) getGlyph gid))
  (define glyf (send glyph _decode))

  ;; get the offset to the glyph from the loca table
  (define loca (send (· this font) _getTable 'loca))
  (define curOffset (list-ref (· loca offsets) gid))
  (define nextOffset (list-ref (· loca offsets) (add1 gid)))

  (define stream (send (· this font) _getTableStream 'glyf))
  (send stream pos (+ (send stream pos) curOffset))

  (define buffer (send stream readBuffer (- nextOffset curOffset)))

  ;; if it is a compound glyph, include its components
  (when (and glyf (negative? (· glyf numberOfContours)))
    (set! buffer (+Buffer buffer))
    (for ([component (in-list (· glyf components))])
      (define gid (includeGlyph (· component glyphID)))
      (send buffer writUInt16BE gid (send component pos))))
  ;; skip variation shit

  (push-end-field! glyf this buffer)
  (report 'updating-loca)
  (hash-update! (get-field loca this) 'offsets (λ (os) (report* os (list (get-field offset this)))
                                                 (append os (list (get-field offset this)))))

  
  (report 'updating-hmtx)
  (hash-update! (get-field hmtx this) 'metrics (λ (ms) (append ms
                                                               (list (mhash 'advance (· glyph advanceWidth)
                                                                      'bearing (· (send glyph _getMetrics) leftBearing))))))

  (increment-field! offset this (bytes-length buffer))
  (sub1 (length (· this glyf))))

;; 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 stream)
  (EncodeStream? . ->m . void?)
  (report 'in-subset-encode)
  (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))])
    (report gid 'adding-gid)
    (send this _addGlyph gid))

  (report 'all-glyphs-added)

  (report (· this glyphs) 'glyphs-added)
  (define maxp (cloneDeep (send (· this font) _getTable 'maxp)))
  (hash-set! maxp 'numGlyphs (length (· this glyf)))

  ;; populate the new loca table
  (report 'doing-loca)
  (hash-update! (· this loca) 'offsets (λ (vals) (append vals (list (· this offset)))))
  (loca-preEncode (· this loca))

  (define head (cloneDeep (send (· this font) _getTable 'head)))
  (hash-set! head 'indexToLocFormat (· this loca version))
  
  (define hhea (cloneDeep (send (· this font) _getTable 'hhea)))
  (report (· this hmtx metrics))
  (hash-set! hhea 'numberOfMetrics (length (· this hmtx metrics)))

  (report 'encoding-directory)
  (send Directory encode stream
        (mhash 'tables
               (mhash
                'head head
                'hhea hhea
                'loca (· this loca)
                'maxp maxp
                'cvt_ (send (· this font) _getTable 'cvt_)
                'prep (send (· this font) _getTable 'prep)
                'glyf (· this glyf)
                'hmtx (· this hmtx)
                'fpgm (send (· this font) _getTable 'fpgm)
                )))

  (report* (bytes-length (send stream dump)))
  
  (void)
  )