SourceBrowser

mp-xbox.mpiv /size: 9 Kb last modification: 2021-10-28 13:50
1% This file is a variant of "macros for boxes"::
2%
3% author    : Taco Hoekwater
4% version   : $Id: boxes.mp,v 1.5 2005/02/25 11:28:56 taco Exp $
5% copyright : Public domain
6% patched   : Hans Hagen
7%
8% author    : Karl Berry
9% version   : $Id: rboxes.mp,v 1.2 2004/09/19 21:47:11 karl Exp $
10% copyright : Public domain
11% patched   : Hans Hagen
12%
13% The code is the same but I've added a boxes_ namespace for some so that we don't
14% clash with metafun.
15
16if
 known
 metafun_loaded_xbox
 :
 endinput
 ;
 fi
 ;
17
18boolean
 metafun_loaded_xbox
 ;
 metafun_loaded_xbox
 :
=
 true
 ;
19
20% Find the length of the prefix of string s for which cond is true for each character
21% c of the prefix. Loading and initialization is now under metafun control. Only the
22% mpxl variant will be adapted. When needed this file will be adapted.
23
24vardef
 boxes_str_prefix
 (
expr
 s
)
 (
text
 cond
)
 =
25    save
 i_
,
 c
;
 string
 c
;
 i_
 =
 0
;
26    forever
:
27        c
 :
=
 substring
 (
i_
,
 i_
 +
 1
)
 of
 s
;
28        exitunless
 cond
;
29        exitif
 incr
 i_
 =
 length
 s
;
30    endfor
31    i_
32enddef
;
33
34% Take a string returned by the str operator and return the same string with explicit
35% numeric subscripts replaced by generic subscript symbols [] (fixed by Eddie Kohler).
36
37vardef
 generisize
 (
expr
 ss
)
 =
38    save
 r
,
 s
,
 l
;
 string
 r
,
 s
;
39    r
 =
 "
"
;
 % result so far
40    s
 =
 ss
;
 % left to process
41    forever
:
42        exitif
 s
 =
 "
"
;
43        l
 :
=
 boxes_str_prefix
