/[defdoc]/DefDoc/src/print-node.lisp
ViewVC logotype

Contents of /DefDoc/src/print-node.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (hide annotations) (vendor branch)
Sun Dec 7 23:27:06 2003 UTC (10 years, 4 months ago) by rjain
Branch: MAIN, defdoc
CVS Tags: start, HEAD
Changes since 1.1: +0 -0 lines
initial import

1 rjain 1.1 #|
2     (put 'define-print-node 'fi:common-lisp-indent-hook 1)
3     |#
4    
5     (in-package :lambdatex)
6    
7     (defvar *font-in-short-display* 0
8     "The font code that is assumed to be present when SHORT-DISPLAY begins;
9     deviations from this font will be printed.")
10    
11     (defun short-display (list &optional (stream *standard-output*))
12     "Prints highlights of list P.
13    
14     Adapted from the TeX sources, sections 174, 175, and 267."
15     (declare (type list list))
16     (let ((*standard-output* stream))
17     (dolist (n list)
18     (typecase n
19     (char-node
20     (when (not (eq (char-node-font n) *font-in-short-display*))
21     ;; print font identifier (section 267)
22     ;; Knuth checks that the font id is between font_base and
23     ;; font_max. If we use symbols, this is not needed.
24     (princ (char-node-font n))
25     (princ #\space)
26     (setq *font-in-short-display* (char-node-font n)))
27     (princ (char-node-char n)))
28     (rule-node (princ #\|))
29     (glue-node (when (not (eq (glue-node-spec n) +zero-glue+))
30     (princ #\space)))
31     (math-node (princ #\$))
32     (ligature-node (short-display (ligature-node-char-list n)))
33     (disc-node (short-display (disc-node-pre-break n))
34     (short-display (disc-node-post-break n))
35     (dotimes (i (disc-node-replace-count n))
36     (when n (setq n (disc-node-link n)))))
37     ((or box-node mark-node adjust-node unset-node whatsit-node)
38     (princ "[]"))))))
39    
40     ;;; SHOW-NODE-LIST helpers from TeX sources, section 176
41     ;;; basically, the TeX pretty-printer.
42     ;;; TODO: need to check if nesting/indentation works.
43     ;;; maybe make these use FORMAT?
44    
45     (defmacro define-print-node (type &body body)
46     `(defmethod print-object ((n ,type) stream)
47     (if *print-readably*
48     (call-next-method)
49     (let ((*standard-output* stream))
50     ,@body))))
51    
52     (define-print-node char-node
53     ;;; print font identifier (section 267).
54     ;;; Again, Knuth checks for a valid id.
55     (princ (char-node-font n))
56     (princ #\space)
57     (princ (char-node-char n)))
58    
59     (defun print-mark (n)
60     (declare (type mark-node n))
61     (princ #\{)
62     (show-token-list (mark-node-link n)
63     nil
64     (- +max-print-line+ 10)) ;; hrm??
65     (princ #\}))
66    
67     (defun print-rule-dimen (n)
68     (if (null n) (princ #\*) (princ n)))
69    
70     (defun print-glue (dim order s)
71     "Prints glue stretch and shrink, possibly followed by the name of finite
72     units.
73    
74     Adapted from TeX sources, section 177."
75     (princ dim)
76     (when (not (eq order :normal)) (princ (symbol-name order)))
77     (when (not (null s)) (princ s)))
78    
79     (defun print-glue-spec (n s)
80     "Prints a whole glue specification.
81    
82     Adapted from TeX sources, section 178."
83     (if (null n)
84     (princ #\*)
85     (progn
86     (princ (glue-spec-width n))
87     (when (not (null s)) (princ s))
88     (when (/= 0 (glue-spec-stretch n))
89     (princ " plus ")
90     (print-glue (glue-spec-stretch n) (glue-spec-stretch-order n) s))
91     (when (/= 0 (glue-spec-shrink n))
92     (print-glue (glue-spec-shrink n) (glue-spec-shrink-order n) s)))))
93    
94     ;;; From section 691, need procedures for displaying elements of mlists
95     ;;; From section 225, need PRINT-SKIP-PARAM
96    
97     ;;; SHOW-NODE-LIST is basically the lisp printer.
98    
99     (define-print-node hlist-node
100     (princ ":h")
101     (call-next-method))
102    
103     (define-print-node vlist-node
104     (princ ":v")
105     (call-next-method))
106    
107     (define-print-node box-node
108     (princ "box(")
109     (princ (box-node-height n))
110     (princ #\+)
111     (princ (box-node-depth n))
112     (princ ")x")
113     (princ (box-node-width n))
114     (let ((glue (box-node-glue-set n))
115     (sign (box-node-glue-sign n)))
116     (when (or (/= g 0) (not (eq sign :normal)))
117     (princ ", glue set ")
118     (when (eq sign :shrinking)
119     (princ "- "))
120     (cond
121     ((> glue 20000) (princ #\>) (setq glue 20000))
122     ((< glue -20000) (princ "< -") (setq glue 20000)))
123     (print-glue glue (box-node-glue-order n) 0)))
124     ;; now recurr on the contents
125     (write (box-node-list n) :stream stream))
126    
127     (define-print-node unset-node
128     (princ ":unsetbox(")
129     (princ (unset-node-height n))
130     (princ #\+)
131     (princ (unset-node-depth n))
132     (princ ")x")
133     (princ (unset-node-width n))
134     (when (> (unset-node-span-count n) 0)
135     (princ " (")
136     (princ (unset-node-span-count n))
137     (princ " columns"))
138     (when (/= 0 (unset-node-stretch 0))
139     (princ ", stretch ")
140     (print-glue (unset-node-glue-stretch n)
141     (unset-node-glue-stretch-order n)
142     nil))
143     (when (/= 0 (unset-node-shrink 0))
144     (princ ", shrink ")
145     (print-glue (unset-node-glue-shrink n)
146     (unset-node-glue-shrink-order n)
147     nil))
148     ;;; now recurr on the contents
149     (write (unset-node-list n) :stream stream))
150    
151     (define-print-node rule-node
152     (princ ":rule(")
153     (print-rule-dimen (rule-node-height n))
154     (princ #\+)
155     (print-rule-dimen (rule-node-depth n))
156     (princ ")x")
157     (print-rule-dimen (rule-node-width n)))
158    
159     (define-print-node insertion-node
160     (princ ":insert")
161     (princ (insertion-node-number n))
162     (princ ", natural size")
163     (princ (insertion-node-height n))
164     (princ "\; split(")
165     (print-glue-spec (insertion-node-split-top n) nil)
166     (princ #\,)
167     (print (insertion-node-depth n))
168     (princ "\; float cost ")
169     (princ (insertion-node-float-cost n))
170     ;;; now recurr on the contents
171     (write (insertion-node-vlist n) :stream stream))
172    
173     (define-print-node glue-node
174     (let ((type (glue-node-type n)))
175     (princ ":glue")
176     (when (not (eq :normal type))
177     (princ #\()
178     (princ (case type
179     (:cond-math ":nonscript")
180     (:mu ":mscript")
181     (t (skip-param type))))
182     (princ #\)))
183     (when (not (eq :cond-math type))
184     (princ #\space)
185     (print-glue (glue-node-spec n)
186     (if (eq :mu type) "mu" nil)))))
187    
188     (define-print-node leader-node
189     (princ #:)
190     (case (leader-node-type n)
191     (:centered (princ #\c))
192     (:expanded (princ #\x)))
193     (princ "leaders")
194     (print-glue-spec (leader-node-spec n) nil)
195     ;; now recurr on the contents
196     (write (leader-node-leader n) :stream stream))
197    
198     (define-print-node kern-node
199     (if (not (eq :mu (kern-node-type n)))
200     (progn
201     (princ ":kern")
202     (when (not (eq :normal (kern-node-type n)))
203     (princ #\space))
204     (princ (kern-node-width n))
205     (when (eq :accent (kern-node-type n))
206     (princ " (for accent)")))
207     (progn
208     (princ ":mkern")
209     (princ (kern-node-width n))
210     (princ "mu"))))
211    
212     (define-print-node math-node
213     (princ ":math")
214     (if (eq :before (math-node-position n))
215     (princ "on")
216     (princ "off"))
217     (when (/= 0 (math-node-width n))
218     (princ " surrounded ")
219     (princ (math-node-width n))))
220    
221     (define-print-node ligature-node
222     (call-next-method)
223     (princ " (ligature ")
224     (when (member (ligature-node-boundaries n) '(:left :both))
225     (princ "|"))
226     (let ((*font-in-short-display* (ligature-node-font n)))
227     (short-display (ligature-node-char-list n)))
228     (when (member (ligature-node-boundaries n) '(:right :both))
229     (princ "|"))
230     (princ #\)))
231    
232     (define-print-node penalty-node
233     (princ ":penalty ")
234     (princ (penalty-node-penalty n)))
235    
236     (define-print-node disc-node
237     (princ ":discretionary")
238     (when (> (disc-node-replace-count n) 0)
239     (princ " replacing ")
240     (princ (disc-node-replace-count n)))
241     ;; recur on the pre-break
242     (write (disc-node-pre-break n) :stream stream)
243     (princ #\|) ; this should actually add a "|" to
244     ; the end of the line leader.
245     ;; recur on the pre-break
246     (write (disc-node-post-break n) :stream stream))
247    
248     (define-print-node mark-node
249     (princ ":mark")
250     (print-mark n))
251    
252     (define-print-node adjust-node
253     (princ ":vadjust")
254     ;; recurr on contents
255     (write (adjust-node-vlist n) :stream stream))

  ViewVC Help
Powered by ViewVC 1.1.5