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 if xpart qq <> 0 : xscaled (xpart qq) fi
781 if ypart qq <> 0 : yscaled (ypart qq) fi
782 endgroup
783enddef ;
784
785
786
787def set_grid(expr w, h, nx, ny) =
788 boolean grid[][] ; boolean grid_full ;
789 numeric grid_w, grid_h, grid_nx, grid_ny, grid_x, grid_y, grid_left ;
790 grid_w := w ;
791 grid_h := h ;
792 grid_nx := nx ;
793 grid_ny := ny ;
794 grid_x := round(wgrid_nx) ;
795 grid_y := round(hgrid_ny) ;
796 grid_left := (1grid_x)(1grid_y) ;
797 grid_full := false ;
798 for i=0 upto grid_x :
799 for j=0 upto grid_y :
800 grid[i][j] := false ;
801 endfor ;
802 endfor ;
803enddef ;
804
805vardef new_on_grid(expr _dx_, _dy_) =
806 dx := _dx_ ;
807 dy := _dy_ ;
808 ddx := min(round(dxgrid_nx),grid_x) ;
809 ddy := min(round(dygrid_ny),grid_y) ;
810 if not grid_full and not grid[ddx][ddy] :
811 grid[ddx][ddy] := true ;
812 grid_left := grid_left-1 ;
813 grid_full := (grid_left=0) ;
814 true
815 else :
816 false
817 fi
818enddef ;
819
820
821
822
823
824
825
826
827
828
829secondarydef p peepholed q =
830 begingroup
831 save start ; pair start ;
832 start := point 0 of p ;
833 if xpart start >= xpart center p :
834 if ypart start >= ypart center p :
835 urcorner q -- ulcorner q -- llcorner q -- lrcorner q --
836 reverse p -- lrcorner q -- cycle
837 else :
838 lrcorner q -- urcorner q -- ulcorner q -- llcorner q --
839 reverse p -- llcorner q -- cycle
840 fi
841 else :
842 if ypart start > ypart center p :
843 ulcorner q -- llcorner q -- lrcorner q -- urcorner q --
844 reverse p -- urcorner q -- cycle
845 else :
846 llcorner q -- lrcorner q -- urcorner q -- ulcorner q --
847 reverse p -- ulcorner q -- cycle
848 fi
849 fi
850 endgroup
851enddef ;
852
853boolean intersection_found ;
854
855secondarydef p intersection_point q =
856 begingroup
857 save x_, y_ ;
858 (x_,y_) = p intersectiontimes q ;
859 if x_< 0 :
860 intersection_found := false ;
861 center p
862 else :
863 intersection_found := true ;
864 .5[point x_ of p, point y_ of q]
865 fi
866 endgroup
867enddef ;
868
869
870
871vardef tensecircle (expr width, height, offset) =
872 (width2,height2) ... (0,height2offset) ...
873 (width2,height2) ... (width2offset,0) ...
874 (width2,height2) ... (0,height2offset) ...
875 (width2,height2) ... (width2offset,0) ... cycle
876enddef ;
877
878vardef roundedsquare (expr width, height, offset) =
879 (offset,0) -- (widthoffset,0) {right} ..
880 (width,offset) -- (width,heightoffset) {up} ..
881 (widthoffset,height) -- (offset,height) {left} ..
882 (0,heightoffset) -- (0,offset) {down} .. cycle
883enddef ;
884
885vardef roundedsquarexy (expr width, height, dx, dy) =
886 (dx,0) -- (widthdx,0) {right} ..
887 (width,dy) -- (width,heightdy) {up} ..
888 (widthdx,height) -- (dx,height) {left} ..
889 (0,heightdy) -- (0,dy) {down} .. cycle
890enddef ;
891
892
893
894def resolvedcolor(expr s) =
895 .5white
896enddef ;
897
898let normalwithcolor = withcolor ;
899
900def withcolor expr c =
901 normalwithcolor if string c : resolvedcolor(c) else : c fi
902enddef ;
903
904
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
931vardef colortype expr c =
932 if cmykcolor c : cmykcolor
933 elseif rgbcolor c : rgbcolor
934 elseif numeric c : grayscale
935 fi
936enddef ;
937
938vardef whitecolor expr c =
939 if cmykcolor c : (0,0,0,0)
940 elseif rgbcolor c : (1,1,1)
941 elseif numeric c : 1
942 elseif string c : whitecolor resolvedcolor(c)
943 fi
944enddef ;
945
946vardef blackcolor expr c =
947 if cmykcolor c : (0,0,0,1)
948 elseif rgbcolor c : (0,0,0)
949 elseif numeric c : 0
950 elseif string c : blackcolor resolvedcolor(c)
951 fi
952enddef ;
953
954vardef complementary expr c =
955 if cmykcolor c : (1,1,1,1) c
956 elseif rgbcolor c : (1,1,1) c
957 elseif pair c : (1,1) c
958 elseif numeric c : 1 c
959 elseif string c : complementary resolvedcolor(c)
960 fi
961enddef ;
962
963vardef complemented expr c =
964 save m ;
965 if cmykcolor c : m := max(cyanpart c, magentapart c, yellowpart c, blackpart c) ;
966 (m,m,m,m) c
967 elseif rgbcolor c : m := max(redpart c, greenpart c, bluepart c) ;
968 (m,m,m) c
969 elseif pair c : m := max(xpart c, ypart c) ;
970 (m,m) c
971 elseif numeric c : m c
972 elseif string c : complemented resolvedcolor(c)
973 fi
974enddef ;
975
976
977
978def drawfill text t =
979 fill t ;
980 draw t ;
981enddef;
982
983
984
985
986def drawfill expr c =
987 path _c_ ; _c_ := c ;
988 mfun_do_drawfill
989enddef ;
990
991def mfun_do_drawfill text t =
992 draw _c_ t ;
993 fill _c_ t ;
994enddef;
995
996def undrawfill expr c =
997 drawfill c withcolor background
998enddef ;
999
1000
1001
1002vardef paired primary d =
1003 if pair d : d else : (d,d) fi
1004enddef ;
1005
1006vardef tripled primary d =
1007 if color d : d else : (d,d,d) fi
1008enddef ;
1009
1010
1011
1012primarydef p enlarged d = ( p llmoved d -- p lrmoved d -- p urmoved d -- p ulmoved d -- cycle ) enddef ;
1013primarydef p llenlarged d = ( p llmoved d -- lrcorner p -- urcorner p -- ulcorner p -- cycle ) enddef ;
1014primarydef p lrenlarged d = ( llcorner p -- p lrmoved d -- urcorner p -- ulcorner p -- cycle ) enddef ;
1015primarydef p urenlarged d = ( llcorner p -- lrcorner p -- p urmoved d -- ulcorner p -- cycle ) enddef ;
1016primarydef p ulenlarged d = ( llcorner p -- lrcorner p -- urcorner p -- p ulmoved d -- cycle ) enddef ;
1017
1018primarydef p llmoved d = ( (llcorner p) shifted (xpart paired(d),ypart paired(d)) ) enddef ;
1019primarydef p lrmoved d = ( (lrcorner p) shifted (xpart paired(d),ypart paired(d)) ) enddef ;
1020primarydef p urmoved d = ( (urcorner p) shifted (xpart paired(d),ypart paired(d)) ) enddef ;
1021primarydef p ulmoved d = ( (ulcorner p) shifted (xpart paired(d),ypart paired(d)) ) enddef ;
1022
1023primarydef p leftenlarged d = ( (llcorner p) shifted (d,0) -- lrcorner p -- urcorner p -- (ulcorner p) shifted (d,0) -- cycle ) enddef ;
1024primarydef p rightenlarged d = ( llcorner p -- (lrcorner p) shifted (d,0) -- (urcorner p) shifted (d,0) -- ulcorner p -- cycle ) enddef ;
1025primarydef p topenlarged d = ( llcorner p -- lrcorner p -- (urcorner p) shifted (0,d) -- (ulcorner p) shifted (0,d) -- cycle ) enddef ;
1026primarydef p bottomenlarged d = ( llcorner p shifted (0,d) -- lrcorner p shifted (0,d) -- urcorner p -- ulcorner p -- cycle ) enddef ;
1027
1028
1029
1030vardef rotation(expr i, n) =
1031 if (n == 0) : 0 else : i 360 n fi
1032enddef ;
1033
1034
1035
1036primarydef p crossed d = (
1037 if pair p :
1038 p shifted (d, 0) -- p --
1039 p shifted ( 0,d) -- p --
1040 p shifted (d, 0) -- p --
1041 p shifted ( 0,d) -- p -- cycle
1042 else :
1043 center p shifted (d, 0) -- llcorner p --
1044 center p shifted ( 0,d) -- lrcorner p --
1045 center p shifted (d, 0) -- urcorner p --
1046 center p shifted ( 0,d) -- ulcorner p -- cycle
1047 fi
1048) enddef ;
1049
1050
1051
1052vardef laddered primary p =
1053 point 0 of p
1054 for i=1 upto length(p) :
1055 -- (xpart (point i of p), ypart (point (i-1) of p)) -- (point i of p)
1056 endfor
1057enddef ;
1058
1059
1060
1061
1062
1063
1064
1065
1066vardef bottomboundary primary p = if pair p : p else : (llcorner p -- lrcorner p) fi enddef ;
1067vardef rightboundary primary p = if pair p : p else : (lrcorner p -- urcorner p) fi enddef ;
1068vardef topboundary primary p = if pair p : p else : (urcorner p -- ulcorner p) fi enddef ;
1069vardef leftboundary primary p = if pair p : p else : (ulcorner p -- llcorner p) fi enddef ;
1070
1071
1072
1073primarydef p superellipsed s =
1074 superellipse (
1075 .5[lrcorner p,urcorner p],
1076 .5[urcorner p,ulcorner p],
1077 .5[ulcorner p,llcorner p],
1078 .5[llcorner p,lrcorner p],
1079 s
1080 )
1081enddef ;
1082
1083primarydef p squeezed s = (
1084 (llcorner p .. .5[llcorner p,lrcorner p] shifted ( 0, ypart paired(s)) .. lrcorner p) &
1085 (lrcorner p .. .5[lrcorner p,urcorner p] shifted (xpart paired(s), 0) .. urcorner p) &
1086 (urcorner p .. .5[urcorner p,ulcorner p] shifted ( 0,ypart paired(s)) .. ulcorner p) &
1087 (ulcorner p .. .5[ulcorner p,llcorner p] shifted ( xpart paired(s), 0) .. llcorner p) & cycle
1088) enddef ;
1089
1090primarydef p randomshifted s =
1091 begingroup ;
1092 save ss ; pair ss ;
1093 ss := paired(s) ;
1094 p shifted (-.5xpart ss uniformdeviate xpart ss,-.5ypart ss uniformdeviate ypart ss)
1095 endgroup
1096enddef ;
1097
1098vardef mfun_randomized_path(expr p,s) =
1099 for i=0 upto length(p)-1 :
1100 (point i of p) .. controls
1101 ((postcontrol i of p) randomshifted s) and
1102 ((precontrol (i+1) of p) randomshifted s) ..
1103 endfor
1104 if cycle p :
1105 cycle
1106 else :
1107 (point length(p) of p)
1108 fi
1109enddef;
1110
1111vardef mfun_randomized_picture(expr p,s)(text rnd) =
1112 save currentpicture ;
1113 picture currentpicture ;
1114 currentpicture := nullpicture ;
1115 for i within p :
1116 addto currentpicture
1117 if stroked i :
1118 doublepath pathpart i rnd s
1119 dashed dashpart i
1120 withpen penpart i
1121 withcolor colorpart i
1122 withprescript prescriptpart i
1123 withpostscript postscriptpart i
1124 elseif filled i :
1125 contour pathpart i rnd s
1126 withpen penpart i
1127 withcolor colorpart i
1128 withprescript prescriptpart i
1129 withpostscript postscriptpart i
1130 else :
1131 also i
1132 fi
1133 ;
1134 endfor ;
1135 currentpicture
1136enddef ;
1137
1138primarydef p randomizedcontrols s = (
1139 if path p :
1140 mfun_randomized_path(p,s)
1141 elseif picture p :
1142 mfun_randomized_picture(p,s)(randomizedcontrols)
1143 else :
1144 p randomized s
1145 fi
1146) enddef ;
1147
1148primarydef p randomized s = (
1149 if path p :
1150 for i=0 upto length(p)-1 :
1151 ((point i of p) randomshifted s) .. controls
1152 ((postcontrol i of p) randomshifted s) and
1153 ((precontrol (i+1) of p) randomshifted s) ..
1154 endfor
1155 if cycle p :
1156 cycle
1157 else :
1158 ((point length(p) of p) randomshifted s)
1159 fi
1160 elseif pair p :
1161 p randomshifted s
1162 elseif cmykcolor p :
1163 if cmykcolor s :
1164 ((uniformdeviate cyanpart s) cyanpart p,
1165 (uniformdeviate magentapart s) magentapart p,
1166 (uniformdeviate yellowpart s) yellowpart p,
1167 (uniformdeviate blackpart s) blackpart p)
1168 elseif pair s :
1169 ((xpart s (uniformdeviate (ypart s xpart s))) p)
1170 else :
1171 ((uniformdeviate s) p)
1172 fi
1173 elseif rgbcolor p :
1174 if rgbcolor s :
1175 ((uniformdeviate redpart s) redpart p,
1176 (uniformdeviate greenpart s) greenpart p,
1177 (uniformdeviate bluepart s) bluepart p)
1178 elseif pair s :
1179 ((xpart s (uniformdeviate (ypart s xpart s))) p)
1180 else :
1181 ((uniformdeviate s) p)
1182 fi
1183 elseif color p :
1184 if color s :
1185 ((uniformdeviate greypart s) greypart p)
1186 elseif pair s :
1187 ((xpart s (uniformdeviate (ypart s xpart s))) p)
1188 else :
1189 ((uniformdeviate s) p)
1190 fi
1191 elseif string p :
1192 (resolvedcolor(p)) randomized s
1193 elseif picture p :
1194 mfun_randomized_picture(p,s)(randomized)
1195 else :
1196
1197 p uniformdeviate s
1198 fi
1199) enddef ;
1200
1201
1202
1203vardef interpolated(expr s, p, q) =
1204 save m ; numeric m ;
1205 m := max(length(p),length(q)) ;
1206 if path p :
1207 for i=0 upto m-1 :
1208 s[point (i m) along p,point (i m) along q] .. controls
1209 s[postcontrol (i m) along p,postcontrol (i m) along q] and
1210 s[precontrol ((i+1)m) along p,precontrol ((i+1)m) along q] ..
1211 endfor
1212 if cycle p :
1213 cycle
1214 else :
1215 s[point infinity of p,point infinity of q]
1216 fi
1217 else :
1218 a[p,q]
1219 fi
1220enddef ;
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235vardef perpendicular expr t of p =
1236 unitvector((direction t of p) rotated 90)
1237enddef ;
1238
1239def istextext(expr p) =
1240 (picture p and ((substring(0,3) of prescriptpart p) = "tx_"))
1241enddef ;
1242
1243primarydef p paralleled d = (
1244 if path p :
1245 begingroup ;
1246 save dp ; pair dp ;
1247 for i=0 upto length p if cycle p : -1 fi :
1248 hide(dp := d perpendicular i of p)
1249 if i > 0 : .. fi
1250 (point i of p dp)
1251 if i < length p :
1252 .. controls (postcontrol i of p dp) and
1253 (precontrol (i+1) of p dp)
1254 fi
1255 endfor
1256 if cycle p : .. cycle fi
1257 endgroup
1258 elseif picture p :
1259 image(
1260 for i within p :
1261 draw (pathpart i)
1262 if not istextext(i) :
1263 paralleled d
1264 fi
1265 mfun_decoration_i i ;
1266 endfor ;
1267 )
1268 elseif pair p :
1269 p
1270 fi
1271) enddef ;
1272
1273vardef punked primary p =
1274 point 0 of p for i=1 upto length(p)-1 : -- point i of p endfor
1275 if cycle p : -- cycle else : -- point length(p) of p fi
1276enddef ;
1277
1278vardef curved primary p =
1279 point 0 of p for i=1 upto length(p)-1 : .. point i of p endfor
1280 if cycle p : .. cycle else : .. point length(p) of p fi
1281enddef ;
1282
1283primarydef p blownup s =
1284 begingroup
1285 save _p_ ; path _p_ ;
1286 _p_ := p xysized (bbwidth(p)+2(xpart paired(s)),bbheight(p)+2(ypart paired(s))) ;
1287 (_p_ shifted (center p center _p_))
1288 endgroup
1289enddef ;
1290
1291
1292
1293
1294
1295vardef leftrightpath(expr p, l) =
1296 save q, r, t, b ; path q, r ; pair t, b ;
1297 t := (ulcorner p -- urcorner p) intersection_point p ;
1298 b := (llcorner p -- lrcorner p) intersection_point p ;
1299 r := if xpart directionpoint t of p < 0 : reverse p else : p fi ;
1300 q := r cutbefore if l: t else: b fi ;
1301 q := q if xpart point 0 of r > 0 : & r fi cutafter if l: b else: t fi ;
1302 q
1303enddef ;
1304
1305vardef leftpath expr p = leftrightpath(p,true ) enddef ;
1306vardef rightpath expr p = leftrightpath(p,false) enddef ;
1307
1308
1309
1310def saveoptions =
1311 save _op_ ; def _op_ = enddef ;
1312enddef ;
1313
1314
1315
1316let normaldraw = draw ;
1317let normalfill = fill ;
1318
1319
1320
1321def normalfill expr c = addto currentpicture contour c _op_ enddef ;
1322def normaldraw expr p = addto currentpicture if picture p: also p else: doublepath p withpen currentpen fi _op_ enddef ;
1323
1324def drawlineoptions (text t) = def _lin_opt_ = t enddef ; enddef ;
1325def drawpointoptions (text t) = def _pnt_opt_ = t enddef ; enddef ;
1326def drawcontroloptions(text t) = def _ctr_opt_ = t enddef ; enddef ;
1327def drawlabeloptions (text t) = def _lab_opt_ = t enddef ; enddef ;
1328def draworiginoptions (text t) = def _ori_opt_ = t enddef ; enddef ;
1329def drawboundoptions (text t) = def _bnd_opt_ = t enddef ; enddef ;
1330def drawpathoptions (text t) = def _pth_opt_ = t enddef ; enddef ;
1331
1332numeric drawoptionsfactor ; drawoptionsfactor := pt ;
1333
1334def resetdrawoptions =
1335 drawlineoptions (withpen pencircle scaled 1.0 drawoptionsfactor withcolor .5white) ;
1336 drawpointoptions (withpen pencircle scaled 4.0 drawoptionsfactor withcolor black) ;
1337 drawcontroloptions(withpen pencircle scaled 2.5 drawoptionsfactor withcolor black) ;
1338 drawlabeloptions () ;
1339 draworiginoptions (withpen pencircle scaled 1.0 drawoptionsfactor withcolor .5white) ;
1340 drawboundoptions (dashed evenly _ori_opt_) ;
1341 drawpathoptions (withpen pencircle scaled 5.0 drawoptionsfactor withcolor .8white) ;
1342enddef ;
1343
1344resetdrawoptions ;
1345
1346
1347
1348def drawpath expr p =
1349 normaldraw p _pth_opt_
1350enddef ;
1351
1352
1353
1354newinternal ahvariant ; ahvariant := 0 ;
1355newinternal ahdimple ; ahdimple := 15 ;
1356newinternal ahscale ; ahscale := 34 ;
1357
1358vardef arrowhead expr p =
1359 save q, e, r ;
1360 pair e ; e = point length p of p ;
1361 path q ; q = gobble(p shifted e cutafter makepath(pencircle scaled (2ahlength))) cuttings ;
1362 if ahvariant > 0:
1363 path r ; r = gobble(p shifted e cutafter makepath(pencircle scaled ((1ahdimple)2ahlength))) cuttings ;
1364 fi
1365 (q rotated (ahangle2) & reverse q rotated (ahangle2)
1366 if ahvariant = 1 :
1367 -- point 0 of r --
1368 elseif ahvariant = 2 :
1369 ... point 0 of r ...
1370 else :
1371 --
1372 fi
1373 cycle
1374 ) shifted e
1375enddef ;
1376
1377vardef drawarrowpath expr p =
1378 save autoarrows ; boolean autoarrows ; autoarrows := true ;
1379 drawarrow p _pth_opt_
1380enddef ;
1381
1382def midarrowhead expr p =
1383 arrowhead p cutafter (point length(p cutafter point .5 along p) ahlength on p)
1384enddef ;
1385
1386vardef arrowheadonpath (expr p, s) =
1387 save autoarrows ; boolean autoarrows ;
1388 autoarrows := true ;
1389 set_ahlength(scaled ahfactor) ;
1390 arrowhead p if s < 1 : cutafter (point (sarclength(p) (ahlength2)) on p) fi
1391enddef ;
1392
1393def resetarrows =
1394 hide (
1395 ahlength := 4 ;
1396 ahangle := 45 ;
1397 ahvariant := 0 ;
1398 ahdimple := 15 ;
1399 ahscale := 34 ;
1400)
1401enddef ;
1402
1403
1404
1405def drawpoint expr c =
1406 if string c :
1407 string _c_ ;
1408 _c_ := "(" & c & ")" ;
1409 dotlabel.urt(_c_, scantokens _c_) ;
1410 drawdot scantokens _c_
1411 else :
1412 dotlabel.urt("(" & decimal xpart c & "," & decimal ypart c & ")", c) ;
1413 drawdot c
1414 fi _pnt_opt_
1415enddef ;
1416
1417
1418
1419def drawpoints expr c = path _c_ ; _c_ := c ; mfun_draw_points enddef ;
1420def drawcontrolpoints expr c = path _c_ ; _c_ := c ; mfun_draw_controlpoints enddef ;
1421def drawcontrollines expr c = path _c_ ; _c_ := c ; mfun_draw_controllines enddef ;
1422def drawpointlabels expr c = path _c_ ; _c_ := c ; mfun_draw_pointlabels enddef ;
1423
1424def mfun_draw_points text t =
1425 for _i_=0 upto length(_c_) if cycle _c_ : -1 fi :
1426 normaldraw point _i_ of _c_ _pnt_opt_ t ;
1427 endfor ;
1428enddef;
1429
1430def mfun_draw_controlpoints text t =
1431 for _i_=0 upto length(_c_) :
1432 normaldraw precontrol _i_ of _c_ _ctr_opt_ t ;
1433 normaldraw postcontrol _i_ of _c_ _ctr_opt_ t ;
1434 endfor ;
1435enddef;
1436
1437def mfun_draw_controllines text t =
1438 for _i_=0 upto length(_c_) :
1439 normaldraw point _i_ of _c_ -- precontrol _i_ of _c_ _lin_opt_ t ;
1440 normaldraw point _i_ of _c_ -- postcontrol _i_ of _c_ _lin_opt_ t ;
1441 endfor ;
1442enddef;
1443
1444boolean swappointlabels ; swappointlabels := false ;
1445numeric pointlabelscale ; pointlabelscale := 0 ;
1446string pointlabelfont ; pointlabelfont := "" ;
1447
1448def mfun_draw_pointlabels text t =
1449 for _i_=0 upto length(_c_) if cycle _c_ : -1 fi :
1450 pair _u_ ; _u_ := unitvector(direction _i_ of _c_) rotated if swappointlabels : fi 90 ;
1451 pair _p_ ; _p_ := (point _i_ of _c_) ;
1452 begingroup ;
1453 if pointlabelscale > 0 :
1454 save defaultscale ; numeric defaultscale ;
1455 defaultscale := pointlabelscale ;
1456 fi ;
1457 if pointlabelfont <> "" :
1458 save defaultfont ; string defaultfont ;
1459 defaultfont := pointlabelfont ;
1460 fi ;
1461 _u_ := 10 drawoptionsfactor defaultscale _u_ ;
1462 normaldraw thelabel ( decimal _i_, _p_ shifted if cycle _c_ and (_i_=0) : fi _u_ ) _lab_opt_ t ;
1463 endgroup ;
1464 endfor ;
1465enddef;
1466
1467
1468
1469def drawboundingbox expr p =
1470 normaldraw boundingbox p _bnd_opt_
1471enddef ;
1472
1473
1474
1475numeric originlength ; originlength := .5cm ;
1476
1477def draworigin text t =
1478 normaldraw (origin shifted (0, originlength) -- origin shifted (0,originlength)) _ori_opt_ t ;
1479 normaldraw (origin shifted ( originlength,0) -- origin shifted (originlength,0)) _ori_opt_ t ;
1480enddef;
1481
1482
1483
1484numeric tickstep ; tickstep := 5mm ;
1485numeric ticklength ; ticklength := 2mm ;
1486
1487def drawxticks expr c = path _c_ ; _c_ := c ; mfun_draw_xticks enddef ;
1488def drawyticks expr c = path _c_ ; _c_ := c ; mfun_draw_yticks enddef ;
1489def drawticks expr c = path _c_ ; _c_ := c ; mfun_draw_ticks enddef ;
1490
1491
1492
1493def mfun_draw_xticks text t =
1494 for i=0 step tickstep until xpart llcorner _c_ eps :
1495 if (i<=xpart lrcorner _c_) :
1496 normaldraw (i,ticklength)--(i,ticklength) _ori_opt_ t ;
1497 fi ;
1498 endfor ;
1499 for i=0 step tickstep until xpart lrcorner _c_ eps :
1500 if (i>=xpart llcorner _c_) :
1501 normaldraw (i,ticklength)--(i,ticklength) _ori_opt_ t ;
1502 fi ;
1503 endfor ;
1504 normaldraw (llcorner _c_ -- ulcorner _c_) shifted (xpart llcorner _c_,0) _ori_opt_ t ;
1505enddef ;
1506
1507def mfun_draw_yticks text t =
1508 for i=0 step tickstep until ypart llcorner _c_ eps :
1509 if (i<=ypart ulcorner _c_) :
1510 normaldraw (ticklength,i)--(ticklength,i) _ori_opt_ t ;
1511 fi ;
1512 endfor ;
1513 for i=0 step tickstep until ypart ulcorner _c_ eps :
1514 if (i>=ypart llcorner _c_) :
1515 normaldraw (ticklength,i)--(ticklength,i) _ori_opt_ t ;
1516 fi ;
1517 endfor ;
1518 normaldraw (llcorner _c_ -- lrcorner _c_) shifted (0,ypart llcorner _c_) _ori_opt_ t ;
1519enddef ;
1520
1521def mfun_draw_ticks text t =
1522 drawxticks _c_ t ;
1523 drawyticks _c_ t ;
1524enddef ;
1525
1526
1527
1528def drawwholepath expr p =
1529 draworigin ;
1530 drawpath p ;
1531 drawcontrollines p ;
1532 drawcontrolpoints p ;
1533 drawpoints p ;
1534 drawboundingbox p ;
1535 drawpointlabels p ;
1536enddef ;
1537
1538def drawpathonly expr p =
1539 drawpath p ;
1540 drawcontrollines p ;
1541 drawcontrolpoints p ;
1542 drawpoints p ;
1543 drawpointlabels p ;
1544enddef ;
1545
1546
1547
1548def visualizeddraw expr c =
1549 if picture c : normaldraw c else : path _c_ ; _c_ := c ; do_visualizeddraw fi
1550enddef ;
1551
1552def visualizedfill expr c =
1553 if picture c : normalfill c else : path _c_ ; _c_ := c ; do_visualizedfill fi
1554enddef ;
1555
1556def do_visualizeddraw text t =
1557 draworigin ;
1558 drawpath _c_ t ;
1559 drawcontrollines _c_ ;
1560 drawcontrolpoints _c_ ;
1561 drawpoints _c_ ;
1562 drawboundingbox _c_ ;
1563 drawpointlabels _c_ ;
1564enddef ;
1565
1566def do_visualizedfill text t =
1567 if cycle _c_ : normalfill _c_ t fi ;
1568 draworigin ;
1569 drawcontrollines _c_ ;
1570 drawcontrolpoints _c_ ;
1571 drawpoints _c_ ;
1572 drawboundingbox _c_ ;
1573 drawpointlabels _c_ ;
1574enddef ;
1575
1576def detaileddraw expr c =
1577 if picture c : normaldraw c else : path _c_ ; _c_ := c ; do_detaileddraw fi
1578enddef ;
1579
1580def do_detaileddraw text t =
1581 drawpath _c_ t ;
1582 drawcontrollines _c_ ;
1583 drawcontrolpoints _c_ ;
1584 drawpoints _c_ ;
1585
1586
1587
1588enddef ;
1589
1590def visualizepaths =
1591 let fill = visualizedfill ;
1592 let draw = visualizeddraw ;
1593enddef ;
1594
1595def detailpaths =
1596 let draw = detaileddraw ;
1597enddef ;
1598
1599def naturalizepaths =
1600 let fill = normalfill ;
1601 let draw = normaldraw ;
1602enddef ;
1603
1604extra_endfig := extra_endfig & " naturalizepaths ; " ;
1605
1606
1607
1608def drawboundary primary p =
1609 draw p dashed evenly withcolor white ;
1610 draw p dashed oddly withcolor black ;
1611 draw ( llcorner p) withpen pencircle scaled 3 withcolor white ;
1612 draw ( llcorner p) withpen pencircle scaled 1.5 withcolor black ;
1613enddef ;
1614
1615
1616
1617extra_beginfig := extra_beginfig & " truecorners := 0 ; " ;
1618extra_beginfig := extra_beginfig & " miterlimit := 10 ; " ;
1619extra_beginfig := extra_beginfig & " linejoin := rounded ; " ;
1620extra_beginfig := extra_beginfig & " linecap := rounded ; " ;
1621
1622
1623
1624boolean autoarrows ; autoarrows := false ;
1625numeric ahfactor ; ahfactor := 2.5 ;
1626
1627def set_ahlength (text t) =
1628
1629
1630
1631 ahlength := (ahfactorpen_size(t)) ;
1632enddef ;
1633
1634vardef pen_size (text t) =
1635 save p ; picture p ; p := nullpicture ;
1636 addto p doublepath (top origin -- bot origin) t ;
1637 (ypart urcorner p ypart lrcorner p)
1638enddef ;
1639
1640
1641
1642
1643vardef arrowpath expr p =
1644 (p cutafter makepath(pencircle
1645 scaled (if ahvariant > 0 : (1ahdimple) fi 2ahlengthcosd(ahangle2))
1646 shifted point length p of p
1647 ))
1648enddef;
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666vardef stroked_paths(expr p) =
1667 save n ; numeric n ; n := 0 ;
1668 for i within p :
1669 if stroked i :
1670 n := n 1 ;
1671 fi
1672 endfor ;
1673 n
1674enddef ;
1675
1676def mfun_decoration_i expr i =
1677 withpen penpart i
1678 withcolor colorpart i
1679 withprescript prescriptpart i
1680 withpostscript postscriptpart i
1681enddef ;
1682
1683
1684
1685
1686numeric mfun_arrow_snippets ;
1687numeric mfun_arrow_count ;
1688
1689def drawarrow expr p =
1690 begingroup ;
1691 save mfun_arrow_path ;
1692 path mfun_arrow_path ;
1693 if path p :
1694 mfun_arrow_path := p ;
1695 expandafter mfun_draw_arrow_path
1696 elseif picture p :
1697 save mfun_arrow_picture ;
1698 picture mfun_arrow_picture ;
1699 mfun_arrow_picture := p ;
1700 expandafter mfun_draw_arrow_picture
1701 else :
1702 expandafter mfun_draw_arrow_nothing
1703 fi
1704enddef ;
1705
1706def drawdblarrow expr p =
1707 begingroup ;
1708 save mfun_arrow_path ;
1709 path mfun_arrow_path ;
1710 if path p :
1711 mfun_arrow_path := p ;
1712 expandafter mfun_draw_arrow_path_double
1713 elseif picture p :
1714 save mfun_arrow_picture ;
1715 picture mfun_arrow_picture ;
1716 mfun_arrow_picture := p ;
1717 expandafter mfun_draw_arrow_picture_double
1718 else :
1719 expandafter mfun_draw_arrow_nothing
1720 fi
1721enddef ;
1722
1723def mfun_draw_arrow_nothing text t =
1724enddef ;
1725
1726
1727
1728
1729def mfun_draw_arrow_path text t =
1730 if autoarrows :
1731 set_ahlength(t) ;
1732 fi
1733 draw arrowpath mfun_arrow_path t ;
1734 fillup arrowhead mfun_arrow_path t ;
1735 endgroup ;
1736enddef ;
1737
1738def mfun_draw_arrow_path_double text t =
1739 if autoarrows :
1740 set_ahlength(t) ;
1741 fi
1742 draw arrowpath (reverse arrowpath mfun_arrow_path) t ;
1743 fillup arrowhead mfun_arrow_path t ;
1744 fillup arrowhead reverse mfun_arrow_path t ;
1745 endgroup ;
1746enddef ;
1747
1748
1749
1750
1751
1752
1753def mfun_with_arrow_picture (text t) =
1754 mfun_arrow_count := 0 ;
1755 mfun_arrow_snippets := stroked_paths(mfun_arrow_picture) ;
1756 for i within mfun_arrow_picture :
1757 if istextext(i) :
1758 draw i
1759 else :
1760 mfun_arrow_count := mfun_arrow_count 1 ;
1761 mfun_arrow_path := pathpart i ;
1762 t
1763 fi ;
1764 endfor ;
1765enddef ;
1766
1767def mfun_draw_arrow_picture text t =
1768 if autoarrows :
1769 set_ahlength(t) ;
1770 fi
1771 mfun_with_arrow_picture (
1772 if mfun_arrow_count = mfun_arrow_snippets :
1773 draw arrowpath mfun_arrow_path mfun_decoration_i i t ;
1774 fillup arrowhead mfun_arrow_path mfun_decoration_i i t ;
1775 else :
1776 draw mfun_arrow_path mfun_decoration_i i t ;
1777 fi ;
1778 )
1779 endgroup ;
1780enddef ;
1781
1782def mfun_draw_arrow_picture_double text t =
1783 if autoarrows :
1784 set_ahlength(t) ;
1785 fi
1786 mfun_with_arrow_picture (
1787 draw
1788 if mfun_arrow_count = 1 :
1789 arrowpath reverse
1790 elseif mfun_arrow_count = mfun_arrow_snippets :
1791 arrowpath
1792 fi
1793 mfun_arrow_path mfun_decoration_i i t ;
1794 if mfun_arrow_count = 1 :
1795 fillup arrowhead reverse mfun_arrow_path mfun_decoration_i i t ;
1796 fi
1797 if mfun_arrow_count = mfun_arrow_snippets :
1798 fillup arrowhead mfun_arrow_path mfun_decoration_i i t ;
1799 fi
1800 )
1801 endgroup ;
1802enddef ;
1803
1804
1805
1806def drawdoublearrows expr p =
1807 begingroup ;
1808 save mfun_arrow_path ;
1809 path mfun_arrow_path ;
1810 save mfun_arrow_path_parallel ;
1811 path mfun_arrow_path_parallel ;
1812 if path p :
1813 mfun_arrow_path := p ;
1814 expandafter mfun_draw_arrow_paths
1815 elseif picture p :
1816 save mfun_arrow_picture ;
1817 picture mfun_arrow_picture ;
1818 mfun_arrow_picture := p ;
1819 expandafter mfun_draw_arrow_pictures
1820 else :
1821 expandafter mfun_draw_arrow_nothing
1822 fi
1823enddef ;
1824
1825def mfun_draw_arrow_paths text t =
1826 if autoarrows :
1827 set_ahlength(t) ;
1828 fi
1829 save d ; d := ahscaleahlengthsind(ahangle2) ;
1830 mfun_arrow_path_parallel := mfun_arrow_path paralleled d ;
1831 draw arrowpath mfun_arrow_path_parallel t ;
1832 fillup arrowhead mfun_arrow_path_parallel t ;
1833 mfun_arrow_path_parallel := (reverse mfun_arrow_path) paralleled d ;
1834 draw arrowpath mfun_arrow_path_parallel t ;
1835 fillup arrowhead mfun_arrow_path_parallel t ;
1836 endgroup ;
1837enddef ;
1838
1839def mfun_draw_arrow_pictures text t =
1840 if autoarrows :
1841 set_ahlength(t) ;
1842 fi
1843 save d ; d := ahscaleahlengthsind(ahangle2) ;
1844 mfun_with_arrow_picture(
1845 if mfun_arrow_count = 1 :
1846 draw (mfun_arrow_path paralleled d) mfun_decoration_i i t ;
1847 mfun_arrow_path_parallel := (reverse mfun_arrow_path) paralleled d ;
1848 draw arrowpath mfun_arrow_path_parallel mfun_decoration_i i t ;
1849 fillup arrowhead mfun_arrow_path_parallel mfun_decoration_i i t ;
1850 elseif mfun_arrow_count = mfun_arrow_snippets :
1851 draw ((reverse mfun_arrow_path) paralleled d) mfun_decoration_i i t ;
1852 mfun_arrow_path_parallel := mfun_arrow_path paralleled d ;
1853 draw arrowpath mfun_arrow_path_parallel mfun_decoration_i i t ;
1854 fillup arrowhead mfun_arrow_path_parallel mfun_decoration_i i t ;
1855 else :
1856 draw ( mfun_arrow_path paralleled d) mfun_decoration_i i t ;
1857 draw ((reverse mfun_arrow_path) paralleled d) mfun_decoration_i i t ;
1858 fi
1859 )
1860 endgroup ;
1861enddef ;
1862
1863
1864
1865vardef pointarrow (expr pat, loc, len, off) =
1866 save l, r, s, t ; path l, r ; numeric s ; pair t ;
1867 t := if pair loc : loc else : point loc along pat fi ;
1868 s := len2 off ; if s<=0 : s := 0 elseif s>len : s := len fi ;
1869 r := pat cutbefore t ;
1870 r := (r cutafter point (arctime s of r) of r) ;
1871 s := len2 off ; if s<=0 : s := 0 elseif s>len : s := len fi ;
1872 l := reverse (pat cutafter t) ;
1873 l := (reverse (l cutafter point (arctime s of l) of l)) ;
1874 (l..r)
1875enddef ;
1876
1877def rightarrow (expr pat,tim,len) = pointarrow(pat,tim,len,len) enddef ;
1878def leftarrow (expr pat,tim,len) = pointarrow(pat,tim,len,len) enddef ;
1879def centerarrow (expr pat,tim,len) = pointarrow(pat,tim,len, 0) enddef ;
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890primarydef pct along pat =
1891 (arctime (pct (arclength pat)) of pat) of pat
1892enddef ;
1893
1894primarydef len on pat =
1895 (arctime if len>=0 : len else : (arclength(pat)len) fi of pat) of pat
1896enddef ;
1897
1898
1899
1900tertiarydef pat cutends len =
1901 begingroup
1902 save tap ; path tap ;
1903 tap := pat cutbefore (point (xpart paired(len)) on pat) ;
1904 (tap cutafter (point (ypart paired(len)) on tap))
1905 endgroup
1906enddef ;
1907
1908
1909
1910path freesquare ; freesquare := (
1911 (-1,0) -- (-1,-1) -- (0,-1) -- (+1,-1) --
1912 (+1,0) -- (+1,+1) -- (0,+1) -- (-1,+1) -- cycle
1913) scaled .5 ;
1914
1915numeric freelabeloffset ; freelabeloffset := 3pt ;
1916numeric freedotlabelsize ; freedotlabelsize := 3pt ;
1917
1918vardef thefreelabel (expr str, loc, ori) =
1919 save s, p, q, l ; picture s ; path p, q ; pair l ;
1920 interim labeloffset := freelabeloffset ;
1921 s := if string str : thelabel(str,loc) else : str shifted center str shifted loc fi ;
1922 setbounds s to boundingbox s enlarged freelabeloffset ;
1923 p := fullcircle scaled (2length(locori)) shifted ori ;
1924 q := freesquare xyscaled (urcorner s llcorner s) ;
1925 l := point xpart (p intersectiontimes (oriloc shifted (locori))) of q ;
1926 setbounds s to boundingbox s enlarged freelabeloffset ;
1927
1928 (s shifted l)
1929enddef ;
1930
1931vardef freelabel (expr str, loc, ori) =
1932 draw thefreelabel(str,loc,ori) ;
1933enddef ;
1934
1935vardef freedotlabel (expr str, loc, ori) =
1936 interim linecap := rounded ;
1937 draw loc withpen pencircle scaled freedotlabelsize ;
1938 draw thefreelabel(str,loc,ori) ;
1939enddef ;
1940
1941
1942
1943
1944
1945newinternal angleoffset ; angleoffset := 0pt ;
1946newinternal anglelength ; anglelength := 20pt ;
1947newinternal anglemethod ; anglemethod := 1 ;
1948
1949vardef anglebetween (expr a, b, str) =
1950 save pointa, pointb, common, middle, offset ;
1951 pair pointa, pointb, common, middle, offset ;
1952 save curve ; path curve ;
1953 save where ; numeric where ;
1954 if round point 0 of a = round point 0 of b :
1955 common := point 0 of a ;
1956 else :
1957 common := a intersectionpoint b ;
1958 fi ;
1959 pointa := point anglelength on a ;
1960 pointb := point anglelength on b ;
1961 where := turningnumber (commonpointapointbcycle) ;
1962 middle := (reverse(commonpointa) rotatedaround (pointa,where90))
1963 intersection_point
1964 (reverse(commonpointb) rotatedaround (pointb, where90)) ;
1965 if not intersection_found :
1966 middle := point .5 along
1967 ((reverse(commonpointa) rotatedaround (pointa,where90)) --
1968 ( (commonpointb) rotatedaround (pointb, where90))) ;
1969 fi ;
1970 if anglemethod = 0 :
1971 curve := pointa{unitvector(middlepointa)}.. pointb;
1972 middle := point .5 along curve ;
1973 curve := common ;
1974 elseif anglemethod = 1 :
1975 curve := pointa{unitvector(middlepointa)}.. pointb;
1976 middle := point .5 along curve ;
1977 elseif anglemethod = 2 :
1978 middle := common rotatedaround(.5[pointa,pointb],180) ;
1979 curve := pointamiddlepointb ;
1980 elseif anglemethod = 3 :
1981 curve := pointamiddlepointb ;
1982 elseif anglemethod = 4 :
1983 curve := pointa..controls middle..pointb ;
1984 middle := point .5 along curve ;
1985 fi ;
1986 draw thefreelabel(str, middle, common) ;
1987 curve
1988enddef ;
1989
1990
1991
1992picture mfun_current_picture_stack[] ;
1993numeric mfun_current_picture_depth ;
1994
1995mfun_current_picture_depth := 0 ;
1996
1997def pushcurrentpicture =
1998 mfun_current_picture_depth := mfun_current_picture_depth 1 ;
1999 mfun_current_picture_stack[mfun_current_picture_depth] := currentpicture ;
2000 currentpicture := nullpicture ;
2001enddef ;
2002
2003def popcurrentpicture text t =
2004 if mfun_current_picture_depth > 0 :
2005 addto mfun_current_picture_stack[mfun_current_picture_depth] also currentpicture t ;
2006 currentpicture := mfun_current_picture_stack[mfun_current_picture_depth] ;
2007 mfun_current_picture_stack[mfun_current_picture_depth] := nullpicture ;
2008 mfun_current_picture_depth := mfun_current_picture_depth 1 ;
2009 fi ;
2010enddef ;
2011
2012
2013
2014vardef colorcircle (expr size, red, green, blue) =
2015 save r, g, b, c, m, y, w ; save radius ;
2016 path r, g, b, c, m, y, w ; numeric radius ;
2017
2018 radius := 5cm ; pickup pencircle scaled (radius25) ;
2019
2020 transform t ; t := identity rotatedaround(origin,120) ;
2021
2022 r := fullcircle rotated 90 scaled radius shifted (0,radius4) rotatedaround(origin,135) ;
2023
2024 b := r transformed t ; g := b transformed t ;
2025
2026 c := buildcycle(subpath(1,7) of g,subpath(1,7) of b) ;
2027 y := c transformed t ; m := y transformed t ;
2028
2029 w := buildcycle(subpath(3,5) of r, subpath(3,5) of g,subpath(3,5) of b) ;
2030
2031 pushcurrentpicture ;
2032
2033 fill r withcolor red ;
2034 fill g withcolor green ;
2035 fill b withcolor blue ;
2036 fill c withcolor white red ;
2037 fill m withcolor white green ;
2038 fill y withcolor white blue ;
2039 fill w withcolor white ;
2040
2041 for i = r,g,b,c,m,y : draw i withcolor .5white ; endfor ;
2042
2043 currentpicture := currentpicture xsized size ;
2044
2045 popcurrentpicture ;
2046enddef ;
2047
2048
2049
2050vardef penpoint expr pnt of p =
2051 save n, d ; numeric n, d ;
2052 (n,d) = if pair pnt : pnt else : (pnt,1) fi ;
2053 (point n of p shifted ((penoffset direction n of p of currentpen) scaled d))
2054enddef ;
2055
2056
2057
2058primarydef p uncolored c =
2059 if color p :
2060 c p
2061 else :
2062 image (
2063 for i within p :
2064 addto currentpicture
2065 if stroked i or filled i :
2066 if filled i :
2067 contour
2068 else :
2069 doublepath
2070 fi
2071 pathpart i
2072 dashed dashpart i withpen penpart i
2073 else :
2074 also i
2075 fi
2076 withcolor c(redpart i, greenpart i, bluepart i) ;
2077 endfor ;
2078 )
2079 fi
2080enddef ;
2081
2082vardef inverted primary p =
2083 p uncolored white
2084enddef ;
2085
2086primarydef p softened c =
2087 begingroup
2088 save cc ; color cc ; cc := tripled(c) ;
2089 if color p :
2090 (redpart cc redpart p,greenpart cc greenpart p, bluepart cc bluepart p)
2091 else :
2092 image (
2093 for i within p :
2094 addto currentpicture
2095 if stroked i or filled i :
2096 if filled i :
2097 contour
2098 else :
2099 doublepath
2100 fi
2101 pathpart i
2102 dashed dashpart i withpen penpart i
2103 else :
2104 also i
2105 fi
2106 withcolor (redpart cc redpart i, greenpart cc greenpart i, bluepart cc bluepart i) ;
2107 endfor ;
2108 )
2109 fi
2110 endgroup
2111enddef ;
2112
2113vardef grayed primary p =
2114 if rgbcolor p :
2115 tripled(.30redpart p+.59greenpart p+.11bluepart p)
2116 elseif cmykcolor p :
2117 tripled(.30(1cyanpart i)+.59(1magentapart i)+.11(1yellowpart i)blackpart i)
2118 elseif greycolor p :
2119 p
2120 elseif string p :
2121 grayed resolvedcolor(p)
2122 elseif picture p :
2123 image (
2124 for i within p :
2125 addto currentpicture
2126 if stroked i or filled i :
2127 if filled i :
2128 contour
2129 else :
2130 doublepath
2131 fi
2132 pathpart i
2133 dashed dashpart i
2134 withpen penpart i
2135 else :
2136 also i
2137 fi
2138 if unknown colorpart i :
2139
2140 elseif rgbcolor colorpart i :
2141 withcolor tripled(.30redpart i+.59greenpart i+.11bluepart i) ;
2142 elseif cmykcolor colorpart i :
2143 withcolor tripled(.30(1cyanpart i)+.59(1magentapart i)+.11(1yellowpart i)blackpart i) ;
2144 else :
2145 withcolor colorpart i ;
2146 fi
2147 endfor ;
2148 )
2149 else :
2150 p
2151 fi
2152enddef ;
2153
2154let greyed = grayed ;
2155
2156vardef hsvtorgb(expr h,s,v) =
2157 save H, S, V, x ;
2158 H = h mod 360 ;
2159 S = if s < 0 : 0 elseif s > 1 : 1 else: s fi ;
2160 V = if v < 0 : 0 elseif v > 1 : 1 else: v fi ;
2161 x = 1 abs(H mod 120 60)60 ;
2162 V ( (1S) (1,1,1) S
2163 if H < 60 : (1,x,0)
2164 elseif H < 120 : (x,1,0)
2165 elseif H < 180 : (0,1,x)
2166 elseif H < 240 : (0,x,1)
2167 elseif H < 300 : (x,0,1)
2168 else : (1,0,x)
2169 fi )
2170enddef ;
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191def condition primary b = if b : "true" else : "false" fi enddef ;
2192
2193
2194
2195primarydef p stretched s =
2196 begingroup
2197 save pp ; path pp ; pp := p xyscaled s ;
2198 (pp shifted ((point 0 of p) (point 0 of pp)))
2199 endgroup
2200enddef ;
2201
2202primarydef p enlonged len =
2203 begingroup
2204 if len == 0 :
2205 p
2206 elseif pair p :
2207 save q ; path q ; q := origin -- p ;
2208 save al ; al := arclength(q) ;
2209 if al > 0 :
2210 point 1 of (q stretched ((allen)al))
2211 else :
2212 p
2213 fi
2214 else :
2215 save al ; al := arclength(p) ;
2216 if al > 0 :
2217 p stretched ((allen)al)
2218 else :
2219 p
2220 fi
2221 fi
2222 endgroup
2223enddef ;
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233primarydef p shortened d =
2234 reverse ( ( reverse (p enlonged xpart paired(d)) ) enlonged ypart paired(d) )
2235enddef ;
2236
2237
2238
2239def xshifted expr dx = shifted(dx,0) enddef ;
2240def yshifted expr dy = shifted(0,dy) enddef ;
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261def readfile (expr name) =
2262 begingroup ; save ok ; boolean ok ;
2263 if (readfrom (name) <> EOF) :
2264 ok := false ;
2265 elseif (readfrom (name) <> EOF) :
2266 ok := false ;
2267 else :
2268 ok := true ;
2269 fi ;
2270 if not ok :
2271 scantokens("input " & name & " ") ;
2272 fi ;
2273 closefrom (name) ;
2274 endgroup ;
2275enddef ;
2276
2277
2278
2279inner end ;
2280
2281
2282
2283let mfun_remap_colors_normalwithcolor = normalwithcolor ;
2284
2285def remapcolors =
2286 def normalwithcolor primary c =
2287 mfun_remap_colors_normalwithcolor remappedcolor(c)
2288 enddef ;
2289enddef ;
2290
2291def normalcolors =
2292 let normalwithcolor = mfun_remap_colors_normalwithcolor ;
2293enddef ;
2294
2295def resetcolormap =
2296 color color_map[][][] ;
2297 normalcolors ;
2298enddef ;
2299
2300resetcolormap ;
2301
2302def r_color primary c = redpart c enddef ;
2303def g_color primary c = greenpart c enddef ;
2304def b_color primary c = bluepart c enddef ;
2305
2306def remapcolor(expr old, new) =
2307 color_map[redpart old][greenpart old][bluepart old] := new ;
2308enddef ;
2309
2310def remappedcolor(expr c) =
2311 if known color_map[redpart c][greenpart c][bluepart c] :
2312 color_map[redpart c][greenpart c][bluepart c]
2313 else :
2314 c
2315 fi
2316enddef ;
2317
2318
2319
2320
2321def recolor suffix p = p := repathed (0,p) enddef ;
2322def refill suffix p = p := repathed (1,p) enddef ;
2323def redraw suffix p = p := repathed (2,p) enddef ;
2324def retext suffix p = p := repathed (3,p) enddef ;
2325def untext suffix p = p := repathed (4,p) enddef ;
2326
2327
2328
2329
2330
2331
2332
2333color refillbackground ; refillbackground := (1,1,1) ;
2334
2335def restroke suffix p = p := repathed (21,p) enddef ;
2336def reprocess suffix p = p := repathed (22,p) enddef ;
2337
2338
2339
2340vardef repathed (expr mode, p) text t =
2341 begingroup ;
2342 if mode = 0 :
2343 save normalwithcolor ;
2344 remapcolors ;
2345 fi ;
2346 save _p_, _pp_, _ppp_, _f_, _b_, _t_ ;
2347 picture _p_, _pp_, _ppp_ ; color _f_ ; path _b_ ; transform _t_ ;
2348 _b_ := boundingbox p ;
2349 _p_ := nullpicture ;
2350 for i within p :
2351 _f_ := (redpart i, greenpart i, bluepart i) ;
2352 if bounded i :
2353 _pp_ := repathed(mode,i) t ;
2354 setbounds _pp_ to pathpart i ;
2355 addto _p_ also _pp_ ;
2356 elseif clipped i :
2357 _pp_ := repathed(mode,i) t ;
2358 clip _pp_ to pathpart i ;
2359 addto _p_ also _pp_ ;
2360 elseif stroked i :
2361 if mode=21 :
2362 _ppp_ := i ;
2363 addto _p_ also image(scantokens(t & " pathpart _ppp_")
2364 dashed dashpart i withpen penpart i
2365 withcolor _f_ ; ) ;
2366 elseif mode=22 :
2367 _ppp_ := i ;
2368 addto _p_ also image(scantokens(t & " pathpart _ppp_")) ;
2369 else :
2370 addto _p_ doublepath pathpart i
2371 dashed dashpart i withpen penpart i
2372 withcolor _f_
2373 if mode = 2 :
2374 t
2375 fi ;
2376 fi ;
2377 elseif filled i :
2378 if mode=11 :
2379 _ppp_ := i ;
2380 addto _p_ also image(scantokens(t & " pathpart _ppp_")
2381 withcolor _f_ ; ) ;
2382 elseif mode=12 :
2383 _ppp_ := i ;
2384 addto _p_ also image(scantokens(t & " pathpart _ppp_")) ;
2385 else :
2386 addto _p_ contour pathpart i
2387 withcolor _f_
2388 if (mode=1) and (_f_<>refillbackground) :
2389 t
2390 fi ;
2391 fi ;
2392 elseif textual i :
2393 if mode <> 4 :
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403 addto _p_ also i
2404 if mode=3 :
2405 t
2406 fi ;
2407 fi ;
2408 else :
2409 addto _p_ also i ;
2410 fi ;
2411 endfor ;
2412 setbounds _p_ to _b_ ;
2413 _p_
2414 endgroup
2415enddef ;
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441def clearxy text s =
2442 if false for $ := s : or true endfor :
2443 forsuffixes $ := s : x$ := whatever ; y$ := whatever ; endfor ;
2444 else :
2445 save x, y ;
2446 fi
2447enddef ;
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457primarydef p smoothed d =
2458 (p llmoved (xpart paired(d),0) -- p lrmoved (xpart paired(d),0) {right} ..
2459 p lrmoved (0,ypart paired(d)) -- p urmoved (0,ypart paired(d)) {up} ..
2460 p urmoved (xpart paired(d),0) -- p ulmoved (xpart paired(d),0) {left} ..
2461 p ulmoved (0,ypart paired(d)) -- p llmoved (0,ypart paired(d)) {down} .. cycle)
2462enddef ;
2463
2464primarydef p cornered c =
2465 ((point 0 of p) shifted (c(unitvector(point 1 of p point 0 of p))) --
2466 for i=1 upto length(p) :
2467 (point i-1 of p) shifted (c(unitvector(point i of p point i-1 of p))) --
2468 (point i of p) shifted (c(unitvector(point i-1 of p point i of p))) ..
2469 controls point i of p ..
2470 endfor cycle)
2471enddef ;
2472
2473
2474
2475
2476primarydef p smoothcornered c =
2477 ( begingroup ;
2478 save cc ;
2479 if not cycle p: (point 0 of p) -- fi
2480 for i=1 upto length(p) :
2481 hide (cc := min(c,arclength (subpath(i-1,i) of p)2);)
2482 (point i-1 of p) shifted (cc(unitvector(point i of p point i-1 of p))) --
2483 (point i of p) shifted (cc(unitvector(point i-1 of p point i of p))) ..
2484 controls point i of p ..
2485 endfor
2486 if cycle p : cycle else : point 1 along p fi
2487 endgroup )
2488enddef ;
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510vardef bbwidth primary p =
2511 if unknown p :
2512 0
2513 elseif path p or picture p :
2514 xpart (lrcorner p llcorner p)
2515 else :
2516 0
2517 fi
2518enddef ;
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532vardef bbheight primary p =
2533 if unknown p :
2534 0
2535 elseif path p or picture p :
2536 ypart (urcorner p lrcorner p)
2537 else :
2538 0
2539 fi
2540enddef ;
2541
2542color nocolor ; numeric noline ;
2543
2544def dowithpath (expr p, lw, lc, bc) =
2545 if known p :
2546 if known bc :
2547 fill p withcolor bc ;
2548 fi ;
2549 if known lw and known lc :
2550 draw p withpen pencircle scaled lw withcolor lc ;
2551 elseif known lw :
2552 draw p withpen pencircle scaled lw ;
2553 elseif known lc :
2554 draw p withcolor lc ;
2555 fi ;
2556 fi ;
2557enddef ;
2558
2559
2560
2561def [[ = [ [ enddef ; def [[[ = [ [ [ enddef ;
2562def ]] = ] ] enddef ; def ]]] = ] ] ] enddef ;
2563
2564let == = = ;
2565
2566
2567
2568picture oddly ;
2569
2570evenly := dashpattern(on 3 off 3) ;
2571oddly := dashpattern(off 3 on 3) ;
2572
2573
2574
2575vardef mfun_straightened(expr sign, p) =
2576 save _p_, _q_ ; path _p_, _q_ ;
2577 _p_ := p ;
2578 forever :
2579 _q_ := mfun_do_straightened(sign, _p_) ;
2580 exitif length(_p_) = length(_q_) ;
2581 _p_ := _q_ ;
2582 endfor ;
2583 _q_
2584enddef ;
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600vardef mfun_do_straightened(expr sign, p) =
2601 if length(p) > 2 :
2602 save pp ; path pp ;
2603 pp := point 0 of p ;
2604 for i=1 upto length(p)-1 :
2605 if round(point i of p) <> round(point length(pp) of pp) :
2606 pp := pp -- point i of p ;
2607 fi ;
2608 endfor ;
2609 save n, ok ; numeric n ; boolean ok ;
2610 n := length(pp) ; ok := false ;
2611 if n > 2 :
2612 for i=0 upto n :
2613 if unitvector(round(point i of pp point if i=0 : n else : i-1 fi of pp)) <>
2614 sign unitvector(round(point if i=n : 0 else : i+1 fi of pp point i of pp)) :
2615 if ok :
2616 --
2617 else :
2618 ok := true ;
2619 fi point i of pp
2620 fi
2621 endfor
2622 if ok and (cycle p) :
2623 -- cycle
2624 fi
2625 else :
2626 pp
2627 fi
2628 else :
2629 p
2630 fi
2631enddef ;
2632
2633vardef simplified expr p = (
2634 reverse mfun_straightened(+1,mfun_straightened(+1,reverse p))
2635) enddef ;
2636
2637vardef unspiked expr p = (
2638 reverse mfun_straightened(-1,mfun_straightened(-1,reverse p))
2639) enddef ;
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657path originpath ; originpath := origin -- cycle ;
2658
2659vardef unitvector primary z =
2660 if abs z = abs origin : z else : zabs z fi
2661enddef;
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671vardef epsed (expr e) =
2672 e if e>0 : eps elseif e<0 : eps fi
2673enddef ;
2674
2675
2676
2677def withgray primary g =
2678 withcolor g
2679enddef ;
2680
2681
2682
2683if unknown darkred : color darkred ; darkred := .625(1,0,0) fi ;
2684if unknown darkgreen : color darkgreen ; darkgreen := .625(0,1,0) fi ;
2685if unknown darkblue : color darkblue ; darkblue := .625(0,0,1) fi ;
2686if unknown darkcyan : color darkcyan ; darkcyan := .625(0,1,1) fi ;
2687if unknown darkmagenta : color darkmagenta ; darkmagenta := .625(1,0,1) fi ;
2688if unknown darkyellow : color darkyellow ; darkyellow := .625(1,1,0) fi ;
2689if unknown darkgray : color darkgray ; darkgray := .625(1,1,1) fi ;
2690if unknown lightgray : color lightgray ; lightgray := .850(1,1,1) fi ;
2691
2692
2693
2694vardef center primary p =
2695 if pair p :
2696 p
2697 else :
2698 .5[llcorner p, urcorner p]
2699 fi
2700enddef;
2701
2702
2703
2704vardef rangepath (expr p, d, a) =
2705 if length p>0 :
2706 (dunitvector(direction 0 of p) rotated a) shifted point 0 of p
2707 -- p --
2708 (dunitvector(direction length(p) of p) rotated a) shifted point length(p) of p
2709 else :
2710 p
2711 fi
2712enddef ;
2713
2714
2715
2716vardef straightpath (expr a, b, method) =
2717 if (method<1) or (method>6) :
2718 (ab)
2719 elseif method = 1 :
2720 (a --
2721 if xpart a > xpart b :
2722 if ypart a > ypart b :
2723 (xpart b,ypart a) --
2724 elseif ypart a < ypart b :
2725 (xpart a,ypart b) --
2726 fi
2727 elseif xpart a < xpart b :
2728 if ypart a > ypart b :
2729 (xpart a,ypart b) --
2730 elseif ypart a < ypart b :
2731 (xpart b,ypart a) --
2732 fi
2733 fi
2734 b)
2735 elseif method = 3 :
2736 (a --
2737 if xpart a > xpart b :
2738 (xpart b,ypart a) --
2739 elseif xpart a < xpart b :
2740 (xpart a,ypart b) --
2741 fi
2742 b)
2743 elseif method = 5 :
2744 (a --
2745 if ypart a > ypart b :
2746 (xpart b,ypart a) --
2747 elseif ypart a < ypart b :
2748 (xpart a,ypart b) --
2749 fi
2750 b)
2751 else :
2752 (reverse straightpath(b,a,method-1))
2753 fi
2754enddef ;
2755
2756
2757
2758def addbackground text t =
2759 begingroup ;
2760 save p, b ; picture p ; path b ;
2761 b := boundingbox currentpicture ;
2762 p := currentpicture ; currentpicture := nullpicture ;
2763 fill b t ;
2764 setbounds currentpicture to b ;
2765 addto currentpicture also p ;
2766 endgroup ;
2767enddef ;
2768
2769
2770
2771
2772vardef infinite expr p =
2773 (infinityunitvector(direction 0 of p)
2774 shifted point 0 of p
2775 -- p --
2776 infinityunitvector(direction length(p) of p)
2777 shifted point length(p) of p)
2778enddef ;
2779
2780
2781
2782
2783string mfun_clean_ascii[] ;
2784
2785def register_dirty_chars(expr str) =
2786 for i = 0 upto length(str)-1 :
2787 mfun_clean_ascii[ASCII substring(i,i+1) of str] := "_" ;
2788 endfor ;
2789enddef ;
2790
2791register_dirty_chars("+-*/:;., ") ;
2792
2793vardef cleanstring (expr s) =
2794 save ss ; string ss, si ; ss = "" ; save i ;
2795 for i=0 upto length(s) :
2796 si := substring(i,i+1) of s ;
2797 ss := ss & if known mfun_clean_ascii[ASCII si] : mfun_clean_ascii[ASCII si] else : si fi ;
2798 endfor ;
2799 ss
2800enddef ;
2801
2802vardef asciistring (expr s) =
2803 save ss ; string ss, si ; ss = "" ; save i ;
2804 for i=0 upto length(s) :
2805 si := substring(i,i+1) of s ;
2806 if (ASCII si >= ASCII "0") and (ASCII si <= ASCII "9") :
2807 ss := ss & char(scantokens(si) ASCII "A") ;
2808 else :
2809 ss := ss & si ;
2810 fi ;
2811 endfor ;
2812 ss
2813enddef ;
2814
2815vardef setunstringed (expr s, v) =
2816 scantokens(cleanstring(s)) := v ;
2817enddef ;
2818
2819vardef getunstringed (expr s) =
2820 scantokens(cleanstring(s))
2821enddef ;
2822
2823vardef unstringed (expr s) =
2824 expandafter known scantokens(cleanstring(s))
2825enddef ;
2826
2827
2828
2829
2830
2831def showgrid (expr MinX, MaxX, DeltaX, MinY, MaxY, DeltaY) =
2832 begingroup
2833 save size ; numeric size ; size := 2pt ;
2834 for x=MinX upto MaxX :
2835 for y=MinY upto MaxY :
2836 draw (xDeltaX, yDeltaY) withpen pencircle scaled
2837 if (x mod 5 = 0) and (y mod 5 = 0) :
2838 1.5size withcolor .50white
2839 else :
2840 size withcolor .75white
2841 fi ;
2842 endfor ;
2843 endfor ;
2844 for x=MinX upto MaxX:
2845 label.bot(textext("\infofont " & decimal x), (xDeltaX,size)) ;
2846 endfor ;
2847 for y=MinY upto MaxY:
2848 label.lft(textext("\infofont " & decimal y), (size,yDeltaY)) ;
2849 endfor ;
2850 endgroup
2851enddef;
2852
2853
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
2880vardef phantom (text t) =
2881 picture _p_ ;
2882 _p_ := image(t) ;
2883 addto _p_ also currentpicture ;
2884 setbounds currentpicture to boundingbox _p_ ;
2885enddef ;
2886
2887vardef c_phantom (expr b) (text t) =
2888 if b :
2889 picture _p_ ;
2890 _p_ := image(t) ;
2891 addto _p_ also currentpicture ;
2892 setbounds currentpicture to boundingbox _p_ ;
2893 else :
2894 t ;
2895 fi ;
2896enddef ;
2897
2898
2899
2900def break =
2901 exitif true ;
2902enddef ;
2903
2904
2905
2906primarydef p xstretched w = (
2907 p if (bbwidth (p)>0) and (w>0) : xscaled (wbbwidth (p)) fi
2908) enddef ;
2909
2910primarydef p ystretched h = (
2911 p if (bbheight(p)>0) and (h>0) : yscaled (hbbheight(p)) fi
2912) enddef ;
2913
2914
2915
2916vardef area expr p =
2917
2918 (xpart llcorner boundingbox p,0) -- p --
2919 (xpart lrcorner boundingbox p,0) -- cycle
2920enddef ;
2921
2922vardef basiccolors[] =
2923 if @ = 0 :
2924 white
2925 else :
2926 save n ; n := @ mod 7 ;
2927 if n = 1 : red
2928 elseif n = 2 : green
2929 elseif n = 3 : blue
2930 elseif n = 4 : cyan
2931 elseif n = 5 : magenta
2932 elseif n = 6 : yellow
2933 else : black
2934 fi
2935 fi
2936enddef ;
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948vardef rcomponent expr p = if rgbcolor p : redpart p elseif cmykcolor p : 1 cyanpart p else : p fi enddef ;
2949vardef gcomponent expr p = if rgbcolor p : greenpart p elseif cmykcolor p : 1 magentapart p else : p fi enddef ;
2950vardef bcomponent expr p = if rgbcolor p : bluepart p elseif cmykcolor p : 1 yellowpart p else : p fi enddef ;
2951vardef ccomponent expr p = if cmykcolor p : cyanpart p elseif rgbcolor p : 1 redpart p else : p fi enddef ;
2952vardef mcomponent expr p = if cmykcolor p : magentapart p elseif rgbcolor p : 1 greenpart p else : p fi enddef ;
2953vardef ycomponent expr p = if cmykcolor p : yellowpart p elseif rgbcolor p : 1 bluepart p else : p fi enddef ;
2954vardef kcomponent expr p = if cmykcolor p : blackpart p elseif rgbcolor p : 0 else : p fi enddef ;
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979vardef undecorated (text imagedata) text decoration =
2980 save currentpicture ;
2981 picture currentpicture ;
2982 currentpicture := nullpicture ;
2983 imagedata ;
2984 currentpicture
2985enddef ;
2986
2987
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 vardef decorated (text imagedata) text decoration =
3024 save mfun_decorated_path, currentpicture ;
3025 picture mfun_decorated_path, currentpicture ;
3026 currentpicture := nullpicture ;
3027 imagedata ;
3028 mfun_decorated_path := currentpicture ;
3029 currentpicture := nullpicture ;
3030 for i within mfun_decorated_path :
3031 addto currentpicture
3032 if stroked i :
3033 doublepath pathpart i
3034 dashed dashpart i
3035 withpen penpart i
3036 withcolor colorpart i
3037 withprescript prescriptpart i
3038 withpostscript postscriptpart i
3039 decoration
3040 elseif filled i :
3041 contour pathpart i
3042 withpen penpart i
3043 withcolor colorpart i
3044 withprescript prescriptpart i
3045 withpostscript postscriptpart i
3046 decoration
3047 elseif textual i :
3048 also i
3049 withcolor colorpart i
3050 withprescript prescriptpart i
3051 withpostscript postscriptpart i
3052 decoration
3053 else :
3054 also i
3055 fi
3056 ;
3057 endfor ;
3058 currentpicture
3059 enddef ;
3060
3061
3062
3063vardef redecorated (text imagedata) text decoration =
3064 save mfun_decorated_path, currentpicture ;
3065 picture mfun_decorated_path, currentpicture ;
3066 currentpicture := nullpicture ;
3067 imagedata ;
3068 mfun_decorated_path := currentpicture ;
3069 currentpicture := nullpicture ;
3070 for i within mfun_decorated_path :
3071 addto currentpicture
3072 if stroked i :
3073 doublepath pathpart i
3074 dashed dashpart i
3075 withpen penpart i
3076 decoration
3077 elseif filled i :
3078 contour pathpart i
3079 withpen penpart i
3080 decoration
3081 elseif textual i :
3082 also i
3083 decoration
3084 else :
3085 also i
3086 fi
3087 ;
3088 endfor ;
3089 currentpicture
3090enddef ;
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106vardef mfun_snapped(expr p, s) =
3107 if p < 0 : ( else : ( fi p div s) s
3108enddef ;
3109
3110vardef mfun_applied(expr p, s)(suffix a) =
3111 if path p :
3112 if pair s :
3113 for i=0 upto length(p)-1 :
3114 (a(xpart point i of p,xpart s),a(ypart point i of p,ypart s)) --
3115 endfor
3116 if cycle p :
3117 cycle
3118 else :
3119 (a(xpart point length(p) of p,xpart s),a(ypart point length(p) of p,ypart s))
3120 fi
3121 else :
3122 for i=0 upto length(p)-1 :
3123 (a(xpart point i of p,s),a(ypart point i of p,s)) --
3124 endfor
3125 if cycle p :
3126 cycle
3127 else :
3128 (a(xpart point length(p) of p,s),a(ypart point length(p) of p,s))
3129 fi
3130 fi
3131 elseif pair p :
3132 if pair s :
3133 (a(xpart p,xpart s),a(ypart p,ypart s))
3134 else :
3135 (a(xpart p,s),a(ypart p,s))
3136 fi
3137 elseif cmykcolor p :
3138 (a(cyanpart p,s),a(magentapart p,s),a(yellowpart p,s),a(blackpart p,s))
3139 elseif rgbcolor p :
3140 (a(redpart p,s),a(greenpart p,s),a(bluepart p,s))
3141 elseif graycolor p :
3142 a(p,s)
3143 elseif numeric p :
3144 a(p,s)
3145 else
3146 p
3147 fi
3148enddef ;
3149
3150primarydef p snapped s =
3151 mfun_applied(p,s)(mfun_snapped)
3152enddef ;
3153
3154
3155
3156newinternal charscale ; charscale := 1 ;
3157
3158def beginglyph(expr unicode, width, height, depth) =
3159 beginfig(unicode) ;
3160 charcode := unicode ;
3161 charwd := width ;
3162 charht := height ;
3163 chardp := depth ;
3164
3165enddef ;
3166
3167def endglyph =
3168 setbounds currentpicture to (boundingbox unitsquare xscaled charwd yscaled (charht chardp) shifted (0,chardp)) ;
3169 if known charscale : if (charscale > 0) and (charscale <> 1) :
3170 currentpicture := currentpicture scaled charscale ;
3171 fi ; fi ;
3172 endfig ;
3173enddef ;
3174
3175def beginfont(expr name) =
3176 begingroup;
3177 passvariable("fontname",name) ;
3178enddef ;
3179
3180def endfont =
3181 endgroup;
3182enddef ;
3183
3184
3185
3186
3187newinternal maxdimensions ; maxdimensions := 14000 ;
3188
3189def mfun_apply_max_dimensions =
3190 if bbwidth currentpicture > maxdimensions :
3191 currentpicture := currentpicture if bbheight currentpicture > bbwidth currentpicture : ysized else : xsized fi maxdimensions ;
3192 elseif bbheight currentpicture > maxdimensions :
3193 currentpicture := currentpicture ysized maxdimensions ;
3194 fi ;
3195enddef;
3196
3197extra_endfig := extra_endfig & "mfun_apply_max_dimensions ;" ;
3198
3199
3200
3201path unittriangle, fulltriangle ;
3202
3203unittriangle := point 0 along unitcircle
3204 -- point 13 along unitcircle
3205 -- point 23 along unitcircle
3206 -- cycle ;
3207fulltriangle := point 0 along fullcircle
3208 -- point 13 along fullcircle
3209 -- point 23 along fullcircle
3210 -- cycle ;
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225vardef listsize(suffix list) =
3226 numeric len ; len := 1 ;
3227 forever :
3228 exitif unknown list[len] ;
3229 len := len 1 ;
3230 endfor ;
3231 len if unknown list[0] : 1 fi
3232enddef ;
3233
3234vardef listlast(suffix list) =
3235 numeric len ; len := if known list[0] : 0 else : 1 fi ;
3236 forever :
3237 len := len 1 ;
3238 exitif unknown list[len] ;
3239 endfor ;
3240 len 1
3241enddef ;
3242
3243vardef mfun_quick_sort(suffix list)(expr _min_, _max_)(text what) =
3244 save l, r, m ;
3245 numeric l ; l := _min_ ;
3246 numeric r ; r := _max_ ;
3247 numeric m ; m := floor(.5[_min_,_max_]) ;
3248 _mid_ := what list[m] ;
3249 forever :
3250 exitif l >= r ;
3251 forever :
3252 exitif l > _max_ ;
3253
3254 exitif (what list[l]) >= _mid_ ;
3255 l := l 1 ;
3256 endfor ;
3257 forever :
3258 exitif r < _min_ ;
3259
3260 exitif _mid_ >= (what list[r]) ;
3261 r := r 1 ;
3262 endfor ;
3263 if l <= r :
3264 temp := list[l] ;
3265 list[l] := list[r] ;
3266 list[r] := temp ;
3267 l := l 1 ;
3268 r := r 1 ;
3269 fi ;
3270 endfor ;
3271 if _min_ < r :
3272 mfun_quick_sort(list)(_min_,r)(what) ;
3273 fi ;
3274 if l < _max_ :
3275 mfun_quick_sort(list)(l,_max_)(what) ;
3276 fi ;
3277enddef ;
3278
3279vardef sortlist(suffix list)(text what) =
3280 save _max_ ; numeric _max_ ;
3281 save _mid_ ; numeric _mid_ ;
3282 save temp ;
3283
3284 _max_ := listlast(list) ;
3285 if pair list[_max_] :
3286 pair temp ;
3287 else :
3288 numeric temp ;
3289 fi ;
3290 if pair what list[_max_] :
3291 pair _mid_ ;
3292 else :
3293 numeric _mid_ ;
3294 fi ;
3295 if _max_ > 1 :
3296
3297 mfun_quick_sort(list)(if known list[0] : 0 else : 1 fi,_max_)(what) ;
3298 fi ;
3299enddef ;
3300
3301vardef uniquelist(suffix list) =
3302
3303enddef ;
3304
3305vardef copylist(suffix list, target) =
3306 save i ; i := 1 ;
3307 forever :
3308 exitif unknown list[i] ;
3309 target[i] := list[i] ;
3310 i := i 1 ;
3311 endfor ;
3312enddef ;
3313
3314vardef listtolines(suffix list) =
3315 list[1] for i=2 upto listsize(list) : -- list[i] endfor
3316enddef ;
3317
3318vardef listtocurves(suffix list) =
3319 list[1] for i=2 upto listsize(list) : .. list[i] endfor
3320enddef ;
3321
3322
3323
3324
3325
3326vardef shapedlist(suffix p) =
3327 save l ; pair l[] ;
3328 save r ; pair r[] ;
3329 save i ; i := 1 ;
3330 save n ; n := 0 ;
3331 forever :
3332 exitif unknown p[i] ;
3333 n := n 1 ;
3334 l[n] := ulcorner p[i] ;
3335 r[n] := urcorner p[i] ;
3336 n := n 1 ;
3337 l[n] := llcorner p[i] ;
3338 r[n] := lrcorner p[i] ;
3339 i := i 1 ;
3340 endfor ;
3341 for i = 3 upto n :
3342 if xpart r[i] < xpart r[i-1] :
3343 r[i] := (xpart r[i],ypart r[i-1]) ;
3344 elseif xpart r[i] > xpart r[i-1] :
3345 r[i-1] := (xpart r[i-1],ypart r[i]) ;
3346 fi ;
3347 if xpart l[i] < xpart l[i-1] :
3348 l[i-1] := (xpart l[i-1],ypart l[i]) ;
3349 elseif xpart l[i] > xpart l[i-1] :
3350 l[i] := (xpart l[i],ypart l[i-1]) ;
3351 fi ;
3352 endfor ;
3353 if n > 0 :
3354 simplified (
3355 for i = 1 upto n : r[i] -- endfor
3356 for i = n downto 1 : l[i] -- endfor
3357 cycle
3358 )
3359 else :
3360 origin -- cycle
3361 fi
3362enddef ;
3363
3364
3365
3366let dump = relax ;
3367
3368
3369
3370def loadmodule expr name =
3371
3372 if (unknown scantokens("context_" & name)) and (unknown scantokens("metafun_loaded_" & name)) :
3373 save s ; string s ;
3374
3375
3376
3377 s := "input " & "mp-" & name & ".mpiv" ;
3378 expandafter scantokens expandafter s
3379 fi ;
3380enddef ;
3381
3382def loadfile (expr filename) = scantokens("input " & filename) enddef ;
3383def loadimage (expr filename) = image(scantokens("input " & filename);) enddef ;
3384
3385
3386
3387def drawpathwithpoints expr p =
3388 do_drawpathwithpoints(p)
3389enddef ;
3390
3391def do_drawpathwithpoints(expr p) text t =
3392 draw p t ;
3393 if length(p) > 2 :
3394 begingroup ;
3395 save _c_ ; path _c_ ;
3396 save _p_; picture _p_ ;
3397 _p_ := image (
3398 _c_ := if cycle p : fullsquare else : fullcircle fi scaled 6pt ;
3399 for i=0 upto length(p) if cycle p : -1 fi :
3400 fill _c_ shifted point i of p withcolor white ;
3401 draw _c_ shifted point i of p withcolor white2 withpen pencircle scaled .5pt ;
3402 if (i = 0) and cycle p :
3403 _c_ := fullcircle scaled 6pt ;
3404 fi ;
3405 endfor ;
3406 for i=0 upto length(p) if cycle p : -1 fi :
3407 draw textext("\infofont " & decimal i) ysized 2pt shifted point i of p ;
3408 endfor ;
3409 ) ;
3410 setbounds _p_ to boundingbox p ;
3411 draw _p_ ;
3412 fi ;
3413enddef ;
3414
3415
3416
3417
3418newinternal crossingdebug ; crossingdebug := 0 ;
3419newinternal crossingscale ; crossingscale := 10 ;
3420newinternal crossingnumbermax ; crossingnumbermax := 1000 ;
3421
3422
3423
3424vardef infotext@#(expr txt, ysize) =
3425 textext@#("\infofont " & if numeric txt : decimal fi txt) ysized ysize
3426enddef ;
3427
3428primarydef p crossingunder q =
3429 begingroup
3430 save pic ; picture pic ; pic := nullpicture ;
3431 if picture p :
3432 for i within p :
3433 if stroked i :
3434 addto pic also image(draw pathpart i crossingunder q) ;
3435 fi
3436 endfor
3437 elseif path p :
3438 save n, t, a, b, c, r, bcuttings, hold ;
3439 numeric n, t[], hold ;
3440 path a, b, c, r, bcuttings, hold[] ;
3441 c := makepath(currentpen scaled crossingscale) ;
3442 r := if picture q : boundingbox fi q ;
3443 t[0] := n := hold := 0 ;
3444 a := p ;
3445
3446
3447 for i=1 upto crossingnumbermax :
3448 clearxy ; z = a intersectiontimes r ;
3449 if x < 0 :
3450 exitif hold < 1 ;
3451 a := hold[hold] ; hold := hold 1 ;
3452 clearxy ; z = a intersectiontimes r ;
3453 fi
3454 (t[incr n], whatever) = p intersectiontimes point x of a ;
3455 if x = 0 :
3456 a := a cutbefore c shifted point x of a ;
3457 elseif x = length a :
3458 a := a cutafter c shifted point x of a ;
3459 else :
3460 b := subpath (0,x) of a cutafter c shifted point x of a ;
3461 bcuttings := cuttings ;
3462 a := subpath (x,length a) of a cutbefore c shifted point x of a ;
3463 clearxy ; z = a intersectiontimes r ;
3464 if x < 0 :
3465 a := b ;
3466 cuttings := bcuttings ;
3467 else :
3468 if length bcuttings > 0 :
3469 clearxy ; z = b intersectiontimes r ;
3470 if x >= 0 :
3471 hold[incr hold] := b ;
3472 fi
3473 fi
3474 fi
3475 fi
3476 if length cuttings = 0 :
3477 exitif hold < 1 ;
3478 a := hold[hold] ; hold := hold 1 ;
3479 fi
3480 if i = crossingnumbermax :
3481 message("crossingunder reached maximum " & decimal i & " intersections.");
3482 fi
3483 endfor
3484
3485 if n = 0 :
3486 save pic ; path pic ; pic := p ;
3487 else :
3488 sortlist(t,) ;
3489
3490 t[incr n] = length p if cycle p : t[1] fi ;
3491
3492
3493
3494
3495 save m ; m := 0 ;
3496 for i=if cycle p: 2 else: 1 fi upto n :
3497
3498
3499 if crossingdebug > 0 :
3500 if crossingdebug = 1 :
3501 addto pic doublepath c shifted point t[i] of p
3502 withpen currentpen withtransparency(1,.5) ;
3503 elseif crossingdebug = 2 :
3504 addto pic also
3505 infotext (incr m,crossingscale5)
3506 shifted point t[i] of p ;
3507 fi
3508 fi
3509 a := subpath (t[i-1],t[i]) of p
3510 if i > 1 :
3511 cutbefore (c shifted point t[i-1] of p)
3512 fi
3513 if (i < n) or (cycle p) :
3514 cutafter (c shifted point t[i] of p)
3515 fi ;
3516 if (not picture q) or (a outsideof q) :
3517 addto pic doublepath a withpen currentpen ;
3518 fi
3519 endfor
3520 fi
3521 fi
3522 pic
3523 endgroup
3524enddef ;
3525
3526primarydef p insideof q =
3527 begingroup
3528 save pth, pic, t ;
3529 path pth ; picture pic ;
3530 pic := if path q : image(draw q;) else : q fi ;
3531 pth := p -- center pic ;
3532 (t, whatever) = pth intersectiontimes boundingbox pic ;
3533 t < 0
3534 endgroup
3535enddef ;
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558primarydef p outsideof q =
3559 not (p insideof q)
3560enddef ;
3561
3562
3563
3564vardef circularpath primary n =
3565 reverse (for i=0 step 2n until 8-2n+2eps: point i of fullcircle .. endfor cycle) rotated 90
3566enddef ;
3567
3568vardef squarepath primary n =
3569 for i=0 step 1n until 4-1n 2eps: point i of fullsquare -- endfor cycle
3570enddef ;
3571
3572vardef linearpath primary n =
3573 origin for i=1n step 1n until 1-1n 2eps: -- point i of (origin--(1,0)) endfor
3574enddef ;
3575
3576
3577
3578color pensilcolor ; pensilcolor := .5red ;
3579newinternal pensilstep ; pensilstep := 125 ;
3580
3581vardef pensilled(expr p, q) =
3582 image (
3583 draw p withcolor pensilcolor withpen q ;
3584 for i = 0 step pensilstep until length(p) eps:
3585 draw point i of p withcolor white withtransparency (1,.5) withpen q ;
3586 endfor ;
3587 )
3588enddef ;
3589
3590
3591
3592vardef tolist(suffix l)(text t) =
3593 save n ; n := 1 ;
3594 for p = t :
3595 if numeric p :
3596 n := p ;
3597 dispose(l[n])
3598 elseif pair p :
3599 l[n] := p ;
3600 n := n 1 ;
3601 elseif path p :
3602 for i=0 step 1 until length(p) :
3603 l[n] := point i of p ;
3604 n := n 1 ;
3605 endfor ;
3606 else :
3607
3608 fi ;
3609 endfor ;
3610 forever :
3611 exitif unknown l[n] ;
3612 dispose(l[n])
3613 n := n 1 ;
3614 endfor ;
3615enddef ;
3616
3617vardef topath(suffix p)(text t) =
3618 save i ; i := if known p[1] : 2 ; p[1] elseif known p[0] : 1 ; p[0] else : 0 ; origin fi
3619 forever :
3620 exitif unknown p[i] ;
3621 t p[i]
3622 hide(i := i 1)
3623 endfor
3624enddef ;
3625
3626vardef tocycle(suffix p)(text t) =
3627 topath(p,t) t cycle
3628enddef ;
3629
3630
3631
3632def drawdot expr p =
3633 if pair p :
3634 addto currentpicture doublepath p
3635 withpen currentpen _op_
3636 elseif path p :
3637 draw image (
3638 for i=0 upto length p :
3639 addto currentpicture doublepath point i of p
3640 withpen currentpen _op_ ;
3641 endfor ;
3642 )
3643 elseif picture p :
3644 draw image (
3645 save pp ; path pp ;
3646 for i within p :
3647 if stroked i or filled i :
3648 pp := pathpart i ;
3649 for j=0 upto length pp :
3650 addto currentpicture doublepath point j of pp
3651 withpen currentpen _op_ ;
3652 endfor ;
3653 fi ;
3654 endfor ;
3655 )
3656 fi
3657enddef ;
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667vardef mfun_timestamp =
3668 decimal year & "-" &
3669 decimal month & "-" &
3670 decimal day & " " &
3671 if ((time div 60) < 10) : "0" & fi
3672 decimal (time div 60) & ":" &
3673 if ((time(time div 60)60) < 10) : "0" & fi
3674 decimal (time(time div 60)60)
3675enddef ;
3676
3677vardef totransform(expr x, y, xx, xy, yx, yy) =
3678 save t ; transform t ;
3679 xxpart t = xx ; yypart t = yy ;
3680 xypart t = xy ; yxpart t = yx ;
3681 xpart t = x ; ypart t = y ;
3682 t
3683enddef ;
3684
3685vardef bymatrix(expr rx, sx, sy, ry, tx, ty) =
3686 save t ; transform t ;
3687 xxpart t = rx ; yypart t = ry ;
3688 xypart t = sx ; yxpart t = sy ;
3689 xpart t = tx ; ypart t = ty ;
3690 t
3691enddef ;
3692
3693let xslanted = slanted ;
3694
3695def yslanted primary s =
3696 transformed
3697 begingroup
3698 save t ; transform t ;
3699 xxpart t = 1 ; yypart t = 1 ;
3700 xypart t = 0 ; yxpart t = s ;
3701 xpart t = 0 ; ypart t = 0 ;
3702 t
3703 endgroup
3704enddef ;
3705
3706
3707
3708
3709
3710newinternal hatch_match; hatch_match := 1;
3711
3712vardef hatched(expr o) primary c =
3713 save a_, b_, d_, l_, i_, r_, za_, zb_, zc_, zd_;
3714 path b_; picture r_; pair za_, zb_, zc_, zd_;
3715 r_ := image (
3716 a_ := redpart(c) mod 180 ;
3717 l_ := greenpart(c) ;
3718 d_ := bluepart(c) ;
3719 b_ := o rotated a_ ;
3720 b_ :=
3721 if a_ >= 90 :
3722 (lrcorner b_ -- llcorner b_ -- ulcorner b_ -- urcorner b_ -- cycle)
3723 else :
3724 (llcorner b_ -- lrcorner b_ -- urcorner b_ -- ulcorner b_ -- cycle)
3725 fi
3726 rotated a_ ;
3727 za_ := point 0 of b_ ;
3728 zb_ := point 1 of b_ ;
3729 zc_ := point 2 of b_ ;
3730 zd_ := point 3 of b_ ;
3731 if hatch_match > 0 :
3732 n_ := round(length(zd_za_) l_) ;
3733 if n_ < 2:
3734 n_ := 2 ;
3735 fi ;
3736 l_ := length(zd_za_) n_ ;
3737 else :
3738 n_ := length(zd_za_) l_ ;
3739 fi
3740 save currentpen; pen currentpen ; pickup pencircle scaled d_;
3741
3742 for i_ := if hatch_match > 0 : 1 else : 0 fi upto ceiling n_ 1 :
3743 nodraw (i_n_)[zd_,za_] -- (i_n_)[zc_,zb_] ;
3744 endfor
3745 dodraw origin ;
3746 ) ;
3747 clip r_ to o;
3748 r_
3749enddef;
3750
3751
3752
3753numeric mfun_dash_on, mfun_dash_off ;
3754
3755primarydef p withdashes len =
3756 hide (
3757 save l, t, n, m, don, doff; pair t ;
3758 l := arclength p ;
3759 t := paired (len) ;
3760 m := xpart t ypart t ;
3761 n := (l if not cycle p : xpart t fi) div m ;
3762 (n if not cycle p : 1 fi) don n doff = l ;
3763 don(ypart t) = doff(xpart t) ;
3764 mfun_dash_on := don ;
3765 mfun_dash_off := doff ;
3766 )
3767 p dashed dashpattern (on mfun_dash_on off mfun_dash_off)
3768enddef ;
3769 |