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.
114 lines
4.8 KiB
Racket
114 lines
4.8 KiB
Racket
#lang debug racket
|
|
(require "struct.rkt"
|
|
"attrs.rkt"
|
|
"param.rkt"
|
|
"debug.rkt"
|
|
"font.rkt"
|
|
"string.rkt"
|
|
quad/base
|
|
racket/date
|
|
pitfall)
|
|
(provide (all-defined-out))
|
|
|
|
|
|
|
|
(define default-page-size "letter")
|
|
(define default-page-orientation "tall")
|
|
(define (page-draw-start q doc)
|
|
(match-define (list page-width page-height) (parse-page-size q))
|
|
(add-page doc page-width page-height)
|
|
(scale doc (zoom-factor) (zoom-factor))
|
|
(draw-debug q doc "purple" "purple" 1))
|
|
|
|
|
|
(define q:page (make-quad
|
|
#:type page-quad
|
|
#:tag 'page
|
|
#:from-parent 'nw
|
|
#:draw-start page-draw-start))
|
|
|
|
|
|
(define (parse-page-size q)
|
|
;; page size can be specified by name, or measurements.
|
|
;; explicit measurements from page-height and page-width supersede those from page-size.
|
|
(match-define (list page-width page-height)
|
|
(for/list ([k (list :page-width :page-height)])
|
|
(and (quad? q) (match (quad-ref q k)
|
|
[#false #false]
|
|
[val (inexact->exact (floor val))]))))
|
|
(resolve-page-size
|
|
(or (debug-page-width) page-width)
|
|
(or (debug-page-height) page-height)
|
|
(quad-ref q :page-size default-page-size)
|
|
(quad-ref q :page-orientation default-page-orientation)))
|
|
|
|
|
|
(define (draw-page-footer q doc)
|
|
(match-define (list x y) (quad-origin q))
|
|
(font-size doc (quad-ref q :font-size))
|
|
(font doc (path->string (quad-ref q font-path-key default-font-face)))
|
|
(fill-color doc default-font-color)
|
|
(define str (or (quad-ref q :footer-text)
|
|
(format "~a · ~a at ~a" (quad-ref q :page-number 0)
|
|
(if (quadwriter-test-mode) "test" (quad-ref q :doc-title "untitled"))
|
|
(date->string (if (quadwriter-test-mode) (seconds->date 0 #f) (current-date)) #t))))
|
|
(text doc str x y)
|
|
#;(set-quad-size! q (make-size-promise-for-string q str)))
|
|
|
|
(define (make-footer-quad col-q page-idx path)
|
|
(define-values (dir name _) (split-path (path-replace-extension path #"")))
|
|
(define attrs (let ([attrs (make-hasheq)]
|
|
[cltq (current-top-level-quad)])
|
|
(hash-set*! attrs
|
|
:footer-text (quad-ref col-q :footer-text)
|
|
:page-number (+ (quad-ref col-q :page-number-start (add1 (section-pages-used))) (sub1 page-idx))
|
|
:doc-title (string-titlecase (path->string name))
|
|
;; we get font & line-height from cltq
|
|
;; because these are not block attrs
|
|
;; so they are not propagated upward from col-q
|
|
:font-size (* 0.8 (quad-ref cltq :font-size))
|
|
:line-height (quad-ref cltq :line-height)
|
|
:font-path (quad-ref cltq :font-path))
|
|
attrs))
|
|
(make-quad #:size (pt 50 default-line-height)
|
|
#:attrs attrs
|
|
#:from-parent 'sw
|
|
#:to 'nw
|
|
#:elems null
|
|
#:shift (pt 0 (* 1.5 default-line-height))
|
|
#:printable #true
|
|
#:draw draw-page-footer
|
|
#:draw-end (λ (q doc)
|
|
(when draw-debug-line?
|
|
(draw-debug q doc "goldenrod" "goldenrod")))))
|
|
|
|
(define ((page-wrap-finish make-page-quad path) cols q-before q-after page-idx)
|
|
(define pq (make-page-quad (+ (section-pages-used) page-idx)))
|
|
;; get attrs from cols if we can, otherwise try q-after or q-before
|
|
(define q-for-attrs (cond
|
|
[(pair? cols) (car cols)]
|
|
[q-after]
|
|
[q-before]
|
|
[else (raise-argument-error 'page-wrap-finish "quad with attrs" (list cols q-after q-before))]))
|
|
(define elems
|
|
(append
|
|
(match (quad-ref q-for-attrs :footer-display #false)
|
|
[(or #false "none") null]
|
|
[_ (list (make-footer-quad q-for-attrs page-idx path))])
|
|
(from-parent cols 'nw)))
|
|
(list (quad-update! pq
|
|
[elems elems]
|
|
[attrs (copy-block-attrs (cond
|
|
[q-for-attrs => quad-attrs]
|
|
[else (hash)])
|
|
(hash-copy (quad-attrs pq)))])))
|
|
|
|
(define (page-wrap qs width [make-page-quad (λ (x) (quad-copy page-quad q:page))])
|
|
(unless (positive? width)
|
|
(raise-argument-error 'page-wrap "positive number" width))
|
|
(wrap qs width
|
|
#:soft-break #true
|
|
#:hard-break page-break-quad?
|
|
#:no-break (λ (q) (quad-ref q :no-pbr))
|
|
#:distance (λ (q dist-so-far wrap-qs) (sum-x wrap-qs))
|
|
#:finish-wrap (page-wrap-finish make-page-quad (pdf-output-path (current-pdf))))) |