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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Sun Dec 7 23:27:07 2003 UTC (10 years, 4 months ago) by rjain
Branch: MAIN
Branch point for: defdoc
Initial revision
1 (in-package :defdoc.layout.flexible-layout)
2
3 ;;; Breaking is only done in one dimension. We do not wrap wrapping-containers. We append
4 ;;; most flowing-containers in the main vertical sequence to the document to be laid-out,
5 ;;; then break where appropriate in that, following TeX's line-breaking algorithm... more
6 ;;; or less, since we have flexibly-sized pages and probably won't have discretionary
7 ;;; breaks (at least not yet), definitely don't have kerns or springs (glues),
8 ;;; etc. However, we will need to be able to count ``words'' in code, math, and images.
9
10 (defmethod prepare ((input section) (output flexible-layout))
11 "Break sections into the header and each of the items in the contents."
12 (let ((section-header (make-instance 'section-header
13 'header-level *header-level* 'contents (title input)))
14 (*header-level* (1+ *header-level*))
15 (contents (contents input)))
16 (do* ((completed-penalty *pre-heading-penalty*
17 previous-previous-penalty)
18 (completed-element section-header
19 previous-element)
20 (previous-previous-penalty *lone-heading-penalty*
21 previous-penalty)
22 (previous-element (pop contents)
23 current-element)
24 (previous-penalty *lone-item-penalty*
25 current-penalty)
26 (current-element (pop contents)
27 (pop contents))
28 (current-penalty *lone-pair-penalty*
29 0)
30 (dummy ; test for empty or one-item section body
31 (cond
32 ((null previous-element)
33 (append-to-vertical-sequence
34 (list (make-instance 'penalty-node 'break-penalty completed-penalty)))
35 (prepare completed-element output)
36 (return))
37 ((null current-element)
38 (append-to-vertical-sequence
39 (list (make-instance 'penalty-node
40 'break-penalty completed-penalty)))
41 (prepare completed-element output)
42 (append-to-vertical-sequence
43 (list (make-instance 'penalty-node
44 'break-penalty (+ previous-previous-penalty *lone-item-penalty*))))
45 (prepare previous-element output)
46 (return)))
47 dummy))
48 ((null current-element) ; termination test
49 ; termination forms
50 (append-to-vertical-sequence
51 (list (make-instance 'penalty-node
52 'break-penalty (+ completed-penalty *lone-pair-penalty*))))
53 (prepare completed-element output)
54 (append-to-vertical-sequence
55 (list (make-instance 'penalty-node
56 'break-penalty (+ previous-previous-penalty *lone-item-penalty*))))
57 (prepare previous-element output))
58 ; iteration forms
59 (append-to-vertical-sequence
60 (list (make-instance 'penalty-node 'break-penalty completed-penalty)))
61 (prepare completed-element output))))
62
63 (defun compute-page-words (page-size)
64 (with-accessors ((page-natural-length natural-length)
65 (page-stretch stretch)
66 (page-shrink shrink)) page-size
67 (assert (unit= 'word (length-units page-natural-length)))
68 (let ((page-natural-words (length-amount page-natural-length)))
69 (values
70 page-natural-words
71 (etypecase page-stretch
72 (fixed-springiness
73 (let ((length (fixed-length page-stretch)))
74 (assert (or (zerop (length-amount length))
75 (unit= 'word (length-units length))))
76 (length-amount length)))
77 (relative-springiness
78 (* page-natural-words (springiness-portion page-stretch)))
79 (infinite-springiness t))
80 (etypecase page-shrink
81 (fixed-springiness
82 (let ((length (fixed-length page-shrink)))
83 (assert (or (zerop (length-amount length))
84 (unit= 'word (length-units length))))
85 (length-amount length)))
86 (relative-springiness
87 (* page-natural-words (springiness-portion page-shrink)))
88 (infinite-springiness
89 (warn "Infinite shrinkage ~A found in page-size. Using 20% instead." page-shrink)
90 (* 1/5 page-natural-words)))))))
91
92 (defmethod compute-breaks ((input toplevel-element) elements (output flexible-layout))
93 (let* ((*word-count-cache* (make-hash-table :test 'eq)))
94 (multiple-value-bind (page-natural-words page-stretch-words page-shrink-words)
95 (compute-page-words (page-size output))
96 (break-into-pages
97 input
98 elements
99 (loop ; 863
100 for tolerance in
101 (list *ideal-badness-tolerance* *acceptable-badness-tolerance* t)
102 count t into pass
103 when
104 (with-breaking ((tolerance decent tight very-tight loose)
105 ((active-list (list (make-active-break nil 0 :fitting decent)))
106 (active-length 0))
107 (try-break
108 (current-active-length active-length)
109 (page-natural-words page-stretch-words page-shrink-words)
110 (badness direction)
111 (cond
112 ((<= badness 12) decent)
113 ((and (= direction -1) (> badness 99)) very-tight)
114 ((= direction +1)
115 (when (> badness 200) ; a bit wasteful, since we just calculated badness
116 (setf badness (1+ +infinitely-bad+)))
117 loose)
118 (t tight))))
119 (do* ((remaining-elements elements (rest remaining-elements))
120 (previous-element nil current-element)
121 (current-element #1=(first remaining-elements) #1#))
122 ((or (null active-list) (null current-element)))
123 (typecase current-element
124 (container (incf active-length (measure current-element 'words)))
125 (discretionary-break ; XXX TODO
126 )
127 (penalty-node
128 (block skip-element
129 (with-accessors ((penalty break-penalty)) current-element
130 (when (= pass 1) ; PREPARE doesn't always combine adjacent
131 ; penalties, so do that on the first pass
132 (if (null previous-element)
133 (loop for next on (rest remaining-elements)
134 while (typep (first next) 'penalty-node)
135 finally (progn (setf elements next)
136 (return-from skip-element)))
137 (loop
138 for next on (rest remaining-elements)
139 while (typep (first next) 'penalty-node)
140 do (penalty-incf penalty (break-penalty (first next)))
141 do (setf (rest remaining-elements) (rest next)))))
142 (assert (and previous-element
143 (not (typep previous-element 'penalty-node))))
144 (unless (or (null previous-element)
145 (typep previous-element 'penalty-node)
146 (penalty= t penalty))
147 (setf active-list
148 (try-break remaining-elements penalty active-list))))))))
149 ; Now try the break at the end of the container.
150 ; If we can't find a reasonable breaking sequence,
151 ; this returns NIL.
152 (if (and active-list (setf active-list (try-break nil nil active-list)))
153 ; (extremum #'penalty< active-list
154 ; :key #'active-break-total-penalty)
155 (loop ; find the active-break with the least penalty
156 with best-break of-type active-break = (pop active-list)
157 with best-penalty = (active-break-total-penalty best-break)
158 for this-break of-type active-break in active-list
159 for this-penalty = (active-break-total-penalty this-break)
160 do (when (penalty< this-penalty best-penalty)
161 (setf best-break this-break
162 best-penalty this-penalty))
163 finally (return best-break))
164 (when (= pass 3)
165 (error "Oops... we didn't find any breaking sequence... that's a problem..."))))
166 return it)))))
167
168 (defun break-into-pages (input elements active) ; 877
169 (declare (type active-break active))
170 (let ((breaks nil)
171 (page-class (sub-container-class input)))
172 (loop ; 878
173 for break = (active-break-breakpoint active) then (passive-break-previous break)
174 while break
175 do (push break breaks))
176 ;(break "doing the page breaking!")
177 (loop
178 for break in breaks
179 for location = (passive-break-breakpoint break)
180 ;do (print "...New Page...")
181 collect (loop
182 until (eq elements location)
183 for element = (pop elements)
184 when (not (typep element 'penalty-node))
185 collect element into page
186 ;and do (print element)
187 end
188 finally (return (make-instance page-class
189 'contents page
190 'toplevel-element input))))))

  ViewVC Help
Powered by ViewVC 1.1.5