forked from mbattyani/cl-typesetting
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathtop-level.lisp
207 lines (193 loc) · 9.27 KB
/
top-level.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
;;; cl-typesetting copyright 2003-2004 Marc Battyani see license.txt for the details
;;; You can reach me at [email protected] or [email protected]
;;; The homepage of cl-typesetting is here: http://www.fractalconcept.com/asp/html/cl-typesetting.html
;;; Toplevel document and page layout, auto splitting
;;; Thanks to Dmitri Ivanov for this!
(in-package #:typeset)
(defconstant* +paper-sizes+ ; In portrait orientation: (width . height)
'((:A3 . (841 . 1190)) ; (841.89 . 1190.55)
(:A4 . (595 . 841)) ; (595.28 . 841.89)
(:A5 . (420 . 595)) ; (420.94 . 595.28)
(:Letter . (612 . 792))
(:Legal . (612 . 1008))))
(defvar *default-page-size* :A4)
(defvar *default-page-orientation* :portrait) ; :portrait or :landscape
(defvar *default-page-header-footer-margin* 30)
(defun compute-page-bounds (&optional (size *default-page-size*)
(orientation *default-page-orientation*))
;;; Compute media box size
;; Args: size Size identifier or (width . height)
(let* ((pair (unless (consp size) (cdr (assoc size +paper-sizes+))))
(width (cond ((consp size) (car size))
((eq orientation :landscape) (or (cdr pair) 841))
((or (car pair) 595))))
(height (cond ((consp size) (cdr size))
((eq orientation :landscape) (or (car pair) 595))
((or (cdr pair) 841)))))
(vector 0 0 width height)))
(defclass page (pdf::page)
((margins :accessor margins :initarg :margins :initform nil) ; :type quad
(header :accessor header :initarg :header :initform nil)
(footer :accessor footer :initarg :footer :initform nil)
(header-top :initarg :header-top :initform nil)
(footer-bottom :initarg :footer-bottom :initform nil)
(finalize-fn :initarg :finalize-fn :initform nil) ; signature: page
;; dy left unallocated on this page
(room-left :accessor room-left :initarg :room-left :initform 0)
))
(defun remove-properties (plist keys)
(loop for (key value) on plist by #'cddr
unless (member key keys) nconc (list key value)))
(defun draw-pages (content &rest args
&key (size *default-page-size*)
(orientation *default-page-orientation*)
bounds margins
(header-top *default-page-header-footer-margin*)
(footer-bottom *default-page-header-footer-margin*)
break
finalize-fn
&allow-other-keys)
;;; Args:
;; content Text content, multi-page-table, or other content.
;; bounds Media box; overwrites size and orientation when specified.
;; margins Quad of distances between media edges and page body area.
;; (independent from header and footer sizes for now).
;; header, footer Content or function of ftype (function (page) content)
;; header-top Distance between the top media edge and the header.
;; footer-bottom Distance between the bottom media edge and the footer.
;; break Force new page ::= :before | :after | :always (both ends)
(with-quad (left-margin top-margin right-margin bottom-margin) margins
(let* ((bounds (or bounds (compute-page-bounds size orientation)))
(height (aref bounds 3)))
(flet ((add-page ()
(setq pdf:*page* (apply #'make-instance 'page
:bounds bounds
:header-top header-top
:footer-bottom footer-bottom
;; Move room-left into initialize-instance :after?
:room-left (- height top-margin bottom-margin)
:finalize-fn finalize-fn
(remove-properties args
'(:size :orientation :bounds
:header-top :footer-bottom :break))))))
(when (and pdf:*page* (member break '(:before :always)))
(finalize-page pdf:*page*)
(setq pdf:*page* nil))
(loop with width = (aref bounds 2)
with dx = (- width left-margin right-margin)
and x = left-margin
with dy and y
while (boxes-left content)
unless pdf:*page*
do (add-page)
do (setq dy (room-left pdf:*page*)
y (+ dy bottom-margin))
when (<= dy +epsilon+)
do (finalize-page pdf:*page*)
(add-page)
(setq dy (room-left pdf:*page*)
y (+ dy bottom-margin))
do
(handler-bind
((end-of-page
#'(lambda (c &aux restart)
(cond ((setq restart (find-restart 'continue-with-next-page c))
(finalize-page pdf:*page*)
(add-page)
(setq dy (room-left pdf:*page*)
y (+ dy bottom-margin))
(invoke-restart restart y))
((loop-finish))))))
(multiple-value-bind (boxes dy-left) (fit-lines content dx dy :top)
(cond (boxes
(let ((vbox (make-instance 'vbox :boxes boxes :dx dx :dy dy
:fixed-size t)))
(do-layout vbox)
(setf (room-left pdf:*page*) dy-left)
(stroke vbox x y)))
;; As no new lines can fit, check whether the page was just started
((> (abs (- dy (- height top-margin bottom-margin))) +epsilon+)
(finalize-page pdf:*page*)
(setq pdf:*page* nil))
;; Cannot fit even on a comletely fresh page
(t (error 'cannot-fit-on-page :box (first (boxes-left content))))
) ) ) )
(when (and pdf:*page* (member break '(:after :always)))
(finalize-page pdf:*page*)
(setq pdf:*page* nil))
) )))
(defun finalize-page (pdf:*page* &optional (get-content t))
;;; Draw header and footer without advancing their content,
;; then obtain the entire page content stream.
(with-slots (margins header header-top footer footer-bottom finalize-fn) pdf:*page*
(with-quad (left-margin top-margin right-margin bottom-margin) margins
(let* ((width (aref (pdf::bounds pdf:*page*) 2))
(height (aref (pdf::bounds pdf:*page*) 3))
(dx (- width left-margin right-margin)))
(when header
(let ((content (if (functionp header) (funcall header pdf:*page*) header)))
(pdf:with-saved-state
(stroke (cond ((typep content 'box)
content)
(content
(make-filled-vbox content dx (- top-margin header-top)
:top nil)))
left-margin (- height header-top)))))
(when footer
(let ((content (if (functionp footer) (funcall footer pdf:*page*) footer)))
(pdf:with-saved-state
(stroke (cond ((typep content 'box)
content)
(content
(make-filled-vbox content dx (- bottom-margin footer-bottom)
:bottom nil)))
left-margin bottom-margin))))))
(when finalize-fn
(funcall finalize-fn pdf:*page*))
(when get-content
(setf (pdf::content (pdf::content-stream pdf:*page*))
(get-output-stream-string pdf::*page-stream*))
(pdf::compress-pdf-stream (pdf::content-stream pdf:*page*))))
pdf:*page*)
(defmethod draw-block (content x y dx dy
&key border (padding 5) rotation (v-align :top) special-fn)
;;; On the current *page*
(pdf:with-saved-state
(pdf:translate x y)
(when rotation
(pdf:rotate rotation))
(when border
(with-quad (left top right bottom) padding
(pdf:set-line-width border)
(pdf:set-gray-stroke 0)
(pdf:set-gray-fill 1)
(pdf:basic-rect (- left) top (+ dx left right) (- (+ dy top bottom)))
(pdf:fill-and-stroke)
(pdf:set-gray-fill 0)
) )
(let ((vbox (make-filled-vbox content dx dy v-align)))
;(push vbox *boxes*)
(when special-fn
(funcall special-fn vbox 0 0))
(stroke vbox 0 0))))
(defun final-pass-p ()
(or (= *current-pass* *max-number-of-passes*)
(not (or *undefined-references* *changed-references*))))
(defmacro with-document ((&rest args) &body body)
`(let ((*reference-table* (make-hash-table :test #'equal))
(*undefined-references* t)
(*changed-references* nil)
(*contextual-variables* nil))
(loop for *current-pass* from 1 to *max-number-of-passes*
while (or *undefined-references* *changed-references*)
do
(setf *undefined-references* nil
*changed-references* nil
*contextual-variables* nil)
(pdf:with-document (,@args)
(let ((pdf::*page-stream* (make-string-output-stream)))
(declare (dynamic-extent pdf::*page-stream*))
,@body)))))
(defun write-document (filename &optional (document pdf:*document*))
(when (final-pass-p)
(pdf:write-document filename document)))