deckle

fontland/fontland/cff-glyph.rkt

@@ -4,7 +4,8 @@
          fontland/struct
          fontland/table-stream
          fontland/table/cff/cff-font
-         fontland/path)
+         fontland/path
+         "deque.rkt")
 (provide (all-defined-out))
 
 #|
@@ -18,23 +19,6 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
     [(< (length s) 33900) 1131]
     [else 32768]))
 
-(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-syntax-rule (case= ID [(NUMS ...) . BODY] ... [else . ELSEBODY])
   (cond
     [(memq ID (list NUMS ...)) . BODY] ...
@@ -50,7 +34,14 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
   (pos stream (hash-ref str 'offset))
 
   (define path (Path))
-  (define stack null)
+
+  (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 stack (initialize-stack))
   (define trans null)
 
   (define width #false)
@@ -79,9 +70,9 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
       (set! width (+ (shift stack) (hash-ref privateDict 'nominalWidthX)))))
 
   (define (parse-stems)
-    (when (odd? (length stack)) (check-width))
-    (set! nStems (+ nStems (arithmetic-shift (length stack) -1)))
-    (set! stack null))
+    (when (odd? (stack-length stack)) (check-width))
+    (set! nStems (+ nStems (arithmetic-shift (stack-length stack) -1)))
+    (set! stack (initialize-stack)))
 
   (define (moveTo x y)
     (when open (path-closePath path))
@@ -102,13 +93,13 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
                       23) ;; vstemhm
                      (parse-stems)]
                     [(4) ;; vmoveto
-                     (when (> (length stack) 1)
+                     (when (> (stack-length stack) 1)
                        (check-width))
                      (set! y (+ y (shift stack)))
                      (moveTo x y)]
                     [(5) ;; rlineto
                      (let loop ()
-                       (when (>= (length stack) 2)
+                       (when (>= (stack-length stack) 2)
                          (set! x (+ x (shift stack)))
                          (set! y (+ y (shift stack)))
                          (path-lineTo path x y)
@@ -117,7 +108,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
                       7) ;; vlineto
                      (define phase (= op 6))
                      (let loop ()
-                       (when (>= (length stack) 1)
+                       (when (>= (stack-length stack) 1)
                          (if phase
                              (set! x (+ x (shift stack)))
                              (set! y (+ y (shift stack))))
@@ -126,7 +117,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
                          (loop)))]
                     [(8) ;; rrcurveto
                      (let loop ()
-                       (when (> (length stack) 0)
+                       (when (> (stack-length stack) 0)
                          (define c1x (+ x (shift stack)))
                          (define c1y (+ y (shift stack)))
                          (define c2x (+ c1x (shift stack)))
@@ -153,7 +144,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
                      (cond
                        [(>= (hash-ref cff 'version) 2) (void)]
                        [else
-                        (when (> (length stack) 0)
+                        (when (> (stack-length stack) 0)
                           (check-width))
                         (when open
                           (path-closePath path)
@@ -171,7 +162,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
                      (pos stream (+ (pos stream) (arithmetic-shift (+ nStems 7) -3)))]
 
                     [(21) ;; rmoveto
-                     (when (> (length stack) 2)
+                     (when (> (stack-length stack) 2)
                        (check-width))
 
                      (set! x (+ x (shift stack)))
@@ -179,7 +170,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
                      (moveTo x y)]
 
                     [(22) ;; hmoveto
-                     (when (> (length stack) 1)
+                     (when (> (stack-length stack) 1)
                        (check-width))
 
                      (set! x (+ x (shift stack)))
@@ -187,7 +178,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
 
                     [(24) ;; rcurveline
                      (let loop ()
-                       (when (>= (length stack) 8)
+                       (when (>= (stack-length stack) 8)
                          (define c1x (+ x (shift stack)))
                          (define c1y (+ y (shift stack)))
                          (define c2x (+ c1x (shift stack)))
@@ -203,7 +194,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
 
                     [(25) ;; rlinecurve
                      (let loop ()
-                       (when (>= (length stack) 8)
+                       (when (>= (stack-length stack) 8)
                          (set! x (+ x (shift stack)))
                          (set! y (+ y (shift stack)))
                          (path-lineTo path x y)
@@ -218,11 +209,11 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
                      (path-bezierCurveTo path c1x c1y c2x c2y x y)]
 
                     [(26) ;; vvcurveto
-                     (when (odd? (length stack))
+                     (when (odd? (stack-length stack))
                        (set! x (+ x (shift stack))))
 
                      (let loop ()
-                       (when (>= (length stack) 4)
+                       (when (>= (stack-length stack) 4)
                          (define c1x x)
                          (define c1y (+ y (shift stack)))
                          (define c2x (+ c1x (shift stack)))
@@ -233,11 +224,11 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
                          (loop)))]
 
                     [(27) ;; hhcurveto
-                     (when (odd? (length stack))
+                     (when (odd? (stack-length stack))
                        (set! y (+ y (shift stack))))
 
                      (let loop ()
-                       (when (>= (length stack) 4)
+                       (when (>= (stack-length stack) 4)
                          (define c1x (+ x (shift stack)))
                          (define c1y y)
                          (define c2x (+ c1x (shift stack)))
@@ -267,7 +258,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
                       31) ;; hvcurveto
                      (define phase (= op 31))
                      (let loop ()
-                       (when (>= (length stack) 4)
+                       (when (>= (stack-length stack) 4)
                          (cond
                            [phase
                             (define c1x (+ x (shift stack)))
@@ -275,7 +266,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
                             (define c2x (+ c1x (shift stack)))
                             (define c2y (+ c1y (shift stack)))
                             (set! y (+ c2y (shift stack)))
-                            (set! x (+ c2x (if (= (length stack) 1) (shift stack) 0)))
+                            (set! x (+ c2x (if (= (stack-length stack) 1) (shift stack) 0)))
                             (path-bezierCurveTo path c1x c1y c2x c2y x y)
                             (set! phase (not phase))]
                            [else
@@ -284,7 +275,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
                             (define c2x (+ c1x (shift stack)))
                             (define c2y (+ c1y (shift stack)))
                             (set! x (+ c2x (shift stack)))
-                            (set! y (+ c2y (if (= (length stack) 1) (shift stack) 0)))
+                            (set! y (+ c2y (if (= (stack-length stack) 1) (shift stack) 0)))
                             (path-bezierCurveTo path c1x c1y c2x c2y x y)
                             (set! phase (not phase))])
                          (loop)))]
@@ -356,7 +347,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
 
                             [(29) ;; index
                              (define idx
-                               (min (max 0 (pop stack)) (- (length stack) 1)))
+                               (min (max 0 (pop stack)) (- (stack-length stack) 1)))
                              (push stack (list-ref stack idx))]
 
                             [(30) ;; roll
@@ -368,7 +359,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
                                   (when (> j 0)
                                     (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 (+ i 1) (list-ref stack i))))
                                     (set! stack (list-set stack 0 t))
                                     (loop (sub1 j))))]
                                [else
@@ -376,7 +367,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
                                   (when (< j 0)
                                     (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 i (list-ref stack (+ i 1)))))
                                     (set! stack (list-set stack (- n 1) t))
                                     (loop (add1 j))))])]
                             [(34) ;; hflex
@@ -400,9 +391,9 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
                             [(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))
+                               (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))
@@ -434,9 +425,9 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
 
                              (define pts null)
                              (for ([i (in-range 0 (add1 4))])
-                                  (set! x (+ x (shift stack)))
-                                  (set! y (+ y (shift stack)))
-                                  (push pts x y))
+                               (set! x (+ x (shift stack)))
+                               (set! y (+ y (shift stack)))
+                               (push pts x y))
 
                              (cond
                                [(> (abs (- x startx)) (abs (- y starty))) ;; horzontal
@@ -451,7 +442,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/CFFGlyph.js
                              (apply path-bezierCurveTo path (drop pts 6))]
                             [else (error (format "unknown op: 12 ~a" op))])]
                     [else (error (format "unknown op: ~a" op))])]
-            [(< op 247) (push stack (- op 139))]
+            [(< op 247) (push stack (- op 139)) stack]
             [(< op 251)
              (push stack (+ (* (- op 247) 256) (read-byte stream) 108))]
             [(< op 255)

fontland/fontland/deque.rkt

@@ -0,0 +1,122 @@
+#lang debug racket/base
+(require racket/struct racket/match)
+(provide (all-defined-out))
+
+(struct deque (start length) #:mutable
+  #:methods gen:custom-write
+  [(define write-proc
+     (make-constructor-style-printer
+      (λ (d) 'deque)
+      (λ (d) (deque->list d))))])
+(struct deque-item (val prev next) #:mutable)
+
+(define (before! di1 di2)
+  (set-deque-item-next! di1 di2)
+  (set-deque-item-prev! di2 di1))
+
+(define (insert-before! new-di di)
+  ((deque-item-prev di) . before! . new-di)
+  (new-di . before! . di))
+
+(define (remove! di)
+  ((deque-item-prev di) . before! . (deque-item-next di)))
+
+(define (push-end! d . vals)
+  (apply push-start! d #:end #true vals))
+
+(define (push-start! d #:end [end? #f] . vals)
+  (define-values (val-count first-di)
+    (for/fold ([count 0]
+               [first-di #f])
+              ([val (in-list vals)])
+      (define di (deque-item val #f #f))
+      (match (deque-start d)
+        [#false (set-deque-start! d di)
+                (before! di di)]
+        [start (di . insert-before! . start)])
+      (values (add1 count) (or first-di di))))
+  (unless (zero? val-count)
+    (unless end?
+      (set-deque-start! d first-di))
+    (set-deque-length! d (+ val-count (deque-length d)))))
+
+(define (pop-start! d #:end [end? #f])
+  (unless (zero? (deque-length d))
+    (define popdi ((if end? deque-item-prev values) (deque-start d)))
+    (begin0
+      (deque-item-val popdi)
+      (set-deque-start! d (and (> (deque-length d) 1) (deque-item-next popdi)))
+      (remove! popdi)
+      (set-deque-length! d (sub1 (deque-length d))))))
+
+(define (pop-end! d)
+  (pop-start! d #:end #true))
+
+(define (make-deque . vals)
+  (define d (deque #f 0))
+  (apply push-end! d vals)
+  d)
+
+(define (deque-ref d idx)
+  (unless (< idx (deque-length d))
+    (error 'deque-idx-too-large))
+  (for/fold ([di (deque-start d)]
+             #:result (deque-item-val di))
+            ([i (in-range idx)])
+    (deque-item-next di)))
+
+(define (deque-rotate! d [count 0])
+  (unless (or (zero? count) (< (deque-length d) 2))
+    (cond
+      [(< (abs count) (deque-length d))
+       (define opp-count ((if (positive? count) - +) (- (deque-length d) (abs count))))
+       (define new-count (if (< (abs opp-count) (abs count)) opp-count count))
+       (define dir (if (positive? new-count) deque-item-next deque-item-prev))
+       (for/fold ([di (deque-start d)]
+                  #:result (set-deque-start! d di))
+                 ([i (in-range (abs new-count))])
+         (dir di))]
+      [else (deque-rotate! d (modulo count ((if (positive? count) + -) (deque-length d))))])))
+
+(define (deque->list d)
+  (for/fold ([vals null]
+             [di (deque-start d)]
+             #:result (reverse vals))
+            ([i (in-range (deque-length d))])
+    (values (cons (deque-item-val di) vals) (deque-item-next di))))
+
+(define (list->deque xs)
+  (apply make-deque xs))
+
+(module+ test
+  (require rackunit)
+  (define d (make-deque 42))
+  (check-equal? (deque-length d) 1)
+  (push-end! d 43 44 45)
+  (check-equal? (deque-length d) 4)
+  (check-equal? (deque-ref d 0) 42)
+  (check-equal? (deque-ref d 1) 43)
+  (check-equal? (deque-ref d 2) 44)
+  (check-equal? (deque-ref d 3) 45)
+  (push-start! d 39 40 41)
+  (check-equal? (deque-length d) 7)
+  (check-equal? (deque-ref d 0) 39)
+  (check-equal? (deque-ref d 1) 40)
+  (check-equal? (deque-ref d 2) 41)
+  (check-equal? (deque-ref d 3) 42)
+  (check-equal? (pop-start! d) 39)
+  (check-equal? (pop-start! d) 40)
+  (check-equal? (pop-end! d) 45)
+  (check-equal? (pop-end! d) 44)
+  (check-equal? (deque-length d) 3)
+  (check-equal? (deque->list d) '(41 42 43))
+  (deque-rotate! d 1)
+  (check-equal? (deque->list d) '(42 43 41))
+  (deque-rotate! d -1)
+  (check-equal? (deque->list d) '(41 42 43))
+  (deque-rotate! d (deque-length d))
+  (check-equal? (deque->list d) '(41 42 43))
+  (let ([d (make-deque 90)])
+    (pop-start! d)
+    (push-end! d -1)
+    (check-equal? (deque->list d) (list -1))))