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