-
Notifications
You must be signed in to change notification settings - Fork 12
/
plotter-strings.lisp
229 lines (205 loc) · 8.8 KB
/
plotter-strings.lisp
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
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
(in-package :plotter)
(defun bounds-overlap-p (bounds1 bounds2)
(labels ((overlaps-p (bounds1 bounds2)
(destructuring-bind (left1 right1) bounds1
(destructuring-bind (left2 right2) bounds2
(declare (ignore right2))
(<= left1 left2 right1))
)))
(or (overlaps-p bounds1 bounds2)
(overlaps-p bounds2 bounds1))
))
(defun expand-bounds (bounds dx)
(list (- (first bounds) dx)
(+ (second bounds) dx)))
;; ------------------------------------------
(defun draw-string-x-y (pane string x y
&key
(x-alignment :left)
(y-alignment :baseline)
prev-bounds
font
(margin 2)
(transparent t)
(color (foreground-color pane))
alpha
clip
(background :white)
bg-alpha
&allow-other-keys)
;; Draw a string at some location, unless the bounds of the new string
;; overlap the previous bounds. This is used to avoid placing axis labels
;; too closely together along the grid.
(multiple-value-bind (left top right bottom)
(gp:get-string-extent pane string font)
(let* ((wd (- right left))
(dx (ecase x-alignment
(:left 0)
(:right (- wd))
(:center (- (floor wd 2)))
))
(dy (ecase y-alignment
(:top (- top))
(:bottom 0)
(:center (- (floor (+ top bottom) 2)))
(:baseline 0)))
(new-bounds (list (+ x left dx) (+ x right dx))))
(if (and prev-bounds
(bounds-overlap-p (expand-bounds prev-bounds margin) new-bounds))
prev-bounds
(with-color (pane (adjust-color pane color alpha))
(with-mask (pane (and clip
(adjust-box (plotter-box pane))))
(gp:draw-string pane string (+ x dx) (+ y dy)
:font font
:block (not transparent)
:background (adjust-color pane background bg-alpha))
new-bounds
)))
)))
;; ------------------------------------------
#+(OR :LISPWORKS6.1 :LISPWORKS7 :LISPWORKS8)
(defun draw-vert-string-x-y (pane string x y
&key
(x-alignment :left)
(y-alignment :baseline)
font
prev-bounds
(margin 2)
(color (foreground-color pane))
;;(transparent t)
)
;;
;; draw vertical string by appealing directly to Cocoa
;;
(multiple-value-bind (lf tp rt bt)
(gp:get-string-extent pane string font)
(declare (ignore bt tp))
(let* ((wd (- rt lf))
(dx (ecase x-alignment
(:right 0)
(:left (- wd))
(:center (- (floor wd 2)))
))
(new-bounds (list (+ y lf dx) (+ y rt dx))))
(if (and prev-bounds
(bounds-overlap-p (expand-bounds prev-bounds margin) new-bounds))
prev-bounds
(progn
(gp:with-graphics-translation (pane x y)
(gp:with-graphics-rotation (pane (/ pi -2))
(gp:with-graphics-translation (pane (- x) (- y))
(gp:draw-string pane string (+ x dx) (- y 2)
:font font
:color color
:alpha 1.0
:x-alignment x-alignment
:y-alignment y-alignment))))
new-bounds)
))))
#+(AND :COCOA (NOT (OR :LISPWORKS6.1 :LISPWORKS7 :LISPWORKS8)))
(defun draw-vert-string-x-y (pane string x y
&key
(x-alignment :left)
(y-alignment :baseline)
font
prev-bounds
(margin 2)
(color (foreground-color pane))
;;(transparent t)
)
;;
;; draw vertical string by appealing directly to Cocoa
;;
(declare (ignore pane))
(multiple-value-bind (lf tp rt bt)
(gp:get-string-extent pane string font)
(declare (ignore bt tp))
(let* ((wd (- rt lf -1))
(dx (ecase x-alignment
(:right 0)
(:left (- wd))
(:center (- (floor wd 2)))
))
(new-bounds (list (+ y lf dx) (+ y rt dx)))
(font-attrs (gp:font-description-attributes (gp:font-description font)))
(font-size (getf font-attrs :size))
(font-name (getf font-attrs :name)))
(if (and prev-bounds
(bounds-overlap-p (expand-bounds prev-bounds margin) new-bounds))
prev-bounds
(progn
(add-label pane string x y
:font font-name
:font-size font-size
:color color
:alpha 1.0
:x-alignment x-alignment
:y-alignment y-alignment
:angle 90.0)
new-bounds)
))))
#+(AND :WIN32 (NOT (OR :LISPWORKS6.1 :LISPWORKS7 :LISPWORKS8)))
(defun draw-vert-string-x-y (pane string x y
&key
(x-alignment :left)
(y-alignment :baseline)
font
prev-bounds
(margin 2)
(color (foreground-color pane))
(transparent t))
;;
;; draw vertical string by rotating bitmap of horizontal string
;;
(multiple-value-bind (lf tp rt bt)
(gp:get-string-extent pane string font)
(let* ((wd (- rt lf -1))
(ht (- bt tp -1))
(dy (ecase y-alignment
(:top 0)
(:bottom (- ht))
(:baseline tp)
(:center (floor tp 2))
))
(dx (ecase x-alignment
(:right 0)
(:left (- wd))
(:center (- (floor wd 2)))
))
(new-bounds (list (+ y lf dx) (+ y rt dx))))
(if (and prev-bounds
(bounds-overlap-p (expand-bounds prev-bounds margin) new-bounds))
prev-bounds
(let ((wd (round wd))
(ht (round ht)))
(with-pixmap-graphics-port (ph pane wd ht
:background (background-color pane)
:foreground (foreground-color pane)
:clear t)
(gp:draw-string ph string
0 (- tp)
:font font
:foreground color
:block (not transparent))
(with-image (pane (v-image #-:WIN32 (gp:make-image pane ht wd)
#+:WIN32 (gp:make-image pane ht wd
:alpha nil)
))
(with-image (ph (h-image (gp:make-image-from-port ph)))
(with-image-access (ha (gp:make-image-access ph h-image))
(with-image-access (va (gp:make-image-access pane v-image))
(gp:image-access-transfer-from-image ha)
(loop for ix from 0 below wd do
(loop for iy from 0 below ht do
(setf (gp:image-access-pixel va iy (- wd ix 1))
(gp:image-access-pixel ha ix iy))
))
(gp:image-access-transfer-to-image va)
)))
(gp:draw-image pane v-image
(+ x dy)
(+ y dx))
))
new-bounds))
)))