setup first page

main
Matthew Butterick 3 years ago
parent bc78ac9824
commit 52d33803de

@ -13,23 +13,25 @@
(define-pass (make-drawing-insts qs)
#:pre (list-of has-position?)
#:post (list-of $drawing-inst?)
(flatten
(list ($doc 'start) ($page 'start)
(apply append
(let ([current-font #false])
(for/list ([q (in-list qs)])
(append
(match (quad-ref q :font-path)
[(== current-font) null]
[font-path
(set! current-font font-path)
(list ($font font-path))])
(cond
[(quad? q)
(cond
[(eq? boq q) (list ($doc-start))]
[(eq? eoq q) (list ($doc-end))]
[(bop-quad? q) (list ($page-start (quad-ref q :page-width) (quad-ref q :page-height)))]
[(eop-quad? q) (list ($page-end))]
[(quad? q)
(append
(match (quad-ref q :font-path)
[(== current-font) null]
[font-path
(set! current-font font-path)
(list ($font font-path))])
(if (pair? (quad-elems q))
(list ($move (quad-posn q)) ($text (char->integer (car (string->list (car (quad-elems q)))))))
null)]
[else (error 'render-unknown-thing)]))))
($page 'end) ($doc 'end))))
null))]
[else (error 'render-unknown-thing)])))))
(define valid-tokens '(doc-start doc-end page-start page-end text move set-font))
@ -45,8 +47,8 @@
[($move ($point x y)) (list y x 'move)]
[($text charint) (list charint 'text)]
[($font path-string) (list path-string 'set-font)]
[($doc 'start) '(doc-start)]
[($doc 'end) '(doc-end)]
[($page 'start) (list ymax xmax 'page-start)]
[($page 'end) '(page-end)]
[($doc-start) '(doc-start)]
[($doc-end) '(doc-end)]
[($page-start width height) (list height width 'page-start)]
[($page-end) '(page-end)]
[_ (error 'unknown-drawing-inst)])) " ")) "\n"))

@ -103,10 +103,21 @@
(module+ test
(mark-text-runs smlqs))
(define-pass (append-bop-and-eop qs)
;; force document to have one page
#:pre (list-of simple-quad?)
#:post (λ (qs) (match qs
[(list (? bop-quad?) (? simple-quad?) ... (? eop-quad?)) #true]
[_ #false]))
(define bop (bop-quad #f (quad-attrs (first qs)) null #f))
(define eop (eop-quad #f (quad-attrs (last qs)) null #f))
(append (list bop) qs (list eop)))
(define-pass (append-boq-and-eoq qs)
;; attach the boq and eoq signals
#:pre (list-of simple-quad?)
#:post (λ (qs) (match qs
[(list (? boq-quad?) (? simple-quad?) ... (? eoq-quad?)) #true]
[(list (== boq) (? simple-quad?) ... (== eoq)) #true]
[_ #false]))
(set-quad-attrs! boq (quad-attrs (first qs)))
(set-quad-attrs! eoq (quad-attrs (last qs)))

@ -48,10 +48,8 @@
;; (e.g., cascading font sizes)
;; because once we linearize, that information is gone.
linearize
(print-pass append-boq-and-eoq)
;; post-linearization resolutions & parsings =============
;; post-linearization resolutions & parsings =============
mark-text-runs
merge-adjacent-strings
split-whitespace
@ -59,8 +57,10 @@
fill-missing-font-path
remove-font-without-char
insert-fallback-font
append-bop-and-eop
append-boq-and-eoq
layout
(print-pass make-drawing-insts)
make-drawing-insts
stackify))
(module+ main
@ -79,8 +79,8 @@
(match (test-compile "X")
[(? string? insts)
(displayln insts)
(render insts #:using text-renderer)
(render insts #:using drr-renderer)
#;(render insts #:using text-renderer)
#;(render insts #:using drr-renderer)
(render insts #:using (html-renderer (build-path (find-system-path 'desk-dir) "test.html")))
#;(render-to-pdf drawing-insts)
]))

@ -52,7 +52,9 @@
[else attrs]))])
(quad-constructor tag attrs elems #false)))
(define (quad-ref q-or-qs key [default-val #false] #:set-default-if-missing [set-default-if-missing? #false])
(define (quad-ref q-or-qs key
[default-val (λ () (error (format "quad-ref: no value for key ~a" key)))]
#:set-default-if-missing [set-default-if-missing? #false])
(unless (attr-key? key)
(raise-argument-error 'quad-ref "attr-key?" key))
(define hash-reffer (if set-default-if-missing? hash-ref! hash-ref))
@ -110,9 +112,11 @@
(module+ test
(define q (make-quad #:tag 'div #:attrs (make-hasheq '((hello . "world"))) #:elems (list "fine"))))
(struct boq-quad quad ())
(define boq (boq-quad #f (make-hasheq) null #f))
(struct eoq-quad quad ())
(define eoq (eoq-quad #f (make-hasheq) null #f))
(define boq (let ()
(struct boq-quad quad ())
(boq-quad #f (make-hasheq) null #f)))
(define eoq (let ()
(struct eoq-quad quad ())
(eoq-quad #f (make-hasheq) null #f)))
(struct bop-quad quad ())
(struct eop-quad quad ())

@ -42,8 +42,8 @@
void
(λ (x y) (set! current-loc (make-rectangular x y)))
(λ ()
(unless (pair? results)
(error 'text-renderer-failed))
#;(unless (pair? results)
(error 'text-renderer-failed))
(for-each displayln results)))))
(require racket/gui)
@ -70,7 +70,8 @@
(send dc set-text-foreground "black")))
void
(λ (charint)
(send dc draw-text (string (integer->char charint)) (real-part current-loc) (imag-part current-loc)))
(when dc
(send dc draw-text (string (integer->char charint)) (real-part current-loc) (imag-part current-loc))))
(λ (ps)
;; racket/draw can't load arbitrary user fonts from a path
;; https://github.com/racket/racket/issues/1348
@ -100,12 +101,12 @@
(set! ymax height))
(λ ()
(set! pages (cons `(div ((class "page")
(style ,(format "position: relative;width:~apx;height:~apx;border:1px solid black;background:white" (* xmax em-scale) (* ymax em-scale)))) ,@(reverse page-quads)) pages))
(style ,(format "position: relative;width:~apx;height:~apx;border:1px solid black;background:white" xmax ymax))) ,@(reverse page-quads)) pages))
(set! page-quads null))
(λ (charint)
(set! page-quads (cons
`(div ((style ,(format "position: absolute;left:~apx;top:~apx;font-family:~a" (* em-scale (real-part current-loc)) (* em-scale (imag-part current-loc)) current-font)))
,(string (integer->char charint))) page-quads)))
,(string (integer->char charint))) page-quads)))
(λ (ps)
(set! current-font (hash-ref! fonts ps (λ () (gensym 'font)))))
(λ (x y) (set! current-loc (make-rectangular x y)))

@ -7,8 +7,10 @@
(struct $move $drawing-inst (posn) #:transparent) ; an absolute location in coordinate system (not relative to last loc)
(struct $text $drawing-inst (charint) #:transparent)
(struct $font $drawing-inst (path-string) #:transparent)
(struct $doc $drawing-inst (inst) #:transparent)
(struct $page $drawing-inst (inst) #:transparent)
(struct $doc-start $drawing-inst () #:transparent)
(struct $doc-end $drawing-inst () #:transparent)
(struct $page-start $drawing-inst (x y) #:transparent)
(struct $page-end $drawing-inst () #:transparent)
(struct attr-key (name mandatory? default) #:transparent
#:methods gen:custom-write

Loading…
Cancel
Save