typesetting/fontland/fontland/subset.rkt

#lang debug racket/base
(require racket/serialize
         racket/contract
         racket/class
         racket/list
         racket/match
         sugar/unstable/class
         sugar/unstable/dict
         sugar/unstable/js
         "table/loca.rkt"
         "directory.rkt"
         "helper.rkt"
         fontland/glyph
         fontland/ttf-glyph
         xenomorph)

(provide subset +subset ttf-subset +ttf-subset subset-include-glyph encode-to-port)

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

; glyphs = list of glyph ids in the subset
; mapping = of glyph ids to indexes in `glyphs`
(struct subset (font glyphs mapping) #:transparent #:mutable)

(define (+subset font [glyphs empty] [mapping (mhash)])
  (define ss (subset font glyphs mapping))
  (subset-include-glyph ss 0)
  ss)

(define (encode-to-port ss)
  (define p (open-output-bytes))
  (encode ss p)
  p)

(define (subset-include-glyph ss glyph-or-gid)
  #;((or/c object? index?) . ->m . index?)
  (define glyph (if (object? glyph-or-gid)
                    (· glyph-or-gid id)
                    glyph-or-gid))
  (hash-ref! (subset-mapping ss) glyph
             (λ ()
               ;; put the new glyph at the end of `glyphs`,
               ;; and put its index in the mapping
               (set-subset-glyphs! ss (append (subset-glyphs ss) (list glyph)))
               (sub1 (length (subset-glyphs ss))))))  

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


#|
;; no CFF font support for now

(define-subclass Subset (CFFSubset)
  #R (· this font)
  (field [cff (send (· this font) _getTable 'CFF_)])
  (unless (· this cff) (error 'not-a-cff-font))
  (field [charStrings #f]
         [subrs #f])

  (as-methods
   subsetCharstrings
   #;subsetSubrs
   #;subsetFontdict
   #;createCIDFontdict
   #;addString
   #;encode))

(define/contract (subsetCharstrings this)
  (->m void?)
  (set-field! charStrings this null)
  (define gsubrs (make-hash))
  (for ([gid (in-list (· this glyphs))])
    (push-end-field! charStrings this (· this cff getCharString gid))
    (define glyph (· this font getGlyph gid))
    (define path (· glyph path)) ; this causes the glyph to be parsed
    (for ([subr (in-list (· glyph _usedGsubrs))])
      (hash-set! gsubrs subr #true)))
  (set-field! this gsubrs (send this subsetSubrs (· this cff globalSubrIndex) gsubrs))
  (void))


|#

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

(struct ttf-subset subset (glyf offset loca hmtx) #:transparent #:mutable)

(define (+ttf-subset font [glyphs empty] [mapping (mhash)]
                    [glyf #f]
                    [offset #f]
                    [loca #f]
                    [hmtx #f])
  (define ss (ttf-subset font glyphs mapping glyf offset loca hmtx))
  (subset-include-glyph ss 0)
  ss)

(define (ttf-subset-add-glyph ss gid)
  #;(index? . ->m . index?)

  (define glyph (send (subset-font ss) getGlyph gid))
  ;; glyph-decode unpacks the `glyf` table data corresponding to a certin gid.
  ;; here, it's not necessary for non-composite glyphs
  ;; because they just get copied entirely into the subset.
  ;; it's just used to detect composite glyphs and handle them specially.
  ;; so an optimization would be to detect composite / noncomposite without full glyph-decode.
  (define ttf-glyf-data (glyph-decode glyph))

  ;; get the offset to the glyph from the loca table
  (match-define (list curOffset nextOffset) (take (drop (· (subset-font ss) loca offsets) gid) 2))

  (define port (send (subset-font ss) _getTableStream 'glyf))
  (pos port (+ (pos port) curOffset))

  (define buffer (read-bytes  (- nextOffset curOffset) port))

  ;; if it is a compound glyph, include its components
  (when (and ttf-glyf-data (negative? (· ttf-glyf-data numberOfContours)))
    (for ([ttf-glyph-component (in-list (· ttf-glyf-data components))])
      (define gid (subset-include-glyph ss (ttf-glyph-component-glyph-id ttf-glyph-component)))
      ;; note: this (ttf-glyph-component-pos component) is correct. It's a field of a Component object, not a port
      (bytes-copy! buffer (ttf-glyph-component-pos ttf-glyph-component) (send uint16be encode #f gid))))
  
  ;; skip variation shit

  (set-ttf-subset-glyf! ss (append (ttf-subset-glyf ss) (list buffer)))
  (hash-update! (ttf-subset-loca ss) 'offsets (λ (os)
                                                 (append os (list (ttf-subset-offset ss)))))

  (hash-update! (ttf-subset-hmtx ss) 'metrics (λ (ms) (append ms
                                                               (list (mhash 'advance (glyph-advance-width glyph)
                                                                            'bearing (· (get-glyph-metrics glyph) leftBearing))))))
  
  (set-ttf-subset-offset! ss (+ (ttf-subset-offset ss) (bytes-length buffer)))
  (sub1 (length (ttf-subset-glyf ss))))

;; 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 (clone-deep val)  (deserialize (serialize val)))

(define (encode ss port)
  #;(output-port? . ->m . void?)
  
  (set-ttf-subset-glyf! ss empty)
  (set-ttf-subset-offset! ss 0)
  (set-ttf-subset-loca! ss (mhash 'offsets empty))
  (set-ttf-subset-hmtx! ss (mhash 'metrics empty 'bearings empty))

  ;; include all the glyphs used in the document
  ;; not using `in-list` because we need to support adding more
  ;; glyphs to the array as component glyphs are discovered & enqueued
  (for ([idx (in-naturals)]
        #:break (= idx (length (subset-glyphs ss))))
    (define gid (list-ref (subset-glyphs ss) idx))
    (ttf-subset-add-glyph ss gid))

  (define maxp (clone-deep (· (subset-font ss) maxp to-hash)))
  (dict-set! maxp 'numGlyphs (length (ttf-subset-glyf ss)))
  
  ;; populate the new loca table
  (dict-update! (ttf-subset-loca ss) 'offsets (λ (vals) (append vals (list (ttf-subset-offset ss)))))
  (loca-pre-encode (ttf-subset-loca ss))

  (define head (clone-deep (· (subset-font ss) head to-hash)))
  (dict-set! head 'indexToLocFormat (· (ttf-subset-loca ss) version))
  
  (define hhea (clone-deep (· (subset-font ss) hhea to-hash)))
  (dict-set! hhea 'numberOfMetrics (length (· (ttf-subset-hmtx ss) metrics)))

  
  (send Directory encode port
        (mhash 'tables
               (mhash
                'head head
                'hhea hhea
                'loca (ttf-subset-loca ss)
                'maxp maxp
                'cvt_ (· (subset-font ss) cvt_)
                'prep (· (subset-font ss) prep)
                'glyf (ttf-subset-glyf ss)
                'hmtx (ttf-subset-hmtx ss)
                'fpgm (· (subset-font ss) fpgm))))

  #;(report* (bytes-length (send stream dump)) (send stream dump))
  #;(report* (bytes-length (file->bytes "out.bin")) (file->bytes "out.bin"))
  
  (void)
  )