/[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.1 - (hide annotations)
Sun Dec 7 23:27:10 2003 UTC (10 years, 4 months ago) by rjain
Branch: MAIN
Branch point for: defdoc
Initial revision
1 rjain 1.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-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 :initform *default-rule-thickness*)))
184    
185     (defclass vertical-rule (vertical-element rule-mixin)
186     ((width :initform *default-rule-thickness*)))
187    
188     ;;;
189     ;;; Characters
190     ;;;
191    
192     (defclass simple-character ()
193     ((font :initarg font
194     :accessor font)
195     (code-number :type unsigned-byte
196     :initarg code-number
197     :accessor code-number
198     :documentation "The index of the character in the specified font.")))
199    
200     (deftype small-character ()
201     "Only usable for characters whose font and code-number can be represented as small
202     numbers. 7 bits for the font, 8 bits for the character code."
203     'fixnum)
204    
205     (defmethod font ((char fixnum))
206     (ldb (byte 7 8) char))
207    
208     (defmethod code-number ((char fixnum))
209     (ldb (byte 8 0) char))
210    
211     (defmethod font ((char character))
212     0)
213    
214     (defmethod code-number ((char character))
215     (char-code char))
216    
217     (defclass ligature (simple-character)
218     ((replaced-chars :type list
219     :initarg replaced-chars
220     :accessor replaced-chars
221     :documentation "The simple characters that were replaced, if any, in
222     order to form this ligature. Useful in, e.g., reconstructing the input text for
223     communication to the end-user or in outputting to a medium which does not have this (or
224     any) ligature."))
225     (:documentation "A character that is formed from the interaction of multiple characters."))
226    
227     ;;;
228     ;;; Breaking
229     ;;;
230    
231     (defclass penalty-node ()
232     ((break-penalty :type penalty
233     :initarg break-penalty
234     :accessor break-penalty))
235     (:documentation "A node indicating the penalty associated with breaking at this specific
236     location."))
237    
238     (defclass discretionary-break (penalty-node)
239     ((pre-break-elements :type list
240     :initform nil
241     :initarg pre-break-elements
242     :accessor pre-break-elements
243     :documentation "The text to precede the break if it is used.")
244     (post-break-elements :type list
245     :initform nil
246     :initarg post-break-elements
247     :accessor post-break-elements
248     :documentation "The text to follow the break if it is used.")
249     (no-break-elements :type list
250     :initform nil
251     :initarg no-break-elements
252     :accessor no-break-elements
253     :documentation "The text to be placed here if the break is not used.")
254     #+nil
255     (num-elements-replaced :type unsigned-byte
256     :initform nil
257     :initarg num-elements-replaced
258     :accessor num-elements-replaced
259     :documentation "The number of elements to be skipped if the break
260     is used. This is the way that Knuth's TeX program implements this data structure (instead
261     of the previous slot).")
262     #+nil
263     (break-skip-to :type list
264     :initarg break-skip-to
265     :accessor break-skip-to
266     :documentation "The cons containing the element to skip to if the
267     break is used. Another way of implementing the previous slot."))
268     (:documentation "A location where a break can be placed, if necessary."))
269    
270     (defmethod slot-unbound ((class t) (instance discretionary-break)
271     (slot-name (eql 'break-penalty)))
272     *discretionary-break-penalty*)
273    
274     (defclass discretionary-hyphen (discretionary-break)
275     ((pre-break-elements #-pcl :type #-pcl (cons * null)
276     :reader pre-break-elements
277     :documentation "Initialize this with the 'HYPHEN-CHAR initarg.")
278     (post-break-elements :type null :allocation :class)
279     (no-break-elements :type null :allocation :class)
280     (break-penalty :type null :allocation :class)))
281    
282     #|
283     In LWPE:
284    
285     Error: Defining method #<STANDARD-METHOD MAKE-INSTANCE (:AROUND) ((EQL #<STANDARD-CLASS
286     DISCRETIONARY-HYPHEN 2140C39C>)) 206696C4> visible from package COMMON-LISP.
287    
288     Unfortunately, they signal a simple-error, so there's no way to reliably attach a
289     handler... unless I maybe look at the available restarts?
290     |#
291    
292     (defmethod make-instance :around ((class (eql (find-class 'discretionary-hyphen)))
293     &rest initargs)
294     (restart-case
295     (call-next-method)
296     (try-discretionary-break () :report "Try making a DISCRETIONARY-BREAK instead."
297     (incf (getf initargs 'break-penalty *discretionary-hyphen-penalty*) 0) ; ``ensure-property''
298     (destructuring-bind (&key ((hyphen-char hyphen-char) #\- hyphen-char-p)
299     ((pre-break-elements pre-break) nil pre-break-p)
300     &allow-other-keys)
301     initargs
302     (declare (ignore pre-break))
303     (cond
304     ((and hyphen-char-p pre-break-p)
305     (restart-case
306     (error "Both a hyphen character and the pre-break elements have been specified.")
307     (use-hyphen-char () :report "Use the hyphen character."
308     (setf (getf initargs 'pre-break-elements) (list hyphen-char))
309     (remf initargs 'hyphen-char))
310     (use-pre-break-elements () :report "Use the pre-break elements."
311     (remf initargs 'hyphen-char))))
312     (pre-break-p)
313     (t (setf initargs (list* 'pre-break-elements hyphen-char initargs))
314     (remf initargs 'hyphen-char))))
315     (apply #'make-instance 'discretionary-break initargs))))
316    
317     (defmethod shared-initialize :around ((object discretionary-hyphen) slots
318     &rest initargs
319     &key ((hyphen-char hyphen-char) #\-))
320     (declare (ignore slots))
321     (when (getf initargs 'break-penalty)
322     (cerror "Don't set it."
323     "Attempt to set break penalty for a discretionary hyphen in an instance's
324     initargs. Please either set *DISCRETIONARY-HYPHEN-PENALTY* to change it globally or use
325     the more generic DISCRETIONARY-BREAK.")
326     (remf initargs 'break-penalty))
327     (when (getf initargs 'pre-break-elements)
328     (cerror "Don't set it."
329     "Attempt to set pre-break elements for a discretionary hyphen. Please use the
330     more generic DISCRETIONARY-BREAK for this functionality.")
331     (remf initargs 'pre-break-elements))
332     (when (getf initargs 'post-break-elements)
333     (cerror "Don't set it."
334     "Attempt to set post-break elements for a discretionary hyphen. Please use the
335     more generic DISCRETIONARY-BREAK for this functionality.")
336     (remf initargs 'post-break-elements))
337     (when (getf initargs 'no-break-elements)
338     (cerror "Don't set it."
339     "Attempt to set no-break elements for a discretionary hyphen. Please use the
340     more generic DISCRETIONARY-BREAK for this functionality.")
341     (remf initargs 'no-break-elements))
342     (call-next-method object slots 'pre-break-elements (list hyphen-char) initargs))
343    
344     (defmethod break-penalty ((object discretionary-hyphen))
345     *discretionary-hyphen-penalty*)
346    
347     (defmethod (setf break-penalty) (new-value (object discretionary-hyphen))
348     (setf new-value *discretionary-hyphen-penalty*))
349    
350     ;;;
351     ;;; Springs
352     ;;;
353    
354     (deftype springiness-priority ()
355     '(signed-byte 8))
356    
357     (defclass fixed-springiness ()
358     ((fixed-length :type length
359     :initarg :amount
360     :accessor fixed-length)
361     (priority :type springiness-priority
362     :initform 0
363     :initarg :priority
364     :accessor priority))
365     (:documentation "A fixed-size springiness."))
366    
367     (defclass relative-springiness ()
368     ((springiness-portion :type rational
369     :initarg :amount
370     :accessor springiness-portion)
371     (priority :type springiness-priority
372     :initform 0
373     :initarg :priority
374     :accessor priority))
375     (:documentation "A fixed-size springiness whose size is a factor of the dimensions of
376     the associated element."))
377    
378     (defclass infinite-springiness ()
379     ((springiness-portion :type rational
380     :initarg :amount
381     :accessor springiness-portion)
382     (priority :type springiness-priority
383     :initform 0
384     :initarg :priority
385     :accessor priority))
386     (:documentation "Infinite springiness takes priority over all other types and can
387     stretch or shrink infinitely."))
388    
389     (define-specified-type springiness
390     :namespacep t
391     :cannonical-types (fixed-springiness infinite-springiness relative-springiness))
392    
393     (defspringiness :none
394     (make-instance 'fixed-springiness :amount (make-length 0 t))
395     "A non-springy springiness.")
396    
397     (defclass springy-mixin ()
398     ((stretch :initform (springiness :none)
399     :initarg stretch
400     :accessor stretch)
401     (shrink :initform (springiness :none)
402     :initarg shrink
403     :accessor shrink)))
404    
405     (defclass spring (springy-mixin)
406     ((natural-length :type length
407     :initform 0
408     :initarg natural-length
409     :accessor natural-length)))
410    
411     (define-specified-type spring
412     :namespacep t)
413    
414     (defstruct spring-total
415     "Type expressing the total amount of length and springiness in a number of elements. No
416     units are given, since the measurements should be converted to a common unit before
417     accumulation."
418     (units t :type symbol)
419     (length 0 :type rational)
420     (fixed-stretch '() :type list #| alist of priority, total |#)
421     (fixed-shrink '() :type list #| alist of priority, total |#)
422     (infinite '() :type list #| alist of priority, total |#))
423    
424     (defgeneric accumulate-springiness (spring-total springiness sign))
425    
426     (defmethod accumulate-springiness ((spring-total spring-total)
427     (springiness fixed-springiness)
428     sign)
429     (let ((value (convert-length (fixed-length springiness) (spring-total-units spring-total)))
430     (priority (priority springiness)))
431     (ecase sign
432     (+1 (incf (getf (spring-total-fixed-stretch spring-total) priority 0)
433     value))
434     (-1 (incf (getf (spring-total-fixed-shrink spring-total) priority 0)
435     value)))))
436    
437     (defun accumulate-spring (spring-total spring)
438     (declare (type spring-total spring-total))
439     (incf (spring-total-length spring-total) (fixed-length spring))
440     (accumulate-springiness spring-total (stretch spring) +1)
441     (accumulate-springiness spring-total (shrink spring) -1)
442     spring-total)
443    
444     (defun springiness-spec-to-springiness-creation-form (amount units priority)
445     (let ((springiness-class
446     (cond ((string-equal (string units) "INF")
447     'infinite-springiness)
448     ((string-equal (string units) "%")
449     (setf amount (/ amount 100))
450     'relative-springiness)
451     (t (setf amount (make-length amount units))
452     'fixed-springiness))))
453     `(make-instance ',springiness-class :amount ',amount :priority ',priority)))
454    
455     (defmacro make-spring (natural-amount natural-units &rest rest)
456     "The syntax is: ((natural-amount natural-units (direction [ name / (amount units
457     priority?)]{0,2}))) where DIRECTION is a symbol with a name of either + or - (at most one
458     of each allowed per definition) to indiciate whether the following items define stretching
459     or shrinking, and PRIORITY is an optional numeric identifier of how much precedence the
460     stretch or shrink should take over others. A priority of 0 is normal, a priority of 1
461     indicates that this one should be used before all those of priority 0, etc. Priorities
462     from -127 to 128 are allowed. The UNITS of a stretch or shrink may be the name of any
463     defined length unit (see: define-length-unit), % to indicate springiness relative to the
464     natural length, or INF to indicate an infinite amount of stretch or shrink. If a NAME is
465     given instead, it is looked up in the springiness namespace (see: defspringiness)."
466     (declare (type real natural-amount)
467     (type symbol natural-units))
468     (let ((stretch nil)
469     (shrink nil))
470     (when rest
471     (loop repeat 2
472     while rest
473     do (let ((direction (find-symbol (symbol-name (pop rest)) #.*package*))
474     (amount (pop rest))
475     creation-form)
476     (etypecase amount
477     (real (let ((units (pop rest))
478     (priority (and (numberp (car rest))
479     (pop rest))))
480     (setf creation-form
481     (springiness-spec-to-springiness-creation-form
482     (rationalize amount) units priority))))
483     (symbol (setf creation-form `(springiness ,amount))))
484     (ecase direction
485     (+ (if stretch
486     (error "Attempting to create spring with two stretches.")
487     (setq stretch creation-form)))
488     (- (if shrink
489     (error "Attempting to create spring with two shrinks.")
490     (setq shrink creation-form)))))))
491     (when rest
492     (cerror "Ignore it."
493     "Junk in MAKE-SPRING form: ~A." rest))
494     `(make-instance 'spring
495     'natural-length ',(make-length (rationalize natural-amount) natural-units)
496     ,@(and stretch `('stretch ,stretch))
497     ,@(and shrink `('shrink ,shrink)))))
498    
499     ;;;
500     ;;; Kerns
501     ;;;
502    
503     (defclass kern ()
504     ((width :type length
505     :initarg width
506     :accessor width))
507     (:documentation "A small adjustment of spacing to make the surrounding letter shapes
508     flow more aesthetically. Usually automatically added based on font metric information; for
509     other situations, please define or use a subclass."))
510    
511     (defclass explicit-kern (kern)
512     ()
513     (:documentation "A kern which was explicitly added to the text."))
514    
515     (defclass accent-kern (kern)
516     ()
517     (:documentation "A kern which was added in order to make an accent character line up
518     with the accented character."))
519    

  ViewVC Help
Powered by ViewVC 1.1.5