/[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.1.1 - (hide annotations) (vendor branch)
Sun Dec 7 23:27:07 2003 UTC (10 years, 4 months ago) by rjain
Branch: defdoc
CVS Tags: start
Changes since 1.1: +0 -0 lines
initial import

1 rjain 1.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