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