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