forked from dbmcclain/LispPlotter
-
Notifications
You must be signed in to change notification settings - Fork 1
Expand file tree
/
Copy pathplotter-strings.lisp
More file actions
204 lines (197 loc) · 7.89 KB
/
Copy pathplotter-strings.lisp
File metadata and controls
204 lines (197 loc) · 7.89 KB
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
(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 port string x y
&key
(x-alignment :left)
(y-alignment :baseline)
prev-bounds
font
(margin 2)
(transparent t)
(color (foreground-color port))
alpha
clip
(background :white)
&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 port string font)
(let* ((dx
(ecase x-alignment
(:left 0)
(:right (- left right))
(:center (floor (- left right) 2))))
(dy
(ecase y-alignment
(:top (- top))
(:bottom 0)
(:center (- (floor (- top bottom) 2) top))
(: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 (port (adjust-color port color alpha))
(with-mask
(port (and clip (adjust-box (plotter-box pane))))
(gp:draw-string
port string (+ x dx) (+ y dy)
:font font
:block (not transparent)
:background background)
new-bounds))))))
#+:LISPWORKS6.1
(defun draw-vert-string-x-y (pane port string x y
&key
(x-alignment :left)
(y-alignment :baseline)
font
prev-bounds
(margin 2)
(color (foreground-color port))
;(transparent t)
)
"Draw vertical string by appealing directly to Cocoa"
(declare (ignore pane))
(multiple-value-bind (lf tp rt bt)
(gp:get-string-extent port 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))))
(if (and
prev-bounds
(bounds-overlap-p
(expand-bounds prev-bounds margin) new-bounds))
prev-bounds
(progn
(gp:with-graphics-translation (port x y)
(gp:with-graphics-rotation (port (/ pi -2))
(gp:with-graphics-translation (port (- x) (- y))
(gp:draw-string
port 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 :LISPWORKS6.1))
(defun draw-vert-string-x-y (pane port string x y
&key
(x-alignment :left)
(y-alignment :baseline)
font
prev-bounds
(margin 2)
(color (foreground-color port))
;;(transparent t)
)
"Draw vertical string by appealing directly to Cocoa"
(declare (ignore pane))
(multiple-value-bind (lf tp rt bt)
(gp:get-string-extent port 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 port 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 :LISPWORKS6.1))
(defun draw-vert-string-x-y (pane port string x y
&key
(x-alignment :left)
(y-alignment :baseline)
font
prev-bounds
(margin 2)
(color (foreground-color port))
(transparent t))
"Draw vertical string by rotating bitmap of horizontal string"
(multiple-value-bind (lf tp rt bt)
(gp:get-string-extent port 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 port wd ht
:background (background-color port)
:foreground (foreground-color port)
:clear t)
(gp:draw-string
ph string 0 (- tp)
:font font
:foreground color
:block (not transparent))
(with-image
(port
(v-image
#+:COCOA (gp:make-image port ht wd)
#+:WIN32 (gp:make-image port 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 port v-image))
(gp:image-access-transfer-from-image ha)
(dotimes (ix wd)
(dotimes (iy ht)
(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 port v-image (+ x dy) (+ y dx))))
new-bounds)))))