1
2
3
4
5
6
7
8
9
10
11
12
13
14if known metafun_loaded_tool : endinput ; fi ;
15
16newinternal boolean metafun_loaded_tool ; metafun_loaded_tool := true ; immutable metafun_loaded_tool ;
17
18let @## = @# ;
19
20let noexpand = quote ;
21
22permanent @##, noexpand ;
23
24
25
26
27
28
29
30
31if not known mpversion : string mpversion ; mpversion := "0.641" ; fi ;
32
33
34
35newinternal metapostversion ; metapostversion := 3.0 ; permanent metapostversion ;
36
37
38
39warningcheck := 0 ;
40
41
42
43def nothing = enddef ;
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66string space ; space := char 32 ;
67string percent ; percent := char 37 ;
68string crlf ; crlf := char 10 & char 13 ;
69string dquote ; dquote := char 34 ;
70
71
72
73
74
75
76permanent space, percent, crlf, dquote ;
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93let triplet = rgbcolor ;
94let quadruplet = cmykcolor ;
95
96permanent triplet, quadruplet ;
97
98
99
100vardef 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 (1mfun_labxf@#mfun_labyf@#) llcorner p
111 )
112 fi
113enddef ;
114
115permanent image ;
116
117
118
119def 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 ;
139enddef ;
140
141permanent dispose ;
142
143
144
145let grayscale = graycolor ;
146let greyscale = greycolor ;
147
148vardef 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
159 fi
160enddef ;
161
162vardef colorlike(text c) text v =
163 save temp_p ; picture temp_p ;
164 forsuffixes i=v :
165 temp_p := image(draw origin withcolor c ;) ;
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 ;
174enddef ;
175
176permanent nocolormodel, greycolormodel, graycolormodel, rgbcolormodel, cmykcolormodel,
177 greyscale, grayscale, colorpart, colorlike ;
178
179
180
181vardef ddecimal primary p =
182 decimal xpart p & " " & decimal ypart p
183enddef ;
184
185vardef dddecimal primary c =
186 decimal redpart c & " " & decimal greenpart c & " " & decimal bluepart c
187enddef ;
188
189vardef ddddecimal primary c =
190 decimal cyanpart c & " " & decimal magentapart c & " " & decimal yellowpart c & " " & decimal blackpart c
191enddef ;
192
193vardef 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
203enddef ;
204
205vardef 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
212enddef ;
213
214permanent decimal, ddecimal, dddecimal, ddddecimal, colordecimals, colordecimalslist ;
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243boolean savingdata ; savingdata := false ;
244boolean savingdatadone ; savingdatadone := false ;
245
246def savedata expr txt =
247 lua.mp.mf_save_data(txt);
248enddef ;
249
250def startsavingdata =
251 lua.mp.mf_start_saving_data();
252enddef ;
253
254def stopsavingdata =
255 lua.mp.mf_stop_saving_data() ;
256enddef ;
257
258def finishsavingdata =
259
260enddef ;
261
262
263
264
265
266
267def newcolor text v = forsuffixes i=v : save i ; color i ; endfor ; enddef ;
268def newrgbcolor text v = forsuffixes i=v : save i ; rgbcolor i ; endfor ; enddef ;
269def newcmykcolor text v = forsuffixes i=v : save i ; cmykcolor i ; endfor ; enddef ;
270def newnumeric text v = forsuffixes i=v : save i ; numeric i ; endfor ; enddef ;
271def newboolean text v = forsuffixes i=v : save i ; boolean i ; endfor ; enddef ;
272def newtransform text v = forsuffixes i=v : save i ; transform i ; endfor ; enddef ;
273def newpath text v = forsuffixes i=v : save i ; path i ; endfor ; enddef ;
274def newpicture text v = forsuffixes i=v : save i ; picture i ; endfor ; enddef ;
275def newstring text v = forsuffixes i=v : save i ; string i ; endfor ; enddef ;
276def newpair text v = forsuffixes i=v : save i ; pair i ; endfor ; enddef ;
277
278permanent newcolor, newrgbcolor, newcmykcolor, newnumeric, newboolean, newtransform, newpath, newpicture, newstring, newpair ;
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310path mfun_boundingbox_stack[] ;
311numeric mfun_boundingbox_stack_depth ;
312
313mfun_boundingbox_stack_depth := 0 ;
314
315def pushboundingbox text p =
316 mfun_boundingbox_stack_depth := mfun_boundingbox_stack_depth 1 ;
317 mfun_boundingbox_stack[mfun_boundingbox_stack_depth] := boundingbox p ;
318enddef ;
319
320def 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 ;
324enddef ;
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360let boundingbox = corners ;
361
362vardef innerboundingbox primary p =
363 save b ; path b ; b := corners p ;
364 top rt point 0 of b --
365 top lft point 1 of b --
366 bot lft point 2 of b --
367 bot rt point 3 of b -- cycle
368enddef;
369
370vardef outerboundingbox primary p =
371 save b ; path b ; b := corners p ;
372 bot lft point 0 of b --
373 bot rt point 1 of b --
374 top rt point 2 of b --
375 top lft point 3 of b -- cycle
376enddef;
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397vardef boundingradius primary p =
398 if picture p :
399 pair c ; c := center p;
400 max(
401 abs((llcorner p) shifted c),
402 abs((lrcorner p) shifted c),
403 abs((urcorner p) shifted c),
404 abs((ulcorner p) shifted c)
405 )
406 elseif pen p :
407 boundingradius image(draw makepath p ;)
408 elseif path p :
409 boundingradius image(draw p ;)
410 fi
411enddef ;
412
413vardef boundingcircle primary p =
414 fullcircle scaled 2boundingradius p shifted center p
415enddef ;
416
417vardef boundingpoint@#(expr p) =
418 if picture p :
419 ( mfun_labxf@# ulcorner p
420 mfun_labyf@# lrcorner p
421 (1mfun_labxf@#mfun_labyf@#)urcorner p)
422 elseif path p :
423 boundingpoint@#(image(draw p ;))
424
425
426
427
428 fi
429enddef ;
430
431permanent pushboundingbox, popboundingbox, boundingbox, innerboundingbox, outerboundingbox,
432 boundingradius, boundingcircle, boundingpoint ;
433
434
435
436def mirrored primary a =
437 a scaled -1
438enddef ;
439
440primarydef a mirroredabout b =
441 (a shifted b) scaled -1 shifted b
442enddef ;
443
444permanent mirrored, mirroredabout ;
445
446
447
448
449
450pi := 3.14159265358979323846264338327950288419716939937510 ;
451radian := 180pi ;
452
453permanent pi, radian ;
454
455
456
457vardef sqr primary x = xx enddef ;
458vardef log primary x = if x=0: 0 else: mlog(x)mlog(10) fi enddef ;
459vardef ln primary x = if x=0: 0 else: mlog(x)256 fi enddef ;
460vardef exp primary x = (mexp 256)x enddef ;
461vardef inv primary x = if x=0: 0 else: x-1 fi enddef ;
462
463vardef pow (expr x,p) = xp enddef ;
464
465vardef tand primary x = sind(x)cosd(x) enddef ;
466vardef cotd primary x = cosd(x)sind(x) enddef ;
467
468
469
470
471vardef cot primary x = cos(x)sin(x) enddef ;
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491primarydef a zmod b = (((b2 a) mod b) b2) enddef ;
492
493permanent sqr, log, ln, exp, inv, pow, tand, cotd, cot, zmod ;
494
495
496
497def undashed =
498 dashed nullpicture
499enddef ;
500
501permanent undashed ;
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561stripe_n := 10;
562stripe_slot := 3;
563stripe_gap := 5;
564stripe_angle := 45;
565
566def mfun_tool_striped_number_action text extra =
567 for i = 1used_n step 1used_n until 1 :
568 draw point (1i) of bounds -- point (3i) of bounds withpen pencircle scaled penwidth extra ;
569 endfor ;
570 for i = 0 step 1used_n until 1 :
571 draw point (3i) of bounds -- point (1i) of bounds withpen pencircle scaled penwidth extra ;
572 endfor ;
573enddef ;
574
575def mfun_tool_striped_set_options(expr option) =
576 save isinner, swapped, isdrawn ;
577 boolean isinner, swapped, isdrawn ;
578 if option = 0 :
579 isdrawn := true;
580 isinner := true ;
581 swapped := false ;
582 elseif option = 1 :
583 isdrawn := false ;
584 isinner := false ;
585 swapped := false ;
586 elseif option = 2 :
587 isdrawn := false ;
588 isinner := true ;
589 swapped := false ;
590 elseif option = 3 :
591 isdrawn := false ;
592 isinner := false ;
593 swapped := true ;
594 elseif option = 4 :
595 isdrawn := false ;
596 isinner := true ;
597 swapped := true ;
598 else :
599 isdrawn := false ;
600 isinner := false ;
601 swapped := false ;
602 fi ;
603enddef ;
604
605vardef mfun_tool_striped_number(expr option, p, asked_n, asked_slot) text extra =
606
607 begingroup ;
608 save pattern, shape, bounds, penwidth, used_n, used_slot ;
609 picture pattern, shape ; path bounds ; numeric used_s, used_slot ;
610 mfun_tool_striped_set_options(option) ;
611 used_slot := if asked_slot = 0 : stripe_slot else : asked_slot fi ;
612 used_n := if asked_n = 0 : stripe_n else : asked_n fi ;
613 shape := image(draw p) ;
614 bounds := boundingbox shape ;
615 penwidth := min(ypart urcorner shape ypart llcorner shape, xpart urcorner shape xpart llcorner shape) (used_slot used_n) ;
616 pattern := image (
617 if isinner :
618 mfun_tool_striped_number_action extra ;
619 for s within shape :
620 if stroked s or filled s :
621 clip currentpicture to pathpart s ;
622 fi
623 endfor ;
624 else :
625 for s within shape :
626 if stroked s or filled s :
627 draw image (
628 mfun_tool_striped_number_action extra ;
629 clip currentpicture to pathpart s ;
630 ) ;
631 fi ;
632 endfor ;
633 fi ;
634 ) ;
635 if isdrawn :
636 addto currentpicture also pattern ;
637 elseif swapped :
638 addto currentpicture also shape ;
639 addto currentpicture also pattern ;
640 else :
641 addto currentpicture also pattern ;
642 addto currentpicture also shape ;
643 fi ;
644 endgroup ;
645
646enddef ;
647
648
649
650
651
652
653
654
655def mfun_tool_striped_angle_action text extra =
656 for i = minimum -.5used_gap step used_gap until maximum :
657 nodraw (minimum,i) -- (maximum,i) extra ;
658 endfor ;
659 dodraw origin ;
660 currentpicture := currentpicture rotated used_angle ;
661enddef ;
662
663vardef mfun_tool_striped_angle(expr option, p, asked_angle, asked_gap) text extra =
664
665 begingroup ;
666 save pattern, shape, mask, maximum, minimum, centrum, used_angle, used_gap ;
667 picture pattern, shape, mask ; numeric maximum, minimum ; pair centrum ; numeric used_angle, used_gap ;
668 mfun_tool_striped_set_options(option) ;
669 used_angle := if asked_angle = 0 : stripe_angle else : asked_angle fi ;
670 used_gap := if asked_gap = 0 : stripe_gap else : asked_gap fi ;
671 shape := image(draw p) ;
672
673 centrum := llcorner shape ;
674 shape := shape shifted centrum ;
675 mask := shape rotated used_angle ;
676 maximum := max (xpart llcorner mask, xpart urcorner mask, ypart llcorner mask, ypart urcorner mask) ;
677 minimum := min (xpart llcorner mask, xpart urcorner mask, ypart llcorner mask, ypart urcorner mask) ;
678
679 maximum := maximum max(xpart urcorner shape, ypart urcorner shape);
680 minimum := minimum max(xpart urcorner shape, ypart urcorner shape);
681
682 pattern := image (
683 if isinner :
684 mfun_tool_striped_angle_action extra ;
685 for s within shape :
686 if stroked s or filled s :
687 clip currentpicture to pathpart s ;
688 fi
689 endfor ;
690 else :
691 for s within shape :
692 if stroked s or filled s :
693 draw image (
694 mfun_tool_striped_angle_action extra ;
695 clip currentpicture to pathpart s ;
696 ) ;
697 fi ;
698 endfor ;
699 fi ;
700 ) ;
701 if isdrawn :
702 addto currentpicture also pattern ;
703 elseif swapped :
704 addto currentpicture also shape ;
705 addto currentpicture also pattern ;
706 else :
707 addto currentpicture also pattern ;
708 addto currentpicture also shape ;
709 fi ;
710 currentpicture := currentpicture shifted centrum ;
711 endgroup ;
712
713enddef;
714
715newinternal striped_normal_inner ; striped_normal_inner := 1 ;
716newinternal striped_reverse_inner ; striped_reverse_inner := 2 ;
717newinternal striped_normal_outer ; striped_normal_outer := 3 ;
718newinternal striped_reverse_outer ; striped_reverse_outer := 4 ;
719
720secondarydef p anglestriped s =
721
722 image(mfun_tool_striped_angle(redpart s,p,greenpart s,bluepart s))
723enddef ;
724
725secondarydef p numberstriped s =
726
727 image(mfun_tool_striped_number(redpart s,p,greenpart s,bluepart s))
728enddef ;
729
730
731
732def stripe_path_n (text asked_spec) (text asked_draw) expr asked_path =
733 do_stripe_path_n (asked_spec) (asked_draw) (asked_path)
734enddef;
735
736def do_stripe_path_n (text asked_spec) (text asked_draw) (expr asked_path) text asked_text =
737 draw image(asked_draw asked_path asked_text) numberstriped(3,0,0) asked_spec ;
738enddef ;
739
740def stripe_path_a (text asked_spec) (text asked_draw) expr asked_path =
741 do_stripe_path_a (asked_spec) (asked_draw) (asked_path)
742enddef;
743
744def do_stripe_path_a (text asked_spec) (text asked_draw) (expr asked_path) text asked_text =
745 draw image(asked_draw asked_path asked_text) anglestriped(3,0,0) asked_spec ;
746enddef ;
747
748
749
750
751
752
753vardef hatch(expr p, a, d) =
754 save thestripe, diag, b ; picture thestripe ; numeric diag ; path b ;
755 b := boundingbox p;
756 diag := 0.55 ( abs((urcorner b) (llcorner b)) ) ;
757 thestripe := image (
758 draw (diag,0) -- (diag, 0) &&
759 for i = d step d until diag:
760 (diag, i) -- (diag, i) &&
761 (diag,i) -- (diag,i) &&
762 endfor nocycle
763 withpen currentpen ;
764 ) ;
765 thestripe := thestripe shifted center b ;
766 thestripe := thestripe rotatedaround(center b, a) ;
767 clip thestripe to p ;
768 thestripe
769enddef ;
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784primarydef p xsized w =
785 begingroup
786 save r, l ; pair r;
787 r := xrange p ;
788 l := ypart r xpart r ;
789 (p if (l > 0) and (w > 0) : scaled (wl) fi)
790 endgroup
791enddef ;
792
793
794
795
796
797
798
799
800
801
802
803
804primarydef p ysized h =
805 begingroup
806 save r, l ; pair r ;
807 r := yrange p ;
808 l := ypart r xpart r ;
809 (p if (l > 0) and (h > 0) : scaled (hl) fi)
810 endgroup
811enddef ;
812
813
814
815
816
817
818
819
820
821
822
823
824primarydef p xysized s =
825 begingroup
826 save wh, w, h, b ; pair wh ; path b;
827 b := corners p ;
828 w := xpart point 1 of b xpart point 0 of b ;
829 h := ypart point 2 of b ypart point 1 of b ;
830 wh := paired (s) ;
831 p
832 if (w > 0) and (h > 0) :
833 if xpart wh > 0 : xscaled (xpart whw) fi
834 if ypart wh > 0 : yscaled (ypart whh) fi
835 fi
836 endgroup
837enddef ;
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852let sized = xysized ;
853
854permanent xsized, ysized, xysized, sized ;
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875primarydef p xynormalized s =
876 begingroup save w, h, b ; path b;
877 b := corners p ;
878 w := xpart point 1 of b xpart point 0 of b ;
879 h := ypart point 2 of b ypart point 1 of b ;
880 if (w > 0) and (h > 0) :
881 save t, wh ; transform t ; pair wh ;
882 wh := paired (s) ;
883 t := identity
884 shifted llcorner p
885 if xpart wh > 0 : xscaled (xpart whw) fi
886 if ypart wh > 0 : yscaled (ypart whh) fi
887 ;
888 p transformed t
889 else :
890 p
891 fi
892 endgroup
893enddef ;
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911primarydef p xnormalized s =
912 begingroup save h, r ; pair r ;
913 r := xrange p ;
914 w := ypart r xpart r ;
915 if (w > 0) :
916 save t ; transform t ;
917 t := identity
918 shifted llcorner p
919 if s > 0 : xscaled (sw) fi
920 ;
921 p transformed t
922 else :
923 p
924 fi
925 endgroup
926enddef ;
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944primarydef p ynormalized s =
945 begingroup save h, r ; pair r ;
946 r := yrange p ;
947 h := ypart r xpart r ;
948 if (h > 0) :
949 save t ; transform t ;
950 t := identity
951 shifted llcorner p
952 if s > 0 : yscaled (sh) fi
953 ;
954 p transformed t
955 else :
956 p
957 fi
958 endgroup
959enddef ;
960
961permanent xnormalized, ynormalized, xynormalized ;
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983path fullsquare, unitcircle ;
984
985fullsquare := unitsquare shifted center unitsquare ;
986unitcircle := fullcircle shifted urcorner fullcircle ;
987
988
989
990path urcircle, ulcircle, llcircle, lrcircle ;
991
992urcircle := origin -- (+.5,0) & (+.5,0){up} .. (0,+.5) & (0,+.5) -- cycle ;
993ulcircle := origin -- (0,+.5) & (0,+.5){left} .. (-.5,0) & (-.5,0) -- cycle ;
994llcircle := origin -- (-.5,0) & (-.5,0){down} .. (0,-.5) & (0,-.5) -- cycle ;
995lrcircle := origin -- (0,-.5) & (0,-.5){right} .. (+.5,0) & (+.5,0) -- cycle ;
996
997path tcircle, bcircle, lcircle, rcircle ;
998
999tcircle := origin -- (+.5,0) & (+.5,0) {up} .. (0,+.5) .. {down} (-.5,0) -- cycle ;
1000bcircle := origin -- (-.5,0) & (-.5,0) {down} .. (0,-.5) .. {up} (+.5,0) -- cycle ;
1001lcircle := origin -- (0,+.5) & (0,+.5) {left} .. (-.5,0) .. {right} (0,-.5) -- cycle ;
1002rcircle := origin -- (0,-.5) & (0,-.5) {right} .. (+.5,0) .. {left} (0,+.5) -- cycle ;
1003
1004path urtriangle, ultriangle, lltriangle, lrtriangle ;
1005
1006urtriangle := origin -- (+.5,0) -- (0,+.5) -- cycle ;
1007ultriangle := origin -- (0,+.5) -- (-.5,0) -- cycle ;
1008lltriangle := origin -- (-.5,0) -- (0,-.5) -- cycle ;
1009lrtriangle := origin -- (0,-.5) -- (+.5,0) -- cycle ;
1010
1011path triangle, uptriangle, downtriangle, lefttriangle, righttriangle ;
1012
1013triangle := (1,0) -- (1,0) rotated 120 -- (1,0) rotated -120 -- cycle ;
1014
1015uptriangle := triangle rotated 90 ;
1016downtriangle := triangle rotated -90 ;
1017lefttriangle := triangle rotated 180 ;
1018righttriangle := triangle ;
1019
1020path unitdiamond, fulldiamond ;
1021
1022unitdiamond := (.5,0) -- (1,.5) -- (.5,1) -- (0,.5) -- cycle ;
1023fulldiamond := unitdiamond shifted center unitdiamond ;
1024
1025path unitoctagon, fulloctagon ;
1026
1027unitoctagon := for i within (unitcircle rotated 452) : pathpoint -- endfor cycle ;
1028fulloctagon := unitoctagon shifted center unitoctagon ;
1029
1030path unithexagon, fullhexagon ;
1031
1032
1033fullhexagon := for i = 0 step 60 until 360 : .5 dir(i) -- endfor cycle ;
1034unithexagon := fullhexagon shifted (.5,.5) ;
1035
1036permanent
1037 fullsquare, unitcircle,
1038 urcircle, ulcircle, llcircle, lrcircle,
1039 tcircle, bcircle, lcircle, rcircle,
1040 urtriangle, ultriangle, lltriangle, lrtriangle,
1041 triangle, uptriangle, downtriangle, lefttriangle, righttriangle,
1042 unitdiamond, fulldiamond, unitoctagon, fulloctagon, unithexagon, fullhexagon ;
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056primarydef p xyscaled q =
1057 begingroup
1058 save qq ; pair qq ;
1059 qq = paired(q) ;
1060 p
1061 if xpart qq <> 0 : xscaled (xpart qq) fi
1062 if ypart qq <> 0 : yscaled (ypart qq) fi
1063 endgroup
1064enddef ;
1065
1066permanent xyscaled ;
1067
1068
1069
1070def set_grid(expr w, h, nx, ny) =
1071 boolean grid[][] ; boolean grid_full ;
1072 numeric grid_w, grid_h, grid_nx, grid_ny, grid_x, grid_y, grid_left ;
1073 grid_w := w ;
1074 grid_h := h ;
1075 grid_nx := nx ;
1076 grid_ny := ny ;
1077 grid_x := round(wgrid_nx) ;
1078 grid_y := round(hgrid_ny) ;
1079 grid_left := (1grid_x)(1grid_y) ;
1080 grid_full := false ;
1081 for i=0 upto grid_x :
1082 for j=0 upto grid_y :
1083 grid[i][j] := false ;
1084 endfor ;
1085 endfor ;
1086enddef ;
1087
1088vardef new_on_grid(expr grid_dx, grid_dy) =
1089 dx := grid_dx ;
1090 dy := grid_dy ;
1091 ddx := min(round(dxgrid_nx),grid_x) ;
1092 ddy := min(round(dygrid_ny),grid_y) ;
1093 if not grid_full and not grid[ddx][ddy] :
1094 grid[ddx][ddy] := true ;
1095 grid_left := grid_left-1 ;
1096 grid_full := (grid_left=0) ;
1097 true
1098 else :
1099 false
1100 fi
1101enddef ;
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111secondarydef p peepholed q =
1112 begingroup
1113 save start ; pair start ;
1114 start := point 0 of p ;
1115 if xpart start >= xpart center p :
1116 if ypart start >= ypart center p :
1117 urcorner q -- ulcorner q -- llcorner q -- lrcorner q --
1118 reverse p -- lrcorner q -- cycle
1119 else :
1120 lrcorner q -- urcorner q -- ulcorner q -- llcorner q --
1121 reverse p -- llcorner q -- cycle
1122 fi
1123 else :
1124 if ypart start > ypart center p :
1125 ulcorner q -- llcorner q -- lrcorner q -- urcorner q --
1126 reverse p -- urcorner q -- cycle
1127 else :
1128 llcorner q -- lrcorner q -- urcorner q -- ulcorner q --
1129 reverse p -- ulcorner q -- cycle
1130 fi
1131 fi
1132 endgroup
1133enddef ;
1134
1135newinternal boolean intersection_found ;
1136
1137secondarydef p intersection_point q =
1138 begingroup
1139 save temp_x, temp_y ;
1140 (temp_x,temp_y) = p intersectiontimes q ;
1141 if temp_x < 0 :
1142 intersection_found := false ;
1143 center p
1144 else :
1145 intersection_found := true ;
1146 .5[point temp_x of p, point temp_y of q]
1147 fi
1148 endgroup
1149enddef ;
1150
1151permanent intersection_found, intersection_point ;
1152
1153
1154
1155vardef tensecircle (expr width, height, offset) =
1156 (width2,height2) ... (0,height2offset) ...
1157 (width2,height2) ... (width2offset,0) ...
1158 (width2,height2) ... (0,height2offset) ...
1159 (width2,height2) ... (width2offset,0) ... cycle
1160enddef ;
1161
1162vardef roundedsquare (expr width, height, offset) =
1163 (offset,0) -- (widthoffset,0) {right} ..
1164 (width,offset) -- (width,heightoffset) {up} ..
1165 (widthoffset,height) -- (offset,height) {left} ..
1166 (0,heightoffset) -- (0,offset) {down} .. cycle
1167enddef ;
1168
1169vardef roundedsquarexy (expr width, height, dx, dy) =
1170 (dx,0) -- (widthdx,0) {right} ..
1171 (width,dy) -- (width,heightdy) {up} ..
1172 (widthdx,height) -- (dx,height) {left} ..
1173 (0,heightdy) -- (0,dy) {down} .. cycle
1174enddef ;
1175
1176permanent tensecircle, roundedsquare, roundedsquarexy ;
1177
1178
1179
1180def resolvedcolor(expr s) =
1181 .5white
1182enddef ;
1183
1184let normalwithcolor = withcolor ;
1185
1186def withcolor expr c =
1187 normalwithcolor if string c : resolvedcolor(c) else : c fi
1188enddef ;
1189
1190permanent resolvedcolor, normalwithcolor, withcolor ;
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218vardef colortype expr c =
1219 if cmykcolor c : cmykcolor
1220 elseif rgbcolor c : rgbcolor
1221 elseif numeric c : grayscale
1222 fi
1223enddef ;
1224
1225vardef whitecolor expr c =
1226 if cmykcolor c : (0,0,0,0)
1227 elseif rgbcolor c : (1,1,1)
1228 elseif numeric c : 1
1229 elseif string c : whitecolor resolvedcolor(c)
1230 fi
1231enddef ;
1232
1233vardef blackcolor expr c =
1234 if cmykcolor c : (0,0,0,1)
1235 elseif rgbcolor c : (0,0,0)
1236 elseif numeric c : 0
1237 elseif string c : blackcolor resolvedcolor(c)
1238 fi
1239enddef ;
1240
1241vardef complementary expr c =
1242 if cmykcolor c : (1,1,1,1) c
1243 elseif rgbcolor c : (1,1,1) c
1244 elseif pair c : (1,1) c
1245 elseif numeric c : 1 c
1246 elseif string c : complementary resolvedcolor(c)
1247 fi
1248enddef ;
1249
1250vardef complemented expr c =
1251 save m ;
1252 if cmykcolor c : m := max(cyanpart c, magentapart c, yellowpart c, blackpart c) ;
1253 (m,m,m,m) c
1254 elseif rgbcolor c : m := max(redpart c, greenpart c, bluepart c) ;
1255 (m,m,m) c
1256 elseif pair c : m := max(xpart c, ypart c) ;
1257 (m,m) c
1258 elseif numeric c : m c
1259 elseif string c : complemented resolvedcolor(c)
1260 fi
1261enddef ;
1262
1263permanent colortype, whitecolor, blackcolor, complementary, complemented ;
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275def drawfill expr c =
1276 path temp_c ; temp_c := c ;
1277 mfun_do_drawfill
1278enddef ;
1279
1280def mfun_do_drawfill text t =
1281 draw temp_c t ;
1282 fill temp_c t ;
1283enddef;
1284
1285def undrawfill expr c =
1286 drawfill c withcolor background
1287enddef ;
1288
1289permanent drawfill, undrawfill ;
1290
1291
1292
1293vardef paired primary d =
1294 if pair d : d else : (d,d) fi
1295enddef ;
1296
1297vardef tripled primary d =
1298 if color d : d else : (d,d,d) fi
1299enddef ;
1300
1301permanent paired, tripled ;
1302
1303
1304
1305primarydef p enlarged d = ( p llmoved d -- p lrmoved d -- p urmoved d -- p ulmoved d -- cycle ) enddef ;
1306primarydef p llenlarged d = ( p llmoved d -- lrcorner p -- urcorner p -- ulcorner p -- cycle ) enddef ;
1307primarydef p lrenlarged d = ( llcorner p -- p lrmoved d -- urcorner p -- ulcorner p -- cycle ) enddef ;
1308primarydef p urenlarged d = ( llcorner p -- lrcorner p -- p urmoved d -- ulcorner p -- cycle ) enddef ;
1309primarydef p ulenlarged d = ( llcorner p -- lrcorner p -- urcorner p -- p ulmoved d -- cycle ) enddef ;
1310
1311primarydef p llmoved d = ( (llcorner p) shifted (xpart paired(d),ypart paired(d)) ) enddef ;
1312primarydef p lrmoved d = ( (lrcorner p) shifted (xpart paired(d),ypart paired(d)) ) enddef ;
1313primarydef p urmoved d = ( (urcorner p) shifted (xpart paired(d),ypart paired(d)) ) enddef ;
1314primarydef p ulmoved d = ( (ulcorner p) shifted (xpart paired(d),ypart paired(d)) ) enddef ;
1315
1316primarydef p leftenlarged d = ( (llcorner p) shifted (d,0) -- lrcorner p -- urcorner p -- (ulcorner p) shifted (d,0) -- cycle ) enddef ;
1317primarydef p rightenlarged d = ( llcorner p -- (lrcorner p) shifted (d,0) -- (urcorner p) shifted (d,0) -- ulcorner p -- cycle ) enddef ;
1318primarydef p topenlarged d = ( llcorner p -- lrcorner p -- (urcorner p) shifted (0,d) -- (ulcorner p) shifted (0,d) -- cycle ) enddef ;
1319primarydef p bottomenlarged d = ( llcorner p shifted (0,d) -- lrcorner p shifted (0,d) -- urcorner p -- ulcorner p -- cycle ) enddef ;
1320
1321
1322permanent
1323 enlarged, llenlarged, lrenlarged, urenlarged, ulenlarged,
1324 llmoved, lrmoved, urmoved, ulmoved,
1325 leftenlarged, rightenlarged, topenlarged, bottomenlarged ;
1326
1327
1328
1329vardef rotation(expr i, n) =
1330 if (n == 0) : 0 else : i 360 n fi
1331enddef ;
1332
1333
1334permanent rotation ;
1335
1336
1337
1338primarydef p crossed d = (
1339 if pair p :
1340 p shifted (d, 0) -- p --
1341 p shifted ( 0,d) -- p --
1342 p shifted (d, 0) -- p --
1343 p shifted ( 0,d) -- p -- cycle
1344 else :
1345 center p shifted (d, 0) -- llcorner p --
1346 center p shifted ( 0,d) -- lrcorner p --
1347 center p shifted (d, 0) -- urcorner p --
1348 center p shifted ( 0,d) -- ulcorner p -- cycle
1349 fi
1350) enddef ;
1351
1352
1353
1354
1355
1356
1357
1358
1359vardef laddered primary p =
1360 save a; pair a ; a := point 0 of p ; a --
1361 for i within p :
1362 if i > 0 : (xpart pathpoint, ypart a) -- pathpoint -- fi
1363 hide(a := pathpoint)
1364 endfor
1365 if cycle p :
1366 (xpart point 0 of p, ypart a) -- point 0 of p -- cycle
1367 else :
1368 nocycle
1369 fi
1370enddef ;
1371
1372permanent crossed, laddered ;
1373
1374
1375
1376
1377
1378
1379
1380
1381vardef bottomboundary primary p = if pair p : p else : (llcorner p -- lrcorner p) fi enddef ;
1382vardef rightboundary primary p = if pair p : p else : (lrcorner p -- urcorner p) fi enddef ;
1383vardef topboundary primary p = if pair p : p else : (urcorner p -- ulcorner p) fi enddef ;
1384vardef leftboundary primary p = if pair p : p else : (ulcorner p -- llcorner p) fi enddef ;
1385
1386permanent bottomboundary, rightboundary, topboundary, leftboundary ;
1387
1388
1389
1390primarydef p superellipsed s =
1391 superellipse (
1392 .5[lrcorner p,urcorner p],
1393 .5[urcorner p,ulcorner p],
1394 .5[ulcorner p,llcorner p],
1395 .5[llcorner p,lrcorner p],
1396 s
1397 )
1398enddef ;
1399
1400primarydef p squeezed s = (
1401 (llcorner p .. .5[llcorner p,lrcorner p] shifted ( 0, ypart paired(s)) .. lrcorner p) &
1402 (lrcorner p .. .5[lrcorner p,urcorner p] shifted (xpart paired(s), 0) .. urcorner p) &
1403 (urcorner p .. .5[urcorner p,ulcorner p] shifted ( 0,ypart paired(s)) .. ulcorner p) &
1404 (ulcorner p .. .5[ulcorner p,llcorner p] shifted ( xpart paired(s), 0) .. llcorner p) & cycle
1405) enddef ;
1406
1407primarydef p randomshifted s =
1408 begingroup ;
1409 save ss ; pair ss ;
1410 ss := paired(s) ;
1411 p shifted (-.5xpart ss uniformdeviate xpart ss,-.5ypart ss uniformdeviate ypart ss)
1412 endgroup
1413enddef ;
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431vardef mfun_randomized_path(expr p,s) =
1432 save r, oldr, newr, firstr, l ; pair r, oldr, newr, firstr ;
1433 r := paired(s) ;
1434 l := length(p) ;
1435 newr := (-12uniformdeviate(1),-12uniformdeviate(1)) xyscaled r ;
1436 firstr := newr ;
1437 for i within p :
1438 hide (
1439 oldr := newr ;
1440 newr := (-12uniformdeviate(1),-12uniformdeviate(1)) xyscaled r ;
1441 )
1442 pathpoint ..
1443 controls (pathpostcontrol shifted oldr )
1444 and ((deltaprecontrol 1) shifted if (i <> l 1) : newr else : firstr fi) ..
1445 endfor if cycle p : cycle else : nocycle fi
1446enddef ;
1447
1448
1449vardef mfun_randomrotated_path(expr p, s) =
1450 save r, oldr, newr, firstr, l ;
1451 l := length(p) ;
1452 newr := (-12uniformdeviate(1))s ;
1453 firstr := newr ;
1454 for i within p :
1455 hide (
1456 oldr := newr ;
1457 newr := (-12uniformdeviate(1)) s ;
1458 )
1459 pathpoint ..
1460 controls (pathpostcontrol rotatedaround(pathpoint, oldr) )
1461 and ((deltaprecontrol 1) rotatedaround(deltapoint 1, if (i <> l 1) : newr else : firstr fi)) ..
1462 endfor if cycle p : cycle else : nocycle fi
1463enddef ;
1464
1465vardef mfun_randomized_picture(expr p,s)(text rnd) =
1466 save currentpicture ;
1467 picture currentpicture ;
1468 currentpicture := nullpicture ;
1469 for i within p :
1470 addto currentpicture
1471 if stroked i :
1472 doublepath pathpart i rnd s
1473 dashed dashpart i
1474 withpen penpart i
1475 withcolor colorpart i
1476 withprescript prescriptpart i
1477 withpostscript postscriptpart i
1478 elseif filled i :
1479 contour pathpart i rnd s
1480 withpen penpart i
1481 withcolor colorpart i
1482 withprescript prescriptpart i
1483 withpostscript postscriptpart i
1484 else :
1485 also i
1486 fi
1487 ;
1488 endfor ;
1489 currentpicture
1490enddef ;
1491
1492primarydef p randomizedcontrols s = (
1493 if path p :
1494 mfun_randomized_path(p,s)
1495 elseif picture p :
1496 mfun_randomized_picture(p,s)(randomizedcontrols)
1497 else :
1498 p randomized s
1499 fi
1500) enddef ;
1501
1502primarydef p randomrotatedcontrols s = (
1503 if path p :
1504 mfun_randomrotated_path(p,s)
1505 elseif picture p :
1506 mfun_randomized_picture(p,s)(randomrotatedcontrols)
1507 else :
1508 p randomized s
1509 fi
1510) enddef ;
1511
1512primarydef p randomized s = (
1513 if path p :
1514 for i=0 upto length(p)-1 :
1515 ((point i of p) randomshifted s) .. controls
1516 ((postcontrol i of p) randomshifted s) and
1517 ((precontrol (i+1) of p) randomshifted s) ..
1518 endfor
1519 if cycle p :
1520 cycle
1521 else :
1522 ((point length(p) of p) randomshifted s)
1523 fi
1524 elseif pair p :
1525 p randomshifted s
1526 elseif cmykcolor p :
1527 if cmykcolor s :
1528 ((uniformdeviate cyanpart s) cyanpart p,
1529 (uniformdeviate magentapart s) magentapart p,
1530 (uniformdeviate yellowpart s) yellowpart p,
1531 (uniformdeviate blackpart s) blackpart p)
1532 elseif pair s :
1533 ((xpart s (uniformdeviate (ypart s xpart s))) p)
1534 else :
1535 ((uniformdeviate s) p)
1536 fi
1537 elseif rgbcolor p :
1538 if rgbcolor s :
1539 ((uniformdeviate redpart s) redpart p,
1540 (uniformdeviate greenpart s) greenpart p,
1541 (uniformdeviate bluepart s) bluepart p)
1542 elseif pair s :
1543 ((xpart s (uniformdeviate (ypart s xpart s))) p)
1544 else :
1545 ((uniformdeviate s) p)
1546 fi
1547 elseif color p :
1548 if color s :
1549 ((uniformdeviate greypart s) greypart p)
1550 elseif pair s :
1551 ((xpart s (uniformdeviate (ypart s xpart s))) p)
1552 else :
1553 ((uniformdeviate s) p)
1554 fi
1555 elseif string p :
1556 (resolvedcolor(p)) randomized s
1557 elseif picture p :
1558 mfun_randomized_picture(p,s)(randomized)
1559 else :
1560
1561 p uniformdeviate s
1562 fi
1563) enddef ;
1564
1565permanent superellipsed, squeezed, randomshifted, randomized,
1566 randomizedcontrols, randomrotatedcontrols ;
1567
1568
1569
1570vardef interpolated(expr s, p, q) =
1571 save m ; numeric m ;
1572 m := max(length(p),length(q)) ;
1573 if path p :
1574 for i=0 upto m-1 :
1575 s[point (i m) along p,point (i m) along q] .. controls
1576 s[postcontrol (i m) along p,postcontrol (i m) along q] and
1577 s[precontrol ((i+1)m) along p,precontrol ((i+1)m) along q] ..
1578 endfor
1579 if cycle p :
1580 cycle
1581 else :
1582 s[point infinity of p,point infinity of q]
1583 fi
1584 else :
1585 a[p,q]
1586 fi
1587enddef ;
1588
1589permanent interpolated ;
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604def istextext(expr p) =
1605 (picture p and ((substring(0,3) of prescriptpart p) = "tx_"))
1606enddef ;
1607
1608vardef perpendicular expr t of p =
1609 unitvector((direction t of p) rotated 90)
1610enddef ;
1611
1612primarydef p paralleled d = (
1613 if path p :
1614 begingroup ;
1615 save dp ; pair dp ;
1616 for i=0 upto length p if cycle p : -1 fi :
1617 hide(dp := d perpendicular i of p)
1618 if i > 0 : .. fi
1619 (point i of p dp)
1620 if i < length p :
1621 .. controls (postcontrol i of p dp) and
1622 (precontrol (i+1) of p dp)
1623 fi
1624 endfor
1625 if cycle p : .. cycle fi
1626 endgroup
1627 elseif picture p :
1628 image(
1629 for i within p :
1630 draw (pathpart i)
1631 if not istextext(i) :
1632 paralleled d
1633 fi
1634 mfun_decoration_i i ;
1635 endfor ;
1636 )
1637 elseif pair p :
1638 p
1639 fi
1640) enddef ;
1641
1642vardef punked primary p =
1643 point 0 of p for i=1 upto length(p)-1 : -- point i of p endfor
1644 if cycle p : -- cycle else : -- point length(p) of p fi
1645enddef ;
1646
1647vardef curved primary p =
1648 point 0 of p for i=1 upto length(p)-1 : .. point i of p endfor
1649 if cycle p : .. cycle else : .. point length(p) of p fi
1650enddef ;
1651
1652primarydef p blownup s =
1653 begingroup
1654 save temp_p ; path temp_p ;
1655 temp_p := p xysized (bbwidth(p)+2(xpart paired(s)),bbheight(p)+2(ypart paired(s))) ;
1656 (temp_p shifted (center p center temp_p))
1657 endgroup
1658enddef ;
1659
1660permanent perpendicular, istextext, paralleled, punked, curved, blownup ;
1661
1662
1663
1664
1665
1666vardef mfun_left_right_path(expr p, l) =
1667 save q, r, t, b ; path q, r ; pair t, b ;
1668 t := (ulcorner p -- urcorner p) intersection_point p ;
1669 b := (llcorner p -- lrcorner p) intersection_point p ;
1670 r := if xpart directionpoint t of p < 0 : reverse p else : p fi ;
1671 q := r cutbefore if l: t else: b fi ;
1672 q := q if xpart point 0 of r > 0 : & r fi cutafter if l: b else: t fi ;
1673 q
1674enddef ;
1675
1676vardef leftpath expr p = mfun_left_right_path(p,true ) enddef ;
1677vardef rightpath expr p = mfun_left_right_path(p,false) enddef ;
1678
1679permanent leftpath, rightpath ;
1680
1681
1682
1683def saveoptions =
1684 save base_draw_options ; def base_draw_options = enddef ;
1685enddef ;
1686
1687permanent saveoptions ;
1688
1689
1690
1691let normaldraw = draw ;
1692let normalfill = fill ;
1693
1694
1695
1696def normalfill expr c = addto currentpicture contour c base_draw_options enddef ;
1697def normaldraw expr p = addto currentpicture if picture p: also p else: doublepath p withpen currentpen fi base_draw_options enddef ;
1698
1699def drawlineoptions (text t) = def mfun_opt_lin = t enddef ; enddef ;
1700def drawpointoptions (text t) = def mfun_opt_pnt = t enddef ; enddef ;
1701def drawcontroloptions(text t) = def mfun_opt_ctr = t enddef ; enddef ;
1702def drawlabeloptions (text t) = def mfun_opt_lab = t enddef ; enddef ;
1703def draworiginoptions (text t) = def mfun_opt_ori = t enddef ; enddef ;
1704def drawboundoptions (text t) = def mfun_opt_bnd = t enddef ; enddef ;
1705def drawpathoptions (text t) = def mfun_opt_pth = t enddef ; enddef ;
1706
1707numeric drawoptionsfactor ; drawoptionsfactor := pt ;
1708
1709def resetdrawoptions =
1710 drawlineoptions (withpen pencircle scaled 1.0 drawoptionsfactor withcolor .5white) ;
1711 drawpointoptions (withpen pencircle scaled 4.0 drawoptionsfactor withcolor black) ;
1712 drawcontroloptions(withpen pencircle scaled 2.5 drawoptionsfactor withcolor black) ;
1713 drawlabeloptions () ;
1714 draworiginoptions (withpen pencircle scaled 1.0 drawoptionsfactor withcolor .5white) ;
1715 drawboundoptions (dashed evenly mfun_opt_ori) ;
1716 drawpathoptions (withpen pencircle scaled 5.0 drawoptionsfactor withcolor .8white) ;
1717enddef ;
1718
1719resetdrawoptions ;
1720
1721
1722
1723def drawpath expr p =
1724 normaldraw p mfun_opt_pth
1725enddef ;
1726
1727permanent
1728 drawlineoptions, drawpointoptions, drawcontroloptions, drawlabeloptions, draworiginoptions,
1729 drawboundoptions, drawpathoptions, drawpath, normaldraw ;
1730
1731
1732
1733newinternal ahvariant ; ahvariant := 0 ;
1734newinternal ahdimple ; ahdimple := 15 ;
1735newinternal ahscale ; ahscale := 34 ;
1736
1737permanent ahvariant, ahdimple, ahscale ;
1738
1739vardef arrowhead expr p =
1740 save q, e, r ;
1741 pair e ; e = point length p of p ;
1742 path q ; q = gobble(p shifted e cutafter makepath(pencircle scaled (2ahlength))) cuttings ;
1743 if ahvariant > 0:
1744 path r ; r = gobble(p shifted e cutafter makepath(pencircle scaled ((1ahdimple)2ahlength))) cuttings ;
1745 fi
1746 (q rotated (ahangle2) & reverse q rotated (ahangle2)
1747 if ahvariant = 1 :
1748 -- point 0 of r --
1749 elseif ahvariant = 2 :
1750 ... point 0 of r ...
1751 else :
1752 --
1753 fi
1754 cycle
1755 ) shifted e
1756enddef ;
1757
1758vardef drawarrowpath expr p =
1759
1760 interim autoarrows := true ;
1761 drawarrow p mfun_opt_pth
1762enddef ;
1763
1764def midarrowhead expr p =
1765 arrowhead p cutafter (point length(p cutafter point .5 along p) ahlength on p)
1766enddef ;
1767
1768vardef arrowheadonpath (expr p, s) =
1769
1770 interim autoarrows := true ;
1771 set_ahlength(scaled ahfactor) ;
1772 arrowhead p if s < 1 : cutafter (point (sarclength(p) (ahlength2)) on p) fi
1773enddef ;
1774
1775def resetarrows =
1776 hide (
1777 ahlength := 4 ;
1778 ahangle := 45 ;
1779 ahvariant := 0 ;
1780 ahdimple := 15 ;
1781 ahscale := 34 ;
1782)
1783enddef ;
1784
1785permanent arrowhead, drawarrowpath, midarrowhead, arrowheadonpath ;
1786
1787
1788
1789vardef dotlabel@#(expr s,z) text t =
1790 label@#(s,z) t ;
1791 interim linecap := rounded ;
1792 normaldraw z withpen pencircle scaled dotlabeldiam t ;
1793enddef ;
1794
1795def drawpoint expr c =
1796 if string c :
1797 string temp_c ;
1798 temp_c := "(" & c & ")" ;
1799 dotlabel.urt(temp_c, scantokens temp_c) ;
1800 drawdot scantokens temp_c
1801 else :
1802 dotlabel.urt("(" & decimal xpart c & "," & decimal ypart c & ")", c) ;
1803 drawdot c
1804 fi mfun_opt_pnt
1805enddef ;
1806
1807
1808
1809def drawpoints expr c = path temp_c ; temp_c := c ; mfun_draw_points enddef ;
1810def drawcontrolpoints expr c = path temp_c ; temp_c := c ; mfun_draw_controlpoints enddef ;
1811def drawcontrollines expr c = path temp_c ; temp_c := c ; mfun_draw_controllines enddef ;
1812def drawpointlabels expr c = path temp_c ; temp_c := c ; mfun_draw_pointlabels enddef ;
1813
1814def mfun_draw_points text t =
1815 for i within temp_c :
1816 normaldraw pathpoint mfun_opt_pnt t ;
1817 endfor ;
1818enddef;
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834def mfun_draw_controlpoints text t =
1835 for i within temp_c :
1836 if (pathstate == 0) or (pathstate == 2) :
1837 normaldraw pathprecontrol t mfun_opt_ctr t ;
1838 fi ;
1839 if (pathstate == 0) or (pathstate == 1) :
1840 normaldraw pathpostcontrol t mfun_opt_ctr t ;
1841 fi ;
1842 endfor ;
1843enddef;
1844
1845def mfun_draw_controllines text t =
1846 for i within temp_c :
1847 if (pathstate == 0) or (pathstate == 2) :
1848 normaldraw pathpoint -- pathprecontrol t mfun_opt_lin t ;
1849 fi ;
1850 if (pathstate == 0) or (pathstate == 1) :
1851 normaldraw pathpoint -- pathpostcontrol t mfun_opt_lin t ;
1852 fi ;
1853 endfor ;
1854enddef;
1855
1856boolean swappointlabels ; swappointlabels := false ;
1857numeric pointlabelscale ; pointlabelscale := 0 ;
1858string pointlabelfont ; pointlabelfont := "" ;
1859
1860def mfun_draw_pointlabels text asked_options =
1861
1862 for i=0 upto length(temp_c) if cycle temp_c : -1 fi :
1863 pair temp_u ; temp_u := unitvector(direction i of temp_c) rotated if swappointlabels : fi 90 ;
1864 pair temp_p ; temp_p := (point i of temp_c) ;
1865 begingroup ;
1866 if pointlabelscale > 0 :
1867 save defaultscale ; numeric defaultscale ;
1868 defaultscale := pointlabelscale ;
1869 fi ;
1870 if pointlabelfont <> "" :
1871 save defaultfont ; string defaultfont ;
1872 defaultfont := pointlabelfont ;
1873 fi ;
1874 temp_u := 10 drawoptionsfactor defaultscale temp_u ;
1875 normaldraw thelabel ( decimal i, temp_p shifted if cycle temp_c and (i=0) : fi temp_u ) mfun_opt_lab asked_options ;
1876 endgroup ;
1877 endfor ;
1878enddef;
1879
1880
1881
1882def drawboundingbox expr p =
1883 normaldraw boundingbox p mfun_opt_bnd
1884enddef ;
1885
1886
1887
1888numeric originlength ; originlength := .5cm ;
1889
1890def draworigin text t =
1891 normaldraw (origin shifted (0, originlength) -- origin shifted (0,originlength)) mfun_opt_ori t ;
1892 normaldraw (origin shifted ( originlength,0) -- origin shifted (originlength,0)) mfun_opt_ori t ;
1893enddef;
1894
1895permanent dotlabel, swappointlabels, pointlabelscale, pointlabelfont ;
1896permanent drawboundingbox, drawpoints, drawcontrolpoints, drawcontrollines, drawpointlabels, draworigin ;
1897
1898
1899
1900numeric tickstep ; tickstep := 5mm ;
1901numeric ticklength ; ticklength := 2mm ;
1902
1903def drawxticks expr c = path temp_c ; temp_c := c ; mfun_draw_xticks enddef ;
1904def drawyticks expr c = path temp_c ; temp_c := c ; mfun_draw_yticks enddef ;
1905def drawticks expr c = path temp_c ; temp_c := c ; mfun_draw_ticks enddef ;
1906
1907
1908
1909def mfun_draw_xticks text t =
1910 for i=0 step tickstep until xpart llcorner temp_c eps :
1911 if (i<=xpart lrcorner temp_c) :
1912 normaldraw (i,ticklength)--(i,ticklength) mfun_opt_ori t ;
1913 fi ;
1914 endfor ;
1915 for i=0 step tickstep until xpart lrcorner temp_c eps :
1916 if (i>=xpart llcorner temp_c) :
1917 normaldraw (i,ticklength)--(i,ticklength) mfun_opt_ori t ;
1918 fi ;
1919 endfor ;
1920 normaldraw (llcorner temp_c -- ulcorner temp_c) shifted (xpart llcorner temp_c,0) mfun_opt_ori t ;
1921enddef ;
1922
1923def mfun_draw_yticks text t =
1924 for i=0 step tickstep until ypart llcorner temp_c eps :
1925 if (i<=ypart ulcorner temp_c) :
1926 normaldraw (ticklength,i)--(ticklength,i) mfun_opt_ori t ;
1927 fi ;
1928 endfor ;
1929 for i=0 step tickstep until ypart ulcorner temp_c eps :
1930 if (i>=ypart llcorner temp_c) :
1931 normaldraw (ticklength,i)--(ticklength,i) mfun_opt_ori t ;
1932 fi ;
1933 endfor ;
1934 normaldraw (llcorner temp_c -- lrcorner temp_c) shifted (0,ypart llcorner temp_c) mfun_opt_ori t ;
1935enddef ;
1936
1937def mfun_draw_ticks text t =
1938 drawxticks temp_c t ;
1939 drawyticks temp_c t ;
1940enddef ;
1941
1942
1943
1944def drawwholepath expr p =
1945 draworigin ;
1946 drawpath p ;
1947 drawcontrollines p ;
1948 drawcontrolpoints p ;
1949 drawpoints p ;
1950 drawboundingbox p ;
1951 drawpointlabels p ;
1952enddef ;
1953
1954def drawpathonly expr p =
1955 drawpath p ;
1956 drawcontrollines p ;
1957 drawcontrolpoints p ;
1958 drawpoints p ;
1959 drawpointlabels p ;
1960enddef ;
1961
1962
1963
1964def visualizeddraw expr c =
1965 if picture c : normaldraw c else : path temp_c ; temp_c := c ; do_visualizeddraw fi
1966enddef ;
1967
1968def visualizedfill expr c =
1969 if picture c : normalfill c else : path temp_c ; temp_c := c ; do_visualizedfill fi
1970enddef ;
1971
1972def do_visualizeddraw text t =
1973 draworigin ;
1974 drawpath temp_c t ;
1975 drawcontrollines temp_c ;
1976 drawcontrolpoints temp_c ;
1977 drawpoints temp_c ;
1978 drawboundingbox temp_c ;
1979 drawpointlabels temp_c ;
1980enddef ;
1981
1982def do_visualizedfill text t =
1983 if cycle temp_c : normalfill temp_c t fi ;
1984 draworigin ;
1985 drawcontrollines temp_c ;
1986 drawcontrolpoints temp_c ;
1987 drawpoints temp_c ;
1988 drawboundingbox temp_c ;
1989 drawpointlabels temp_c ;
1990enddef ;
1991
1992def detaileddraw expr c =
1993 if picture c : normaldraw c else : path temp_c ; temp_c := c ; do_detaileddraw fi
1994enddef ;
1995
1996def do_detaileddraw text t =
1997 drawpath temp_c t ;
1998 drawcontrollines temp_c ;
1999 drawcontrolpoints temp_c ;
2000 drawpoints temp_c ;
2001
2002
2003
2004enddef ;
2005
2006def visualizepaths =
2007 let fill = visualizedfill ;
2008 let draw = visualizeddraw ;
2009enddef ;
2010
2011def detailpaths =
2012 let draw = detaileddraw ;
2013enddef ;
2014
2015def naturalizepaths =
2016 let fill = normalfill ;
2017 let draw = normaldraw ;
2018enddef ;
2019
2020extra_endfig := extra_endfig & " naturalizepaths ; " ;
2021
2022permanent
2023 visualizeddraw, detaileddraw, visualizedfill,
2024 visualizepaths, detailpaths, naturalizepaths ;
2025
2026
2027
2028def drawboundary primary p =
2029 draw p dashed evenly withcolor white ;
2030 draw p dashed oddly withcolor black ;
2031 draw ( llcorner p) withpen pencircle scaled 3 withcolor white ;
2032 draw ( llcorner p) withpen pencircle scaled 1.5 withcolor black ;
2033enddef ;
2034
2035permanent drawboundary ;
2036
2037
2038
2039extra_beginfig := extra_beginfig & " truecorners := 0 ; " ;
2040extra_beginfig := extra_beginfig & " miterlimit := 10 ; " ;
2041extra_beginfig := extra_beginfig & " linejoin := rounded ; " ;
2042extra_beginfig := extra_beginfig & " linecap := rounded ; " ;
2043
2044
2045
2046
2047numeric ahfactor ; ahfactor := 2.5 ;
2048
2049newinternal boolean autoarrows ;
2050
2051permanent ahfactor, ahlength, autoarrows ;
2052
2053def set_ahlength (text t) =
2054
2055
2056
2057 ahlength := (ahfactorpen_size(t)) ;
2058enddef ;
2059
2060vardef pen_size (text t) =
2061 save p ; picture p ; p := nullpicture ;
2062 addto p doublepath (top origin -- bot origin) t ;
2063 (ypart urcorner p ypart lrcorner p)
2064enddef ;
2065
2066
2067
2068
2069vardef arrowpath expr p =
2070 (p cutafter makepath(pencircle
2071 scaled (if ahvariant > 0 : (1ahdimple) fi 2ahlengthcosd(ahangle2))
2072 shifted point length p of p
2073 ))
2074enddef;
2075
2076permanent arrowpath ;
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094vardef stroked_paths(expr p) =
2095 save n ; numeric n ; n := 0 ;
2096 for i within p :
2097 if stroked i :
2098 n := n 1 ;
2099 fi
2100 endfor ;
2101 n
2102enddef ;
2103
2104def mfun_decoration_i expr i =
2105 withpen penpart i
2106 withcolor colorpart i
2107 withprescript prescriptpart i
2108 withpostscript postscriptpart i
2109enddef ;
2110
2111
2112
2113
2114numeric mfun_arrow_snippets ;
2115numeric mfun_arrow_count ;
2116
2117def drawarrow expr p =
2118 begingroup ;
2119 save mfun_arrow_path ;
2120 path mfun_arrow_path ;
2121 if path p :
2122 mfun_arrow_path := p ;
2123 expandafter mfun_draw_arrow_path
2124 elseif picture p :
2125 save mfun_arrow_picture ;
2126 picture mfun_arrow_picture ;
2127 mfun_arrow_picture := p ;
2128 expandafter mfun_draw_arrow_picture
2129 else :
2130 expandafter mfun_draw_arrow_nothing
2131 fi
2132enddef ;
2133
2134def drawdblarrow expr p =
2135 begingroup ;
2136 save mfun_arrow_path ;
2137 path mfun_arrow_path ;
2138 if path p :
2139 mfun_arrow_path := p ;
2140 expandafter mfun_draw_arrow_path_double
2141 elseif picture p :
2142 save mfun_arrow_picture ;
2143 picture mfun_arrow_picture ;
2144 mfun_arrow_picture := p ;
2145 expandafter mfun_draw_arrow_picture_double
2146 else :
2147 expandafter mfun_draw_arrow_nothing
2148 fi
2149enddef ;
2150
2151def mfun_draw_arrow_nothing text t =
2152enddef ;
2153
2154
2155
2156
2157def mfun_draw_arrow_path text t =
2158 if autoarrows :
2159 set_ahlength(t) ;
2160 fi
2161 draw arrowpath mfun_arrow_path t ;
2162 fillup arrowhead mfun_arrow_path t ;
2163 endgroup ;
2164enddef ;
2165
2166def mfun_draw_arrow_path_double text t =
2167 if autoarrows :
2168 set_ahlength(t) ;
2169 fi
2170 draw arrowpath (reverse arrowpath mfun_arrow_path) t ;
2171 fillup arrowhead mfun_arrow_path t ;
2172 fillup arrowhead reverse mfun_arrow_path t ;
2173 endgroup ;
2174enddef ;
2175
2176
2177
2178
2179
2180def mfun_with_arrow_picture (text t) =
2181 mfun_arrow_count := 0 ;
2182 mfun_arrow_snippets := stroked_paths(mfun_arrow_picture) ;
2183 for i within mfun_arrow_picture :
2184 if istextext(i) :
2185 draw i
2186 else :
2187 mfun_arrow_count := mfun_arrow_count 1 ;
2188 mfun_arrow_path := pathpart i ;
2189 t
2190 fi ;
2191 endfor ;
2192enddef ;
2193
2194def mfun_draw_arrow_picture text t =
2195 if autoarrows :
2196 set_ahlength(t) ;
2197 fi
2198 mfun_with_arrow_picture (
2199 if mfun_arrow_count = mfun_arrow_snippets :
2200 draw arrowpath mfun_arrow_path mfun_decoration_i i t ;
2201 fillup arrowhead mfun_arrow_path mfun_decoration_i i t ;
2202 else :
2203 draw mfun_arrow_path mfun_decoration_i i t ;
2204 fi ;
2205 )
2206 endgroup ;
2207enddef ;
2208
2209def mfun_draw_arrow_picture_double text t =
2210 if autoarrows :
2211 set_ahlength(t) ;
2212 fi
2213 mfun_with_arrow_picture (
2214 draw
2215 if mfun_arrow_count = 1 :
2216 arrowpath reverse
2217 elseif mfun_arrow_count = mfun_arrow_snippets :
2218 arrowpath
2219 fi
2220 mfun_arrow_path mfun_decoration_i i t ;
2221 if mfun_arrow_count = 1 :
2222 fillup arrowhead reverse mfun_arrow_path mfun_decoration_i i t ;
2223 fi
2224 if mfun_arrow_count = mfun_arrow_snippets :
2225 fillup arrowhead mfun_arrow_path mfun_decoration_i i t ;
2226 fi
2227 )
2228 endgroup ;
2229enddef ;
2230
2231
2232
2233let drawdoublearrow = drawdblarrow ;
2234
2235def drawdoublearrows expr p =
2236 begingroup ;
2237 save mfun_arrow_path ;
2238 path mfun_arrow_path ;
2239 save mfun_arrow_path_parallel ;
2240 path mfun_arrow_path_parallel ;
2241 if path p :
2242 mfun_arrow_path := p ;
2243 expandafter mfun_draw_arrow_paths
2244 elseif picture p :
2245 save mfun_arrow_picture ;
2246 picture mfun_arrow_picture ;
2247 mfun_arrow_picture := p ;
2248 expandafter mfun_draw_arrow_pictures
2249 else :
2250 expandafter mfun_draw_arrow_nothing
2251 fi
2252enddef ;
2253
2254def mfun_draw_arrow_paths text t =
2255 if autoarrows :
2256 set_ahlength(t) ;
2257 fi
2258 save d ; d := ahscaleahlengthsind(ahangle2) ;
2259 mfun_arrow_path_parallel := mfun_arrow_path paralleled d ;
2260 draw arrowpath mfun_arrow_path_parallel t ;
2261 fillup arrowhead mfun_arrow_path_parallel t ;
2262 mfun_arrow_path_parallel := (reverse mfun_arrow_path) paralleled d ;
2263 draw arrowpath mfun_arrow_path_parallel t ;
2264 fillup arrowhead mfun_arrow_path_parallel t ;
2265 endgroup ;
2266enddef ;
2267
2268def mfun_draw_arrow_pictures text t =
2269 if autoarrows :
2270 set_ahlength(t) ;
2271 fi
2272 save d ; d := ahscaleahlengthsind(ahangle2) ;
2273 mfun_with_arrow_picture(
2274 if mfun_arrow_count = 1 :
2275 draw (mfun_arrow_path paralleled d) mfun_decoration_i i t ;
2276 mfun_arrow_path_parallel := (reverse mfun_arrow_path) paralleled d ;
2277 draw arrowpath mfun_arrow_path_parallel mfun_decoration_i i t ;
2278 fillup arrowhead mfun_arrow_path_parallel mfun_decoration_i i t ;
2279 elseif mfun_arrow_count = mfun_arrow_snippets :
2280 draw ((reverse mfun_arrow_path) paralleled d) mfun_decoration_i i t ;
2281 mfun_arrow_path_parallel := mfun_arrow_path paralleled d ;
2282 draw arrowpath mfun_arrow_path_parallel mfun_decoration_i i t ;
2283 fillup arrowhead mfun_arrow_path_parallel mfun_decoration_i i t ;
2284 else :
2285 draw ( mfun_arrow_path paralleled d) mfun_decoration_i i t ;
2286 draw ((reverse mfun_arrow_path) paralleled d) mfun_decoration_i i t ;
2287 fi
2288 )
2289 endgroup ;
2290enddef ;
2291
2292
2293
2294vardef pointarrow (expr pat, loc, len, off) =
2295 save l, r, s, t ; path l, r ; numeric s ; pair t ;
2296 t := if pair loc : loc else : point loc along pat fi ;
2297 s := len2 off ; if s<=0 : s := 0 elseif s>len : s := len fi ;
2298 r := pat cutbefore t ;
2299 r := (r cutafter point (arctime s of r) of r) ;
2300 s := len2 off ; if s<=0 : s := 0 elseif s>len : s := len fi ;
2301 l := reverse (pat cutafter t) ;
2302 l := (reverse (l cutafter point (arctime s of l) of l)) ;
2303 (l..r)
2304enddef ;
2305
2306def rightarrow (expr pat,tim,len) = pointarrow(pat,tim,len,len) enddef ;
2307def leftarrow (expr pat,tim,len) = pointarrow(pat,tim,len,len) enddef ;
2308def centerarrow (expr pat,tim,len) = pointarrow(pat,tim,len, 0) enddef ;
2309
2310permanent drawarrow, drawdblarrow, drawdoublearrows, drawdoublearrow, pointarrow, rightarrow, leftarrow, centerarrow ;
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321primarydef pct along pat =
2322 (arctime (pct (arclength pat)) of pat) of pat
2323enddef ;
2324
2325primarydef len on pat =
2326 (arctime if len>=0 : len else : (arclength(pat)len) fi of pat) of pat
2327enddef ;
2328
2329
2330
2331tertiarydef pat cutends len =
2332 begingroup
2333 save tap ; path tap ;
2334 tap := pat cutbefore (point (xpart paired(len)) on pat) ;
2335 (tap cutafter (point (ypart paired(len)) on tap))
2336 endgroup
2337enddef ;
2338
2339permanent along, on, cutends ;
2340
2341
2342
2343path freesquare ; freesquare := (
2344 (-1,0) -- (-1,-1) -- (0,-1) -- (+1,-1) --
2345 (+1,0) -- (+1,+1) -- (0,+1) -- (-1,+1) -- cycle
2346) scaled .5 ;
2347
2348numeric freelabeloffset ; freelabeloffset := 3pt ;
2349numeric freedotlabelsize ; freedotlabelsize := 3pt ;
2350
2351vardef thefreelabel (expr asked_text, asked_location, asked_origin) =
2352 save s, p, q, l ; picture s ; path p, q ; pair l ;
2353 interim labeloffset := freelabeloffset ;
2354 s := if string asked_text : thelabel(asked_text,asked_location) else : asked_text shifted center asked_text shifted asked_location fi ;
2355 setbounds s to boundingbox s enlarged freelabeloffset ;
2356 p := fullcircle scaled (2length(asked_locationasked_origin)) shifted asked_origin ;
2357 q := freesquare xyscaled (urcorner s llcorner s) ;
2358 l := point xpart (p intersectiontimes (asked_originasked_location shifted (asked_locationasked_origin))) of q ;
2359 setbounds s to boundingbox s enlarged freelabeloffset ;
2360
2361 (s shifted l)
2362enddef ;
2363
2364vardef freelabel (expr asked_text, asked_location, asked_origin) =
2365 draw thefreelabel(asked_text,asked_location,asked_origin) ;
2366enddef ;
2367
2368vardef freedotlabel (expr asked_text, asked_location, asked_origin) =
2369 interim linecap := rounded ;
2370 draw asked_location withpen pencircle scaled freedotlabelsize ;
2371 draw thefreelabel(asked_text,asked_location,asked_origin) ;
2372enddef ;
2373
2374immutable freesquare ;
2375permanent freelabeloffset, freedotlabelsize, thefreelabel, freelabel, freedotlabel ;
2376
2377
2378
2379
2380
2381newinternal angleoffset ; angleoffset := 0pt ;
2382newinternal anglelength ; anglelength := 20pt ;
2383newinternal anglemethod ; anglemethod := 1 ;
2384
2385vardef anglebetween (expr a, b, s) =
2386 save pointa, pointb, common, middle, offset ;
2387 pair pointa, pointb, common, middle, offset ;
2388 save curve ; path curve ;
2389 save where ; numeric where ;
2390 if round point 0 of a = round point 0 of b :
2391 common := point 0 of a ;
2392 else :
2393 common := a intersectionpoint b ;
2394 fi ;
2395 pointa := point anglelength on a ;
2396 pointb := point anglelength on b ;
2397 where := turningnumber (commonpointapointbcycle) ;
2398 middle := (reverse(commonpointa) rotatedaround (pointa,where90))
2399 intersection_point
2400 (reverse(commonpointb) rotatedaround (pointb, where90)) ;
2401 if not intersection_found :
2402 middle := point .5 along
2403 ((reverse(commonpointa) rotatedaround (pointa,where90)) --
2404 ( (commonpointb) rotatedaround (pointb, where90))) ;
2405 fi ;
2406 if anglemethod = 0 :
2407 curve := pointa{unitvector(middlepointa)}.. pointb;
2408 middle := point .5 along curve ;
2409 curve := common ;
2410 elseif anglemethod = 1 :
2411 curve := pointa{unitvector(middlepointa)}.. pointb;
2412 middle := point .5 along curve ;
2413 elseif anglemethod = 2 :
2414 middle := common rotatedaround(.5[pointa,pointb],180) ;
2415 curve := pointamiddlepointb ;
2416 elseif anglemethod = 3 :
2417 curve := pointamiddlepointb ;
2418 elseif anglemethod = 4 :
2419 curve := pointa..controls middle..pointb ;
2420 middle := point .5 along curve ;
2421 fi ;
2422 draw thefreelabel(s, middle, common) ;
2423 curve
2424enddef ;
2425
2426permanent anglebetween, angleoffset, anglelength, anglemethod ;
2427
2428
2429
2430picture mfun_current_picture_stack[] ;
2431numeric mfun_current_picture_depth ;
2432
2433mfun_current_picture_depth := 0 ;
2434
2435def pushcurrentpicture =
2436 mfun_current_picture_depth := mfun_current_picture_depth 1 ;
2437 mfun_current_picture_stack[mfun_current_picture_depth] := currentpicture ;
2438 currentpicture := nullpicture ;
2439enddef ;
2440
2441def popcurrentpicture text t =
2442 if mfun_current_picture_depth > 0 :
2443 addto mfun_current_picture_stack[mfun_current_picture_depth] also currentpicture t ;
2444 currentpicture := mfun_current_picture_stack[mfun_current_picture_depth] ;
2445 mfun_current_picture_stack[mfun_current_picture_depth] := nullpicture ;
2446 mfun_current_picture_depth := mfun_current_picture_depth 1 ;
2447 fi ;
2448enddef ;
2449
2450permanent pushcurrentpicture, popcurrentpicture ;
2451
2452
2453
2454vardef penpoint expr pnt of p =
2455 save n, d ; numeric n, d ;
2456 (n,d) = if pair pnt : pnt else : (pnt,1) fi ;
2457 (point n of p shifted ((penoffset direction n of p of currentpen) scaled d))
2458enddef ;
2459
2460permanent penpoint ;
2461
2462
2463
2464vardef colorcircle (expr size, red, green, blue) =
2465 save r, g, b, c, m, y, w ; save radius ;
2466 path r, g, b, c, m, y, w ; numeric radius ;
2467
2468 radius := 5cm ; pickup pencircle scaled (radius25) ;
2469
2470 transform t ; t := identity rotatedaround(origin,120) ;
2471
2472 r := fullcircle rotated 90 scaled radius shifted (0,radius4) rotatedaround(origin,135) ;
2473
2474 b := r transformed t ; g := b transformed t ;
2475
2476 c := buildcycle(subpath(1,7) of g,subpath(1,7) of b) ;
2477 y := c transformed t ; m := y transformed t ;
2478
2479 w := buildcycle(subpath(3,5) of r, subpath(3,5) of g,subpath(3,5) of b) ;
2480
2481 pushcurrentpicture ;
2482
2483 fill r withcolor red ;
2484 fill g withcolor green ;
2485 fill b withcolor blue ;
2486 fill c withcolor white red ;
2487 fill m withcolor white green ;
2488 fill y withcolor white blue ;
2489 fill w withcolor white ;
2490
2491 for i = r,g,b,c,m,y : draw i withcolor .5white ; endfor ;
2492
2493 currentpicture := currentpicture xsized size ;
2494
2495 popcurrentpicture ;
2496enddef ;
2497
2498
2499
2500primarydef p uncolored c =
2501 if color p :
2502 c p
2503 else :
2504 image (
2505 for i within p :
2506 addto currentpicture
2507 if stroked i or filled i :
2508 if filled i :
2509 contour
2510 else :
2511 doublepath
2512 fi
2513 pathpart i
2514 dashed dashpart i withpen penpart i
2515 else :
2516 also i
2517 fi
2518 withcolor c(redpart i, greenpart i, bluepart i) ;
2519 endfor ;
2520 )
2521 fi
2522enddef ;
2523
2524vardef inverted primary p =
2525 p uncolored white
2526enddef ;
2527
2528primarydef p softened c =
2529 begingroup
2530 save cc ; color cc ; cc := tripled(c) ;
2531 if color p :
2532 (redpart cc redpart p,greenpart cc greenpart p, bluepart cc bluepart p)
2533 else :
2534 image (
2535 for i within p :
2536 addto currentpicture
2537 if stroked i or filled i :
2538 if filled i :
2539 contour
2540 else :
2541 doublepath
2542 fi
2543 pathpart i
2544 dashed dashpart i withpen penpart i
2545 else :
2546 also i
2547 fi
2548 withcolor (redpart cc redpart i, greenpart cc greenpart i, bluepart cc bluepart i) ;
2549 endfor ;
2550 )
2551 fi
2552 endgroup
2553enddef ;
2554
2555vardef grayed primary p =
2556 if rgbcolor p :
2557 tripled(.30redpart p+.59greenpart p+.11bluepart p)
2558 elseif cmykcolor p :
2559 tripled(.30(1cyanpart i)+.59(1magentapart i)+.11(1yellowpart i)blackpart i)
2560 elseif greycolor p :
2561 p
2562 elseif string p :
2563 grayed resolvedcolor(p)
2564 elseif picture p :
2565 image (
2566 for i within p :
2567 addto currentpicture
2568 if stroked i or filled i :
2569 if filled i :
2570 contour
2571 else :
2572 doublepath
2573 fi
2574 pathpart i
2575 dashed dashpart i
2576 withpen penpart i
2577 else :
2578 also i
2579 fi
2580 if unknown colorpart i :
2581
2582 elseif rgbcolor colorpart i :
2583 withcolor tripled(.30redpart i+.59greenpart i+.11bluepart i) ;
2584 elseif cmykcolor colorpart i :
2585 withcolor tripled(.30(1cyanpart i)+.59(1magentapart i)+.11(1yellowpart i)blackpart i) ;
2586 else :
2587 withcolor colorpart i ;
2588 fi
2589 endfor ;
2590 )
2591 else :
2592 p
2593 fi
2594enddef ;
2595
2596let greyed = grayed ;
2597
2598vardef hsvtorgb(expr h,s,v) =
2599 save H, S, V, x ;
2600 H = h mod 360 ;
2601 S = if s < 0 : 0 elseif s > 1 : 1 else: s fi ;
2602 V = if v < 0 : 0 elseif v > 1 : 1 else: v fi ;
2603 x = 1 abs(H mod 120 60)60 ;
2604 V ( (1S) (1,1,1) S
2605 if H < 60 : (1,x,0)
2606 elseif H < 120 : (x,1,0)
2607 elseif H < 180 : (0,1,x)
2608 elseif H < 240 : (0,x,1)
2609 elseif H < 300 : (x,0,1)
2610 else : (1,0,x)
2611 fi )
2612enddef ;
2613
2614permanent colorcircle, uncolored, inverted, grayed, greyed, hsvtorgb ;
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635def condition primary b = if b : "true" else : "false" fi enddef ;
2636
2637permanent condition ;
2638
2639
2640
2641primarydef p stretched s =
2642 begingroup
2643 save pp ; path pp ; pp := p xyscaled s ;
2644 (pp shifted ((point 0 of p) (point 0 of pp)))
2645 endgroup
2646enddef ;
2647
2648primarydef p enlonged len =
2649 begingroup
2650 if len == 0 :
2651 p
2652 elseif pair p :
2653 save q ; path q ; q := origin -- p ;
2654 save al ; al := arclength(q) ;
2655 if al > 0 :
2656 point 1 of (q stretched ((allen)al))
2657 else :
2658 p
2659 fi
2660 else :
2661 save al ; al := arclength(p) ;
2662 if al > 0 :
2663 p stretched ((allen)al)
2664 else :
2665 p
2666 fi
2667 fi
2668 endgroup
2669enddef ;
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679primarydef p shortened d =
2680 reverse ( ( reverse (p enlonged xpart paired(d)) ) enlonged ypart paired(d) )
2681enddef ;
2682
2683
2684
2685def xshifted expr dx = shifted(dx,0) enddef ;
2686def yshifted expr dy = shifted(0,dy) enddef ;
2687
2688
2689permanent stretched, enlonged, shortened, xshifted, yshifted ;
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710def readfile (expr name) =
2711 begingroup ; save ok ; boolean ok ;
2712 if (readfrom (name) <> EOF) :
2713 ok := false ;
2714 elseif (readfrom (name) <> EOF) :
2715 ok := false ;
2716 else :
2717 ok := true ;
2718 fi ;
2719 if not ok :
2720 scantokens("input " & name & " ") ;
2721 fi ;
2722 closefrom (name) ;
2723 endgroup ;
2724enddef ;
2725
2726permanent readfile ;
2727
2728
2729
2730inner end ;
2731
2732
2733
2734let mfun_remap_colors_normalwithcolor = normalwithcolor ;
2735
2736def remapcolors =
2737 def normalwithcolor primary c =
2738 mfun_remap_colors_normalwithcolor remappedcolor(c)
2739 enddef ;
2740enddef ;
2741
2742def normalcolors =
2743 let normalwithcolor = mfun_remap_colors_normalwithcolor ;
2744enddef ;
2745
2746def resetcolormap =
2747 color color_map[][][] ;
2748 normalcolors ;
2749enddef ;
2750
2751resetcolormap ;
2752
2753def r_color primary c = redpart c enddef ;
2754def g_color primary c = greenpart c enddef ;
2755def b_color primary c = bluepart c enddef ;
2756
2757def remapcolor(expr old, new) =
2758 color_map[redpart old][greenpart old][bluepart old] := new ;
2759enddef ;
2760
2761def remappedcolor(expr c) =
2762 if known color_map[redpart c][greenpart c][bluepart c] :
2763 color_map[redpart c][greenpart c][bluepart c]
2764 else :
2765 c
2766 fi
2767enddef ;
2768
2769
2770
2771
2772def recolor suffix p = p := mfun_repathed (0,p) enddef ;
2773def refill suffix p = p := mfun_repathed (1,p) enddef ;
2774def redraw suffix p = p := mfun_repathed (2,p) enddef ;
2775def retext suffix p = p := mfun_repathed (3,p) enddef ;
2776def untext suffix p = p := mfun_repathed (4,p) enddef ;
2777
2778
2779
2780
2781
2782
2783
2784color refillbackground ; refillbackground := (1,1,1) ;
2785
2786def restroke suffix p = p := mfun_repathed (21,p) enddef ;
2787def reprocess suffix p = p := mfun_repathed (22,p) enddef ;
2788
2789permanent recolor, refill, redraw, retext, untext, restroke, reprocess, refillbackground ;
2790
2791
2792
2793vardef mfun_repathed (expr mode, p) text t =
2794 begingroup ;
2795 if mode = 0 :
2796 save normalwithcolor ;
2797 remapcolors ;
2798 fi ;
2799 save temp_p, temp_q, temp_r, temp_f, temp_b ;
2800 picture temp_p, temp_q, temp_r ; color temp_f ; path temp_b ;
2801 temp_b := boundingbox p ;
2802 temp_p := nullpicture ;
2803 for i within p :
2804 temp_f := (redpart i, greenpart i, bluepart i) ;
2805 if bounded i :
2806 temp_q := mfun_repathed(mode,i) t ;
2807 setbounds temp_q to pathpart i ;
2808 addto temp_p also temp_q ;
2809 elseif clipped i :
2810 temp_q := mfun_repathed(mode,i) t ;
2811 clip temp_q to pathpart i ;
2812 addto temp_p also temp_q ;
2813 elseif stroked i :
2814 if mode=21 :
2815 temp_r := i ;
2816 addto temp_p also image(scantokens(t & " pathpart temp_r")
2817 dashed dashpart i withpen penpart i
2818 withcolor temp_f ; ) ;
2819 elseif mode=22 :
2820 temp_r := i ;
2821 addto temp_p also image(scantokens(t & " pathpart temp_r")) ;
2822 else :
2823 addto temp_p doublepath pathpart i
2824 dashed dashpart i withpen penpart i
2825 withcolor temp_f
2826 if mode = 2 :
2827 t
2828 fi ;
2829 fi ;
2830 elseif filled i :
2831 if mode=11 :
2832 temp_r := i ;
2833 addto temp_p also image(scantokens(t & " pathpart temp_r")
2834 withcolor temp_f ; ) ;
2835 elseif mode=12 :
2836 temp_r := i ;
2837 addto temp_p also image(scantokens(t & " pathpart temp_r")) ;
2838 else :
2839 addto temp_p contour pathpart i
2840 withcolor temp_f
2841 if (mode=1) and (temp_f<>refillbackground) :
2842 t
2843 fi ;
2844 fi ;
2845 else :
2846 addto temp_p also i ;
2847 fi ;
2848 endfor ;
2849 setbounds temp_p to temp_b ;
2850 temp_p
2851 endgroup
2852enddef ;
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877def clearxy text s =
2878 if false for $ := s : or true endfor :
2879 forsuffixes $ := s : x$ := whatever ; y$ := whatever ; endfor ;
2880 else :
2881 save x, y ;
2882 fi
2883enddef ;
2884
2885permanent clearxy ;
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895primarydef p smoothed d =
2896 (p llmoved (xpart paired(d),0) -- p lrmoved (xpart paired(d),0) {right} ..
2897 p lrmoved (0,ypart paired(d)) -- p urmoved (0,ypart paired(d)) {up} ..
2898 p urmoved (xpart paired(d),0) -- p ulmoved (xpart paired(d),0) {left} ..
2899 p ulmoved (0,ypart paired(d)) -- p llmoved (0,ypart paired(d)) {down} .. cycle)
2900enddef ;
2901
2902primarydef p cornered c =
2903 ((point 0 of p) shifted (c(unitvector(point 1 of p point 0 of p))) --
2904 for i=1 upto length(p) :
2905 (point i-1 of p) shifted (c(unitvector(point i of p point i-1 of p))) --
2906 (point i of p) shifted (c(unitvector(point i-1 of p point i of p))) ..
2907 controls point i of p ..
2908 endfor cycle)
2909enddef ;
2910
2911
2912
2913
2914primarydef p smoothcornered c =
2915 ( begingroup ;
2916 save cc ;
2917 if not cycle p: (point 0 of p) -- fi
2918 for i=1 upto length(p) :
2919 hide (cc := min(c,arclength (subpath(i-1,i) of p)2);)
2920 (point i-1 of p) shifted (cc(unitvector(point i of p point i-1 of p))) --
2921 (point i of p) shifted (cc(unitvector(point i-1 of p point i of p))) ..
2922 controls point i of p ..
2923 endfor
2924 if cycle p : cycle else : point 1 along p fi
2925 endgroup )
2926enddef ;
2927
2928permanent smoothed, cornered, smoothcornered ;
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968vardef bbwidth primary p =
2969 if unknown p :
2970 0
2971 elseif path p or picture p :
2972 save r ; pair r ; r := xrange p ;
2973 ypart r xpart r
2974 else :
2975 0
2976 fi
2977enddef ;
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009vardef bbheight primary p =
3010 if unknown p :
3011 0
3012 elseif path p or picture p :
3013 save r ; pair r ; r := yrange p ;
3014 ypart r xpart r
3015 else :
3016 0
3017 fi
3018enddef ;
3019
3020permanent bbwidth, bbheight ;
3021
3022color nocolor ; numeric noline ;
3023
3024def dowithpath (expr p, lw, lc, bc) =
3025 if known p :
3026 if known bc :
3027 fill p withcolor bc ;
3028 fi ;
3029 if known lw and known lc :
3030 draw p withpen pencircle scaled lw withcolor lc ;
3031 elseif known lw :
3032 draw p withpen pencircle scaled lw ;
3033 elseif known lc :
3034 draw p withcolor lc ;
3035 fi ;
3036 fi ;
3037enddef ;
3038
3039
3040
3041def [[[ = [ [ [ enddef ;
3042def ]]] = ] ] ] enddef ;
3043
3044let == = = ;
3045
3046permanent [[[, ]]], ==;
3047
3048
3049
3050picture oddly ;
3051
3052evenly := dashpattern(on 3 off 3) ;
3053oddly := dashpattern(off 3 on 3) ;
3054
3055
3056
3057vardef mfun_straightened(expr sign, p) =
3058 save temp_p, temp_q ; path temp_p, temp_q ;
3059 temp_p := p ;
3060 forever :
3061 temp_q := mfun_do_straightened(sign, temp_p) ;
3062 exitif length(temp_p) = length(temp_q) ;
3063 temp_p := temp_q ;
3064 endfor ;
3065 temp_q
3066enddef ;
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082vardef mfun_do_straightened(expr sign, p) =
3083 if length(p) > 2 :
3084 save pp ; path pp ;
3085 pp := point 0 of p ;
3086 for i=1 upto length(p)-1 :
3087 if round(point i of p) <> round(point length(pp) of pp) :
3088 pp := pp -- point i of p ;
3089 fi ;
3090 endfor ;
3091 save n, ok ; numeric n ; boolean ok ;
3092 n := length(pp) ; ok := false ;
3093 if n > 2 :
3094 for i=0 upto n :
3095 if unitvector(round(point i of pp point if i=0 : n else : i-1 fi of pp)) <>
3096 sign unitvector(round(point if i=n : 0 else : i+1 fi of pp point i of pp)) :
3097 if ok :
3098 --
3099 else :
3100 ok := true ;
3101 fi point i of pp
3102 fi
3103 endfor
3104 if ok and (cycle p) :
3105 -- cycle
3106 fi
3107 else :
3108 pp
3109 fi
3110 else :
3111 p
3112 fi
3113enddef ;
3114
3115vardef simplified expr p = (
3116 reverse mfun_straightened(+1,mfun_straightened(+1,reverse p))
3117) enddef ;
3118
3119vardef unspiked expr p = (
3120 reverse mfun_straightened(-1,mfun_straightened(-1,reverse p))
3121) enddef ;
3122
3123permanent simplified, unspiked ;
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141path originpath ; originpath := origin -- cycle ;
3142
3143vardef unitvector primary z =
3144 if abs z = abs origin : z else : zabs z fi
3145enddef;
3146
3147vardef epsed (expr e) =
3148 e if e>0 : eps elseif e < 0 : eps fi
3149enddef ;
3150
3151immutable originpath ;
3152permanent unitvector, epsed ;
3153
3154
3155
3156def withgray primary g =
3157 withcolor g
3158enddef ;
3159
3160if unknown darkred : color darkred ; darkred := .625(1,0,0) fi ;
3161if unknown darkgreen : color darkgreen ; darkgreen := .625(0,1,0) fi ;
3162if unknown darkblue : color darkblue ; darkblue := .625(0,0,1) fi ;
3163if unknown darkcyan : color darkcyan ; darkcyan := .625(0,1,1) fi ;
3164if unknown darkmagenta : color darkmagenta ; darkmagenta := .625(1,0,1) fi ;
3165if unknown darkyellow : color darkyellow ; darkyellow := .625(1,1,0) fi ;
3166if unknown darkgray : color darkgray ; darkgray := .625(1,1,1) fi ;
3167if unknown lightgray : color lightgray ; lightgray := .850(1,1,1) fi ;
3168
3169permanent withgray ;
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183vardef center primary p =
3184 centerof p
3185enddef ;
3186
3187
3188
3189vardef rangepath (expr p, d, a) =
3190 if length p>0 :
3191 (dunitvector(direction 0 of p) rotated a) shifted point 0 of p
3192 -- p --
3193 (dunitvector(direction length(p) of p) rotated a) shifted point length(p) of p
3194 else :
3195 p
3196 fi
3197enddef ;
3198
3199
3200
3201vardef straightpath (expr a, b, method) =
3202 if (method<1) or (method>6) :
3203 (ab)
3204 elseif method = 1 :
3205 (a --
3206 if xpart a > xpart b :
3207 if ypart a > ypart b :
3208 (xpart b,ypart a) --
3209 elseif ypart a < ypart b :
3210 (xpart a,ypart b) --
3211 fi
3212 elseif xpart a < xpart b :
3213 if ypart a > ypart b :
3214 (xpart a,ypart b) --
3215 elseif ypart a < ypart b :
3216 (xpart b,ypart a) --
3217 fi
3218 fi
3219 b)
3220 elseif method = 3 :
3221 (a --
3222 if xpart a > xpart b :
3223 (xpart b,ypart a) --
3224 elseif xpart a < xpart b :
3225 (xpart a,ypart b) --
3226 fi
3227 b)
3228 elseif method = 5 :
3229 (a --
3230 if ypart a > ypart b :
3231 (xpart b,ypart a) --
3232 elseif ypart a < ypart b :
3233 (xpart a,ypart b) --
3234 fi
3235 b)
3236 else :
3237 (reverse straightpath(b,a,method-1))
3238 fi
3239enddef ;
3240
3241permanent straightpath ;
3242
3243
3244
3245def addbackground text t =
3246 begingroup ;
3247 save p, b ; picture p ; path b ;
3248 b := boundingbox currentpicture ;
3249 p := currentpicture ; currentpicture := nullpicture ;
3250 fill b t ;
3251 setbounds currentpicture to b ;
3252 addto currentpicture also p ;
3253 endgroup ;
3254enddef ;
3255
3256permanent addbackground ;
3257
3258
3259
3260
3261vardef infinite expr p =
3262 (infinityunitvector(direction 0 of p)
3263 shifted point 0 of p
3264 -- p --
3265 infinityunitvector(direction length(p) of p)
3266 shifted point length(p) of p)
3267enddef ;
3268
3269permanent infinite ;
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322def showgrid (expr minx, maxx, deltax, miny, maxy, deltay) =
3323 begingroup
3324 save size ; numeric size ; size := 2pt ;
3325 for x=minx upto maxx :
3326 for y=miny upto maxy :
3327 draw (xdeltax, ydeltay) withpen pencircle scaled
3328 if (x mod 5 = 0) and (y mod 5 = 0) :
3329 1.5size withcolor .50white
3330 else :
3331 size withcolor .75white
3332 fi ;
3333 endfor ;
3334 endfor ;
3335 for x=minx upto maxx:
3336 label.bot(textext("\infofont " & decimal x), (xdeltax,size)) ;
3337 endfor ;
3338 for y=miny upto maxy:
3339 label.lft(textext("\infofont " & decimal y), (size,ydeltay)) ;
3340 endfor ;
3341 endgroup
3342enddef;
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371vardef phantom (text t) =
3372 picture temp_p ;
3373 temp_p := image(t) ;
3374 addto temp_p also currentpicture ;
3375 setbounds currentpicture to boundingbox temp_p ;
3376enddef ;
3377
3378vardef c_phantom (expr b) (text t) =
3379 if b :
3380 save temp_p; picture temp_p ;
3381 temp_p := image(t) ;
3382 addto temp_p also currentpicture ;
3383 setbounds currentpicture to boundingbox temp_p ;
3384 else :
3385 t ;
3386 fi ;
3387enddef ;
3388
3389permanent phantom ;
3390
3391
3392
3393def break =
3394 exitif true ;
3395enddef ;
3396
3397permanent break ;
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409primarydef p xstretched w = (
3410 begingroup save l, r ; pair r;
3411 r := xrange p ;
3412 l := ypart r xpart r ;
3413 p if (l > 0) and (w > 0) : xscaled (wl) fi
3414 endgroup
3415) enddef ;
3416
3417primarydef p ystretched h = (
3418 begingroup save l, r ; pair r;
3419 r := yrange p ;
3420 l := ypart r xpart r ;
3421 p if (l > 0) and (h > 0) : yscaled (hl) fi
3422 endgroup
3423) enddef ;
3424
3425permanent xstretched, ystretched ;
3426
3427
3428
3429vardef area expr p =
3430
3431 (xpart llcorner boundingbox p,0) -- p --
3432 (xpart lrcorner boundingbox p,0) -- cycle
3433enddef ;
3434
3435vardef basiccolors[] =
3436 if @ = 0 :
3437 white
3438 else :
3439 save n ; n := @ mod 7 ;
3440 if n = 1 : red
3441 elseif n = 2 : green
3442 elseif n = 3 : blue
3443 elseif n = 4 : cyan
3444 elseif n = 5 : magenta
3445 elseif n = 6 : yellow
3446 else : black
3447 fi
3448 fi
3449enddef ;
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460vardef rcomponent expr p = if rgbcolor p : redpart p elseif cmykcolor p : 1 cyanpart p else : p fi enddef ;
3461vardef gcomponent expr p = if rgbcolor p : greenpart p elseif cmykcolor p : 1 magentapart p else : p fi enddef ;
3462vardef bcomponent expr p = if rgbcolor p : bluepart p elseif cmykcolor p : 1 yellowpart p else : p fi enddef ;
3463vardef ccomponent expr p = if cmykcolor p : cyanpart p elseif rgbcolor p : 1 redpart p else : p fi enddef ;
3464vardef mcomponent expr p = if cmykcolor p : magentapart p elseif rgbcolor p : 1 greenpart p else : p fi enddef ;
3465vardef ycomponent expr p = if cmykcolor p : yellowpart p elseif rgbcolor p : 1 bluepart p else : p fi enddef ;
3466vardef kcomponent expr p = if cmykcolor p : blackpart p elseif rgbcolor p : 0 else : p fi enddef ;
3467
3468permanent rcomponent, gcomponent, bcomponent, ccomponent, mcomponent, ycomponent, kcomponent ;
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493vardef undecorated (text t) text decoration =
3494 save currentpicture ;
3495 picture currentpicture ;
3496 currentpicture := nullpicture ;
3497 t ;
3498 currentpicture
3499enddef ;
3500
3501vardef decorated (text imagedata) text decoration =
3502 save mfun_decorated_path, currentpicture ;
3503 picture mfun_decorated_path, currentpicture ;
3504 currentpicture := nullpicture ;
3505 imagedata ;
3506 mfun_decorated_path := currentpicture ;
3507 currentpicture := nullpicture ;
3508 for i within mfun_decorated_path :
3509 addto currentpicture
3510 if stroked i :
3511 doublepath pathpart i
3512 dashed dashpart i
3513 withpen penpart i
3514 withcolor colorpart i
3515 withprescript prescriptpart i
3516 withpostscript postscriptpart i
3517 decoration
3518 elseif filled i :
3519 contour pathpart i
3520 withpen penpart i
3521 withcolor colorpart i
3522 withprescript prescriptpart i
3523 withpostscript postscriptpart i
3524 decoration
3525 elseif textual i :
3526 also i
3527 withcolor colorpart i
3528 withprescript prescriptpart i
3529 withpostscript postscriptpart i
3530 decoration
3531 else :
3532 also i
3533 fi
3534 ;
3535 endfor ;
3536 currentpicture
3537enddef ;
3538
3539vardef redecorated (text imagedata) text decoration =
3540 save mfun_decorated_path, currentpicture ;
3541 picture mfun_decorated_path, currentpicture ;
3542 currentpicture := nullpicture ;
3543 imagedata ;
3544 mfun_decorated_path := currentpicture ;
3545 currentpicture := nullpicture ;
3546 for i within mfun_decorated_path :
3547 addto currentpicture
3548 if stroked i :
3549 doublepath pathpart i
3550 dashed dashpart i
3551 withpen penpart i
3552 decoration
3553 elseif filled i :
3554 contour pathpart i
3555 withpen penpart i
3556 decoration
3557 elseif textual i :
3558 also i
3559 decoration
3560 else :
3561 also i
3562 fi
3563 ;
3564 endfor ;
3565 currentpicture
3566enddef ;
3567
3568permanent decorated, undecorated, redecorated ;
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584vardef mfun_snapped(expr p, s) =
3585 if p < 0 : ( else : ( fi p div s) s
3586enddef ;
3587
3588vardef mfun_applied(expr p, s)(suffix a) =
3589 if path p :
3590 if pair s :
3591 for i=0 upto length(p)-1 :
3592 (a(xpart point i of p,xpart s),a(ypart point i of p,ypart s)) --
3593 endfor
3594 if cycle p :
3595 cycle
3596 else :
3597 (a(xpart point length(p) of p,xpart s),a(ypart point length(p) of p,ypart s))
3598 fi
3599 else :
3600 for i=0 upto length(p)-1 :
3601 (a(xpart point i of p,s),a(ypart point i of p,s)) --
3602 endfor
3603 if cycle p :
3604 cycle
3605 else :
3606 (a(xpart point length(p) of p,s),a(ypart point length(p) of p,s))
3607 fi
3608 fi
3609 elseif pair p :
3610 if pair s :
3611 (a(xpart p,xpart s),a(ypart p,ypart s))
3612 else :
3613 (a(xpart p,s),a(ypart p,s))
3614 fi
3615 elseif cmykcolor p :
3616 (a(cyanpart p,s),a(magentapart p,s),a(yellowpart p,s),a(blackpart p,s))
3617 elseif rgbcolor p :
3618 (a(redpart p,s),a(greenpart p,s),a(bluepart p,s))
3619 elseif graycolor p :
3620 a(p,s)
3621 elseif numeric p :
3622 a(p,s)
3623 else
3624 p
3625 fi
3626enddef ;
3627
3628primarydef p snapped s =
3629 mfun_applied(p,s)(mfun_snapped)
3630enddef ;
3631
3632permanent snapped ;
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645picture font_glyph[][] ;
3646numeric font_count ; font_count := 0;
3647
3648def beginfont(expr n) =
3649 begingroup ;
3650 save name ; string name; name := n;
3651 font_count := font_count 1 ;
3652 lmt_registerglyphs [
3653 name = name,
3654 units = 10,
3655 width = 10,
3656 height = 8,
3657 depth = 2,
3658 ] ;
3659enddef ;
3660
3661def endfont =
3662 endgroup;
3663enddef ;
3664
3665def beginglyph(expr u, w, h, d) =
3666 save unicode ; unicode := u;
3667 lmt_registerglyph [
3668 category = name,
3669 unicode = u,
3670 code = "draw font_glyph[" & decimal font_count & "][" & decimal u & "];"
3671 width = w,
3672 height = h,
3673 depth = d,
3674 ] ;
3675 currentpicture := nullpicture ;
3676enddef ;
3677
3678def endglyph =
3679 font_glyph[font_count][unicode] := currentpicture ;
3680enddef ;
3681
3682permanent beginfont, endfont, beginglyph, endglyph ;
3683
3684
3685
3686
3687newinternal maxdimensions ; maxdimensions := 14000 ;
3688
3689def mfun_apply_max_dimensions =
3690 if bbwidth currentpicture > maxdimensions :
3691 currentpicture := currentpicture if bbheight currentpicture > bbwidth currentpicture : ysized else : xsized fi maxdimensions ;
3692 elseif bbheight currentpicture > maxdimensions :
3693 currentpicture := currentpicture ysized maxdimensions ;
3694 fi ;
3695enddef;
3696
3697extra_endfig := extra_endfig & "mfun_apply_max_dimensions ;" ;
3698
3699
3700
3701path unittriangle, fulltriangle ;
3702
3703unittriangle := point 0 along unitcircle
3704 -- point 13 along unitcircle
3705 -- point 23 along unitcircle
3706 -- cycle ;
3707fulltriangle := point 0 along fullcircle
3708 -- point 13 along fullcircle
3709 -- point 23 along fullcircle
3710 -- cycle ;
3711
3712immutable unittriangle, fulltriangle ;
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726vardef listsize(suffix list) =
3727 numeric len ; len := 1 ;
3728 forever :
3729 exitif unknown list[len] ;
3730 len := len 1 ;
3731 endfor ;
3732 len if unknown list[0] : 1 fi
3733enddef ;
3734
3735vardef listlast(suffix list) =
3736 numeric len ; len := if known list[0] : 0 else : 1 fi ;
3737 forever :
3738 len := len 1 ;
3739 exitif unknown list[len] ;
3740 endfor ;
3741 len 1
3742enddef ;
3743
3744vardef mfun_quick_sort(suffix list)(expr asked_min, asked_max)(text what) =
3745 save l, r, m ;
3746 numeric l ; l := asked_min ;
3747 numeric r ; r := asked_max ;
3748 numeric m ; m := floor(.5[asked_min,asked_max]) ;
3749 asked_mid := what list[m] ;
3750 forever :
3751 exitif l >= r ;
3752 forever :
3753 exitif l > asked_max ;
3754
3755 exitif (what list[l]) >= asked_mid ;
3756 l := l 1 ;
3757 endfor ;
3758 forever :
3759 exitif r < asked_min ;
3760
3761 exitif asked_mid >= (what list[r]) ;
3762 r := r 1 ;
3763 endfor ;
3764 if l <= r :
3765 temp := list[l] ;
3766 list[l] := list[r] ;
3767 list[r] := temp ;
3768 l := l 1 ;
3769 r := r 1 ;
3770 fi ;
3771 endfor ;
3772 if asked_min < r :
3773 mfun_quick_sort(list)(asked_min,r)(what) ;
3774 fi ;
3775 if l < asked_max :
3776 mfun_quick_sort(list)(l,asked_max)(what) ;
3777 fi ;
3778enddef ;
3779
3780vardef sortlist(suffix list)(text what) =
3781 save asked_max ; numeric asked_max ;
3782 save asked_mid ; numeric asked_mid ;
3783 save temp ;
3784
3785 asked_max := listlast(list) ;
3786 if pair list[asked_max] :
3787 pair temp ;
3788 else :
3789 numeric temp ;
3790 fi ;
3791 if pair what list[asked_max] :
3792 pair asked_mid ;
3793 else :
3794 numeric asked_mid ;
3795 fi ;
3796 if asked_max > 1 :
3797
3798 mfun_quick_sort(list)(if known list[0] : 0 else : 1 fi,asked_max)(what) ;
3799 fi ;
3800enddef ;
3801
3802vardef uniquelist(suffix list) =
3803
3804enddef ;
3805
3806vardef copylist(suffix list, target) =
3807 save i ; i := 1 ;
3808 forever :
3809 exitif unknown list[i] ;
3810 target[i] := list[i] ;
3811 i := i 1 ;
3812 endfor ;
3813enddef ;
3814
3815vardef listtolines(suffix list) =
3816 list[1] for i=2 upto listsize(list) : -- list[i] endfor
3817enddef ;
3818
3819vardef listtocurves(suffix list) =
3820 list[1] for i=2 upto listsize(list) : .. list[i] endfor
3821enddef ;
3822
3823
3824
3825
3826
3827vardef shapedlist(suffix p) =
3828 save l ; pair l[] ;
3829 save r ; pair r[] ;
3830 save i ; i := 1 ;
3831 save n ; n := 0 ;
3832 forever :
3833 exitif unknown p[i] ;
3834 n := n 1 ;
3835 l[n] := ulcorner p[i] ;
3836 r[n] := urcorner p[i] ;
3837 n := n 1 ;
3838 l[n] := llcorner p[i] ;
3839 r[n] := lrcorner p[i] ;
3840 i := i 1 ;
3841 endfor ;
3842 for i = 3 upto n :
3843 if xpart r[i] < xpart r[i-1] :
3844 r[i] := (xpart r[i],ypart r[i-1]) ;
3845 elseif xpart r[i] > xpart r[i-1] :
3846 r[i-1] := (xpart r[i-1],ypart r[i]) ;
3847 fi ;
3848 if xpart l[i] < xpart l[i-1] :
3849 l[i-1] := (xpart l[i-1],ypart l[i]) ;
3850 elseif xpart l[i] > xpart l[i-1] :
3851 l[i] := (xpart l[i],ypart l[i-1]) ;
3852 fi ;
3853 endfor ;
3854 if n > 0 :
3855 simplified (
3856 for i = 1 upto n : r[i] -- endfor
3857 for i = n downto 1 : l[i] -- endfor
3858 cycle
3859 )
3860 else :
3861 origin -- cycle
3862 fi
3863enddef ;
3864
3865permanent listsize, listlast, sortlist, uniquelist, copylist, listtolines, listtocurves, shapedlist ;
3866
3867
3868
3869let dump = relax ;
3870
3871
3872
3873def loadmodule expr name =
3874
3875 if (unknown scantokens("context_" & name)) and (unknown scantokens("metafun_loaded_" & name)) :
3876 save s ; string s ; s := "input " & ditto & "mp-" & name & ditto & ";" ;
3877 expandafter scantokens expandafter s
3878 fi ;
3879enddef ;
3880
3881def loadfile (expr filename) = scantokens("input " & filename) enddef ;
3882def loadimage (expr filename) = image(scantokens("input " & filename);) enddef ;
3883
3884permanent loadmodule, loadfile, loadimage ;
3885
3886
3887
3888def drawpathwithpoints expr p =
3889 do_drawpathwithpoints(p)
3890enddef ;
3891
3892def do_drawpathwithpoints(expr p) text t =
3893 draw p t ;
3894 if length(p) > 2 :
3895 begingroup ;
3896 save temp_c ; path temp_c ;
3897 save temp_p; picture temp_p ;
3898 temp_p := image (
3899 temp_c := if cycle p : fullsquare else : fullcircle fi scaled 6pt ;
3900 for i=0 upto length(p) if cycle p : -1 fi :
3901 fill temp_c shifted point i of p withcolor white ;
3902 draw temp_c shifted point i of p withcolor white2 withpen pencircle scaled .5pt ;
3903 if (i = 0) and cycle p :
3904 temp_c := fullcircle scaled 6pt ;
3905 fi ;
3906 endfor ;
3907 for i=0 upto length(p) if cycle p : -1 fi :
3908 draw textext("\infofont " & decimal i) ysized 2pt shifted point i of p ;
3909 endfor ;
3910 ) ;
3911 setbounds temp_p to boundingbox p ;
3912 draw temp_p ;
3913 fi ;
3914enddef ;
3915
3916
3917
3918newinternal crossingdebug ; crossingdebug := 0 ;
3919newinternal crossingscale ; crossingscale := 10 ;
3920newinternal crossingnumbermax ; crossingnumbermax := 1000 ;
3921
3922
3923
3924vardef infotext@#(expr txt, ysize) =
3925 textext@#("\infofont " & if numeric txt : decimal fi txt) ysized ysize
3926enddef ;
3927
3928primarydef p crossingunder q =
3929 begingroup
3930 save pic ; picture pic ; pic := nullpicture ;
3931 if picture p :
3932 for i within p :
3933 if stroked i :
3934 addto pic also image(draw pathpart i crossingunder q) ;
3935 fi
3936 endfor
3937 elseif path p :
3938 save n, t, a, b, c, r, bcuttings, hold ;
3939 numeric n, t[], hold ;
3940 path a, b, c, r, bcuttings, hold[] ;
3941 c := makepath(currentpen scaled crossingscale) ;
3942 r := if picture q : boundingbox fi q ;
3943 t[0] := n := hold := 0 ;
3944 a := p ;
3945
3946
3947 for i=1 upto crossingnumbermax :
3948 clearxy ; z = a intersectiontimes r ;
3949 if x < 0 :
3950 exitif hold < 1 ;
3951 a := hold[hold] ; hold := hold 1 ;
3952 clearxy ; z = a intersectiontimes r ;
3953 fi
3954 (t[incr n], whatever) = p intersectiontimes point x of a ;
3955 if x = 0 :
3956 a := a cutbefore c shifted point x of a ;
3957 elseif x = length a :
3958 a := a cutafter c shifted point x of a ;
3959 else :
3960 b := subpath (0,x) of a cutafter c shifted point x of a ;
3961 bcuttings := cuttings ;
3962 a := subpath (x,length a) of a cutbefore c shifted point x of a ;
3963 clearxy ; z = a intersectiontimes r ;
3964 if x < 0 :
3965 a := b ;
3966 cuttings := bcuttings ;
3967 else :
3968 if length bcuttings > 0 :
3969 clearxy ; z = b intersectiontimes r ;
3970 if x >= 0 :
3971 hold[incr hold] := b ;
3972 fi
3973 fi
3974 fi
3975 fi
3976 if length cuttings = 0 :
3977 exitif hold < 1 ;
3978 a := hold[hold] ; hold := hold 1 ;
3979 fi
3980 if i = crossingnumbermax :
3981 message("crossingunder reached maximum " & decimal i & " intersections.");
3982 fi
3983 endfor
3984
3985 if n = 0 :
3986 save pic ; path pic ; pic := p ;
3987 else :
3988 sortlist(t,) ;
3989
3990 t[incr n] = length p if cycle p : t[1] fi ;
3991
3992
3993
3994
3995 save m ; m := 0 ;
3996 for i=if cycle p: 2 else: 1 fi upto n :
3997
3998
3999 if crossingdebug > 0 :
4000 if crossingdebug = 1 :
4001 addto pic doublepath c shifted point t[i] of p
4002 withpen currentpen withtransparency(1,.5) ;
4003 elseif crossingdebug = 2 :
4004 addto pic also
4005 infotext (incr m,crossingscale5)
4006 shifted point t[i] of p ;
4007 fi
4008 fi
4009 a := subpath (t[i-1],t[i]) of p
4010 if i > 1 :
4011 cutbefore (c shifted point t[i-1] of p)
4012 fi
4013 if (i < n) or (cycle p) :
4014 cutafter (c shifted point t[i] of p)
4015 fi ;
4016 if (not picture q) or (a outsideof q) :
4017 addto pic doublepath a withpen currentpen ;
4018 fi
4019 endfor
4020 fi
4021 fi
4022 pic
4023 endgroup
4024enddef ;
4025
4026primarydef p insideof q =
4027 begingroup
4028 save pth, pic, t ;
4029 path pth ; picture pic ;
4030 pic := if path q : image(draw q;) else : q fi ;
4031 pth := p -- center pic ;
4032 (t, whatever) = pth intersectiontimes boundingbox pic ;
4033 t < 0
4034 endgroup
4035enddef ;
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058primarydef p outsideof q =
4059 not (p insideof q)
4060enddef ;
4061
4062permanent crossingdebug, crossingscale, crossingnumbermax, infotext, crossingunder, insideof, outsideof ;
4063
4064
4065
4066vardef circularpath primary n =
4067 reverse (for i=0 step 2n until 8-2n+2eps: point i of fullcircle .. endfor cycle) rotated 90
4068enddef ;
4069
4070vardef squarepath primary n =
4071 for i=0 step 1n until 4-1n 2eps: point i of fullsquare -- endfor cycle
4072enddef ;
4073
4074vardef linearpath primary n =
4075 origin for i=1n step 1n until 1-1n 2eps: -- point i of (origin--(1,0)) endfor
4076enddef ;
4077
4078permanent circularpath, squarepath, linearpath ;
4079
4080
4081
4082color pensilcolor ; pensilcolor := .5red ;
4083newinternal pensilstep ; pensilstep := 125 ;
4084
4085vardef pensilled(expr p, q) =
4086 image (
4087 draw p withcolor pensilcolor withpen q ;
4088 for i = 0 step pensilstep until length(p) eps:
4089 draw point i of p withcolor white withtransparency (1,.5) withpen q ;
4090 endfor ;
4091 )
4092enddef ;
4093
4094permanent pensilled, pensilcolor, pensilstep ;
4095
4096
4097
4098vardef tolist(suffix l)(text t) =
4099 save n ; n := 1 ;
4100 for p = t :
4101 if numeric p :
4102 n := p ;
4103 dispose(l[n])
4104 elseif pair p :
4105 l[n] := p ;
4106 n := n 1 ;
4107 elseif path p :
4108 for i=0 step 1 until length(p) :
4109 l[n] := point i of p ;
4110 n := n 1 ;
4111 endfor ;
4112 else :
4113
4114 fi ;
4115 endfor ;
4116 forever :
4117 exitif unknown l[n] ;
4118 dispose(l[n])
4119 n := n 1 ;
4120 endfor ;
4121enddef ;
4122
4123vardef topath(suffix p)(text t) =
4124 save i ; i := if known p[1] : 2 ; p[1] elseif known p[0] : 1 ; p[0] else : 0 ; origin fi
4125 forever :
4126 exitif unknown p[i] ;
4127 t p[i]
4128 hide(i := i 1)
4129 endfor
4130enddef ;
4131
4132vardef tocycle(suffix p)(text t) =
4133 topath(p,t) t cycle
4134enddef ;
4135
4136permanent tolist, topath, tocycle ;
4137
4138
4139
4140def drawdot expr p =
4141 if pair p :
4142 addto currentpicture doublepath p
4143 withpen currentpen base_draw_options
4144 elseif path p :
4145 draw image (
4146 for i=0 upto length p :
4147 addto currentpicture doublepath point i of p
4148 withpen currentpen base_draw_options ;
4149 endfor ;
4150 )
4151 elseif picture p :
4152 draw image (
4153 save pp ; path pp ;
4154 for i within p :
4155 if stroked i or filled i :
4156 pp := pathpart i ;
4157 for j=0 upto length pp :
4158 addto currentpicture doublepath point j of pp
4159 withpen currentpen base_draw_options ;
4160 endfor ;
4161 fi ;
4162 endfor ;
4163 )
4164 fi
4165enddef ;
4166
4167permanent drawdot ;
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177vardef mfun_timestamp =
4178 decimal year & "-" &
4179 decimal month & "-" &
4180 decimal day & " " &
4181 if ((time div 60) < 10) : "0" & fi
4182 decimal (time div 60) & ":" &
4183 if ((time(time div 60)60) < 10) : "0" & fi
4184 decimal (time(time div 60)60)
4185enddef ;
4186
4187vardef totransform(expr x, y, xx, xy, yx, yy) =
4188 save t ; transform t ;
4189 xxpart t = xx ; yypart t = yy ;
4190 xypart t = xy ; yxpart t = yx ;
4191 xpart t = x ; ypart t = y ;
4192 t
4193enddef ;
4194
4195vardef bymatrix(expr rx, sx, sy, ry, tx, ty) =
4196 save t ; transform t ;
4197 xxpart t = rx ; yypart t = ry ;
4198 xypart t = sx ; yxpart t = sy ;
4199 xpart t = tx ; ypart t = ty ;
4200 t
4201enddef ;
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211vardef closedcurve primary p =
4212 p if (path p and not cycle p) or (pair p) : .. cycle fi
4213enddef ;
4214
4215vardef closedlines primary p =
4216 p if (path p and not cycle p) or (pair p) : -- cycle fi
4217enddef ;
4218
4219permanent totransform, bymatrix, closedcurve, closedlines ;
4220
4221let xslanted = slanted ;
4222
4223def yslanted primary s =
4224 transformed
4225 begingroup
4226 save t ; transform t ;
4227 xxpart t = 1 ; yypart t = 1 ;
4228 xypart t = 0 ; yxpart t = s ;
4229 xpart t = 0 ; ypart t = 0 ;
4230 t
4231 endgroup
4232enddef ;
4233
4234permanent xslanted, yslanted ;
4235
4236vardef processpath (expr p) (text pp) =
4237 if path p :
4238 for i=0 upto length(p)-1 :
4239 pp(point i of p) .. controls
4240 pp(postcontrol i of p) and
4241 pp(precontrol (i+1) of p) ..
4242 endfor
4243 if cycle p :
4244 cycle
4245 else :
4246 pp(point length(p) of p)
4247 fi
4248 elseif pair p :
4249 pp(p)
4250 else :
4251 p
4252 fi
4253enddef ;
4254
4255permanent processpath ;
4256
4257
4258
4259
4260
4261newinternal hatch_match; hatch_match := 1;
4262
4263vardef hatched(expr o) primary c =
4264 save a_, b_, d_, l_, i_, r_, za_, zb_, zc_, zd_;
4265 path b_; picture r_; pair za_, zb_, zc_, zd_;
4266 r_ := image (
4267 a_ := redpart(c) mod 180 ;
4268 l_ := greenpart(c) ;
4269 d_ := bluepart(c) ;
4270 b_ := o rotated a_ ;
4271 b_ :=
4272 if a_ >= 90 :
4273 (lrcorner b_ -- llcorner b_ -- ulcorner b_ -- urcorner b_ -- cycle)
4274 else :
4275 (llcorner b_ -- lrcorner b_ -- urcorner b_ -- ulcorner b_ -- cycle)
4276 fi
4277 rotated a_ ;
4278 za_ := point 0 of b_ ;
4279 zb_ := point 1 of b_ ;
4280 zc_ := point 2 of b_ ;
4281 zd_ := point 3 of b_ ;
4282 if hatch_match > 0 :
4283 n_ := round(length(zd_za_) l_) ;
4284 if n_ < 2:
4285 n_ := 2 ;
4286 fi ;
4287 l_ := length(zd_za_) n_ ;
4288 else :
4289 n_ := length(zd_za_) l_ ;
4290 fi
4291 save currentpen; pen currentpen ; pickup pencircle scaled d_;
4292
4293 for i_ := if hatch_match > 0 : 1 else : 0 fi upto ceiling n_ 1 :
4294 nodraw (i_n_)[zd_,za_] -- (i_n_)[zc_,zb_] ;
4295 endfor
4296 dodraw origin ;
4297 ) ;
4298 clip r_ to o;
4299 r_
4300enddef;
4301
4302permanent hatched ;
4303
4304
4305
4306numeric mfun_dash_on, mfun_dash_off ;
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321primarydef p withdashes len =
4322 hide (
4323 save l, t, n, m, don, doff; pair t ;
4324 l := arclength p ;
4325 t := paired (len) ;
4326 m := xpart t ypart t ;
4327 n := (l if not cycle p : xpart t fi) div m ;
4328 (n if not cycle p : 1 fi) don n doff = l ;
4329 don(ypart t) = doff(xpart t) ;
4330 mfun_dash_on := don ;
4331 mfun_dash_off := doff ;
4332 )
4333 p dashed dashpattern (on mfun_dash_on off mfun_dash_off)
4334enddef ;
4335
4336permanent withdashes ;
4337
4338
4339
4340path mfun_b ;
4341pair mfun_k ;
4342
4343path mfun_nullpath ;
4344
4345tertiarydef p sortedintersectiontimes q =
4346 sortedpath (p intersectiontimeslist q)
4347enddef ;
4348
4349tertiarydef p intersectionpath q =
4350 begingroup ;
4351 save mfun_b ; path mfun_b ; mfun_b := sortedpath (p intersectiontimeslist q) ;
4352 save mfun_k ; pair mfun_k ; mfun_k := point 0 of mfun_b;
4353 if mfun_k <> (-1,-1) :
4354 .5[point xpart mfun_k of p, point ypart mfun_k of q]
4355 for i = 1 upto length(mfun_b) :
4356 hide(mfun_k := point i of mfun_b;)
4357 -- .5[point xpart mfun_k of p, point ypart mfun_k of q]
4358 endfor
4359 else :
4360 mfun_nullpath
4361 fi
4362 endgroup
4363enddef ;
4364
4365tertiarydef p firstintersectionpath q =
4366 begingroup ;
4367 save mfun_b ; path mfun_b ; mfun_b := sortedpath (p intersectiontimeslist q) ;
4368 if (point 0 of mfun_b) <> (-1,-1) :
4369 point xpart (point 0 of mfun_b) of p
4370 for i = 1 upto length(mfun_b) :
4371 -- point xpart (point i of mfun_b) of p
4372 endfor
4373 else :
4374 mfun_nullpath
4375 fi
4376 endgroup
4377enddef ;
4378
4379tertiarydef p secondintersectionpath q =
4380 q firstintersectionpath p
4381enddef;
4382
4383vardef intersectionsfound expr p =
4384 (point 0 of p) <> (-1,-1)
4385enddef ;
4386
4387
4388
4389tertiarydef p cutbeforefirst q =
4390 begingroup ;
4391 save mfun_b, mfun_p ; path mfun_b, mfun_p ; mfun_b := sortedpath (p intersectiontimeslist q) ;
4392 if (point 0 of mfun_b) <> (-1,-1) :
4393 mfun_p := subpath(xpart point 0 of mfun_b, length p) of p;
4394 else :
4395 mfun_p := p ;
4396 fi ;
4397 mfun_p
4398 endgroup
4399enddef ;
4400
4401tertiarydef p cutafterfirst q =
4402 begingroup ;
4403 save mfun_b, mfun_p ; path mfun_b, mfun_p ; mfun_b := sortedpath (p intersectiontimeslist q) ;
4404 if (point 0 of mfun_b) <> (-1,-1) :
4405 mfun_p := subpath(0, xpart point 0 of mfun_b) of p;
4406 else :
4407 mfun_p := p ;
4408 fi ;
4409 mfun_p
4410 endgroup
4411enddef ;
4412
4413
4414tertiarydef p cutbeforelast q =
4415 begingroup ;
4416 save mfun_b, mfun_p ; path mfun_b, mfun_p ; mfun_b := sortedpath (p intersectiontimeslist q) ;
4417 if (point 0 of mfun_b) <> (-1,-1) :
4418 mfun_p := subpath(xpart point (length mfun_b) of mfun_b, length p) of p;
4419 else :
4420 mfun_p := p ;
4421 fi ;
4422 mfun_p
4423 endgroup
4424enddef ;
4425
4426tertiarydef p cutafterlast q =
4427 begingroup ;
4428 save mfun_b, mfun_p ; path mfun_b, mfun_p ; mfun_b := sortedpath (p intersectiontimeslist q) ;
4429 if (point 0 of mfun_b) <> (-1,-1) :
4430 mfun_p := subpath(0, xpart point (length mfun_b) of mfun_b) of p;
4431 else :
4432 mfun_p := p ;
4433 fi ;
4434 mfun_p
4435 endgroup
4436enddef ;
4437
4438
4439
4440vardef starring(expr e) =
4441 save a, b, c, d ;
4442 pair a, b, c, d ;
4443 a := (-1,-1) ; b := ( 1,-1) ;
4444 c := ( 1, 1) ; d := (-1, 1) ;
4445 a -- (.5[a,b] shifted (0,e)) --
4446 b -- (.5[b,c] shifted (e, 0)) --
4447 c -- (.5[c,d] shifted (0, e)) --
4448 d -- (.5[d,a] shifted (e,0)) -- cycle
4449enddef ;
4450
4451vardef dashing (expr pth, shp, stp) =
4452 for i within arcpointlist stp of pth :
4453 shp
4454 rotated angle(pathdirection)
4455 shifted pathpoint
4456 &&
4457 endfor nocycle
4458enddef ;
4459
4460
4461
4462
4463
4464
4465 |