1
2
3
4
5
6
7
8
9
10
11
12
13string base_name, base_version ;
14
15base_name := "plain" ;
16base_version := "1.004 for metafun iv and xl" ;
17
18message "loading metafun, including plain.mp version " & base_version ;
19
20delimiters () ;
21
22def upto = step 1 until enddef ;
23def downto = step -1 until enddef ;
24
25def exitunless expr c =
26 exitif not c
27enddef ;
28
29let relax = \ ;
30let \\ = \ ;
31
32def [[ = [ [ enddef ;
33def ]] = ] ] enddef ;
34
35def -- =
36 {curl 1} .. {curl 1}
37enddef ;
38
39def --- =
40 .. tension infinity ..
41enddef ;
42
43def ... =
44 .. tension atleast 1 ..
45enddef ;
46
47def gobble primary g =
48enddef ;
49
50primarydef g gobbled gg =
51enddef ;
52
53def hide(text t) =
54 exitif numeric begingroup t ; endgroup ;
55enddef ;
56
57def ??? =
58 hide (
59 interim showstopping := 1 ;
60 showdependencies
61 )
62enddef ;
63
64def stop expr s =
65 message s ;
66 gobble readstring
67enddef ;
68
69warningcheck := 1 ;
70tracinglostchars := 1 ;
71
72def interact =
73 hide (
74 showstopping := 1 ;
75 tracingonline := 1 ;
76 )
77enddef ;
78
79def loggingall =
80 tracingcommands := 3 ;
81 tracingtitles := 1 ;
82 tracingequations := 1 ;
83 tracingcapsules := 1 ;
84 tracingspecs := 2 ;
85 tracingchoices := 1 ;
86 tracinglostchars := 1 ;
87 tracingstats := 1 ;
88 tracingmacros := 1 ;
89 tracingrestores := 1 ;
90enddef ;
91
92def tracingall =
93 tracingonline := 1 ;
94 showstopping := 1 ;
95 loggingall ;
96enddef ;
97
98def tracingnone =
99 tracingcommands := 0 ;
100 tracingtitles := 0 ;
101 tracingequations := 0 ;
102 tracingcapsules := 0 ;
103 tracingspecs := 0 ;
104 tracingchoices := 0 ;
105 tracinglostchars := 0 ;
106 tracingstats := 0 ;
107 tracingmacros := 0 ;
108 tracingrestores := 0 ;
109enddef ;
110
111
112
113vardef dashpattern(text t) =
114 save on, off, w ;
115 let on = _on_ ;
116 let off = _off_ ;
117 w = 0 ;
118 nullpicture t
119enddef ;
120
121tertiarydef p _on_ d =
122 begingroup save pic ;
123 picture pic;
124 pic = p ;
125 addto pic doublepath (w,w) .. (wd,w) ;
126 w := w d ;
127 pic shifted (0,d)
128 endgroup
129enddef ;
130
131tertiarydef p _off_ d =
132 begingroup w := w d ;
133 p shifted (0,d)
134 endgroup
135enddef ;
136
137
138
139
140
141newinternal eps, epsilon, infinity, _ ;
142
143eps := .00049 ;
144epsilon := 1256256 ;
145infinity := 4095.99998 ;
146_ := -1 ;
147
148
149
150newinternal mitered, rounded, beveled, butt, squared ;
151
152mitered := 0 ; rounded := 1 ; beveled := 2 ;
153butt := 0 ; rounded := 1 ; squared := 2 ;
154
155
156
157pair right, left, up, down, origin;
158
159origin = (0,0) ;
160up = down = (0,1) ;
161right = left = (1,0) ;
162
163
164
165path quartercircle, halfcircle, fullcircle, unitsquare ;
166
167fullcircle = makepath pencircle ;
168halfcircle = subpath (0,4) of fullcircle ;
169quartercircle = subpath (0,2) of fullcircle ;
170unitsquare = (0,0) -- (1,0) -- (1,1) -- (0,1) -- cycle ;
171
172
173
174transform identity ;
175
176for z=origin,right,up :
177 z transformed identity = z ;
178endfor
179
180
181
182color black, white, red, green, blue, cyan, magenta, yellow, background;
183
184black := (0,0,0) ;
185white := (1,1,1) ;
186red := (1,0,0) ;
187green := (0,1,0) ;
188blue := (0,0,1) ;
189cyan := (0,1,1) ;
190magenta := (1,0,1) ;
191yellow := (1,1,0) ;
192
193background := white ;
194
195let graypart = greypart ;
196let greycolor = numeric ;
197let graycolor = numeric ;
198
199
200
201newinternal nocolormodel ; nocolormodel := 1 ;
202newinternal greycolormodel ; greycolormodel := 3 ;
203newinternal graycolormodel ; graycolormodel := 3 ;
204newinternal rgbcolormodel ; rgbcolormodel := 5 ;
205newinternal cmykcolormodel ; cmykcolormodel := 7 ;
206
207def colorpart primary t =
208 if colormodel t = cmykcolormodel:
209 (cyanpart t, magentapart t, yellowpart t, blackpart t)
210 elseif colormodel t = rgbcolormodel :
211 (redpart t, greenpart t, bluepart t)
212 elseif colormodel t = graycolormodel :
213 (greypart t)
214 elseif colormodel t = nocolormodel :
215 false
216 elseif defaultcolormodel = cmykcolormodel :
217 (0,0,0,1)
218 elseif defaultcolormodel = rgbcolormodel :
219 black
220 elseif defaultcolormodel = graycolormodel :
221 0
222 else :
223 false
224 fi
225enddef ;
226
227
228
229picture blankpicture, evenly, withdots ;
230
231blankpicture = nullpicture ;
232evenly = dashpattern(on 3 off 3) ;
233withdots = dashpattern(off 2.5 on 0 off 2.5) ;
234
235
236
237string ditto, EOF ;
238
239ditto = char 34 ;
240EOF = char 0 ;
241
242
243
244pen pensquare, penrazor, penspec ;
245
246pensquare = makepen(unitsquare shifted (.5,.5)) ;
247penrazor = makepen((-.5,0) -- (.5,0) -- cycle) ;
248penspec = pensquare scaled eps ;
249
250def penspeck = penspec enddef ;
251
252
253
254vardef whatever =
255 save ? ;
256 ?
257enddef ;
258
259
260
261let abs = length ;
262
263vardef round primary u =
264 if numeric u :
265 floor(u+.5)
266 elseif pair u :
267 (floor(xpart u+.5), floor(ypart u+.5))
268 elseif path u :
269
270 for i=0 upto length u-1 :
271 round(point i of u) ..
272 controls round(postcontrol i of u) and round(precontrol i+1 of u) ..
273 endfor
274 if cycle u : cycle else : point infinity of u fi
275 else :
276 u
277 fi
278enddef ;
279
280vardef ceiling primary x =
281 floor(x)
282enddef ;
283
284vardef byte primary s =
285 if string s :
286 ASCII
287 fi s
288enddef ;
289
290vardef dir primary d =
291 right rotated d
292enddef ;
293
294vardef unitvector primary z =
295 zabs z
296enddef ;
297
298vardef inverse primary T =
299 transform T_ ;
300 T_ transformed T = identity ;
301 T_
302enddef ;
303
304vardef counterclockwise primary c =
305 if turningnumber c <= 0 :
306 reverse
307 fi c
308enddef ;
309
310vardef tensepath expr r =
311 for k=0 upto length r 1 :
312 point k of r ---
313 endfor
314 if cycle r :
315 cycle
316 else :
317 point infinity of r
318 fi
319enddef ;
320
321vardef center primary p =
322 .5[llcorner p, urcorner p]
323enddef ;
324
325
326
327primarydef x mod y =
328 (xyfloor(xy))
329enddef ;
330
331primarydef x div y =
332 floor(xy)
333enddef ;
334
335primarydef w dotprod z =
336 (xpart w xpart z ypart w ypart z)
337enddef ;
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372primarydef xy =
373 if y = 0 :
374 1
375 elseif x = 0 :
376 0
377 elseif y < 0 :
378 1(xy)
379 elseif y = 1 :
380 x
381 elseif y = 2 :
382 xx
383 elseif y = 3 :
384 xxx
385 else :
386 takepower y of x
387 fi
388enddef ;
389
390def takepower expr y of x =
391 if y=0 :
392 1
393 elseif x=0 :
394 0
395 else :
396 if y = floor y :
397 1
398 if y >= 0 :
399 for n=1 upto y :
400 x
401 endfor
402 else :
403 for n=-1 downto y :
404 x
405 endfor
406 fi
407 elseif x>0 :
408 mexp(ymlog x)
409 else :
410 mexp(ymlog x)
411 fi
412 fi
413enddef ;
414
415vardef direction expr t of p =
416 postcontrol t of p precontrol t of p
417enddef ;
418
419vardef directionpoint expr z of p =
420 a_ := directiontime z of p ;
421 if a_ < 0 :
422 errmessage("The direction doesn't occur") ;
423 fi
424 point a_ of p
425enddef ;
426
427secondarydef p intersectionpoint q =
428 begingroup
429 save x_, y_ ;
430 (x_,y_) = p intersectiontimes q ;
431 if x_ < 0 :
432 errmessage("The paths don't intersect") ;
433 origin
434 else :
435 .5[point x_ of p, point y_ of q]
436 fi
437 endgroup
438enddef ;
439
440tertiarydef p softjoin q =
441 begingroup
442 c_ := fullcircle scaled 2join_radius shifted point 0 of q ;
443 a_ := ypart(c_ intersectiontimes p) ;
444 b_ := ypart(c_ intersectiontimes q) ;
445 if a_ < 0 :
446 point 0 of p{direction 0 of p}
447 else :
448 subpath(0,a_) of p
449 fi
450 ...
451 if b_ < 0 :
452 {direction infinity of q} point infinity of q
453 else :
454 subpath(b_,infinity) of q
455 fi
456 endgroup
457enddef ;
458
459newinternal join_radius, a_, b_ ; path c_ ;
460
461path cuttings ;
462
463tertiarydef a cutbefore b =
464 begingroup
465 save t ;
466 (t, whatever) = a intersectiontimes b ;
467 if t < 0 :
468 cuttings := point 0 of a ;
469 a
470 else :
471 cuttings := subpath (0,t) of a ;
472 subpath (t,length a) of a
473 fi
474 endgroup
475enddef ;
476
477tertiarydef a cutafter b =
478 reverse (reverse a cutbefore b)
479 hide(cuttings := reverse cuttings)
480enddef ;
481
482
483
484vardef incr suffix $ = $ := $ 1 ; $ enddef ;
485vardef decr suffix $ = $ := $ 1 ; $ enddef ;
486
487def reflectedabout(expr w,z) =
488 transformed
489 begingroup
490 transform T_ ;
491 w transformed T_ = w ;
492 z transformed T_ = z ;
493 xxpart T_ = yypart T_ ;
494 xypart T_ = yxpart T_ ;
495 T_
496 endgroup
497enddef ;
498
499def rotatedaround(expr z, d) =
500 shifted z rotated d shifted z
501enddef ;
502
503let rotatedabout = rotatedaround ;
504
505vardef min(expr u)(text t) =
506 save u_ ;
507 setu_ u ;
508 for uu = t :
509 if uu < u_ :
510 u_ := uu ;
511 fi
512 endfor
513 u_
514enddef ;
515
516vardef max(expr u)(text t) =
517 save u_ ;
518 setu_ u ;
519 for uu = t :
520 if uu > u_ :
521 u_ := uu ;
522 fi
523 endfor
524 u_
525enddef ;
526
527def setu_ primary u =
528 if pair u :
529 pair u_
530 elseif string u :
531 string u_
532 fi ;
533 u_=u
534enddef ;
535
536def flex(text t) =
537 hide (
538 n_ := 0 ;
539 for z=t :
540 z_[incr n_] := z ;
541 endfor
542 dz_ := z_[n_]z_1
543 )
544 z_1 for k=2 upto n_-1 :
545 ... z_[k]{dz_}
546 endfor ... z_[n_]
547enddef ;
548
549newinternal n_; pair z_[],dz_;
550
551def superellipse(expr r,t,l,b,s) =
552 r { up } ... (s[xpart t,xpart r],s[ypart r,ypart t]) { tr } ...
553 t { left } ... (s[xpart t,xpart l],s[ypart l,ypart t]) { lt } ...
554 l { down } ... (s[xpart b,xpart l],s[ypart l,ypart b]) { bl } ...
555 b { right } ... (s[xpart b,xpart r],s[ypart r,ypart b]) { rb } ... cycle enddef ;
556
557vardef interpath(expr a,p,q) =
558 for t=0 upto length p-1 :
559 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] ..
560 endfor
561 if cycle p :
562 cycle
563 else :
564 a[point infinity of p, point infinity of q]
565 fi
566enddef ;
567
568vardef solve@#(expr true_x,false_x)=
569 tx_:=true_x; fx_:=false_x;
570 forever :
571 x_ := .5[tx_,fx_] ;
572 exitif abs(tx_fx_) <= tolerance ;
573 if @#(x_) :
574 tx_
575 else :
576 fx_
577 fi := x_ ;
578 endfor
579 x_
580enddef ;
581
582newinternal tolerance, tx_, fx_, x_ ;
583
584tolerance := .01 ;
585
586vardef buildcycle(text ll) =
587 save ta_, tb_, k_, i_, pp_ ; path pp_[] ;
588 k_ = 0 ;
589 for q=ll :
590 pp_[incr k_] = q ;
591 endfor
592 i_ = k_ ;
593 for i=1 upto k_ :
594 (ta_[i], length pp_[i_]tb_[i_]) = pp_[i] intersectiontimes reverse pp_[i_] ;
595 if ta_[i]<0 :
596 errmessage("Paths "& decimal i &" and "& decimal i_ &" don't intersect") ;
597 fi
598 i_ := i;
599 endfor
600 for i=1 upto k_ :
601 subpath (ta_[i],tb_[i]) of pp_[i] ..
602 endfor
603 cycle
604enddef ;
605
606
607
608mm := 2.83464 ;
609pt := 0.99626 ;
610dd := 1.06601 ;
611bp := 1 ;
612cm := 28.34645 ;
613pc := 11.95517 ;
614cc := 12.79213 ;
615in := 72 ;
616
617vardef magstep primary m =
618 mexp(46.67432m)
619enddef ;
620
621
622
623def drawoptions(text t) =
624 def _op_ = t enddef
625enddef ;
626
627
628
629linejoin := rounded ;
630linecap := rounded ;
631miterlimit := 10 ;
632
633drawoptions() ;
634
635pen currentpen ;
636picture currentpicture ;
637
638def fill expr c =
639 addto currentpicture contour c _op_
640enddef ;
641
642def draw expr p =
643 addto currentpicture
644 if picture p :
645 also p
646 else :
647 doublepath p withpen currentpen
648 fi
649 _op_
650enddef ;
651
652def filldraw expr c =
653 addto currentpicture contour c withpen currentpen _op_
654enddef ;
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680def drawdot expr p =
681 if pair p :
682 addto currentpicture doublepath p withpen currentpen _op_
683 else :
684 errmessage("drawdot only accepts a pair expression")
685 fi
686enddef ;
687
688def unfill expr c = fill c withcolor background enddef ;
689def undraw expr p = draw p withcolor background enddef ;
690def unfilldraw expr c = filldraw c withcolor background enddef ;
691def undrawdot expr z = drawdot z withcolor background enddef ;
692
693def erase text t =
694 def _e_ =
695 withcolor background hide(def _e_ = enddef ;)
696 enddef ;
697 t _e_
698enddef ;
699
700def _e_ = enddef ;
701
702def cutdraw text t =
703 begingroup
704 interim linecap := butt ;
705 draw t _e_ ;
706 endgroup
707enddef ;
708
709vardef image(text t) =
710 save currentpicture ;
711 picture currentpicture ;
712 currentpicture := nullpicture ;
713 t ;
714 currentpicture
715enddef ;
716
717def pickup secondary q =
718 if numeric q :
719 numeric_pickup_
720 else :
721 pen_pickup_
722 fi q
723enddef ;
724
725def numeric_pickup_ primary q =
726 if unknown pen_[q] :
727 errmessage "Unknown pen" ;
728 clearpen
729 else :
730 currentpen := pen_ [q] ;
731 pen_lft := pen_lft_[q] ;
732 pen_rt := pen_rt_ [q] ;
733 pen_top := pen_top_[q] ;
734 pen_bot := pen_bot_[q] ;
735 currentpen_path := pen_path_[q]
736 fi ;
737enddef ;
738
739def pen_pickup_ primary q =
740 currentpen := q ;
741 pen_lft := xpart penoffset down of currentpen ;
742 pen_rt := xpart penoffset up of currentpen ;
743 pen_top := ypart penoffset left of currentpen ;
744 pen_bot := ypart penoffset right of currentpen ;
745 path currentpen_path ;
746enddef ;
747
748newinternal pen_lft, pen_rt, pen_top, pen_bot, pen_count_ ;
749
750vardef savepen =
751 pen_[incr pen_count_] = currentpen ;
752 pen_lft_ [pen_count_] = pen_lft ;
753 pen_rt_ [pen_count_] = pen_rt ;
754 pen_top_ [pen_count_] = pen_top ;
755 pen_bot_ [pen_count_] = pen_bot ;
756 pen_path_[pen_count_] = currentpen_path ;
757 pen_count_
758enddef ;
759
760def clearpen =
761 currentpen := nullpen;
762 pen_lft := pen_rt := pen_top := pen_bot := 0 ;
763 path currentpen_path ;
764enddef ;
765
766def clear_pen_memory =
767 pen_count_ := 0 ;
768 numeric pen_lft_[], pen_rt_[], pen_top_[], pen_bot_[] ;
769 pen currentpen, pen_[];
770 path currentpen_path, pen_path_[] ;
771enddef ;
772
773vardef lft primary x = x if pair x: (pen_lft,0) else: pen_lft fi enddef ;
774vardef rt primary x = x if pair x: (pen_rt,0) else: pen_rt fi enddef ;
775vardef top primary y = y if pair y: (0,pen_top) else: pen_top fi enddef ;
776vardef bot primary y = y if pair y: (0,pen_bot) else: pen_bot fi enddef ;
777
778vardef penpos@#(expr b,d) =
779 (x@#rx@#l,y@#ry@#l) = (b,0) rotated d ;
780 x@# = .5(x@#lx@#r) ;
781 y@# = .5(y@#ly@#r) ;
782enddef ;
783
784path path_.l, path_.r ;
785
786def penstroke text t =
787 forsuffixes e = l, r :
788 path_.e := t ;
789 endfor
790 fill path_.l -- reverse path_.r -- cycle
791enddef ;
792
793
794
795newinternal ahlength, ahangle ;
796
797ahlength := 4 ;
798ahangle := 45 ;
799
800vardef arrowhead expr p =
801 save q, e ; path q ; pair e ;
802 e = point length p of p ;
803 q = gobble(p shifted e cutafter makepath(pencircle scaled 2ahlength)) cuttings ;
804 (q rotated .5ahangle & reverse q rotated -.5ahangle -- cycle) shifted e
805enddef ;
806
807path _apth ;
808
809def drawarrow expr p = _apth := p ; _finarr enddef ;
810def drawdblarrow expr p = _apth := p ; _findarr enddef ;
811
812def _finarr text t =
813 draw _apth t ;
814 filldraw arrowhead _apth t
815enddef ;
816
817def _findarr text t =
818 draw _apth t ;
819 filldraw arrowhead _apth withpen currentpen t ;
820 filldraw arrowhead reverse _apth withpen currentpen t ;
821enddef ;
822
823
824
825newinternal bboxmargin ;
826
827bboxmargin := 2bp ;
828
829vardef bbox primary p =
830 llcorner p ( bboxmargin, bboxmargin) --
831 lrcorner p ( bboxmargin,bboxmargin) --
832 urcorner p ( bboxmargin, bboxmargin) --
833 ulcorner p (bboxmargin, bboxmargin) -- cycle
834enddef ;
835
836string defaultfont ; newinternal defaultscale, labeloffset ;
837
838defaultfont := "cmr10" ;
839defaultscale := 1 ;
840labeloffset := 3bp ;
841
842vardef thelabel@#(expr s,z) =
843 save p ; picture p ;
844 if picture s :
845 p = s
846 else :
847 p = s infont defaultfont scaled defaultscale
848 fi ;
849 p shifted (z labeloffsetlaboff@# ( labxf@#lrcorner p labyf@#ulcorner p (1labxf@#labyf@#)llcorner p) )
850enddef ;
851
852def label =
853 draw thelabel
854enddef ;
855
856newinternal dotlabeldiam ;
857
858dotlabeldiam := 3bp ;
859
860vardef dotlabel@#(expr s,z) text t_ =
861 label@#(s,z) t_ ;
862
863 interim linecap := rounded ;
864 draw z withpen pencircle scaled dotlabeldiam t_ ;
865enddef ;
866
867def makelabel =
868 dotlabel
869enddef ;
870
871
872
873pair laboff, laboff.lft, laboff.rt, laboff.top, laboff.bot ;
874pair laboff.ulft, laboff.llft, laboff.urt, laboff.lrt ;
875
876laboff = (0,0) ; labxf = .5 ; labyf = .5 ;
877laboff.lft = (-1,0) ; labxf.lft = 1 ; labyf.lft = .5 ;
878laboff.rt = (1,0) ; labxf.rt = 0 ; labyf.rt = .5 ;
879laboff.bot = (0,-1) ; labxf.bot = .5 ; labyf.bot = 1 ;
880laboff.top = (0,1) ; labxf.top = .5 ; labyf.top = 0 ;
881laboff.ulft = (-.7,.7) ; labxf.ulft = 1 ; labyf.ulft = 0 ;
882laboff.urt = (.7,.7) ; labxf.urt = 0 ; labyf.urt = 0 ;
883laboff.llft = (.7,.7) ; labxf.llft = 1 ; labyf.llft = 1 ;
884laboff.lrt = (.7,-.7) ; labxf.lrt = 0 ; labyf.lrt = 1 ;
885
886vardef labels@#(text t) =
887 forsuffixes $=t :
888 label@#(str$,z$) ;
889 endfor
890enddef ;
891
892
893
894vardef dotlabels@#(text t) =
895 forsuffixes $=t:
896 dotlabel@#(str$,z$) ;
897 endfor
898enddef ;
899
900vardef penlabels@#(text t) =
901 forsuffixes $$=l,,r :
902 forsuffixes $=t :
903 makelabel@#(str$.$$,z$.$$) ;
904 endfor
905 endfor
906enddef ;
907
908
909
910def range expr x =
911 _numtok_[x]
912enddef ;
913
914def _numtok_ suffix x =
915 x
916enddef ;
917
918tertiarydef m thru n =
919 m for x=m+1 step 1 until n :
920 , _numtok_[x]
921 endfor
922enddef ;
923
924
925
926string extra_beginfig, extra_endfig ;
927
928extra_beginfig := "" ;
929extra_endfig := "" ;
930
931boolean makingfigure ; makingfigure := false ;
932numeric stacking ; stacking := 0 ;
933
934def beginfig(expr c) =
935 begingroup
936 save makingfigure ; boolean makingfigure ;
937 save stacking ; numeric stacking;
938 charcode := c ;
939 clearxy ;
940 clearit ;
941 clearpen ;
942 pickup defaultpen ;
943 drawoptions() ;
944 stacking := 0 ;
945 makingfigure := true;
946 scantokens extra_beginfig ;
947enddef ;
948
949def endfig =
950 ;
951 scantokens extra_endfig ;
952 shipit ;
953 endgroup
954enddef ;
955
956
957
958vardef z@# =
959 (x@#,y@#)
960enddef ;
961
962def clearxy =
963 save x, y
964enddef ;
965
966def clearit =
967 currentpicture := nullpicture
968enddef ;
969
970def shipit =
971 shipout currentpicture
972enddef ;
973
974let bye = end ;
975outer end, bye ;
976
977clear_pen_memory ;
978clearit ;
979
980
981
982newinternal defaultpen ;
983
984pickup pencircle scaled .5bp ;
985
986defaultpen := savepen ;
987 |