mp-tool.mpiv /size: 111 Kb    last modification: 2021-10-28 13:50
1
%D \module
2
%D [ file=mp-tool.mpiv,
3
%D version=1998.02.15,
4
%D title=\CONTEXT\ \METAPOST\ graphics,
5
%D subtitle=auxiliary macros,
6
%D author=Hans Hagen,
7
%D date=\currentdate,
8
%D copyright={PRAGMA ADE \& \CONTEXT\ Development Team}]
9
%C
10
%C This module is part of the \CONTEXT\ macro||package and is
11
%C therefore copyrighted by \PRAGMA. See mreadme.pdf for
12
%C details.
13 14
if
known
context_tool
:
endinput
;
fi
;
15 16
boolean
context_tool
;
context_tool
:
=
true
;
17 18
let
@#
#
=
@#
;
19 20
let
noexpand
=
quote
;
21 22
%D New, version number testing:
23
%D
24
%D \starttyping
25
%D fill fullcircle scaled 2cm withcolor if mpversiongt("0.6") : red else : green fi ;
26
%D fill fullcircle scaled 1cm withcolor if mpversionlt(0.6) : blue else : white fi ;
27
%D \stoptyping
28 29
if
not
known
mpversion
:
string
mpversion
;
mpversion
:
=
"
0.641
"
;
fi
;
30 31
% newinternal metapostversion ; metapostversion := scantokens(mpversion) ;
32 33
newinternal
metapostversion
;
metapostversion
:
=
2.0
;
34 35
%D We always want \EPS\ conforming output, so we say:
36 37
prologues
:
=
1
;
38
warningcheck
:
=
0
;
39
mpprocset
:
=
1
;
40 41
%D Handy:
42 43
def
nothing
=
enddef
;
44 45
%D Namespace handling:
46 47
% let exclamationmark = ! ;
48
% let questionmark = ? ;
49
%
50
% def unprotect =
51
% let ! = relax ;
52
% let ? = relax ;
53
% enddef ;
54
%
55
% def protect =
56
% let ! = exclamationmark ;
57
% let ? = questionmark ;
58
% enddef ;
59
%
60
% unprotect ;
61
%
62
% mp!some!module = 10 ; show mp!some!module ; show somemodule ;
63
%
64
% protect ;
65 66
string
space
;
space
:
=
char
32
;
67
string
percent
;
percent
:
=
char
37
;
68
string
crlf
;
crlf
:
=
char
10
&
char
13
;
69
string
dquote
;
dquote
:
=
char
34
;
70 71
let
SPACE
=
space
;
72
let
CRLF
=
crlf
;
73
let
DQUOTE
=
dquote
;
74
let
PERCENT
=
percent
;
75 76
vardef
ddecimal
primary
p
=
77
decimal
xpart
p
&
"
"
&
decimal
ypart
p
78
enddef
;
79 80
%D Plain compatibility:
81 82
string
plain_compatibility_data
;
plain_compatibility_data
:
=
"
"
;
83 84
def
startplaincompatibility
=
85
begingroup
;
86
scantokens
plain_compatibility_data
;
87
enddef
;
88 89
def
stopplaincompatibility
=
90
endgroup
;
91
enddef
;
92 93
%D More neutral:
94 95
let
triplet
=
rgbcolor
;
96
let
quadruplet
=
cmykcolor
;
97 98
%D Image redefined, for Alan:
99 100
vardef
image
@#
(
text
t
)
=
101
save
currentpicture
;
102
picture
currentpicture
;
103
currentpicture
:
=
nullpicture
;
104
t
;
105
currentpicture
106
if
str
@#
<
>
"
"
:
107
shifted
(
108
mfun_labxf
@#
*
lrcorner
p
109
+
mfun_labyf
@#
*
ulcorner
p
110
+
(
1
-
mfun_labxf
@#
-
mfun_labyf
@#
)
*
llcorner
p
111
)
112
fi
113
enddef
;
114 115
%D Variables
116 117
def
dispose
suffix
s
=
118
if
known
s
:
119
begingroup
;
120
save
ss
;
121
if
numeric
s
:
numeric
ss
122
elseif
boolean
s
:
boolean
ss
123
elseif
pair
s
:
pair
ss
124
elseif
path
s
:
path
ss
125
elseif
picture
s
:
picture
ss
126
elseif
string
s
:
string
ss
127
elseif
transform
s
:
transform
ss
128
elseif
color
s
:
color
ss
129
elseif
rgbcolor
s
:
rgbcolor
ss
130
elseif
cmykcolor
s
:
cmykcolor
ss
131
elseif
pen
s
:
pen
ss
132
else
s
:
numeric
ss
133
fi
;
134
s
:
=
ss
;
135
endgroup
;
136
fi
;
137
enddef
;
138 139
%D Colors:
140 141
let
grayscale
=
graycolor
;
142
let
greyscale
=
greycolor
;
143 144
vardef
colorpart
expr
c
=
145
if
not
picture
c
:
146
0
147
elseif
colormodel
c
=
greycolormodel
:
148
greypart
c
149
elseif
colormodel
c
=
rgbcolormodel
:
150
(
redpart
c
,
greenpart
c
,
bluepart
c
)
151
elseif
colormodel
c
=
cmykcolormodel
:
152
(
cyanpart
c
,
magentapart
c
,
yellowpart
c
,
blackpart
c
)
153
else
:
154
0
% black
155
fi
156
enddef
;
157 158
vardef
colorlike
(
text
c
)
text
v
=
% colorlike(a) b, c, d ;
159
save
_p_
;
picture
_p_
;
160
forsuffixes
i
=
v
:
161
_p_
:
=
image
(
draw
origin
withcolor
c
;
)
;
% intercept pre and postscripts
162
if
(
colormodel
_p_
=
cmykcolormodel
)
:
163
cmykcolor
i
;
164
elseif
(
colormodel
_p_
=
rgbcolormodel
)
:
165
rgbcolor
i
;
166
else
:
167
greycolor
i
;
168
fi
;
169
endfor
;
170
enddef
;
171 172
%D Also handy (when we flush colors):
173 174
vardef
dddecimal
primary
c
=
175
decimal
redpart
c
&
"
"
&
decimal
greenpart
c
&
"
"
&
decimal
bluepart
c
176
enddef
;
177 178
vardef
ddddecimal
primary
c
=
179
decimal
cyanpart
c
&
"
"
&
decimal
magentapart
c
&
"
"
&
decimal
yellowpart
c
&
"
"
&
decimal
blackpart
c
180
enddef
;
181 182
vardef
colordecimals
primary
c
=
183
if
cmykcolor
c
:
184
decimal
cyanpart
c
&
"
:
"
&
decimal
magentapart
c
&
"
:
"
&
decimal
yellowpart
c
&
"
:
"
&
decimal
blackpart
c
185
elseif
rgbcolor
c
:
186
decimal
redpart
c
&
"
:
"
&
decimal
greenpart
c
&
"
:
"
&
decimal
bluepart
c
187
elseif
string
c
:
188
colordecimals
resolvedcolor
(
c
)
189
else
:
190
decimal
c
191
fi
192
enddef
;
193 194
vardef
colordecimalslist
(
text
t
)
=
195
save
b
;
boolean
b
;
b
:
=
false
;
196
for
s
=
t
:
197
if
b
:
&
"
"
&
fi
198
colordecimals
(
s
)
199
hide
(
b
:
=
true
;
)
200
endfor
201
enddef
;
202 203
% vardef _ctx_color_spec_ primary c =
204
% if cmykcolor c :
205
% "c=" & decimal cyanpart c &
206
% ",m=" & decimal magentapart c &
207
% ",y=" & decimal yellowpart c &
208
% ",k=" & decimal blackpart c
209
% elseif rgbcolor c :
210
% "r=" & decimal redpart c &
211
% ",g=" & decimal greenpart c &
212
% ",b=" & decimal bluepart c
213
% else :
214
% "s=" & decimal c
215
% fi
216
% enddef ;
217
%
218
% vardef _ctx_color_spec_list_(text t) =
219
% save b ; boolean b ; b := false ;
220
% for s=t :
221
% if b : & " " & fi
222
% _ctx_color_spec_(s)
223
% hide(b := true ;)
224
% endfor
225
% enddef ;
226 227
%D We have standardized data file names:
228 229
def
job_name
=
230
jobname
231
enddef
;
232 233
%D Because \METAPOST\ has a hard coded limit of 4~datafiles,
234
%D we need some trickery when we have multiple files. This will
235
%D be redone (via \LUA).
236 237
boolean
savingdata
;
savingdata
:
=
false
;
238
boolean
savingdatadone
;
savingdatadone
:
=
false
;
239 240
def
savedata
expr
txt
=
241
lua.mp.mf_save_data
(
txt
)
;
242
enddef
;
243 244
def
startsavingdata
=
245
lua.mp.mf_start_saving_data
(
)
;
246
enddef
;
247 248
def
stopsavingdata
=
249
lua.mp.mf_stop_saving_data
(
)
;
250
enddef
;
251 252
def
finishsavingdata
=
253
lua.mp.mf_finish_saving_data
(
)
;
254
enddef
;
255 256
%D Instead of a keystroke eating save and allocation
257
%D sequence, you can use the \citeer {new} alternatives to
258
%D save and allocate in one command.
259 260
def
newcolor
text
v
=
forsuffixes
i
=
v
:
save
i
;
color
i
;
endfor
;
enddef
;
261
def
newnumeric
text
v
=
forsuffixes
i
=
v
:
save
i
;
numeric
i
;
endfor
;
enddef
;
262
def
newboolean
text
v
=
forsuffixes
i
=
v
:
save
i
;
boolean
i
;
endfor
;
enddef
;
263
def
newtransform
text
v
=
forsuffixes
i
=
v
:
save
i
;
transform
i
;
endfor
;
enddef
;
264
def
newpath
text
v
=
forsuffixes
i
=
v
:
save
i
;
path
i
;
endfor
;
enddef
;
265
def
newpicture
text
v
=
forsuffixes
i
=
v
:
save
i
;
picture
i
;
endfor
;
enddef
;
266
def
newstring
text
v
=
forsuffixes
i
=
v
:
save
i
;
string
i
;
endfor
;
enddef
;
267
def
newpair
text
v
=
forsuffixes
i
=
v
:
save
i
;
pair
i
;
endfor
;
enddef
;
268 269
%D Sometimes we don't want parts of the graphics add to the
270
%D bounding box. One way of doing this is to save the bounding
271
%D box, draw the graphics that may not count, and restore the
272
%D bounding box.
273
%D
274
%D \starttyping
275
%D push_boundingbox currentpicture;
276
%D pop_boundingbox currentpicture;
277
%D \stoptyping
278
%D
279
%D The bounding box can be called with:
280
%D
281
%D \starttyping
282
%D boundingbox currentpicture
283
%D inner_boundingbox currentpicture
284
%D outer_boundingbox currentpicture
285
%D \stoptyping
286
%D
287
%D Especially the latter one can be of use when we include
288
%D the graphic in a document that is clipped to the bounding
289
%D box. In such occasions one can use:
290
%D
291
%D \starttyping
292
%D set_outer_boundingbox currentpicture;
293
%D \stoptyping
294
%D
295
%D Its counterpart is:
296
%D
297
%D \starttyping
298
%D set_inner_boundingbox p
299
%D \stoptyping
300 301
path
mfun_boundingbox_stack
[
]
;
302
numeric
mfun_boundingbox_stack_depth
;
303 304
mfun_boundingbox_stack_depth
:
=
0
;
305 306
def
pushboundingbox
text
p
=
307
mfun_boundingbox_stack_depth
:
=
mfun_boundingbox_stack_depth
+
1
;
308
mfun_boundingbox_stack
[
mfun_boundingbox_stack_depth
]
:
=
boundingbox
p
;
309
enddef
;
310 311
def
popboundingbox
text
p
=
312
setbounds
p
to
mfun_boundingbox_stack
[
mfun_boundingbox_stack_depth
]
;
313
mfun_boundingbox_stack
[
mfun_boundingbox_stack_depth
]
:
=
origin
--
cycle
;
314
mfun_boundingbox_stack_depth
:
=
mfun_boundingbox_stack_depth
-
1
;
315
enddef
;
316 317
let
push_boundingbox
=
pushboundingbox
;
% downward compatible
318
let
pop_boundingbox
=
popboundingbox
;
% downward compatible
319 320
vardef
boundingbox
primary
p
=
321
if
(
path
p
)
or
(
picture
p
)
:
322
llcorner
p
--
lrcorner
p
--
urcorner
p
--
ulcorner
p
323
else
:
324
origin
325
fi
--
cycle
326
enddef
;
327 328
vardef
innerboundingbox
primary
p
=
329
top
rt
llcorner
p
--
330
top
lft
lrcorner
p
--
331
bot
lft
urcorner
p
--
332
bot
rt
ulcorner
p
--
cycle
333
enddef
;
334 335
vardef
outerboundingbox
primary
p
=
336
bot
lft
llcorner
p
--
337
bot
rt
lrcorner
p
--
338
top
rt
urcorner
p
--
339
top
lft
ulcorner
p
--
cycle
340
enddef
;
341 342
def
inner_boundingbox
=
innerboundingbox
enddef
;
343
def
outer_boundingbox
=
outerboundingbox
enddef
;
344 345
vardef
set_inner_boundingbox
text
q
=
% obsolete
346
setbounds
q
to
innerboundingbox
q
;
347
enddef
;
348 349
vardef
set_outer_boundingbox
text
q
=
% obsolete
350
setbounds
q
to
outerboundingbox
q
;
351
enddef
;
352 353
% secondarydef a boundedto b = % will this cleanup ?
354
% hide(picture mfun_a_b ; mfun_a_b := a ; setbounds mfun_a_b to b;)
355
% mfun_a_b
356
% enddef ;
357 358
%D Here are some special ones, cooked up in the process of Alan's mp-node
359
%D module:
360 361
vardef
boundingradius
primary
p
=
362
if
picture
p
:
363
max
(
364
abs
(
(
llcorner
p
)
shifted
-
center
p
)
,
365
abs
(
(
lrcorner
p
)
shifted
-
center
p
)
,
366
abs
(
(
urcorner
p
)
shifted
-
center
p
)
,
367
abs
(
(
ulcorner
p
)
shifted
-
center
p
)
368
)
369
elseif
pen
p
:
370
boundingradius
image
(
draw
makepath
p
;
)
371
elseif
path
p
:
372
boundingradius
image
(
draw
p
;
)
373
fi
374
enddef
;
375 376
vardef
boundingcircle
primary
p
=
377
fullcircle
scaled
2
boundingradius
p
shifted
center
p
378
enddef
;
379 380
vardef
boundingpoint
@#
(
expr
p
)
=
381
if
picture
p
:
% pen?
382
(
mfun_labxf
@#
*
ulcorner
p
383
+
mfun_labyf
@#
*
lrcorner
p
384
+
(
1
-
mfun_labxf
@#
-
mfun_labyf
@#
)
*
urcorner
p
)
385
elseif
path
p
:
386
boundingpoint
@#
(
image
(
draw
p
;
)
)
387
%elseif pair p :
388
% p
389
%else :
390
% origin
391
fi
392
enddef
;
393 394
def
mirrored
primary
a
=
395
a
scaled
-1
396
enddef
;
397 398
primarydef
a
mirroredabout
b
=
399
(
a
shifted
-
b
)
scaled
-1
shifted
b
400
enddef
;
401 402
%D Some missing functions can be implemented rather straightforward (thanks to
403
%D Taco and others):
404 405
% oldpi := 3.14159265358979323846 ; % from <math.h>
406
pi
:
=
3.14159265358979323846264338327950288419716939937510
;
% 50 digits
407
radian
:
=
180
/
pi
;
% 2pi*radian = 360 ;
408 409
% let +++ = ++ ;
410 411
vardef
sqr
primary
x
=
x
*
x
enddef
;
412
vardef
log
primary
x
=
if
x
=
0
:
0
else
:
mlog
(
x
)
/
mlog
(
10
)
fi
enddef
;
413
vardef
ln
primary
x
=
if
x
=
0
:
0
else
:
mlog
(
x
)
/
256
fi
enddef
;
414
vardef
exp
primary
x
=
(
mexp
256
)
*
*
x
enddef
;
415
vardef
inv
primary
x
=
if
x
=
0
:
0
else
:
x
*
*
-1
fi
enddef
;
416 417
vardef
pow
(
expr
x
,
p
)
=
x
*
*
p
enddef
;
418 419
vardef
tand
primary
x
=
sind
(
x
)
/
cosd
(
x
)
enddef
;
420
vardef
cotd
primary
x
=
cosd
(
x
)
/
sind
(
x
)
enddef
;
421 422
vardef
sin
primary
x
=
sind
(
x
*
radian
)
enddef
;
423
vardef
cos
primary
x
=
cosd
(
x
*
radian
)
enddef
;
424
vardef
tan
primary
x
=
sin
(
x
)
/
cos
(
x
)
enddef
;
425
vardef
cot
primary
x
=
cos
(
x
)
/
sin
(
x
)
enddef
;
426 427
vardef
asin
primary
x
=
angle
(
(
1
+-+
x
,
x
)
)
enddef
;
428
vardef
acos
primary
x
=
angle
(
(
x
,
1
+-+
x
)
)
enddef
;
429
vardef
atan
primary
x
=
angle
(
1
,
x
)
enddef
;
430 431
vardef
invsin
primary
x
=
(
asin
(
x
)
)
/
radian
enddef
;
432
vardef
invcos
primary
x
=
(
acos
(
x
)
)
/
radian
enddef
;
433
vardef
invtan
primary
x
=
(
atan
(
x
)
)
/
radian
enddef
;
434 435
vardef
acosh
primary
x
=
ln
(
x
+
(
x
+-+
1
)
)
enddef
;
436
vardef
asinh
primary
x
=
ln
(
x
+
(
x
++
1
)
)
enddef
;
437 438
vardef
sinh
primary
x
=
save
xx
;
xx
=
exp
x
;
(
xx
-1
/
xx
)
/
2
enddef
;
439
vardef
cosh
primary
x
=
save
xx
;
xx
=
exp
x
;
(
xx
+1
/
xx
)
/
2
enddef
;
440
vardef
tanh
primary
x
=
save
xx
;
xx
=
exp
x
;
(
xx
-1
/
xx
)
/
(
xx
+1
/
xx
)
enddef
;
441 442
%D Like mod, but useful for angles, it returns (-.5d,+.5d] and is used
443
%D in for instance mp-chem.
444 445
primarydef
a
zmod
b
=
(
-
(
(
b
/
2
-
a
)
mod
b
)
+
b
/
2
)
enddef
;
446 447
%D Sometimes this is handy:
448 449
def
undashed
=
450
dashed
nullpicture
451
enddef
;
452 453
%D We provide two macros for drawing stripes across a shape.
454
%D The first method (with the n suffix) uses another method,
455
%D slower in calculation, but more efficient when drawn. The
456
%D first macro divides the sides into n equal parts. The
457
%D first argument specifies the way the lines are drawn, while
458
%D the second argument identifier the way the shape is to be
459
%D drawn.
460
%D
461
%D \starttyping
462
%D stripe_path_n
463
%D (dashed evenly withcolor blue)
464
%D (filldraw)
465
%D fullcircle xscaled 100 yscaled 40 shifted (50,50) withpen pencircle scaled 4;
466
%D \stoptyping
467
%D
468
%D The a (or angle) alternative supports arbitrary angles and
469
%D is therefore more versatile.
470
%D
471
%D \starttyping
472
%D stripe_path_a
473
%D (withpen pencircle scaled 2 withcolor red)
474
%D (draw)
475
%D fullcircle xscaled 100 yscaled 40 withcolor blue;
476
%D \stoptyping
477
%D
478
%D We have two alternatives, controlled by arguments or defaults (when arguments
479
%D are zero).
480
%D
481
%D The newer and nicer interface is used as follows (triggered by a question by Mari):
482
%D
483
%D \starttyping
484
%D draw image (draw fullcircle scaled 3cm shifted (0cm,0cm) withcolor green) numberstriped (1,10,3) withcolor red ;
485
%D draw image (draw fullcircle scaled 3cm shifted (3cm,0cm) withcolor green) numberstriped (2,20,3) withcolor green ;
486
%D draw image (draw fullcircle scaled 3cm shifted (3cm,3cm) withcolor green) numberstriped (3,10,5) withcolor blue ;
487
%D draw image (draw fullcircle scaled 3cm shifted (0cm,3cm) withcolor green) numberstriped (4,20,5) withcolor yellow ;
488
%D
489
%D draw image (draw fullcircle scaled 3cm shifted (6cm,0cm) withcolor green) anglestriped (1,20,2) withcolor red ;
490
%D draw image (draw fullcircle scaled 3cm shifted (9cm,0cm) withcolor green) anglestriped (2,40,2) withcolor green ;
491
%D draw image (draw fullcircle scaled 3cm shifted (9cm,3cm) withcolor green) anglestriped (3,60,2) withcolor blue ;
492
%D draw image (draw fullcircle scaled 3cm shifted (6cm,3cm) withcolor green) anglestriped (4,80,2) withcolor yellow ;
493
%D
494
%D draw image (
495
%D draw fullcircle scaled 3cm shifted (0cm,0cm) withcolor green withpen pencircle scaled 2mm ;
496
%D draw fullcircle scaled 2cm shifted (0cm,1cm) withcolor blue withpen pencircle scaled 3mm ;
497
%D ) shifted (9cm,0cm) numberstriped (1,10,3) withcolor red ;
498
%D
499
%D draw image (
500
%D draw fullcircle scaled 3cm shifted (0cm,0cm) withcolor green withpen pencircle scaled 2mm ;
501
%D draw fullcircle scaled 2cm shifted (0cm,1cm) withcolor blue withpen pencircle scaled 3mm ;
502
%D ) shifted (12cm,0cm) numberstriped (2,10,3) withcolor red ;
503
%D
504
%D draw image (
505
%D draw fullcircle scaled 3cm shifted (0cm,0cm) withcolor green withpen pencircle scaled 2mm ;
506
%D draw fullcircle scaled 2cm shifted (0cm,1cm) withcolor blue withpen pencircle scaled 3mm ;
507
%D ) shifted (9cm,5cm) numberstriped (3,10,3) withcolor red ;
508
%D
509
%D draw image (
510
%D draw fullcircle scaled 3cm shifted (0cm,0cm) withcolor green withpen pencircle scaled 2mm ;
511
%D draw fullcircle scaled 2cm shifted (0cm,1cm) withcolor blue withpen pencircle scaled 3mm ;
512
%D ) shifted (12cm,5cm) numberstriped (4,10,3) withcolor red ;
513
%D \stoptyping
514 515
stripe_n
:
=
10
;
516
stripe_slot
:
=
3
;
517
stripe_gap
:
=
5
;
518
stripe_angle
:
=
45
;
519 520
def
mfun_tool_striped_number_action
text
extra
=
521
for
i
=
1
/
used_n
step
1
/
used_n
until
1
:
522
draw
point
(
1
+
i
)
of
bounds
--
point
(
3
-
i
)
of
bounds
withpen
pencircle
scaled
penwidth
extra
;
523
endfor
;
524
for
i
=
0
step
1
/
used_n
until
1
:
525
draw
point
(
3
+
i
)
of
bounds
--
point
(
1
-
i
)
of
bounds
withpen
pencircle
scaled
penwidth
extra
;
526
endfor
;
527
enddef
;
528 529
def
mfun_tool_striped_set_options
(
expr
option
)
=
530
save
isinner
,
swapped
;
531
boolean
isinner
,
swapped
;
532
if
option
=
1
:
533
isinner
:
=
false
;
534
swapped
:
=
false
;
535
elseif
option
=
2
:
536
isinner
:
=
true
;
537
swapped
:
=
false
;
538
elseif
option
=
3
:
539
isinner
:
=
false
;
540
swapped
:
=
true
;
541
elseif
option
=
4
:
542
isinner
:
=
true
;
543
swapped
:
=
true
;
544
else
:
545
isinner
:
=
false
;
546
swapped
:
=
false
;
547
fi
;
548
enddef
;
549 550
vardef
mfun_tool_striped_number
(
expr
option
,
p
,
s_n
,
s_slot
)
text
extra
=
551
image
(
552
begingroup
;
553
save
pattern
,
shape
,
bounds
,
penwidth
,
used_n
,
used_slot
;
554
picture
pattern
,
shape
;
path
bounds
;
numeric
used_s
,
used_slot
;
555
mfun_tool_striped_set_options
(
option
)
;
556
used_slot
:
=
if
s_slot
=
0
:
stripe_slot
else
:
s_slot
fi
;
557
used_n
:
=
if
s_n
=
0
:
stripe_n
else
:
s_n
fi
;
558
shape
:
=
image
(
draw
p
)
;
559
bounds
:
=
boundingbox
shape
;
560
penwidth
:
=
min
(
ypart
urcorner
shape
-
ypart
llcorner
shape
,
xpart
urcorner
shape
-
xpart
llcorner
shape
)
/
(
used_slot
*
used_n
)
;
561
pattern
:
=
image
(
562
if
isinner
:
563
mfun_tool_striped_number_action
extra
;
564
for
s
within
shape
:
565
if
stroked
s
or
filled
s
:
566
clip
currentpicture
to
pathpart
s
;
567
fi
568
endfor
;
569
else
:
570
for
s
within
shape
:
571
if
stroked
s
or
filled
s
:
572
draw
image
(
573
mfun_tool_striped_number_action
extra
;
574
clip
currentpicture
to
pathpart
s
;
575
)
;
576
fi
;
577
endfor
;
578
fi
;
579
)
;
580
if
swapped
:
581
addto
currentpicture
also
shape
;
582
addto
currentpicture
also
pattern
;
583
else
:
584
addto
currentpicture
also
pattern
;
585
addto
currentpicture
also
shape
;
586
fi
;
587
endgroup
;
588
)
589
enddef
;
590 591
def
mfun_tool_striped_angle_action
text
extra
=
592
for
i
=
minimum
-.5
used_gap
step
used_gap
until
maximum
:
593
draw
(
minimum
,
i
)
--
(
maximum
,
i
)
extra
;
594
endfor
;
595
currentpicture
:
=
currentpicture
rotated
used_angle
;
596
enddef
;
597 598
vardef
mfun_tool_striped_angle
(
expr
option
,
p
,
s_angle
,
s_gap
)
text
extra
=
599
image
(
600
begingroup
;
601
save
pattern
,
shape
,
mask
,
maximum
,
minimum
,
centrum
,
used_angle
,
used_gap
;
602
picture
pattern
,
shape
,
mask
;
numeric
maximum
,
minimum
;
pair
centrum
;
numeric
used_angle
,
used_gap
;
603
mfun_tool_striped_set_options
(
option
)
;
604
used_angle
:
=
if
s_angle
=
0
:
stripe_angle
else
:
s_angle
fi
;
605
used_gap
:
=
if
s_gap
=
0
:
stripe_gap
else
:
s_gap
fi
;
606
shape
:
=
image
(
draw
p
)
;
607
centrum
:
=
center
shape
;
608
shape
:
=
shape
shifted
-
centrum
;
609
mask
:
=
shape
rotated
used_angle
;
610
maximum
:
=
max
(
xpart
llcorner
mask
,
xpart
urcorner
mask
,
ypart
llcorner
mask
,
ypart
urcorner
mask
)
;
611
minimum
:
=
min
(
xpart
llcorner
mask
,
xpart
urcorner
mask
,
ypart
llcorner
mask
,
ypart
urcorner
mask
)
;
612
pattern
:
=
image
(
613
if
isinner
:
614
mfun_tool_striped_angle_action
extra
;
615
for
s
within
shape
:
616
if
stroked
s
or
filled
s
:
617
clip
currentpicture
to
pathpart
s
;
618
fi
619
endfor
;
620
else
:
621
for
s
within
shape
:
622
if
stroked
s
or
filled
s
:
623
draw
image
(
624
mfun_tool_striped_angle_action
extra
;
625
clip
currentpicture
to
pathpart
s
;
626
)
;
627
fi
;
628
endfor
;
629
fi
;
630
)
;
631
if
swapped
:
632
addto
currentpicture
also
shape
;
633
addto
currentpicture
also
pattern
;
634
else
:
635
addto
currentpicture
also
pattern
;
636
addto
currentpicture
also
shape
;
637
fi
;
638
currentpicture
:
=
currentpicture
shifted
centrum
;
639
endgroup
;
640
)
641
enddef
;
642 643
newinternal
striped_normal_inner
;
striped_normal_inner
:
=
1
;
644
newinternal
striped_reverse_inner
;
striped_reverse_inner
:
=
2
;
645
newinternal
striped_normal_outer
;
striped_normal_outer
:
=
3
;
646
newinternal
striped_reverse_outer
;
striped_reverse_outer
:
=
4
;
647 648
secondarydef
p
anglestriped
s
=
649
mfun_tool_striped_angle
(
redpart
s
,
p
,
greenpart
s
,
bluepart
s
)
650
enddef
;
651 652
secondarydef
p
numberstriped
s
=
653
mfun_tool_striped_number
(
redpart
s
,
p
,
greenpart
s
,
bluepart
s
)
654
enddef
;
655 656
% for old times sake:
657 658
def
stripe_path_n
(
text
s_spec
)
(
text
s_draw
)
expr
s_path
=
659
do_stripe_path_n
(
s_spec
)
(
s_draw
)
(
s_path
)
660
enddef
;
661 662
def
do_stripe_path_n
(
text
s_spec
)
(
text
s_draw
)
(
expr
s_path
)
text
s_text
=
663
draw
image
(
s_draw
s_path
s_text
)
numberstriped
(
3
,
0
,
0
)
s_spec
;
664
enddef
;
665 666
def
stripe_path_a
(
text
s_spec
)
(
text
s_draw
)
expr
s_path
=
667
do_stripe_path_a
(
s_spec
)
(
s_draw
)
(
s_path
)
668
enddef
;
669 670
def
do_stripe_path_a
(
text
s_spec
)
(
text
s_draw
)
(
expr
s_path
)
text
s_text
=
671
draw
image
(
s_draw
s_path
s_text
)
anglestriped
(
3
,
0
,
0
)
s_spec
;
672
enddef
;
673 674
%D A few normalizing macros:
675 676
primarydef
p
xsized
w
=
677
(
p
if
(
bbwidth
(
p
)
>
0
)
and
(
w
>
0
)
:
scaled
(
w
/
bbwidth
(
p
)
)
fi
)
678
enddef
;
679 680
primarydef
p
ysized
h
=
681
(
p
if
(
bbheight
(
p
)
>
0
)
and
(
h
>
0
)
:
scaled
(
h
/
bbheight
(
p
)
)
fi
)
682
enddef
;
683 684
primarydef
p
xysized
s
=
685
begingroup
686
save
wh
,
w
,
h
;
pair
wh
;
numeric
w
,
h
;
687
wh
:
=
paired
(
s
)
;
w
:
=
bbwidth
(
p
)
;
h
:
=
bbheight
(
p
)
;
688
p
689
if
(
w
>
0
)
and
(
h
>
0
)
:
690
if
xpart
wh
>
0
:
xscaled
(
xpart
wh
/
w
)
fi
691
if
ypart
wh
>
0
:
yscaled
(
ypart
wh
/
h
)
fi
692
fi
693
endgroup
694
enddef
;
695 696
let
sized
=
xysized
;
697 698
def
xscale_currentpicture
(
expr
w
)
=
% obsolete
699
currentpicture
:
=
currentpicture
xsized
w
;
700
enddef
;
701 702
def
yscale_currentpicture
(
expr
h
)
=
% obsolete
703
currentpicture
:
=
currentpicture
ysized
h
;
704
enddef
;
705 706
def
xyscale_currentpicture
(
expr
w
,
h
)
=
% obsolete
707
currentpicture
:
=
currentpicture
xysized
(
w
,
h
)
;
708
enddef
;
709 710
def
scale_currentpicture
(
expr
w
,
h
)
=
% obsolete
711
currentpicture
:
=
currentpicture
xsized
w
;
712
currentpicture
:
=
currentpicture
ysized
h
;
713
enddef
;
714 715
%D A full circle is centered at the origin, while a unitsquare
716
%D is located in the first quadrant. Now guess what kind of
717
%D path fullsquare and unitcircle do return.
718 719
path
fullsquare
,
unitcircle
;
720 721
fullsquare
:
=
unitsquare
shifted
-
center
unitsquare
;
722
unitcircle
:
=
fullcircle
shifted
urcorner
fullcircle
;
723 724
%D Some more paths:
725 726
path
urcircle
,
ulcircle
,
llcircle
,
lrcircle
;
727 728
urcircle
:
=
origin
--
(
+.5
,
0
)
&
(
+.5
,
0
)
{
up
}
..
(
0
,
+.5
)
&
(
0
,
+.5
)
--
cycle
;
729
ulcircle
:
=
origin
--
(
0
,
+.5
)
&
(
0
,
+.5
)
{
left
}
..
(
-.5
,
0
)
&
(
-.5
,
0
)
--
cycle
;
730
llcircle
:
=
origin
--
(
-.5
,
0
)
&
(
-.5
,
0
)
{
down
}
..
(
0
,
-.5
)
&
(
0
,
-.5
)
--
cycle
;
731
lrcircle
:
=
origin
--
(
0
,
-.5
)
&
(
0
,
-.5
)
{
right
}
..
(
+.5
,
0
)
&
(
+.5
,
0
)
--
cycle
;
732 733
path
tcircle
,
bcircle
,
lcircle
,
rcircle
;
734 735
tcircle
=
origin
--
(
+.5
,
0
)
&
(
+.5
,
0
)
{
up
}
..
(
0
,
+.5
)
..
{
down
}
(
-.5
,
0
)
--
cycle
;
736
bcircle
=
origin
--
(
-.5
,
0
)
&
(
-.5
,
0
)
{
down
}
..
(
0
,
-.5
)
..
{
up
}
(
+.5
,
0
)
--
cycle
;
737
lcircle
=
origin
--
(
0
,
+.5
)
&
(
0
,
+.5
)
{
left
}
..
(
-.5
,
0
)
..
{
right
}
(
0
,
-.5
)
--
cycle
;
738
rcircle
=
origin
--
(
0
,
-.5
)
&
(
0
,
-.5
)
{
right
}
..
(
+.5
,
0
)
..
{
left
}
(
0
,
+.5
)
--
cycle
;
739 740
path
urtriangle
,
ultriangle
,
lltriangle
,
lrtriangle
;
% watch out: it's contrary to what you expect and starts in the origin
741 742
urtriangle
:
=
origin
--
(
+.5
,
0
)
--
(
0
,
+.5
)
--
cycle
;
743
ultriangle
:
=
origin
--
(
0
,
+.5
)
--
(
-.5
,
0
)
--
cycle
;
744
lltriangle
:
=
origin
--
(
-.5
,
0
)
--
(
0
,
-.5
)
--
cycle
;
745
lrtriangle
:
=
origin
--
(
0
,
-.5
)
--
(
+.5
,
0
)
--
cycle
;
746 747
path
triangle
,
uptriangle
,
downtriangle
,
lefttriangle
,
righttriangle
;
748 749
triangle
:
=
(
1
,
0
)
--
(
1
,
0
)
rotated
120
--
(
1
,
0
)
rotated
-120
--
cycle
;
750 751
uptriangle
:
=
triangle
rotated
90
;
752
downtriangle
:
=
triangle
rotated
-90
;
753
lefttriangle
:
=
triangle
rotated
180
;
754
righttriangle
:
=
triangle
;
755 756
path
unitdiamond
,
fulldiamond
;
757 758
unitdiamond
:
=
(
.5
,
0
)
--
(
1
,
.5
)
--
(
.5
,
1
)
--
(
0
,
.5
)
--
cycle
;
759
fulldiamond
:
=
unitdiamond
shifted
-
center
unitdiamond
;
760 761
%D More robust:
762 763
% let normalscaled = scaled ;
764
% let normalxscaled = xscaled ;
765
% let normalyscaled = yscaled ;
766
%
767
% def scaled expr s = normalscaled (s) enddef ;
768
% def xscaled expr s = normalxscaled (s) enddef ;
769
% def yscaled expr s = normalyscaled (s) enddef ;
770 771
%D Shorter
772 773
primarydef
p
xyscaled
q
=
% secundarydef does not work out well
774
begingroup
775
save
qq
;
pair
qq
;
776
qq
=
paired
(
q
)
;
777
p
778
if
xpart
qq
<
>
0
:
xscaled
(
xpart
qq
)
fi
779
if
ypart
qq
<
>
0
:
yscaled
(
ypart
qq
)
fi
780
endgroup
781
enddef
;
782 783
%D Some personal code that might move to another module (todo: save).
784 785
def
set_grid
(
expr
w
,
h
,
nx
,
ny
)
=
786
boolean
grid
[
]
[
]
;
boolean
grid_full
;
787
numeric
grid_w
,
grid_h
,
grid_nx
,
grid_ny
,
grid_x
,
grid_y
,
grid_left
;
788
grid_w
:
=
w
;
789
grid_h
:
=
h
;
790
grid_nx
:
=
nx
;
791
grid_ny
:
=
ny
;
792
grid_x
:
=
round
(
w
/
grid_nx
)
;
% +.5) ;
793
grid_y
:
=
round
(
h
/
grid_ny
)
;
% +.5) ;
794
grid_left
:
=
(
1
+
grid_x
)
*
(
1
+
grid_y
)
;
795
grid_full
:
=
false
;
796
for
i
=
0
upto
grid_x
:
797
for
j
=
0
upto
grid_y
:
798
grid
[
i
]
[
j
]
:
=
false
;
799
endfor
;
800
endfor
;
801
enddef
;
802 803
vardef
new_on_grid
(
expr
_dx_
,
_dy_
)
=
804
dx
:
=
_dx_
;
805
dy
:
=
_dy_
;
806
ddx
:
=
min
(
round
(
dx
/
grid_nx
)
,
grid_x
)
;
% +.5),grid_x) ;
807
ddy
:
=
min
(
round
(
dy
/
grid_ny
)
,
grid_y
)
;
% +.5),grid_y) ;
808
if
not
grid_full
and
not
grid
[
ddx
]
[
ddy
]
:
809
grid
[
ddx
]
[
ddy
]
:
=
true
;
810
grid_left
:
=
grid_left
-1
;
811
grid_full
:
=
(
grid_left
=
0
)
;
812
true
813
else
:
814
false
815
fi
816
enddef
;
817 818
%D usage: \type{innerpath peepholed outerpath}.
819
%D
820
%D beginfig(1);
821
%D def fullsquare = (unitsquare shifted -center unitsquare) enddef ;
822
%D fill (fullsquare scaled 200) withcolor red ;
823
%D path p ; p := (fullcircle scaled 100) ; bboxmargin := 0 ;
824
%D fill p peepholed bbox p ;
825
%D endfig;
826 827
secondarydef
p
peepholed
q
=
828
begingroup
829
save
start
;
pair
start
;
830
start
:
=
point
0
of
p
;
831
if
xpart
start
>
=
xpart
center
p
:
832
if
ypart
start
>
=
ypart
center
p
:
833
urcorner
q
--
ulcorner
q
--
llcorner
q
--
lrcorner
q
--
834
reverse
p
--
lrcorner
q
--
cycle
835
else
:
836
lrcorner
q
--
urcorner
q
--
ulcorner
q
--
llcorner
q
--
837
reverse
p
--
llcorner
q
--
cycle
838
fi
839
else
:
840
if
ypart
start
>
ypart
center
p
:
841
ulcorner
q
--
llcorner
q
--
lrcorner
q
--
urcorner
q
--
842
reverse
p
--
urcorner
q
--
cycle
843
else
:
844
llcorner
q
--
lrcorner
q
--
urcorner
q
--
ulcorner
q
--
845
reverse
p
--
ulcorner
q
--
cycle
846
fi
847
fi
848
endgroup
849
enddef
;
850 851
boolean
intersection_found
;
852 853
secondarydef
p
intersection_point
q
=
854
begingroup
855
save
x_
,
y_
;
856
(
x_
,
y_
)
=
p
intersectiontimes
q
;
857
if
x_
<
0
:
858
intersection_found
:
=
false
;
859
center
p
% origin
860
else
:
861
intersection_found
:
=
true
;
862
.5
[
point
x_
of
p
,
point
y_
of
q
]
863
fi
864
endgroup
865
enddef
;
866 867
%D New, undocumented, experimental:
868 869
vardef
tensecircle
(
expr
width
,
height
,
offset
)
=
870
(
-
width
/
2
,
-
height
/
2
)
...
(
0
,
-
height
/
2
-
offset
)
...
871
(
+
width
/
2
,
-
height
/
2
)
...
(
+
width
/
2
+
offset
,
0
)
...
872
(
+
width
/
2
,
+
height
/
2
)
...
(
0
,
+
height
/
2
+
offset
)
...
873
(
-
width
/
2
,
+
height
/
2
)
...
(
-
width
/
2
-
offset
,
0
)
...
cycle
874
enddef
;
875 876
vardef
roundedsquare
(
expr
width
,
height
,
offset
)
=
877
(
offset
,
0
)
--
(
width
-
offset
,
0
)
{
right
}
..
878
(
width
,
offset
)
--
(
width
,
height
-
offset
)
{
up
}
..
879
(
width
-
offset
,
height
)
--
(
offset
,
height
)
{
left
}
..
880
(
0
,
height
-
offset
)
--
(
0
,
offset
)
{
down
}
..
cycle
881
enddef
;
882 883
vardef
roundedsquarexy
(
expr
width
,
height
,
dx
,
dy
)
=
884
(
dx
,
0
)
--
(
width
-
dx
,
0
)
{
right
}
..
885
(
width
,
dy
)
--
(
width
,
height
-
dy
)
{
up
}
..
886
(
width
-
dx
,
height
)
--
(
dx
,
height
)
{
left
}
..
887
(
0
,
height
-
dy
)
--
(
0
,
dy
)
{
down
}
..
cycle
888
enddef
;
889 890
%D Some colors.
891 892
def
resolvedcolor
(
expr
s
)
=
893
.5
white
894
enddef
;
895 896
let
normalwithcolor
=
withcolor
;
897 898
def
withcolor
expr
c
=
899
normalwithcolor
if
string
c
:
resolvedcolor
(
c
)
else
:
c
fi
900
enddef
;
901 902
% I don't want a "withcolor black" in case of an empty string ... who knows
903
% how that can interfere with outer colors. Somehow the next one doesn't
904
% always work out ok, but why ... must be some parsing issue. Anyway, when
905
% we cannot do that, we need to fix some chem macros instead as empty strings
906
% now lead to black while everywhere else in context empty means: leave color
907
% untouched.
908 909
% def withcolor expr c =
910
% if not string c :
911
% normalwithcolor c
912
% elseif c <> "" :
913
% normalwithcolor resolvedcolor(c)
914
% fi
915
% enddef ;
916 917
% So why does this work better than the above:
918
%
919
% def withcolor expr c =
920
% if string c :
921
% if c <> "" :
922
% normalwithcolor resolvedcolor(c)
923
% fi
924
% else :
925
% normalwithcolor c
926
% fi
927
% enddef ;
928 929
vardef
colortype
expr
c
=
930
if
cmykcolor
c
:
cmykcolor
931
elseif
rgbcolor
c
:
rgbcolor
932
elseif
numeric
c
:
grayscale
933
fi
934
enddef
;
935 936
vardef
whitecolor
expr
c
=
937
if
cmykcolor
c
:
(
0
,
0
,
0
,
0
)
938
elseif
rgbcolor
c
:
(
1
,
1
,
1
)
939
elseif
numeric
c
:
1
940
elseif
string
c
:
whitecolor
resolvedcolor
(
c
)
941
fi
942
enddef
;
943 944
vardef
blackcolor
expr
c
=
945
if
cmykcolor
c
:
(
0
,
0
,
0
,
1
)
946
elseif
rgbcolor
c
:
(
0
,
0
,
0
)
947
elseif
numeric
c
:
0
948
elseif
string
c
:
blackcolor
resolvedcolor
(
c
)
949
fi
950
enddef
;
951 952
vardef
complementary
expr
c
=
953
if
cmykcolor
c
:
(
1
,
1
,
1
,
1
)
-
c
954
elseif
rgbcolor
c
:
(
1
,
1
,
1
)
-
c
955
elseif
pair
c
:
(
1
,
1
)
-
c
956
elseif
numeric
c
:
1
-
c
957
elseif
string
c
:
complementary
resolvedcolor
(
c
)
958
fi
959
enddef
;
960 961
vardef
complemented
expr
c
=
962
save
m
;
963
if
cmykcolor
c
:
m
:
=
max
(
cyanpart
c
,
magentapart
c
,
yellowpart
c
,
blackpart
c
)
;
964
(
m
,
m
,
m
,
m
)
-
c
965
elseif
rgbcolor
c
:
m
:
=
max
(
redpart
c
,
greenpart
c
,
bluepart
c
)
;
966
(
m
,
m
,
m
)
-
c
967
elseif
pair
c
:
m
:
=
max
(
xpart
c
,
ypart
c
)
;
968
(
m
,
m
)
-
c
969
elseif
numeric
c
:
m
-
c
970
elseif
string
c
:
complemented
resolvedcolor
(
c
)
971
fi
972
enddef
;
973 974
%D Well, this is the dangerous and naive version:
975 976
def
drawfill
text
t
=
977
fill
t
;
978
draw
t
;
979
enddef
;
980 981
%D This two step approach saves the path first, since it can
982
%D be a function. Attributes must not be randomized.
983 984
def
drawfill
expr
c
=
985
path
_c_
;
_c_
:
=
c
;
986
mfun_do_drawfill
987
enddef
;
988 989
def
mfun_do_drawfill
text
t
=
990
draw
_c_
t
;
991
fill
_c_
t
;
992
enddef
;
993 994
def
undrawfill
expr
c
=
995
drawfill
c
withcolor
background
% rather useless
996
enddef
;
997 998
%D Moved from mp-char.mp
999 1000
vardef
paired
primary
d
=
1001
if
pair
d
:
d
else
:
(
d
,
d
)
fi
1002
enddef
;
1003 1004
vardef
tripled
primary
d
=
1005
if
color
d
:
d
else
:
(
d
,
d
,
d
)
fi
1006
enddef
;
1007 1008
% maybe secondaries:
1009 1010
primarydef
p
enlarged
d
=
(
p
llmoved
d
--
p
lrmoved
d
--
p
urmoved
d
--
p
ulmoved
d
--
cycle
)
enddef
;
1011
primarydef
p
llenlarged
d
=
(
p
llmoved
d
--
lrcorner
p
--
urcorner
p
--
ulcorner
p
--
cycle
)
enddef
;
1012
primarydef
p
lrenlarged
d
=
(
llcorner
p
--
p
lrmoved
d
--
urcorner
p
--
ulcorner
p
--
cycle
)
enddef
;
1013
primarydef
p
urenlarged
d
=
(
llcorner
p
--
lrcorner
p
--
p
urmoved
d
--
ulcorner
p
--
cycle
)
enddef
;
1014
primarydef
p
ulenlarged
d
=
(
llcorner
p
--
lrcorner
p
--
urcorner
p
--
p
ulmoved
d
--
cycle
)
enddef
;
1015 1016
primarydef
p
llmoved
d
=
(
(
llcorner
p
)
shifted
(
-
xpart
paired
(
d
)
,
-
ypart
paired
(
d
)
)
)
enddef
;
1017
primarydef
p
lrmoved
d
=
(
(
lrcorner
p
)
shifted
(
+
xpart
paired
(
d
)
,
-
ypart
paired
(
d
)
)
)
enddef
;
1018
primarydef
p
urmoved
d
=
(
(
urcorner
p
)
shifted
(
+
xpart
paired
(
d
)
,
+
ypart
paired
(
d
)
)
)
enddef
;
1019
primarydef
p
ulmoved
d
=
(
(
ulcorner
p
)
shifted
(
-
xpart
paired
(
d
)
,
+
ypart
paired
(
d
)
)
)
enddef
;
1020 1021
primarydef
p
leftenlarged
d
=
(
(
llcorner
p
)
shifted
(
-
d
,
0
)
--
lrcorner
p
--
urcorner
p
--
(
ulcorner
p
)
shifted
(
-
d
,
0
)
--
cycle
)
enddef
;
1022
primarydef
p
rightenlarged
d
=
(
llcorner
p
--
(
lrcorner
p
)
shifted
(
d
,
0
)
--
(
urcorner
p
)
shifted
(
d
,
0
)
--
ulcorner
p
--
cycle
)
enddef
;
1023
primarydef
p
topenlarged
d
=
(
llcorner
p
--
lrcorner
p
--
(
urcorner
p
)
shifted
(
0
,
d
)
--
(
ulcorner
p
)
shifted
(
0
,
d
)
--
cycle
)
enddef
;
1024
primarydef
p
bottomenlarged
d
=
(
llcorner
p
shifted
(
0
,
-
d
)
--
lrcorner
p
shifted
(
0
,
-
d
)
--
urcorner
p
--
ulcorner
p
--
cycle
)
enddef
;
1025 1026
%D Handy as stepper:
1027 1028
vardef
rotation
(
expr
i
,
n
)
=
1029
if
(
n
=
=
0
)
:
0
else
:
i
*
360
/
n
fi
1030
enddef
;
1031 1032
%D Handy for testing/debugging:
1033 1034
primarydef
p
crossed
d
=
(
1035
if
pair
p
:
1036
p
shifted
(
-
d
,
0
)
--
p
--
1037
p
shifted
(
0
,
-
d
)
--
p
--
1038
p
shifted
(
+
d
,
0
)
--
p
--
1039
p
shifted
(
0
,
+
d
)
--
p
--
cycle
1040
else
:
1041
center
p
shifted
(
-
d
,
0
)
--
llcorner
p
--
1042
center
p
shifted
(
0
,
-
d
)
--
lrcorner
p
--
1043
center
p
shifted
(
+
d
,
0
)
--
urcorner
p
--
1044
center
p
shifted
(
0
,
+
d
)
--
ulcorner
p
--
cycle
1045
fi
1046
)
enddef
;
1047 1048
%D Also handy (math ladders):
1049 1050
vardef
laddered
primary
p
=
% was expr
1051
point
0
of
p
1052
for
i
=
1
upto
length
(
p
)
:
1053
--
(
xpart
(
point
i
of
p
)
,
ypart
(
point
(
i
-1
)
of
p
)
)
--
(
point
i
of
p
)
1054
endfor
1055
enddef
;
1056 1057
%D Saves typing:
1058 1059
% vardef bottomboundary primary p = (llcorner p -- lrcorner p) enddef ;
1060
% vardef rightboundary primary p = (lrcorner p -- urcorner p) enddef ;
1061
% vardef topboundary primary p = (urcorner p -- ulcorner p) enddef ;
1062
% vardef leftboundary primary p = (ulcorner p -- llcorner p) enddef ;
1063 1064
vardef
bottomboundary
primary
p
=
if
pair
p
:
p
else
:
(
llcorner
p
--
lrcorner
p
)
fi
enddef
;
1065
vardef
rightboundary
primary
p
=
if
pair
p
:
p
else
:
(
lrcorner
p
--
urcorner
p
)
fi
enddef
;
1066
vardef
topboundary
primary
p
=
if
pair
p
:
p
else
:
(
urcorner
p
--
ulcorner
p
)
fi
enddef
;
1067
vardef
leftboundary
primary
p
=
if
pair
p
:
p
else
:
(
ulcorner
p
--
llcorner
p
)
fi
enddef
;
1068 1069
%D Nice too:
1070 1071
primarydef
p
superellipsed
s
=
1072
superellipse
(
1073
.5
[
lrcorner
p
,
urcorner
p
]
,
1074
.5
[
urcorner
p
,
ulcorner
p
]
,
1075
.5
[
ulcorner
p
,
llcorner
p
]
,
1076
.5
[
llcorner
p
,
lrcorner
p
]
,
1077
s
1078
)
1079
enddef
;
1080 1081
primarydef
p
squeezed
s
=
(
1082
(
llcorner
p
..
.5
[
llcorner
p
,
lrcorner
p
]
shifted
(
0
,
ypart
paired
(
s
)
)
..
lrcorner
p
)
&
1083
(
lrcorner
p
..
.5
[
lrcorner
p
,
urcorner
p
]
shifted
(
-
xpart
paired
(
s
)
,
0
)
..
urcorner
p
)
&
1084
(
urcorner
p
..
.5
[
urcorner
p
,
ulcorner
p
]
shifted
(
0
,
-
ypart
paired
(
s
)
)
..
ulcorner
p
)
&
1085
(
ulcorner
p
..
.5
[
ulcorner
p
,
llcorner
p
]
shifted
(
xpart
paired
(
s
)
,
0
)
..
llcorner
p
)
&
cycle
1086
)
enddef
;
1087 1088
primarydef
p
randomshifted
s
=
1089
begingroup
;
1090
save
ss
;
pair
ss
;
1091
ss
:
=
paired
(
s
)
;
1092
p
shifted
(
-.5
xpart
ss
+
uniformdeviate
xpart
ss
,
-.5
ypart
ss
+
uniformdeviate
ypart
ss
)
1093
endgroup
1094
enddef
;
1095 1096
vardef
mfun_randomized_path
(
expr
p
,
s
)
=
1097
for
i
=
0
upto
length
(
p
)
-1
:
1098
(
point
i
of
p
)
..
controls
1099
(
(
postcontrol
i
of
p
)
randomshifted
s
)
and
1100
(
(
precontrol
(
i
+1
)
of
p
)
randomshifted
s
)
..
1101
endfor
1102
if
cycle
p
:
1103
cycle
1104
else
:
1105
(
point
length
(
p
)
of
p
)
1106
fi
1107
enddef
;
1108 1109
vardef
mfun_randomized_picture
(
expr
p
,
s
)
(
text
rnd
)
=
1110
save
currentpicture
;
1111
picture
currentpicture
;
1112
currentpicture
:
=
nullpicture
;
1113
for
i
within
p
:
1114
addto
currentpicture
1115
if
stroked
i
:
1116
doublepath
pathpart
i
rnd
s
1117
dashed
dashpart
i
1118
withpen
penpart
i
1119
withcolor
colorpart
i
1120
withprescript
prescriptpart
i
1121
withpostscript
postscriptpart
i
1122
elseif
filled
i
:
1123
contour
pathpart
i
rnd
s
1124
withpen
penpart
i
1125
withcolor
colorpart
i
1126
withprescript
prescriptpart
i
1127
withpostscript
postscriptpart
i
1128
else
:
1129
also
i
1130
fi
1131
;
1132
endfor
;
1133
currentpicture
1134
enddef
;
1135 1136
primarydef
p
randomizedcontrols
s
=
(
1137
if
path
p
:
1138
mfun_randomized_path
(
p
,
s
)
1139
elseif
picture
p
:
1140
mfun_randomized_picture
(
p
,
s
)
(
randomizedcontrols
)
1141
else
:
1142
p
randomized
s
1143
fi
1144
)
enddef
;
1145 1146
primarydef
p
randomized
s
=
(
1147
if
path
p
:
1148
for
i
=
0
upto
length
(
p
)
-1
:
1149
(
(
point
i
of
p
)
randomshifted
s
)
..
controls
1150
(
(
postcontrol
i
of
p
)
randomshifted
s
)
and
1151
(
(
precontrol
(
i
+1
)
of
p
)
randomshifted
s
)
..
1152
endfor
1153
if
cycle
p
:
1154
cycle
1155
else
:
1156
(
(
point
length
(
p
)
of
p
)
randomshifted
s
)
1157
fi
1158
elseif
pair
p
:
1159
p
randomshifted
s
1160
elseif
cmykcolor
p
:
1161
if
cmykcolor
s
:
1162
(
(
uniformdeviate
cyanpart
s
)
*
cyanpart
p
,
1163
(
uniformdeviate
magentapart
s
)
*
magentapart
p
,
1164
(
uniformdeviate
yellowpart
s
)
*
yellowpart
p
,
1165
(
uniformdeviate
blackpart
s
)
*
blackpart
p
)
1166
elseif
pair
s
:
1167
(
(
xpart
s
+
(
uniformdeviate
(
ypart
s
-
xpart
s
)
)
)
*
p
)
1168
else
:
1169
(
(
uniformdeviate
s
)
*
p
)
1170
fi
1171
elseif
rgbcolor
p
:
1172
if
rgbcolor
s
:
1173
(
(
uniformdeviate
redpart
s
)
*
redpart
p
,
1174
(
uniformdeviate
greenpart
s
)
*
greenpart
p
,
1175
(
uniformdeviate
bluepart
s
)
*
bluepart
p
)
1176
elseif
pair
s
:
1177
(
(
xpart
s
+
(
uniformdeviate
(
ypart
s
-
xpart
s
)
)
)
*
p
)
1178
else
:
1179
(
(
uniformdeviate
s
)
*
p
)
1180
fi
1181
elseif
color
p
:
1182
if
color
s
:
1183
(
(
uniformdeviate
greypart
s
)
*
greypart
p
)
1184
elseif
pair
s
:
1185
(
(
xpart
s
+
(
uniformdeviate
(
ypart
s
-
xpart
s
)
)
)
*
p
)
1186
else
:
1187
(
(
uniformdeviate
s
)
*
p
)
1188
fi
1189
elseif
string
p
:
1190
(
resolvedcolor
(
p
)
)
randomized
s
1191
elseif
picture
p
:
1192
mfun_randomized_picture
(
p
,
s
)
(
randomized
)
1193
else
:
1194
% p - s/2 + uniformdeviate s % would have been better but we want to be positive
1195
p
+
uniformdeviate
s
1196
fi
1197
)
enddef
;
1198 1199
%D Not perfect (alternative for interpath)
1200 1201
vardef
interpolated
(
expr
s
,
p
,
q
)
=
1202
save
m
;
numeric
m
;
1203
m
:
=
max
(
length
(
p
)
,
length
(
q
)
)
;
1204
if
path
p
:
1205
for
i
=
0
upto
m
-1
:
1206
s
[
point
(
i
/
m
)
along
p
,
point
(
i
/
m
)
along
q
]
..
controls
1207
s
[
postcontrol
(
i
/
m
)
along
p
,
postcontrol
(
i
/
m
)
along
q
]
and
1208
s
[
precontrol
(
(
i
+1
)
/
m
)
along
p
,
precontrol
(
(
i
+1
)
/
m
)
along
q
]
..
1209
endfor
1210
if
cycle
p
:
1211
cycle
1212
else
:
1213
s
[
point
infinity
of
p
,
point
infinity
of
q
]
1214
fi
1215
else
:
1216
a
[
p
,
q
]
1217
fi
1218
enddef
;
1219 1220
%D Interesting too:
1221 1222
% primarydef p paralleled d = (
1223
% p shifted if d < 0 : - fi ((point abs(d) on (p rotatedaround(point 0 of p,90))) - point 0 of p)
1224
% ) enddef ;
1225
%
1226
% primarydef p paralleled d = (
1227
% p shifted ((d*unitvector(direction 0 of p) - point 0 of p) rotated 90)
1228
% ) enddef ;
1229
%
1230
% Alan came up with an improved version and stepwise we ended up with (or
1231
% might up with a variant of):
1232 1233
vardef
perpendicular
expr
t
of
p
=
1234
unitvector
(
(
direction
t
of
p
)
rotated
90
)
1235
enddef
;
1236 1237
def
istextext
(
expr
p
)
=
1238
(
picture
p
and
(
(
substring
(
0
,
3
)
of
prescriptpart
p
)
=
"
tx_
"
)
)
1239
enddef
;
1240 1241
primarydef
p
paralleled
d
=
(
1242
if
path
p
:
1243
begingroup
;
1244
save
dp
;
pair
dp
;
1245
for
i
=
0
upto
length
p
if
cycle
p
:
-1
fi
:
1246
hide
(
dp
:
=
d
*
perpendicular
i
of
p
)
1247
if
i
>
0
:
..
fi
1248
(
point
i
of
p
+
dp
)
1249
if
i
<
length
p
:
1250
..
controls
(
postcontrol
i
of
p
+
dp
)
and
1251
(
precontrol
(
i
+1
)
of
p
+
dp
)
1252
fi
1253
endfor
1254
if
cycle
p
:
..
cycle
fi
1255
endgroup
1256
elseif
picture
p
:
1257
image
(
1258
for
i
within
p
:
1259
draw
(
pathpart
i
)
1260
if
not
istextext
(
i
)
:
% dirty trick
1261
paralleled
d
1262
fi
1263
mfun_decoration_i
i
;
1264
endfor
;
1265
)
1266
elseif
pair
p
:
1267
p
1268
fi
1269
)
enddef
;
1270 1271
vardef
punked
primary
p
=
1272
point
0
of
p
for
i
=
1
upto
length
(
p
)
-1
:
--
point
i
of
p
endfor
1273
if
cycle
p
:
--
cycle
else
:
--
point
length
(
p
)
of
p
fi
1274
enddef
;
1275 1276
vardef
curved
primary
p
=
1277
point
0
of
p
for
i
=
1
upto
length
(
p
)
-1
:
..
point
i
of
p
endfor
1278
if
cycle
p
:
..
cycle
else
:
..
point
length
(
p
)
of
p
fi
1279
enddef
;
1280 1281
primarydef
p
blownup
s
=
1282
begingroup
1283
save
_p_
;
path
_p_
;
1284
_p_
:
=
p
xysized
(
bbwidth
(
p
)
+2
(
xpart
paired
(
s
)
)
,
bbheight
(
p
)
+2
(
ypart
paired
(
s
)
)
)
;
1285
(
_p_
shifted
(
center
p
-
center
_p_
)
)
1286
endgroup
1287
enddef
;
1288 1289
%D Rather fundamental.
1290 1291
% not yet ok
1292 1293
vardef
leftrightpath
(
expr
p
,
l
)
=
% used in s-pre-19
1294
save
q
,
r
,
t
,
b
;
path
q
,
r
;
pair
t
,
b
;
1295
t
:
=
(
ulcorner
p
--
urcorner
p
)
intersection_point
p
;
1296
b
:
=
(
llcorner
p
--
lrcorner
p
)
intersection_point
p
;
1297
r
:
=
if
xpart
directionpoint
t
of
p
<
0
:
reverse
p
else
:
p
fi
;
% r is needed, else problems when reverse is fed
1298
q
:
=
r
cutbefore
if
l
:
t
else
:
b
fi
;
1299
q
:
=
q
if
xpart
point
0
of
r
>
0
:
&
r
fi
cutafter
if
l
:
b
else
:
t
fi
;
1300
q
1301
enddef
;
1302 1303
vardef
leftpath
expr
p
=
leftrightpath
(
p
,
true
)
enddef
;
1304
vardef
rightpath
expr
p
=
leftrightpath
(
p
,
false
)
enddef
;
1305 1306
%D Drawoptions
1307 1308
def
saveoptions
=
1309
save
_op_
;
def
_op_
=
enddef
;
1310
enddef
;
1311 1312
%D Tracing. (not yet in lexer)
1313 1314
let
normaldraw
=
draw
;
1315
let
normalfill
=
fill
;
1316 1317
% bugged in mplib so ...
1318 1319
def
normalfill
expr
c
=
addto
currentpicture
contour
c
_op_
enddef
;
1320
def
normaldraw
expr
p
=
addto
currentpicture
if
picture
p
:
also
p
else
:
doublepath
p
withpen
currentpen
fi
_op_
enddef
;
1321 1322
def
drawlineoptions
(
text
t
)
=
def
_lin_opt_
=
t
enddef
;
enddef
;
1323
def
drawpointoptions
(
text
t
)
=
def
_pnt_opt_
=
t
enddef
;
enddef
;
1324
def
drawcontroloptions
(
text
t
)
=
def
_ctr_opt_
=
t
enddef
;
enddef
;
1325
def
drawlabeloptions
(
text
t
)
=
def
_lab_opt_
=
t
enddef
;
enddef
;
1326
def
draworiginoptions
(
text
t
)
=
def
_ori_opt_
=
t
enddef
;
enddef
;
1327
def
drawboundoptions
(
text
t
)
=
def
_bnd_opt_
=
t
enddef
;
enddef
;
1328
def
drawpathoptions
(
text
t
)
=
def
_pth_opt_
=
t
enddef
;
enddef
;
1329 1330
numeric
drawoptionsfactor
;
drawoptionsfactor
:
=
pt
;
1331 1332
def
resetdrawoptions
=
1333
drawlineoptions
(
withpen
pencircle
scaled
1.0
drawoptionsfactor
withcolor
.5
white
)
;
1334
drawpointoptions
(
withpen
pencircle
scaled
4.0
drawoptionsfactor
withcolor
black
)
;
1335
drawcontroloptions
(
withpen
pencircle
scaled
2.5
drawoptionsfactor
withcolor
black
)
;
1336
drawlabeloptions
(
)
;
1337
draworiginoptions
(
withpen
pencircle
scaled
1.0
drawoptionsfactor
withcolor
.5
white
)
;
1338
drawboundoptions
(
dashed
evenly
_ori_opt_
)
;
1339
drawpathoptions
(
withpen
pencircle
scaled
5.0
drawoptionsfactor
withcolor
.8
white
)
;
1340
enddef
;
1341 1342
resetdrawoptions
;
1343 1344
%D Path.
1345 1346
def
drawpath
expr
p
=
1347
normaldraw
p
_pth_opt_
1348
enddef
;
1349 1350
%D Arrow.
1351 1352
newinternal
ahvariant
;
ahvariant
:
=
0
;
1353
newinternal
ahdimple
;
ahdimple
:
=
1
/
5
;
1354
newinternal
ahscale
;
ahscale
:
=
3
/
4
;
1355 1356
vardef
arrowhead
expr
p
=
1357
save
q
,
e
,
r
;
1358
pair
e
;
e
=
point
length
p
of
p
;
1359
path
q
;
q
=
gobble
(
p
shifted
-
e
cutafter
makepath
(
pencircle
scaled
(
2
ahlength
)
)
)
cuttings
;
1360
if
ahvariant
>
0
:
1361
path
r
;
r
=
gobble
(
p
shifted
-
e
cutafter
makepath
(
pencircle
scaled
(
(
1
-
ahdimple
)
*
2
ahlength
)
)
)
cuttings
;
1362
fi
1363
(
q
rotated
(
ahangle
/
2
)
&
reverse
q
rotated
-
(
ahangle
/
2
)
1364
if
ahvariant
=
1
:
1365
--
point
0
of
r
--
1366
elseif
ahvariant
=
2
:
1367
...
point
0
of
r
...
1368
else
:
1369
--
1370
fi
1371
cycle
1372
)
shifted
e
1373
enddef
;
1374 1375
vardef
drawarrowpath
expr
p
=
1376
save
autoarrows
;
boolean
autoarrows
;
autoarrows
:
=
true
;
1377
drawarrow
p
_pth_opt_
1378
enddef
;
1379 1380
def
midarrowhead
expr
p
=
1381
arrowhead
p
cutafter
(
point
length
(
p
cutafter
point
.5
along
p
)
+
ahlength
on
p
)
1382
enddef
;
1383 1384
vardef
arrowheadonpath
(
expr
p
,
s
)
=
1385
save
autoarrows
;
boolean
autoarrows
;
1386
autoarrows
:
=
true
;
1387
set_ahlength
(
scaled
ahfactor
)
;
% added
1388
arrowhead
p
if
s
<
1
:
cutafter
(
point
(
s
*
arclength
(
p
)
+
(
ahlength
/
2
)
)
on
p
)
fi
1389
enddef
;
1390 1391
def
resetarrows
=
1392
hide
(
1393
ahlength
:
=
4
;
1394
ahangle
:
=
45
;
1395
ahvariant
:
=
0
;
1396
ahdimple
:
=
1
/
5
;
1397
ahscale
:
=
3
/
4
;
1398
)
1399
enddef
;
1400 1401
%D Points.
1402 1403
def
drawpoint
expr
c
=
1404
if
string
c
:
1405
string
_c_
;
1406
_c_
:
=
"
(
"
&
c
&
"
)
"
;
1407
dotlabel
.
urt
(
_c_
,
scantokens
_c_
)
;
1408
drawdot
scantokens
_c_
1409
else
:
1410
dotlabel
.
urt
(
"
(
"
&
decimal
xpart
c
&
"
,
"
&
decimal
ypart
c
&
"
)
"
,
c
)
;
1411
drawdot
c
1412
fi
_pnt_opt_
1413
enddef
;
1414 1415
%D PathPoints.
1416 1417
def
drawpoints
expr
c
=
path
_c_
;
_c_
:
=
c
;
mfun_draw_points
enddef
;
1418
def
drawcontrolpoints
expr
c
=
path
_c_
;
_c_
:
=
c
;
mfun_draw_controlpoints
enddef
;
1419
def
drawcontrollines
expr
c
=
path
_c_
;
_c_
:
=
c
;
mfun_draw_controllines
enddef
;
1420
def
drawpointlabels
expr
c
=
path
_c_
;
_c_
:
=
c
;
mfun_draw_pointlabels
enddef
;
1421 1422
def
mfun_draw_points
text
t
=
1423
for
_i_
=
0
upto
length
(
_c_
)
if
cycle
_c_
:
-1
fi
:
1424
normaldraw
point
_i_
of
_c_
_pnt_opt_
t
;
1425
endfor
;
1426
enddef
;
1427 1428
def
mfun_draw_controlpoints
text
t
=
1429
for
_i_
=
0
upto
length
(
_c_
)
:
1430
normaldraw
precontrol
_i_
of
_c_
_ctr_opt_
t
;
1431
normaldraw
postcontrol
_i_
of
_c_
_ctr_opt_
t
;
1432
endfor
;
1433
enddef
;
1434 1435
def
mfun_draw_controllines
text
t
=
1436
for
_i_
=
0
upto
length
(
_c_
)
:
1437
normaldraw
point
_i_
of
_c_
--
precontrol
_i_
of
_c_
_lin_opt_
t
;
1438
normaldraw
point
_i_
of
_c_
--
postcontrol
_i_
of
_c_
_lin_opt_
t
;
1439
endfor
;
1440
enddef
;
1441 1442
boolean
swappointlabels
;
swappointlabels
:
=
false
;
1443
numeric
pointlabelscale
;
pointlabelscale
:
=
0
;
1444
string
pointlabelfont
;
pointlabelfont
:
=
"
"
;
1445 1446
def
mfun_draw_pointlabels
text
t
=
1447
for
_i_
=
0
upto
length
(
_c_
)
if
cycle
_c_
:
-1
fi
:
1448
pair
_u_
;
_u_
:
=
unitvector
(
direction
_i_
of
_c_
)
rotated
if
swappointlabels
:
-
fi
90
;
1449
pair
_p_
;
_p_
:
=
(
point
_i_
of
_c_
)
;
1450
begingroup
;
1451
if
pointlabelscale
>
0
:
1452
save
defaultscale
;
numeric
defaultscale
;
1453
defaultscale
:
=
pointlabelscale
;
1454
fi
;
1455
if
pointlabelfont
<
>
"
"
:
1456
save
defaultfont
;
string
defaultfont
;
1457
defaultfont
:
=
pointlabelfont
;
1458
fi
;
1459
_u_
:
=
10
*
drawoptionsfactor
*
defaultscale
*
_u_
;
1460
normaldraw
thelabel
(
decimal
_i_
,
_p_
shifted
if
cycle
_c_
and
(
_i_
=
0
)
:
-
fi
_u_
)
_lab_opt_
t
;
1461
endgroup
;
1462
endfor
;
1463
enddef
;
1464 1465
%D Bounding box.
1466 1467
def
drawboundingbox
expr
p
=
1468
normaldraw
boundingbox
p
_bnd_opt_
1469
enddef
;
1470 1471
%D Origin.
1472 1473
numeric
originlength
;
originlength
:
=
.5
cm
;
1474 1475
def
draworigin
text
t
=
1476
normaldraw
(
origin
shifted
(
0
,
originlength
)
--
origin
shifted
(
0
,
-
originlength
)
)
_ori_opt_
t
;
1477
normaldraw
(
origin
shifted
(
originlength
,
0
)
--
origin
shifted
(
-
originlength
,
0
)
)
_ori_opt_
t
;
1478
enddef
;
1479 1480
%D Axis.
1481 1482
numeric
tickstep
;
tickstep
:
=
5
mm
;
1483
numeric
ticklength
;
ticklength
:
=
2
mm
;
1484 1485
def
drawxticks
expr
c
=
path
_c_
;
_c_
:
=
c
;
mfun_draw_xticks
enddef
;
1486
def
drawyticks
expr
c
=
path
_c_
;
_c_
:
=
c
;
mfun_draw_yticks
enddef
;
1487
def
drawticks
expr
c
=
path
_c_
;
_c_
:
=
c
;
mfun_draw_ticks
enddef
;
1488 1489
% Adding eps prevents disappearance due to rounding errors.
1490 1491
def
mfun_draw_xticks
text
t
=
1492
for
i
=
0
step
-
tickstep
until
xpart
llcorner
_c_
-
eps
:
1493
if
(
i
<
=
xpart
lrcorner
_c_
)
:
1494
normaldraw
(
i
,
-
ticklength
)
--
(
i
,
ticklength
)
_ori_opt_
t
;
1495
fi
;
1496
endfor
;
1497
for
i
=
0
step
tickstep
until
xpart
lrcorner
_c_
+
eps
:
1498
if
(
i
>
=
xpart
llcorner
_c_
)
:
1499
normaldraw
(
i
,
-
ticklength
)
--
(
i
,
ticklength
)
_ori_opt_
t
;
1500
fi
;
1501
endfor
;
1502
normaldraw
(
llcorner
_c_
--
ulcorner
_c_
)
shifted
(
-
xpart
llcorner
_c_
,
0
)
_ori_opt_
t
;
1503
enddef
;
1504 1505
def
mfun_draw_yticks
text
t
=
1506
for
i
=
0
step
-
tickstep
until
ypart
llcorner
_c_
-
eps
:
1507
if
(
i
<
=
ypart
ulcorner
_c_
)
:
1508
normaldraw
(
-
ticklength
,
i
)
--
(
ticklength
,
i
)
_ori_opt_
t
;
1509
fi
;
1510
endfor
;
1511
for
i
=
0
step
tickstep
until
ypart
ulcorner
_c_
+
eps
:
1512
if
(
i
>
=
ypart
llcorner
_c_
)
:
1513
normaldraw
(
-
ticklength
,
i
)
--
(
ticklength
,
i
)
_ori_opt_
t
;
1514
fi
;
1515
endfor
;
1516
normaldraw
(
llcorner
_c_
--
lrcorner
_c_
)
shifted
(
0
,
-
ypart
llcorner
_c_
)
_ori_opt_
t
;
1517
enddef
;
1518 1519
def
mfun_draw_ticks
text
t
=
1520
drawxticks
_c_
t
;
1521
drawyticks
_c_
t
;
1522
enddef
;
1523 1524
%D All of it except axis.
1525 1526
def
drawwholepath
expr
p
=
1527
draworigin
;
1528
drawpath
p
;
1529
drawcontrollines
p
;
1530
drawcontrolpoints
p
;
1531
drawpoints
p
;
1532
drawboundingbox
p
;
1533
drawpointlabels
p
;
1534
enddef
;
1535 1536
def
drawpathonly
expr
p
=
1537
drawpath
p
;
1538
drawcontrollines
p
;
1539
drawcontrolpoints
p
;
1540
drawpoints
p
;
1541
drawpointlabels
p
;
1542
enddef
;
1543 1544
%D Tracing.
1545 1546
def
visualizeddraw
expr
c
=
1547
if
picture
c
:
normaldraw
c
else
:
path
_c_
;
_c_
:
=
c
;
do_visualizeddraw
fi
1548
enddef
;
1549 1550
def
visualizedfill
expr
c
=
1551
if
picture
c
:
normalfill
c
else
:
path
_c_
;
_c_
:
=
c
;
do_visualizedfill
fi
1552
enddef
;
1553 1554
def
do_visualizeddraw
text
t
=
1555
draworigin
;
1556
drawpath
_c_
t
;
1557
drawcontrollines
_c_
;
1558
drawcontrolpoints
_c_
;
1559
drawpoints
_c_
;
1560
drawboundingbox
_c_
;
1561
drawpointlabels
_c_
;
1562
enddef
;
1563 1564
def
do_visualizedfill
text
t
=
1565
if
cycle
_c_
:
normalfill
_c_
t
fi
;
1566
draworigin
;
1567
drawcontrollines
_c_
;
1568
drawcontrolpoints
_c_
;
1569
drawpoints
_c_
;
1570
drawboundingbox
_c_
;
1571
drawpointlabels
_c_
;
1572
enddef
;
1573 1574
def
detaileddraw
expr
c
=
1575
if
picture
c
:
normaldraw
c
else
:
path
_c_
;
_c_
:
=
c
;
do_detaileddraw
fi
1576
enddef
;
1577 1578
def
do_detaileddraw
text
t
=
1579
drawpath
_c_
t
;
1580
drawcontrollines
_c_
;
1581
drawcontrolpoints
_c_
;
1582
drawpoints
_c_
;
1583
% % for labels we need an third run (as the second will mark the numbers); i could preroll them
1584
% % but then the hash needs to handle that as well (as now we keep numbering)
1585
% drawpointlabels _c_ ;
1586
enddef
;
1587 1588
def
visualizepaths
=
1589
let
fill
=
visualizedfill
;
1590
let
draw
=
visualizeddraw
;
1591
enddef
;
1592 1593
def
detailpaths
=
1594
let
draw
=
detaileddraw
;
1595
enddef
;
1596 1597
def
naturalizepaths
=
1598
let
fill
=
normalfill
;
1599
let
draw
=
normaldraw
;
1600
enddef
;
1601 1602
extra_endfig
:
=
extra_endfig
&
"
naturalizepaths ;
"
;
1603 1604
%D Nice tracer:
1605 1606
def
drawboundary
primary
p
=
1607
draw
p
dashed
evenly
withcolor
white
;
1608
draw
p
dashed
oddly
withcolor
black
;
1609
draw
(
-
llcorner
p
)
withpen
pencircle
scaled
3
withcolor
white
;
1610
draw
(
-
llcorner
p
)
withpen
pencircle
scaled
1.5
withcolor
black
;
1611
enddef
;
1612 1613
%D Also handy:
1614 1615
extra_beginfig
:
=
extra_beginfig
&
"
truecorners := 0 ;
"
;
% restores
1616
extra_beginfig
:
=
extra_beginfig
&
"
miterlimit := 10 ;
"
;
% restores
1617
extra_beginfig
:
=
extra_beginfig
&
"
linejoin := rounded ;
"
;
% restores
1618
extra_beginfig
:
=
extra_beginfig
&
"
linecap := rounded ;
"
;
% restores
1619 1620
%D Normally, arrowheads don't scale well. So we provide a hack.
1621 1622
boolean
autoarrows
;
autoarrows
:
=
false
;
1623
numeric
ahfactor
;
ahfactor
:
=
2.5
;
1624 1625
def
set_ahlength
(
text
t
)
=
% called to often
1626
% ahlength := (ahfactor*pen_size(_op_ t)) ; % _op_ added
1627
% problem: _op_ can contain color so a no-go, we could apply the transform
1628
% but i need to figure out the best way (fakepicture and take components).
1629
ahlength
:
=
(
ahfactor
*
pen_size
(
t
)
)
;
1630
enddef
;
1631 1632
vardef
pen_size
(
text
t
)
=
1633
save
p
;
picture
p
;
p
:
=
nullpicture
;
1634
addto
p
doublepath
(
top
origin
--
bot
origin
)
t
;
1635
(
ypart
urcorner
p
-
ypart
lrcorner
p
)
1636
enddef
;
1637 1638
%D The next two macros are adapted versions of plain
1639
%D \METAPOST\ definitions.
1640 1641
vardef
arrowpath
expr
p
=
% patch by Peter Rolf: supports squared pen and shifting (hh: maybe just use center of head as first)
1642
(
p
cutafter
makepath
(
pencircle
1643
scaled
(
if
ahvariant
>
0
:
(
1
-
ahdimple
)
*
fi
2
ahlength
*
cosd
(
ahangle
/
2
)
)
1644
shifted
point
length
p
of
p
1645
)
)
1646
enddef
;
1647 1648
% New experimental extension: also handling pictures:
1649
%
1650
% drawarrow fullsquare scaled 2cm withcolor green ;
1651
% drawarrow fullcircle scaled 3cm withcolor green ;
1652
% drawarrow image (
1653
% draw fullsquare scaled 4cm withcolor red ;
1654
% draw fullcircle scaled 5cm withcolor blue ;
1655
% ) ;
1656
% currentpicture := currentpicture shifted (-bbwidth(currentpicture)-1cm,0) ;
1657
% drawdblarrow fullsquare scaled 2cm withcolor green ;
1658
% drawdblarrow fullcircle scaled 3cm withcolor green ;
1659
% drawdblarrow image (
1660
% draw fullsquare scaled 4cm withcolor red ;
1661
% draw fullcircle scaled 5cm withcolor blue ;
1662
% ) ;
1663 1664
vardef
stroked_paths
(
expr
p
)
=
1665
save
n
;
numeric
n
;
n
:
=
0
;
1666
for
i
within
p
:
1667
if
stroked
i
:
1668
n
:
=
n
+
1
;
1669
fi
1670
endfor
;
1671
n
1672
enddef
;
1673 1674
def
mfun_decoration_i
expr
i
=
1675
withpen
penpart
i
1676
withcolor
colorpart
i
1677
withprescript
prescriptpart
i
1678
withpostscript
postscriptpart
i
1679
enddef
;
1680 1681
% We could collapse all in one helper but in context we nowaways don't want
1682
% the added obscurity. Tokens come cheap.
1683 1684
numeric
mfun_arrow_snippets
;
1685
numeric
mfun_arrow_count
;
1686 1687
def
drawarrow
expr
p
=
1688
begingroup
;
1689
save
mfun_arrow_path
;
1690
path
mfun_arrow_path
;
1691
if
path
p
:
1692
mfun_arrow_path
:
=
p
;
1693
expandafter
mfun_draw_arrow_path
1694
elseif
picture
p
:
1695
save
mfun_arrow_picture
;
1696
picture
mfun_arrow_picture
;
1697
mfun_arrow_picture
:
=
p
;
1698
expandafter
mfun_draw_arrow_picture
1699
else
:
1700
expandafter
mfun_draw_arrow_nothing
1701
fi
1702
enddef
;
1703 1704
def
drawdblarrow
expr
p
=
1705
begingroup
;
1706
save
mfun_arrow_path
;
1707
path
mfun_arrow_path
;
1708
if
path
p
:
1709
mfun_arrow_path
:
=
p
;
1710
expandafter
mfun_draw_arrow_path_double
1711
elseif
picture
p
:
1712
save
mfun_arrow_picture
;
1713
picture
mfun_arrow_picture
;
1714
mfun_arrow_picture
:
=
p
;
1715
expandafter
mfun_draw_arrow_picture_double
1716
else
:
1717
expandafter
mfun_draw_arrow_nothing
1718
fi
1719
enddef
;
1720 1721
def
mfun_draw_arrow_nothing
text
t
=
1722
enddef
;
1723 1724
% The path is shortened so that the arrow head extends it to the original
1725
% length. In case of a double arrow the path gets shortened twice.
1726 1727
def
mfun_draw_arrow_path
text
t
=
1728
if
autoarrows
:
1729
set_ahlength
(
t
)
;
1730
fi
1731
draw
arrowpath
mfun_arrow_path
t
;
1732
fillup
arrowhead
mfun_arrow_path
t
;
1733
endgroup
;
1734
enddef
;
1735 1736
def
mfun_draw_arrow_path_double
text
t
=
1737
if
autoarrows
:
1738
set_ahlength
(
t
)
;
1739
fi
1740
draw
arrowpath
(
reverse
arrowpath
mfun_arrow_path
)
t
;
1741
fillup
arrowhead
mfun_arrow_path
t
;
1742
fillup
arrowhead
reverse
mfun_arrow_path
t
;
1743
endgroup
;
1744
enddef
;
1745 1746
% The picture variant is not treating each path but only the first and
1747
% last path. This can be somewhat counterintuitive but is needed for Alan's
1748
% macros. So here the last and in case of a double path first paths in a
1749
% picture get the shortening.
1750 1751
def
mfun_with_arrow_picture
(
text
t
)
=
1752
mfun_arrow_count
:
=
0
;
1753
mfun_arrow_snippets
:
=
stroked_paths
(
mfun_arrow_picture
)
;
1754
for
i
within
mfun_arrow_picture
:
1755
if
istextext
(
i
)
:
1756
draw
i
1757
else
:
1758
mfun_arrow_count
:
=
mfun_arrow_count
+
1
;
1759
mfun_arrow_path
:
=
pathpart
i
;
1760
t
1761
fi
;
1762
endfor
;
1763
enddef
;
1764 1765
def
mfun_draw_arrow_picture
text
t
=
1766
if
autoarrows
:
1767
set_ahlength
(
t
)
;
1768
fi
1769
mfun_with_arrow_picture
(
1770
if
mfun_arrow_count
=
mfun_arrow_snippets
:
1771
draw
arrowpath
mfun_arrow_path
mfun_decoration_i
i
t
;
1772
fillup
arrowhead
mfun_arrow_path
mfun_decoration_i
i
t
;
1773
else
:
1774
draw
mfun_arrow_path
mfun_decoration_i
i
t
;
1775
fi
;
1776
)
1777
endgroup
;
1778
enddef
;
1779 1780
def
mfun_draw_arrow_picture_double
text
t
=
1781
if
autoarrows
:
1782
set_ahlength
(
t
)
;
1783
fi
1784
mfun_with_arrow_picture
(
1785
draw
1786
if
mfun_arrow_count
=
1
:
1787
arrowpath
reverse
1788
elseif
mfun_arrow_count
=
mfun_arrow_snippets
:
1789
arrowpath
1790
fi
1791
mfun_arrow_path
mfun_decoration_i
i
t
;
1792
if
mfun_arrow_count
=
1
:
1793
fillup
arrowhead
reverse
mfun_arrow_path
mfun_decoration_i
i
t
;
1794
fi
1795
if
mfun_arrow_count
=
mfun_arrow_snippets
:
1796
fillup
arrowhead
mfun_arrow_path
mfun_decoration_i
i
t
;
1797
fi
1798
)
1799
endgroup
;
1800
enddef
;
1801 1802
%D Some more arrow magic, by Alan:
1803 1804
def
drawdoublearrows
expr
p
=
1805
begingroup
;
1806
save
mfun_arrow_path
;
1807
path
mfun_arrow_path
;
1808
save
mfun_arrow_path_parallel
;
1809
path
mfun_arrow_path_parallel
;
1810
if
path
p
:
1811
mfun_arrow_path
:
=
p
;
1812
expandafter
mfun_draw_arrow_paths
1813
elseif
picture
p
:
1814
save
mfun_arrow_picture
;
1815
picture
mfun_arrow_picture
;
1816
mfun_arrow_picture
:
=
p
;
1817
expandafter
mfun_draw_arrow_pictures
1818
else
:
1819
expandafter
mfun_draw_arrow_nothing
1820
fi
1821
enddef
;
1822 1823
def
mfun_draw_arrow_paths
text
t
=
1824
if
autoarrows
:
1825
set_ahlength
(
t
)
;
1826
fi
1827
save
d
;
d
:
=
ahscale
*
ahlength
*
sind
(
ahangle
/
2
)
;
1828
mfun_arrow_path_parallel
:
=
mfun_arrow_path
paralleled
d
;
1829
draw
arrowpath
mfun_arrow_path_parallel
t
;
1830
fillup
arrowhead
mfun_arrow_path_parallel
t
;
1831
mfun_arrow_path_parallel
:
=
(
reverse
mfun_arrow_path
)
paralleled
d
;
1832
draw
arrowpath
mfun_arrow_path_parallel
t
;
1833
fillup
arrowhead
mfun_arrow_path_parallel
t
;
1834
endgroup
;
1835
enddef
;
1836 1837
def
mfun_draw_arrow_pictures
text
t
=
1838
if
autoarrows
:
1839
set_ahlength
(
t
)
;
1840
fi
1841
save
d
;
d
:
=
ahscale
*
ahlength
*
sind
(
ahangle
/
2
)
;
1842
mfun_with_arrow_picture
(
1843
if
mfun_arrow_count
=
1
:
1844
draw
(
mfun_arrow_path
paralleled
d
)
mfun_decoration_i
i
t
;
1845
mfun_arrow_path_parallel
:
=
(
reverse
mfun_arrow_path
)
paralleled
d
;
1846
draw
arrowpath
mfun_arrow_path_parallel
mfun_decoration_i
i
t
;
1847
fillup
arrowhead
mfun_arrow_path_parallel
mfun_decoration_i
i
t
;
1848
elseif
mfun_arrow_count
=
mfun_arrow_snippets
:
1849
draw
(
(
reverse
mfun_arrow_path
)
paralleled
d
)
mfun_decoration_i
i
t
;
1850
mfun_arrow_path_parallel
:
=
mfun_arrow_path
paralleled
d
;
1851
draw
arrowpath
mfun_arrow_path_parallel
mfun_decoration_i
i
t
;
1852
fillup
arrowhead
mfun_arrow_path_parallel
mfun_decoration_i
i
t
;
1853
else
:
1854
draw
(
mfun_arrow_path
paralleled
d
)
mfun_decoration_i
i
t
;
1855
draw
(
(
reverse
mfun_arrow_path
)
paralleled
d
)
mfun_decoration_i
i
t
;
1856
fi
1857
)
1858
endgroup
;
1859
enddef
;
1860 1861
%D Handy too ......
1862 1863
vardef
pointarrow
(
expr
pat
,
loc
,
len
,
off
)
=
1864
save
l
,
r
,
s
,
t
;
path
l
,
r
;
numeric
s
;
pair
t
;
1865
t
:
=
if
pair
loc
:
loc
else
:
point
loc
along
pat
fi
;
1866
s
:
=
len
/
2
-
off
;
if
s
<
=
0
:
s
:
=
0
elseif
s
>
len
:
s
:
=
len
fi
;
1867
r
:
=
pat
cutbefore
t
;
1868
r
:
=
(
r
cutafter
point
(
arctime
s
of
r
)
of
r
)
;
1869
s
:
=
len
/
2
+
off
;
if
s
<
=
0
:
s
:
=
0
elseif
s
>
len
:
s
:
=
len
fi
;
1870
l
:
=
reverse
(
pat
cutafter
t
)
;
1871
l
:
=
(
reverse
(
l
cutafter
point
(
arctime
s
of
l
)
of
l
)
)
;
1872
(
l
.
.
r
)
1873
enddef
;
1874 1875
def
rightarrow
(
expr
pat
,
tim
,
len
)
=
pointarrow
(
pat
,
tim
,
len
,
-
len
)
enddef
;
1876
def
leftarrow
(
expr
pat
,
tim
,
len
)
=
pointarrow
(
pat
,
tim
,
len
,
+
len
)
enddef
;
1877
def
centerarrow
(
expr
pat
,
tim
,
len
)
=
pointarrow
(
pat
,
tim
,
len
,
0
)
enddef
;
1878 1879
%D The \type {along} and \type {on} operators can be used as follows:
1880
%D
1881
%D \starttyping
1882
%D drawdot point .5 along somepath ;
1883
%D drawdot point 3cm on somepath ;
1884
%D \stoptyping
1885
%D
1886
%D The number denotes a percentage (fraction).
1887 1888
primarydef
pct
along
pat
=
% also negative
1889
(
arctime
(
pct
*
(
arclength
pat
)
)
of
pat
)
of
pat
1890
enddef
;
1891 1892
primarydef
len
on
pat
=
% no outer ( ) .. somehow fails
1893
(
arctime
if
len
>
=
0
:
len
else
:
(
arclength
(
pat
)
+
len
)
fi
of
pat
)
of
pat
1894
enddef
;
1895 1896
% this cuts of a piece from both ends
1897 1898
tertiarydef
pat
cutends
len
=
1899
begingroup
1900
save
tap
;
path
tap
;
1901
tap
:
=
pat
cutbefore
(
point
(
xpart
paired
(
len
)
)
on
pat
)
;
1902
(
tap
cutafter
(
point
-
(
ypart
paired
(
len
)
)
on
tap
)
)
1903
endgroup
1904
enddef
;
1905 1906
%D To be documented.
1907 1908
path
freesquare
;
freesquare
:
=
(
1909
(
-1
,
0
)
--
(
-1
,
-1
)
--
(
0
,
-1
)
--
(
+1
,
-1
)
--
1910
(
+1
,
0
)
--
(
+1
,
+1
)
--
(
0
,
+1
)
--
(
-1
,
+1
)
--
cycle
1911
)
scaled
.5
;
1912 1913
numeric
freelabeloffset
;
freelabeloffset
:
=
3
pt
;
1914
numeric
freedotlabelsize
;
freedotlabelsize
:
=
3
pt
;
1915 1916
vardef
thefreelabel
(
expr
str
,
loc
,
ori
)
=
1917
save
s
,
p
,
q
,
l
;
picture
s
;
path
p
,
q
;
pair
l
;
1918
interim
labeloffset
:
=
freelabeloffset
;
1919
s
:
=
if
string
str
:
thelabel
(
str
,
loc
)
else
:
str
shifted
-
center
str
shifted
loc
fi
;
1920
setbounds
s
to
boundingbox
s
enlarged
freelabeloffset
;
1921
p
:
=
fullcircle
scaled
(
2
*
length
(
loc
-
ori
)
)
shifted
ori
;
1922
q
:
=
freesquare
xyscaled
(
urcorner
s
-
llcorner
s
)
;
1923
l
:
=
point
xpart
(
p
intersectiontimes
(
ori
-
-
loc
shifted
(
loc
-
ori
)
)
)
of
q
;
1924
setbounds
s
to
boundingbox
s
enlarged
-
freelabeloffset
;
% new
1925
% draw boundingbox s shifted -l withpen pencircle scaled .5pt withcolor red ;
1926
(
s
shifted
-
l
)
1927
enddef
;
1928 1929
vardef
freelabel
(
expr
str
,
loc
,
ori
)
=
1930
draw
thefreelabel
(
str
,
loc
,
ori
)
;
1931
enddef
;
1932 1933
vardef
freedotlabel
(
expr
str
,
loc
,
ori
)
=
1934
interim
linecap
:
=
rounded
;
1935
draw
loc
withpen
pencircle
scaled
freedotlabelsize
;
1936
draw
thefreelabel
(
str
,
loc
,
ori
)
;
1937
enddef
;
1938 1939
%D \starttyping
1940
%D drawarrow anglebetween(line_a,line_b,somelabel) ;
1941
%D \stoptyping
1942 1943
newinternal
angleoffset
;
angleoffset
:
=
0
pt
;
1944
newinternal
anglelength
;
anglelength
:
=
20
pt
;
1945
newinternal
anglemethod
;
anglemethod
:
=
1
;
1946 1947
vardef
anglebetween
(
expr
a
,
b
,
str
)
=
% path path string
1948
save
pointa
,
pointb
,
common
,
middle
,
offset
;
1949
pair
pointa
,
pointb
,
common
,
middle
,
offset
;
1950
save
curve
;
path
curve
;
1951
save
where
;
numeric
where
;
1952
if
round
point
0
of
a
=
round
point
0
of
b
:
1953
common
:
=
point
0
of
a
;
1954
else
:
1955
common
:
=
a
intersectionpoint
b
;
1956
fi
;
1957
pointa
:
=
point
anglelength
on
a
;
1958
pointb
:
=
point
anglelength
on
b
;
1959
where
:
=
turningnumber
(
common
-
-
pointa
-
-
pointb
-
-
cycle
)
;
1960
middle
:
=
(
reverse
(
common
-
-
pointa
)
rotatedaround
(
pointa
,
-
where
*
90
)
)
1961
intersection_point
1962
(
reverse
(
common
-
-
pointb
)
rotatedaround
(
pointb
,
where
*
90
)
)
;
1963
if
not
intersection_found
:
1964
middle
:
=
point
.5
along
1965
(
(
reverse
(
common
-
-
pointa
)
rotatedaround
(
pointa
,
-
where
*
90
)
)
--
1966
(
(
common
-
-
pointb
)
rotatedaround
(
pointb
,
where
*
90
)
)
)
;
1967
fi
;
1968
if
anglemethod
=
0
:
1969
curve
:
=
pointa
{
unitvector
(
middle
-
pointa
)
}
..
pointb
;
1970
middle
:
=
point
.5
along
curve
;
1971
curve
:
=
common
;
1972
elseif
anglemethod
=
1
:
1973
curve
:
=
pointa
{
unitvector
(
middle
-
pointa
)
}
..
pointb
;
1974
middle
:
=
point
.5
along
curve
;
1975
elseif
anglemethod
=
2
:
1976
middle
:
=
common
rotatedaround
(
.5
[
pointa
,
pointb
]
,
180
)
;
1977
curve
:
=
pointa
-
-
middle
-
-
pointb
;
1978
elseif
anglemethod
=
3
:
1979
curve
:
=
pointa
-
-
middle
-
-
pointb
;
1980
elseif
anglemethod
=
4
:
1981
curve
:
=
pointa
.
.
controls
middle
.
.
pointb
;
1982
middle
:
=
point
.5
along
curve
;
1983
fi
;
1984
draw
thefreelabel
(
str
,
middle
,
common
)
;
% withcolor black ;
1985
curve
1986
enddef
;
1987 1988
% Stack
1989 1990
picture
mfun_current_picture_stack
[
]
;
1991
numeric
mfun_current_picture_depth
;
1992 1993
mfun_current_picture_depth
:
=
0
;
1994 1995
def
pushcurrentpicture
=
1996
mfun_current_picture_depth
:
=
mfun_current_picture_depth
+
1
;
1997
mfun_current_picture_stack
[
mfun_current_picture_depth
]
:
=
currentpicture
;
1998
currentpicture
:
=
nullpicture
;
1999
enddef
;
2000 2001
def
popcurrentpicture
text
t
=
% optional text
2002
if
mfun_current_picture_depth
>
0
:
2003
addto
mfun_current_picture_stack
[
mfun_current_picture_depth
]
also
currentpicture
t
;
2004
currentpicture
:
=
mfun_current_picture_stack
[
mfun_current_picture_depth
]
;
2005
mfun_current_picture_stack
[
mfun_current_picture_depth
]
:
=
nullpicture
;
2006
mfun_current_picture_depth
:
=
mfun_current_picture_depth
-
1
;
2007
fi
;
2008
enddef
;
2009 2010
%D colorcircle(size, red, green, blue) ;
2011 2012
vardef
colorcircle
(
expr
size
,
red
,
green
,
blue
)
=
% might move
2013
save
r
,
g
,
b
,
c
,
m
,
y
,
w
;
save
radius
;
2014
path
r
,
g
,
b
,
c
,
m
,
y
,
w
;
numeric
radius
;
2015 2016
radius
:
=
5
cm
;
pickup
pencircle
scaled
(
radius
/
25
)
;
2017 2018
transform
t
;
t
:
=
identity
rotatedaround
(
origin
,
120
)
;
2019 2020
r
:
=
fullcircle
rotated
90
scaled
radius
shifted
(
0
,
radius
/
4
)
rotatedaround
(
origin
,
135
)
;
2021 2022
b
:
=
r
transformed
t
;
g
:
=
b
transformed
t
;
2023 2024
c
:
=
buildcycle
(
subpath
(
1
,
7
)
of
g
,
subpath
(
1
,
7
)
of
b
)
;
2025
y
:
=
c
transformed
t
;
m
:
=
y
transformed
t
;
2026 2027
w
:
=
buildcycle
(
subpath
(
3
,
5
)
of
r
,
subpath
(
3
,
5
)
of
g
,
subpath
(
3
,
5
)
of
b
)
;
2028 2029
pushcurrentpicture
;
2030 2031
fill
r
withcolor
red
;
2032
fill
g
withcolor
green
;
2033
fill
b
withcolor
blue
;
2034
fill
c
withcolor
white
-
red
;
2035
fill
m
withcolor
white
-
green
;
2036
fill
y
withcolor
white
-
blue
;
2037
fill
w
withcolor
white
;
2038 2039
for
i
=
r
,
g
,
b
,
c
,
m
,
y
:
draw
i
withcolor
.5
white
;
endfor
;
2040 2041
currentpicture
:
=
currentpicture
xsized
size
;
2042 2043
popcurrentpicture
;
2044
enddef
;
2045 2046
% penpoint (i,2) of somepath -> inner / outer point
2047 2048
vardef
penpoint
expr
pnt
of
p
=
2049
save
n
,
d
;
numeric
n
,
d
;
2050
(
n
,
d
)
=
if
pair
pnt
:
pnt
else
:
(
pnt
,
1
)
fi
;
2051
(
point
n
of
p
shifted
(
(
penoffset
direction
n
of
p
of
currentpen
)
scaled
d
)
)
2052
enddef
;
2053 2054
% nice: currentpicture := inverted currentpicture ;
2055 2056
primarydef
p
uncolored
c
=
% not complete ... needs text and scripts and ...
2057
if
color
p
:
2058
c
-
p
2059
else
:
2060
image
(
2061
for
i
within
p
:
2062
addto
currentpicture
2063
if
stroked
i
or
filled
i
:
2064
if
filled
i
:
2065
contour
2066
else
:
2067
doublepath
2068
fi
2069
pathpart
i
2070
dashed
dashpart
i
withpen
penpart
i
2071
else
:
2072
also
i
2073
fi
2074
withcolor
c
-
(
redpart
i
,
greenpart
i
,
bluepart
i
)
;
2075
endfor
;
2076
)
2077
fi
2078
enddef
;
2079 2080
vardef
inverted
primary
p
=
2081
p
uncolored
white
2082
enddef
;
2083 2084
primarydef
p
softened
c
=
2085
begingroup
2086
save
cc
;
color
cc
;
cc
:
=
tripled
(
c
)
;
2087
if
color
p
:
2088
(
redpart
cc
*
redpart
p
,
greenpart
cc
*
greenpart
p
,
bluepart
cc
*
bluepart
p
)
2089
else
:
2090
image
(
2091
for
i
within
p
:
2092
addto
currentpicture
2093
if
stroked
i
or
filled
i
:
2094
if
filled
i
:
2095
contour
2096
else
:
2097
doublepath
2098
fi
2099
pathpart
i
2100
dashed
dashpart
i
withpen
penpart
i
2101
else
:
2102
also
i
2103
fi
2104
withcolor
(
redpart
cc
*
redpart
i
,
greenpart
cc
*
greenpart
i
,
bluepart
cc
*
bluepart
i
)
;
2105
endfor
;
2106
)
2107
fi
2108
endgroup
2109
enddef
;
2110 2111
vardef
grayed
primary
p
=
2112
if
rgbcolor
p
:
2113
tripled
(
.30
redpart
p
+.59
greenpart
p
+.11
bluepart
p
)
2114
elseif
cmykcolor
p
:
2115
tripled
(
.30
*
(
1
-
cyanpart
i
)
+.59
*
(
1
-
magentapart
i
)
+.11
*
(
1
-
yellowpart
i
)
+
blackpart
i
)
2116
elseif
greycolor
p
:
2117
p
2118
elseif
string
p
:
2119
grayed
resolvedcolor
(
p
)
2120
elseif
picture
p
:
2121
image
(
2122
for
i
within
p
:
2123
addto
currentpicture
2124
if
stroked
i
or
filled
i
:
2125
if
filled
i
:
2126
contour
2127
else
:
2128
doublepath
2129
fi
2130
pathpart
i
2131
dashed
dashpart
i
2132
withpen
penpart
i
2133
else
:
2134
also
i
2135
fi
2136
if
unknown
colorpart
i
:
2137
% nothing
2138
elseif
rgbcolor
colorpart
i
:
2139
withcolor
tripled
(
.30
redpart
i
+.59
greenpart
i
+.11
bluepart
i
)
;
2140
elseif
cmykcolor
colorpart
i
:
2141
withcolor
tripled
(
.30
*
(
1
-
cyanpart
i
)
+.59
*
(
1
-
magentapart
i
)
+.11
*
(
1
-
yellowpart
i
)
+
blackpart
i
)
;
2142
else
:
2143
withcolor
colorpart
i
;
2144
fi
2145
endfor
;
2146
)
2147
else
:
2148
p
2149
fi
2150
enddef
;
2151 2152
let
greyed
=
grayed
;
2153 2154
vardef
hsvtorgb
(
expr
h
,
s
,
v
)
=
2155
save
H
,
S
,
V
,
x
;
2156
H
=
h
mod
360
;
2157
S
=
if
s
<
0
:
0
elseif
s
>
1
:
1
else
:
s
fi
;
2158
V
=
if
v
<
0
:
0
elseif
v
>
1
:
1
else
:
v
fi
;
2159
x
=
1
-
abs
(
H
mod
120
-
60
)
/
60
;
2160
V
*
(
(
1
-
S
)
*
(
1
,
1
,
1
)
+
S
*
2161
if
H
<
60
:
(
1
,
x
,
0
)
2162
elseif
H
<
120
:
(
x
,
1
,
0
)
2163
elseif
H
<
180
:
(
0
,
1
,
x
)
2164
elseif
H
<
240
:
(
0
,
x
,
1
)
2165
elseif
H
<
300
:
(
x
,
0
,
1
)
2166
else
:
(
1
,
0
,
x
)
2167
fi
)
2168
enddef
;
2169 2170
% yes or no: "text" infont "cmr12" at 24pt ;
2171 2172
% let normalinfont = infont ;
2173
%
2174
% numeric lastfontsize ; lastfontsize = fontsize defaultfont ;
2175
%
2176
% def infont primary name = % no vardef, no expr
2177
% hide(lastfontsize := fontsize name) % no ;
2178
% normalinfont name
2179
% enddef ;
2180
%
2181
% def scaledat expr size =
2182
% scaled (size/lastfontsize)
2183
% enddef ;
2184
%
2185
% let at = scaledat ;
2186 2187
% like decimal
2188 2189
def
condition
primary
b
=
if
b
:
"
true
"
else
:
"
false
"
fi
enddef
;
2190 2191
% undocumented
2192 2193
primarydef
p
stretched
s
=
2194
begingroup
2195
save
pp
;
path
pp
;
pp
:
=
p
xyscaled
s
;
2196
(
pp
shifted
(
(
point
0
of
p
)
-
(
point
0
of
pp
)
)
)
2197
endgroup
2198
enddef
;
2199 2200
primarydef
p
enlonged
len
=
2201
begingroup
2202
if
len
=
=
0
:
2203
p
2204
elseif
pair
p
:
2205
save
q
;
path
q
;
q
:
=
origin
--
p
;
2206
save
al
;
al
:
=
arclength
(
q
)
;
2207
if
al
>
0
:
2208
point
1
of
(
q
stretched
(
(
al
+
len
)
/
al
)
)
2209
else
:
2210
p
2211
fi
2212
else
:
2213
save
al
;
al
:
=
arclength
(
p
)
;
2214
if
al
>
0
:
2215
p
stretched
(
(
al
+
len
)
/
al
)
2216
else
:
2217
p
2218
fi
2219
fi
2220
endgroup
2221
enddef
;
2222 2223
% path p ; p := (0,0) -- (10cm,5cm) ;
2224
% drawarrow p withcolor red ;
2225
% drawarrow p shortened 1cm withcolor green ;
2226 2227
% primarydef p shortened d =
2228
% reverse ( ( reverse (p enlonged -d) ) enlonged -d )
2229
% enddef ;
2230 2231
primarydef
p
shortened
d
=
2232
reverse
(
(
reverse
(
p
enlonged
-
xpart
paired
(
d
)
)
)
enlonged
-
ypart
paired
(
d
)
)
2233
enddef
;
2234 2235
% yes or no, untested -)
2236 2237
def
xshifted
expr
dx
=
shifted
(
dx
,
0
)
enddef
;
2238
def
yshifted
expr
dy
=
shifted
(
0
,
dy
)
enddef
;
2239 2240
% also handy
2241 2242
% right: str = readfrom ("abc" & ".def" ) ;
2243
% wrong: str = readfrom "abc" & ".def" ;
2244 2245
% Every 62th read fails so we need to try again!
2246 2247
% def readfile (expr name) =
2248
% if (readfrom (name) <> EOF) :
2249
% scantokens("input " & name & ";") ;
2250
% elseif (readfrom (name) <> EOF) :
2251
% scantokens("input " & name & ";") ;
2252
% fi ;
2253
% closefrom (name) ;
2254
% enddef ;
2255
%
2256
% this sometimes fails on the elseif, so :
2257
%
2258 2259
def
readfile
(
expr
name
)
=
2260
begingroup
;
save
ok
;
boolean
ok
;
2261
if
(
readfrom
(
name
)
<
>
EOF
)
:
2262
ok
:
=
false
;
2263
elseif
(
readfrom
(
name
)
<
>
EOF
)
:
2264
ok
:
=
false
;
2265
else
:
2266
ok
:
=
true
;
2267
fi
;
2268
if
not
ok
:
2269
scantokens
(
"
input
"
&
name
&
"
"
)
;
2270
fi
;
2271
closefrom
(
name
)
;
2272
endgroup
;
2273
enddef
;
2274 2275
% permits redefinition of end in macro
2276 2277
inner
end
;
2278 2279
% this will be redone (when needed) using scripts and backend handling
2280 2281
let
mfun_remap_colors_normalwithcolor
=
normalwithcolor
;
2282 2283
def
remapcolors
=
2284
def
normalwithcolor
primary
c
=
2285
mfun_remap_colors_normalwithcolor
remappedcolor
(
c
)
2286
enddef
;
2287
enddef
;
2288 2289
def
normalcolors
=
2290
let
normalwithcolor
=
mfun_remap_colors_normalwithcolor
;
2291
enddef
;
2292 2293
def
resetcolormap
=
2294
color
color_map
[
]
[
]
[
]
;
2295
normalcolors
;
2296
enddef
;
2297 2298
resetcolormap
;
2299 2300
def
r_color
primary
c
=
redpart
c
enddef
;
2301
def
g_color
primary
c
=
greenpart
c
enddef
;
2302
def
b_color
primary
c
=
bluepart
c
enddef
;
2303 2304
def
remapcolor
(
expr
old
,
new
)
=
2305
color_map
[
redpart
old
]
[
greenpart
old
]
[
bluepart
old
]
:
=
new
;
2306
enddef
;
2307 2308
def
remappedcolor
(
expr
c
)
=
2309
if
known
color_map
[
redpart
c
]
[
greenpart
c
]
[
bluepart
c
]
:
2310
color_map
[
redpart
c
]
[
greenpart
c
]
[
bluepart
c
]
2311
else
:
2312
c
2313
fi
2314
enddef
;
2315 2316
% Thanks to Jens-Uwe Morawski for pointing out that we need
2317
% to treat bounded and clipped components as local pictures.
2318 2319
def
recolor
suffix
p
=
p
:
=
repathed
(
0
,
p
)
enddef
;
2320
def
refill
suffix
p
=
p
:
=
repathed
(
1
,
p
)
enddef
;
2321
def
redraw
suffix
p
=
p
:
=
repathed
(
2
,
p
)
enddef
;
2322
def
retext
suffix
p
=
p
:
=
repathed
(
3
,
p
)
enddef
;
2323
def
untext
suffix
p
=
p
:
=
repathed
(
4
,
p
)
enddef
;
2324 2325
% primarydef p recolored t = repathed(0,p) t enddef ;
2326
% primarydef p refilled t = repathed(1,p) t enddef ;
2327
% primarydef p redrawn t = repathed(2,p) t enddef ;
2328
% primarydef p retexted t = repathed(3,p) t enddef ;
2329
% primarydef p untexted t = repathed(4,p) t enddef ;
2330 2331
color
refillbackground
;
refillbackground
:
=
(
1
,
1
,
1
)
;
2332 2333
def
restroke
suffix
p
=
p
:
=
repathed
(
21
,
p
)
enddef
;
% keep attributes
2334
def
reprocess
suffix
p
=
p
:
=
repathed
(
22
,
p
)
enddef
;
% no attributes
2335 2336
% also 11 and 12
2337 2338
vardef
repathed
(
expr
mode
,
p
)
text
t
=
2339
begingroup
;
2340
if
mode
=
0
:
2341
save
normalwithcolor
;
2342
remapcolors
;
2343
fi
;
2344
save
_p_
,
_pp_
,
_ppp_
,
_f_
,
_b_
,
_t_
;
2345
picture
_p_
,
_pp_
,
_ppp_
;
color
_f_
;
path
_b_
;
transform
_t_
;
2346
_b_
:
=
boundingbox
p
;
2347
_p_
:
=
nullpicture
;
2348
for
i
within
p
:
2349
_f_
:
=
(
redpart
i
,
greenpart
i
,
bluepart
i
)
;
2350
if
bounded
i
:
2351
_pp_
:
=
repathed
(
mode
,
i
)
t
;
2352
setbounds
_pp_
to
pathpart
i
;
2353
addto
_p_
also
_pp_
;
2354
elseif
clipped
i
:
2355
_pp_
:
=
repathed
(
mode
,
i
)
t
;
2356
clip
_pp_
to
pathpart
i
;
2357
addto
_p_
also
_pp_
;
2358
elseif
stroked
i
:
2359
if
mode
=
21
:
2360
_ppp_
:
=
i
;
% indirectness is needed
2361
addto
_p_
also
image
(
scantokens
(
t
&
"
pathpart _ppp_
"
)
2362
dashed
dashpart
i
withpen
penpart
i
2363
withcolor
_f_
;
)
;
2364
elseif
mode
=
22
:
2365
_ppp_
:
=
i
;
% indirectness is needed
2366
addto
_p_
also
image
(
scantokens
(
t
&
"
pathpart _ppp_
"
)
)
;
2367
else
:
2368
addto
_p_
doublepath
pathpart
i
2369
dashed
dashpart
i
withpen
penpart
i
2370
withcolor
_f_
% (redpart i, greenpart i, bluepart i)
2371
if
mode
=
2
:
2372
t
2373
fi
;
2374
fi
;
2375
elseif
filled
i
:
2376
if
mode
=
11
:
2377
_ppp_
:
=
i
;
% indirectness is needed
2378
addto
_p_
also
image
(
scantokens
(
t
&
"
pathpart _ppp_
"
)
2379
withcolor
_f_
;
)
;
2380
elseif
mode
=
12
:
2381
_ppp_
:
=
i
;
% indirectness is needed
2382
addto
_p_
also
image
(
scantokens
(
t
&
"
pathpart _ppp_
"
)
)
;
2383
else
:
2384
addto
_p_
contour
pathpart
i
2385
withcolor
_f_
2386
if
(
mode
=
1
)
and
(
_f_
<
>
refillbackground
)
:
2387
t
2388
fi
;
2389
fi
;
2390
elseif
textual
i
:
% textpart i <> "" :
2391
if
mode
<
>
4
:
2392
% transform _t_ ;
2393
% (xpart _t_, xxpart _t_, xypart _t_) = (xpart i, xxpart i, xypart i) ;
2394
% (ypart _t_, yypart _t_, yxpart _t_) = (ypart i, yypart i, yxpart i) ;
2395
% addto _p_ also
2396
% textpart i infont fontpart i % todo : other font
2397
% transformed _t_
2398
% withpen penpart i
2399
% withcolor _f_
2400
% if mode=3 : t fi ;
2401
addto
_p_
also
i
2402
if
mode
=
3
:
2403
t
2404
fi
;
2405
fi
;
2406
else
:
2407
addto
_p_
also
i
;
2408
fi
;
2409
endfor
;
2410
setbounds
_p_
to
_b_
;
2411
_p_
2412
endgroup
2413
enddef
;
2414 2415
% After a question of Denis on how to erase a z variable, Jacko
2416
% suggested to assign whatever to x and y. So a clearz
2417
% variable can be defined as:
2418
%
2419
% vardef clearz@# =
2420
% x@# := whatever ;
2421
% y@# := whatever ;
2422
% enddef ;
2423
%
2424
% but Jacko suggested a redefinition of clearxy:
2425
%
2426
% def clearxy text s =
2427
% clearxy_index_:=0;
2428
% for $:=s:
2429
% clearxy_index_:=clearxy_index_+1; endfor;
2430
% if clearxy_index_=0:
2431
% save x,y;
2432
% else:
2433
% forsuffixes $:=s: x$:=whatever; y$:=whatever; endfor;
2434
% fi
2435
% enddef;
2436
%
2437
% which i decided to simplify to:
2438 2439
def
clearxy
text
s
=
2440
if
false
for
$
:
=
s
:
or
true
endfor
:
2441
forsuffixes
$
:
=
s
:
x
$
:
=
whatever
;
y
$
:
=
whatever
;
endfor
;
2442
else
:
2443
save
x
,
y
;
2444
fi
2445
enddef
;
2446 2447
% so now we can say: clearxy ; as well as clearxy 1, 2, 3 ;
2448 2449
% show x0 ; z0 = (10,10) ;
2450
% show x0 ; x0 := whatever ; y0 := whatever ;
2451
% show x0 ; z0 = (20,20) ;
2452
% show x0 ; clearxy 0 ;
2453
% show x0 ; z0 = (30,30) ;
2454 2455
primarydef
p
smoothed
d
=
2456
(
p
llmoved
(
-
xpart
paired
(
d
)
,
0
)
--
p
lrmoved
(
-
xpart
paired
(
d
)
,
0
)
{
right
}
..
2457
p
lrmoved
(
0
,
-
ypart
paired
(
d
)
)
--
p
urmoved
(
0
,
-
ypart
paired
(
d
)
)
{
up
}
..
2458
p
urmoved
(
-
xpart
paired
(
d
)
,
0
)
--
p
ulmoved
(
-
xpart
paired
(
d
)
,
0
)
{
left
}
..
2459
p
ulmoved
(
0
,
-
ypart
paired
(
d
)
)
--
p
llmoved
(
0
,
-
ypart
paired
(
d
)
)
{
down
}
..
cycle
)
2460
enddef
;
2461 2462
primarydef
p
cornered
c
=
2463
(
(
point
0
of
p
)
shifted
(
c
*
(
unitvector
(
point
1
of
p
-
point
0
of
p
)
)
)
--
2464
for
i
=
1
upto
length
(
p
)
:
2465
(
point
i
-1
of
p
)
shifted
(
c
*
(
unitvector
(
point
i
of
p
-
point
i
-1
of
p
)
)
)
--
2466
(
point
i
of
p
)
shifted
(
c
*
(
unitvector
(
point
i
-1
of
p
-
point
i
of
p
)
)
)
..
2467
controls
point
i
of
p
..
2468
endfor
cycle
)
2469
enddef
;
2470 2471
% cmyk color support
2472 2473
% vardef cmyk(expr c,m,y,k) = % elsewhere
2474
% (1-c-k,1-m-k,1-y-k)
2475
% enddef ;
2476 2477
% handy
2478 2479
% vardef bbwidth (expr p) = % vardef width_of primary p =
2480
% if known p :
2481
% if path p or picture p :
2482
% xpart (lrcorner p - llcorner p)
2483
% else :
2484
% 0
2485
% fi
2486
% else :
2487
% 0
2488
% fi
2489
% enddef ;
2490 2491
vardef
bbwidth
primary
p
=
2492
if
unknown
p
:
2493
0
2494
elseif
path
p
or
picture
p
:
2495
xpart
(
lrcorner
p
-
llcorner
p
)
2496
else
:
2497
0
2498
fi
2499
enddef
;
2500 2501
% vardef bbheight (expr p) = % vardef heigth_of primary p =
2502
% if known p :
2503
% if path p or picture p :
2504
% ypart (urcorner p - lrcorner p)
2505
% else :
2506
% 0
2507
% fi
2508
% else :
2509
% 0
2510
% fi
2511
% enddef ;
2512 2513
vardef
bbheight
primary
p
=
2514
if
unknown
p
:
2515
0
2516
elseif
path
p
or
picture
p
:
2517
ypart
(
urcorner
p
-
lrcorner
p
)
2518
else
:
2519
0
2520
fi
2521
enddef
;
2522 2523
color
nocolor
;
numeric
noline
;
% both unknown signals
2524 2525
def
dowithpath
(
expr
p
,
lw
,
lc
,
bc
)
=
2526
if
known
p
:
2527
if
known
bc
:
2528
fill
p
withcolor
bc
;
2529
fi
;
2530
if
known
lw
and
known
lc
:
2531
draw
p
withpen
pencircle
scaled
lw
withcolor
lc
;
2532
elseif
known
lw
:
2533
draw
p
withpen
pencircle
scaled
lw
;
2534
elseif
known
lc
:
2535
draw
p
withcolor
lc
;
2536
fi
;
2537
fi
;
2538
enddef
;
2539 2540
% result from metafont discussion list (denisr/boguslawj)
2541 2542
def
[
[
=
[
[
enddef
;
def
[
[
[
=
[
[
[
enddef
;
2543
def
]
]
=
]
]
enddef
;
def
]
]
]
=
]
]
]
enddef
;
2544 2545
let
=
=
=
=
;
2546 2547
% added
2548 2549
picture
oddly
;
% evenly already defined
2550 2551
evenly
:
=
dashpattern
(
on
3
off
3
)
;
2552
oddly
:
=
dashpattern
(
off
3
on
3
)
;
2553 2554
% not perfect, but useful since it removes redundant points.
2555 2556
vardef
mfun_straightened
(
expr
sign
,
p
)
=
2557
save
_p_
,
_q_
;
path
_p_
,
_q_
;
2558
_p_
:
=
p
;
2559
forever
:
2560
_q_
:
=
mfun_do_straightened
(
sign
,
_p_
)
;
2561
exitif
length
(
_p_
)
=
length
(
_q_
)
;
2562
_p_
:
=
_q_
;
2563
endfor
;
2564
_q_
2565
enddef
;
2566 2567
% vardef mfun_straightened(expr sign, p) =
2568
% save lp, lq, q ; path q ; q := p ;
2569
% lp := length(p) ;
2570
% forever :
2571
% q := mfun_do_straightened(sign,q) ;
2572
% lq := length(q) ;
2573
% exitif lp = lq ;
2574
% lp := lq ;
2575
% endfor ;
2576
% q
2577
% enddef ;
2578 2579
% can be optimized:
2580 2581
vardef
mfun_do_straightened
(
expr
sign
,
p
)
=
2582
if
length
(
p
)
>
2
:
% was 1, but straight lines are ok
2583
save
pp
;
path
pp
;
2584
pp
:
=
point
0
of
p
;
2585
for
i
=
1
upto
length
(
p
)
-1
:
2586
if
round
(
point
i
of
p
)
<
>
round
(
point
length
(
pp
)
of
pp
)
:
2587
pp
:
=
pp
--
point
i
of
p
;
2588
fi
;
2589
endfor
;
2590
save
n
,
ok
;
numeric
n
;
boolean
ok
;
2591
n
:
=
length
(
pp
)
;
ok
:
=
false
;
2592
if
n
>
2
:
2593
for
i
=
0
upto
n
:
2594
if
unitvector
(
round
(
point
i
of
pp
-
point
if
i
=
0
:
n
else
:
i
-1
fi
of
pp
)
)
<
>
2595
sign
*
unitvector
(
round
(
point
if
i
=
n
:
0
else
:
i
+1
fi
of
pp
-
point
i
of
pp
)
)
:
2596
if
ok
:
2597
--
2598
else
:
2599
ok
:
=
true
;
2600
fi
point
i
of
pp
2601
fi
2602
endfor
2603
if
ok
and
(
cycle
p
)
:
2604
--
cycle
2605
fi
2606
else
:
2607
pp
2608
fi
2609
else
:
2610
p
2611
fi
2612
enddef
;
2613 2614
vardef
simplified
expr
p
=
(
2615
reverse
mfun_straightened
(
+1
,
mfun_straightened
(
+1
,
reverse
p
)
)
2616
)
enddef
;
2617 2618
vardef
unspiked
expr
p
=
(
2619
reverse
mfun_straightened
(
-1
,
mfun_straightened
(
-1
,
reverse
p
)
)
2620
)
enddef
;
2621 2622
% path p ;
2623
% p := (2cm,1cm) -- (2cm,1cm) -- (2cm,1cm) -- (3cm,1cm) --
2624
% (4cm,1cm) -- (4cm,2cm) -- (4cm,2.5cm) -- (4cm,3cm) --
2625
% (3cm,3cm) -- (2cm,3cm) -- (1cm,3cm) -- (-1cm,3cm) --
2626
% .5[(-1cm,3cm),(1cm,1cm)] -- (1cm,1cm) -- cycle ;
2627
%
2628
% p := unitcircle scaled 4cm ;
2629
%
2630
% drawpath p ; drawpoints p ; drawpointlabels p ;
2631
% p := p shifted (4cm,0) ; p := straightened p ;
2632
% drawpath p ; drawpoints p ; drawpointlabels p ;
2633
% p := p shifted (4cm,0) ; p := straightened p ;
2634
% drawpath p ; drawpoints p ; drawpointlabels p ;
2635 2636
% new
2637 2638
path
originpath
;
originpath
:
=
origin
--
cycle
;
2639 2640
vardef
unitvector
primary
z
=
2641
if
abs
z
=
abs
origin
:
z
else
:
z
/
abs
z
fi
% hm, abs origin is just origin
2642
enddef
;
2643 2644
% also new
2645 2646
% vardef anchored@#(expr p, z) = % maybe use the textext variant
2647
% p shifted (z + (labxf@#*lrcorner p + labyf@#*ulcorner p + (1-labxf@#-labyf@#)*llcorner p))
2648
% enddef ;
2649 2650
% epsed(1.2345)
2651 2652
vardef
epsed
(
expr
e
)
=
2653
e
if
e
>
0
:
+
eps
elseif
e
<
0
:
-
eps
fi
2654
enddef
;
2655 2656
% handy
2657 2658
def
withgray
primary
g
=
2659
withcolor
g
2660
enddef
;
2661 2662
% for metafun
2663 2664
if
unknown
darkred
:
color
darkred
;
darkred
:
=
.625
(
1
,
0
,
0
)
fi
;
2665
if
unknown
darkgreen
:
color
darkgreen
;
darkgreen
:
=
.625
(
0
,
1
,
0
)
fi
;
2666
if
unknown
darkblue
:
color
darkblue
;
darkblue
:
=
.625
(
0
,
0
,
1
)
fi
;
2667
if
unknown
darkcyan
:
color
darkcyan
;
darkcyan
:
=
.625
(
0
,
1
,
1
)
fi
;
2668
if
unknown
darkmagenta
:
color
darkmagenta
;
darkmagenta
:
=
.625
(
1
,
0
,
1
)
fi
;
2669
if
unknown
darkyellow
:
color
darkyellow
;
darkyellow
:
=
.625
(
1
,
1
,
0
)
fi
;
2670
if
unknown
darkgray
:
color
darkgray
;
darkgray
:
=
.625
(
1
,
1
,
1
)
fi
;
2671
if
unknown
lightgray
:
color
lightgray
;
lightgray
:
=
.850
(
1
,
1
,
1
)
fi
;
2672 2673
% an improved plain mp macro
2674 2675
vardef
center
primary
p
=
2676
if
pair
p
:
2677
p
2678
else
:
2679
.5
[
llcorner
p
,
urcorner
p
]
2680
fi
2681
enddef
;
2682 2683
% new, yet undocumented
2684 2685
vardef
rangepath
(
expr
p
,
d
,
a
)
=
2686
if
length
p
>
0
:
2687
(
d
*
unitvector
(
direction
0
of
p
)
rotated
a
)
shifted
point
0
of
p
2688
--
p
--
2689
(
d
*
unitvector
(
direction
length
(
p
)
of
p
)
rotated
a
)
shifted
point
length
(
p
)
of
p
2690
else
:
2691
p
2692
fi
2693
enddef
;
2694 2695
% under construction
2696 2697
vardef
straightpath
(
expr
a
,
b
,
method
)
=
2698
if
(
method
<
1
)
or
(
method
>
6
)
:
2699
(
a
-
-
b
)
2700
elseif
method
=
1
:
2701
(
a
--
2702
if
xpart
a
>
xpart
b
:
2703
if
ypart
a
>
ypart
b
:
2704
(
xpart
b
,
ypart
a
)
--
2705
elseif
ypart
a
<
ypart
b
:
2706
(
xpart
a
,
ypart
b
)
--
2707
fi
2708
elseif
xpart
a
<
xpart
b
:
2709
if
ypart
a
>
ypart
b
:
2710
(
xpart
a
,
ypart
b
)
--
2711
elseif
ypart
a
<
ypart
b
:
2712
(
xpart
b
,
ypart
a
)
--
2713
fi
2714
fi
2715
b
)
2716
elseif
method
=
3
:
2717
(
a
--
2718
if
xpart
a
>
xpart
b
:
2719
(
xpart
b
,
ypart
a
)
--
2720
elseif
xpart
a
<
xpart
b
:
2721
(
xpart
a
,
ypart
b
)
--
2722
fi
2723
b
)
2724
elseif
method
=
5
:
2725
(
a
--
2726
if
ypart
a
>
ypart
b
:
2727
(
xpart
b
,
ypart
a
)
--
2728
elseif
ypart
a
<
ypart
b
:
2729
(
xpart
a
,
ypart
b
)
--
2730
fi
2731
b
)
2732
else
:
2733
(
reverse
straightpath
(
b
,
a
,
method
-1
)
)
2734
fi
2735
enddef
;
2736 2737
% handy for myself
2738 2739
def
addbackground
text
t
=
2740
begingroup
;
2741
save
p
,
b
;
picture
p
;
path
b
;
2742
b
:
=
boundingbox
currentpicture
;
2743
p
:
=
currentpicture
;
currentpicture
:
=
nullpicture
;
2744
fill
b
t
;
2745
setbounds
currentpicture
to
b
;
2746
addto
currentpicture
also
p
;
2747
endgroup
;
2748
enddef
;
2749 2750
% makes a (line) into an infinite one (handy for calculating
2751
% intersection points
2752 2753
vardef
infinite
expr
p
=
2754
(
-
infinity
*
unitvector
(
direction
0
of
p
)
2755
shifted
point
0
of
p
2756
--
p
--
2757
+
infinity
*
unitvector
(
direction
length
(
p
)
of
p
)
2758
shifted
point
length
(
p
)
of
p
)
2759
enddef
;
2760 2761
% obscure macros: create var from string and replace - and :
2762
% (needed for process color id's) .. will go away
2763 2764
string
mfun_clean_ascii
[
]
;
2765 2766
def
register_dirty_chars
(
expr
str
)
=
2767
for
i
=
0
upto
length
(
str
)
-1
:
2768
mfun_clean_ascii
[
ASCII
substring
(
i
,
i
+1
)
of
str
]
:
=
"
_
"
;
2769
endfor
;
2770
enddef
;
2771 2772
register_dirty_chars
(
"
+-*/:;.,
"
)
;
2773 2774
vardef
cleanstring
(
expr
s
)
=
2775
save
ss
;
string
ss
,
si
;
ss
=
"
"
;
save
i
;
2776
for
i
=
0
upto
length
(
s
)
:
2777
si
:
=
substring
(
i
,
i
+1
)
of
s
;
2778
ss
:
=
ss
&
if
known
mfun_clean_ascii
[
ASCII
si
]
:
mfun_clean_ascii
[
ASCII
si
]
else
:
si
fi
;
2779
endfor
;
2780
ss
2781
enddef
;
2782 2783
vardef
asciistring
(
expr
s
)
=
2784
save
ss
;
string
ss
,
si
;
ss
=
"
"
;
save
i
;
2785
for
i
=
0
upto
length
(
s
)
:
2786
si
:
=
substring
(
i
,
i
+1
)
of
s
;
2787
if
(
ASCII
si
>
=
ASCII
"
0
"
)
and
(
ASCII
si
<
=
ASCII
"
9
"
)
:
2788
ss
:
=
ss
&
char
(
scantokens
(
si
)
+
ASCII
"
A
"
)
;
2789
else
:
2790
ss
:
=
ss
&
si
;
2791
fi
;
2792
endfor
;
2793
ss
2794
enddef
;
2795 2796
vardef
setunstringed
(
expr
s
,
v
)
=
2797
scantokens
(
cleanstring
(
s
)
)
:
=
v
;
2798
enddef
;
2799 2800
vardef
getunstringed
(
expr
s
)
=
2801
scantokens
(
cleanstring
(
s
)
)
2802
enddef
;
2803 2804
vardef
unstringed
(
expr
s
)
=
2805
expandafter
known
scantokens
(
cleanstring
(
s
)
)
2806
enddef
;
2807 2808
% for david arnold:
2809 2810
% showgrid(-5,10,1cm,-10,10,1cm);
2811 2812
def
showgrid
(
expr
MinX
,
MaxX
,
DeltaX
,
MinY
,
MaxY
,
DeltaY
)
=
% will move
2813
begingroup
2814
save
size
;
numeric
size
;
size
:
=
2
pt
;
2815
for
x
=
MinX
upto
MaxX
:
2816
for
y
=
MinY
upto
MaxY
:
2817
draw
(
x
*
DeltaX
,
y
*
DeltaY
)
withpen
pencircle
scaled
2818
if
(
x
mod
5
=
0
)
and
(
y
mod
5
=
0
)
:
2819
1.5
size
withcolor
.50
white
2820
else
:
2821
size
withcolor
.75
white
2822
fi
;
2823
endfor
;
2824
endfor
;
2825
for
x
=
MinX
upto
MaxX
:
2826
label
.
bot
(
textext
(
"
\infofont
"
&
decimal
x
)
,
(
x
*
DeltaX
,
-
size
)
)
;
2827
endfor
;
2828
for
y
=
MinY
upto
MaxY
:
2829
label
.
lft
(
textext
(
"
\infofont
"
&
decimal
y
)
,
(
-
size
,
y
*
DeltaY
)
)
;
2830
endfor
;
2831
endgroup
2832
enddef
;
2833 2834
% new, handy for:
2835
%
2836
% \startuseMPgraphic{map}{n}
2837
% \includeMPgraphic{map:germany} ;
2838
% c_phantom (\MPvar{n}<1) (
2839
% fill map_germany withcolor \MPcolor{lightgray} ;
2840
% draw map_germany withpen pencircle scaled 1pt withcolor \MPcolor{darkgray} ;
2841
% ) ;
2842
% \includeMPgraphic{map:austria} ;
2843
% c_phantom (\MPvar{n}<2) (
2844
% fill map_austria withcolor \MPcolor{lightgray} ;
2845
% draw map_austria withpen pencircle scaled 1pt withcolor \MPcolor{darkgray} ;
2846
% ) ;
2847
% c_phantom (\MPvar{n}<3) (
2848
% \includeMPgraphic{map:swiss} ;
2849
% fill map_swiss withcolor \MPcolor{lightgray} ;
2850
% draw map_swiss withpen pencircle scaled 1pt withcolor \MPcolor{darkgray} ;
2851
% ) ;
2852
% c_phantom (\MPvar{n}<4) (
2853
% \includeMPgraphic{map:luxembourg} ;
2854
% fill map_luxembourg withcolor \MPcolor{lightgray} ;
2855
% draw map_luxembourg withpen pencircle scaled 1pt withcolor \MPcolor{darkgray} ;
2856
% ) ;
2857
% \stopuseMPgraphic
2858
%
2859
% \useMPgraphic{map}{n=3}
2860 2861
vardef
phantom
(
text
t
)
=
% to be checked
2862
picture
_p_
;
2863
_p_
:
=
image
(
t
)
;
2864
addto
_p_
also
currentpicture
;
2865
setbounds
currentpicture
to
boundingbox
_p_
;
2866
enddef
;
2867 2868
vardef
c_phantom
(
expr
b
)
(
text
t
)
=
2869
if
b
:
2870
picture
_p_
;
2871
_p_
:
=
image
(
t
)
;
2872
addto
_p_
also
currentpicture
;
2873
setbounds
currentpicture
to
boundingbox
_p_
;
2874
else
:
2875
t
;
2876
fi
;
2877
enddef
;
2878 2879
%D Handy:
2880 2881
def
break
=
2882
exitif
true
;
% fi
2883
enddef
;
2884 2885
%D New too:
2886 2887
primarydef
p
xstretched
w
=
(
2888
p
if
(
bbwidth
(
p
)
>
0
)
and
(
w
>
0
)
:
xscaled
(
w
/
bbwidth
(
p
)
)
fi
2889
)
enddef
;
2890 2891
primarydef
p
ystretched
h
=
(
2892
p
if
(
bbheight
(
p
)
>
0
)
and
(
h
>
0
)
:
yscaled
(
h
/
bbheight
(
p
)
)
fi
2893
)
enddef
;
2894 2895
%D Newer:
2896 2897
vardef
area
expr
p
=
2898
% we could calculate the boundingbox once
2899
(
xpart
llcorner
boundingbox
p
,
0
)
--
p
--
2900
(
xpart
lrcorner
boundingbox
p
,
0
)
--
cycle
2901
enddef
;
2902 2903
vardef
basiccolors
[
]
=
2904
if
@
=
0
:
2905
white
2906
else
:
2907
save
n
;
n
:
=
@
mod
7
;
2908
if
n
=
1
:
red
2909
elseif
n
=
2
:
green
2910
elseif
n
=
3
:
blue
2911
elseif
n
=
4
:
cyan
2912
elseif
n
=
5
:
magenta
2913
elseif
n
=
6
:
yellow
2914
else
:
black
2915
fi
2916
fi
2917
enddef
;
2918 2919 2920
% vardef somecolor = (1,1,0,0) enddef ;
2921 2922
% fill OverlayBox withcolor (rcomponent somecolor,gcomponent somecolor,bcomponent somecolor) ;
2923
% fill OverlayBox withcolor (ccomponent somecolor,mcomponent somecolor,ycomponent somecolor,bcomponent somecolor) ;
2924 2925
% This could be standard mplib 2 behaviour:
2926 2927
% vardef rcomponent expr p = if rgbcolor p : redpart elseif cmykcolor p : 1 - cyanpart fi p enddef ;
2928 2929
vardef
rcomponent
expr
p
=
if
rgbcolor
p
:
redpart
p
elseif
cmykcolor
p
:
1
-
cyanpart
p
else
:
p
fi
enddef
;
2930
vardef
gcomponent
expr
p
=
if
rgbcolor
p
:
greenpart
p
elseif
cmykcolor
p
:
1
-
magentapart
p
else
:
p
fi
enddef
;
2931
vardef
bcomponent
expr
p
=
if
rgbcolor
p
:
bluepart
p
elseif
cmykcolor
p
:
1
-
yellowpart
p
else
:
p
fi
enddef
;
2932
vardef
ccomponent
expr
p
=
if
cmykcolor
p
:
cyanpart
p
elseif
rgbcolor
p
:
1
-
redpart
p
else
:
p
fi
enddef
;
2933
vardef
mcomponent
expr
p
=
if
cmykcolor
p
:
magentapart
p
elseif
rgbcolor
p
:
1
-
greenpart
p
else
:
p
fi
enddef
;
2934
vardef
ycomponent
expr
p
=
if
cmykcolor
p
:
yellowpart
p
elseif
rgbcolor
p
:
1
-
bluepart
p
else
:
p
fi
enddef
;
2935
vardef
kcomponent
expr
p
=
if
cmykcolor
p
:
blackpart
p
elseif
rgbcolor
p
:
0
else
:
p
fi
enddef
;
2936 2937
% draw image (...) ... ; % prescripts prepended to first, postscripts appended to last
2938
% draw decorated (...) ... ; % prescripts prepended to each, postscripts appended to each
2939
% draw redecorated (...) ... ; % prescripts assigned to each, postscripts assigned to each
2940
% draw undecorated (...) ... ; % following properties are ignored, existing properties are kept
2941
%
2942
% draw decorated (
2943
% draw fullcircle scaled 20cm withpen pencircle scaled 20mm withcolor red withtransparency (1,.40) ;
2944
% draw fullcircle scaled 15cm withpen pencircle scaled 15mm withcolor green withtransparency (1,.30) ;
2945
% draw fullcircle scaled 10cm withpen pencircle scaled 10mm withcolor blue withtransparency (1,.20) ;
2946
% )
2947
% withcolor blue
2948
% withtransparency (1,.125) % selectively applied
2949
% withpen pencircle scaled 10mm
2950
% ;
2951 2952
% vardef image (text imagedata) = % already defined
2953
% save currentpicture ;
2954
% picture currentpicture ;
2955
% currentpicture := nullpicture ;
2956
% imagedata ;
2957
% currentpicture
2958
% enddef ;
2959 2960
vardef
undecorated
(
text
imagedata
)
text
decoration
=
2961
save
currentpicture
;
2962
picture
currentpicture
;
2963
currentpicture
:
=
nullpicture
;
2964
imagedata
;
2965
currentpicture
2966
enddef
;
2967 2968
% if metapostversion < 1.770 :
2969
%
2970
% vardef decorated (text imagedata) text decoration =
2971
% save mfun_decorated_path, currentpicture ;
2972
% picture mfun_decorated_path, currentpicture ;
2973
% currentpicture := nullpicture ;
2974
% imagedata ;
2975
% mfun_decorated_path := currentpicture ;
2976
% currentpicture := nullpicture ;
2977
% for i within mfun_decorated_path :
2978
% addto currentpicture
2979
% if stroked i :
2980
% doublepath pathpart i
2981
% dashed dashpart i
2982
% withpen penpart i
2983
% withcolor colorpart i
2984
% decoration
2985
% elseif filled i :
2986
% contour pathpart i
2987
% withpen penpart i
2988
% withcolor colorpart i
2989
% decoration
2990
% elseif textual i :
2991
% also i
2992
% withcolor colorpart i
2993
% decoration
2994
% else :
2995
% also i
2996
% fi
2997
% ;
2998
% endfor ;
2999
% currentpicture
3000
% enddef ;
3001
%
3002
% else:
3003 3004
vardef
decorated
(
text
imagedata
)
text
decoration
=
3005
save
mfun_decorated_path
,
currentpicture
;
3006
picture
mfun_decorated_path
,
currentpicture
;
3007
currentpicture
:
=
nullpicture
;
3008
imagedata
;
3009
mfun_decorated_path
:
=
currentpicture
;
3010
currentpicture
:
=
nullpicture
;
3011
for
i
within
mfun_decorated_path
:
3012
addto
currentpicture
3013
if
stroked
i
:
3014
doublepath
pathpart
i
3015
dashed
dashpart
i
3016
withpen
penpart
i
3017
withcolor
colorpart
i
3018
withprescript
prescriptpart
i
3019
withpostscript
postscriptpart
i
3020
decoration
3021
elseif
filled
i
:
3022
contour
pathpart
i
3023
withpen
penpart
i
3024
withcolor
colorpart
i
3025
withprescript
prescriptpart
i
3026
withpostscript
postscriptpart
i
3027
decoration
3028
elseif
textual
i
:
3029
also
i
3030
withcolor
colorpart
i
3031
withprescript
prescriptpart
i
3032
withpostscript
postscriptpart
i
3033
decoration
3034
else
:
3035
also
i
3036
fi
3037
;
3038
endfor
;
3039
currentpicture
3040
enddef
;
3041 3042
% fi ;
3043 3044
vardef
redecorated
(
text
imagedata
)
text
decoration
=
3045
save
mfun_decorated_path
,
currentpicture
;
3046
picture
mfun_decorated_path
,
currentpicture
;
3047
currentpicture
:
=
nullpicture
;
3048
imagedata
;
3049
mfun_decorated_path
:
=
currentpicture
;
3050
currentpicture
:
=
nullpicture
;
3051
for
i
within
mfun_decorated_path
:
3052
addto
currentpicture
3053
if
stroked
i
:
3054
doublepath
pathpart
i
3055
dashed
dashpart
i
3056
withpen
penpart
i
3057
decoration
3058
elseif
filled
i
:
3059
contour
pathpart
i
3060
withpen
penpart
i
3061
decoration
3062
elseif
textual
i
:
3063
also
i
3064
decoration
3065
else
:
3066
also
i
3067
fi
3068
;
3069
endfor
;
3070
currentpicture
3071
enddef
;
3072 3073
% path mfun_bleed_box ;
3074 3075
% primarydef p bleeded d =
3076
% image (
3077
% mfun_bleed_box := boundingbox p ;
3078
% if pair d :
3079
% draw p xysized (bbwidth(p)+2*xpart d,bbheight(p)+2*ypart d) shifted -d ;
3080
% else :
3081
% draw p xysized (bbwidth(p)+2d,bbheight(p)+2d) shifted (-d,-d) ;
3082
% fi ;
3083
% setbounds currentpicture to mfun_bleed_box ;
3084
% )
3085
% enddef ;
3086 3087
vardef
mfun_snapped
(
expr
p
,
s
)
=
3088
if
p
<
0
:
-
(
-
else
:
(
fi
p
div
s
)
*
s
% the less tokens the better
3089
enddef
;
3090 3091
vardef
mfun_applied
(
expr
p
,
s
)
(
suffix
a
)
=
3092
if
path
p
:
3093
if
pair
s
:
3094
for
i
=
0
upto
length
(
p
)
-1
:
3095
(
a
(
xpart
point
i
of
p
,
xpart
s
)
,
a
(
ypart
point
i
of
p
,
ypart
s
)
)
--
3096
endfor
3097
if
cycle
p
:
3098
cycle
3099
else
:
3100
(
a
(
xpart
point
length
(
p
)
of
p
,
xpart
s
)
,
a
(
ypart
point
length
(
p
)
of
p
,
ypart
s
)
)
3101
fi
3102
else
:
3103
for
i
=
0
upto
length
(
p
)
-1
:
3104
(
a
(
xpart
point
i
of
p
,
s
)
,
a
(
ypart
point
i
of
p
,
s
)
)
--
3105
endfor
3106
if
cycle
p
:
3107
cycle
3108
else
:
3109
(
a
(
xpart
point
length
(
p
)
of
p
,
s
)
,
a
(
ypart
point
length
(
p
)
of
p
,
s
)
)
3110
fi
3111
fi
3112
elseif
pair
p
:
3113
if
pair
s
:
3114
(
a
(
xpart
p
,
xpart
s
)
,
a
(
ypart
p
,
ypart
s
)
)
3115
else
:
3116
(
a
(
xpart
p
,
s
)
,
a
(
ypart
p
,
s
)
)
3117
fi
3118
elseif
cmykcolor
p
:
3119
(
a
(
cyanpart
p
,
s
)
,
a
(
magentapart
p
,
s
)
,
a
(
yellowpart
p
,
s
)
,
a
(
blackpart
p
,
s
)
)
3120
elseif
rgbcolor
p
:
3121
(
a
(
redpart
p
,
s
)
,
a
(
greenpart
p
,
s
)
,
a
(
bluepart
p
,
s
)
)
3122
elseif
graycolor
p
:
3123
a
(
p
,
s
)
3124
elseif
numeric
p
:
3125
a
(
p
,
s
)
3126
else
3127
p
3128
fi
3129
enddef
;
3130 3131
primarydef
p
snapped
s
=
3132
mfun_applied
(
p
,
s
)
(
mfun_snapped
)
% so we can play with variants
3133
enddef
;
3134 3135
%D New helpers:
3136 3137
newinternal
charscale
;
charscale
:
=
1
;
% persistent so one needs to 'reset' it to 0 or 1
3138 3139
def
beginglyph
(
expr
unicode
,
width
,
height
,
depth
)
=
3140
beginfig
(
unicode
)
;
% the number is irrelevant
3141
charcode
:
=
unicode
;
3142
charwd
:
=
width
;
3143
charht
:
=
height
;
3144
chardp
:
=
depth
;
3145
% charscale := 1 ; % can be set for a whole font, so no reset here
3146
enddef
;
3147 3148
def
endglyph
=
3149
setbounds
currentpicture
to
(
boundingbox
unitsquare
xscaled
charwd
yscaled
(
charht
+
chardp
)
shifted
(
0
,
-
chardp
)
)
;
3150
if
known
charscale
:
if
(
charscale
>
0
)
and
(
charscale
<
>
1
)
:
3151
currentpicture
:
=
currentpicture
scaled
charscale
;
3152
fi
;
fi
;
3153
endfig
;
3154
enddef
;
3155 3156
def
beginfont
(
expr
name
)
=
3157
begingroup
;
3158
passvariable
(
"
fontname
"
,
name
)
;
3159
enddef
;
3160 3161
def
endfont
=
3162
endgroup
;
3163
enddef
;
3164 3165
%D Dimensions have never been an issue as traditional MP can't make that large
3166
%D pictures, but with double mode we need a catch:
3167 3168
newinternal
maxdimensions
;
maxdimensions
:
=
14000
;
3169 3170
def
mfun_apply_max_dimensions
=
% not a generic helper, we want to protect this one
3171
if
bbwidth
currentpicture
>
maxdimensions
:
3172
currentpicture
:
=
currentpicture
if
bbheight
currentpicture
>
bbwidth
currentpicture
:
ysized
else
:
xsized
fi
maxdimensions
;
3173
elseif
bbheight
currentpicture
>
maxdimensions
:
3174
currentpicture
:
=
currentpicture
ysized
maxdimensions
;
3175
fi
;
3176
enddef
;
3177 3178
extra_endfig
:
=
extra_endfig
&
"
mfun_apply_max_dimensions ;
"
;
3179 3180
%D Bonus shapes (need along):
3181 3182
path
unittriangle
,
fulltriangle
;
% not really units but circle based
3183 3184
unittriangle
:
=
point
0
along
unitcircle
3185
--
point
1
/
3
along
unitcircle
3186
--
point
2
/
3
along
unitcircle
3187
--
cycle
;
3188
fulltriangle
:
=
point
0
along
fullcircle
3189
--
point
1
/
3
along
fullcircle
3190
--
point
2
/
3
along
fullcircle
3191
--
cycle
;
3192 3193
%D Kind of special and undocumented. On Wikipedia one can find examples
3194
%D of quick sort routines. Here we have a variant that permits a
3195
%D method.
3196 3197
% vardef listsize(suffix list) =
3198
% numeric len ; len := 0 ;
3199
% forever :
3200
% exitif unknown list[len+1] ;
3201
% len := len + 1 ;
3202
% endfor ;
3203
% len
3204
% enddef ;
3205 3206
vardef
listsize
(
suffix
list
)
=
3207
numeric
len
;
len
:
=
1
;
3208
forever
:
3209
exitif
unknown
list
[
len
]
;
3210
len
:
=
len
+
1
;
3211
endfor
;
3212
len
if
unknown
list
[
0
]
:
-
1
fi
3213
enddef
;
3214 3215
vardef
listlast
(
suffix
list
)
=
3216
numeric
len
;
len
:
=
if
known
list
[
0
]
:
0
else
:
1
fi
;
3217
forever
:
3218
len
:
=
len
+
1
;
3219
exitif
unknown
list
[
len
]
;
3220
endfor
;
3221
len
-
1
3222
enddef
;
3223 3224
vardef
mfun_quick_sort
(
suffix
list
)
(
expr
_min_
,
_max_
)
(
text
what
)
=
3225
save
l
,
r
,
m
;
3226
numeric
l
;
l
:
=
_min_
;
3227
numeric
r
;
r
:
=
_max_
;
3228
numeric
m
;
m
:
=
floor
(
.5
[
_min_
,
_max_
]
)
;
3229
_mid_
:
=
what
list
[
m
]
;
3230
forever
:
3231
exitif
l
>
=
r
;
3232
forever
:
3233
exitif
l
>
_max_
;
3234
% exitif (what list[l]) >= (what list[m]) ;
3235
exitif
(
what
list
[
l
]
)
>
=
_mid_
;
3236
l
:
=
l
+
1
;
3237
endfor
;
3238
forever
:
3239
exitif
r
<
_min_
;
3240
% exitif (what list[m]) >= (what list[r]) ;
3241
exitif
_mid_
>
=
(
what
list
[
r
]
)
;
3242
r
:
=
r
-
1
;
3243
endfor
;
3244
if
l
<
=
r
:
3245
temp
:
=
list
[
l
]
;
3246
list
[
l
]
:
=
list
[
r
]
;
3247
list
[
r
]
:
=
temp
;
3248
l
:
=
l
+
1
;
3249
r
:
=
r
-
1
;
3250
fi
;
3251
endfor
;
3252
if
_min_
<
r
:
3253
mfun_quick_sort
(
list
)
(
_min_
,
r
)
(
what
)
;
3254
fi
;
3255
if
l
<
_max_
:
3256
mfun_quick_sort
(
list
)
(
l
,
_max_
)
(
what
)
;
3257
fi
;
3258
enddef
;
3259 3260
vardef
sortlist
(
suffix
list
)
(
text
what
)
=
3261
save
_max_
;
numeric
_max_
;
3262
save
_mid_
;
numeric
_mid_
;
3263
save
temp
;
3264
% _max_ := listsize(list) ;
3265
_max_
:
=
listlast
(
list
)
;
3266
if
pair
list
[
_max_
]
:
3267
pair
temp
;
3268
else
:
3269
numeric
temp
;
3270
fi
;
3271
if
pair
what
list
[
_max_
]
:
3272
pair
_mid_
;
3273
else
:
3274
numeric
_mid_
;
3275
fi
;
3276
if
_max_
>
1
:
3277
% mfun_quick_sort(list)(1,_max_)(what) ;
3278
mfun_quick_sort
(
list
)
(
if
known
list
[
0
]
:
0
else
:
1
fi
,
_max_
)
(
what
)
;
3279
fi
;
3280
enddef
;
3281 3282
vardef
uniquelist
(
suffix
list
)
=
3283
% this one will be defined later
3284
enddef
;
3285 3286
vardef
copylist
(
suffix
list
,
target
)
=
3287
save
i
;
i
:
=
1
;
3288
forever
:
3289
exitif
unknown
list
[
i
]
;
3290
target
[
i
]
:
=
list
[
i
]
;
3291
i
:
=
i
+
1
;
3292
endfor
;
3293
enddef
;
3294 3295
vardef
listtolines
(
suffix
list
)
=
3296
list
[
1
]
for
i
=
2
upto
listsize
(
list
)
:
--
list
[
i
]
endfor
3297
enddef
;
3298 3299
vardef
listtocurves
(
suffix
list
)
=
3300
list
[
1
]
for
i
=
2
upto
listsize
(
list
)
:
..
list
[
i
]
endfor
3301
enddef
;
3302 3303
%D The sorter is used in:
3304 3305
% not yet ok
3306 3307
vardef
shapedlist
(
suffix
p
)
=
% takes a list of paths
3308
save
l
;
pair
l
[
]
;
3309
save
r
;
pair
r
[
]
;
3310
save
i
;
i
:
=
1
;
3311
save
n
;
n
:
=
0
;
3312
forever
:
3313
exitif
unknown
p
[
i
]
;
3314
n
:
=
n
+
1
;
3315
l
[
n
]
:
=
ulcorner
p
[
i
]
;
3316
r
[
n
]
:
=
urcorner
p
[
i
]
;
3317
n
:
=
n
+
1
;
3318
l
[
n
]
:
=
llcorner
p
[
i
]
;
3319
r
[
n
]
:
=
lrcorner
p
[
i
]
;
3320
i
:
=
i
+
1
;
3321
endfor
;
3322
for
i
=
3
upto
n
:
3323
if
xpart
r
[
i
]
<
xpart
r
[
i
-1
]
:
3324
r
[
i
]
:
=
(
xpart
r
[
i
]
,
ypart
r
[
i
-1
]
)
;
3325
elseif
xpart
r
[
i
]
>
xpart
r
[
i
-1
]
:
3326
r
[
i
-1
]
:
=
(
xpart
r
[
i
-1
]
,
ypart
r
[
i
]
)
;
3327
fi
;
3328
if
xpart
l
[
i
]
<
xpart
l
[
i
-1
]
:
3329
l
[
i
-1
]
:
=
(
xpart
l
[
i
-1
]
,
ypart
l
[
i
]
)
;
3330
elseif
xpart
l
[
i
]
>
xpart
l
[
i
-1
]
:
3331
l
[
i
]
:
=
(
xpart
l
[
i
]
,
ypart
l
[
i
-1
]
)
;
3332
fi
;
3333
endfor
;
3334
if
n
>
0
:
3335
simplified
(
3336
for
i
=
1
upto
n
:
r
[
i
]
--
endfor
3337
for
i
=
n
downto
1
:
l
[
i
]
--
endfor
3338
cycle
3339
)
3340
else
:
3341
origin
--
cycle
3342
fi
3343
enddef
;
3344 3345
%D Dumping is fake anyway but let's keep this:
3346 3347
let
dump
=
relax
;
3348 3349
%D Loading modules can be done with:
3350 3351
def
loadmodule
expr
name
=
% no vardef
3352
% input can't be used directly in a macro
3353
if
(
unknown
scantokens
(
"
context_
"
&
name
)
)
and
(
unknown
scantokens
(
"
metafun_loaded_
"
&
name
)
)
:
3354
save
s
;
string
s
;
3355
% s := "mp-" & name & ".mpiv" ;
3356
% message("loading module",s) ;
3357
% s := "input " & s ;
3358
s
:
=
"
input
"
&
"
mp-
"
&
name
&
"
.mpiv
"
;
3359
expandafter
scantokens
expandafter
s
3360
fi
;
3361
enddef
;
3362 3363
def
loadfile
(
expr
filename
)
=
scantokens
(
"
input
"
&
filename
)
enddef
;
3364
def
loadimage
(
expr
filename
)
=
image
(
scantokens
(
"
input
"
&
filename
)
;
)
enddef
;
3365 3366
%D Handy for backgrounds:
3367 3368
def
drawpathwithpoints
expr
p
=
3369
do_drawpathwithpoints
(
p
)
3370
enddef
;
3371 3372
def
do_drawpathwithpoints
(
expr
p
)
text
t
=
3373
draw
p
t
;
3374
if
length
(
p
)
>
2
:
3375
begingroup
;
3376
save
_c_
;
path
_c_
;
3377
save
_p_
;
picture
_p_
;
3378
_p_
:
=
image
(
3379
_c_
:
=
if
cycle
p
:
fullsquare
else
:
fullcircle
fi
scaled
6
pt
;
3380
for
i
=
0
upto
length
(
p
)
if
cycle
p
:
-1
fi
:
3381
fill
_c_
shifted
point
i
of
p
withcolor
white
;
3382
draw
_c_
shifted
point
i
of
p
withcolor
white
/
2
withpen
pencircle
scaled
.5
pt
;
3383
if
(
i
=
0
)
and
cycle
p
:
3384
_c_
:
=
fullcircle
scaled
6
pt
;
3385
fi
;
3386
endfor
;
3387
for
i
=
0
upto
length
(
p
)
if
cycle
p
:
-1
fi
:
3388
draw
textext
(
"
\infofont
"
&
decimal
i
)
ysized
2
pt
shifted
point
i
of
p
;
3389
endfor
;
3390
)
;
3391
setbounds
_p_
to
boundingbox
p
;
3392
draw
_p_
;
3393
fi
;
3394
enddef
;
3395 3396
%D These new helpers are by Alan and are used in for instance the mp-node
3397
%D module.
3398 3399
newinternal
crossingdebug
;
crossingdebug
:
=
0
;
3400
newinternal
crossingscale
;
crossingscale
:
=
10
;
3401
newinternal
crossingnumbermax
;
crossingnumbermax
:
=
1000
;
3402 3403
% primary, secondary or tertiary? always hard to decide but primary makes sense
3404 3405
vardef
infotext
@#
(
expr
txt
,
ysize
)
=
3406
textext
@#
(
"
\infofont
"
&
if
numeric
txt
:
decimal
fi
txt
)
ysized
ysize
3407
enddef
;
3408 3409
primarydef
p
crossingunder
q
=
3410
begingroup
3411
save
pic
;
picture
pic
;
pic
:
=
nullpicture
;
3412
if
picture
p
:
3413
for
i
within
p
:
3414
if
stroked
i
:
3415
addto
pic
also
image
(
draw
pathpart
i
crossingunder
q
)
;
3416
fi
3417
endfor
3418
elseif
path
p
:
3419
save
n
,
t
,
a
,
b
,
c
,
r
,
bcuttings
,
hold
;
3420
numeric
n
,
t
[
]
,
hold
;
3421
path
a
,
b
,
c
,
r
,
bcuttings
,
hold
[
]
;
3422
c
:
=
makepath
(
currentpen
scaled
crossingscale
)
;
3423
r
:
=
if
picture
q
:
boundingbox
fi
q
;
3424
t
[
0
]
:
=
n
:
=
hold
:
=
0
;
3425
a
:
=
p
;
3426
% The cutbefore/cutafter using c below prevents endless loops!
3427
%forever : % find all intersections
3428
for
i
=
1
upto
crossingnumbermax
:
% safeguard
3429
clearxy
;
z
=
a
intersectiontimes
r
;
3430
if
x
<
0
:
3431
exitif
hold
<
1
;
3432
a
:
=
hold
[
hold
]
;
hold
:
=
hold
-
1
;
3433
clearxy
;
z
=
a
intersectiontimes
r
;
3434
fi
3435
(
t
[
incr
n
]
,
whatever
)
=
p
intersectiontimes
point
x
of
a
;
3436
if
x
=
0
:
3437
a
:
=
a
cutbefore
c
shifted
point
x
of
a
;
3438
elseif
x
=
length
a
:
3439
a
:
=
a
cutafter
c
shifted
point
x
of
a
;
3440
else
:
% before or after?
3441
b
:
=
subpath
(
0
,
x
)
of
a
cutafter
c
shifted
point
x
of
a
;
3442
bcuttings
:
=
cuttings
;
3443
a
:
=
subpath
(
x
,
length
a
)
of
a
cutbefore
c
shifted
point
x
of
a
;
3444
clearxy
;
z
=
a
intersectiontimes
r
;
3445
if
x
<
0
:
3446
a
:
=
b
;
3447
cuttings
:
=
bcuttings
;
3448
else
:
3449
if
length
bcuttings
>
0
:
3450
clearxy
;
z
=
b
intersectiontimes
r
;
3451
if
x
>
=
0
:
3452
hold
[
incr
hold
]
:
=
b
;
3453
fi
3454
fi
3455
fi
3456
fi
3457
if
length
cuttings
=
0
:
% a single point: nothing cut
3458
exitif
hold
<
1
;
3459
a
:
=
hold
[
hold
]
;
hold
:
=
hold
-
1
;
3460
fi
3461
if
i
=
crossingnumbermax
:
3462
message
(
"
crossingunder reached maximum
"
&
decimal
i
&
"
intersections.
"
)
;
3463
fi
3464
endfor
3465 3466
if
n
=
0
:
% No crossings, we return the PATH
3467
save
pic
;
path
pic
;
pic
:
=
p
;
3468
else
:
% n>0
3469
sortlist
(
t
,
)
;
3470
% we add too much, maybe a test is needed
3471
t
[
incr
n
]
=
length
p
if
cycle
p
:
+
t
[
1
]
fi
;
3472
% save tt[] ; numeric tt[] ; uniquelist(t,tt) ; t := tt ;
3473
% Now, n>1 !
3474
% t[0] is the first point of the path and t[n] is the last point
3475
% (or the first intersection beyond the length if cyclic)
3476
save
m
;
m
:
=
0
;
3477
for
i
=
if
cycle
p
:
2
else
:
1
fi
upto
n
:
3478
% skip the first segment if cyclic
3479
% as it gets repeated (fully) at the end.
3480
if
crossingdebug
>
0
:
3481
if
crossingdebug
=
1
:
3482
addto
pic
doublepath
c
shifted
point
t
[
i
]
of
p
3483
withpen
currentpen
withtransparency
(
1
,
.5
)
;
3484
elseif
crossingdebug
=
2
:
3485
addto
pic
also
3486
infotext
(
incr
m
,
crossingscale
/
5
)
3487
shifted
point
t
[
i
]
of
p
;
3488
fi
3489
fi
3490
a
:
=
subpath
(
t
[
i
-1
]
,
t
[
i
]
)
of
p
3491
if
i
>
1
:
3492
cutbefore
(
c
shifted
point
t
[
i
-1
]
of
p
)
3493
fi
3494
if
(
i
<
n
)
or
(
cycle
p
)
:
3495
cutafter
(
c
shifted
point
t
[
i
]
of
p
)
3496
fi
;
3497
if
(
not
picture
q
)
or
(
a
outsideof
q
)
:
3498
addto
pic
doublepath
a
withpen
currentpen
;
3499
fi
3500
endfor
3501
fi
3502
fi
3503
pic
3504
endgroup
3505
enddef
;
3506 3507
primarydef
p
insideof
q
=
3508
begingroup
3509
save
pth
,
pic
,
t
;
3510
path
pth
;
picture
pic
;
3511
pic
:
=
if
path
q
:
image
(
draw
q
;
)
else
:
q
fi
;
3512
pth
:
=
p
--
center
pic
;
3513
(
t
,
whatever
)
=
pth
intersectiontimes
boundingbox
pic
;
3514
t
<
0
3515
endgroup
3516
enddef
;
3517 3518
% primarydef p insideof q =
3519
% if (path q or picture q) :
3520
% if (path p or picture p) :
3521
% (xpart llcorner p > xpart llcorner q) and
3522
% (xpart urcorner p < xpart urcorner q) and
3523
% (ypart llcorner p > ypart llcorner q) and
3524
% (ypart urcorner p < ypart urcorner q)
3525
% elseif pair p :
3526
% (xpart p > xpart llcorner q) and
3527
% (xpart p < xpart urcorner q) and
3528
% (ypart p > ypart llcorner q) and
3529
% (ypart p < ypart urcorner q)
3530
% fi
3531
% elseif (numeric p and pair q) :
3532
% % range check
3533
% (p >= xpart q) and (p <= ypart q)
3534
% else : % maybe triplets and such
3535
% false
3536
% fi
3537
% enddef ;
3538 3539
primarydef
p
outsideof
q
=
3540
not
(
p
insideof
q
)
3541
enddef
;
3542 3543
%D Also handy:
3544 3545
vardef
circularpath
primary
n
=
3546
reverse
(
for
i
=
0
step
2
/
n
until
8
-2
/
n
+2
eps
:
point
i
of
fullcircle
..
endfor
cycle
)
rotated
90
3547
enddef
;
3548 3549
vardef
squarepath
primary
n
=
3550
for
i
=
0
step
1
/
n
until
4
-1
/
n
+
2
eps
:
point
i
of
fullsquare
--
endfor
cycle
3551
enddef
;
3552 3553
vardef
linearpath
primary
n
=
3554
origin
for
i
=
1
/
n
step
1
/
n
until
1
-1
/
n
+
2
eps
:
--
point
i
of
(
origin
--
(
1
,
0
)
)
endfor
3555
enddef
;
3556 3557
%D A nice tracing helper:
3558 3559
color
pensilcolor
;
pensilcolor
:
=
.5
red
;
3560
newinternal
pensilstep
;
pensilstep
:
=
1
/
25
;
3561 3562
vardef
pensilled
(
expr
p
,
q
)
=
3563
image
(
3564
draw
p
withcolor
pensilcolor
withpen
q
;
3565
for
i
=
0
step
pensilstep
until
length
(
p
)
+
eps
:
3566
draw
point
i
of
p
withcolor
white
withtransparency
(
1
,
.5
)
withpen
q
;
3567
endfor
;
3568
)
3569
enddef
;
3570 3571
%D Easy to forget but handy for manuals:
3572 3573
vardef
tolist
(
suffix
l
)
(
text
t
)
=
3574
save
n
;
n
:
=
1
;
3575
for
p
=
t
:
3576
if
numeric
p
:
3577
n
:
=
p
;
3578
dispose
(
l
[
n
]
)
3579
elseif
pair
p
:
3580
l
[
n
]
:
=
p
;
3581
n
:
=
n
+
1
;
3582
elseif
path
p
:
3583
for
i
=
0
step
1
until
length
(
p
)
:
3584
l
[
n
]
:
=
point
i
of
p
;
3585
n
:
=
n
+
1
;
3586
endfor
;
3587
else
:
3588
% ignore
3589
fi
;
3590
endfor
;
3591
forever
:
3592
exitif
unknown
l
[
n
]
;
3593
dispose
(
l
[
n
]
)
3594
n
:
=
n
+
1
;
3595
endfor
;
3596
enddef
;
3597 3598
vardef
topath
(
suffix
p
)
(
text
t
)
=
3599
save
i
;
i
:
=
if
known
p
[
1
]
:
2
;
p
[
1
]
elseif
known
p
[
0
]
:
1
;
p
[
0
]
else
:
0
;
origin
fi
3600
forever
:
3601
exitif
unknown
p
[
i
]
;
3602
t
p
[
i
]
3603
hide
(
i
:
=
i
+
1
)
3604
endfor
3605
enddef
;
3606 3607
vardef
tocycle
(
suffix
p
)
(
text
t
)
=
3608
topath
(
p
,
t
)
t
cycle
3609
enddef
;
3610 3611
% reimplemented to support paths and pictures
3612 3613
def
drawdot
expr
p
=
3614
if
pair
p
:
3615
addto
currentpicture
doublepath
p
3616
withpen
currentpen
_op_
3617
elseif
path
p
:
3618
draw
image
(
3619
for
i
=
0
upto
length
p
:
3620
addto
currentpicture
doublepath
point
i
of
p
3621
withpen
currentpen
_op_
;
3622
endfor
;
3623
)
3624
elseif
picture
p
:
3625
draw
image
(
3626
save
pp
;
path
pp
;
3627
for
i
within
p
:
3628
if
stroked
i
or
filled
i
:
3629
pp
:
=
pathpart
i
;
3630
for
j
=
0
upto
length
pp
:
3631
addto
currentpicture
doublepath
point
j
of
pp
3632
withpen
currentpen
_op_
;
3633
endfor
;
3634
fi
;
3635
endfor
;
3636
)
3637
fi
3638
enddef
;
3639 3640
% vardef textlength(text t) =
3641
% save n ; n := 0 ;
3642
% for i = t :
3643
% n := n + 1 ;
3644
% endfor;
3645
% n
3646
% enddef;
3647 3648
vardef
mfun_timestamp
=
3649
decimal
year
&
"
-
"
&
3650
decimal
month
&
"
-
"
&
3651
decimal
day
&
"
"
&
3652
if
(
(
time
div
60
)
<
10
)
:
"
0
"
&
fi
3653
decimal
(
time
div
60
)
&
"
:
"
&
3654
if
(
(
time
-
(
time
div
60
)
*
60
)
<
10
)
:
"
0
"
&
fi
3655
decimal
(
time
-
(
time
div
60
)
*
60
)
3656
enddef
;
3657 3658
vardef
totransform
(
expr
x
,
y
,
xx
,
xy
,
yx
,
yy
)
=
3659
save
t
;
transform
t
;
3660
xxpart
t
=
xx
;
yypart
t
=
yy
;
3661
xypart
t
=
xy
;
yxpart
t
=
yx
;
3662
xpart
t
=
x
;
ypart
t
=
y
;
3663
t
3664
enddef
;
3665 3666
vardef
bymatrix
(
expr
rx
,
sx
,
sy
,
ry
,
tx
,
ty
)
=
3667
save
t
;
transform
t
;
3668
xxpart
t
=
rx
;
yypart
t
=
ry
;
3669
xypart
t
=
sx
;
yxpart
t
=
sy
;
3670
xpart
t
=
tx
;
ypart
t
=
ty
;
3671
t
3672
enddef
;
3673 3674
let
xslanted
=
slanted
;
3675 3676
def
yslanted
primary
s
=
3677
transformed
3678
begingroup
3679
save
t
;
transform
t
;
3680
xxpart
t
=
1
;
yypart
t
=
1
;
3681
xypart
t
=
0
;
yxpart
t
=
s
;
3682
xpart
t
=
0
;
ypart
t
=
0
;
3683
t
3684
endgroup
3685
enddef
;
3686 3687
% By Bogluslaw Jackowski (public domain):
3688
%
3689
% draw hatched (fullcircle scaled 10cm) (45, 4, 1) withcolor "red" ;
3690 3691
newinternal
hatch_match
;
hatch_match
:
=
1
;
3692 3693
vardef
hatched
(
expr
o
)
primary
c
=
3694
save
a_
,
b_
,
d_
,
l_
,
i_
,
r_
,
za_
,
zb_
,
zc_
,
zd_
;
3695
path
b_
;
picture
r_
;
pair
za_
,
zb_
,
zc_
,
zd_
;
3696
r_
:
=
image
(
3697
a_
:
=
redpart
(
c
)
mod
180
;
3698
l_
:
=
greenpart
(
c
)
;
3699
d_
:
=
-
bluepart
(
c
)
;
3700
b_
:
=
o
rotated
-
a_
;
3701
b_
:
=
3702
if
a_
>
=
90
:
3703
(
lrcorner
b_
--
llcorner
b_
--
ulcorner
b_
--
urcorner
b_
--
cycle
)
3704
else
:
3705
(
llcorner
b_
--
lrcorner
b_
--
urcorner
b_
--
ulcorner
b_
--
cycle
)
3706
fi
3707
rotated
a_
;
3708
za_
:
=
point
0
of
b_
;
3709
zb_
:
=
point
1
of
b_
;
3710
zc_
:
=
point
2
of
b_
;
3711
zd_
:
=
point
3
of
b_
;
3712
if
hatch_match
>
0
:
3713
n_
:
=
round
(
length
(
zd_
-
za_
)
/
l_
)
;
3714
if
n_
<
2
:
3715
n_
:
=
2
;
3716
fi
;
3717
l_
:
=
length
(
zd_
-
za_
)
/
n_
;
3718
else
:
3719
n_
:
=
length
(
zd_
-
za_
)
/
l_
;
3720
fi
3721
save
currentpen
;
pen
currentpen
;
pickup
pencircle
scaled
d_
;
3722
% we use a single path instead:
3723
for
i_
:
=
if
hatch_match
>
0
:
1
else
:
0
fi
upto
ceiling
n_
-
1
:
3724
nodraw
(
i_
/
n_
)
[
zd_
,
za_
]
--
(
i_
/
n_
)
[
zc_
,
zb_
]
;
3725
endfor
3726
dodraw
origin
;
3727
)
;
3728
clip
r_
to
o
;
3729
r_
3730
enddef
;
3731