You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
typesetting/quad/qtest/typewriter.rkt

192 lines
7.7 KiB
Racket

This file contains invisible Unicode characters!

This file contains invisible Unicode characters that may be processed differently from what appears below. If your use case is intentional and legitimate, you can safely ignore this warning. Use the Escape button to reveal hidden characters.

#lang debug racket
(require quad racket/class)
(require racket/promise racket/list sugar/debug pitfall/pdf 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/override (start 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)))))
(define doc% (class quad% (super-new)
(define/override (start doc) (start-doc doc))
(define/override (end doc) (end-doc doc))))
(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)))])
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 pdf qarg)
(define chars 65)
(define line-width (* 7.2 chars))
(define lines-per-page (* 40 line-height))
(time-name config-pdf
[font pdf (path->string charter)]
[font-size pdf 12])
(let* ([x (time-name runify (runify qarg))]
[x (time-name quadify (map (λ (x) (quadify pdf 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 pdf (time-name make-pdf (make-pdf #:compress #t)))
(define q (typeset pdf qin))
(report draw-counter)
(time-name draw (with-output-to-file path (λ () (send q draw pdf)) #: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"))))