You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
425 lines
19 KiB
Racket
425 lines
19 KiB
Racket
#lang debug racket
|
|
(require racket/match
|
|
xenomorph
|
|
fontland/struct
|
|
fontland/table-stream
|
|
fontland/table/cff/cff-font
|
|
fontland/path
|
|
"deque.rkt")
|
|
(provide (all-defined-out))
|
|
|
|
#|
|
|
approximates
|
|
https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
|
|
|#
|
|
|
|
(define (bias this s)
|
|
(cond
|
|
[(< (vector-length s) 1240) 107]
|
|
[(< (vector-length s) 33900) 1131]
|
|
[else 32768]))
|
|
|
|
(define-syntax-rule (case= ID [(NUMS ...) . BODY] ... [else . ELSEBODY])
|
|
(cond
|
|
[(memq ID (list NUMS ...)) . BODY] ...
|
|
[else . ELSEBODY]))
|
|
|
|
(define (getPath this)
|
|
|
|
(define cff (get-table (glyph-font this) 'CFF_))
|
|
(define str (vector-ref (hash-ref* cff 'topDict 'CharStrings) (glyph-id this)))
|
|
(define end (+ (index-item-offset str) (index-item-length str)))
|
|
(define stream (get-table-stream (glyph-font this) 'CFF_))
|
|
(pos stream (index-item-offset str))
|
|
|
|
(define path (Path))
|
|
|
|
#|
|
|
(define (shift deque) (pop-start! deque))
|
|
(define (push deque . vals) (apply push-end! deque vals))
|
|
(define (pop deque) (pop-end! deque))
|
|
(define initialize-stack make-deque)
|
|
(define stack-length deque-length)
|
|
|#
|
|
(define-syntax-rule (shift ID)
|
|
(begin0
|
|
(car ID)
|
|
(set! ID (cdr ID))))
|
|
|
|
(define-syntax-rule (push ID VAL ...)
|
|
(begin
|
|
(set! ID (append ID (list VAL ...)))
|
|
ID))
|
|
|
|
(define-syntax-rule (pop ID)
|
|
(cond
|
|
[(> (length ID) 0)
|
|
(define-values (head last) (split-at-right ID 1))
|
|
(set! ID head)
|
|
(car last)]))
|
|
|
|
(define (initialize-stack) null)
|
|
(define stack-length length)
|
|
|
|
(define stack (initialize-stack))
|
|
(define trans null)
|
|
|
|
(define width #false)
|
|
(define nStems 0)
|
|
(define x 0)
|
|
(define y 0)
|
|
(define used-gsubrs (make-hasheq))
|
|
(define used-subrs (make-hasheq))
|
|
(define open #false)
|
|
|
|
(define gsubrs (hash-ref cff 'globalSubrIndex (vector)))
|
|
(define gsubrs-bias (bias this gsubrs))
|
|
|
|
(define privateDict (or (private-dict-for-glyph cff (glyph-id this)) (make-hasheq)))
|
|
(define subrs (hash-ref privateDict 'Subrs (vector)))
|
|
(define subrs-bias (bias this subrs))
|
|
|
|
(define (check-width)
|
|
(unless width
|
|
(set! width (+ (shift stack) (hash-ref privateDict 'nominalWidthX)))))
|
|
|
|
(define (parse-stems)
|
|
(when (odd? (stack-length stack))
|
|
(check-width))
|
|
(set! nStems (+ nStems (arithmetic-shift (stack-length stack) -1)))
|
|
(set! stack (initialize-stack))
|
|
0)
|
|
|
|
(define (moveTo x y)
|
|
(when open (path-closePath path))
|
|
(path-moveTo path x y)
|
|
(set! open #true))
|
|
|
|
(let parse ()
|
|
(let/ec return
|
|
(for ([i (in-naturals)]
|
|
#:break (>= (pos stream) end))
|
|
(define op (read-byte stream))
|
|
(cond
|
|
[(< op 32)
|
|
(case= op
|
|
[(1 ;; hstem
|
|
3 ;; vstem
|
|
18 ;; hstemhm
|
|
23) ;; vstemhm
|
|
(parse-stems)]
|
|
[(4) ;; vmoveto
|
|
(when (> (stack-length stack) 1)
|
|
(check-width))
|
|
(set! y (+ y (shift stack)))
|
|
(moveTo x y)]
|
|
[(5) ;; rlineto
|
|
(let loop ()
|
|
(when (>= (stack-length stack) 2)
|
|
(set! x (+ x (shift stack)))
|
|
(set! y (+ y (shift stack)))
|
|
(path-lineTo path x y)
|
|
(loop)))]
|
|
[(6 ;; hlineto
|
|
7) ;; vlineto
|
|
(let loop ([phase (= op 6)])
|
|
(when (>= (stack-length stack) 1)
|
|
(if phase
|
|
(set! x (+ x (shift stack)))
|
|
(set! y (+ y (shift stack))))
|
|
(path-lineTo path x y)
|
|
(loop (not phase))))]
|
|
[(8) ;; rrcurveto
|
|
(let loop ()
|
|
(when (positive? (stack-length stack))
|
|
(define c1x (+ x (shift stack)))
|
|
(define c1y (+ y (shift stack)))
|
|
(define c2x (+ c1x (shift stack)))
|
|
(define c2y (+ c1y (shift stack)))
|
|
(set! x (+ c2x (shift stack)))
|
|
(set! y (+ c2y (shift stack)))
|
|
(path-bezierCurveTo path c1x c1y c2x c2y x y)
|
|
(loop)))]
|
|
[(10) ;; callsubr
|
|
(define index (+ (pop stack) subrs-bias))
|
|
(define subr (vector-ref subrs index))
|
|
(when subr
|
|
(hash-set! used-subrs index #true)
|
|
(define p (pos stream))
|
|
(define e end)
|
|
(pos stream (index-item-offset subr))
|
|
(set! end (+ (index-item-offset subr) (index-item-length subr)))
|
|
(parse)
|
|
(pos stream p)
|
|
(set! end e))]
|
|
[(11) ;; return
|
|
(when (< (hash-ref cff 'version) 2)
|
|
(return))]
|
|
[(14) ;; endchar
|
|
(when (< (hash-ref cff 'version) 2)
|
|
(when (> (stack-length stack) 0)
|
|
(check-width))
|
|
(when open
|
|
(path-closePath path)
|
|
(set! open #false)))]
|
|
[(15) ;; vsindex
|
|
(when (< (hash-ref cff 'version) 2)
|
|
(error 'vsindex-operator-not-supported))]
|
|
[(16) ;; blend
|
|
(error 'blend-operator-not-supported)]
|
|
[(19 ;; hintmask
|
|
20) ;; cntrmask
|
|
(parse-stems)
|
|
(pos stream (+ (pos stream) (arithmetic-shift (+ nStems 7) -3)))]
|
|
[(21) ;; rmoveto
|
|
(when (> (stack-length stack) 2)
|
|
(check-width))
|
|
(set! x (+ x (shift stack)))
|
|
(set! y (+ y (shift stack)))
|
|
(moveTo x y)]
|
|
[(22) ;; hmoveto
|
|
(when (> (stack-length stack) 1)
|
|
(check-width))
|
|
(set! x (+ x (shift stack)))
|
|
(moveTo x y)]
|
|
[(24) ;; rcurveline
|
|
(let loop ()
|
|
(when (>= (stack-length stack) 8)
|
|
(define c1x (+ x (shift stack)))
|
|
(define c1y (+ y (shift stack)))
|
|
(define c2x (+ c1x (shift stack)))
|
|
(define c2y (+ c1y (shift stack)))
|
|
(set! x (+ c2x (shift stack)))
|
|
(set! y (+ c2y (shift stack)))
|
|
(path-bezierCurveTo path c1x c1y c2x c2y x y)
|
|
(loop)))
|
|
(set! x (+ x (shift stack)))
|
|
(set! y (+ y (shift stack)))
|
|
(path-lineTo path x y)]
|
|
[(25) ;; rlinecurve
|
|
(let loop ()
|
|
(when (>= (stack-length stack) 8)
|
|
(set! x (+ x (shift stack)))
|
|
(set! y (+ y (shift stack)))
|
|
(path-lineTo path x y)
|
|
(loop)))
|
|
(define c1x (+ x (shift stack)))
|
|
(define c1y (+ y (shift stack)))
|
|
(define c2x (+ c1x (shift stack)))
|
|
(define c2y (+ c1y (shift stack)))
|
|
(set! x (+ c2x (shift stack)))
|
|
(set! y (+ c2y (shift stack)))
|
|
(path-bezierCurveTo path c1x c1y c2x c2y x y)]
|
|
[(26) ;; vvcurveto
|
|
(when (odd? (stack-length stack))
|
|
(set! x (+ x (shift stack))))
|
|
(let loop ()
|
|
(when (>= (stack-length stack) 4)
|
|
(define c1x x)
|
|
(define c1y (+ y (shift stack)))
|
|
(define c2x (+ c1x (shift stack)))
|
|
(define c2y (+ c1y (shift stack)))
|
|
(set! x c2x)
|
|
(set! y (+ c2y (shift stack)))
|
|
(path-bezierCurveTo path c1x c1y c2x c2y x y)
|
|
(loop)))]
|
|
[(27) ;; hhcurveto
|
|
(when (odd? (stack-length stack))
|
|
(set! y (+ y (shift stack))))
|
|
(let loop ()
|
|
(when (>= (stack-length stack) 4)
|
|
(define c1x (+ x (shift stack)))
|
|
(define c1y y)
|
|
(define c2x (+ c1x (shift stack)))
|
|
(define c2y (+ c1y (shift stack)))
|
|
(set! x (+ c2x (shift stack)))
|
|
(set! y c2y)
|
|
(path-bezierCurveTo path c1x c1y c2x c2y x y)
|
|
(loop)))]
|
|
[(28) ;; shortint
|
|
(push stack (decode int16be stream))]
|
|
[(29) ;; callgsubr
|
|
(define index (+ (pop stack) gsubrs-bias))
|
|
(define subr (vector-ref gsubrs index))
|
|
(when subr
|
|
(hash-set! used-gsubrs index #true)
|
|
(define old-pos (pos stream))
|
|
(define old-end end)
|
|
(pos stream (index-item-offset subr))
|
|
(set! end (+ (index-item-offset subr) (index-item-length subr)))
|
|
(parse)
|
|
(pos stream old-pos)
|
|
(set! end old-end))]
|
|
[(30 ;; vhcurveto
|
|
31) ;; hvcurveto
|
|
(let loop ([phase (= op 31)])
|
|
(when (>= (stack-length stack) 4)
|
|
(cond
|
|
[phase
|
|
(define c1x (+ x (shift stack)))
|
|
(define c1y y)
|
|
(define c2x (+ c1x (shift stack)))
|
|
(define c2y (+ c1y (shift stack)))
|
|
(set! y (+ c2y (shift stack)))
|
|
(set! x (+ c2x (if (= (stack-length stack) 1) (shift stack) 0)))
|
|
(path-bezierCurveTo path c1x c1y c2x c2y x y)
|
|
(loop (not phase))]
|
|
[else
|
|
(define c1x x)
|
|
(define c1y (+ y (shift stack)))
|
|
(define c2x (+ c1x (shift stack)))
|
|
(define c2y (+ c1y (shift stack)))
|
|
(set! x (+ c2x (shift stack)))
|
|
(set! y (+ c2y (if (= (stack-length stack) 1) (shift stack) 0)))
|
|
(path-bezierCurveTo path c1x c1y c2x c2y x y)
|
|
(loop (not phase))])))]
|
|
[(12)
|
|
(println "warning: check truthiness")
|
|
(set! op (read-byte stream))
|
|
(case= op
|
|
[(3) ;; and
|
|
(push stack (if (and (pop stack) (pop stack)) 1 0))]
|
|
[(4) ;; or
|
|
(push stack (if (or (pop stack) (pop stack)) 1 0))]
|
|
[(5) ;; not
|
|
(push stack (if (pop stack) 0 1))]
|
|
[(9) ;; abs
|
|
(push stack (abs (pop stack)))]
|
|
[(10) ;; add
|
|
(push stack (+ (pop stack) (pop stack)))]
|
|
[(11) ;; sub
|
|
(push stack (- (pop stack) (pop stack)))]
|
|
[(12) ;; div
|
|
(push stack (/ (pop stack) (pop stack) 1.0))]
|
|
[(14) ;; neg
|
|
(push stack (- (pop stack)))]
|
|
[(15) ;; eq
|
|
(push stack (if (- (pop stack) (pop stack)) 1 0))]
|
|
[(18) ;; drop
|
|
(pop stack)]
|
|
[(20) ;; put
|
|
(define val (pop stack))
|
|
(define idx (pop stack))
|
|
(set! trans (list-set trans idx val))]
|
|
[(21) ;; get
|
|
(push stack (or (list-ref trans (pop stack)) 0))]
|
|
[(22) ;; ifelse
|
|
(define s1 (pop stack))
|
|
(define s2 (pop stack))
|
|
(define v1 (pop stack))
|
|
(define v2 (pop stack))
|
|
(push stack (if (<= v1 v2) s1 s2))]
|
|
[(23) ;; random
|
|
(push stack (random))]
|
|
[(24) ;; mul
|
|
(push stack (* (pop stack) (pop stack)))]
|
|
[(26) ;; sqrt
|
|
(push stack (sqrt (pop stack)))]
|
|
[(26) ;; dup
|
|
(define a (pop stack))
|
|
(push stack a a)]
|
|
[(28) ;; exch
|
|
(define a (pop stack))
|
|
(define b (pop stack))
|
|
(push stack b a)]
|
|
[(29) ;; index
|
|
(define idx
|
|
(min (max 0 (pop stack)) (- (stack-length stack) 1)))
|
|
(push stack (list-ref stack idx))]
|
|
[(30) ;; roll
|
|
(define n (pop stack))
|
|
(define j (pop stack))
|
|
(cond
|
|
[(>= j 0)
|
|
(let loop ([j j])
|
|
(when (positive? j)
|
|
(define t (list-ref stack (- n 1)))
|
|
(for [(i (in-range (- n 2) (sub1 0) -1))]
|
|
(set! stack (list-set stack (+ i 1) (list-ref stack i))))
|
|
(set! stack (list-set stack 0 t))
|
|
(loop (sub1 j))))]
|
|
[else
|
|
(let loop ([j j])
|
|
(when (negative? j)
|
|
(define t (list-ref stack 0))
|
|
(for ([i (in-range (add1 n))])
|
|
(set! stack (list-set stack i (list-ref stack (+ i 1)))))
|
|
(set! stack (list-set stack (- n 1) t))
|
|
(loop (add1 j))))])]
|
|
[(34) ;; hflex
|
|
(define c1x (+ x (shift stack)))
|
|
(define c1y y)
|
|
(define c2x (+ c1x (shift stack)))
|
|
(define c2y (+ c1y (shift stack)))
|
|
(define c3x (+ c2x (shift stack)))
|
|
(define c3y c2y)
|
|
(define c4x (+ c3x (shift stack)))
|
|
(define c4y c3y)
|
|
(define c5x (+ c4x (shift stack)))
|
|
(define c5y c4y)
|
|
(define c6x (+ c5x (shift stack)))
|
|
(define c6y c5y)
|
|
(set! x c6x)
|
|
(set! y c6y)
|
|
(path-bezierCurveTo path c1x c1y c2x c2y c3x c3y)
|
|
(path-bezierCurveTo path c4x c4y c5x c5y c6x c6y)]
|
|
[(35) ;; flex
|
|
(define pts null)
|
|
(for ([i (in-range (add1 5))])
|
|
(set! x (+ x (shift stack)))
|
|
(set! y (+ y (shift stack)))
|
|
(push pts x y))
|
|
(apply path-bezierCurveTo path (take pts 6))
|
|
(apply path-bezierCurveTo path (drop pts 6))
|
|
(shift stack)] ;; fd
|
|
[(36) ;; hflex1
|
|
(define c1x (+ x (shift stack)))
|
|
(define c1y (+ y (shift stack)))
|
|
(define c2x (+ c1x (shift stack)))
|
|
(define c2y (+ c1y (shift stack)))
|
|
(define c3x (+ c2x (shift stack)))
|
|
(define c3y c2y)
|
|
(define c4x (+ c3x (shift stack)))
|
|
(define c4y c3y)
|
|
(define c5x (+ c4x (shift stack)))
|
|
(define c5y (+ c4y (shift stack)))
|
|
(define c6x (+ c5x (shift stack)))
|
|
(define c6y c5y)
|
|
(set! x c6x)
|
|
(set! y c6y)
|
|
(path-bezierCurveTo path c1x c1y c2x c2y c3x c3y)
|
|
(path-bezierCurveTo path c4x c4y c5x c5y c6x c6y)]
|
|
[(37) ;; flex1
|
|
(define startx x)
|
|
(define starty y)
|
|
(define pts null)
|
|
(for ([i (in-range 0 (add1 4))])
|
|
(set! x (+ x (shift stack)))
|
|
(set! y (+ y (shift stack)))
|
|
(push pts x y))
|
|
(cond
|
|
[(> (abs (- x startx)) (abs (- y starty))) ;; horzontal
|
|
(set! x (shift stack))
|
|
(set! y starty)]
|
|
[else
|
|
(set! x startx)
|
|
(set! y (shift stack))])
|
|
(push pts x y)
|
|
(apply path-bezierCurveTo path (take pts 6))
|
|
(apply path-bezierCurveTo path (drop pts 6))]
|
|
[else (error (format "unknown op: 12 ~a" op))])]
|
|
[else (error (format "unknown op: ~a" op))])]
|
|
[else
|
|
|
|
(push stack (cond
|
|
[(< op 247) (- op 139)]
|
|
[(< op 251) (+ (* (- op 247) 256) (read-byte stream) 108)]
|
|
[(< op 255) (- (* (- 251 op) 256) (read-byte stream) 108)]
|
|
[else (/ (decode int32be stream) 65536.0)]))]))))
|
|
|
|
(when open (path-closePath path))
|
|
(set-cff-glyph-_usedSubrs! this used-subrs)
|
|
(set-cff-glyph-_usedGsubrs! this used-gsubrs)
|
|
(set-cff-glyph-path! this path)
|
|
path)
|