1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
;;; cl-typesetting copyright 2003-2004 Marc Battyani see license.txt for the details
;;; You can reach me at marc.battyani@fractalconcept.com or marc@battyani.net
;;; The homepage of cl-typesetting is here: http://www.fractalconcept.com/asp/html/cl-typesetting.html
(in-package typeset)
(defmethod stroke (box x y)
)
(defmethod stroke :before ((box char-box) x y)
(when (functionp *pre-decoration*)
(funcall *pre-decoration*
box
x (+ y (baseline box) (offset box))
(dx box) (- (dy box)))))
(defmethod stroke :after ((box char-box) x y)
(when (functionp *post-decoration*)
(funcall *post-decoration*
box
x (+ y (baseline box) (offset box))
(dx box) (- (dy box)))))
(defmethod stroke ((hbox hbox) x y)
(decf x (baseline hbox))
(decf x (offset hbox))
(decf y (internal-baseline hbox))
(dolist (box (boxes hbox))
(stroke box x y)
(incf x (+ (dx box)(delta-size box)))))
(defmethod stroke ((vbox vbox) x y)
(incf y (baseline vbox))
(incf y (offset vbox))
(incf x (internal-baseline vbox))
(dolist (box (boxes vbox))
(stroke box x y)
(decf y (+ (dy box)(delta-size box)))))
(defmethod stroke ((box char-box) x y)
(pdf:in-text-mode
(pdf:move-text x (+ y (offset box)))
(pdf:set-font *font* *font-size*)
(pdf:set-text-x-scale (* *text-x-scale* 100))
(pdf:show-char (boxed-char box))))
(defmethod stroke ((line text-line) x y)
(decf y (internal-baseline line))
(let ((string ())
(offset 0)
(nb-spaces 0)
text-x text-y
(text-chunk ()))
(labels ((end-string ()
(when string
(push (coerce (nreverse string) unicode-string-type) text-chunk)
(setf string nil)))
(end-text-chunk ()
(end-string)
(setf nb-spaces 0)
(when (some 'stringp text-chunk)
(pdf:in-text-mode
(pdf:move-text text-x text-y)
(pdf:set-font *font* *font-size*)
(pdf:set-text-x-scale (* *text-x-scale* 100))
(pdf:show-spaced-strings (nreverse text-chunk)))
(setf text-chunk nil)))
(add-char (char-box)
(when (/= offset (offset char-box))
(end-text-chunk)
(setf offset (offset char-box)
text-y (+ offset y)))
(unless (or string text-chunk)
(setf text-x x text-y (+ offset y)))
(let ((char (boxed-char char-box)))
(when (find char "\\()" :test #'char=)
(push #\\ string))
(push char string)))
(add-spacing (space)
(setf space (round (/ (* -1000 space) *text-x-scale*) *font-size*))
(unless (zerop space)
(end-string)
(incf nb-spaces)(when (> nb-spaces 10)(end-text-chunk))
(when (or string text-chunk)
(push space text-chunk)))))
(loop for box in (boxes line)
for size = (+ (dx box)(delta-size box))
do
(cond
((or (functionp *pre-decoration*)
(functionp *post-decoration*))
(end-text-chunk)
(stroke box x y))
((char-box-p box)(add-char box))
((white-space-p box) (add-spacing size))
(t (end-text-chunk)(stroke box x y)))
(incf x size))
(end-text-chunk))))
(defmethod stroke ((style text-style) x y)
(when (font style)
(setf *font* (font style)))
(when (font-size style)
(setf *font-size* (font-size style)))
(when (text-x-scale style)
(setf *text-x-scale* (text-x-scale style)))
(when (color style)
(setf *color* (color style))
(pdf::set-color-fill *color*))
(when (pre-decoration style)
(setf *pre-decoration* (pre-decoration style)))
(when (post-decoration style)
(setf *post-decoration* (post-decoration style))))
|
