diff --git a/quad/quad/atomize.rkt b/quad/quad/atomize.rkt index 6162a1ac..524086ec 100644 --- a/quad/quad/atomize.rkt +++ b/quad/quad/atomize.rkt @@ -3,11 +3,10 @@ (provide (all-defined-out)) (define (atomize x) - (define empty-attrs (make-attrs)) (apply vector-immutable (flatten - (cons + (list (let loop ([x x][loop-attrs default-attrs]) (cond [($shim? x) x] @@ -15,21 +14,34 @@ ;; consolidate consecutive whitespaces into single word space ;; todo: hyphenate here? then they are in the quad stream (for/list ([c (in-string x)]) - (cons ($shim empty-attrs #f #f) - ;; todo: is it feasible to box or otherwise object-ize a char - ;; so that all the quads with that char share that object - ;; and thus the measurement can be shared too? - ;; (object would have to be packaged with other typographic specs) - ((casev c - [(#\space) $space] - [(#\-) $hyphen] - [(#\u00AD) $shy] - [else $black]) loop-attrs #f c)))] + (cons + ;; installing loop attrs allows us to recognize contiguous runs later + ($shim loop-attrs #f #f) + ;; todo: is it feasible to box or otherwise object-ize a char + ;; so that all the quads with that char share that object + ;; and thus the measurement can be shared too? + ;; (object would have to be packaged with other typographic specs) + ((casev c + [(#\space) $space] + [(#\-) $hyphen] + [(#\u00AD) $shy] + [else $black]) loop-attrs #f c)))] [else (map (λ(xi) (loop xi ((quad-attrs x) . override-with . loop-attrs))) (quad-val x))])) - ($eof empty-attrs #f #f))))) ; add eof so any in-vector loop consumes all the input vals + ($eof (make-empty-attrs) #f #f))))) ; add eof so any in-vector loop consumes all the input vals + +(define (merge-runs xs) + ; combine quads with same attrs into sublists + (cond + [(empty? xs) empty] + [else + (define target (car xs)) + (define-values (matches rest) + (splitf-at (cdr xs) (λ(x) (eq? (quad-attrs target) (quad-attrs x))))) + (list* (cons target matches) (merge-runs rest))])) (module+ test (require rackunit) - (atomize (quad (make-attrs #:size 10 #:font "Eq") "ba" (line-break) "r" (quad (make-attrs #:size 8) "zam") "q\tux")) - (atomize (quad #f "snowman"))) + #;(atomize (quad (make-attrs #:size 10 #:font "Eq") "ba" (line-break) "r" (quad (make-attrs #:size 8) "zam") "q\tux")) + (define qs (atomize (quad #f "A" (page-break) "B"))) + qs) diff --git a/quad/quad/main.rkt b/quad/quad/main.rkt index 7f4ef75d..36be5fb7 100644 --- a/quad/quad/main.rkt +++ b/quad/quad/main.rkt @@ -1,11 +1,11 @@ #lang quad/dev -(require "quads.rkt" "typeset.rkt" "atomize.rkt" "render.rkt" racket/list racket/string) +(require "quads.rkt" "typeset.rkt" "atomize.rkt" "render.rkt" "render-pdf.rkt" racket/list racket/string) (provide (except-out (all-from-out quad/dev "quads.rkt") #%module-begin) (rename-out [~module-begin #%module-begin])) (define-syntax-rule (~module-begin lang-line-config-arg . args) (#%module-begin - (define main-quad (apply quad #f (add-between (list . args) "\n"))) ; at-reader splits lines, but we want one contiguous run + (define main-quad (apply quad #f (list . args))) ; at-reader splits lines, but we want one contiguous run ;; branch on config-arg to allow debug / inspection options on #lang line (define config-pieces (string-split (string-trim lang-line-config-arg))) (and (pair? config-pieces) @@ -14,6 +14,7 @@ [("in") (atomize main-quad)] [("out") (time (apply fit (atomize main-quad) config-args))] [("test") (time (debug-render (apply fit (atomize main-quad) config-args)))] + [("pdf") (time (render-pdf (apply fit (atomize main-quad) config-args)))] [else (fit (atomize main-quad))]))))) (module reader syntax/module-reader diff --git a/quad/quad/quadlang-test.rkt b/quad/quad/quadlang-test.rkt index 434a0f56..f8bb0497 100644 --- a/quad/quad/quadlang-test.rkt +++ b/quad/quad/quadlang-test.rkt @@ -1,2 +1,2 @@ #lang quad/text test 300 -Produces a list of three-element lists, where each three-element list represents a set of consecutive code points for which the Unicode standard specifies character properties. Each three-element list contains two integers and a boolean; the first integer is a starting code-point value (inclusive), the second integer is an ending code-point value (inclusive), and the boolean is #t when all characters in the code-point range have identical results for all of the character predicates above. The three-element lists are ordered in the overall result list such that later lists represent larger code-point values, and all three-element lists are separated from every other by at least one code-point value that is not specified by Unicode. \ No newline at end of file +Artful@(page-break)Belligerence \ No newline at end of file diff --git a/quad/quad/quads.rkt b/quad/quad/quads.rkt index 367fae7f..3108f00b 100644 --- a/quad/quad/quads.rkt +++ b/quad/quad/quads.rkt @@ -58,6 +58,9 @@ measure (line width) #:font [font #f]) (hasheq 'size size 'font font)) +(define (make-empty-attrs) (make-attrs)) + + (define (quad attr . xs) ;; squeeze excess whitespace out of quad args diff --git a/quad/quad/render-pdf.rkt b/quad/quad/render-pdf.rkt new file mode 100644 index 00000000..ab28b531 --- /dev/null +++ b/quad/quad/render-pdf.rkt @@ -0,0 +1,92 @@ +#lang quad/dev +(require racket/class racket/contract sugar/debug sugar/cache racket/list racket/file racket/draw data/gvector) +(provide (all-defined-out)) + +(define (world:paper-width-default) 612) +(define (world:paper-height-default) 792) + +(define renderable-quads '(word box)) + +(define (render-pdf [qs #f] [path-string "test.pdf"]) + (send* (current-ps-setup) (set-margin 0 0) (set-scaling 1.0 1.0)) + (define dc-output-port (open-output-bytes)) + (define dc (new pdf-dc% [interactive #f][use-paper-bbox #f][as-eps #f] + [output dc-output-port] + [width (world:paper-width-default)][height (world:paper-height-default)])) + (send dc start-doc "boing") + (send dc set-pen "black" 1 'solid) + (send dc set-brush "black" 'transparent) ; no fill by default + + + #;(for ([q (in-vector qs)] #:when (member (quad-name q) renderable-quads)) + (define p (quad-attr-ref q world:page-key)) + (gvector-set! page-quad-vector p (cons q (gvector-ref page-quad-vector p null)))) + + #;(for/list ([pq (in-gvector page-quad-vector)]) + (send dc start-page) + (map/send render-element (filter-not whitespace/nbsp? elements)) + (send dc end-page)) + + (define (print-status) + (send dc draw-text (format "foobar ~a" (current-milliseconds)) 0 0)) + + (define f (make-font #:face "Source Code Pro" #:size 10)) + (send dc set-font f) + + (send dc start-page) + (print-status) + + (when qs + (for/fold ([page-pos 0] + [x-pos 40] + [y-pos 40]) + ([q (in-vector qs)]) + (cond + [(eq? (quad-dim q) 'page-break) + (send dc end-page) + (send dc start-page) + (print-status) + (values page-pos 40 40)] + [(quad-printable? q) + (send dc draw-text (format "~a" (quad-val q)) x-pos y-pos) + (values page-pos (+ x-pos (quad-dim q)) y-pos)] + [else (values page-pos x-pos y-pos)]))) + + (send dc end-page) + (send dc end-doc) + + (define result-bytes (get-output-bytes dc-output-port)) + (display-to-file result-bytes path-string #:exists 'replace #:mode 'binary)) + + +#;(define (render-element q) + (cond + [(word? q) (render-word q)] + [else q])) + + +(define/caching (make-font/caching font size style weight) + (make-font #:face font #:size size #:style style #:weight weight)) + +#;(define (render-word w) + (define word-font (quad-attr-ref/parameter w world:font-name-key)) + (define word-size (quad-attr-ref/parameter w world:font-size-key)) + (define word-style (quad-attr-ref/parameter w world:font-style-key)) + (define word-weight (quad-attr-ref/parameter w world:font-weight-key)) + (define word-color (quad-attr-ref/parameter w world:font-color-key)) + (define word-background (quad-attr-ref/parameter w world:font-background-key)) + (send dc set-font (make-font/caching word-font word-size word-style word-weight)) + (send dc set-text-foreground (send the-color-database find-color word-color)) + (define background-color (send the-color-database find-color word-background)) + (if background-color ; all invalid color-string values will return #f + (send* dc (set-text-mode 'solid) (set-text-background background-color)) + (send dc set-text-mode 'transparent)) + + (define word-text (quad-car w)) + (send dc draw-text word-text (quad-attr-ref w world:x-position-key) + ;; we want to align by baseline rather than top of box + ;; thus, subtract ascent from y to put baseline at the y coordinate + (- (quad-attr-ref w world:y-position-key) (quad-attr-ref w world:ascent-key 0)) #t)) + +(module+ test + (render-pdf)) \ No newline at end of file diff --git a/quad/quad/typeset.rkt b/quad/quad/typeset.rkt index 95f6c550..4017d38e 100644 --- a/quad/quad/typeset.rkt +++ b/quad/quad/typeset.rkt @@ -33,7 +33,7 @@ [(page-break) page-start-position] [else current-posn])) - (for/fold ([current-posn (handle-break 'page-break)]) ; moves to page start position + (for/fold ([current-posn page-start-position]) ([q (in-vector qs)]) (unless (quad-dim q) (measure! q)) (cond