/[defdoc]/DefDoc/src/layout/engine-framework.lisp
ViewVC logotype

Contents of /DefDoc/src/layout/engine-framework.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Sun Feb 15 05:01:45 2004 UTC (10 years, 2 months ago) by rjain
Branch: MAIN
Changes since 1.1: +3 -0 lines
additions and tweaks for the defdoc-generated defdoc website:
elements that are abbreviations for more complex sequences of elements
hyperlink document element
small-caps style element
subtitle in documents
1 (in-package :defdoc.layout)
2
3 ;;; PREPARE
4 (defgeneric prepare (input output)
5 (:documentation "Breaks up the input into the basic elements to be laid out and appends
6 them to the main vertical sequence using APPEND-TO-VERTICAL-SEQUENCE."))
7
8 (declaim (type list *vertical-sequence* *vertical-sequence-tail*))
9 (defvar *vertical-sequence*)
10 (defvar *vertical-sequence-tail*)
11
12 (declaim (type unsigned-byte *header-level*))
13 (defvar *header-level*)
14
15 (defun append-to-vertical-sequence (list)
16 "Appends the given list of elements to the main vertical sequence."
17 (if *vertical-sequence*
18 (setf (rest *vertical-sequence-tail*) list)
19 (setf *vertical-sequence* list))
20 (setf *vertical-sequence-tail* (last list)))
21
22 (defmethod prepare ((input t) (output t))
23 "By default, just leave it as-is."
24 (append-to-vertical-sequence (list input)))
25
26 (defmethod prepare ((input toplevel-element) (output t))
27 ; XXX TODO: title / title page
28 (dolist (element (contents input))
29 (prepare element output)))
30
31 #+nil
32 (defmethod prepare :around ((input container) (output t))
33 (let ((badness-weighting nil))
34 (handler-case (setf badness-weighting (badness-weighting input))
35 (slot-unbound ()))
36 ;;(progv (and badness-weighting '(*badness-weighting*))
37 ;; (list badness-weighting)
38 (let ((*badness-weighting* (or badness-weighting *badness-weighting*)))
39 (call-next-method))))
40
41 ;;; COMPUTE-BREAKS
42 (defgeneric compute-breaks (input elements output)
43 (:documentation "Breaks up the given basic element list, returning a list of
44 toplevel-subelements."))
45
46 (defstruct (active-break
47 (:constructor make-active-break
48 (breakpoint total-penalty &key fitting discretionary-p #+nil number)))
49 (breakpoint nil :type (or null passive-break) :read-only t)
50 (total-penalty 0 :type penalty :read-only t) ; the total penalty up to this breakpoint
51 #+nil(number 0 :type integer :read-only t) ; the line, page, etc number this break starts
52 (fitting nil :read-only t) ; for assessing *adjacent-incompatible-fitting-penalty*
53 (discretionary-p nil :type boolean :read-only t))
54
55 (declaim (type unsigned-byte *passive-break-counter*))
56 (defvar *passive-break-counter*)
57
58 (defstruct (passive-break (:constructor make-passive-break (breakpoint previous)))
59 (breakpoint nil :type list :read-only t) ; its CAR is the item broken on or nil if the
60 ; start or end of the paragraph.
61 (previous nil :type (or null passive-break) :read-only t) ; the break which would best precede this one
62 (serial (incf *passive-break-counter*) :type unsigned-byte :read-only t))
63
64 (defmethod compute-breaks :around ((input toplevel-element) (elements t) (output t))
65 (let* ((*passive-break-counter* 0))
66 (call-next-method)))
67
68 (defun compute-penalty-form (location force-p active badness penalty fitting fittings)
69 `(if ,force-p
70 (active-break-total-penalty ,active)
71 (penalty+ (active-break-total-penalty ,active)
72 ,badness *per-break-penalty* ,penalty
73 (if (active-break-discretionary-p ,active)
74 (cond
75 ((typep (first ,location) 'discretionary-break)
76 *consecutive-discretionary-break-penalty*)
77 ((null ,location) *final-break-discretionary-penalty*)
78 (t 0))
79 0)
80 ,(when fittings
81 `(if (not (eql (active-break-fitting ,active) ,fitting))
82 *adjacent-incompatible-fitting-penalty*
83 0)))))
84
85 (defun compute-breaking-function (spec tolerance num-fittings)
86 "Tests if the breakpoint at the start of LOCATION is feasible by running through
87 ACTIVE-LIST and measuring the penalty for using each of those breakpoints as the previous
88 one. If LOCATION is NIL, we are at the end of the container. ACTIVE-LENGTH is the distance
89 from the first active break to the current location. It is maintained by the breaking
90 function. The return value is the new ACTIVE-LIST to be used for later breakpoints,
91 removing ones that are too far from the current element and adding one for the current
92 element when appropriate."
93 (let ((minimal-penalty (gensym "MINIMAL-PENALTY-"))
94 (minimum-penalty (gensym "MINIMUM-PENALTY-"))
95 (best-place (gensym "BEST-PLACE-"))
96 (collect-p (gensym "COLLECT-P-"))
97 (record-p (gensym "RECORD-P-"))
98 (new-active-list (gensym "NEW-ACTIVE-LIST-"))
99 (location (gensym "LOCATION-"))
100 (penalty (gensym "PENALTY-"))
101 (active-list (gensym "ACTIVE-LIST-"))
102 (active (gensym "ACTIVE-"))
103 (delta (gensym "DELTA-"))
104 (fittings-p (plusp num-fittings)))
105 (destructuring-bind
106 (name (current-active-length active-length &optional break-length)
107 (natural-size stretch shrink) (badness direction) fitting-form)
108 spec
109 `(,name
110 (,location ,penalty ,active-list)
111 (let ((,current-active-length ,active-length)
112 ,@(when break-length `((,break-length 0)))
113 (,minimum-penalty t)
114 (,new-active-list nil)
115 ,@(if fittings-p
116 `((,minimal-penalty
117 (make-array ,num-fittings :element-type 'penalty
118 :initial-element t))
119 (,best-place
120 (make-array ,num-fittings :element-type '(or null passive-break)
121 :initial-element nil)))
122 `((,best-place))))
123 (do ((,active #1=(pop ,active-list) #1#))
124 ((null ,active))
125 (if (integerp ,active)
126 (progn
127 (incf ,current-active-length ,active)
128 (push ,active ,new-active-list))
129 (let ((,collect-p t)
130 (,record-p nil))
131 (multiple-value-bind (,badness ,direction)
132 (compute-badness ,current-active-length
133 ,natural-size ,stretch ,shrink)
134 (let ((.fitting. ,fitting-form))
135 (if (or (>= ,badness +infinitely-bad+) (penalty= ,penalty nil))
136 (progn ; 854: prepare to deactivate active
137 (cond
138 ((and (eq ,tolerance t)
139 (eq ,minimum-penalty t)
140 (null (rest ,new-active-list))
141 (null ,active-list))
142 ; OK, we give up. Let's just use this break, it's
143 ; the only one we have.
144 (setf ,record-p :force))
145 ((penalty<= ,badness ,tolerance) (setf ,record-p t)))
146 (setf ,collect-p nil))
147 (unless (penalty> ,badness ,tolerance) (setf ,record-p t)))
148 (when ,record-p ; 855
149 (let ((.total-penalty.
150 ,(compute-penalty-form location `(eq ,record-p :force)
151 active badness penalty
152 '.fitting. fittings-p)))
153 ,(if fittings-p
154 `(when (penalty<= .total-penalty.
155 (aref ,minimal-penalty .fitting.))
156 (setf (aref ,minimal-penalty .fitting.) .total-penalty.)
157 (setf (aref ,best-place .fitting.)
158 (active-break-breakpoint ,active))
159 (setf ,minimum-penalty
160 (penalty-min ,minimum-penalty .total-penalty.)))
161 `(when (penalty<= .total-penalty. ,minimum-penalty)
162 (setf ,minimum-penalty .total-penalty.)
163 (setf ,best-place (active-break-breakpoint ,active))))))
164 (if ,collect-p
165 (push ,active ,new-active-list)
166 ; 860: fixup the deltas since we're not collecting
167 ; an active-break
168 (cond
169 ((null ,new-active-list) ; 861: that was the first active break
170 (when (integerp (first ,active-list))
171 (incf ,active-length (pop ,active-list))
172 (setf ,current-active-length ,active-length)))
173 ((integerp (first ,active-list)) ; we just passed a delta
174 (cond
175 ((null ,active-list) ; and we're at the end
176 (decf ,current-active-length (pop ,new-active-list)))
177 ((integerp (first ,active-list)) ; and delta is just ahead
178 (let ((,delta (pop ,active-list)))
179 (incf ,current-active-length ,delta)
180 (incf (first ,new-active-list) ,delta))))))))))))
181 (when (penalty< ,minimum-penalty t)
182 ; 835/836: Create new active nodes for the best
183 ; feasible breaks found. Do not compute
184 ; break-length, since we don't yet have any
185 ; elements that are discarded after breaking
186 (cond ; 843: insert a delta to prepare for breaks here
187 ((integerp (first ,new-active-list)) ; modify an existing delta
188 ,(when break-length `(incf (first ,new-active-list) ,break-length)))
189 ((null ,new-active-list) ; no delta needed at the beginning
190 (setf ,active-length ,(or break-length 0)))
191 (t (push (- ,@(when break-length `(,break-length)) ,current-active-length)
192 ,new-active-list)))
193 ,(if fittings-p ; XXX be sure to add discretionary-p args below
194 `(progn
195 (penalty-incf ,minimum-penalty *adjacent-incompatible-fitting-penalty*)
196 (dotimes (.fitting. ,num-fittings)
197 (when (penalty<= (aref ,minimal-penalty .fitting.) ,minimum-penalty)
198 ; 845
199 (let ((.new-passive.
200 (make-passive-break ,location (aref ,best-place .fitting.))))
201 (push (make-active-break .new-passive.
202 (aref ,minimal-penalty .fitting.)
203 :fitting .fitting.)
204 ,new-active-list)))))
205 `(unless (penalty= ,minimum-penalty t) ; 845
206 (let ((.new-passive. (make-passive-break ,location) ,best-place))
207 (push (make-active-break .new-passive. ,minimum-penalty)
208 ,new-active-list)))))
209 ; 844: TODO, when variable container boundaries
210 ; are implemented
211 (nreverse ,new-active-list))))))
212
213 (defmacro with-breaking (((tolerance &rest fittings)
214 bindings
215 &rest breaking-functions)
216 &body body)
217 (let ((num-fittings 0))
218 `(let (,@(mapcar (lambda (fitting) `(,fitting ,(1- (incf num-fittings))))
219 fittings))
220 (let (,@bindings)
221 (flet (,@(mapcar (lambda (spec)
222 (compute-breaking-function spec tolerance num-fittings))
223 breaking-functions))
224 ,@body)))))
225
226 ;;; MEASURE
227 (defgeneric measure (element units)
228 (:documentation "Measures the given element in terms of the given units. Returns NIL if
229 such a measurement is not possible."))
230
231 (defmethod measure ((element t) (units symbol))
232 (measure element (search-for-unit units)))
233
234 (defmethod measure ((element t) (units null))
235 (error "Attempt to measure the length of ~A in terms of unknown units." element))
236
237 (defvar *word-count-cache*)
238
239 (defun word-count (element)
240 "Very roughly count the number of words in the given document element (based mostly on
241 the number of spaces)."
242 (or (gethash element *word-count-cache*)
243 (let ((words 0))
244 (typecase element
245 (string (incf words (count #\space element)))
246 (list (incf words (reduce #'+ (mapcar #'word-count element))))
247 (logical-structure-element (incf words (1+ (word-count (contents element)))))
248 (container (incf words (word-count (contents element))))
249 (character (when (eql element #\space) (incf words))))
250 (setf (gethash element *word-count-cache*) words))))
251
252 (defmethod measure ((element t) (units (eql (search-for-unit 'words))))
253 (word-count element))
254
255 ;;; CONVERT
256 (defgeneric convert (input output)
257 (:documentation "Converts the input into the format specified by the output."))
258
259 (defun layout (input output)
260 "Lays out the input object for the layout parameters specified by the output object,
261 returning the objects that result."
262 (let ((*vertical-sequence* '())
263 (*vertical-sequence-tail* '())
264 (*header-level* 1))
265 (dolist (subelement (contents input))
266 (prepare subelement output))
267 (compute-breaks input *vertical-sequence* output)))
268
269 (defmethod convert :around ((input toplevel-element) (output t))
270 (let ((*print-length* nil)
271 (*print-circle* nil)
272 (*print-escape* nil)
273 (*print-readably* nil)
274 (*print-base* 10)
275 (*print-radix* nil)
276 (*print-lines* nil))
277 (call-next-method))
278 t)
279
280 (defmethod convert ((input toplevel-element) (output t))
281 (dolist (toplevel-subelement (layout input output))
282 (convert toplevel-subelement output)))
283
284 (defmethod convert :around ((input toplevel-element) (output pretty-printable-mixin))
285 (let ((*print-right-margin* (print-right-margin output))
286 (*print-miser-width* (print-miser-width output))
287 (*print-pretty* (print-pretty output)))
288 (call-next-method))
289 t)
290
291 (defmethod convert ((input defdoc.elements:abbreviation) (output t))
292 (dolist (element (contents input))
293 (convert element output)))

  ViewVC Help
Powered by ViewVC 1.1.5