(
s
,
 (
c
<
>
"
[
"
)
 and
 (
(
c
<
"
0
"
)
 or
 (
c
>
"
9
"
)
)
)
;
44        r
 :
=
 r
 &
 substring
 (
0
,
l
)
 of
 s
;
45        s
 :
=
 substring
 (
l
,
 infinity
)
 of
 s
;
46        if
 s
 <
>
 "
"
 :
47            if
 (
s
 >
=
 "
[
"
)
 and
 (
length
 s
 >
 1
)
 :
48                if
 (
substring
 (
1
,
2
)
 of
 s
)
 =
 "
[
"
 :
49                    l
 :
=
 2
;
50                    r
 :
=
 r
 &
 "
[[
"
;
51                else
 :
52                    l
 :
=
 1
 +
 boxes_str_prefix
(
s
,
 c
 <
>
 "
]
"
)
;
53                    r
 :
=
 r
 &
 "
[]
"
;
54                fi
55            else
 :
56                r
 :
=
 r
 &
 "
[]
"
;
57                l
 :
=
 boxes_str_prefix
(
s
,
 (
c
 =
 "
.
"
)
 or
 (
"
0
"
 <
=
 c
)
 and
 (
c
 <
=
 "
9
"
)
)
;
58            fi
59            s
 :
=
 substring
(
l
,
 infinity
)
 of
 s
;
60        fi
61    endfor
62    r
63enddef
;
64
65% Make sure the string boxes_n_gen is generisize(_n_):
66
67string
 boxes_n
,
 boxes_n_cur
,
 boxes_n_gen
;
 boxes_n_cur
 :
=
 "
]
"
;
 % this won't match _n_
68
69vardef
 boxes_set_n_gen
 =
70    if
 boxes_n
 <
>
 boxes_n_cur
:
71        boxes_n_cur
 :
=
 boxes_n
;
72        boxes_n_gen
 :
=
 generisize
(
boxes_n
)
;
73    fi
74enddef
;
75
76% Given a type t and list of variable names vars, make sure that they are of type t
77% and redeclare them as necessary.  In the vars list _n represents scantokens boxes_n,
78% a suffix that might contain numeric subscripts. This suffix needs to be replaced
79% by scantokens boxes_n_gen in order to get a variable that can be declared to be of
80% type t.
81
82vardef
 boxes_declare
(
text
 t
)
 text
 vars
 =
83    boxes_set_n_gen
;
84    forsuffixes
 v_
 =
 vars
 :
85        if
 forsuffixes
 _n
 =
 scantokens
 boxes_n
 :
 not
 t
 v_
 endfor
 :
86            def
 boxes_gdmac
 text
 _n
 =
 t
 v_
 enddef
;
87            expandafter
 boxes_gdmac
 scantokens
 boxes_n_gen
;
88        fi
89    endfor
90enddef
;
91
92% Here is another version that redeclares the vars even if they are already of the
93% right type.
94
95vardef
 boxes_redeclare
(
text
 t
)
 text
 vars
 =
96    boxes_set_n_gen
;
97    def
 boxes_gdmac
 text
 _n
 =
 t
 vars
 enddef
;
98    expandafter
 boxes_gdmac
 scantokens
 boxes_n_gen
;
99enddef
;
100
101% pp should be a string giving the name of a macro that finds the boundary path and
102% sp should be a string that names a macro for fixing the size and shape. The suffix
103% $ is the name of the box. The text t gives the box contents: either empty, a
104% picture, or a string to typeset.
105
106def
 boxes_begin
 (
expr
 pp
,
 sp
)
 (
suffix
 $
)
 (
text
 t
)
 =
107    boxes_n
 :
=
 str
 $
;
108    boxes_declare
 (
pair
)
 _n
.
off
,
 _n
.
c
;
109    boxes_declare
 (
string
)
 boxes_pproc
.
_n
,
 boxes_sproc
.
_n
;
110    boxes_declare
 (
picture
)
 boxes_pic
.
_n
;
111    boxes_pproc
$
 :
=
 pp
;
112    boxes_sproc
$
 :
=
 sp
;
113    boxes_pic
$
 :
=
 nullpicture
;
114    for
 _p_
 =
 t
 :
115      % boxes_pic$ := if picture _p_: _p_ else: _p_ infont defaultfont scaled defaultscale fi;
116        boxes_pic
$
 :
=
 if
 picture
 _p_
:
 _p_
 else
:
 textext
(
_p_
)
 fi
;
117    endfor
118    $
c
 =
 $
off
 +
 .5
[
llcorner
 boxes_pic
$
,
 urcorner
 boxes_pic
$
]
119enddef
;
120
121% The suffix cl names a vardef macro that clears box-related variables. The suffix $
122% is the name of the box being ended.
123
124def
 boxes_end
(
suffix
 cl
,
 $
)
 =
125    if
 known
 boxes_pic
.
boxes_prevbox
:
126        boxes_dojoin
(
boxes_prevbox
,
$
)
;
127    fi
128    def
 boxes_prevbox
 =
 $
 enddef
;
129    expandafter
 def
 expandafter
 boxes_clear_all
 expandafter
 =
130        boxes_clear_all
 cl
(
$
)
;
131    enddef
132enddef
;
133
134% Text t gives equations for joining box a to box b.
135
136def
 boxes_boxjoin
(
text
 t
)
 =
137    def
 boxes_prevbox
 =
 _
 enddef
;
138    def
 boxes_dojoin
(
suffix
 a
,
b
)
 =
 t
 enddef
;
139enddef
 ;
140
141def
 boxes_clear_all
 =
 enddef
;
142
143% Given a list of box names, give whatever default values are necessary
144% in order to fix the size and shape of each box.
145
146vardef
 boxes_fixsize
(
text
 t
)
 =
147    forsuffixes
 $
 =
 t
 :
 scantokens
 boxes_sproc
$
(
$
)
;
 endfor
148enddef
;
149
150% Given a list of box names, give default values for any unknown positioning offsets.
151
152vardef
 boxes_fixpos
(
text
 t
)
 =
153    forsuffixes
 $
=
t
:
154        if
 unknown
 xpart
 $
.
off
 :
 xpart
 $
.
off
 =
 0
;
 fi
155        if
 unknown
 ypart
 $
.
off
 :
 ypart
 $
.
off
 =
 0
;
 fi
156    endfor
157enddef
;
158
159% Return the boundary path for the given box
160
161vardef
 bpath
 suffix
 $
 =
162    boxes_fixsize
(
$
)
;
163    boxes_fixpos
(
$
)
;
164    scantokens
 boxes_pproc
$
(
$
)
165enddef
;
166
167% Return the contents of the given box. First define a private version that the user can't
168% accidently clobber.
169
170vardef
 boxes_pic_mac
 suffix
 $
 =
171    boxes_fixsize
(
$
)
;
172    boxes_fixpos
(
$
)
;
173    boxes_pic
$
 shifted
 $
off
174enddef
;
175
176vardef
 pic
 suffix
 $
 =
 boxes_pic_mac
 $
 enddef
;
177
178% Draw each box:
179
180def
 drawboxed
(
text
 t
)
 =
181    boxes_fixsize
(
t
)
;
182    boxes_fixpos
(
t
)
;
183    forsuffixes
 s
 =
 t
:
 draw
 boxes_pic_mac
.
s
;
 draw
 bpath
.
s
;
 endfor
184enddef
;
185
186% Draw contents of each box:
187
188def
 drawunboxed
(
text
 t
)
 =
189    boxes_fixsize
(
t
)
;
190    boxes_fixpos
(
t
)
;
191    forsuffixes
 s
 =
 t
 :
192        draw
 boxes_pic_mac
.
s
;
193    endfor
194enddef
;
195
196% Draw boundary path for each box:
197
198def
 drawboxes
(
text
 t
)
 =
199    forsuffixes
 s
 =
 t
 :
200        draw
 bpath
.
s
;
201    endfor
202enddef
;
203
204% Rectangular boxes
205
206newinternal
 defaultdx
,
 defaultdy
;
 defaultdx
 :
=
 defaultdy
 :
=
 3
bp
;
207
208vardef
 boxit
@#
(
text
 tt
)
 =
209    boxes_begin
(
"
boxes_path
"
,
"
boxes_size
"
,
@#
,
tt
)
;
210    boxes_declare
 (
pair
)
 _n
.
sw
,
 _n
.
s
,
 _n
.
se
,
 _n
.
e
,
 _n
.
ne
,
 _n
.
n
,
 _n
.
nw
,
 _n
.
w
;
211    0
 =
 xpart
(
@#
nw
 -
 @#
sw
)
 =
 ypart
(
@#
se
 -
 @#
sw
)
;
212    0
 =
 xpart
(
@#
ne
 -
 @#
se
)
 =
 ypart
(
@#
ne
 -
 @#
nw
)
;
213    @#
w
 =
 .5
[
@#
nw
,
@#
sw
]
;
214    @#
s
 =
 .5
[
@#
sw
,
@#
se
]
;
215    @#
e
 =
 .5
[
@#
ne
,
@#
se
]
;
216    @#
n
 =
 .5
[
@#
ne
,
@#
nw
]
;
217    @#
ne
 -
 @#
c
 =
 @#
c
 -
 @#
sw
 =
 (
@#
dx
,
@#
dy
)
 +
 .5
*
(
urcorner
 boxes_pic
@#
 -
 llcorner
 boxes_pic
@#
)
;
218    boxes_end
(
boxes_clear
,
@#
)
;
219enddef
;
220
221def
 boxes_path
(
suffix
 $
)
 =
222    $
.
sw
 --
 $
.
se
 --
 $
.
ne
 --
 $
.
nw
 --
 cycle
223enddef
;
224
225def
 boxes_size
(
suffix
 $
)
 =
226    if
 unknown
 $
.
dx
 :
 $
.
dx
 =
 defaultdx
;
 fi
227    if
 unknown
 $
.
dy
 :
 $
.
dy
 =
 defaultdy
;
 fi
228enddef
;
229
230vardef
 boxes_clear
(
suffix
 $
)
 =
231    boxes_n
 :
=
 str
 $
;
232    boxes_redeclare
(
numeric
)
 _n
.
sw
,
 _n
.
s
,
 _n
.
se
,
 _n
.
e
,
 _n
.
ne
,
 _n
.
n
,
 _n
.
nw
,
 _n
.
w
,
 _n
.
c
,
 _n
.
off
,
 _n
.
dx
,
 _n
.
dy
;
233enddef
;
234
235% Circular and oval boxes
236
237newinternal
 circmargin
;
 circmargin
 :
=
 2
bp
;
  % default clearance for picture corner
238
239vardef
 circleit
@#
(
text
 tt
)
 =
240    boxes_begin
(
"
boxes_the_circle
"
,
"
boxes_size_circle
"
,
@#
,
tt
)
;
241    boxes_generic_declare
(
pair
)
 _n
.
n
,
 _n
.
s
,
 _n
.
e
,
 _n
.
w
;
242    @#
e
 -
 @#
c
 =
 @#
c
 -
 @#
w
 =
 (
@#
dx
,
0
)
 +
 .5
*
(
lrcorner
 boxes_pic
@#
 -
 llcorner
 boxes_pic
@#
)
;
243    @#
n
 -
 @#
c
 =
 @#
c
 -
 @#
s
 =
 (
0
,
@#
dy
)
 +
 .5
*
(
ulcorner
 boxes_pic
@#
 -
 llcorner
 boxes_pic
@#
)
;
244    boxes_end
(
boxes_clear_circle
,
@#
)
;
245enddef
;
246
247def
 boxes_the_circle
 (
suffix
 $
)
 =
248    $
.
e
{
up
}
 ...
 $
.
n
{
left
}
 ...
 $
.
w
{
down
}
 ...
 $
.
s
{
right
}
 ...
 cycle
249enddef
;
250
251vardef
 boxes_clear_circle
 (
suffix
 $
)
 =
252    boxes_n
 :
=
 str
 $
;
253    boxes_redeclare
(
numeric
)
 _n
.
n
,
 _n
.
s
,
 _n
.
e
,
 _n
.
w
,
 _n
.
c
,
 _n
.
off
,
 _n
.
dx
,
 _n
.
dy
;
254enddef
;
255
256vardef
 boxes_size_circle
 (
suffix
 $
)
 =
257    save
 a_
,
 b_
;
258    (
a_
,
b_
)
 =
 .5
*
(
urcorner
 boxes_pic
$
 -
 llcorner
 boxes_pic
$
)
;
259    if
 unknown
 $
dx
 :
260        if
 unknown
 $
dy
 :
261            if
 unknown
(
$
dy
-
$
dx
)
 :
262                a_
 +
 $
dx
 =
 b_
 +
 $
dy
;
263            fi
264            if
 a_
 +
 $
dx
 =
 b_
 +
 $
dy
 :
265                a_
 +
 $
dx
 =
 a_
 ++
 b_
 +
 circmargin
;
266            else
 :
267                $
dx
 =
 boxes_select
(
max
(
a_
,
b_
 +
 $
dx
 -
 $
dy
)
,
 (
a_
 +
 d_
,
0
)
{
up
}
 ...
 (
0
,
b_
 +
 d_
 +
 $
dy
 -
 $
dx
)
{
left
}
)
;
268            fi
269        else
 :
270            $
dx
 =
 boxes_select
(
a_
,
 (
a_
 +
 d_
,
0
)
{
up
}
...
(
0
,
b_
 +
 $
dy
)
{
left
}
)
;
271        fi
272    elseif
 unknown
 $
dy
 :
273        $
dy
 =
 boxes_select
(
b_
,
 (
a_
 +
 $
dx
,
0
)
{
up
}
...
(
0
,
b_
 +
 d_
)
{
left
}
)
;
274    fi
275enddef
;
276
277vardef
 boxes_select
(
expr
 dhi
)
(
text
 tt
)
 =
278    save
 f_
,
 p_
;
 path
 p_
;
279    p_
 =
 origin
 ..
 (
a_
,
b_
)
 +
 circmargin
 *
 unitvector
(
a_
,
b_
)
;
280    vardef
 f_
 (
expr
 d_
)
 =
281        xpart
(
(
tt
)
 intersectiontimes
 p_
)
 >
=
 0
282    enddef
;
283    solve
 f_
(
0
,
 dhi
 +
 1.5
circmargin
)
284enddef
;
285
286def
 boxes_init_all
 =
287    boxes_boxjoin
(
)
;
288    save
 boxes_pic
,
 boxes_sproc
,
 boxes_pproc
;
289    def
 boxes_clear_all
 =
 enddef
;
290enddef
 ;
291
292def
 boxjoin
(
text
 t
)
 =
293    def
 boxes_prevbox
 =
 _
 enddef
;
294    def
 boxes_dojoin
(
suffix
 a
,
b
)
 =
 t
 enddef
;
295enddef
;
296
297extra_beginfig
 :
=
 extra_beginfig
 &
 "
boxes_init_all;
"
;
298extra_endfig
   :
=
 "
boxes_clear_all;
"
 &
 extra_endfig
;
299
300if
 makingfigure
 :
301    boxes_init_all
;
302fi
 ;
303
304% Rectangular boxes with rounded corners
305
306newinternal
 rbox_radius
 ;
 rbox_radius
 :
=
 8
bp
 ;
307
308vardef
 rboxit
@#
(
text
 tt
)
 =
309    boxes_begin
(
"
boxes_the_rounded
"
,
"
boxes_size
"
,
@#
,
tt
)
 ;
310    boxes_generic_declare
 (
pair
)
 _n
.
sw
,
 _n
.
s
,
 _n
.
se
,
 _n
.
e
,
 _n
.
ne
,
 _n
.
n
,
 _n
.
nw
,
 _n
.
w
 ;
311    0
 =
 xpart
(
@#
nw
 -
 @#
sw
)
 =
 ypart
(
@#
se
 -
 @#
sw
)
 ;
312    0
 =
 xpart
(
@#
ne
 -
 @#
se
)
 =
 ypart
(
@#
ne
 -
 @#
nw
)
 ;
313    @#
w
 =
 .5
[
@#
nw
,
@#
sw
]
 ;
314    @#
s
 =
 .5
[
@#
sw
,
@#
se
]
 ;
315    @#
e
 =
 .5
[
@#
ne
,
@#
se
]
 ;
316    @#
n
 =
 .5
[
@#
ne
,
@#
nw
]
 ;
317    @#
ne
 -
 @#
c
 =
 @#
c
 -
 @#
sw
 =
 (
@#
dx
,
@#
dy
)
 +
 .5
*
(
urcorner
 boxes_pic
@#
 -
 llcorner
 boxes_pic
@#
)
 ;
318    boxes_end
(
boxes_clear
,
@#
)
 ;
319enddef
;
320
321def
 boxes_the_rounded
(
suffix
 $
)
 =
322    save
 _r
 ;
 _r
 =
 min
(
rbox_radius
,
 .5
*
ypart
(
$
.
n
-
$
.
s
)
,
 .5
*
xpart
(
$
.
e
-
$
.
w
)
)
;
323    $
.
sw
 +
 (
_r
,
0
)
 {
right
}
 ..
 {
right
}
 $
.
se
 -
 (
_r
,
0
)
 ..
324    $
.
se
 +
 (
0
,
_r
)
    {
up
}
 ..
 {
up
}
    $
.
ne
 -
 (
0
,
_r
)
 ..
325    $
.
ne
 -
 (
_r
,
0
)
  {
left
}
 ..
 {
left
}
  $
.
nw
 +
 (
_r
,
0
)
 ..
326    $
.
nw
 -
 (
0
,
_r
)
  {
down
}
 ..
 {
down
}
  $
.
sw
 +
 (
0
,
_r
)
 ..
327    cycle
328enddef
;
329
330
Source Browser ?
