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