mp-base.mpxl /size: 24 Kb    last modification: 2021-10-28 13:50
1
% This is a reformatted copy of the plain.mp file. We use a copy
2
% because (1) we want to make sure that there are no unresolved
3
% dependencies, and (2) we may patch this file eventually.
4 5
% This file gives the macros for plain MetaPost It contains all the
6
% features of plain METAFONT except those specific to font-making.
7
% There are also a number of macros for labeling figures, etc.
8 9
% For practical reasons I have moved some new code here (and might
10
% remove some code as well). After all, there is no development in
11
% this format.
12 13
message
"
loading metafun for lmtx, including the plain 1.004 base definitions
"
;
14 15
if
known
metafun_loaded_base
:
endinput
;
fi
;
16 17
newinternal
boolean
metafun_loaded_base
;
metafun_loaded_base
:
=
true
;
immutable
metafun_loaded_base
;
18 19
delimiters
(
)
;
% this makes parentheses behave like parentheses
20 21
def
upto
=
step
1
until
enddef
;
22
def
downto
=
step
-1
until
enddef
;
23 24
def
exitunless
expr
c
=
25
exitif
not
c
26
enddef
;
27 28
let
relax
=
\
;
% ignore the word relax, as in TeX
29
let
\
\
=
\
;
% double relaxation is like single
30 31
def
[
[
=
[
[
enddef
;
32
def
]
]
=
]
]
enddef
;
33 34
def
--
=
{
curl
1
}
..
{
curl
1
}
enddef
;
35
def
---
=
..
tension
infinity
..
enddef
;
36
def
...
=
..
tension
atleast
1
..
enddef
;
37 38
def
gobble
primary
g
=
enddef
;
39
primarydef
g
gobbled
gg
=
enddef
;
40 41
def
hide
(
text
t
)
=
42
exitif
numeric
begingroup
t
;
endgroup
;
43
enddef
;
44 45
def
?
?
?
=
46
hide
(
47
interim
showstopping
:
=
1
;
48
showdependencies
49
)
50
enddef
;
51 52
def
stop
expr
s
=
53
message
s
;
54
gobble
readstring
55
enddef
;
56 57
% \\ and ??? can go
58 59
permanent
$
,
$
$
,
(
,
)
,
upto
,
downto
,
exitunless
,
relax
,
\
\
,
[
[
,
]
]
,
--
,
---
,
...
,
gobble
,
gobbled
,
stop
,
?
?
?
;
60
mutable
?
;
61 62
% These need to be adapted to a library approach:
63 64
warningcheck
:
=
1
;
65 66
def
interact
=
% sets up to make "show" commands stop
67
hide
(
68
interim
showstopping
:
=
1
;
69
interim
tracingonline
:
=
1
;
70
)
71
enddef
;
72 73
def
loggingall
=
% puts tracing info into the log
74
interim
tracingtitles
:
=
1
;
75
interim
tracingequations
:
=
1
;
76
interim
tracingcapsules
:
=
1
;
77
interim
tracingspecs
:
=
2
;
78
interim
tracingchoices
:
=
1
;
79
interim
tracingstats
:
=
1
;
80
interim
tracingmacros
:
=
1
;
81
interim
tracingcommands
:
=
3
;
82
interim
tracingrestores
:
=
1
;
83
enddef
;
84 85
def
tracingall
=
% turns on every form of tracing
86
interim
tracingonline
:
=
1
;
87
interim
showstopping
:
=
1
;
88
loggingall
;
89
enddef
;
90 91
def
tracingnone
=
% turns off every form of tracing
92
interim
tracingrestores
:
=
0
;
93
interim
tracingcommands
:
=
0
;
94
interim
tracingtitles
:
=
0
;
95
interim
tracingequations
:
=
0
;
96
interim
tracingcapsules
:
=
0
;
97
interim
tracingspecs
:
=
0
;
98
interim
tracingchoices
:
=
0
;
99
interim
tracingstats
:
=
0
;
100
interim
tracingmacros
:
=
0
;
101
enddef
;
102 103
permanent
interact
,
loggingall
,
tracingall
,
tracingnone
;
104 105
%% dash patterns
106 107
vardef
dashpattern
(
text
t
)
=
108
save
on
,
off
,
w
;
109
let
on
=
_on_
;
110
let
off
=
_off_
;
111
w
=
0
;
112
nullpicture
t
113
enddef
;
114 115
tertiarydef
p
_on_
d
=
116
begingroup
save
pic
;
117
picture
pic
;
118
pic
=
p
;
119
addto
pic
doublepath
(
w
,
w
)
..
(
w
+
d
,
w
)
;
120
w
:
=
w
+
d
;
121
pic
shifted
(
0
,
d
)
122
endgroup
123
enddef
;
124 125
tertiarydef
p
_off_
d
=
126
begingroup
w
:
=
w
+
d
;
127
p
shifted
(
0
,
d
)
128
endgroup
129
enddef
;
130 131
permanent
dashpattern
,
_on_
,
_off_
,
on
,
off
;
% on and off are not primitives
132 133
%% basic constants and mathematical macros
134 135
% numeric constants
136 137
newinternal
eps
,
epsilon
,
infinity
,
_
;
138 139
eps
:
=
.00049
;
% this is a pretty small positive number
140
epsilon
:
=
1
/
256
/
256
;
% but this is the smallest
141
infinity
:
=
4095.99998
;
% and this is the largest
142
_
:
=
-1
;
% internal constant to make macros unreadable but shorter
143 144
immutable
eps
,
epsilon
,
infinity
,
_
;
145 146
% linejoin and linecap types
147 148
newinternal
mitered
,
rounded
,
beveled
,
butt
,
squared
;
149 150
mitered
:
=
0
;
rounded
:
=
1
;
beveled
:
=
2
;
151
butt
:
=
0
;
rounded
:
=
1
;
squared
:
=
2
;
152 153
immutable
mitered
,
rounded
,
beveled
,
butt
,
squared
;
154 155
% pair constants
156 157
pair
right
,
left
,
up
,
down
,
origin
;
158 159
origin
=
(
0
,
0
)
;
160
up
=
-
down
=
(
0
,
1
)
;
161
right
=
-
left
=
(
1
,
0
)
;
162 163
immutable
right
,
left
,
up
,
down
,
origin
;
164 165
% path constants
166 167
path
quartercircle
,
halfcircle
,
fullcircle
,
unitsquare
;
168 169
fullcircle
=
makepath
pencircle
;
170
halfcircle
=
subpath
(
0
,
4
)
of
fullcircle
;
171
quartercircle
=
subpath
(
0
,
2
)
of
fullcircle
;
172
unitsquare
=
(
0
,
0
)
--
(
1
,
0
)
--
(
1
,
1
)
--
(
0
,
1
)
--
cycle
;
173 174
immutable
quartercircle
,
halfcircle
,
fullcircle
,
unitsquare
;
175 176
% transform constants
177 178
transform
identity
;
179 180
for
z
=
origin
,
right
,
up
:
181
z
transformed
identity
=
z
;
182
endfor
;
183 184
immutable
identity
;
185 186
% color constants (all in rgb color space)
187 188
color
black
,
white
,
red
,
green
,
blue
,
cyan
,
magenta
,
yellow
,
background
;
189 190
black
:
=
(
0
,
0
,
0
)
;
191
white
:
=
(
1
,
1
,
1
)
;
192
red
:
=
(
1
,
0
,
0
)
;
193
green
:
=
(
0
,
1
,
0
)
;
194
blue
:
=
(
0
,
0
,
1
)
;
195
cyan
:
=
(
0
,
1
,
1
)
;
196
magenta
:
=
(
1
,
0
,
1
)
;
197
yellow
:
=
(
1
,
1
,
0
)
;
198 199
background
:
=
white
;
% obsolete
200 201
% should these be tagged with a property ?
202 203
let
graypart
=
greypart
;
204
let
greycolor
=
numeric
;
205
let
graycolor
=
numeric
;
206 207
% color part (will be overloaded)
208 209
newinternal
nocolormodel
;
nocolormodel
:
=
0
;
210
newinternal
greycolormodel
;
greycolormodel
:
=
1
;
211
newinternal
graycolormodel
;
graycolormodel
:
=
1
;
212
newinternal
rgbcolormodel
;
rgbcolormodel
:
=
2
;
213
newinternal
cmykcolormodel
;
cmykcolormodel
:
=
3
;
214 215
def
colorpart
primary
t
=
216
if
colormodel
t
=
cmykcolormodel
:
217
(
cyanpart
t
,
magentapart
t
,
yellowpart
t
,
blackpart
t
)
218
elseif
colormodel
t
=
rgbcolormodel
:
219
(
redpart
t
,
greenpart
t
,
bluepart
t
)
220
elseif
colormodel
t
=
graycolormodel
:
221
(
greypart
t
)
222
elseif
colormodel
t
=
nocolormodel
:
223
false
224
elseif
defaultcolormodel
=
cmykcolormodel
:
225
(
0
,
0
,
0
,
1
)
226
elseif
defaultcolormodel
=
rgbcolormodel
:
227
black
228
elseif
defaultcolormodel
=
graycolormodel
:
229
0
230
else
:
231
false
232
fi
233
enddef
;
234 235
permanent
graypart
,
greycolor
,
graycolor
;
% colorpart
236 237
% picture constants
238 239
picture
blankpicture
,
evenly
,
withdots
;
240 241
blankpicture
=
nullpicture
;
% display blankpicture...
242
evenly
=
dashpattern
(
on
3
off
3
)
;
% dashed evenly
243
withdots
=
dashpattern
(
off
2.5
on
0
off
2.5
)
;
% dashed withdots
244 245
immutable
blankpicture
;
246
permanent
evenly
,
withdots
;
247 248
% string constants
249 250
string
ditto
,
EOF
;
251 252
ditto
=
char
34
;
% ASCII double-quote mark
253
EOF
=
char
0
;
% end-of-file for readfrom and write..to
254 255
immutable
ditto
,
EOF
;
256 257
% pen constants
258 259
pen
pensquare
,
penrazor
,
penspec
;
260 261
pensquare
=
makepen
(
unitsquare
shifted
-
(
.5
,
.5
)
)
;
262
penrazor
=
makepen
(
(
-.5
,
0
)
--
(
.5
,
0
)
--
cycle
)
;
263
penspec
=
pensquare
scaled
eps
;
264 265
immutable
pensquare
,
penrazor
,
penspec
;
266 267
% nullary operators
268 269
vardef
whatever
=
270
save
?
;
271
?
272
enddef
;
273 274
permanent
whatever
;
275 276
% unary operators (with patched round)
277 278
let
abs
=
length
;
279 280
vardef
round
primary
u
=
281
if
numeric
u
:
282
floor
(
u
+.5
)
283
elseif
pair
u
:
284
(
floor
(
xpart
u
+.5
)
,
floor
(
ypart
u
+.5
)
)
285
elseif
path
u
:
286
% added by HH
287
for
i
=
0
upto
length
u
-1
:
288
round
(
point
i
of
u
)
..
289
controls
round
(
postcontrol
i
of
u
)
and
round
(
precontrol
i
+1
of
u
)
..
290
endfor
291
if
cycle
u
:
cycle
else
:
point
infinity
of
u
fi
292
else
:
293
u
294
fi
295
enddef
;
296 297
vardef
ceiling
primary
x
=
298
-
floor
(
-
x
)
299
enddef
;
300 301
vardef
byte
primary
s
=
302
if
string
s
:
303
ASCII
304
fi
s
305
enddef
;
306 307
vardef
dir
primary
d
=
308
right
rotated
d
309
enddef
;
310 311
vardef
unitvector
primary
z
=
312
z
/
abs
z
313
enddef
;
314 315
vardef
inverse
primary
t
=
316
transform
temp_transform
;
317
temp_transform
transformed
t
=
identity
;
318
temp_transform
319
enddef
;
320 321
vardef
counterclockwise
primary
c
=
322
if
turningnumber
c
<
=
0
:
323
reverse
324
fi
c
325
enddef
;
326 327
vardef
tensepath
expr
r
=
328
for
k
=
0
upto
length
r
-
1
:
329
point
k
of
r
---
330
endfor
331
if
cycle
r
:
332
cycle
333
else
:
334
point
infinity
of
r
335
fi
336
enddef
;
337 338
vardef
center
primary
p
=
339
.5
[
llcorner
p
,
urcorner
p
]
340
enddef
;
341 342
permanent
abs
,
round
,
ceiling
,
byte
,
dir
,
unitvector
,
inverse
,
counterclockwise
,
tensepath
,
center
;
343 344
% binary operators
345 346
primarydef
x
mod
y
=
347
(
x
-
y
*
floor
(
x
/
y
)
)
348
enddef
;
349 350
primarydef
x
div
y
=
351
floor
(
x
/
y
)
352
enddef
;
353 354
primarydef
w
dotprod
z
=
355
(
xpart
w
*
xpart
z
+
ypart
w
*
ypart
z
)
356
enddef
;
357 358
permanent
mod
,
div
,
dotprod
;
359 360
% primarydef x**y =
361
% if y = 2 :
362
% x*x
363
% else :
364
% takepower y of x
365
% fi
366
% enddef ;
367
%
368
% def takepower expr y of x =
369
% if x>0 :
370
% mexp(y*mlog x)
371
% elseif (x=0) and (y>0) :
372
% 0
373
% else :
374
% 1
375
% if y = floor y :
376
% if y >= 0 :
377
% for n=1 upto y :
378
% *x
379
% endfor
380
% else :
381
% for n=-1 downto y :
382
% /x
383
% endfor
384
% fi
385
% else :
386
% hide(errmessage "Undefined power: " & decimal x & "**" & decimal y)
387
% fi
388
% fi
389
% enddef ;
390 391
% for big number systems:
392 393
primarydef
x
*
*
y
=
394
if
y
=
0
:
1
395
elseif
x
=
0
:
0
396
elseif
y
<
0
:
1
/
(
x
*
*
-
y
)
397
elseif
y
=
1
:
x
398
elseif
y
=
2
:
x
*
x
399
elseif
y
=
3
:
x
*
x
*
x
400
else
:
takepower
y
of
x
401
fi
402
enddef
;
403 404
def
takepower
expr
y
of
x
=
405
if
y
=
0
:
% isn't x**0 = 1 even if x=0 ?
406
1
407
elseif
x
=
0
:
408
0
409
else
:
410
if
y
=
floor
y
:
411
1
412
if
y
>
=
0
:
413
for
n
=
1
upto
y
:
414
*
x
415
endfor
416
else
:
417
for
n
=
-1
downto
y
:
418
/
x
419
endfor
420
fi
421
elseif
x
>
0
:
422
mexp
(
y
*
mlog
x
)
423
else
:
424
-
mexp
(
y
*
mlog
-
x
)
425
fi
426
fi
427
enddef
;
428 429
permanent
*
*
,
takepower
;
430 431
newinternal
temp_internal_a
,
temp_internal_b
;
432
newinternal
temp_numeric_x
,
temp_numeric_y
;
433
newinternal
temp_internal_tx
,
temp_internal_ty
,
temp_internal_fx
,
temp_internal_fy
;
434
newinternal
temp_internal_n
;
435
path
temp_path_a
,
temp_path_b
;
436
pair
temp_pair_dz
,
temp_pair_z
[
]
;
437 438
vardef
direction
expr
t
of
p
=
439
postcontrol
t
of
p
-
precontrol
t
of
p
440
enddef
;
441 442
vardef
directionpoint
expr
z
of
p
=
443
temp_internal_a
:
=
directiontime
z
of
p
;
444
if
temp_internal_a
<
0
:
445
errmessage
(
"
The direction doesn't occur
"
)
;
446
fi
447
point
temp_internal_a
of
p
448
enddef
;
449 450
secondarydef
p
intersectionpoint
q
=
451
begingroup
452
save
temp_numeric_x
,
temp_numeric_y
;
453
(
temp_numeric_x
,
temp_numeric_y
)
=
p
intersectiontimes
q
;
454
if
temp_numeric_x
<
0
:
455
errmessage
(
"
The paths don't intersect
"
)
;
456
origin
457
else
:
458
.5
[
point
temp_numeric_x
of
p
,
point
temp_numeric_y
of
q
]
459
fi
460
endgroup
461
enddef
;
462 463
tertiarydef
p
softjoin
q
=
464
begingroup
465
temp_path_a
:
=
fullcircle
scaled
2
join_radius
shifted
point
0
of
q
;
466
temp_internal_a
:
=
ypart
(
temp_path_a
intersectiontimes
p
)
;
467
temp_internal_b
:
=
ypart
(
temp_path_a
intersectiontimes
q
)
;
468
if
temp_internal_a
<
0
:
469
point
0
of
p
{
direction
0
of
p
}
470
else
:
471
subpath
(
0
,
temp_internal_a
)
of
p
472
fi
473
...
474
if
temp_internal_b
<
0
:
475
{
direction
infinity
of
q
}
point
infinity
of
q
476
else
:
477
subpath
(
temp_internal_b
,
infinity
)
of
q
478
fi
479
endgroup
480
enddef
;
481 482
permanent
direction
,
directionpoint
,
intersectionpoint
,
softjoin
;
483 484
newinternal
join_radius
;
485
path
cuttings
;
% what got cut off
486 487
tertiarydef
a
cutbefore
b
=
% tries to cut as little as possible
488
begingroup
489
save
t
;
490
(
t
,
whatever
)
=
a
intersectiontimes
b
;
491
if
t
<
0
:
492
cuttings
:
=
point
0
of
a
;
493
a
494
else
:
495
cuttings
:
=
subpath
(
0
,
t
)
of
a
;
496
subpath
(
t
,
length
a
)
of
a
497
fi
498
endgroup
499
enddef
;
500 501
tertiarydef
a
cutafter
b
=
502
reverse
(
reverse
a
cutbefore
b
)
503
hide
(
cuttings
:
=
reverse
cuttings
)
504
enddef
;
505 506
permanent
join_radius
,
cuttings
,
cutbefore
,
cutafter
;
507 508
% special operators
509 510
vardef
incr
suffix
$
=
$
:
=
$
+
1
;
$
enddef
;
511
vardef
decr
suffix
$
=
$
:
=
$
-
1
;
$
enddef
;
512 513
permanent
incr
,
decr
;
514 515
def
reflectedabout
(
expr
w
,
z
)
=
% reflects about the line w..z
516
transformed
517
begingroup
518
transform
temp_transform
;
519
w
transformed
temp_transform
=
w
;
520
z
transformed
temp_transform
=
z
;
521
xxpart
temp_transform
=
-
yypart
temp_transform
;
522
xypart
temp_transform
=
yxpart
temp_transform
;
% temp_transform is a reflection
523
temp_transform
524
endgroup
525
enddef
;
526 527
def
rotatedaround
(
expr
z
,
d
)
=
% rotates d degrees around z
528
shifted
-
z
rotated
d
shifted
z
529
enddef
;
530 531
let
rotatedabout
=
rotatedaround
;
% for roundabout people
532 533
permanent
reflectedabout
,
rotatedaround
,
rotatedabout
;
534 535
vardef
min
(
expr
u
)
(
text
t
)
=
% t is a list of numerics, pairs, or strings
536
save
temp_any_u
;
537
if
pair
u
:
538
pair
temp_any_u
539
elseif
string
u
:
540
string
temp_any_u
541
fi
;
542
temp_any_u
:
=
u
;
543
for
i
=
t
:
544
if
i
<
temp_any_u
:
545
temp_any_u
:
=
i
;
546
fi
547
endfor
548
temp_any_u
549
enddef
;
550 551
vardef
max
(
expr
u
)
(
text
t
)
=
% t is a list of numerics, pairs, or strings
552
save
temp_any_u
;
553
if
pair
u
:
554
pair
temp_any_u
555
elseif
string
u
:
556
string
temp_any_u
557
fi
;
558
temp_any_u
:
=
u
;
559
for
i
=
t
:
560
if
i
>
temp_any_u
:
561
temp_any_u
:
=
i
;
562
fi
563
endfor
564
temp_any_u
565
enddef
;
566 567
def
flex
(
text
t
)
=
% t is a list of pairs
568
hide
(
569
temp_internal_n
:
=
0
;
570
for
z
=
t
:
571
temp_pair_z
[
incr
temp_internal_n
]
:
=
z
;
572
endfor
573
temp_pair_dz
:
=
temp_pair_z
[
temp_internal_n
]
-
temp_pair_z
[
1
]
574
)
575
temp_pair_z
[
1
]
for
k
=
2
upto
temp_internal_n
-
1
:
...
temp_pair_z
[
k
]
{
temp_pair_dz
}
endfor
...
temp_pair_z
[
temp_internal_n
]
576
enddef
;
577 578
permanent
min
,
max
,
flex
;
579 580
def
superellipse
(
expr
r
,
t
,
l
,
b
,
s
)
=
581
r
{
up
}
...
(
s
[
xpart
t
,
xpart
r
]
,
s
[
ypart
r
,
ypart
t
]
)
{
t
-
r
}
...
582
t
{
left
}
...
(
s
[
xpart
t
,
xpart
l
]
,
s
[
ypart
l
,
ypart
t
]
)
{
l
-
t
}
...
583
l
{
down
}
...
(
s
[
xpart
b
,
xpart
l
]
,
s
[
ypart
l
,
ypart
b
]
)
{
b
-
l
}
...
584
b
{
right
}
...
(
s
[
xpart
b
,
xpart
r
]
,
s
[
ypart
r
,
ypart
b
]
)
{
r
-
b
}
...
cycle
enddef
;
585 586
vardef
interpath
(
expr
a
,
p
,
q
)
=
587
for
t
=
0
upto
length
p
-1
:
588
a
[
point
t
of
p
,
point
t
of
q
]
..
controls
a
[
postcontrol
t
of
p
,
postcontrol
t
of
q
]
and
a
[
precontrol
t
+1
of
p
,
precontrol
t
+1
of
q
]
..
589
endfor
590
if
cycle
p
:
591
cycle
592
else
:
593
a
[
point
infinity
of
p
,
point
infinity
of
q
]
594
fi
595
enddef
;
596 597
permanent
superellipse
,
interpath
;
598 599
newinternal
tolerance
;
tolerance
:
=
.01
;
600 601
vardef
solve
@#
(
expr
t
,
f
)
=
% @#(t)=true, @#(f)=false
602
temp_internal_tx
:
=
t
;
603
temp_internal_fx
:
=
f
;
604
forever
:
605
temp_numeric_x
:
=
.5
[
temp_internal_tx
,
temp_internal_fx
]
;
606
exitif
abs
(
temp_internal_tx
-
temp_internal_fx
)
<
=
tolerance
;
607
if
@#
(
temp_numeric_x
)
:
608
temp_internal_tx
609
else
:
610
temp_internal_fx
611
fi
:
=
temp_numeric_x
;
612
endfor
613
temp_numeric_x
% now temp_numeric_x is near where @# changes from true to false
614
enddef
;
615 616
vardef
buildcycle
(
text
ll
)
=
617
save
temp_a
,
temp_b
,
temp_k
,
temp_i
,
temp_p
;
path
temp_p
[
]
;
618
temp_k
=
0
;
619
for
q
=
ll
:
620
temp_p
[
incr
temp_k
]
=
q
;
621
endfor
622
temp_i
=
temp_k
;
623
for
i
=
1
upto
temp_k
:
624
(
temp_a
[
i
]
,
length
temp_p
[
temp_i
]
-
temp_b
[
temp_i
]
)
=
temp_p
[
i
]
intersectiontimes
reverse
temp_p
[
temp_i
]
;
625
if
temp_a
[
i
]
<
0
:
626
errmessage
(
"
Paths
"
&
decimal
i
&
"
and
"
&
decimal
temp_i
&
"
don't intersect
"
)
;
627
fi
628
temp_i
:
=
i
;
629
endfor
630
for
i
=
1
upto
temp_k
:
631
subpath
(
temp_a
[
i
]
,
temp_b
[
i
]
)
of
temp_p
[
i
]
..
632
endfor
633
cycle
634
enddef
;
635 636
permanent
interpath
,
solve
,
buildcycle
,
tolerance
;
637 638
%% units of measure
639 640
mm
:
=
2.83464
;
641
pt
:
=
0.99626
;
642
dd
:
=
1.06601
;
% 1.0660068107174
643
bp
:
=
1
;
644
cm
:
=
28.34645
;
645
pc
:
=
11.95517
;
646
cc
:
=
12.79213
;
647
in
:
=
72
;
648
dk
:
=
6.41577
;
% 6.4157650704225 ;
649 650
immutable
mm
,
pt
,
bp
,
cm
,
in
;
% we don't protect (yet): dd, pc cc (used as locals)
651 652
% vardef magstep primary m = % obsolete
653
% mexp(46.67432m)
654
% enddef ;
655 656
%% macros for drawing and filling
657 658
def
drawoptions
(
text
t
)
=
659
def
base_draw_options
=
t
enddef
660
enddef
;
661 662
% parameters that effect drawing
663 664
linejoin
:
=
rounded
;
665
linecap
:
=
rounded
;
666
miterlimit
:
=
10
;
667 668
drawoptions
(
)
;
669 670
pen
currentpen
;
671
picture
currentpicture
;
672 673
def
fill
expr
c
=
674
addto
currentpicture
contour
c
base_draw_options
675
enddef
;
676 677
def
draw
expr
p
=
678
addto
currentpicture
679
if
picture
p
:
680
also
p
681
else
:
682
doublepath
p
withpen
currentpen
683
fi
684
base_draw_options
685
enddef
;
686 687
def
filldraw
expr
c
=
688
addto
currentpicture
contour
c
withpen
currentpen
base_draw_options
689
enddef
;
690 691
% def drawdot expr z =
692
% addto currentpicture contour makepath currentpen shifted z base_draw_options
693
% enddef ;
694
%
695
% testcase DEK:
696
%
697
% for j=1 upto 9 :
698
% pickup pencircle xscaled .4 yscaled .2 ;
699
% drawdot (10j,0) withpen pencircle xscaled .5j yscaled .25j rotated 45 ;
700
% pickup pencircle xscaled .5j yscaled .25j rotated 45 ;
701
% drawdot (10j,10);
702
% endfor ;
703
%
704
% or:
705
%
706
%\startMPpage
707
%
708
% def drawdot expr z =
709
% addto currentpicture contour (makepath currentpen shifted z) base_draw_options
710
% enddef;
711
%
712
% drawdot origin shifted (0,-3cm) withpen pencircle scaled 2cm ;
713
% pickup pencircle scaled 2cm ; drawdot origin withcolor red ;
714 715
def
drawdot
expr
p
=
716
if
pair
p
:
717
addto
currentpicture
doublepath
p
withpen
currentpen
base_draw_options
718
else
:
719
errmessage
(
"
drawdot only accepts a pair expression
"
)
720
fi
721
enddef
;
722 723
permanent
drawoptions
,
currentpen
,
filldraw
,
drawdot
;
% redefined later: fill, draw
724 725
% permanent currentpicture; % not yet
726 727
% Kind of obsolete:
728 729
def
unfill
expr
c
=
fill
c
withcolor
background
enddef
;
730
def
undraw
expr
p
=
draw
p
withcolor
background
enddef
;
731
def
unfilldraw
expr
c
=
filldraw
c
withcolor
background
enddef
;
732
def
undrawdot
expr
z
=
drawdot
z
withcolor
background
enddef
;
733 734
def
plain_erase
=
enddef
;
735 736
def
erase
text
t
=
737
def
plain_erase
=
738
withcolor
background
hide
(
def
plain_erase
=
enddef
;
)
739
enddef
;
740
t
plain_erase
741
enddef
;
742 743
def
cutdraw
text
t
=
744
begingroup
745
interim
linecap
:
=
butt
;
746
draw
t
plain_erase
;
747
endgroup
748
enddef
;
749 750
permanent
unfill
,
undraw
,
unfilldraw
,
undrawdot
,
erase
,
cutdraw
;
751 752
% Popular:
753 754
vardef
image
(
text
t
)
=
755
save
currentpicture
;
756
picture
currentpicture
;
757
currentpicture
:
=
nullpicture
;
758
t
;
759
currentpicture
760
enddef
;
761 762
permanent
image
;
763 764
def
pickup
secondary
q
=
765
if
numeric
q
:
766
plain_pickup_numeric
767
else
:
768
plain_pickup_path
769
fi
q
770
enddef
;
771 772
% pens
773 774
newinternal
pen_lft
,
pen_rt
,
pen_top
,
pen_bot
;
775 776
newinternal
temp_pen_count
;
777
path
temp_pen_result
;
778
path
temp_pen_path
.
l
,
temp_pen_path
.
r
;
779
numeric
temp_pen_l
[
]
,
temp_pen_r
[
]
,
temp_pen_t
[
]
,
temp_pen_b
[
]
;
780
pen
temp_pen_stack
[
]
;
781
path
temp_pen_p
[
]
;
782 783
pen
currentpen
;
784 785
temp_pen_count
:
=
0
;
786 787
def
plain_pickup_numeric
primary
q
=
788
if
unknown
temp_pen_stack
[
q
]
:
789
errmessage
"
Unknown pen
"
;
790
clearpen
791
else
:
792
currentpen
:
=
temp_pen_stack
[
q
]
;
793
pen_lft
:
=
temp_pen_l
[
q
]
;
794
pen_rt
:
=
temp_pen_r
[
q
]
;
795
pen_top
:
=
temp_pen_t
[
q
]
;
796
pen_bot
:
=
temp_pen_b
[
q
]
;
797
temp_pen_result
:
=
temp_pen_p
[
q
]
798
fi
;
799
enddef
;
800 801
def
plain_pickup_path
primary
q
=
802
currentpen
:
=
q
;
803
pen_lft
:
=
xpart
penoffset
down
of
currentpen
;
804
pen_rt
:
=
xpart
penoffset
up
of
currentpen
;
805
pen_top
:
=
ypart
penoffset
left
of
currentpen
;
806
pen_bot
:
=
ypart
penoffset
right
of
currentpen
;
807
path
temp_pen_result
;
808
enddef
;
809 810
vardef
savepen
=
811
temp_pen_stack
[
incr
temp_pen_count
]
=
currentpen
;
812
temp_pen_l
[
temp_pen_count
]
=
pen_lft
;
813
temp_pen_r
[
temp_pen_count
]
=
pen_rt
;
814
temp_pen_t
[
temp_pen_count
]
=
pen_top
;
815
temp_pen_b
[
temp_pen_count
]
=
pen_bot
;
816
temp_pen_p
[
temp_pen_count
]
=
temp_pen_result
;
817
temp_pen_count
818
enddef
;
819 820
def
clearpen
=
821
currentpen
:
=
nullpen
;
822
pen_lft
:
=
pen_rt
:
=
pen_top
:
=
pen_bot
:
=
0
;
823
path
temp_pen_result
;
824
enddef
;
825 826
vardef
lft
primary
x
=
x
+
if
pair
x
:
(
pen_lft
,
0
)
else
:
pen_lft
fi
enddef
;
827
vardef
rt
primary
x
=
x
+
if
pair
x
:
(
pen_rt
,
0
)
else
:
pen_rt
fi
enddef
;
828
vardef
top
primary
y
=
y
+
if
pair
y
:
(
0
,
pen_top
)
else
:
pen_top
fi
enddef
;
829
vardef
bot
primary
y
=
y
+
if
pair
y
:
(
0
,
pen_bot
)
else
:
pen_bot
fi
enddef
;
830 831
vardef
penpos
@#
(
expr
b
,
d
)
=
832
(
x
@#
r
-
x
@#
l
,
y
@#
r
-
y
@#
l
)
=
(
b
,
0
)
rotated
d
;
833
x
@#
=
.5
(
x
@#
l
+
x
@#
r
)
;
834
y
@#
=
.5
(
y
@#
l
+
y
@#
r
)
;
% ; added HH
835
enddef
;
836 837
def
penstroke
text
t
=
838
forsuffixes
e
=
l
,
r
:
839
temp_pen_path
.
e
:
=
t
;
840
endfor
841
fill
temp_pen_path
.
l
--
reverse
temp_pen_path
.
r
--
cycle
842
enddef
;
843 844
permanent
845
pen_lft
,
pen_rt
,
pen_top
,
pen_bot
,
846
lft
,
rt
,
top
,
bot
,
847
pickup
,
penpos
,
clearpen
,
penstroke
,
savepen
;
848 849
%% High level drawing commands
850 851
newinternal
ahlength
,
ahangle
;
852 853
ahlength
:
=
4
;
% default arrowhead length 4bp
854
ahangle
:
=
45
;
% default head angle 45 degrees
855 856
path
temp_arrow_path
;
857 858
vardef
arrowhead
expr
p
=
859
save
q
,
e
;
path
q
;
pair
e
;
860
e
=
point
length
p
of
p
;
861
q
=
gobble
(
p
shifted
-
e
cutafter
makepath
(
pencircle
scaled
2
ahlength
)
)
cuttings
;
862
(
q
rotated
.5
ahangle
&
reverse
q
rotated
-.5
ahangle
--
cycle
)
shifted
e
863
enddef
;
864 865
def
drawarrow
expr
p
=
temp_arrow_path
:
=
p
;
plain_arrow_finish
enddef
;
866
def
drawdblarrow
expr
p
=
temp_arrow_path
:
=
p
;
plain_arrow_find
enddef
;
867 868
def
plain_arrow_finish
text
t
=
869
draw
temp_arrow_path
t
;
870
filldraw
arrowhead
temp_arrow_path
t
871
enddef
;
872 873
def
plain_arrow_find
text
t
=
% this had fill in 0.63 (potential incompatibility)
874
draw
temp_arrow_path
t
;
875
filldraw
arrowhead
temp_arrow_path
withpen
currentpen
t
;
876
filldraw
arrowhead
reverse
temp_arrow_path
withpen
currentpen
t
;
% ; added HH
877
enddef
;
878 879
permanent
ahlength
,
ahangle
,
arrowhead
,
drawarrow
,
drawdblarrow
;
880 881
%% macros for labels
882 883
newinternal
bboxmargin
;
884 885
bboxmargin
:
=
2
bp
;
% this can bite you, just don't use it in \METAFUN
886 887
vardef
bbox
primary
p
=
888
llcorner
p
-
(
bboxmargin
,
bboxmargin
)
--
889
lrcorner
p
+
(
bboxmargin
,
-
bboxmargin
)
--
890
urcorner
p
+
(
bboxmargin
,
bboxmargin
)
--
891
ulcorner
p
+
(
-
bboxmargin
,
bboxmargin
)
--
cycle
892
enddef
;
893 894
permanent
bboxmargin
,
bbox
;
895 896
string
defaultfont
;
newinternal
defaultscale
,
labeloffset
,
dotlabeldiam
;
897 898
defaultfont
:
=
"
cmr10
"
;
899
defaultscale
:
=
1
;
900
labeloffset
:
=
3
bp
;
901
dotlabeldiam
:
=
3
bp
;
902 903
mutable
defaultfont
,
defaultscale
,
labeloffset
,
dotlabeldiam
;
904 905
vardef
thelabel
@#
(
expr
s
,
z
)
=
% Position s near z
906
save
p
;
picture
p
;
907
if
picture
s
:
908
p
=
s
909
else
:
910
p
=
s
infont
defaultfont
scaled
defaultscale
911
fi
;
912
p
shifted
(
z
+
labeloffset
*
laboff
@#
-
(
labxf
@#
*
lrcorner
p
+
labyf
@#
*
ulcorner
p
+
(
1
-
labxf
@#
-
labyf
@#
)
*
llcorner
p
)
)
913
enddef
;
914 915
def
label
=
916
draw
thelabel
917
enddef
;
918 919
vardef
dotlabel
@#
(
expr
s
,
z
)
text
t
=
920
label
@#
(
s
,
z
)
t
;
921
interim
linecap
:
=
rounded
;
922
draw
z
withpen
pencircle
scaled
dotlabeldiam
t
;
923
enddef
;
924 925
% def makelabel =
926
% dotlabel
927
% enddef ;
928 929
permanent
label
,
dotlabel
;
930 931
% this will be overloaded
932 933
pair
laboff
,
laboff
.
lft
,
laboff
.
rt
,
laboff
.
top
,
laboff
.
bot
;
934
pair
laboff
.
ulft
,
laboff
.
llft
,
laboff
.
urt
,
laboff
.
lrt
;
935 936
laboff
=
(
0
,
0
)
;
labxf
=
.5
;
labyf
=
.5
;
937
laboff
.
lft
=
(
-1
,
0
)
;
labxf
.
lft
=
1
;
labyf
.
lft
=
.5
;
938
laboff
.
rt
=
(
1
,
0
)
;
labxf
.
rt
=
0
;
labyf
.
rt
=
.5
;
939
laboff
.
bot
=
(
0
,
-1
)
;
labxf
.
bot
=
.5
;
labyf
.
bot
=
1
;
940
laboff
.
top
=
(
0
,
1
)
;
labxf
.
top
=
.5
;
labyf
.
top
=
0
;
941
laboff
.
ulft
=
(
-.7
,
.7
)
;
labxf
.
ulft
=
1
;
labyf
.
ulft
=
0
;
942
laboff
.
urt
=
(
.7
,
.7
)
;
labxf
.
urt
=
0
;
labyf
.
urt
=
0
;
943
laboff
.
llft
=
-
(
.7
,
.7
)
;
labxf
.
llft
=
1
;
labyf
.
llft
=
1
;
944
laboff
.
lrt
=
(
.7
,
-.7
)
;
labxf
.
lrt
=
0
;
labyf
.
lrt
=
1
;
945 946
vardef
labels
@#
(
text
t
)
=
947
forsuffixes
$
=
t
:
948
label
@#
(
str
$
,
z
$
)
;
949
endfor
950
enddef
;
951 952
% till lhere
953 954
vardef
dotlabels
@#
(
text
t
)
=
955
forsuffixes
$
=
t
:
956
dotlabel
@#
(
str
$
,
z
$
)
;
957
endfor
958
enddef
;
959 960
vardef
penlabels
@#
(
text
t
)
=
961
forsuffixes
$
$
=
l
,
,
r
:
962
forsuffixes
$
=
t
:
963
dotlabel
@#
(
str
$
.
$
$
,
z
$
.
$
$
)
;
964
endfor
965
endfor
966
enddef
;
967 968
permanent
dotlabels
,
penlabels
;
969 970
% range 4 thru 10
971 972
def
plain_numtok
suffix
x
=
973
x
974
enddef
;
975 976
def
range
expr
x
=
977
plain_numtok
[
x
]
978
enddef
;
979 980
tertiarydef
m
thru
n
=
981
m
for
x
=
m
+1
step
1
until
n
:
982
,
plain_numtok
[
x
]
983
endfor
984
enddef
;
985 986
permanent
range
,
thru
;
987 988
%% Overall administration
989 990
% Todo: make an add to this helper thet temporarily disables warning
991 992
string
extra_beginfig
,
extra_endfig
;
993 994
extra_beginfig
:
=
"
"
;
995
extra_endfig
:
=
"
"
;
996 997
newinternal
boolean
makingfigure
;
makingfigure
:
=
false
;
998 999
def
beginfig
(
expr
c
)
=
% redefined in mp-grph !
1000
begingroup
1001
charcode
:
=
c
;
1002
clearxy
;
1003
clearit
;
1004
clearpen
;
1005
pickup
defaultpen
;
1006
drawoptions
(
)
;
1007
interim
stacking
:
=
0
;
1008
interim
makingfigure
:
=
true
;
1009
scantokens
extra_beginfig
;
1010
enddef
;
1011 1012
def
endfig
=
1013
;
% added by HH
1014
scantokens
extra_endfig
;
1015
shipit
;
1016
endgroup
1017
enddef
;
1018 1019
permanent
1020
% extra_beginfig, extra_endfig,
1021
beginfig
,
endfig
;
1022 1023
%% last-minute items
1024 1025
vardef
z
@#
=
1026
(
x
@#
,
y
@#
)
1027
enddef
;
1028 1029
def
clearxy
=
1030
save
x
,
y
1031
enddef
;
1032 1033
def
clearit
=
1034
currentpicture
:
=
nullpicture
1035
enddef
;
1036 1037
clearit
;
1038 1039
permanent
z
,
clearit
;
% redefined: clearxy
1040 1041
def
shipit
=
1042
shipout
currentpicture
1043
enddef
;
1044 1045
let
bye
=
end
;
1046
outer
end
,
bye
;
1047 1048
permanent
shipit
,
bye
;
1049 1050
% set default line width
1051 1052
newinternal
defaultpen
;
1053 1054
pickup
pencircle
scaled
.5
bp
;
1055 1056
defaultpen
:
=
savepen
;
1057 1058
permanent
defaultpen
;
1059