From fa1374984d869495f69a611ab2e8e3d11e74d107 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 9 Jun 2017 11:23:26 -0700 Subject: [PATCH] redo --- pitfall/pitfall/fontkit.rkt | 45 ++++++++++++++--------------- pitfall/pitfall/racket.rkt | 3 +- pitfall/restructure/streamcoder.rkt | 28 +++++++++++++++++- pitfall/restructure/struct.rkt | 26 ++++++++--------- pitfall/sugar/port.rkt | 7 +++++ 5 files changed, 71 insertions(+), 38 deletions(-) create mode 100644 pitfall/sugar/port.rkt diff --git a/pitfall/pitfall/fontkit.rkt b/pitfall/pitfall/fontkit.rkt index 631ddf8b..663117ce 100644 --- a/pitfall/pitfall/fontkit.rkt +++ b/pitfall/pitfall/fontkit.rkt @@ -4,19 +4,22 @@ (define-runtime-path charter-path "test/assets/charter.ttf") -;; approximates -;; https://github.com/devongovett/fontkit/blob/master/src/TTFFont.js +#| +approximates +https://github.com/devongovett/fontkit/blob/master/src/TTFFont.js +|# ;; This is the base class for all SFNT-based font formats in fontkit. ;; It supports TrueType, and PostScript glyphs, and several color glyph formats. -(define-subclass object% (TTFFont [stream (open-input-bytes #"")]) - (super-new) +(define-subclass object% (TTFFont stream) (when stream (unless (input-port? stream) (raise-argument-error 'TTFFont "input port" stream))) + (unless (member (bytes->string/latin-1 (peek-bytes 4 0 stream)) + (list "true" "OTTO" "\u0\u1\u0\u0")) + (raise 'probe-fail)) (port-count-lines! stream) ;; skip variationCoords - (field [_directoryPos (let-values ([(l c p) (port-next-location stream)]) - p)] + (field [_directoryPos (port-position stream)] [_tables (mhash)] [_glyphs (mhash)] [_layoutEngine #f]) @@ -25,9 +28,9 @@ (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))) + (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)) @@ -37,13 +40,6 @@ (define/public (_decodeDirectory) (set! directory (directory-decode stream (mhash '_startOffset 0))) directory) - - (define/public (probe buffer) - (and - (member (bytes->string/latin-1 (subbytes buffer 0 4)) - (list "true" "OTTO" "\u0\u1\u0\u0")) - 'TTF-format)) - (field [ft-library (FT_Init_FreeType)]) (field [ft-face (FT_New_Face ft-library charter-path 0)]) @@ -208,7 +204,7 @@ ;; for now, just use UTF-8 (define codepoints (map char->integer (string->list string))) (for/list ([cp (in-list codepoints)]) - (send this glyphForCodePoint cp))) + (send this glyphForCodePoint cp))) ;; Maps a single unicode code point to a Glyph object. @@ -231,7 +227,7 @@ (string? number? . ->m . number?) (/ (* size (for/sum ([c (in-string str)]) - (measure-char-width this c))) (· this unitsPerEm))) + (measure-char-width this c))) (· this unitsPerEm))) ;; Register font formats @@ -254,11 +250,14 @@ ((bytes?) ((or/c string? #f)) . ->* . any/c) (or (for*/first ([format (in-list formats)] - #:when (send (make-object format) probe buffer)) - (define font (make-object format (open-input-bytes buffer))) - (if postscriptName - (send font getFont postscriptName) ; used to select from collection files like TTC - font)) + ;; rather than use a `probe` function, + ;; just try making a font with each format and see what happens + [font (in-value (with-handlers ([(curry eq? 'probe-fail) (λ (exn) #f)]) + (make-object format (open-input-bytes buffer))))] + #:when font) + (if postscriptName + (send font getFont postscriptName) ; used to select from collection files like TTC + font)) (error 'fontkit:create "unknown font format"))) diff --git a/pitfall/pitfall/racket.rkt b/pitfall/pitfall/racket.rkt index ad960192..9cb42828 100644 --- a/pitfall/pitfall/racket.rkt +++ b/pitfall/pitfall/racket.rkt @@ -22,7 +22,8 @@ sugar/class sugar/js sugar/dict - sugar/stub) + sugar/stub + sugar/port) (module reader syntax/module-reader #:language 'pitfall/racket diff --git a/pitfall/restructure/streamcoder.rkt b/pitfall/restructure/streamcoder.rkt index 8c374374..abe99bf9 100644 --- a/pitfall/restructure/streamcoder.rkt +++ b/pitfall/restructure/streamcoder.rkt @@ -13,4 +13,30 @@ (when stream (unless (is-a? stream REncodeStream) (raise-argument-error 'encode "REncodeStream" stream))) - (inner (void) encode stream . args))) \ No newline at end of file + (inner (void) encode stream . args))) + +#| +(define-subclass RBase (RStreamcoder) + + (define/overment (decode stream-or-port . args) + (unless (or (is-a? stream RDecodeStream) (input-port? stream-or-port)) + (raise-argument-error 'decode "RDecodeStream or input port" stream)) + (define stream (and stream-or-port + (if (input-port? stream-or-port) + (make-object RDecodeStream stream-or-port) + stream-or-port))) + (inner (void) decode stream . args)) + + (define/overment (encode stream-or-port . args) + (report stream-or-port) + (when stream-or-port + (unless (or (is-a? stream-or-port REncodeStream) (output-port? stream-or-port)) + (raise-argument-error 'encode "REncodeStream or output port" stream-or-port))) + + (define stream (and stream-or-port + (if (output-port? stream-or-port) + (make-object REncodeStream stream-or-port) + stream-or-port))) + + (inner (void) encode stream . args))) +|# \ No newline at end of file diff --git a/pitfall/restructure/struct.rkt b/pitfall/restructure/struct.rkt index bd4a1fcc..f5deb00d 100644 --- a/pitfall/restructure/struct.rkt +++ b/pitfall/restructure/struct.rkt @@ -11,7 +11,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee (field [key-index (map car assocs)] [fields (mhash)]) (for ([(k v) (in-dict assocs)]) - (hash-set! fields k v)) + (hash-set! fields k v)) (define/override (decode stream [parent #f] [length 0]) (define res (_setup stream parent length)) @@ -21,26 +21,26 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee (define/override (encode stream val [parent #f]) (for ([key (in-list key-index)]) - (send (hash-ref fields key) encode stream (hash-ref val key)))) + (send (hash-ref fields key) encode stream (hash-ref val key)))) (define/private (_setup stream parent length) (define res (mhasheq)) ;; define hidden properties #;(hash-set! res '_props - (mhasheq 'parent (mhasheq 'value parent) - '_startOffset (mhasheq 'value (· stream pos)) - '_currentOffset (mhasheq 'value 0 'writable #t) - '_length (mhasheq 'value length))) + (mhasheq 'parent (mhasheq 'value parent) + '_startOffset (mhasheq 'value (· stream pos)) + '_currentOffset (mhasheq 'value 0 'writable #t) + '_length (mhasheq 'value length))) res) (define/private (_parseFields stream res field) - (for ([key (in-list key-index)]) - (define hashvalue (hash-ref fields key)) - (define val - (if (procedure? hashvalue) - (hashvalue res) - (send hashvalue decode stream res))) - (hash-set! res key val))) + (for ([key (in-list key-index)]) + (define hashvalue (hash-ref fields key)) + (define val + (if (procedure? hashvalue) + (hashvalue res) + (send hashvalue decode stream res))) + (hash-set! res key val))) ) diff --git a/pitfall/sugar/port.rkt b/pitfall/sugar/port.rkt new file mode 100644 index 00000000..fe4cf839 --- /dev/null +++ b/pitfall/sugar/port.rkt @@ -0,0 +1,7 @@ +#lang racket/base +(require racket/port) +(provide (all-defined-out) (all-from-out racket/port)) + +(define (port-position ip) + (define-values (line col pos) (port-next-location ip)) + pos) \ No newline at end of file