/[defdoc]/DefDoc/src/elements/basic-elements.lisp
ViewVC logotype

Contents of /DefDoc/src/elements/basic-elements.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Mon Mar 1 18:14:54 2004 UTC (10 years, 1 month ago) by rjain
Branch: MAIN
Changes since 1.1: +9 -3 lines
tweak var name for line-rule default thickness

allow changes in this variable to propagate to rules keeping the default value
1 (in-package :defdoc.elements)
2
3 ;;;
4 ;;; Basic elements
5 ;;;
6
7 (defclass element ()
8 ((height :type length
9 :initarg height
10 :documentation "The distance from the beginning of this box to the horizontal
11 baseline. Unbound means to fill the parent box in that direction.")
12 (width :type length
13 :initarg width
14 :documentation "The distance from the beginning of this box to the vertical
15 baseline. Unbound means to fill the parent box in that direction.")
16 (engine-specific :type list
17 :initform nil
18 :initarg engine-specific
19 :accessor engine-specific
20 :documentation "A alist of output or layout engine name to an alist of
21 engine-specific options. Use ENGINE-SPECIFIC-OPTION to access this slot's information
22 externally."))
23 (:documentation "The basic type of an element."))
24
25 (defgeneric engine-specific-option (element engine option)
26 (:documentation "Returns a the engine-specific option that applies to the given
27 conversion under the given name."))
28
29 (defun get-one-engine-specific (element engine option)
30 (declare (type element element)
31 (type symbol engine))
32 (cdr (assoc option (cdr (assoc engine (engine-specific element))))))
33
34 (defmethod engine-specific-option ((element t) (engine t) (option t))
35 nil)
36
37 (eval-when (:execute :compile-toplevel)
38 (defconstant +mop-cpl+
39 (first (find-all-symbols "CLASS-PRECEDENCE-LIST")))
40 (defconstant +mop-class-of+
41 (or (find-symbol "CLASS-OF" (symbol-package +mop-cpl+)) 'class-of))
42 (defconstant +mop-class-name+
43 (or (find-symbol "CLASS-NAME" (symbol-package +mop-cpl+)) 'class-name)))
44
45 (defmethod engine-specific-option ((element element) (engine t) (option t))
46 (and (engine-specific element)
47 (loop
48 for class in (#.+mop-cpl+ (#.+mop-class-of+ engine))
49 append (get-one-engine-specific element
50 (#.+mop-class-name+ class)
51 option))))
52
53 (defclass vertical-element (element)
54 ((breadth :type length
55 :initarg breadth
56 :documentation "The distance from the vertical baseline to the end of this
57 box. Unbound means to fill the parent box in that direction."))
58 (:documentation "An element that is to be laid out in a vertical sequence."))
59
60 (defclass horizontal-element (element)
61 ((depth :type length
62 :initarg depth
63 :documentation "The distance from the horizontal baseline to the end of this
64 box. Unbound means to fill the parent box in that direction."))
65 (:documentation "An element that is to be laid out in a horizontal sequence."))
66
67 ;;;
68 ;;; Containers
69 ;;;
70
71 (defclass container (element)
72 ((contents :type list
73 :initform nil
74 :initarg contents
75 :accessor contents
76 :documentation "The elements that are laid out in this container. They must
77 all have an orientation that is perpendicular to this container or be flowing-containers.")
78 (position-offset :type length
79 :initform 0
80 :initarg position-offset
81 :accessor position-offset
82 :documentation "The offset of this container in the parent container,
83 in the direction perpendicular to the layout of this container. Currently ignored.")
84 (layout-direction :type (member :right/down :left/up)
85 :initform :right/down
86 :initarg layout-direction
87 :accessor layout-direction
88 :documentation "The direction in which the elements in this container
89 should be laid out. Currently ignored.")
90 (badness-weighting :type badness-weighting
91 :initarg badness-weighting
92 :accessor badness-weighting
93 :documentation "The treatment a badness is given in order to
94 determine the penalty assessed for layouts within this container. Currently ignored."))
95 (:documentation "Mixin for elements that themselves contain elements. Do not use this
96 class to create a normal container element; rather, choose one of vertical- or
97 horizontal-container-mixin and any of the other mixins. Breaking is not performed on
98 simple containers."))
99
100 (defmethod slot-unbound
101 ((class standard-class) (instance container) (slot-name (eql 'badness-weighting)))
102 *badness-weighting*)
103
104 (defclass vertical-container (container)
105 ()
106 (:documentation "Mixin for containers whose contents are vertical-elements."))
107
108 (defclass horizontal-container (container)
109 ()
110 (:documentation "Mixin for containers whose contents are horizontal-elements."))
111
112 (defclass overflowable-container-mixin (container)
113 ((overflow-containers :type list
114 :initform nil
115 :accessor overflow-containers
116 :documentation "The list of containers which, in order, will
117 accomodate overflowing elements from this container."))
118 (:documentation "Mixin for a container whose contents overflow into a specific series of
119 containers. Useful for, e.g., articles in newspapers and magazines with
120 continuations. Used in implementing pages and lines as well."))
121
122 (defclass wrapping-container-mixin (container)
123 ((sub-container-class :type (or standard-class symbol)
124 :initarg sub-container-class
125 :accessor sub-container-class
126 :documentation "Class of the sub-containers that this one wraps into."))
127 (:documentation "Mixin for a container whose contents can be wrapped as desired into as
128 many consecutive similar containers within the parent container. E.g., a normal document
129 is a subclass of wrapping-container-mixin with a sub-container-constructor that makes page
130 objects. Note that paragraphs are flowing-vertical-containers because the lines in them
131 are laid out vertically and flow into the parent element's layout; it is the lines that
132 are horizontal-containers."))
133
134 (defclass flowing-container-mixin (container)
135 ()
136 (:documentation "Mixin for a container whose contents flow into (are spliced into the
137 layout of) the parent container's contents if they both have the same orientation.
138 Containers that do not inherit from this class will never be broken."))
139
140 (defclass floatable-container-mixin (container)
141 ((float-penalty :type penalty
142 :initform 0
143 :initarg float-penalty
144 :accessor float-penalty
145 :documentation "The penalty of floating the container. Defaults to 0,
146 indicating to always float the container unless putting it inline creates a more pleasing layout.")
147 (float-distance-penalty :type penalty
148 :initform *default-float-distance-penalty*
149 :initarg float-distance-penalty
150 :accessor float-distance-penalty
151 :documentation "The penalty of floating the container, charged
152 once each time that it is pushed into the next overflow container. To use a non-linear
153 relationship, override the CALCULATE-FLOAT-PENALTY generic-function in a subclass."))
154 ;;; XXX Need a way to indicate that this float must come before some specific
155 ;;; (higher-level) container type's end. Just have some way for a container type to
156 ;;; indicate that all pending floats should be placed before it?
157
158 ;;; To handle, e.g., footnotes, we need to have one of these that can be wrapped, and
159 ;;; give a way to assess penalties, most notably for having more than a certain portion
160 ;;; of a page filled with footnote information.
161 (:documentation "Mixin to create a container which can be floated and pushed into
162 overflow containers."))
163
164 (defgeneric calculate-float-penalty (element distance)
165 ;; XXX this needs more parameters, probably
166 (:documentation "Computes the penalty to be assessed for floating the given ELEMENT the
167 given DISTANCE away from where it is defined in the document."))
168
169 (defmethod calculate-float-penalty ((element floatable-container-mixin) distance)
170 (+ (float-penalty element) (* distance (float-distance-penalty element))))
171
172 ;;;
173 ;;; Rules
174 ;;;
175
176 (defvar *default-line-rule-thickness* '(4/10 px))
177
178 (defclass rule-mixin (dimension-mixin)
179 ()
180 (:documentation "An element that is filled with ink within the dimension boundaries."))
181
182 (defclass horizontal-rule (horizontal-element rule-mixin)
183 ((height)))
184
185 (defmethod slot-unbound (class (instance horizontal-rule) (slot-name (eql 'height)))
186 *default-line-rule-thickness*)
187
188 (defclass vertical-rule (vertical-element rule-mixin)
189 ((width)))
190
191 (defmethod slot-unbound (class (instance vertical-rule) (slot-name (eql 'width)))
192 *default-line-rule-thickness*)
193
194 ;;;
195 ;;; Characters
196 ;;;
197
198 (defclass simple-character ()
199 ((font :initarg font
200 :accessor font)
201 (code-number :type unsigned-byte
202 :initarg code-number
203 :accessor code-number
204 :documentation "The index of the character in the specified font.")))
205
206 (deftype small-character ()
207 "Only usable for characters whose font and code-number can be represented as small
208 numbers. 7 bits for the font, 8 bits for the character code."
209 'fixnum)
210
211 (defmethod font ((char fixnum))
212 (ldb (byte 7 8) char))
213
214 (defmethod code-number ((char fixnum))
215 (ldb (byte 8 0) char))
216
217 (defmethod font ((char character))
218 0)
219
220 (defmethod code-number ((char character))
221 (char-code char))
222
223 (defclass ligature (simple-character)
224 ((replaced-chars :type list
225 :initarg replaced-chars
226 :accessor replaced-chars
227 :documentation "The simple characters that were replaced, if any, in
228 order to form this ligature. Useful in, e.g., reconstructing the input text for
229 communication to the end-user or in outputting to a medium which does not have this (or
230 any) ligature."))
231 (:documentation "A character that is formed from the interaction of multiple characters."))
232
233 ;;;
234 ;;; Breaking
235 ;;;
236
237 (defclass penalty-node ()
238 ((break-penalty :type penalty
239 :initarg break-penalty
240 :accessor break-penalty))
241 (:documentation "A node indicating the penalty associated with breaking at this specific
242 location."))
243
244 (defclass discretionary-break (penalty-node)
245 ((pre-break-elements :type list
246 :initform nil
247 :initarg pre-break-elements
248 :accessor pre-break-elements
249 :documentation "The text to precede the break if it is used.")
250 (post-break-elements :type list
251 :initform nil
252 :initarg post-break-elements
253 :accessor post-break-elements
254 :documentation "The text to follow the break if it is used.")
255 (no-break-elements :type list
256 :initform nil
257 :initarg no-break-elements
258 :accessor no-break-elements
259 :documentation "The text to be placed here if the break is not used.")
260 #+nil
261 (num-elements-replaced :type unsigned-byte
262 :initform nil
263 :initarg num-elements-replaced
264 :accessor num-elements-replaced
265 :documentation "The number of elements to be skipped if the break
266 is used. This is the way that Knuth's TeX program implements this data structure (instead
267 of the previous slot).")
268 #+nil
269 (break-skip-to :type list
270 :initarg break-skip-to
271 :accessor break-skip-to
272 :documentation "The cons containing the element to skip to if the
273 break is used. Another way of implementing the previous slot."))
274 (:documentation "A location where a break can be placed, if necessary."))
275
276 (defmethod slot-unbound ((class t) (instance discretionary-break)
277 (slot-name (eql 'break-penalty)))
278 *discretionary-break-penalty*)
279
280 (defclass discretionary-hyphen (discretionary-break)
281 ((pre-break-elements #-pcl :type #-pcl (cons * null)
282 :reader pre-break-elements
283 :documentation "Initialize this with the 'HYPHEN-CHAR initarg.")
284 (post-break-elements :type null :allocation :class)
285 (no-break-elements :type null :allocation :class)
286 (break-penalty :type null :allocation :class)))
287
288 #|
289 In LWPE:
290
291 Error: Defining method #<STANDARD-METHOD MAKE-INSTANCE (:AROUND) ((EQL #<STANDARD-CLASS
292 DISCRETIONARY-HYPHEN 2140C39C>)) 206696C4> visible from package COMMON-LISP.
293
294 Unfortunately, they signal a simple-error, so there's no way to reliably attach a
295 handler... unless I maybe look at the available restarts?
296 |#
297
298 (defmethod make-instance :around ((class (eql (find-class 'discretionary-hyphen)))
299 &rest initargs)
300 (restart-case
301 (call-next-method)
302 (try-discretionary-break () :report "Try making a DISCRETIONARY-BREAK instead."
303 (incf (getf initargs 'break-penalty *discretionary-hyphen-penalty*) 0) ; ``ensure-property''
304 (destructuring-bind (&key ((hyphen-char hyphen-char) #\- hyphen-char-p)
305 ((pre-break-elements pre-break) nil pre-break-p)
306 &allow-other-keys)
307 initargs
308 (declare (ignore pre-break))
309 (cond
310 ((and hyphen-char-p pre-break-p)
311 (restart-case
312 (error "Both a hyphen character and the pre-break elements have been specified.")
313 (use-hyphen-char () :report "Use the hyphen character."
314 (setf (getf initargs 'pre-break-elements) (list hyphen-char))
315 (remf initargs 'hyphen-char))
316 (use-pre-break-elements () :report "Use the pre-break elements."
317 (remf initargs 'hyphen-char))))
318 (pre-break-p)
319 (t (setf initargs (list* 'pre-break-elements hyphen-char initargs))
320 (remf initargs 'hyphen-char))))
321 (apply #'make-instance 'discretionary-break initargs))))
322
323 (defmethod shared-initialize :around ((object discretionary-hyphen) slots
324 &rest initargs
325 &key ((hyphen-char hyphen-char) #\-))
326 (declare (ignore slots))
327 (when (getf initargs 'break-penalty)
328 (cerror "Don't set it."
329 "Attempt to set break penalty for a discretionary hyphen in an instance's
330 initargs. Please either set *DISCRETIONARY-HYPHEN-PENALTY* to change it globally or use
331 the more generic DISCRETIONARY-BREAK.")
332 (remf initargs 'break-penalty))
333 (when (getf initargs 'pre-break-elements)
334 (cerror "Don't set it."
335 "Attempt to set pre-break elements for a discretionary hyphen. Please use the
336 more generic DISCRETIONARY-BREAK for this functionality.")
337 (remf initargs 'pre-break-elements))
338 (when (getf initargs 'post-break-elements)
339 (cerror "Don't set it."
340 "Attempt to set post-break elements for a discretionary hyphen. Please use the
341 more generic DISCRETIONARY-BREAK for this functionality.")
342 (remf initargs 'post-break-elements))
343 (when (getf initargs 'no-break-elements)
344 (cerror "Don't set it."
345 "Attempt to set no-break elements for a discretionary hyphen. Please use the
346 more generic DISCRETIONARY-BREAK for this functionality.")
347 (remf initargs 'no-break-elements))
348 (call-next-method object slots 'pre-break-elements (list hyphen-char) initargs))
349
350 (defmethod break-penalty ((object discretionary-hyphen))
351 *discretionary-hyphen-penalty*)
352
353 (defmethod (setf break-penalty) (new-value (object discretionary-hyphen))
354 (setf new-value *discretionary-hyphen-penalty*))
355
356 ;;;
357 ;;; Springs
358 ;;;
359
360 (deftype springiness-priority ()
361 '(signed-byte 8))
362
363 (defclass fixed-springiness ()
364 ((fixed-length :type length
365 :initarg :amount
366 :accessor fixed-length)
367 (priority :type springiness-priority
368 :initform 0
369 :initarg :priority
370 :accessor priority))
371 (:documentation "A fixed-size springiness."))
372
373 (defclass relative-springiness ()
374 ((springiness-portion :type rational
375 :initarg :amount
376 :accessor springiness-portion)
377 (priority :type springiness-priority
378 :initform 0
379 :initarg :priority
380 :accessor priority))
381 (:documentation "A fixed-size springiness whose size is a factor of the dimensions of
382 the associated element."))
383
384 (defclass infinite-springiness ()
385 ((springiness-portion :type rational
386 :initarg :amount
387 :accessor springiness-portion)
388 (priority :type springiness-priority
389 :initform 0
390 :initarg :priority
391 :accessor priority))
392 (:documentation "Infinite springiness takes priority over all other types and can
393 stretch or shrink infinitely."))
394
395 (define-specified-type springiness
396 :namespacep t
397 :cannonical-types (fixed-springiness infinite-springiness relative-springiness))
398
399 (defspringiness :none
400 (make-instance 'fixed-springiness :amount (make-length 0 t))
401 "A non-springy springiness.")
402
403 (defclass springy-mixin ()
404 ((stretch :initform (springiness :none)
405 :initarg stretch
406 :accessor stretch)
407 (shrink :initform (springiness :none)
408 :initarg shrink
409 :accessor shrink)))
410
411 (defclass spring (springy-mixin)
412 ((natural-length :type length
413 :initform 0
414 :initarg natural-length
415 :accessor natural-length)))
416
417 (define-specified-type spring
418 :namespacep t)
419
420 (defstruct spring-total
421 "Type expressing the total amount of length and springiness in a number of elements. No
422 units are given, since the measurements should be converted to a common unit before
423 accumulation."
424 (units t :type symbol)
425 (length 0 :type rational)
426 (fixed-stretch '() :type list #| alist of priority, total |#)
427 (fixed-shrink '() :type list #| alist of priority, total |#)
428 (infinite '() :type list #| alist of priority, total |#))
429
430 (defgeneric accumulate-springiness (spring-total springiness sign))
431
432 (defmethod accumulate-springiness ((spring-total spring-total)
433 (springiness fixed-springiness)
434 sign)
435 (let ((value (convert-length (fixed-length springiness) (spring-total-units spring-total)))
436 (priority (priority springiness)))
437 (ecase sign
438 (+1 (incf (getf (spring-total-fixed-stretch spring-total) priority 0)
439 value))
440 (-1 (incf (getf (spring-total-fixed-shrink spring-total) priority 0)
441 value)))))
442
443 (defun accumulate-spring (spring-total spring)
444 (declare (type spring-total spring-total))
445 (incf (spring-total-length spring-total) (fixed-length spring))
446 (accumulate-springiness spring-total (stretch spring) +1)
447 (accumulate-springiness spring-total (shrink spring) -1)
448 spring-total)
449
450 (defun springiness-spec-to-springiness-creation-form (amount units priority)
451 (let ((springiness-class
452 (cond ((string-equal (string units) "INF")
453 'infinite-springiness)
454 ((string-equal (string units) "%")
455 (setf amount (/ amount 100))
456 'relative-springiness)
457 (t (setf amount (make-length amount units))
458 'fixed-springiness))))
459 `(make-instance ',springiness-class :amount ',amount :priority ',priority)))
460
461 (defmacro make-spring (natural-amount natural-units &rest rest)
462 "The syntax is: ((natural-amount natural-units (direction [ name / (amount units
463 priority?)]{0,2}))) where DIRECTION is a symbol with a name of either + or - (at most one
464 of each allowed per definition) to indiciate whether the following items define stretching
465 or shrinking, and PRIORITY is an optional numeric identifier of how much precedence the
466 stretch or shrink should take over others. A priority of 0 is normal, a priority of 1
467 indicates that this one should be used before all those of priority 0, etc. Priorities
468 from -127 to 128 are allowed. The UNITS of a stretch or shrink may be the name of any
469 defined length unit (see: define-length-unit), % to indicate springiness relative to the
470 natural length, or INF to indicate an infinite amount of stretch or shrink. If a NAME is
471 given instead, it is looked up in the springiness namespace (see: defspringiness)."
472 (declare (type real natural-amount)
473 (type symbol natural-units))
474 (let ((stretch nil)
475 (shrink nil))
476 (when rest
477 (loop repeat 2
478 while rest
479 do (let ((direction (find-symbol (symbol-name (pop rest)) #.*package*))
480 (amount (pop rest))
481 creation-form)
482 (etypecase amount
483 (real (let ((units (pop rest))
484 (priority (and (numberp (car rest))
485 (pop rest))))
486 (setf creation-form
487 (springiness-spec-to-springiness-creation-form
488 (rationalize amount) units priority))))
489 (symbol (setf creation-form `(springiness ,amount))))
490 (ecase direction
491 (+ (if stretch
492 (error "Attempting to create spring with two stretches.")
493 (setq stretch creation-form)))
494 (- (if shrink
495 (error "Attempting to create spring with two shrinks.")
496 (setq shrink creation-form)))))))
497 (when rest
498 (cerror "Ignore it."
499 "Junk in MAKE-SPRING form: ~A." rest))
500 `(make-instance 'spring
501 'natural-length ',(make-length (rationalize natural-amount) natural-units)
502 ,@(and stretch `('stretch ,stretch))
503 ,@(and shrink `('shrink ,shrink)))))
504
505 ;;;
506 ;;; Kerns
507 ;;;
508
509 (defclass kern ()
510 ((width :type length
511 :initarg width
512 :accessor width))
513 (:documentation "A small adjustment of spacing to make the surrounding letter shapes
514 flow more aesthetically. Usually automatically added based on font metric information; for
515 other situations, please define or use a subclass."))
516
517 (defclass explicit-kern (kern)
518 ()
519 (:documentation "A kern which was explicitly added to the text."))
520
521 (defclass accent-kern (kern)
522 ()
523 (:documentation "A kern which was added in order to make an accent character line up
524 with the accented character."))
525

  ViewVC Help
Powered by ViewVC 1.1.5