|
|
#lang debug racket
|
|
|
(require quad racket/class)
|
|
|
(require racket/promise racket/list sugar/debug pitfall/document pitfall/vector pitfall/font pitfall/annotation pitfall/color pitfall/text fontland/font racket/runtime-path pollen/tag)
|
|
|
(provide (rename-out [mb #%module-begin]) (except-out (all-from-out racket) #%module-begin))
|
|
|
|
|
|
(define-runtime-path charter "fonts/charter.ttf")
|
|
|
|
|
|
(define (soft-break? q)
|
|
|
(and (quad? q)
|
|
|
(or (memv (car (get-field elems q)) '(#\space #\- #\u00AD))
|
|
|
(member (car (get-field elems q)) (map string '(#\space #\- #\u00AD))))))
|
|
|
|
|
|
(define (draw-debug q doc)
|
|
|
(save doc)
|
|
|
(line-width doc 0.25)
|
|
|
(apply rect doc (append (send q origin) (send q size)))
|
|
|
(stroke doc "#fcc")
|
|
|
(apply rect doc (append (send q origin) (send q size)))
|
|
|
(clip doc)
|
|
|
(circle doc (pt-x (in-point q)) (pt-y (in-point q)) 1)
|
|
|
(circle doc (pt-x (out-point q)) (pt-y (out-point q)) 1)
|
|
|
(fill doc "#f99")
|
|
|
(restore doc))
|
|
|
|
|
|
(define draw-counter 0)
|
|
|
(define textish%
|
|
|
(class quad%
|
|
|
(super-new)
|
|
|
(inherit-field [@size size] [@elems elems]
|
|
|
[@attrs attrs] [@origin origin] [@in in] [@out out])
|
|
|
(set! @in 'bi)
|
|
|
(set! @out 'bo)
|
|
|
|
|
|
(define/override (printable? [sig #f])
|
|
|
(case (car @elems)
|
|
|
[(" " #\u00AD) (λ (sig) (memq sig '(end)))]
|
|
|
[(" " #\space) (λ (sig) (not (memq sig '(start end))))]
|
|
|
[else #true]))
|
|
|
|
|
|
(define/override (draw doc)
|
|
|
(set! draw-counter (add1 draw-counter ))
|
|
|
(font-size doc (string->number (hash-ref @attrs 'fontsize "12")))
|
|
|
(let ([str (car @elems)])
|
|
|
(cond
|
|
|
[(hash-has-key? @attrs 'link)
|
|
|
(save doc)
|
|
|
(fill-color doc "blue")
|
|
|
(text doc str (first @origin) (second @origin) (hasheq 'link (hash-ref @attrs 'link)))
|
|
|
(restore doc)]
|
|
|
[else
|
|
|
#;(println str)
|
|
|
(void)
|
|
|
(apply text doc str @origin)])))))
|
|
|
|
|
|
(define quadify%
|
|
|
(class textish%
|
|
|
(super-new)
|
|
|
(init-field doc)
|
|
|
(inherit-field [@size size] [@elems elems] [@attrs attrs])
|
|
|
(set! @size
|
|
|
(delay
|
|
|
(define fontsize (string->number (hash-ref @attrs 'fontsize "12")))
|
|
|
(define str (car @elems))
|
|
|
(font-size doc fontsize)
|
|
|
(font doc (path->string charter))
|
|
|
(list
|
|
|
(string-width doc str)
|
|
|
(current-line-height doc))))))
|
|
|
|
|
|
(define (quadify doc q)
|
|
|
(make-object quadify% doc (hash-set* (get-field attrs q) 'font charter) (get-field elems q)))
|
|
|
|
|
|
(define $line (class quad% (super-new)
|
|
|
(set-field! size this (list +inf.0 line-height))
|
|
|
(set-field! out this 'sw)))
|
|
|
(define $page (class quad% (super-new)
|
|
|
(set-field! offset this'(36 36))))
|
|
|
(define $doc (class quad% (super-new)))
|
|
|
(define $break (class quad% (super-new)))
|
|
|
(define page-count 1)
|
|
|
(define (make-break . xs) (make-object $break (hasheq 'printable? #f 'size '(0 0)) xs))
|
|
|
|
|
|
(define (consolidate-runs pcs)
|
|
|
(for/fold ([runs empty]
|
|
|
[pcs pcs]
|
|
|
#:result (reverse runs))
|
|
|
([i (in-naturals)]
|
|
|
#:break (empty? pcs))
|
|
|
(define-values (run-pcs rest) (splitf-at pcs (λ (p) (same-run? (car pcs) p))))
|
|
|
(define new-run (make-object textish% (get-field attrs (car pcs)) (get-field elems (car pcs))))
|
|
|
(set-field! size new-run (delay (list (for/sum ([pc (in-list run-pcs)])
|
|
|
(pt-x (send pc size)))
|
|
|
(pt-y (send (car pcs) size)))))
|
|
|
(set-field! elems new-run (merge-adjacent-strings (apply append (for/list ([pc (in-list run-pcs)])
|
|
|
(get-field elems pc)))))
|
|
|
(values (cons new-run runs) rest)))
|
|
|
|
|
|
(define line-height 16)
|
|
|
(define consolidate-into-runs? #t)
|
|
|
(define (line-wrap xs size [debug #f])
|
|
|
(break xs size debug
|
|
|
#:break-val (make-break #\newline)
|
|
|
#:soft-break-proc soft-break?
|
|
|
#:finish-wrap-proc (λ (pcs) (list (make-object $line (hasheq)
|
|
|
;; consolidate chars into a single run (naively)
|
|
|
;; by taking attributes from first (including origin)
|
|
|
;; this only works because there's only one run per line
|
|
|
;; that is, it suffices to position the first letter
|
|
|
(if consolidate-into-runs?
|
|
|
(consolidate-runs pcs)
|
|
|
pcs))))))
|
|
|
|
|
|
;; 181231 it's weird that setup work for page is in the page break,
|
|
|
;; which is between pages, not associated with either
|
|
|
(define pb (make-object (let ([pb (class $break
|
|
|
(super-new)
|
|
|
(define/override (printable?) #f)
|
|
|
(inherit-field (@size size))
|
|
|
(set! @size '(0 0))
|
|
|
(define/override (draw doc)
|
|
|
(add-page doc)
|
|
|
(font-size doc 10)
|
|
|
(define str (string-append "page " (number->string page-count)))
|
|
|
;; page number
|
|
|
(save doc)
|
|
|
(fill-color doc "blue")
|
|
|
(text doc str 10 10 (hasheq 'link "https://practicaltypography.com"))
|
|
|
(restore doc)
|
|
|
(set! page-count (add1 page-count))))])
|
|
|
pb) '(#\page)))
|
|
|
|
|
|
(define ($break? x) (is-a? x $break))
|
|
|
(define (page-wrap xs size [debug #f])
|
|
|
(break xs size debug
|
|
|
#:break-before? #t
|
|
|
#:break-val pb
|
|
|
#:soft-break-proc $break?
|
|
|
#:finish-wrap-proc (λ (pcs) (list (make-object $page (hasheq) (filter-not $break? pcs))))))
|
|
|
|
|
|
(define (typeset doc qarg)
|
|
|
(define chars 65)
|
|
|
(define line-width (* 7.2 chars))
|
|
|
(define lines-per-page (* 40 line-height))
|
|
|
(let* ([x (time-name runify (runify qarg))]
|
|
|
[x (time-name quadify (map (λ (x) (quadify doc x)) x))]
|
|
|
[x (time-name line-wrap (line-wrap x line-width))]
|
|
|
[x (time-name page-wrap (page-wrap x lines-per-page))]
|
|
|
[x (time-name position (position (make-object $doc (hasheq) x)))])
|
|
|
x))
|
|
|
|
|
|
(define (run qin [path "test.pdf"])
|
|
|
(define doc (time-name make-doc
|
|
|
(make-$doc
|
|
|
(hasheq 'compress #t
|
|
|
'autoFirstPage #f))))
|
|
|
(time-name config-doc
|
|
|
[font doc (path->string charter)]
|
|
|
[font-size doc 12])
|
|
|
(define q (typeset doc qin))
|
|
|
(report draw-counter)
|
|
|
(time-name draw
|
|
|
(with-output-to-file path
|
|
|
(λ ()
|
|
|
(start-doc doc)
|
|
|
(send q draw doc)
|
|
|
(end-doc doc))
|
|
|
#:exists 'replace))
|
|
|
(report draw-counter))
|
|
|
|
|
|
(define-syntax (mb stx)
|
|
|
(syntax-case stx ()
|
|
|
[(_ . ARGS)
|
|
|
(with-syntax ([PS (syntax-property #'ARGS 'ps)]
|
|
|
[(REP . QS) #'ARGS])
|
|
|
#'(#%module-begin
|
|
|
(define qs (list . QS))
|
|
|
(define lotsa-qs (append* (make-list (string->number (string-trim REP)) qs)))
|
|
|
(run (qexpr->quad (apply quad #:fontsize "12" lotsa-qs)) PS)
|
|
|
(void)))]))
|
|
|
|
|
|
(define quad (default-tag-function 'quad))
|
|
|
(provide quad)
|
|
|
|
|
|
(module reader syntax/module-reader
|
|
|
qtest/typewriter
|
|
|
#:read quad-read
|
|
|
#:read-syntax quad-read-syntax
|
|
|
#:whole-body-readers? #t ;; need this to make at-reader work
|
|
|
(require scribble/reader)
|
|
|
|
|
|
(define (quad-read p) (syntax->datum (quad-read-syntax (object-name p) p)))
|
|
|
|
|
|
(define (quad-read-syntax path-string p)
|
|
|
(define quad-at-reader (make-at-reader
|
|
|
#:syntax? #t
|
|
|
#:inside? #t
|
|
|
#:command-char #\◊))
|
|
|
(syntax-property (quad-at-reader path-string p) 'ps (path-replace-extension path-string #".pdf"))))
|