/[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.3 - (hide annotations)
Mon Feb 16 05:44:57 2004 UTC (10 years, 2 months ago) by rjain
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +1 -2 lines
call PREPARE directly on the toplevel element instead of on its subelements so that subclasses can hook in
1 rjain 1.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 rjain 1.3 (prepare input output)
266 rjain 1.1 (compute-breaks input *vertical-sequence* output)))
267    
268     (defmethod convert :around ((input toplevel-element) (output t))
269     (let ((*print-length* nil)
270     (*print-circle* nil)
271     (*print-escape* nil)
272     (*print-readably* nil)
273     (*print-base* 10)
274     (*print-radix* nil)
275     (*print-lines* nil))
276     (call-next-method))
277     t)
278    
279     (defmethod convert ((input toplevel-element) (output t))
280     (dolist (toplevel-subelement (layout input output))
281     (convert toplevel-subelement output)))
282    
283     (defmethod convert :around ((input toplevel-element) (output pretty-printable-mixin))
284     (let ((*print-right-margin* (print-right-margin output))
285     (*print-miser-width* (print-miser-width output))
286     (*print-pretty* (print-pretty output)))
287     (call-next-method))
288     t)
289    
290 rjain 1.2 (defmethod convert ((input defdoc.elements:abbreviation) (output t))
291     (dolist (element (contents input))
292     (convert element output)))

  ViewVC Help
Powered by ViewVC 1.1.5