summaryrefslogtreecommitdiff
path: root/Master/texmf-dist/metapost/mfpic/grafbase.mp
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2006-07-01 23:18:44 +0000
committerKarl Berry <karl@freefriends.org>2006-07-01 23:18:44 +0000
commitd6c7c85a6b1261a182a60431f6af860b855ec216 (patch)
tree794c53fc0f09ba53c39a272379fbf0004390c6eb /Master/texmf-dist/metapost/mfpic/grafbase.mp
parentd6dd1c3b1739f957dd0acc6f89e480825511c927 (diff)
mfpic 0.9 update
git-svn-id: svn://tug.org/texlive/trunk@1747 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/texmf-dist/metapost/mfpic/grafbase.mp')
-rw-r--r--Master/texmf-dist/metapost/mfpic/grafbase.mp3575
1 files changed, 2309 insertions, 1266 deletions
diff --git a/Master/texmf-dist/metapost/mfpic/grafbase.mp b/Master/texmf-dist/metapost/mfpic/grafbase.mp
index 08e9f3de9b1..225150795f1 100644
--- a/Master/texmf-dist/metapost/mfpic/grafbase.mp
+++ b/Master/texmf-dist/metapost/mfpic/grafbase.mp
@@ -8,86 +8,80 @@
%%
%% -------------------------------------------------------------------
%%
-%% Copyright 2002--2003, Daniel H. Luecking
-%%
-%% Mfpic consists of the 3 files mfpic.dtx, grafbase.dtx and mfpic.ins
-%% and the 5 files they generate: mfpic.tex, mfpic.sty, grafbase.mf,
-%% grafbase.mp, and dvipsnam.mp.
-%%
-%% Documentation, examples, and ancillary files are separate. See
-%% readme.1st for a complete list.
+%% Copyright 2002--2006, Daniel H. Luecking
%%
%% Mfpic may be distributed and/or modified under the conditions of the
-%% LaTeX Project Public License, either version 1.2 of this license or (at
+%% LaTeX Project Public License, either version 1.3b of this license or (at
%% your option) any later version. The latest version of this license is in
+%% <http://www.latex-project.org/lppl.txt>
+%% and version 1.3b or later is part of all distributions of LaTeX version
+%% 2005/12/01 or later.
%%
-%% http://www.latex-project.org/lppl.txt
-%%
-%% and version 1.2 or later is part of all distributions of LaTeX version
-%% 1999/12/01 or later.
+%% Mfpic has maintenance status "author-maintained". The Current Maintainer
+%% is Daniel H. Luecking. There are several Base Interpreters associated
+%% with mfpic: plain TeX, LaTeX, plain Metafont and plain MetaPost.
%%
-%% With respect to the proposed draft LPPL-1.3: mfpic has maintenance
-%% status "maintained". The Current Maintainer is Daniel H. Luecking. There
-%% are several Base Interpreters: TeX, LaTeX, MetaPost and Metafont.
-%%
-string fileversion, filedate;
-fileversion := "0.7a beta"; filedate := "2004/04/16";
-def GBmsg expr s = message "Grafbase: " & s; enddef;
-def GBerrmsg (expr s) expr t =
- errhelp t;
- errmessage "Grafbase: "& s;
- errhelp "";
-enddef;
-if (known grafbaseversion) or (known grafbase) :
- GBmsg "You have loaded grafbase more than once! " &
- "Please make sure that it is loaded only once.";
+if (known grafbaseversion) or (known grafbase):
+ message "Grafbase (" & jobname & "): You have loaded grafbase more "
+ & "than once! Please make sure that it is loaded only once.";
endinput;
fi
-
boolean grafbase; grafbase := true;
-boolean MFPIC; MFPIC := false;
+
+string fileversion, filedate;
+fileversion := "0.9"; filedate := "2006/05/26";
+
+message " Loading grafbase macros, version " & fileversion & " " &
+ filedate & ".";
+
+def GBmsg expr s = message "Grafbase (" & jobname & "): " & s; enddef;
+def GBwarn expr s = GBmsg "Warning, " & s; enddef;
+def GBerrmsg (expr s) expr t = errhelp t;
+ errmessage "Grafbase (" & jobname & "): " & s; errhelp "";
+enddef;
+
+boolean MFPIC; MFPIC := false;
def checkversions (expr g)=
- numeric grafbaseversion; grafbaseversion := g;
- if unknown mfpicversion : % no mfpic, or < 0.63
+ numeric grafbaseversion; grafbaseversion := g;
+ if unknown mfpicversion: % no mfpic, or < 0.63
GBmsg "Recent mfpic not detected.";
- elseif g = mfpicversion :
+ elseif g = mfpicversion:
MFPIC := true;
else:
- GBerrmsg ("version mismatch")
- "The installation may be broken: mfpic and grafbase " &
- "versions do not match.";
+ message "";
+ GBwarn "Version mismatch: "
+ & "mfpic and grafbase versions do not match.";
+ message "";
fi
enddef;
-checkversions (70);
+checkversions (90);
-if unknown base_name : input plain;
-elseif not string base_name : input plain;
-elseif base_name <> "plain" : input plain;
+if unknown base_name : input plain;
+elseif not string base_name: input plain;
+elseif base_name <> "plain": input plain;
fi
boolean METAPOST;
-if known color Maurits Cornelis Escher : METAPOST := true;
-else: METAPOST := false;
+if known color Geamparalele din Babadag:
+ METAPOST := true;
+else:
+ METAPOST := false;
fi
-if not METAPOST :
- GBerrmsg ("wrong compiler")
- "You may have input to Metafont a file designed for Metapost. " &
- "Instead of the file grafbase.mp, Metafont should be using " &
- "grafbase.mf. Make sure the extension was not changed.";
+if not METAPOST:
+ GBerrmsg ("wrong compiler.")
+ "This file is for Metapost. For Metafont use grafbase.mf.";
fi
-if (unknown debug) or (not boolean debug) :
- boolean debug; debug := false;
-fi
+if not boolean debug: boolean debug; debug := false; fi
def GBdebug =
begingroup
- save >>; def >> = message enddef;
- >> "Grafbase DEBUG: ";
+ save >>; def >> = message enddef;
+ >> "Grafbase DEBUG";
enddef;
def GBenddebug =
>> "End DEBUG";
@@ -95,77 +89,78 @@ def GBenddebug =
enddef;
vardef mftitle expr t =
- t; message t;
+ if string t: t; message t; fi
enddef;
-pt# := 1pt;
-def t_ = transformed currenttransform enddef;
-if unknown aspect_ratio: aspect_ratio := 1; fi
-if unknown hppp : hppp := 1 fi;
-if unknown currenttransform :
+pt# := pt; bp# := bp;
+def t_ = transformed currenttransform enddef;
+if unknown aspect_ratio: aspect_ratio := 1; fi
+if unknown hppp: hppp := 1 fi;
+if unknown currenttransform:
transform currenttransform;
currenttransform := identity yscaled aspect_ratio;
fi
interim warningcheck := 0;
-numeric unitlen, xscale, yscale, xneg, xpos, yneg, ypos;
-unitlen := 1 bp;
-xscale := 7.2; % (xscale * unitlen) = 1/10 inch
-yscale := 7.2; % (yscale * unitlen) = 1/10 inch
-xneg := 0; xpos := 10;
-yneg := 0; ypos := 10;
+numeric unitlen, xscale, yscale, xneg, xpos, yneg, ypos;
-newinternal radian, pi, deg;
-deg := 1; pi := 3.14159;
-radian := 180/pi;
+unitlen := 1 bp#;
+xscale := 7.2;
+yscale := 7.2;
+xneg := 0; xpos := 10;
+yneg := 0; ypos := 10;
+newinternal deg, pi, radian;
+deg := 1; pi := 3.14159;
+radian := 57.29578;
+numeric degree; degree := deg;
-newinternal penwd; penwd := 0.5pt;
+newinternal penwd; penwd := 0.5pt;
pen drawpen;
def resizedrawpen (expr s) =
interim penwd := s;
- setvariable (pen) (drawpen) (pencircle scaled penwd);
- save currentpen; pen currentpen; pickup drawpen;
+ setvariable (pen) (drawpen) pencircle scaled penwd;
+ save currentpen; pen currentpen; pickup drawpen;
enddef;
-numeric hatchwd; hatchwd := 0.5bp;
-pen hatchpen; hatchpen := pencircle scaled hatchwd;
+numeric hatchwd; hatchwd := 0.5bp;
+pen hatchpen; hatchpen := pencircle scaled hatchwd;
-boolean clipall; clipall := false;
-boolean ClipOn; ClipOn := false;
-path ClipPath[]; numeric ClipPath; ClipPath = 0;
-boolean truebbox; truebbox := false;
+boolean clipall; clipall := false;
+boolean ClipOn; ClipOn := false;
+path ClipPath[]; numeric ClipPath; ClipPath = 0;
+boolean truebbox; truebbox := false;
def DoClip (suffix v) =
- if ClipOn and (ClipPath > 0) : clipsto (v, ClipPath); fi
+ if ClipOn and (ClipPath > 0): clipsto (v, ClipPath); fi
enddef;
def noclip (text t) =
- hide( save ClipOn; boolean ClipOn; ClipOn := false; t)
+ hide ( setboolean (ClipOn) false; t)
enddef;
-boolean showbbox; showbbox := false;
+boolean showbbox; showbbox := false;
-def _wc_ = withcolor enddef;
+def _wc_ = withcolor enddef;
-color currentcolor, fillcolor, drawcolor, hatchcolor,
+color currentcolor, drawcolor, fillcolor, hatchcolor,
headcolor, pointcolor, tlabelcolor, background;
currentcolor := fillcolor := drawcolor := hatchcolor :=
headcolor := pointcolor := tlabelcolor := black;
background := white;
vardef snapto expr t =
- if unknown t : 0
- elseif not (numeric t) : 0
- elseif t < 0 : 0
- elseif t > 1 : 1
- else : t
+ if unknown t: 0
+ elseif not (numeric t): 0
+ elseif t < 0: 0
+ elseif t > 1: 1
+ else: t
fi
enddef;
-vardef gray (expr g) = (snapto g)*white enddef;
+vardef gray (expr g) = (snapto g)*white enddef;
vardef makeclr (expr r, g, b) =
(r, g, b)
@@ -183,12 +178,13 @@ vardef RGB (expr R, G, B) =
rgb (R/255, G/255, B/255)
enddef;
-vardef named (suffix c) = forceclr (c) enddef;
+vardef named (suffix c) =
+ if unknown c: black else: forceclr (c) fi
+enddef;
vardef forceclr (expr c) =
- if unknown c : black
- elseif numeric c : gray (c)
- elseif color c : c
- else : black
+ if numeric c: gray (c)
+ elseif color c: c
+ else: black
fi
enddef;
@@ -200,55 +196,70 @@ cyan := rgb (0, 1, 1);
magenta := rgb (1, 0, 1);
yellow := rgb (1, 1, 0);
-vardef list (suffix v) (text lst) =
- v := 0; for _itm = lst: v[incr v] := _itm; endfor
+def list (suffix v) (text lst) =
+ v := 0; for _itm = lst: v[incr v] := _itm; endfor
+ if v = 0:
+ GBerrmsg ("no list to process!")
+ "An attempt was made to produce an array from a "
+ & "list of expressions having no valid entries.";
+ fi
enddef;
def map (text proc) (text lst) =
- hide(_map := 0;)
- for _a = lst :
- if _map = 0 : hide(_map := 1;) else: , fi
- proc(_a)
+ hide (_map := 0;)
+ for _a = lst:
+ if _map = 0: hide (_map := 1;) else: , fi
+ proc (_a)
endfor
enddef;
-vardef knownarray suffix arr =
- save _kna; boolean _kna;
- _kna := (known arr) and (numeric arr);
+vardef knownnumericarray suffix arr =
+ setboolean (_kna) (known arr) and (numeric arr);
if _kna :
_kna := (arr = floor arr) and (arr >= 1);
for _idx = 1 upto arr :
exitif not _kna;
- _kna := known arr[_idx];
+ _kna := (known arr[_idx]) and (numeric arr[_idx]);
endfor
fi
_kna
enddef;
-def copyarray(suffix from, to) =
- to := 0;
- for _idx = 1 upto from:
- to[incr to] := from[_idx];
- endfor
+def copyarray (suffix src, dest) =
+ for _idx = 1 upto src: dest[_idx] := src[_idx]; endfor
+ dest := src;
enddef;
def maparr (text proc) (suffix p) =
- for _idx = 1 upto p: proc (p[_idx]); endfor
+ for _idx = 1 upto p: proc (p[_idx]); endfor
enddef;
-def textpairs (suffix p) (text t) =
- numeric p; pair p[]; list (p) (t);
+def textpairs = gsetarray (pair) enddef;
+
+def setuniquepairs (suffix p) (text t) =
+ save p; pair p[];
+ setpairs (_up) (t);
+ if _up > 0:
+ p := 1; p1 := _up1;
+ for _i = 2 upto _up:
+ if _up[_i] <> p[p]: p[incr p] := _up[_i]; fi
+ endfor
+ else:
+ p := 0;
+ fi
enddef;
vardef chpair (text proc) (expr p) =
(proc (xpart p), proc (ypart p))
enddef;
-vardef floorpair (expr p) = chpair (floor) (p) enddef;
-vardef ceilingpair (expr p) = chpair (ceiling) (p) enddef;
+vardef floorpair (expr p) = (floor (xpart p), floor (ypart p)) enddef;
+vardef ceilingpair (expr p) =
+ (ceiling (xpart p), ceiling (ypart p))
+enddef;
-vardef emin (expr a, b) = if a < b : a else: b fi enddef;
-vardef emax (expr a, b) = if a > b : a else: b fi enddef;
+vardef emin (expr a, b) = if a < b: a else: b fi enddef;
+vardef emax (expr a, b) = if a > b: a else: b fi enddef;
vardef pairmin (expr z, w) =
( emin (xpart z, xpart w), emin (ypart z, ypart w ) )
@@ -257,22 +268,147 @@ vardef pairmax (expr z, w) =
( emax (xpart z, xpart w), emax (ypart z, ypart w ) )
enddef;
-vardef minpair (suffix p) =
- save _mp; pair _mp; _mp := p1;
- for _idx = 2 upto p - 1 :
- _mp := pairmin(_mp, p[_idx]);
- endfor
+vardef minpair (suffix p) = setpair (_mp) p1;
+ for _idx = 2 upto p - 1: _mp := pairmin (_mp, p[_idx]); endfor
pairmin (_mp, p[p])
enddef;
-vardef maxpair (suffix p) =
- save _mp; pair _mp; _mp := p1;
- for _idx = 2 upto p - 1: _mp := pairmax(_mp, p[_idx]); endfor
+vardef maxpair (suffix p) = setpair (_mp) p1;
+ for _idx = 2 upto p - 1: _mp := pairmax (_mp, p[_idx]); endfor
pairmax (_mp, p[p])
enddef;
+primarydef Z xprod W = (xpart Z * ypart W - xpart W * ypart Z) enddef;
+
+def force_initial (expr p) (suffix f) =
+ hide( setnumeric (_n) length f;
+ f := p
+ if _n = 0:
+ {0,0}
+ else:
+ ..controls post0 (f) and pre 1 (f).. subpath (1,_n) of f
+ fi;)
+enddef;
+
+def force_terminal (expr p) (suffix f) =
+ hide(setpath (_f) reverse f;
+ force_initial (p) (_f);
+ f := reverse _f;)
+enddef;
+
+def force_equal_ends (suffix f, g) =
+ hide(save _p; pair _p;
+ _p := .5[pnt[length f] (f), pnt0(g)];
+ force_terminal (_p) (f); force_initial (_p) (g);)
+enddef;
+
+def replace_ends_of_cycle (expr p) (suffix f) =
+hide(
+if cycle f:
+ save _n; _n := length f;
+ f := p
+ if _n = 0: &cycle
+ else: .. controls post0 (f) and pre 1 (f) ..
+ if _n = 1: cycle
+ else: subpath (1, _n - 1) of f ..
+ controls post[_n - 1](f) and pre[_n](f) .. cycle
+ fi
+ fi;
+fi)
+enddef;
+
+pair thetimes;
+numeric _Xtime, _Ytime;
+tertiarydef a intersects b =
+ begingroup
+ thetimes := a intersectiontimes b;
+ _Xtime := xpart thetimes;
+ _Ytime := ypart thetimes;
+ (_Xtime > -1)
+ endgroup
+enddef;
+
+tertiarydef a misses b = ((a intersectiontimes b) < origin) enddef;
+
+vardef makepicture (expr s) =
+ if picture s: s
+ elseif string s: s infont defaultfont scaled defaultscale
+ elseif path s: picpath (s)
+ else: nullpicture
+ fi
+enddef;
+
+vardef onepointpath (expr cyclic, q) =
+ q if cyclic: &cycle else: {0,0} fi
+enddef;
+
+vardef fallbackpath (expr cyclic, p) (text t) =
+ onepointpath (cyclic, p)
+enddef;
+
+def even = not odd enddef;
+
+primarydef a divides b =
+ ((b mod a) = 0)
+enddef;
+
+def beginimage =
+ begingroup
+ newpicture (currentpicture);
+enddef;
+def endimage =
+ ; currentpicture
+ endgroup
+enddef;
+
+def makeimage (suffix name) (expr refpt) =
+ setpair (_image_reference_point) zconv(refpt);
+ setpicture (name) beginimage
+enddef;
+def concludeimage =
+ endimage shifted
+ -_image_reference_point
+enddef;
+
+def setvariable (text kind) (suffix name) =
+ save name; kind name; name :=
+enddef;
+def gsetvariable (text kind) (suffix name) = kind name; name :=
+enddef;
+
+def setnumeric (suffix name) = save name; name := enddef;
+def setboolean = setvariable (boolean) enddef;
+def setpair = setvariable (pair) enddef;
+def setpath = setvariable (path) enddef;
+def setcolor = setvariable (color) enddef;
+def setpicture = setvariable (picture) enddef;
+def settension (suffix tn) expr tens =
+ setnumeric (tn) if tens > 0: tens else: default_tension fi;
+enddef;
+def fixtension (suffix tn) = if tn < .75: tn := .75; fi enddef;
+
+def newpicture (suffix pic) = setpicture (pic) nullpicture; enddef;
+def convertpath (suffix g) expr f = setpath (g) zconv (f); enddef;
+
+def setarray (text kind) (suffix name) =
+ save name; kind name[]; list (name)
+enddef;
+def setpairs = setarray (pair) enddef;
+def gsetarray (text kind) (suffix name) =
+ numeric name; kind name[]; list (name)
+enddef;
+
+
+def setbbox (suffix ll, ur) =
+ save ll, ur; pair ll, ur; getbbox (ll, ur)
+enddef;
+
+def setsplit (suffix s) expr ss =
+ setnumeric (s) emax (1, ceiling ss);
+enddef;
+
transform ztr, vtr;
def setztr =
- if debug :
+ if debug:
GBdebug;
>> "w_ = " & decimal w_ & "bp";
>> "h_ = " & decimal h_ & "bp";
@@ -287,65 +423,63 @@ def setztr =
fi
save ztr, vtr;
transform ztr, vtr;
- vtr := identity xscaled (xscale) yscaled (yscale)
- scaled (unitlen*hppp);
- ztr := identity shifted (-(xneg, yneg)) transformed vtr;
- if debug :
+ vtr := identity xscaled xscale yscaled yscale scaled (unitlen*hppp);
+ ztr := identity shifted (-xneg, -yneg) transformed vtr;
+ if debug:
GBdebug;
- >> "ztr: ";
+ >> "ztr is";
show ztr;
- >> "vtr: ";
+ >> "vtr is";
show vtr;
GBenddebug;
fi
enddef;
-vardef zconv (expr a) = a transformed ztr enddef;
-vardef invzconv (expr a) = a transformed (inverse ztr) enddef;
-vardef vconv (expr v) = v transformed vtr enddef;
-vardef invvconv (expr v) = v transformed (inverse vtr) enddef;
+vardef zconv (expr a) = a transformed ztr enddef;
+vardef invzconv (expr a) = a transformed (inverse ztr) enddef;
+vardef vconv (expr v) = v transformed vtr enddef;
+vardef invvconv (expr v) = v transformed (inverse vtr) enddef;
-def active_plane = currentpicture enddef;
+def active_plane = currentpicture enddef;
-boolean overlaylabels;
-overlaylabels = false;
+boolean overlaylabels, underlaylabels, havebackground;
+overlaylabels := false;
+underlaylabels := false;
+havebackground := false;
def initpic =
setztr;
resizedrawpen (penwd);
- if ClipOn : ClipPath := 1;
+ if ClipOn: ClipPath := 1;
ClipPath1 := rect (origin, (w_, h_));
fi
- if debug :
+ if debug:
GBdebug;
>> "Drawing nominal bounding box around picture";
GBenddebug;
noclip ( safedraw rect (origin, (w_, h_)) );
fi
- save current_labels; picture current_labels;
- current_labels := nullpicture;
- save labelbb; pair labelbb.ll, labelbb.ur;
+ newpicture (foreground_labels);
+ newpicture (background_labels);
+ havebackground := false;
+ save labelbb; pair labelbb.ll, labelbb.ur;
labelbb.ll := labelbb.ur := origin;
enddef;
-def mfpicenv = enddef;
-def endmfpicenv = enddef;
+def mfpicenv = enddef;
+def endmfpicenv = enddef;
def bounds (expr a, b, c, d) =
- xneg := a; xpos := b;
- yneg := c; ypos := d;
+ xneg := a; xpos := b;
+ yneg := c; ypos := d;
enddef;
-def setvariable (text kind) (suffix name) (expr value) =
- save name; kind name; name := value;
-enddef;
-
-string extra_beginmfpic; extra_beginmfpic := "";
+string extra_beginmfpic; extra_beginmfpic := "";
string extra_endmfpic; extra_endmfpic := "";
def beginmfpic (expr ch) =
beginfig (ch);
gcode := ch;
- save w_, h_, d_; numeric w_, h_, d_;
+ save w_, h_, d_;
charwd := (xpos-xneg)*xscale*unitlen;
charht := (ypos-yneg)*yscale*unitlen;
chardp := 0;
@@ -358,52 +492,59 @@ enddef;
def endmfpic =
scantokens extra_endmfpic;
- if debug :
+ if debug:
GBdebug;
>> "width = " & decimal w_ & "bp";
>> "height = " & decimal h_ & "bp";
GBenddebug;
fi
DoClip (active_plane);
- if clipall : clipto (active_plane) rect(origin, (w_, h_)); fi
- if showbbox : noclip ( safedraw rect (origin, (w_, h_)) ); fi
+ if clipall: clipto (active_plane) rect (origin, (w_, h_)); fi
+ if showbbox: noclip ( safedraw rect (origin, (w_, h_)) ); fi
save _ll, _ur;
pair _ll, _ur;
- if truebbox :
+ if truebbox:
_ll := llcorner active_plane;
_ur := urcorner active_plane;
elseif clipall:
_ll := origin;
_ur := (w_,h_);
else: % expand to accomodate labels
- _ll := pairmin((0, 0 ), labelbb.ll);
- _ur := pairmax((w_, h_), labelbb.ur);
+ _ll := pairmin ((0, 0 ), labelbb.ll);
+ _ur := pairmax ((w_, h_), labelbb.ur);
fi
- _ur := pairmax(_ur, _ll + eps*(1, 1));
- setbounds active_plane to rect(_ll, _ur);
- addto active_plane also current_labels;
+ _ur := pairmax (_ur, _ll + eps*(1, 1));
+ setbounds active_plane to rect (_ll, _ur);
+ if havebackground:
+ addto background_labels also active_plane;
+ active_plane := background_labels;
+ background_labels := nullpicture;
+ fi
+ addto active_plane also foreground_labels;
+ foreground_labels := nullpicture;
endfig;
enddef;
-pair label_adjust; label_adjust := (0, 0);
-numeric label_sep; label_sep := 0;
+pair label_adjust;
+label_adjust := origin;
+numeric label_sep, labelpath_sep ;
+label_sep := 0; labelpath_sep := 0;
vardef newgblabel (expr hf, vf, BL, r) (expr s) (text pts) =
- save _lab, _ll, _ur; picture _lab; pair _ll, _ur;
- _lab :=
- if picture s : s
- elseif string s : s infont defaultfont scaled defaultscale
- elseif path s : picpath (s)
- else : nullpicture
- fi;
- labeldims (origin, _lab) (_ll, _ur);
- _lab := thegblabel(ref_shift (hf, vf, BL, _ll, _ur), r, _lab);
- save _b; pair _b;
- for _itm = pts :
- _b := zconv(_itm);
- if overlaylabels :
- addto current_labels also _lab shifted _b _wc_ tlabelcolor;
+ save _lab, _ll, _ur; picture _lab; pair _ll, _ur;
+ _lab := makepicture (s);
+ pathdims (origin, _lab) (_ll, _ur);
+ readjustdims (_ll, _ur) (label_sep);
+ _lab := thegblabel (ref_shift (hf, vf, BL, _ll, _ur), r, _lab);
+ save _b; pair _b;
+ for _itm = pts:
+ _b := zconv (_itm);
+ if overlaylabels:
+ addto foreground_labels also _lab shifted _b _wc_ tlabelcolor;
+ elseif underlaylabels:
+ addto background_labels also _lab shifted _b _wc_ tlabelcolor;
+ havebackground := true;
else:
addto active_plane also _lab shifted _b _wc_ tlabelcolor;
labelbb.ll := pairmin (_b + llcorner _lab, labelbb.ll);
@@ -418,7 +559,7 @@ enddef;
vardef ref_shift (expr hf, vf, BL, ll, ur) =
- ( (hf)[xpart ll, xpart ur],
- (vf)[if BL: 0 else: (ypart ll) fi, ypart ur] )
+ (vf)[if BL: 0 else: (ypart ll) fi, ypart ur] )
enddef;
vardef thegblabel (expr z, r, p) =
@@ -435,98 +576,89 @@ vardef textellipse (expr lbl, rat, loc) =
xellipse (false, .5, .5, false, 0) (origin, lbl, rat, loc)
enddef;
-boolean roundends; roundends := true;
+boolean roundends; roundends := true;
vardef textrectx (expr a, b, c, rot, xy, lbl, rad, loc) =
save ll, ur, _r, f, zz;
pair ll, ur, zz; path f;
- labeldims (xy, lbl) (ll, ur);
- _r :=
- if boolean rad :
- if rad : emin (xpart (ur-ll), ypart (ur-ll))/sqrt(2)
- else: 0
- fi
- elseif numeric rad : rad
- else: 0
+ pathdims (xy, lbl) (ll, ur);
+ readjustdims (ll, ur) (labelpath_sep)
+ _r := if numeric rad: rad
+ elseif not boolean rad: 0
+ elseif rad: emin (xpart(ur-ll), ypart (ur-ll))/sqrt(2)
+ else: 0
fi;
- if _r = 0 :
- f := rect(ll, ur);
+ if _r = 0:
+ f := rect (ll, ur);
else:
save p, q;
pair p[]; path q;
- p1 := ur - _r*dir(45); % center of upper right arc
- p3 := ll + _r*dir(45); % lower left
- p2 := (xpart p3, ypart p1); % upper left
- p4 := (xpart p1, ypart p3); % lower right
- q := quartercircle scaled 2_r;
- if _r > 0:
- f := (q shifted p1) -- (q rotated 90 shifted p2)
- -- (q rotated 180 shifted p3)
- -- (q rotated -90 shifted p4)
- -- cycle;
- else:
- f := (q shifted p1) -- (q rotated -90 shifted p4)
- -- (q rotated 180 shifted p3)
- -- (q rotated 90 shifted p2)
- -- cycle;
- fi
+ p1 := ur - _r*dir(45);
+ p3 := ll + _r*dir(45);
+ p2 := (xpart p3, ypart p1);
+ p4 := (xpart p1, ypart p3);
+ q := if _r < 0: reverse fi quartercircle scaled 2_r;
+ f :=
+ (q shifted p1)--(q rotated 90 shifted p2)
+ --(q rotated 180 shifted p3)
+ --(q rotated -90 shifted p4)--cycle;
+
fi
- invvconv(thegblabel(ref_shift(a, b, c, ll, ur), rot, f)) shifted loc
+ readjustdims (ll, ur) (label_sep - labelpath_sep);
+ invvconv (thegblabel (ref_shift(a, b, c, ll, ur), rot, f)) shifted loc
enddef;
-def textovalx = xellipse (true) enddef;
-def textellipsex = xellipse (false) enddef;
+def textovalx = xellipse (true) enddef;
+def textellipsex = xellipse (false) enddef;
vardef xellipse (expr aspect, a, b, c, r, xy, lbl, mult, loc) =
- if mult = 0 :
+ if mult = 0:
textrectx (a, b, c, r) (xy, lbl, 0, loc)
else:
save ll, ur, cc, ww, hh, f;
pair ll, ur, cc; path f;
- labeldims (xy, lbl) (ll, ur);
- cc := .5[ll, ur]; % center
+ pathdims (xy, lbl) (ll, ur);
+ readjustdims (ll, ur) (labelpath_sep)
+ cc := .5[ll, ur];
(ww, hh) = ur - cc;
- if (ww = 0) or (hh = 0) : % make a line:
+ if (ww = 0) or (hh = 0):
f = (ll--ur);
else:
- save aa, bb, mm;
- mm := if aspect : ww/hh*mult else: mult fi;
- aa := ww ++ hh*mm;
- bb := aa/mm;
- f := ellipse(cc, aa, bb, 0);
+ save aa, bb;
+ aa := ww ++ if aspect: ww else: hh fi *mult;
+ bb := hh ++ if aspect: hh else: ww fi /mult;
+ f := ellipse (cc, aa, bb, 0);
fi
- invvconv(thegblabel (ref_shift (a, b, c, ll, ur), r, f)) shifted loc
+ readjustdims (ll, ur) (label_sep - labelpath_sep);
+ invvconv (thegblabel (ref_shift(a, b, c, ll, ur), r, f)) shifted loc
fi
enddef;
-
-def labeldims (expr xy, lbl) (suffix ll, ur) =
- if pair lbl :
- ll := xy; ur := lbl;
+def pathdims (expr xy, lbl) (suffix ll, ur) =
+ if pair lbl:
+ ll := xy; ur := lbl;
else:
- save _lbl; picture _lbl;
- _lbl :=
- if picture lbl : lbl
- elseif string lbl :
- lbl infont defaultfont scaled defaultscale
- elseif path lbl : picpath (lbl)
- else : nullpicture
- fi;
+ setpicture (_lbl) makepicture (lbl);
ll := llcorner _lbl;
ur := urcorner _lbl;
fi
- ll := ll - label_sep*(1, 1);
- ur := ur + label_sep*(1, 1);
enddef;
-newinternal nottoosmall; nottoosmall := eps/2 + 2epsilon;
-newinternal reallysmall; reallysmall := 3epsilon;
-def signof (expr X) = if X < 0 : - fi enddef;
-def TruncateWarn expr s = GBmsg s & " too large; truncating"; enddef;
+def readjustdims (suffix ll, ur) (expr s) =
+ ll := ll - s*(1,1);
+ ur := ur + s*(1,1);
+enddef;
+
+newinternal reallysmall; reallysmall := 3epsilon;
+newinternal nottoosmall; nottoosmall := eps/2 + 2epsilon;
+def signof (expr X) = if X < 0: - fi enddef;
+def TruncateWarn expr s =
+ GBwarn s & " is too large or undefined, so it will be truncated.";
+enddef;
vardef secd primary X =
- save temp; temp := cosd(X);
- if abs(temp) < reallysmall :
- TruncateWarn "Secant";
+ setnumeric (temp) cosd(X);
+ if abs(temp) < reallysmall:
+ TruncateWarn "Secant or Tangent";
temp := signof (temp) reallysmall;
fi
1/temp
@@ -534,17 +666,31 @@ enddef;
vardef tand primary X = sind(X)*secd(X) enddef;
vardef cscd primary X =
- save temp; temp := sind(X);
- if abs(temp) < reallysmall :
- TruncateWarn "Cosecant";
+ setnumeric (temp) sind(X);
+ if abs(temp) < reallysmall:
+ TruncateWarn "Cosecant or Cotangent";
temp := signof(temp) reallysmall;
fi
1/temp
enddef;
vardef cotd primary X = cosd(X)*cscd(X) enddef;
-vardef acos primary X = angle (X, 1 +-+ X) enddef;
-vardef asin primary X = angle (1 +-+ X, X) enddef;
+vardef acos primary X =
+ if abs X > 1:
+ TruncateWarn "Argument of arccosine";
+ angle (signof(X) 1, 0)
+ else:
+ angle (X, 1 +-+ X)
+ fi
+enddef;
+vardef asin primary X =
+ if abs X > 1:
+ TruncateWarn "Argument of arcsine";
+ angle (0, signof(X) 1)
+ else:
+ angle (1 +-+ X, X)
+ fi
+enddef;
vardef atan primary X = angle (1, X) enddef;
vardef sin primary X = sind (X*radian) enddef;
@@ -554,28 +700,28 @@ vardef cot primary X = cotd (X*radian) enddef;
vardef sec primary X = secd (X*radian) enddef;
vardef csc primary X = cscd (X*radian) enddef;
+vardef degrees (expr t) = t*radian enddef;
+vardef radians (expr t) = t/radian enddef;
vardef invcos primary X = (acos X)/radian enddef;
vardef invsin primary X = (asin X)/radian enddef;
vardef invtan primary X = (atan X)/radian enddef;
-vardef exp primary X = mexp (256 * X) enddef;
-vardef ln primary X = (mlog X) / 256 enddef;
-def log = ln enddef;
-vardef logbase (expr B) primary X = (mlog X)/(mlog B) enddef;
-def logtwo = logbase( 2) enddef;
-def logten = logbase(10) enddef;
+vardef exp primary X = mexp (256 * X) enddef;
+vardef ln primary X = (mlog X) / 256 enddef;
+def log = ln enddef;
+vardef logbase (expr B) primary X = (mlog X)/(mlog B) enddef;
+def logtwo = logbase( 2) enddef;
+def logten = logbase(10) enddef;
-vardef Arg primary Z = (angle Z)/radian enddef;
-vardef Log primary Z = (ln(abs(Z)), Arg (Z)) enddef;
-vardef cis primary T = dir(radian*T) enddef;
-vardef zexp primary Z = (exp (xpart Z))*(cis(ypart Z)) enddef;
-vardef sgn primary Z =
- if Z = origin : origin else: unitvector Z fi
-enddef;
+vardef Arg primary Z = (angle Z)/radian enddef;
+vardef Log primary Z = (ln (abs Z), Arg Z) enddef;
+vardef cis primary T = dir (T*radian) enddef;
+vardef zexp primary Z = (exp (xpart Z)) * cis (ypart Z) enddef;
+vardef sgn primary Z = if not (Z = origin): unitvector fi Z enddef;
vardef cosh primary X =
- save temp; temp := 2 exp (-abs(X));
- if temp < reallysmall :
+ setnumeric (temp) 2 exp (-abs(X));
+ if temp < reallysmall:
TruncateWarn "Cosh";
temp := reallysmall;
fi
@@ -583,8 +729,8 @@ vardef cosh primary X =
enddef;
vardef sinh primary X =
- save temp; temp := 2 exp (-abs(X));
- if temp < reallysmall :
+ setnumeric (temp) 2 exp (-abs(X));
+ if temp < reallysmall:
TruncateWarn "Sinh";
temp := reallysmall;
fi
@@ -592,164 +738,222 @@ vardef sinh primary X =
enddef;
vardef sech primary X =
- save temp; temp := exp(-(abs (X)));
+ setnumeric (temp) exp(-(abs (X)));
2temp/(1 + temp*temp)
enddef;
vardef tanh primary X =
- save temp; temp := exp(-2(abs (X)));
+ setnumeric (temp) exp(-2(abs (X)));
signof (X) (1 - temp)/(1 + temp)
enddef;
vardef csch primary X =
- save temp; temp := exp(-(abs (X)));
- if abs(1 - temp*temp) < reallysmall :
+ save temp, tempa; temp := exp(-(abs (X)));
+ tempa := (1 - temp*temp)/2;
+ if tempa < reallysmall:
TruncateWarn "Csch";
- signof (X) 2temp / reallysmall
- else:
- signof (X) 2temp / (1 - temp*temp)
+ tempa := reallysmall;
fi
+ signof (X) temp / tempa
enddef;
vardef coth primary X =
- save temp; temp := tanh(X);
- if abs(temp) < reallysmall :
+ setnumeric (temp) tanh(X);
+ if abs(temp) < reallysmall:
TruncateWarn "Coth";
- temp := signof (temp) reallysmall;
+ temp := signof (X) reallysmall;
fi
1/temp
enddef;
vardef acosh primary y =
- if y < 1 :
- GBerrmsg ("Undefined function: acosh " & decimal y)
- "If you proceed, a value of 0 will be used. " &
- "Expect more errors later.";
+ if y < 1:
+ TruncateWarn "acosh";
0
else:
- ln (y + (y+-+1))
+ ln (y + (y +-+ 1))
fi
enddef;
-vardef asinh primary y = ln (y + (y++1)) enddef;
+vardef asinh primary y = ln (y + (y ++ 1)) enddef;
vardef atanh primary y =
- if abs (y) < 1 :
- (ln(1+y) - ln(1-y))/2
+ if abs (y) < 1:
+ (ln (1 + y) - ln (1 - y))/2
else:
- GBerrmsg ("Undefined function: atanh " & decimal y)
- "If you proceed, a value of plus or minus infinity " &
- "will be used. Expect more errors later.";
+ TruncateWarn "atanh";
signof (y) infinity
fi
enddef;
-vardef polar (expr p) = (xpart p) * dir (ypart p) enddef;
-def id (expr x) = x enddef;
+vardef polar primary p = (xpart p) * dir (ypart p) enddef;
+def id (expr x) = x enddef;
-transform T_stack[]; T_stack := 0;
-def T_push (expr T) = T_stack[incr T_stack] := T; enddef;
+primarydef x**y =
+ if y=2: x*x
+ elseif (x = floor x) and (abs y = floor y):
+ 1 for n=1 upto y: *x endfor
+ else: takepower y of x
+ fi
+enddef;
+let ^ = **;
+transform T_stack[];
+numeric T_stack; T_stack := 0;
+def T_push (expr T) = T_stack[incr T_stack] := T; enddef;
def T_pop (suffix $) =
- if T_stack > 0 :
- $ := T_stack[T_stack]; T_stack := T_stack - 1;
+ if T_stack > 0:
+ $ := T_stack[T_stack];
+ T_stack := T_stack - 1;
fi
enddef;
-def bcoords = hide ( T_push (ztr); T_push (vtr) ) enddef;
-def ecoords = hide ( T_pop (vtr); T_pop (ztr) ) enddef;
+def bcoords = hide ( T_push (ztr) ) enddef;
+def ecoords = hide ( T_pop (ztr); vtr := vectorpart ztr ) enddef;
+
+vardef vectorpart primary T = T shifted -(origin transformed T) enddef;
def apply_t (text Transformer) =
ztr := identity Transformer transformed ztr;
- vtr := ztr shifted - zconv(origin);
+ vtr := vectorpart ztr;
enddef;
-def xslant = slanted enddef; % (x+sy, y).
+def xslant = slanted enddef; % (x+sy, y).
def yslant primary s = % (x, y+sx).
transformed
begingroup
- save _T; transform _T;
- origin transformed _T = origin;
- (1, 0) transformed _T = (1, s);
- (0, 1) transformed _T = (0, 1);
- _T
+ save T; transform T;
+ origin transformed T = origin;
+ (1, 0) transformed T = (1, s);
+ (0, 1) transformed T = (0, 1);
+ T
endgroup
enddef;
-def zslant primary p = % (xu+yv, xv+yu), where p = (u, v).
+def zslant primary p = % (xu+yv, xv+yu), where p = (u, v).
transformed
begingroup
- save _T; transform _T;
- xpart _T = ypart _T = 0;
- xxpart _T = yypart _T = xpart p;
- xypart _T = yxpart _T = ypart p;
- _T
+ save T; transform T;
+ xpart T = ypart T = 0;
+ xxpart T = yypart T = xpart p;
+ xypart T = yxpart T = ypart p;
+ T
endgroup
enddef;
-def xyswap = zslant (0, 1) enddef;
-def boost primary X = zslant (cosh X, sinh X) enddef;
+def xyswap = zslant (0, 1) enddef;
+def boost primary X = zslant (cosh X, sinh X) enddef;
-vardef rotatedpath (expr p, th) expr f =
- f transformed vtr rotatedaround (p transformed vtr, th)
- transformed (inverse vtr)
+vardef transformedpath (text Transformer) expr f = f Transformer
enddef;
-vardef scaledpath (expr p, s) expr f =
- f shifted -p scaled s shifted p
+
+def rotatedpath (expr p, th) =
+ transformedpath (
+ transformed vtr
+ rotatedaround (p transformed vtr, th)
+ transformed (inverse vtr)
+ )
enddef;
-vardef xslantedpath (expr b, s) expr f =
- f shifted (0, -b) slanted s shifted (0, b)
+def reflectedpath (expr p, q) =
+ transformedpath (
+ transformed vtr
+ reflectedabout (p transformed vtr, q transformed vtr)
+ transformed (inverse vtr)
+ )
enddef;
-def slantedpath = xslantedpath enddef;
-vardef yslantedpath (expr a, s) expr f =
- f shifted (-a, 0) yslant s shifted (0, a)
+
+def scaledpath (expr p, s) =
+ transformedpath (shifted -p scaled s shifted p)
enddef;
-vardef xscaledpath (expr a, s) expr f =
- f shifted (-a, 0) xscaled s shifted (a, 0)
+def xscaledpath (expr a, s) =
+ transformedpath (shifted (-a, 0) xscaled s shifted (a, 0))
enddef;
-vardef yscaledpath (expr b, s) expr f =
- f shifted (0, -b) yscaled s shifted (0, b)
+def yscaledpath (expr b, s) =
+ transformedpath (shifted (0, -b) yscaled s shifted (0, b))
enddef;
-vardef shiftedpath (expr v) expr f = f shifted v enddef;
-vardef reflectedpath (expr p, q) expr f =
- f transformed vtr
- reflectedabout (p transformed vtr, q transformed vtr)
- transformed (inverse vtr)
+
+def slantedpath = xslantedpath enddef;
+def xslantedpath (expr b, s) =
+ transformedpath (shifted (0, -b) slanted s shifted (0, b))
enddef;
-vardef xyswappedpath expr f = f xyswap enddef;
-vardef transformedpath (text Transformer) expr f =
- f Transformer
+def yslantedpath (expr a, s) =
+ transformedpath (shifted (-a, 0) yslant s shifted (0, a))
enddef;
+def shiftedpath (expr v) = transformedpath (shifted v) enddef;
+
+def xyswappedpath = transformedpath (xyswap) enddef;
+
vardef partialpath (expr a, b) expr f =
- save p; path p;
- p := zconv (f) scaled (1/unit_of_length);
- save cumlen, totlen, idx, ta, tb;
- totlen := makelengtharray(cumlen) p;
- idx := 0;
- if a <= b:
- ta := gettime (cumlen, idx) (a*totlen);
- tb := gettime (cumlen, idx) (b*totlen);
+ save flag, flo, fhi, lo, hi, n;
+ boolean flag; flag = true;
+ convertpath (g) f;
+ n := length f;
+
+ flo := snapto emin(a,b);
+ if flo = 0:
+ lo := 0;
+ elseif flo < 1:
+ setuplengtharray (cum, tot, idx) g;
+ flag := false;
+ lo := gettime (cum, idx) (flo*tot);
else:
- tb := gettime (cumlen, idx) (b*totlen);
- ta := gettime (cumlen, idx) (a*totlen);
+ lo := n;
fi
- subpath (ta, tb) of f
+
+ fhi := snapto emax (a,b);
+ if flo = fhi:
+ hi := lo;
+ elseif fhi < 1:
+ if flag: setuplengtharray (cum, tot, idx) g; fi
+ hi := gettime (cum, idx) (fhi*tot);
+ else:
+ hi := n;
+ fi
+
+ if a > b: reverse fi subpath (lo, hi) of f
+enddef;
+
+vardef gsubpath (expr a, b) expr f = subpath (a, b) of f enddef;
+
+def setuplengtharray (suffix cum, tot, idx) =
+ save cum, tot, idx; idx := 0; tot := makelengtharray (cum)
+enddef;
+
+vardef pathtime@# (suffix p) =
+ if @# <= 0: 0
+ elseif @# >= 1: length p
+ else:
+ setuplengtharray (cum, tot, idx) p;
+ gettime (cum, idx) (@#*tot)
+ fi
+enddef;
+
+vardef pathpoint (expr frac) (suffix p) =
+ convertpath (_pp) p; pnt[pathtime[frac] (_pp)] (p)
enddef;
-vardef gsubpath (expr a, b) expr f = subpath (a, b) of f enddef;
def coloraddto (expr clr) (suffix u) (expr v) =
addto u also v _wc_ clr;
enddef;
-def orto (suffix u) (expr v) = addto u also v; enddef;
+def orto (suffix u) (expr v) = addto u also v; enddef;
+
+def coloraddon (expr clr) (suffix v) =
+ addto active_plane also v _wc_ clr;
+enddef;
+
+def _orto (suffix u, v) =
+ addto u also v;
+enddef;
vardef interior expr c =
- save v; picture v; v := nullpicture;
+ newpicture (v);
addto v contour (c.t_);
v
enddef;
+
vardef interiors suffix cc =
- save _ints; picture _ints; _ints := nullpicture;
+ newpicture (_ints);
for _idx = 1 upto cc:
addto _ints also interior cc[_idx]);
endfor
@@ -757,28 +961,29 @@ vardef interiors suffix cc =
enddef;
def clipto (suffix vt) expr c =
+ if path c:
clip vt to c;
+ fi
enddef;
def clipsto (suffix vt, cc) =
begingroup
- save _cl, _cl_; picture _cl, _cl_; _cl_ := nullpicture;
+ save _cl, _cl_; picture _cl, _cl_; _cl_ := nullpicture;
for _idx = 1 upto cc:
- _cl := vt; clip _cl to cc[_idx]; addto _cl_ also _cl;
+ _cl := vt; clip _cl to cc[_idx]; addto _cl_ also _cl;
endfor
vt := _cl_;
endgroup
enddef;
vardef Clipped (suffix vt) expr c =
- save _Cl; picture _Cl; _Cl := vt; clipto (_Cl) c; _Cl
+ setpicture (_Cl) vt; clipto (_Cl) c; _Cl
enddef;
-let clipped_ = clipped;
-def clipped = Clipped enddef;
vardef picneg (suffix vt) expr c =
- save _pn; picture _pn; _pn := nullpicture;
- addto _pn (interior c) _wc_ fillcolor;
- addto _pn also (Clipped (vt) c) _wc_ background;
+ setpicture (_cl) vt; clip _cl to c;
+ newpicture (_pn);
+ addto _pn also (interior c ) _wc_ fillcolor;
+ addto _pn also _cl _wc_ background;
_pn
enddef;
@@ -789,8 +994,8 @@ enddef;
numeric minpenwd;
minpenwd := .05bp; % 1 pixel at 1440dpi
vardef picpath expr d =
- save v; picture v; v := nullpicture;
- if penwd >= minpenwd :
+ newpicture (v);
+ if penwd >= minpenwd:
shpath (v, drawpen) (d);
fi
v
@@ -802,59 +1007,56 @@ def picdot (suffix v) (expr w, p) =
enddef;
vardef setdot (expr apath, sc) =
- if cycle apath : interior
- else : picpath
+ if cycle apath: interior
+ else: picpath
fi
- (apath scaled emax(sc, minpenwd))
+ (apath scaled emax (sc, minpenwd))
enddef;
vardef shaded (expr clr) expr c =
- if cycle c :
- save v; picture v;
- v := nullpicture;
+ if cycle c:
+ newpicture (v);
addto v contour c _wc_ clr;
v
- else: picpath c % should we? or just make it null?
+ else: picpath c % should we? or just make it null?
fi
enddef;
-vardef filledwith (expr pic, dims, ll, ur) =
- save b, v; picture b, v;
- b := v := nullpicture;
+vardef fillwith (suffix v) (expr pic, dims, ll, ur) =
+ newpicture (b);
for s = xpart ll step xpart dims until xpart ur:
addto b also pic shifted (s, 0);
endfor
for s = ypart ll step ypart dims until ypart ur:
addto v also b shifted (0, s);
endfor
- v
enddef;
-vardef thatchf (suffix v) (expr CT, sp, a, b) =
- save _sp;
- _sp = signof (ypart(b - a)) abs(sp);
- for _y = _sp*( ceiling ((ypart a)/_sp) ) step _sp until ypart b:
- shpath (v, hatchpen)
- ( ( (xpart a, _y)--(xpart b, _y) ) transformed CT );
- endfor
+def thatchf (suffix v) (expr CT, sp, a, b) =
+ begingroup
+ setnumeric (_sp) signof (ypart b - ypart a) abs(sp);
+ for _y = _sp*( ceiling ((ypart a)/_sp) ) step _sp until ypart b:
+ shpath (v, hatchpen)
+ ( ( (xpart a, _y)--(xpart b, _y) ) transformed CT );
+ endfor
+ endgroup
enddef;
def tile (suffix atile) (expr unit, width, height, clipit) =
- picture atile.pic; atile.pic := nullpicture;
- numeric atile.wd, atile.ht;
- (atile.wd, atile.ht) = (width, height)*unit;
- boolean atile.clipon; atile.clipon := clipit;
+ picture atile.pic; atile.pic := nullpicture;
+ pair atile.dims;
+ atile.dims := (width, height)*unit;
begingroup
save active_plane;
- def active_plane = atile.pic enddef;
- save ztr, vtr; transform ztr, vtr;
- ztr := identity scaled unit; vtr := ztr;
- save ClipOn; boolean ClipOn;
- if clipit :
+ def active_plane = atile.pic enddef;
+ save ztr, vtr; transform ztr, vtr;
+ ztr := identity scaled unit; vtr := ztr;
+ save xneg, xpos, yneg, ypos;
+ xneg := 0; xpos := width; yneg := 0; ypos := height;
+ save ClipOn; boolean ClipOn;
+ if clipit:
ClipOn := true;
- save ClipPath; path ClipPath[];
- ClipPath = 1;
- ClipPath[1] = rect(origin, (atile.wd, atile.ht));
+ setarray (path) (ClipPath) (rect(origin, atile.dims));
else:
ClipOn := false;
fi
@@ -865,88 +1067,173 @@ def endtile =
enddef;
vardef is_tile (suffix atile) =
- (known atile.pic ) and (picture atile.pic ) and
- (known atile.wd ) and (numeric atile.wd ) and
- (known atile.ht ) and (numeric atile.ht ) and
- (known atile.clipon) and (boolean atile.clipon)
+ (known atile.pic ) and (picture atile.pic) and
+ (known atile.dims) and (pair atile.dims )
enddef;
-vardef pnt@# (expr p) = point @# of p enddef;
-vardef pre@# (expr p) = precontrol @# of p enddef;
-vardef post@# (expr p) = postcontrol @# of p enddef;
+vardef pnt@# (expr p) = point @# of p enddef;
+vardef pre@# (expr p) = precontrol @# of p enddef;
+vardef post@# (expr p) = postcontrol @# of p enddef;
-vardef gbbox (expr g) (suffix ll, ur) =
- ll := llcorner g; ur := urcorner g;
- if showbbox : noclip ( safedraw rect (ll, ur) ); fi
+def getbbox (suffix ll, ur) expr g =
+ ll := llcorner g; ur := urcorner g;
+ if showbbox: noclip ( safedraw rect (ll, ur) ); fi
enddef;
-def safedraw = colorsafedraw (drawcolor) enddef;
-vardef colorsafedraw (expr clr) expr d =
- save v; picture v; v := picpath d;
- DoClip (v);
- coloraddto (clr) (active_plane, v);
+def safedraw = colorsafedraw (drawcolor) enddef;
+def colorsafedraw (expr clr) expr d =
+ begingroup
+ setpicture (v) picpath d;
+ DoClip (v); coloraddon (clr, v);
+ endgroup
enddef;
-def NoCycleWarn expr s =
- GBmsg s & " cannot be applied to an open path. "
- & "The path will be drawn instead.";
+def NoCycle (expr s) expr p =
+ GBwarn s & " cannot be applied to an open path."
+ & " The path will be drawn instead.";
+ safedraw p;
enddef;
-def safefill = colorsafefill (fillcolor) enddef;
+def safefill = colorsafefill (fillcolor) enddef;
vardef colorsafefill (expr clr) expr c =
- if cycle c :
- save v; picture v; v := interior c;
+ if cycle c:
+ setpicture (v) interior c;
DoClip (v);
- coloraddto (clr) (active_plane, v);
- else: NoCycleWarn "fill"; safedraw c;
+ coloraddon (clr, v);
+ else: NoCycle("fill") c;
fi
enddef;
def safeunfill expr c =
- if cycle c : noclip (colorsafefill (background) c);
- else: NoCycleWarn "unfill"; safedraw c;
+ if cycle c: noclip (colorsafefill (background) c);
+ else: NoCycle("unfill") c;
fi
enddef;
def safeclip expr c =
- if cycle c : clipto (active_plane) c;
- else: NoCycleWarn "clip"; safedraw c;
+ if cycle c: clipto (active_plane) c;
+ else: NoCycle("clip") c;
fi
enddef;
def store (suffix fs) expr f =
-hide(
- if (not path f) and (not pair f) :
- GBerrmsg ("Second argument to `store' must be a path or pair")
- "";
+hide (
+ if (not path f) and (not pair f):
+ GBerrmsg ("improper expression type.")
+ "The second argument to `store' must be a path or pair.";
fi
- if not path fs : path fs; fi
+ if not path fs: path fs; fi
fs := f
)
enddef;
-vardef stored (suffix fs) expr f = store (fs) f; f enddef;
+vardef stored (suffix fs) expr f = store (fs) f; f enddef;
-def drawn = colordrawn (drawcolor) enddef;
+def drawn = colordrawn (drawcolor) enddef;
vardef colordrawn (expr clr) expr f =
- colorsafedraw (clr) (zconv (f)); f
+ colorsafedraw (clr) (zconv (f)); f
+enddef;
+
+def zigzag = colorzigzag (drawcolor) enddef;
+def colorzigzag (expr clr) = colorwiggle (false, clr, 0) enddef;
+def sinewave = colorsinewave (drawcolor) enddef;
+def colorsinewave = colorwiggle (true) enddef;
+
+vardef colorwiggle (expr smth, clr, tens, blen, elen, len, wid) expr f =
+ convertpath (g) f;
+ setuplengtharray (cumlen, totlen, ct) g;
+ save B;
+ if cycle f:
+ B := 0;
+ else:
+ B := abs(blen)/_rescale_factor;
+ totlen := totlen - B - abs(elen)/_rescale_factor;
+ fi
+ setnumeric (n) 2*round (totlen/len*_rescale_factor);
+ if n < 2:
+ colorsafedraw (clr) g;
+ else:
+ save T, U, X, Y, Z, p;
+ pair U, X, Y, Z; path p;
+ T := if cycle f: 0 else: gettime (cumlen, ct) (B) fi;
+ Z := pnt[T] (g);
+ p :=if not cycle f: (subpath (0,T) of g)
+ if smth: {curl 0} ..tension tens.. else: -- fi
+ fi
+ for i = 1 upto n:
+ hide(
+ T := gettime (cumlen, ct) (B+(i/n)*totlen);
+ X := Z; Z := pnt[T] (g);
+ Y := .5[X,Z]; U := sgn (Z-X);
+ )
+ (Y + (U zscaled (0, if even i: - fi wid)))
+ if smth: {U}..tension tens.. else: -- fi
+ endfor
+ if cycle f: cycle
+ else: if smth: {curl 0} fi (subpath (T, length g) of g)
+ fi;
+ newpicture (v);
+ shpath (v, drawpen) (p);
+ DoClip(v); coloraddon (clr, v);
+ fi
+ f
enddef;
-def filled = colorfilled (fillcolor) enddef;
+def corkscrew = colorcorkscrew (drawcolor) enddef;
+vardef colorcorkscrew (expr clr, tens, blen, elen, len, wid) expr f =
+ convertpath (g) f;
+ setuplengtharray (cumlen, totlen, ct) g;
+ save B;
+ if cycle f:
+ B := 0;
+ else:
+ B := abs(blen)/_rescale_factor;
+ totlen := totlen - B - abs(elen)/_rescale_factor;
+ fi
+ setnumeric (n) round (totlen/len*_rescale_factor);
+ if n < 2:
+ colorsafedraw (clr) g;
+ else:
+ save T, U, X, Y, Z, p;
+ pair U, X, Y, Z; path p;
+ T := if cycle f: 0 else: gettime (cumlen, ct) (B) fi;
+ Z := pnt[T] (g);
+ p :=if (not cycle f) and (B > 0): (subpath (0,T) of g)-- fi
+ for i = 1 upto n:
+ hide(
+ T := gettime (cumlen, ct) (B+(i/n)*totlen);
+ X := Z; Z := pnt[T] (g);
+ Y := .5[X,Z]; U := sgn (Z-X);
+ )
+ (X + (U zscaled (0,-wid))){ U}..tension tens..
+ (Y + (U zscaled (0, wid))){-U}..tension tens..
+ endfor
+ if cycle f: cycle
+ else:
+ {U}(Z + (U zscaled (0,-wid)))
+ if elen <> 0: --(subpath(T, length g) of g) fi
+ fi;
+ newpicture (v);
+ shpath (v, drawpen) (p);
+ DoClip(v); coloraddon (clr, v);
+ fi
+ f
+enddef;
+
+def filled = colorfilled (fillcolor) enddef;
vardef colorfilled (expr clr) expr c =
- colorsafefill (clr) zconv (c); c
+ colorsafefill (clr) zconv (c); c
enddef;
-vardef unfilled expr c = safeunfill zconv (c); c enddef;
-vardef Clip expr c = safeclip zconv(c); c enddef;
+vardef unfilled expr c = safeunfill zconv (c); c enddef;
+vardef Clip expr c = safeclip zconv (c); c enddef;
-numeric shadewd; shadewd := 0.5bp;
+numeric shadewd; shadewd := 0.5bp;
path shadedotpath;
-shadedotpath := fullcircle; % unitsquare;
+shadedotpath := fullcircle;
vardef shade (expr sp) expr f =
- save g; path g; g := zconv (f);
- save gr; numeric gr;
- gr := 1 - (.88*abs(shadewd)/sp)**2;
- if not cycle g : NoCycleWarn "shade"; safedraw g;
- elseif gr <= 0 : safefill g;
+ convertpath (g) f;
+ setnumeric (gr) 1 - (.88*abs(shadewd)/sp)**2;
+ if not cycle g: NoCycle("shade") g;
+ elseif gr <= 0: safefill g;
else:
colorsafefill (gr*white) g;
fi
@@ -955,647 +1242,407 @@ enddef;
polkadotwd := 5bp;
mindotspace := 1bp;
-path polkadotpath; polkadotpath := fullcircle;
+path polkadotpath; polkadotpath := fullcircle;
vardef polkadot (expr sp) expr f =
- save g; path g; g := zconv (f);
- if not cycle g : NoCycleWarn "polkadot"; safedraw g;
- elseif sp <= emax (2*polkadotwd/3, mindotspace) :
+ convertpath (g) f;
+ if not cycle g: NoCycle("polkadot") g;
+ elseif sp <= emax (2*polkadotwd/3, mindotspace):
safefill g;
else:
- save ll, ur; pair ll, ur;
- gbbox (g, ll, ur);
- save dx, dy; dx := sp/2; dy := dx*(sqrt 3);
- hshift := ((xpart (ur - ll)) mod dx)/2;
- vshift := ((ypart (ur - ll)) mod dy)/2;
- save p, dims; pair p, dims;
- p := ll + (hshift, vshift);
+ setbbox (ll, ur) g;
+ save dx, dy, dshift; pair dshift;
+ dx := sp/2; dy := dx*sqrt 3;
+ dshift := (xpart(ur - ll) mod dx, ypart (ur - ll) mod dy)/2;
+ save p, dims; pair p, dims;
+ p := ll + dshift;
dims := 2(dx, dy);
- save v, thepolkadot; picture v, thepolkadot;
- thepolkadot := setdot (polkadotpath, polkadotwd);
- v := filledwith (thepolkadot, dims, p, ur);
- p := p + (dx, dy);
- orto (v, filledwith (thepolkadot, dims, p, ur));
- DoClip (v); clipto (v) g;
- coloraddto (fillcolor) (active_plane) (v);
+ setpicture (thepolkadot) setdot (polkadotpath, polkadotwd);
+ newpicture (v);
+ fillwith (v) (thepolkadot, dims, p, ur);
+ fillwith (v) (thepolkadot, dims, p + (dx, dy), ur);
+ DoClip (v); clipto (v) g;
+ coloraddon (fillcolor, v);
fi
f
enddef;
-def thatch = colorthatch (hatchcolor) enddef;
+def thatch = colorthatch (hatchcolor) enddef;
vardef colorthatch (expr clr) (expr sp, theta) expr f =
- save g; path g; g := zconv (f);
- if not cycle g : NoCycleWarn "hatch"; safedraw g;
- elseif sp <= abs(hatchwd) : colorsafefill (clr) g;
+ convertpath (g) f;
+ if not cycle g: NoCycle("hatch") g;
+ elseif sp <= abs(hatchwd): colorsafefill (clr) g;
else:
- save v; picture v; v := nullpicture;
- save CT; transform CT; CT := identity rotated theta;
- save ll, ur; pair ll, ur;
- gbbox (g transformed inverse CT, ll, ur);
- thatchf (v, CT, sp, ll, ur);
- DoClip(v);
- coloraddto (clr) (active_plane) (Clipped (v) g);
+ newpicture (v);
+ setbbox (ll, ur) g rotated -theta;
+ thatchf (v, identity rotated theta, sp, ll, ur);
+ DoClip (v); clipto (v) (g);
+ coloraddon (clr, v);
fi
f
enddef;
-def hhatch (expr sp) = thatch (sp, 0) enddef;
-def vhatch (expr sp) = thatch (sp, 90) enddef;
-def lhatch (expr sp) = thatch (sp, -45) enddef;
-def rhatch (expr sp) = thatch (sp, 45) enddef;
+def hhatch (expr sp) = thatch (sp, 0) enddef;
+def vhatch (expr sp) = thatch (sp, 90) enddef;
+def lhatch (expr sp) = thatch (sp, -45) enddef;
+def rhatch (expr sp) = thatch (sp, 45) enddef;
-def xhatch = colorxhatch (hatchcolor) enddef;
-vardef colorxhatch (expr clr, sp) expr f =
- colorthatch (clr) (sp, 45) colorthatch (clr) (sp, -45) f
+def xhatch = colorxhatch (hatchcolor) enddef;
+def colorxhatch (expr clr, sp) =
+ colorthatch (clr) (sp, 45) colorthatch (clr) (sp, -45)
enddef;
+vardef NoTile (suffix atile) expr g =
+ GBwarn str atile & " is not a valid tile for tess()."
+ & " The path will be drawn instead.";
+ safedraw g;
+enddef;
vardef tess (suffix atile) expr c =
- save _g; path _g; _g := zconv (c);
- if not is_tile (atile) :
- GBerrmsg ("Tile parameter " & str atile & " of tess() is invalid")
- "This tile may be undefined or incorrectly defined. " &
- "If you proceed, tess() will be abandoned and the curve " &
- "merely drawn."; safedraw _g;
- elseif not cycle _g : NoCycleWarn "tess"; safedraw _g;
+ convertpath (_g) c;
+ if not cycle _g: NoCycle("tess") _g;
+ elseif not is_tile (atile): NoTile (atile) _g;
else:
- save _ll, _ur; pair _ll, _ur;
- gbbox (_g, _ll, _ur);
- save _ts; picture _ts;
- _ts := filledwith (atile.pic, (atile.wd, atile.ht), _ll, _ur);
- DoClip (_ts);
- orto (active_plane, Clipped (_ts) _g);
+ setbbox (_ll, _ur) _g;
+ newpicture (_ts);
+ fillwith (_ts) (atile.pic, atile.dims, _ll, _ur);
+ DoClip (_ts); clipto (_ts) _g;
+ _orto (active_plane, _ts);
fi
c
enddef;
-if unknown segment_split : segment_split := 8; fi
-if unknown dashsize : dashsize := 3bp; fi
-if unknown dashgap : dashgap := dashsize + 2penwd; fi
-if unknown dash_finish : dash_finish := .5; fi
-if unknown dash_start : dash_start := .5; fi
-if unknown unit_of_length : unit_of_length := 0.1in; fi
+if unknown segment_split: segment_split := 8; fi
+if unknown dashsize: dashsize := 3bp; fi
+if unknown dashgap: dashgap := dashsize + 2penwd; fi
+if unknown dash_finish: dash_finish := .5; fi
+if unknown dash_start: dash_start := .5; fi
+if unknown _rescale_factor: _rescale_factor := 0.1in; fi
+numeric last_dot_size; last_dot_size := 0;
vardef gendashed (suffix pat) expr f =
- save _g; path _g; _g := zconv(f);
- if (unknown pat.rep) : % no "pattern"
- GBmsg "Dash pattern " & str pat & " undefined. " &
- "Path will be drawn instead.";
+ convertpath (_g) f;
+ save _dpat;
+ if not mkdasharrays (pat) (_dpat):
+ GBwarn "Dash pattern " & str pat
+ & " undefined. Path will be drawn instead.";
safedraw _g;
- elseif pat.rep < 2 : % no "spaces"
+ elseif _dpat.rep < 2:
safedraw _g;
else:
- save _dl, _tmppat;
- forsuffixes _s = start, rep, finish :
- _dl._s := 0; _tmppat._s := pat._s;
- for i = 1 upto pat._s :
- _tmppat._s[i] := pat._s[i]/unit_of_length;
- _dl._s := _dl._s + _tmppat._s[i];
+ save _dl;
+ forsuffixes _s = start, rep, finish:
+ _dl._s := 0;
+ for i = 1 upto _dpat._s:
+ _dpat._s[i] := _dpat._s[i]/_rescale_factor;
+ _dl._s := _dl._s + _dpat._s[i];
endfor
endfor
- if _dl.rep = 0 :
- GBmsg "Dash pattern " & str pat & " has length 0. " &
- "Path will be drawn instead.";
+
+ if _dl.rep = 0:
+ GBwarn "Dash pattern " & str pat & " has length 0. "
+ & "Path will be drawn instead.";
safedraw _g;
else:
- save _p; path _p;
- _p := _g scaled (1/unit_of_length);
- save _cumlen, _totlen, _n, _sf;
- _totlen := makelengtharray(_cumlen) _p;
- _sf := scale_adjust (_n, _dl)(_totlen);
- if _n < 0 : safedraw _g;
+ setuplengtharray (_cumlen, _totlen, _ct) _g;
+ save _n, _sf, _no_dots;
+ boolean _no_dots; _no_dots := true;
+ _sf := scale_adjust (_n, _dl) (_totlen);
+ if _n < 0: safedraw _g;
else:
- forsuffixes _s = start, rep, finish :
- for _i = 1 upto _tmppat._s :
- _tmppat._s[_i] := _tmppat._s[_i]*_sf;
+ forsuffixes _s = start, rep, finish:
+ for _i = 1 upto _dpat._s:
+ if (_dpat._s[_i] = 0) and _no_dots: _no_dots := false;
+ else: _dpat._s[_i] := _dpat._s[_i]*_sf;
+ fi
endfor
_dl._s := _dl._s*_sf;
endfor
- save dashingdot; picture dashingdot;
- if known plot_pic : dashingdot := makesymbol(plot_pic, penwd);
- else: dashingdot := makesymbol(dotpath, penwd);
+ if _no_dots:
+ else:
+ if unknown plot_pic:
+ save plot_pic; path plot_pic;
+ plot_pic := dotpath;
+ fi;
+ last_dot_size :=
+ if known plot_pic.size: plot_pic.size else: penwd fi;
+ setpicture (dashingdot) makesymbol (plot_pic, last_dot_size);
fi
- save _ct, _t, _d, _v;
- picture _v; _v := nullpicture;
- _ct := 0;
- % Begin with pat.start
- _d0 := 0; _t0 := 0;
- dashit (_tmppat.start) (_v);
- % then pat.rep
- if _n > 0 :
- save _m; _m := ceiling sqrt(_n);
- for _j = 0 step _m until _n - 1 :
- for _i = 0 upto _m - 1 :
+ save _t, _d, _v;
+ picture _v; _v := nullpicture;
+ _d0 := 0; _t0 := 0;
+ dashit (_dpat.start) (_v);
+
+ if _n > 0:
+ save _m; _m := ceiling sqrt(_n);
+ for _j = 0 step _m until _n - 1:
+ for _i = 0 upto _m - 1:
exitif (_i + _j) > _n - 1;
_d0 := _dl.start + (_j + _i)*_dl.rep;
- _t0 := gettime(_cumlen, _ct) (_d0);
- dashit (_tmppat.rep) (_v);
+ _t0 := gettime (_cumlen, _ct) (_d0);
+ dashit (_dpat.rep) (_v);
endfor
- % add _m patterns and reset.
- DoClip(_v);
- coloraddto (drawcolor) (active_plane, _v);
+ DoClip (_v);
+ coloraddon (drawcolor, _v);
_v := nullpicture;
endfor
fi
- % and finally, pat.finish
+
_d0 := _totlen - _dl.finish;
- _t0 := gettime(_cumlen, _ct) (_d0);
- dashit (_tmppat.finish) (_v);
- DoClip(_v);
- coloraddto (drawcolor) (active_plane, _v);
+ _t0 := gettime (_cumlen, _ct) (_d0);
+ dashit (_dpat.finish) (_v);
+ DoClip (_v);
+ coloraddon (drawcolor, _v);
fi
fi
fi
f
enddef;
-vardef makelengtharray (suffix clen) expr p =
- save _s; _s := emax (1, ceiling segment_split);
- clen := _s*length p; clen[0] := 0;
- for _i = 1 upto clen :
- clen[_i] := clen[_i-1] + abs (pnt[_i/_s] (p) - pnt[(_i-1)/_s] (p));
+vardef makelengtharray (suffix clen) suffix p =
+ setsplit (_s) segment_split;
+ numeric clen[];
+ clen := _s * length p; clen0 := 0;
+ for _i = 1 upto clen:
+ clen[_i] := clen[_i-1] + abs (pnt[_i/_s] (p) - pnt[(_i-1)/_s] (p)) /
+ _rescale_factor;
endfor
clen[clen]
enddef;
vardef scale_adjust (suffix n, pl) (expr lngth) =
n := (lngth - pl.start - pl.finish)/pl.rep;
- n := if n < 0 : -1 else: round(n) fi;
- lngth/(pl.start + emax(n, 0)*pl.rep + pl.finish)
+ n := if n < 0: -1 else: round(n) fi;
+ lngth/(pl.start + emax (n, 0)*pl.rep + pl.finish)
enddef;
vardef gettime (suffix arr, ct) (expr lngth) =
- save _gtl, _s;
- _s := emax(1, ceiling segment_split);
- _gtl := emax (arr[ct], emin (arr[arr], lngth));
- forever:
- exitif ( (arr[ct] <= _gtl) and (_gtl <= arr[ct+1]) );
- ct := ct + 1; % need to exit *before* incrementing
+ setnumeric (_gtl) emax (arr[ct], emin (arr[arr], lngth));
+ setsplit (_s) segment_split;
+ forever: exitif ( (arr[ct] <= _gtl) and (_gtl <= arr[ct+1]) );
+ next ct;
endfor
- if arr[ct] = arr[ct+1] : ct
- else: ( ct + (_gtl - arr[ct]) / (arr[ct+1] - arr[ct]) )
- fi /_s
+ if arr[ct] = arr[ct+1]: ct
+ else: ( ct + (_gtl - arr[ct]) / (arr[ct+1] - arr[ct]) )
+ fi /_s
enddef;
+def next suffix X = X := X + 1; enddef;
+
def dashit (suffix pos) (suffix pic) =
for _k = 1 upto pos:
- if odd _k : % draw a dash of length pos[_k]
- if pos[_k] = 0 : % point required
- _d1 := _d0; _t1 := _t0;
+ if odd _k:
+ if pos[_k] = 0:
+ _d1 := _d0; _t1 := _t0;
picdot (pic, dashingdot, pnt [_t0] (_g));
else:
_d1 := _d0 + pos[_k];
_t1 := gettime (_cumlen, _ct) (_d1);
shpath (pic, drawpen) (subpath (_t0, _t1) of _g);
fi
- else: % find the start of the next dash:
+ else:
_d0 := _d1 + pos[_k];
- _t0 := gettime(_cumlen, _ct) (_d0);
+ _t0 := gettime (_cumlen, _ct) (_d0);
fi
endfor
enddef;
def dashpat (suffix pat) (text t) =
- pat.rep := 0;
- for _itm = t:
- pat.rep[incr pat.rep] := _itm;
- endfor;
- if odd (pat.rep) and (pat.rep > 1):
- pat.rep[incr pat.rep] := 0;
- fi
- pat.start := 1;
- pat.start[1] := pat.rep[1]*dash_start;
- for _idx = 2 upto pat.rep :
- pat.start[incr pat.start] := pat.rep[_idx];
+ list (pat) (t);
+ if (pat = 0) or (odd (pat) and (pat > 1)):
+ pat[incr pat] := 0;
+ fi
+enddef;
+
+vardef mkdasharrays (suffix src, dest) =
+ save _bad; boolean _bad; _bad := false;
+ forsuffixes _s = start, rep, finish:
+ numeric dest._s, dest._s[];
+ boolean _bad._s;
+ if knownnumericarray src._s:
+ copyarray (src._s) (dest._s);
+ _bad._s := false;
+ else:
+ _bad := _bad._s := true;
+ fi
endfor
- pat.finish := 1;
- pat.finish[1] := pat.rep[1]*dash_finish;
+ % _bad = one of the three arrays not copied.
+ if _bad:
+ if knownnumericarray src: _bad := false;
+ if _bad.rep: % make dest.rep = src
+ copyarray (src) (dest.rep);
+ fi
+ if _bad.start: % shrink first dash to get dest.start
+ copyarray (src) (dest.start);
+ dest.start1 := dash_start*src1;
+ fi
+ if _bad.finish: % use partial first dash for dest.finish
+ dest.finish := 1;
+ dest.finish1 := dash_finish*src1;
+ fi
+ fi
+ fi
+ not _bad
enddef;
-vardef DASHED (expr dlen, dgap) expr f =
- save dashes; dashpat (dashes) (dlen, dgap);
+vardef Dashed (expr dlen, dgap) expr f =
+ save dashes; dashpat (dashes) (dlen, dgap);
gendashed (dashes) f
enddef;
-let dashed_ = dashed;
-def dashed = DASHED enddef;
+def DASHED = Dashed enddef;
vardef doplot (expr spath, sc, dgap) expr f =
- save dots; dashpat (dots) (0, dgap);
- save plot_pic; picture plot_pic;
- plot_pic := makesymbol (spath, sc);
+ save dots; dashpat (dots) (0, dgap);
+ setpicture (plot_pic) makesymbol (spath, sc);
+ plot_pic.size := sc;
gendashed (dots) f
enddef;
-path dotpath; dotpath := fullcircle;
-vardef dotted (expr dsize, dgap) expr f =
- doplot (dotpath, dsize, dgap) f
-enddef;
+path dotpath; dotpath := fullcircle;
+def dotted = doplot (dotpath) enddef;
vardef plotnodes (expr symbol, size) expr f =
- save _pln; pair _pln[];
- _pln := 0;
- for _a = 0 upto (length f) if cycle f : - 1 fi :
- _pln[incr _pln] := pnt[_a] (f);
- endfor
- dosymbols (drawcolor, symbol, size) (_pln);
- f
-enddef;
-
-vardef centerit (expr pic) =
- pic shifted -(0.5[urcorner pic, llcorner pic]);
-enddef;
-
-vardef makesymbol (expr spath, sc) =
- if path spath : setdot (spath, sc)
- elseif picture spath :
- spath
- elseif string spath :
- spath infont defaultfont scaled defaultscale
- else:
- GBmsg "Undefined symbol for plotting, using dotpath instead.";
- setdot (dotpath, sc)
+ if size > 0:
+ save pln; pair pln[];
+ pln := 0;
+ for _a = 0 upto (length f) if cycle f: - 1 fi:
+ pln[incr pln] := pnt[_a] (f);
+ endfor
+ dosymbols (drawcolor, symbol, size) (pln);
fi
+ f
enddef;
-path Triangle, Square, Circle, Diamond, Star, Plus, Cross,
- Asterisk, SolidTriangle, SolidSquare, SolidCircle,
- SolidDiamond, SolidStar;
-
-Triangle := (for n = 0 upto 2:
- (up rotated 120n)-- endfor up) scaled .78;
-SolidTriangle := Triangle & cycle;
-
-Square := (for n = 0 upto 3:
- dir (90n + 45)-- endfor dir 45) scaled .63;
-SolidSquare := Square & cycle;
-
-Circle := halfcircle & halfcircle rotated 180;
-SolidCircle := Circle & cycle;
-
-Diamond := (Square rotated 45) xscaled (1/1.2) yscaled 1.2;
-SolidDiamond := Diamond & cycle;
-
-Plus := (origin for n = 0 upto 3:
- --(up rotated 90n)--origin endfor) scaled .65;
-Cross := Plus rotated 45;
-Asterisk := (origin for n = 0 upto 5:
- --(up rotated 60n)--origin endfor) scaled .6;
-
-pair zz;
-zz = (whatever)[up, up rotated 144];
-zz = (whatever)[up rotated 72, up rotated -72];
-Star := (for n = 0 upto 4:
- (up rotated 72n)--(zz rotated 72n)-- endfor up) scaled .84;
-SolidStar := Star & cycle;
-save zz;
-
-numeric dashtype;
-forsuffixes s = start, rep, finish :
- numeric dashtype[].s, dashtype[].s[];
-endfor
-def defaultdashes =
- dashpat (dashtype0) (0); % solid
- dashpat (dashtype1) (3bp, 4bp); % dashed
- dashpat (dashtype2) (0, 4bp); % dotted
- dashpat (dashtype3) (0, 4bp, 3bp, 4bp); % dot-dash
- dashpat (dashtype4) (0, 4bp, 3bp, 4bp, 0, 4bp);% dot-dash-dot
- dashpat (dashtype5) (0, 4bp, 3bp, 4bp, 3bp, 4bp);% dot-dash-dash
- dashtype := 6;
-enddef;
-defaultdashes;
-
-vardef isdashpat suffix pat =
- (knownarray pat.start) and
- (knownarray pat.finish) and
- (knownarray pat.rep)
-enddef;
-
-def setdatadashes (text lst) =
- save dashtype; dashtype := 0;
- forsuffixes _itm = lst :
- if isdashpat _itm :
- forsuffixes _s = start, rep, finish :
- copyarray (_itm._s, dashtype[dashtype]._s);
- endfor
- dashtype := dashtype + 1;
- else: GBmsg "Improper dash pattern in setdatadashes.";
- fi
+def showcontrols = colorshowcontrols (pointcolor) enddef;
+vardef colorshowcontrols (expr clr, syma, symb, size) expr f =
+ save shpre, shpost;
+ pair shpre[], shpost[];
+ shpre := 0; shpost := 0;
+ for a = 0 upto (length f) if cycle f: - 1 fi:
+ shpre [incr shpre] := pre [a] (f);
+ shpost[incr shpost] := post[a] (f);
+ colorsafedraw (clr)
+ (zconv (shpre[shpre]--pnt[a](f)--shpost[shpost]));
endfor
- if dashtype = 0 :
- SetdataWarn "dashes";
- defaultdashes;
+ if size > 0:
+ if not numeric syma: dosymbols (clr, syma, size) (shpre) ; fi
+ if not numeric symb: dosymbols (clr, symb, size) (shpost); fi
fi
-enddef;
-def getdashpat expr n = dashtype[n mod dashtype] enddef;
-
-def SetdataWarn expr s =
- GBmsg "Command setdata"& s &"() failed; using defaults."
+ f
enddef;
-def setdatasymbols (text lst) =
- save pointtype; path pointtype[]; pointtype := 0;
- for _itm = lst :
- if (known _itm) and (path _itm):
- pointtype[pointtype] := _itm;
- pointtype := pointtype + 1;
- else:
- GBmsg "Improper path in setdatasymbols().";
- fi
- endfor
- if pointtype = 0:
- SetdataWarn "symbols";
- defaultsymbols;
- fi
+def doubledraw = colordoubledraw (drawcolor) enddef;
+vardef colordoubledraw (expr clr, sep) expr f =
+ convertpath (g) f;
+ colorsafedraw (clr) (parapath ( sep/2) g);
+ colorsafedraw (clr) (parapath (-sep/2) g);
+ f
enddef;
-def getsymbol expr n := pointtype[n mod pointtype] enddef;
-numeric pointtype; path pointtype[];
-def defaultsymbols =
- pointtype0 := Circle;
- pointtype1 := Cross;
- pointtype2 := SolidDiamond;
- pointtype3 := Square;
- pointtype4 := Plus;
- pointtype5 := Triangle;
- pointtype6 := SolidCircle;
- pointtype7 := Star;
- pointtype8 := SolidTriangle;
- pointtype := 9;
+vardef centerit (expr pic) =
+ pic shifted -(0.5[urcorner pic, llcorner pic])
enddef;
-defaultsymbols;
-def setdatacolors (text lst) =
- save colortype; color colortype[]; colortype := 0;
- for _itm = lst :
- if (known _itm) and (color _itm) :
- colortype[colortype] := _itm;
- colortype := colortype + 1;
- else: GBmsg "Improper color in setdatacolors().";
- fi
- endfor
- if colortype = 0 :
- SetdataWarm "colors";
- defaultcolors;
+vardef makesymbol (expr spath, sc) =
+ if picture spath :
+ spath
+ elseif path spath: setdot (spath, sc)
+ elseif string spath:
+ spath infont defaultfont scaled defaultscale
+ else:
+ GBwarn "Undefined symbol for plotting, "
+ & "dotpath will be used instead.";
+ setdot (dotpath, sc)
fi
enddef;
-def getcolor expr n = colortype[n mod colortype] enddef;
-
-numeric colortype; color colortype[];
-def defaultcolors =
- colortype0 := black;
- colortype1 := red;
- colortype2 := 0.80blue + .2white; % blue
- colortype3 := 0.66yellow + .34red; % orange
- colortype4 := 0.80green; % green
- colortype5 := 0.85magenta; % magenta
- colortype6 := 0.85cyan; % cyan
- colortype7 := 0.85yellow; % yellow
- colortype := 8;
-enddef;
-defaultcolors;
vardef bpoint (expr ptwd, b) =
fullcircle scaled ptwd shifted b
enddef;
+
def pointd (expr ptwd, filled) (text t) =
- if filled :
+ if filled:
plotsymbol (SolidCircle, ptwd) (t);
- else :
+ else:
begingroup;
- save clearsymbols; boolean clearsymbols; clearsymbols := true;
+ setboolean (clearsymbols) true;
plotsymbol (Circle, ptwd) (t);
endgroup
fi
enddef;
-boolean clearsymbols; clearsymbols := false;
+boolean clearsymbols; clearsymbols := false;
vardef clearable (expr pth) =
- false
- if path pth :
- if (not cycle pth) and (length pth > 0):
- if ( pnt0 (pth) = pnt[length pth] (pth) ) :
- or true
- fi fi fi
-enddef;
-
-def plotsymbol = colorplotsymbol (pointcolor) enddef;
-vardef colorplotsymbol (expr clr, spath, sc) (text t) =
- save _cpls;
- textpairs (_cpls) (t);
- dosymbols (clr, spath, sc) (_cpls);
-enddef;
-
-vardef dosymbols (expr clr, spath, sc) (suffix arr) =
- save one_symbol, _pls; picture one_symbol, _pls;
- if clearsymbols and clearable (spath):
- addsymbols (background, spath&cycle, sc) (arr);
+ if path pth:
+ ( pnt0 (pth) = pnt[length pth] (pth) ) and (not cycle pth)
+ and (length pth > 0)
+ else: false
fi
- addsymbols (clr, spath, sc) (arr);
enddef;
-def addsymbols (expr clr, spath, sc) (suffix arr) =
- one_symbol := makesymbol (spath, sc);
- _pls := nullpicture;
- for _idx = 1 upto arr:
- picdot (_pls, one_symbol, zconv(arr[_idx]));
- endfor
- DoClip (_pls);
- coloraddto (clr) (active_plane) (_pls);
-enddef;
-
-vardef lclosed expr f = f if not cycle f : --cycle fi enddef;
-
-numeric default_tension;
-default_tension := 1;
-
-def sclosed = sclosedt (default_tension) enddef;
-vardef sclosedt (expr t) expr f =
- if cycle f : f
- else: save n; n := length f;
- if n = 0 : f&cycle
- elseif n = 1 : f..tension t..cycle
- else :
- (pnt0 (f)) { (pnt1(f)) - (pnt[n] (f)) }..tension t
- ..(subpath (1, n-1) of f)..tension t
- ..(pnt[n](f)) { pnt0(f) - pnt[n-1](f) }
- ..tension t..cycle
- fi
- fi
+def clearopenpath expr f =
+ if clearable (f): safeunfill f & cycle; fi
enddef;
-def bclosed = bclosedt (default_tension) enddef;
-vardef bclosedt (expr t) expr f =
- f if not cycle f : ..tension t..cycle fi
-enddef;
-
-def uclosed = bclosed enddef;
-
-def bsplinecontrols (suffix b) expr f =
- b := 4;
- b1 := 2[pre 1(f), post0(f)];
- b2 := 2[post0(f), pnt 0(f)];
- b3 := 2[b1, b2];
- b4 := 2[b2, b3];
-enddef;
-
-vardef cbclosed expr f =
- if cycle f : f
- elseif (length f)=0 : f&cycle
- else:
- save p, q; pair p[], q[];
- bsplinecontrols (p) f; % defines p1 to p4
- bsplinecontrols (q) reverse f; % defines q1 to q4
- f..controls q2 and q3..opencbs (q1,q4,p4,p1)
- ..controls p3 and p2..cycle
+def plotsymbol = colorplotsymbol (pointcolor) enddef;
+def colorplotsymbol (expr clr, spath, sc) (text t) =
+ if sc > 0:
+ begingroup
+ setpairs (_cpls) (t);
+ if _cpls > 0: dosymbols (clr, spath, sc) (_cpls); fi
+ endgroup
fi
enddef;
-vardef qbclosed expr f =
- if cycle f : f
- else: save n; n := length f;
- if n = 0 : f&cycle
- else:
- save p; pair p[]; p := 4;
- p1 := (3/2)[pnt[n](f), pre[n](f)];
- p2 := 2[p1, pnt[n](f)];
- p4 := (3/2)[pnt 0 (f), post0 (f)];
- p3 := 2[p4, pnt 0 (f)];
- f & mkqbs (p) & cycle
- fi
+def dosymbols (expr clr, spath, sc) (suffix arr) =
+ if clearsymbols and clearable (spath):
+ addsymbols (background, makesymbol (spath&cycle, sc)) (arr);
fi
+ addsymbols (clr, makesymbol (spath, sc)) (arr);
enddef;
-vardef makesector expr p =
- (pathcenter p)--p--cycle
-enddef;
-
-vardef cutoffbefore (expr b) expr f =
- save w, t, u, n; n:= length f;
- pair w;
- for k = 1 upto n :
- w := (subpath (0,k) of f) intersectiontimes b;
- exitif w > left;
+def addsymbols (expr clr, symb) (suffix arr) =
+ newpicture (_pls);
+ for _idx = 1 upto arr:
+ picdot (_pls, symb, zconv (arr[_idx]));
endfor
- if debug :
- GBdebug;
- >> "Intersectiontimes:";
- show w;
- GBenddebug;
- fi
- t := xpart w;
- if t < 0:
- cuttings := pnt0 (f);
- f
- else:
- cuttings := subpath (0,t) of f;
- subpath (t, n) of f
- fi
+ DoClip (_pls); coloraddon (clr, _pls);
enddef;
-vardef cutoffafter (expr b) expr f =
- save g; path g;
- g := cutoffbefore (b) reverse f;
- cuttings := reverse cuttings;
- reverse g
-enddef;
-
-vardef trimmedpath (expr btrim, etrim) expr f =
- save g, h; path g, h;
- g := invvconv (fullcircle scaled 2btrim) shifted pnt0(f);
- h := invvconv (fullcircle scaled 2etrim) shifted pnt[length f] (f);
- cutoffafter (h) cutoffbefore (g) f
-enddef;
-
-vardef predirection@# (expr p) =
- - postdirection[length p - @#] (reverse p)
-enddef;
-
-vardef postdirection@# (expr p) =
- save _n; _n := length (p);
- save v; pair v; v := __dir (subpath (@#, @# + _n) of p);
- if v = origin :
- v := - __dir (subpath (@#, @# - _n) of p);
- fi
- v
-enddef;
-
-vardef __dir (expr p) =
- save v, w; pair v, w; w := pnt0 (p);
- v := origin;
- for n = 1 upto length (p) :
- v := post[n-1] (p) - w;
- if v = origin :
- v := pre[n] (p) - w;
- if v = origin :
- v := pnt[n] (p) - w;
- fi
- fi
- exitif v <> origin;
+def putimage (suffix pic) (text t) =
+ newpicture (_pti);
+ for _itm = t:
+ addto _pti also
+ (pic shifted zconv (_itm));
+ DoClip (_pti); addto active_plane also _pti;
+ _pti := nullpicture;
endfor
- v
enddef;
-newinternal hdwdr, hdten;
-interim hdwdr := 1; interim hdten := 1;
-boolean hfilled; hfilled := false;
-
-def headshape (expr wr, tens, fil) =
- interim hdwdr := wr; interim hdten := tens;
- save hfilled; boolean hfilled; hfilled := fil;
+def arrowdraw (expr hlen) (expr f) =
+ store (curpath) headpath (hlen, 0, 0) drawn f;
enddef;
-def head = ahead enddef;
-
-vardef ahead (expr clr, front, back, hwr, tens, filled) =
- if front <> back :
- save side; pair side;
- side := (hwr/2) * ((front-back) rotated 90);
- save f; path f;
- f := (back + side)..tension tens..
- {front-back}front{back-front}..tension tens..
- (back - side)
- if filled : --cycle; colorsafefill (clr) f fi;
- colorsafedraw (clr) f;
- fi
+def xaxis (expr hlen) = arrowdraw (hlen) ((xneg, 0)--(xpos, 0));
enddef;
-
-def headpath = colorheadpath (headcolor) enddef;
-vardef colorheadpath (expr clr, hlen, hrot, hback) expr f =
- if hlen <> 0 :
- save g; path g; g := zconv (f);
- save P; pair P[];
- P2 := pnt[length g] (g);
- P1 := predirection[length g] (g);
- if P1 <> (0, 0) :
- P3 := (unitvector P1) rotated hrot;
- P4 := P2 - (hback * P3);
- P5 := P4 - (hlen * P3);
- ahead (clr, P4, P5, hdwdr, hdten, hfilled);
- fi
- fi
- f
+def yaxis (expr hlen) = arrowdraw (hlen) ((0, yneg)--(0, ypos));
enddef;
+def axes (expr hlen) = xaxis (hlen); yaxis (hlen); enddef;
-def arrowdraw (expr hlen) (expr f) =
- store (curpath) headpath (hlen, 0, 0) drawn f;
-enddef;
+laxis := baxis := raxis := taxis := 0;
-def xaxis (expr hlen) = arrowdraw (hlen) ((xneg, 0)--(xpos, 0)); enddef;
-def yaxis (expr hlen) = arrowdraw (hlen) ((0, yneg)--(0, ypos)); enddef;
-def axes (expr hlen) = xaxis (hlen); yaxis (hlen); enddef;
+vardef axisline.x = (xneg + laxis, 0)--(xpos - raxis, 0) enddef;
+vardef axisline.y = (0, yneg + baxis)--(0, ypos - taxis) enddef;
+vardef axisline.l = axisline.y shifted (xneg + laxis, 0) enddef;
+vardef axisline.b = axisline.x shifted (0, yneg + baxis) enddef;
+vardef axisline.r = axisline.y shifted (xpos - raxis, 0) enddef;
+vardef axisline.t = axisline.x shifted (0, ypos - taxis) enddef;
-laxis := baxis := raxis := taxis := 0;
+vardef axis@# (expr len) = headpath (len, 0, 0) axisline@# enddef;
-vardef axisline.x = (xneg + laxis, 0)--(xpos - raxis, 0) enddef;
-vardef axisline.y = (0, yneg + baxis)--(0, ypos - taxis) enddef;
-vardef axisline.l = axisline.y shifted (xneg + laxis, 0) enddef;
-vardef axisline.b = axisline.x shifted (0, yneg + baxis) enddef;
-vardef axisline.r = axisline.y shifted (xpos - raxis, 0) enddef;
-vardef axisline.t = axisline.x shifted (0, ypos - taxis) enddef;
-vardef axis@# (expr len) =
- headpath (len, 0, 0) axisline@#
+vardef borderrect =
+ rect((xneg+laxis,yneg+baxis),(xpos-raxis,ypos-taxis))
enddef;
-
numeric inside, outside, centered, onleft, onright, ontop, onbottom;
inside := -2;
outside := -1;
@@ -1609,63 +1656,97 @@ xtick := ytick := centered;
vardef axismarks (expr inang, tp, loc, pdir) (expr len) (text t) =
save _tp, _U, _P, _tic, _ticang;
- pair _U, _P, _tic[];
- _ticang := if tp<0 : inang else: 90 fi;
+ pair _U, _P; path _tic;
+ _ticang := if tp < 0: inang else: 90 fi;
_tp := abs(tp) - 1;
_U := unitvector (vconv (pdir)) rotated _ticang;
- _tic1 := (_tp - 1) * len * _U; % start of mark
- _tic2 := _tp * len * _U; % end of mark
+ _tic := (-_U--(0,0)) shifted (_tp*_U) scaled len;
for _a = t:
- safedraw ((_tic1--_tic2) shifted zconv (loc + _a*pdir));
+ safedraw (_tic shifted zconv (loc + _a*pdir));
endfor
enddef;
-def xmarks = axismarks ( 90, xtick, (0, 0), right) enddef;
-def ymarks = axismarks (-90, ytick, (0, 0), up) enddef;
+def xmarks = axismarks ( 90, xtick, origin, right) enddef;
+def ymarks = axismarks (-90, ytick, origin, up) enddef;
def lmarks = axismarks (-90, ltick, (xneg + laxis, 0), up) enddef;
-def bmarks = axismarks ( 90, btick, (0, yneg + baxis), right) enddef;
+def bmarks = axismarks ( 90, btick, (0, yneg + baxis), right) enddef;
def rmarks = axismarks ( 90, rtick, (xpos - raxis, 0), up) enddef;
-def tmarks = axismarks (-90, ttick, (0, ypos - taxis), right) enddef;
+def tmarks = axismarks (-90, ttick, (0, ypos - taxis), right) enddef;
-path griddotpath; griddotpath := fullcircle;
-def grid = vgrid (0.5bp) enddef;
-vardef vgrid (expr dsize, xspace, yspace) =
- save gdot, gridpic; picture gdot, gridpic;
+path griddotpath; griddotpath := fullcircle;
+def grid = vargrid (0.5bp) enddef;
+vardef vargrid (expr dsize, xsp, ysp) =
+ save gdot, gridpic; picture gdot, gridpic;
gdot := setdot (griddotpath, dsize);
gridpic := nullpicture;
- for n = ceiling(xneg/xspace) upto floor(xpos/xspace):
- for m = ceiling(yneg/yspace) upto floor(ypos/yspace):
- picdot (gridpic, gdot, zconv((n*xspace, m*yspace)));
+ for n = ceiling ((xneg + laxis)/xsp) upto floor ((xpos - raxis)/xsp):
+ for m = ceiling ((yneg + baxis)/ysp) upto floor ((ypos - taxis)/ysp):
+ picdot (gridpic, gdot, zconv ((n*xsp, m*ysp)));
endfor
endfor
- coloraddto (pointcolor) (active_plane) (gridpic);
+ coloraddon (pointcolor, gridpic);
enddef;
+def vgrid = vargrid enddef;
def hgridlines (expr ysp) =
- for n = ceiling((yneg + baxis)/ysp) upto floor((ypos - taxis)/ysp) :
- safedraw zconv((xneg + laxis, n*ysp)--(xpos - raxis, n*ysp));
+ for n = ceiling ((yneg + baxis)/ysp) upto floor ((ypos - taxis)/ysp):
+ safedraw zconv ((xneg + laxis, n*ysp)--(xpos - raxis, n*ysp));
endfor
enddef;
def vgridlines (expr xsp) =
- for n = ceiling((xneg + laxis)/xsp) upto floor((xpos - raxis)/xsp) :
- safedraw zconv((n*xsp, yneg + baxis)--(n*xsp, ypos - taxis));
+ for n = ceiling ((xneg + laxis)/xsp) upto floor ((xpos - raxis)/xsp):
+ safedraw zconv ((n*xsp, yneg + baxis)--(n*xsp, ypos - taxis));
endfor
enddef;
def gridlines (expr xsp, ysp) =
- vgridlines (xsp); hgridlines (ysp);
+ vgridlines (xsp); hgridlines (ysp);
enddef;
-vardef plrpatch (expr rstart, rstop, rstep, tstart, tstop, tstep) =
- save v; picture v; v := nullpicture;
- patcharcs (v) (rstart, rstop, rstep, tstart, tstop);
- coloraddto (drawcolor) (active_plane, v);
- v := nullpicture;
- patchrays (v) (tstart, tstop, tstep, rstart, rstop);
- coloraddto (drawcolor) (active_plane, v);
+def vectorfield (expr len, xsp, ysp) (text fcn) (text cond) =
+ save _vf, _is_OK;
+ vardef _vf (expr x,y) = ((0,0)--(fcn)) shifted (x,y) enddef;
+ vardef _is_OK (expr x,y) = cond enddef;
+ mkvectorfield (len, xsp, ysp) (_vf, _is_OK);
enddef;
+
+vardef mkvectorfield (expr len, xsp, ysp) (suffix vf, isOK) =
+ for n = ceiling ((xneg + laxis)/xsp) upto floor ((xpos - raxis)/xsp):
+ for m = ceiling ((yneg + baxis)/ysp) upto floor ((ypos - taxis)/ysp):
+ if isOK (n*xsp,m*ysp): arrowdraw (len) (vf(n*xsp,m*ysp)); fi
+ endfor
+ endfor
+enddef;
+
+def plrvectorfield (expr len, rsp, tsp) (text fcn) (text cond) =
+ save _vf, _is_OK, _A, _B, _C, _D;
+ _A := xneg + laxis; _B := xpos + raxis;
+ _C := yneg + baxis; _D := ypos + taxis;
+ vardef _vf (expr r,t) = ((0,0)--(fcn)) shifted (r*dir t) enddef;
+ vardef _is_OK (expr r,t) =
+ save _X, _Y; _X := r*cosd t; _Y := r*sind t;
+ (cond) and (_A < _X) and (_X < _B) and (_C < _Y) and (_Y < _D)
+ enddef;
+ mkplrvectorfield (len, rsp, tsp) (_vf, _is_OK);
+enddef;
+
+vardef mkplrvectorfield (expr len, rsp, tsp) (suffix vf, isOK) =
+ save rmin, rmax, tmin, tmax;
+ getpolarbounds;
+ if rmin = 0:
+ if isOK (0,tmin): arrowdraw (len) (vf (0,tmin)); fi
+ rmin := rsp;
+ fi
+ for n = ceiling (rmin/rsp) upto floor (rmax/rsp):
+ for m = ceiling (tmin/tsp) upto floor (tmax/tsp):
+ if isOK (n*rsp,m*tsp): arrowdraw (len) (vf (n*rsp,m*tsp)); fi
+ endfor
+ endfor
+enddef;
+
def patcharcs (suffix X) (expr rstart, rstop, rstep, tstart, tstop) =
- for rad = (if rstart=0: rstep else: rstart fi) step rstep until rstop:
- orto (X, picpath zconv (arcplr ((0, 0), tstart, tstop, rad)) );
+ for rad = (if rstart = 0: rstep else: rstart fi)
+ step rstep until rstop:
+ orto (X, picpath zconv (arcplr (origin, tstart, tstop, rad)) );
endfor
enddef;
def patchrays (suffix X) (expr tstart, tstop, tstep, rstart, rstop) =
@@ -1674,116 +1755,130 @@ def patchrays (suffix X) (expr tstart, tstop, tstep, rstart, rstop) =
endfor
enddef;
-def polargrid (expr rstep, tstep) =
- gridarcs (rstep); gridrays (tstep);
-enddef;
-
-def polargridpoints (expr dsize, rstep, tstep) =
- beginpolargrid;
- save gdot; picture gdot; gdot := setdot (griddotpath, dsize);
- if rmin = 0:
- picdot (gridpic, gdot, zconv(origin));
- rmin := rstep;
- fi
- for n = ceiling (rmin/rstep) upto floor (rmax/rstep) :
- for m = ceiling (tmin/tstep) upto floor (tmax/tstep) :
- picdot ( gridpic, gdot, zconv ( polar((n*rstep, m*tstep)) ) );
- endfor
- endfor
- endpolargrid (pointcolor, .5dsize);
+def plrpatch (expr rstart, rstop, rstep, tstart, tstop, tstep) =
+begingroup
+ newpicture (v);
+ patcharcs (v) (rstart, rstop, rstep, tstart, tstop);
+ coloraddon (drawcolor, v);
+ v := nullpicture;
+ patchrays (v) (tstart, tstop, tstep, rstart, rstop);
+ coloraddon (drawcolor, v);
+endgroup
enddef;
def gridarcs (expr rstep) =
beginpolargrid;
- if rmin = 0 : % add "circle" of radius 0
- picdot (gridpic, setdot(griddotpath, penwd), zconv(origin));
+ if rmin = 0:
+ picdot (gridpic, setdot (griddotpath, penwd), zconv (origin));
fi
- rmin := rstep * floor(rmin/rstep + 1);
- rmax := rstep*ceiling(rmax/rstep - 1);
+ rmin := rstep * floor (rmin/rstep + 1);
+ rmax := rstep * ceiling (rmax/rstep - 1);
patcharcs (gridpic) (rmin, rmax, rstep, tmin, tmax);
endpolargrid (drawcolor, .5penwd);
enddef;
def gridrays (expr tstep) =
beginpolargrid;
- tmin := tstep*ceiling(tmin/tstep);
- tmax := tstep * floor(tmax/tstep);
+ tmin := tstep * ceiling (tmin/tstep);
+ tmax := tstep * floor (tmax/tstep);
patchrays (gridpic) (tmin, tmax, tstep, rmin, rmax);
endpolargrid (drawcolor, .5penwd);
enddef;
+def polargrid (expr rstep, tstep) =
+ gridarcs (rstep); gridrays (tstep);
+enddef;
+
+def polargridpoints (expr dsize, rstep, tstep) =
+ beginpolargrid;
+ setpicture (gdot) setdot (griddotpath, dsize);
+ if rmin = 0:
+ picdot (gridpic, gdot, zconv (origin));
+ rmin := rstep;
+ fi
+ for n = ceiling (rmin/rstep) upto floor (rmax/rstep):
+ for m = ceiling (tmin/tstep) upto floor (tmax/tstep):
+ picdot ( gridpic, gdot, zconv ( polar ((n*rstep, m*tstep)) ) );
+ endfor
+ endfor
+ endpolargrid (pointcolor, .5dsize);
+enddef;
+
def beginpolargrid =
- begingroup;
- save p, r, t, rmax, rmin, tmax, tmin;
+begingroup;
+ save rmax, rmin, tmax, tmin;
+ getpolarbounds;
+ newpicture (gridpic);
+enddef;
+
+def getpolarbounds =
+ save p, r, t;
pair p[];
- % Four corners:
- p0 := (xneg, yneg); p1 := (xneg, ypos);
- p2 := (xpos, ypos); p3 := (xpos, yneg);
- r0 := abs(p0); rmax := r0;
- for j = 1 upto 3 :
+ p0 := (xneg, yneg); p1 := (xneg, ypos);
+ p2 := (xpos, ypos); p3 := (xpos, yneg);
+ r0 := abs(p0); rmax := r0;
+ for j = 1 upto 3:
r[j] := abs(p[j]);
- if rmax < r[j] : rmax := r[j]; fi
+ if rmax < r[j]: rmax := r[j]; fi
endfor
rmin := 0;
- if (xneg < 0) and (xpos > 0) and (yneg < 0) and (ypos > 0) :
- tmin := 0; tmax := 360;
- elseif (p0 = (0,0)) : tmin := 0; tmax := 90;
- elseif (p1 = (0,0)) : tmin := -90; tmax := 0;
- elseif (p2 = (0,0)) : tmin := -180; tmax := -90;
- elseif (p3 = (0,0)) : tmin := 90; tmax := 180;
- else :
+ if (xneg < 0) and (xpos > 0) and (yneg < 0) and (ypos > 0):
+ tmin := 0; tmax := 360;
+ elseif (p0 = origin): tmin := 0; tmax := 90;
+ elseif (p1 = origin): tmin := -90; tmax := 0;
+ elseif (p2 = origin): tmin := -180; tmax := -90;
+ elseif (p3 = origin): tmin := 90; tmax := 180;
+ else:
tmax := tmin := t0 := angle p0;
for j = 1 upto 3:
- t := t0 + angle (p[j] rotated -t0);
- if tmax < t : tmax := t; fi
- if tmin > t : tmin := t; fi
+ t := t0 + anglefromto (p0, p[j]);
+ if tmax < t: tmax := t; fi
+ if tmin > t: tmin := t; fi
endfor
- if (xneg < 0) and (xpos > 0) : % (1)
- rmin := emin(abs(yneg), abs(ypos));
- elseif (yneg < 0) and (ypos > 0) : % (2)
- rmin := emin(abs(xneg), abs(xpos));
- else : % (3)
- rmin := min(r0, r1, r2, r3);
+ if (xneg < 0) and (0 < xpos):
+ rmin := emin (abs(yneg), abs(ypos));
+ elseif (yneg < 0) and (0 < ypos):
+ rmin := emin (abs(xneg), abs(xpos));
+ else:
+ rmin := min (r0, r1, r2, r3);
fi
fi
- save gridpic; picture gridpic; gridpic := nullpicture;
enddef;
def endpolargrid (expr clr, size)=
- clipto (gridpic) rect ( zconv((xneg, yneg)) - size*(1,1),
- zconv((xpos, ypos)) + size*(1,1) );
- coloraddto (clr) (active_plane) (gridpic);
+ clipto (gridpic) rect ( zconv ((xneg, yneg)) - size*(1,1),
+ zconv ((xpos, ypos)) + size*(1,1) );
+ coloraddon (clr, gridpic);
endgroup
enddef;
vardef polarpatch (expr rstart, rstop, rstep, tstart, tstop, tstep) =
plrpatch (rstart, rstop, rstep, tstart, tstop, tstep);
- safedraw zconv ( arcplr ((0, 0), tstart, tstop, rstop) );
+ safedraw zconv ( arcplr (origin, tstart, tstop, rstop) );
safedraw zconv ( ((rstart, 0)--(rstop, 0)) rotated tstop );
enddef;
vardef rect (expr ll, ur) =
ll--(xpart ur, ypart ll)--ur--(xpart ll, ypart ur)--cycle
enddef;
-vardef triangle (expr A, B, C) = A--B--C--cycle enddef;
+vardef triangle (expr A, B, C) = A--B--C--cycle enddef;
vardef regularpolygon (expr n) (suffix Bob) (text eqns) =
- pair Bob[]; Bob := emax(round (abs (n)), 2);
+ pair Bob[]; Bob := emax (round (abs (n)), 2);
eqns;
- for _uncle = 1 upto Bob - 1 :
- (Bob1 - Bob0) rotated (360*_uncle/Bob) = Bob[_uncle+1] - Bob0;
+ for _uncle = 1 upto Bob - 1:
+ (Bob1 - Bob0) rotated (360/Bob*_uncle) = Bob[_uncle+1] - Bob0;
endfor
mkpoly (true) (Bob)
enddef;
vardef altitudept expr n of t =
- save A, B, C, zz; pair A, B, C, zz;
- A := pnt[n] (t);
- B := pnt[n + 1] (t); % wraps around a cyclic path
+ save A, B, C, zz; pair A, B, C, zz;
+ B := pnt[n + 1] (t);
C := pnt[n + 2] (t);
zz = whatever[B,C];
- zz = A + whatever*((C-B) rotated 90);
+ zz = pnt[n](t) + whatever*((C-B) rotated 90);
zz
enddef;
@@ -1800,11 +1895,11 @@ vardef median expr n of t =
enddef;
vardef anglebisectorpt expr n of t =
- save A, B, C; pair A, B, C;
+ save A, B, C; pair A, B, C;
A := pnt[n ] (t);
B := pnt[n + 1] (t);
C := pnt[n + 2] (t);
- save zz; pair zz;
+ save zz; pair zz;
zz = whatever[B,C];
zz = A + whatever*((B-A) rotated (.5*cornerangle (A,B,C)));
zz
@@ -1814,232 +1909,417 @@ vardef anglebisector expr n of t =
(pnt[n](t))--(anglebisectorpt n of t)
enddef;
+vardef anglefromto (expr u, v) =
+ if (u = origin) or (v = origin): 0
+ else: angle (v rotated (-angle u))
+ fi
+enddef;
+
vardef cornerangle (expr A, B, C) =
- if (A = B) and (B = C) : 60
- elseif (B = C) : 0
- elseif (A = B) or (A = C) : 90
- else: angle ((C - A) rotated (-angle (B - A)))
+ if (A = B) and (B = C) : 60
+ elseif (A=B) or (A=C) : 90
+ else: anglefromto (B - A, C - A)
fi
enddef;
vardef mkpath (expr smooth, tens, cyclic) (suffix pts) =
- if smooth : mksmooth (tens, cyclic, pts)
- else : mkpoly (cyclic, pts)
- fi
+ if smooth: mksmooth (tens)
+ else: mkpoly
+ fi (cyclic, pts)
enddef;
vardef mkpoly (expr cyclic) (suffix pts) =
for _i = 1 upto pts-1: pts[_i]-- endfor
- pts[pts] if cyclic : -- cycle fi
+ pts[pts] if cyclic: -- cycle else: {0,0} fi
enddef;
vardef polyline (expr cyclic) (text t) =
- save _pl; textpairs (_pl) (t); mkpoly (cyclic, _pl)
+ setpairs (_pl) (t);
+ if _pl=0: NoPoints ("polyline", _pl); fi
+ mkpoly (cyclic, _pl)
+enddef;
+
+def NoPoints (expr s) (suffix pts) =
+ GBwarn s & " attempted with empty list."; pts[incr pts] := origin;
+enddef;
+
+vardef turtle (text t) =
+ setnumeric (_tu) 0;
+ pair _tu[]; _tu0 := origin;
+ for _a = t: _tu[incr _tu] := _tu[_tu - 1] + _a; endfor
+ if _tu = 0: NoPoints("turtle", _tu); fi
+ mkpoly (false, _tu)
enddef;
vardef mksmooth (expr tens, cyclic) (suffix pts) =
- pts1
- if pts = 1 :
- if cyclic : &cycle fi
+ if pts = 1: onepointpath (cyclic, pts1)
else:
- if cyclic :
- {pts[2]-pts[pts]}
- fi
+ settension (_tn) tens; fixtension (_tn);
+ pts1 if cyclic: {pts[2]-pts[pts]} fi
for _i = 2 upto pts-1:
- ..tension tens..pts[_i]{pts[_i+1]-pts[_i-1]}
+ ..tension _tn..pts[_i]{pts[_i+1]-pts[_i-1]}
+ endfor
+ ..tension _tn..pts[pts]
+ if cyclic: {pts[1]-pts[pts-1]}..tension _tn..cycle fi
+ fi
+enddef;
+
+vardef mktenser (expr tens, cyclic) (suffix pts) =
+ if pts = 1: onepointpath (cyclic, pts1)
+ else:
+ settension (_tn) tens; fixtension (_tn);
+ pts1 if cyclic: {pts[2]-pts[pts]} fi
+ for _i = 2 upto pts-1:
+ ..tension atleast _tn..pts[_i]{pts[_i+1]-pts[_i-1]}
+ endfor
+ ..tension atleast _tn..pts[pts]
+ if cyclic: {pts[1]-pts[pts-1]}..tension atleast _tn..cycle fi
+ fi
+enddef;
+
+vardef mkconvex (expr tens, cyclic) (suffix pts) =
+ save _B, _d, _tmp; pair _d[];
+ settension (_tn) tens; fixtension (_tn);
+ if pts < 4: mktenser (_tn, cyclic) (pts)
+ else:
+ for _j = 2 upto pts - 1:
+ _B[_j] := sqrt(abs((pts[_j]-pts[_j-1])xprod(pts[_j+1]-pts[_j])));
+ endfor
+ if cyclic:
+ _B1 := sqrt(abs((pts1 - pts[pts])xprod(pts2 - pts1)));
+ _B[pts] := sqrt(abs((pts[pts]-pts[pts-1])xprod(pts1 - pts[pts])));
+ else:
+ _B1 := _B2;
+ _B[pts] := _B[pts-1];
+ fi
+ for _j = 2 upto pts - 1:
+ _tmp := _B[_j-1] + _B[_j+1];
+ _d[_j] :=
+ if _tmp = 0: origin % signal to use curl1
+ else:
+ ( _B[_j+1]*(pts[_j] - pts[_j-1]) +
+ _B[_j-1]*(pts[_j+1] - pts[_j]) )/_tmp
+ fi;
endfor
- ..tension tens..pts[pts]
- if cyclic :
- {pts[1]-pts[pts-1]}..tension tens..cycle
+ if cyclic:
+ _tmp := _B[pts] + _B2;
+ _d1 :=
+ if _tmp = 0: origin
+ else:
+ (_B2*(pts1 - pts[pts]) + _B[pts]*(pts2 - pts1))/_tmp
+ fi;
+ _tmp := _B[pts-1] + _B1;
+ _d[pts] :=
+ if _tmp = 0: origin
+ else:
+ ( _B1*(pts[pts] - pts[pts-1]) +
+ _B[pts-1]*(pts1 - pts[pts]) )/_tmp
+ fi;
+ else:
+ _d1 := origin; _d[pts] := origin;
fi
+ pts1
+ for _j = 1 upto pts-1:
+ {if _d[_j] = origin: curl1 else: _d[_j] fi}
+ ..tension atleast _tn..pts[_j+1]
+ endfor
+ {if _d[pts] = origin: curl1 else: _d[pts] fi}
+ if cyclic: ..tension atleast _tn..cycle fi
fi
enddef;
-def curve = tcurve (default_tension) enddef;
+numeric default_tension; default_tension := 1;
+def curve = tcurve (default_tension) enddef;
vardef tcurve (expr tens, cyclic) (text t) =
- save _tc; textpairs (_tc) (t); mksmooth (tens, cyclic, _tc)
+ setpairs (_tc) (t); mksmooth (tens, cyclic, _tc)
+enddef;
+
+def ccurve = tccurve (default_tension) enddef;
+vardef tccurve (expr tens, cyclic) (text t) =
+ setuniquepairs (_tcc) (t); mkconvex (tens, cyclic, _tcc)
enddef;
vardef mkbezier (expr tens, cyclic) (suffix pts) =
- for _i = 1 upto pts-1 : pts[_i]..tension tens.. endfor
- pts[pts] if cyclic : ..tension tens..cycle fi
+ settension (_tn) tens; fixtension (_tn);
+ pts1
+ for _i = 2 upto pts: ..tension _tn..pts[_i] endfor
+ if cyclic: ..tension _tn..cycle else: {0,0} fi
enddef;
-def bezier = tbezier (default_tension) enddef;
+def bezier = tbezier (default_tension) enddef;
vardef tbezier (expr tens, cyclic) (text t) =
- save _tsb; textpairs (_tsb) (t); mkbezier (tens, cyclic) (_tsb)
+ setpairs (_tbs) (t);
+ if _tbs=0: NoPoints ("bezier", _tbs); fi
+ mkbezier (tens, cyclic) (_tbs)
enddef;
vardef mkqbezier (expr cyclic) (suffix pts) =
- save _mqb; _mqb := pts;
- if (cyclic and odd pts) or not (cyclic or odd pts):
- pts[incr _mqb] := pts[pts];
- fi
- if cyclic : pts[incr _mqb] := pts1; fi
pts1
- for _i = 2 step 2 until _mqb - 1 :
- ..controls 1/3[pts[_i],pts[_i-1]] and 1/3[pts[_i], pts[_i+1]]
- ..pts[_i+1]
- endfor
- if cyclic : &cycle fi
+ if pts=1: {0,0}
+ else:
+ for _i = 2 step 2 until pts - 1:
+ ..controls 1/3[pts[_i], pts[_i-1] ] and 1/3[pts[_i], pts[_i+1] ]..
+ pts[_i+1]
+ endfor
+ if cyclic:
+ ..controls 1/3[ pts[pts], pts[pts - 1] ]
+ and 1/3[ pts[pts], pts1 ]..cycle
+ fi
+ fi
enddef;
vardef qbezier (expr cyclic) (text t) =
- save _qbz; textpairs (_qbz) (t); mkqbezier (cyclic) (_qbz)
+ setpairs (_qbz) (t);
+ if _qbz=0: NoPoints ("qbezier", _qbz); fi
+ if _qbz=1: onepointpath (cyclic, _qbz1)
+ else:
+ if (cyclic and odd _qbz) or (not cyclic and even _qbz):
+ _qbz[incr _qbz] := _qbz[_qbz-1];
+ fi
+ mkqbezier (cyclic) (_qbz)
+ fi
enddef;
-vardef openqbs (text t) =
- save _oq; textpairs (_oq) (t); mkqbs (_oq)
+vardef fcncontrol (expr ftens, X, Y, Z) =
+ Y if (xpart(Z-Y) <> 0) and (xpart(Y-X) <> 0):
+ + xpart(Z-Y)/3/xpart(Z-X)*(Z - X)/ftens fi
enddef;
-vardef closedqbs (text t) =
- save _cq; textpairs (_cq) (t);
- _cq[incr _cq] := _cq1; _cq[incr _cq] := _cq2;
- mkqbs (_cq) & cycle
+vardef mkfcnpath (expr ftens) (suffix q) =
+ settension (_tn) ftens;
+ if _tn <= 0: _tn := 1; fi
+ for _i = 1 upto q - 1:
+ q[_i]..controls fcncontrol (_tn) (q[_i-1], q[_i], q[_i+1])
+ and fcncontrol (_tn) (q[_i+2], q[_i+1], q[_i])..
+ endfor
+ q[q]{0,0}
enddef;
+def fcncurve = functioncurve (default_tension) enddef;
+def tfcncurve = functioncurve enddef;
+vardef functioncurve (expr ftens) (text t) =
+ settension (_ftens) ftens; if _ftens < 1/3: _ftens := 1/3; fi
+ setuniquepairs (_fc) (t);
+ if _fc > 1: _fc0 := _fc1; _fc[_fc+1] := _fc[_fc]; fi
+ mkfcnpath (_ftens) (_fc)
+enddef;
+
+def openqbs = qspline (false) enddef;
+def closedqbs = qspline (true) enddef;
+
vardef mkqbs (suffix b) =
- for _i = 1 upto b-2:
- 0.5[b[_i], b[_i+1]]
- ..controls 1/6[b[_i+1], b[_i]] and 1/6[b[_i+1], b[_i+2]]..
- endfor
- 0.5[b[b-1], b[b]]
+ 0.5[ b1, b2]
+ if b<3: {0,0}
+ else:
+ for _i = 2 upto b-1:
+ ..controls 1/6[ b[_i], b[_i-1] ] and 1/6[ b[_i], b[_i+1] ]..
+ 0.5[ b[_i], b[_i+1] ]
+ endfor
+ fi
enddef;
-vardef mkopencbs (suffix b) =
- for _i = 1 upto b-3:
- (b[_i]+4b[_i+1]+b[_i+2])/6
- ..controls 1/3[b[_i+1], b[_i+2]] and 2/3[b[_i+1], b[_i+2]]..
- endfor
- (b[b-2]+4b[b-1]+b[b])/6
+vardef qspline (expr cyclic) (text t) =
+ setpairs (_qs) (t);
+ if _qs=0: NoPoints ("qspline", _qs); fi
+ if _qs=1: _qs[incr _qs] := _qs1; fi
+ if cyclic:
+ _qs[incr _qs] := _qs1; _qs[incr _qs] := _qs2;
+ fi
+ mkqbs (_qs) if cyclic: & cycle fi
enddef;
+vardef mkcbs (suffix b) =
+ (b[1]+4b[2]+b[3])/6
+ if b < 4: {0,0}
+ else:
+ for _i = 3 upto b-1:
+ ..controls 1/3[ b[_i-1], b[_i] ] and 1/3[ b[_i], b[_i-1] ]
+ .. (b[_i-1] + 4b[_i] + b[_i+1])/6
+ endfor
+ fi
+enddef;
+
+def mkopencbs = mkcbs enddef;
vardef mkclosedcbs (suffix b) =
- mkopencbs (b) & opencbs (b[b-2],b[b-1],b[b], b1, b2, b3) & cycle
+ mkcbs (b) & opencbs (b[b-2],b[b-1],b[b], b1, b2, b3) & cycle
enddef;
-vardef opencbs (text t) =
- save _oc; textpairs (_oc) (t); mkopencbs (_oc)
+def opencbs = cspline (false) enddef;
+def closedcbs = cspline (true) enddef;
+
+vardef cspline (expr cyclic) (text t) =
+ setpairs (_cs) (t);
+ if _cs=0: NoPoints ("cspline", _cs); fi
+ for _idx = _cs upto 2: _cs[incr _cs] := _cs[_idx]; endfor
+ if cyclic:
+ for _idx = 1 upto 3: _cs[incr _cs] := _cs[_idx]; endfor
+ fi
+ mkcbs (_cs) if cyclic: & cycle fi
+enddef;
+def init_spline_eqns (suffix pts) =
+ save _spl_pre, _spl_post;
+ pair _spl_pre[], _spl_post[];
+ for j= 2 upto pts - 1:
+ _spl_post[j] + _spl_pre[j] = 2pts[j];
+ _spl_pre[j+1]+2_spl_pre[j] = 2_spl_post[j]+_spl_post[j-1];
+ endfor
enddef;
-vardef closedcbs (text t) =
- save _clc; textpairs (_clc) (t); mkclosedcbs (_clc)
+
+def closed_spline_eqns (suffix pts) =
+ _spl_post1 + _spl_pre1 = 2pts1;
+ _spl_post[pts] + _spl_pre[pts] = 2pts[pts];
+ _spl_pre2 + 2_spl_pre1 = 2_spl_post1 + _spl_post[pts];
+ _spl_pre1+2_spl_pre[pts] = 2_spl_post[pts]+_spl_post[pts-1];
enddef;
-vardef fcncontrol (expr ftens, X, Y, Z) =
- save dl, dr, before, after; pair before, after;
- before := Y - X; after := Z - Y;
- dl := xpart (before); dr := xpart (after);
- if (dr = 0) or (dl = 0):
- Y + abs(dr)/ftens * sgn before
- else:
- Y + abs(dr)/ftens * unitvector (before*dr/dl + after*dl/dr)
+def relaxed_spline_eqns (suffix pts) =
+ _spl_pre2 + pts1 = 2_spl_post1;
+ pts[pts] + _spl_post[pts-1] = 2_spl_pre[pts];
+enddef;
+
+vardef mksplinepath (expr closed) (suffix pts) =
+ pts1..controls _spl_post1 and
+ for j = 2 upto pts if not closed: -1 fi:
+ _spl_pre[j]..pts[j]..controls _spl_post[j] and
+ endfor
+ if closed: _spl_pre1..cycle else: _spl_pre[pts]..pts[pts] fi
+enddef;
+
+def mkspline (expr closed) (suffix pts) =
+ init_spline_eqns (pts);
+ if closed: closed_spline_eqns (pts);
+ else: relaxed_spline_eqns (pts);
fi
+ mksplinepath (closed) (pts)
enddef;
-vardef mkfcnpath (expr ftens) (suffix q) =
- for _i = 1 upto q - 1:
- q[_i]..controls fcncontrol (ftens) (q[_i-1], q[_i], q[_i+1])
- and fcncontrol (ftens) (q[_i+2], q[_i+1], q[_i])..
+vardef dospline (expr closed) (text the_list) =
+ setpairs (_sp) (the_list);
+ if _sp=0: NoPoints ("dospline", _sp); fi
+ if _sp=1: _sp[incr _sp] := _sp1; fi
+ mkspline (closed) (_sp)
+enddef;
+
+def init_fcnspl_eqns (suffix pts) =
+ save _dx, _sl; numeric _dx[], _sl[];
+ _dx1 := xpart (pts2 - pts1);
+ for j = 2 upto pts - 1:
+ _dx[j] := xpart (pts[j+1] - pts[j]);
+ _sl[j + 1]*_dx[j] + _sl[j-1]*_dx[j-1] + 2_sl[j]*(_dx[j] + _dx[j-1])
+ = 3*ypart(pts[j+1] - pts[j-1]);
endfor
- q[q]
enddef;
-def fcncurve = functioncurve (emax(1.2default_tension, eps)) enddef;
-vardef functioncurve (expr ftens) (text t) =
- save _fc; textpairs (_fc) (t);
- if _fc > 1 : _fc0 := _fc1; _fc[_fc+1] := _fc[_fc]; fi
- mkfcnpath (ftens)(_fc)
+def periodic_fcnspl_eqns (suffix pts) =
+ _sl1 = _sl[pts];
+ _sl2*_dx1 + 2_sl1*_dx1 + 2_sl[pts]*_dx[pts-1] + _sl[pts-1]*_dx[pts-1]
+ = 3 * ypart (pts[2] - pts[pts-1]);
enddef;
-vardef turtle (text t) =
- save _tu; pair _tu[]; _tu := 0; _tu0 := (0, 0);
- for _a = t: _tu[incr _tu] := _tu[_tu - 1] + _a; endfor
- mkpoly (false, _tu)
+def relaxed_fcnspl_eqns (suffix pts) =
+ _sl2*_dx1 + 2_sl1*_dx1 = 3 * ypart(pts2 - pts1);
+ _sl[pts-1]*_dx[pts-1] + 2_sl[pts]*_dx[pts-1]
+ = 3 * ypart(pts[pts] - pts[pts-1]);
+enddef;
+
+vardef mkfcnsplpath (suffix pts) =
+ pts1..controls (pts1 + (1, _sl1)/3*_dx1) and
+ for j = 2 upto pts - 1:
+ (pts[j] - (1, _sl[j])/3*_dx[j-1]) ..pts[j]..
+ controls (pts[j] + (1,_sl[j])/3*_dx[j]) and
+ endfor
+ (pts[pts] - (1,_sl[pts])*_dx[pts-1]/3)..pts[pts]
enddef;
-vardef mkarc (expr center, from, to, sweep) =
- save n, d; pair d;
- n := ceiling (abs(sweep)/45);
- d := (from - center) rotated (signof (sweep) 90);
- from{d}
- for j = 1 upto n-1 :
- ..(from rotatedabout (center, j/n*sweep)){d rotated (j/n*sweep)}
- endfor ..to{d rotated sweep}
+vardef mkfcnspline (expr periodic) (suffix pts) =
+ init_fcnspl_eqns (pts);
+ if periodic: periodic_fcnspl_eqns (pts);
+ else: relaxed_fcnspl_eqns (pts);
+ fi
+ mkfcnsplpath (pts)
enddef;
-vardef arc (expr center, from, sweep) =
- if (center = from) or (sweep = 0) :
- from--from
+vardef fcnspline (expr periodic) (text the_list) =
+ setpairs (_fs) (the_list);
+ if _fs<2:
+ if _fs=0: NoPoints ("fcnspline", _fs); fi
+ onepointpath (false, _fs1)
else:
- save to; pair to;
- to := from rotatedabout (center, sweep);
- mkarc (center, from, to, sweep)
+ mkfcnspline (periodic) (_fs)
fi
enddef;
-def arccps = arc enddef;
-vardef arccenter (expr from, to, sweep) =
- save ang, c;
- pair c;
- ang := 90 - (sweep mod 360)/2; % -90 < ang <= 90
- if (abs(ang) = 90) or (from = to) :
- GBmsg "The central point of this arc is undefined. " &
- "Using midpoint of chord instead.";
- 0.5[from, to]
+vardef mkarc (expr center, begpt, endpt, sweep) =
+ if (sweep = 0): begpt--endpt
else:
- save cd; pair cd; cd := to - from;
- c = from + whatever*(cd rotated ang);
- if abs(ang) < 30 :
- c = (0.5)[from, to] + whatever*(cd rotated 90);
- else:
- c = to + whatever*(-cd rotated -ang);
- fi
- c
+ setnumeric (n) ceiling (abs(sweep)/45);
+ setpair (d) (begpt - center) rotated (signof (sweep) 90);
+ begpt{d}
+ for j = 1 upto n-1:
+ ..(begpt rotatedabout (center, j/n*sweep)){d rotated (j/n*sweep)}
+ endfor ..endpt{d rotated sweep}
fi
enddef;
-vardef midarc (expr from, to, sweep) =
- save m, cd; pair m, cd;
- cd := to - from;
- m = from + whatever*( cd rotated (-sweep/4));
- m = 0.5[from, to] + whatever*(cd rotated 90);
- m
+vardef arc (expr center, begpt, sweep) =
+ if (center = begpt) or (sweep = 0): begpt--begpt
+ else:
+ mkarc (center, begpt, begpt rotatedabout (center, sweep), sweep)
+ fi
enddef;
+def arccps = arc enddef;
-vardef arcpps (expr from, to, sweep) =
- if ((sweep mod 360) = 0) or (from = to) :
- GBmsg "Undefined arc. A line segment will be used instead.";
- from--to
- elseif abs(sweep) <= 90 :
- save cd; pair cd; cd := to - from;
- if abs(sweep) <= 45 :
- from{cd rotated (-sweep/2)}..to{cd rotated (sweep/2)}
+vardef arcpps (expr begpt, endpt, sweep) =
+ if begpt = endpt: begpt--endpt
+ else:
+ setpair (cd) unitvector (endpt-begpt);
+ if abs(sweep) <= 45:
+ begpt{cd rotated (-sweep/2)}..endpt{cd rotated (sweep/2)}
+ elseif abs(sweep) <= 90:
+ save m; pair m;
+ m = begpt + whatever*( cd rotated (-sweep/4));
+ m = 0.5[begpt, endpt] + whatever*(cd rotated 90);
+ begpt{cd rotated (-sweep/2)}..m{cd}..endpt{cd rotated (sweep/2)}
else:
- from{cd rotated (-sweep/2)}..midarc(from, to, sweep){cd}
- ..to{cd rotated (sweep/2)}
+ setnumeric (ang) 90 - ((sweep/2) mod 180);
+ if abs(ang) = 90:
+ GBwarn "undefined arc. A line segment will be used instead.";
+ begpt--endpt
+ else:
+ save c; pair c;
+ c = begpt + whatever*(cd rotated ang);
+ c = if abs(ang) < 30:
+ (0.5)[begpt, endpt] + whatever*(cd rotated 90)
+ else:
+ endpt + whatever*(-cd rotated -ang)
+ fi;
+ mkarc (c, begpt, endpt, sweep)
+ fi
fi
- else:
- save center; pair center;
- center := arccenter (from, to, sweep);
- mkarc (center, from, to, sweep)
fi
enddef;
+vardef arcpp (expr small, begpt, endpt, rad) =
+ save full, ang; full := signof (rad) 360;
+ if 2*abs(rad) > abs(begpt - endpt):
+ ang := if not small: full - fi 2*asin (abs(begpt-endpt)/(2rad));
+ else: ang := signof (rad) 180;
+ fi
+ arcpps (begpt, endpt, ang)
+enddef;
+def arcppr (expr begpt, endpt, rad, small) =
+ arcpp (small, begpt, endpt, rad)
+enddef;
+
vardef arcplr (expr center, frtheta, totheta, rad) =
- if rad = 0 :
- center -- center
+ if rad = 0: center--center
else:
- save from, to; pair from, to;
- from := center + rad*dir frtheta;
- to := center + rad*dir totheta;
- if frtheta = totheta :
- from--to
- else:
- mkarc (center, from, to, totheta - frtheta)
- fi
+ mkarc (center, center + rad*dir frtheta,
+ center + rad*dir totheta, totheta - frtheta)
fi
enddef;
-vardef arcalt (expr center, radius, anglefrom, angleto) =
- arcplr (center, anglefrom, angleto, radius)
+
+vardef arcalt (expr center, radius, frtheta, totheta) =
+ arcplr (center, frtheta, totheta, radius)
enddef;
vardef arcppp (expr first, second, third) =
@@ -2054,32 +2334,33 @@ enddef;
vardef circle (expr center, rad) =
fullcircle scaled (2*rad) shifted center
enddef;
-
vardef circlecp (expr center, point) =
mkarc (center, point, point, 360) & cycle
enddef;
vardef circleppp (expr one, two, three) =
- save ang; numeric ang[];
- ang0 := cornerangle(three, one, two);
- ang1 := cornerangle(one, two, three);
- ang2 := cornerangle(two, three, one);
- arcpps (one, two, 2ang0) & arcpps (two, three, 2ang1) &
- arcpps (three, one, 2ang2) & cycle
+ arcpps (one, two, 2*cornerangle (three, one, two))
+ & arcpps (two, three, 2*cornerangle (one, two, three))
+ & arcpps (three, one, 2*cornerangle (two, three, one))
+ & cycle
enddef;
vardef circlepps (expr one, two, sweep) =
- save ang, full; numeric ang[], full;
+ save ang, full;
full := signof (sweep) 360;
- ang1 := sweep mod (full);
- ang2 := full - ang1;
- arcpps (one, two, ang1) & arcpps (two, one, ang2) & cycle
+ ang := sweep mod full;
+ arcpps (one, two, ang) & arcpps (two, one, full - ang) & cycle
+enddef;
+vardef circlepp (expr small, one, two, rad) =
+ arcpp (small, one, two, rad) & arcpp (not small, two, one, rad) & cycle
+enddef;
+def circleppr (expr one, two, rad, small) =
+ circleppr (one, two, rad, small)
enddef;
-
vardef pathcenter expr p =
- save a, cntr, n; pair cntr, a[];
+ save a, cntr, n; pair cntr, a[];
n := length p;
a1 = pnt 0 (p);
a3 = pnt [n/2] (p);
- if cycle p :
+ if cycle p:
a2 = pnt [n/4] (p);
a4 = pnt [3n/4] (p);
else:
@@ -2096,146 +2377,909 @@ vardef circumcircle expr t =
enddef;
vardef incircle expr t =
- save A, B, C; pair A, B, C;
+ save A, B, C; pair A, B, C;
A := pnt0 (t);
B := pnt1 (t);
C := pnt2 (t);
- % Find the tangent points on the sides. E.g., a is the common
- % distance from A to the tangent points on the adjacent sides.
- save a, b, c;
- a + b = abs (B-A);
- b + c = abs (C-B);
- a + c = abs (A-C);
- circleppp (A + a*unitvector (B-A),
- B + b*unitvector (C-B),
- C + c*unitvector (A-C))
+ save a, b, c, D, E, F;
+ D := abs (B-A) = a + b;
+ E := abs (C-B) = b + c;
+ F := abs (A-C) = a + c;
+ circleppp ((a/D)[A,B], (b/E)[B,C], (c/F)[C,A])
enddef;
vardef excircle expr n of t =
- save A, B, C; pair A, B, C;
- A := pnt[n] (t);
- B := pnt[n + 1] (t); % wraps around
+ save A, B, C; pair A, B, C;
+ A := pnt[n] (t);
+ B := pnt[n + 1] (t);
C := pnt[n + 2] (t);
- save a, b, c;
- a - b = abs (B-A);
- b + c = abs (C-B);
- a - c = abs (C-A);
- circleppp (A + a*unitvector(B-A),
- B + b*unitvector(C-B),
- C + c*unitvector(C-A))
+ save a, b, c, D, E, F;
+ D := abs (B-A) = a - b;
+ E := abs (C-B) = b + c;
+ F := abs (C-A) = a - c;
+ circleppp ((a/D)[A,B], (b/E)[B,C], (c/F)[A,C])
enddef;
vardef ninepointcircle expr t =
circleppp (medianpt 0 of t, medianpt 1 of t, medianpt 2 of t)
enddef;
-vardef circumcenter expr t = pathcenter circumcircle t enddef;
-vardef incenter expr t = pathcenter incircle t enddef;
-vardef excenter expr n of t = pathcenter excircle n of t enddef;
-vardef ninepointcenter expr t = pathcenter ninepointcircle t enddef;
-
vardef barycenter expr t =
- save n, m; n := length t; m := n + 1;
- save xxx;
- xxx : = pnt0 (t)/m for k = 1 upto n-1 : + pnt[k] (t)/m endfor;
- if cycle t: xxx*(1 + 1/n)
- else: xxx + pnt[n] (t)/m
- fi
+ save m; m := length t if not cycle t: + 1 fi;
+ pnt0(t)/m for k = 1 upto m - 1: + pnt[k](t)/m endfor
enddef;
+
vardef sector (expr center, rad, frtheta, totheta) =
center -- arcalt (center, rad, frtheta, totheta) -- cycle
enddef;
-vardef mkfcn (expr smooth, tens) (expr bmin, bmax, bst) (text pf) =
- save _p; pair _p[]; _p := 0;
- save _dx, _n, _r; numeric _dx, _n, _r;
- if bmax = bmin : _n := 1;
+vardef mkfcn (expr sm, tens) (expr bmin, bmax, bst) (text pf) =
+ save _p; pair _p[]; _p := 0;
+ save _dx, _n, _r; numeric _dx, _n, _r;
+ if bmax = bmin: _n := 1;
else:
_r := bmax - bmin;
_dx := max (abs(bst), nottoosmall*abs(_r), epsilon);
_n := emax (round(abs(_r)/_dx), 1);
fi
for _i = 0 upto _n: _p[incr _p] := pf(bmin + _i/_n*_r); endfor
- mkpath (smooth, tens, false, _p)
+ mkpath (sm, tens, false, _p)
enddef;
-def tfcn (expr smooth) = mkfcn (smooth, default_tension) enddef;
-def parafcn (expr smooth) = tparafcn (smooth, default_tension) enddef;
+def tfcn (expr sm) = mkfcn (sm, default_tension) enddef;
+
+def parafcn (expr sm) = tparafcn (sm, default_tension) enddef;
vardef tparafcn (expr sm, tn) (expr bmin, bmax, bst) (text pf) =
- save _fp; vardef _fp (expr t) = pf enddef;
+ save _fp; vardef _fp (expr t) = pf enddef;
mkfcn (sm, tn) (bmin, bmax, bst) (_fp)
enddef;
-vardef xfcn (expr smooth) (expr xmin, xmax, st) (text _fx) =
- save _fp; vardef _fp (expr _x) = (_x, _fx(_x)) enddef;
- mkfcn (smooth, default_tension) (xmin, xmax, st) (_fp)
+vardef xfcn (expr sm) (expr xmin, xmax, st) (text _fx) =
+ save _fp; vardef _fp (expr _x) = (_x, _fx(_x)) enddef;
+ mkfcn (sm, default_tension) (xmin, xmax, st) (_fp)
enddef;
-def function (expr smooth) = tfunction (smooth, default_tension) enddef;
-vardef tfunction (expr smooth, tens) (expr xmin, xmax, st) (text _fx) =
- save _fp; vardef _fp (expr x) = (x, _fx) enddef;
- mkfcn (smooth, tens) (xmin, xmax, st) (_fp)
+def function (expr sm) = tfunction (sm, default_tension) enddef;
+vardef tfunction (expr sm, tens, xmin, xmax, st) (text _fx) =
+ save _fp; vardef _fp (expr x) = (x, _fx) enddef;
+ mkfcn (sm, tens) (xmin, xmax, st) (_fp)
enddef;
-def btwnfcn (expr sm) = tbtwnfcn (sm, default_tension) enddef;
-vardef tbtwnfcn (expr sm, tn)(expr xlo, xhi, st)(text _fx)(text _gx) =
+def btwnfcn (expr sm) = tbtwnfcn (sm, default_tension) enddef;
+vardef tbtwnfcn (expr sm, tn, xlo, xhi, st)(text _fx)(text _gx) =
tfunction (sm, tn) (xlo, xhi, st) (_fx) --
( reverse tfunction (sm, tn) (xlo, xhi, st) (_gx) ) -- cycle
enddef;
-vardef rfcn (expr smooth) (expr tmin, tmax, st) (text ft) =
- save _fq; vardef _fq (expr t) = (ft(t)) * (dir t) enddef;
- mkfcn (smooth, default_tension) (tmin, tmax, st) (_fq)
+def belowfcn (expr sm) = tbelowfcn (sm, default_tension) enddef;
+vardef tbelowfcn (expr sm, tn, xlo, xhi, st)(text _fx) =
+ (xlo,0)--(xhi,0)--
+ (reverse tfunction (sm, tn, xlo, xhi, st)(_fx))--cycle
+enddef;
+
+vardef rfcn (expr sm, tmin, tmax, st) (text ft) =
+ save _fq; vardef _fq (expr t) = (ft(t)) * (dir t) enddef;
+ mkfcn (sm, default_tension) (tmin, tmax, st) (_fq)
+enddef;
+
+def plrfcn (expr sm) = tplrfcn (sm, default_tension) enddef;
+vardef tplrfcn (expr sm, tens, tmin, tmax, st) (text ft) =
+ save _fq; vardef _fq (expr t) = (ft) * (dir t) enddef;
+ mkfcn (sm, tens) (tmin, tmax, st) (_fq)
+enddef;
+
+def btwnplrfcn (expr sm) = tbtwnplrfcn (sm, default_tension) enddef;
+vardef tbtwnplrfcn (expr sm, tn, tlo, thi, st)(text _ft)(text _gt)=
+ tplrfcn (sm, tn, tlo, thi, st) (_ft) --
+ ( reverse tplrfcn (sm, tn, tlo, thi, st) (_gt) ) -- cycle
+enddef;
+
+def plrregion (expr sm) = tplrregion (sm, default_tension) enddef;
+vardef tplrregion (expr sm, tn, tlo, thi, st) (text _ft) =
+ (0,0)--tplrfcn (sm, tn, tlo, thi, st ) (_ft)--cycle
+enddef;
+numeric tolerancefactor;
+tolerancefactor := .02;
+vardef mklevelset (expr sm, tens, X, Y, t, a, b, c, d) =
+ save _inside_;
+ vardef _inside_ (expr U, V) =
+ inside_levelset (U, V) and (a < U) and (U < b)
+ and (c < V) and (V < d)
+ enddef;
+ if not _inside_ (X, Y):
+ GBwarn "Invalid seed point for levelset.";
+ pairmax((a,c), pairmin((X,Y), (b,d)))&cycle
+ else:
+ save ls, W, A, B, prev, curr, seed;
+ pair ls[], prev, curr, seed;
+ seed := (X,Y);
+ ls := 0; W := 0;
+
+ save _first_, _next_, get_next;
+ vardef _first_ (expr U) = _inside_ (U, Y) enddef;
+ vardef _next_ (expr ang) =
+ _inside_ (X_curr + t * cosd ang, Y_curr + t * sind ang)
+ enddef;
+ def get_next (expr angA, angB) =
+ X_curr := xpart curr; Y_curr := ypart curr;
+ ls[incr ls] := curr + t * dir (solve _next_ (angA, angB));
+ prev := curr; curr := ls[ls];
+ W := W + anglefromto (prev - seed, curr - seed);
+ enddef;
+
+ interim tolerance := t*tolerancefactor;
+ ls[incr ls] := (solve _first_ (X, b), Y);
+ curr := ls[ls];
+ interim tolerance := radian*tolerancefactor;
+ get_next (180, 0);
+ for n = 3 upto max_points:
+ A := angle (curr - prev);
+ get_next (A + 120, A - 120);
+ exitif ((abs(W) > 180) or (ls > 10))
+ and (abs(ls[ls] - ls1) < 1.2t);
+ endfor
+ mkpath (sm, tens, true) (ls)
+ fi
+enddef;
+
+numeric max_points;
+max_points := 2000;
+
+def levelset (expr s) = tlevelset (s, default_tension) enddef;
+vardef tlevelset (expr smth, tens, seed, seg) (text cond) =
+ save inside_levelset, _t;
+ vardef inside_levelset (expr x, y) = cond enddef;
+ _t := if seg <= 0: emax (xpos-xneg, ypos-yneg)/max_points * 20
+ else: seg fi;
+ mklevelset (smth, tens, xpart seed, ypart seed, _t)
+ (xneg, xpos, yneg, ypos)
+enddef;
+
+vardef lclosed expr f =
+ f
+ if not cycle f:
+ if pnt0(f) = pnt[infinity](f): & else: -- fi cycle
+ fi
+enddef;
+
+def sclosed = sclosedt (default_tension) enddef;
+vardef sclosedt (expr t) expr f =
+ if cycle f: f
+ else: save n; n := length f;
+ if n = 0: f&cycle
+ elseif n = 1: pnt0(f)..tension t..pnt1(f)..tension t..cycle
+ else:
+ (pnt0 (f)) { (pnt1(f)) - (pnt[n] (f)) }..tension t
+ ..(subpath (1, n-1) of f)..tension t
+ ..(pnt[n](f)) { pnt0(f) - pnt[n-1](f) }
+ ..tension t..cycle
+ fi
+ fi
enddef;
-def plrfcn (expr smooth) = tplrfcn (smooth, default_tension) enddef;
-vardef tplrfcn (expr smooth, tens) (expr tmin, tmax, st) (text ft) =
- save _fq; vardef _fq (expr t) = (ft) * (dir t) enddef;
- mkfcn (smooth, tens) (tmin, tmax, st) (_fq)
+def bclosed = bclosedt (default_tension) enddef;
+vardef bclosedt (expr t) expr f =
+ f
+ if not cycle f:
+ if pnt0(f) = pnt[infinity](f): & else: ..tension t.. fi cycle
+ fi
+enddef;
+
+def uclosed = bclosed enddef;
+def uclosedt = bclosedt enddef;
+
+def cbcontrols (suffix b, t) =
+ b1 := 2[t3, t2];
+ b2 := 2[t2, t1];
+ b3 := 2[b1, b2];
+ b4 := 2[b2, b3];
enddef;
-vardef piechart (expr sign, ang, cent, rad) (text data) =
- save _sum, _tot;
- numeric piewedge; piewedge := 0;
- numeric pieangle, pieangle[]; pieangle0 := 0;
- for _val = data :
- pieangle[incr piewedge] := pieangle[piewedge - 1] + _val;
+vardef cbclosed expr f =
+ save n; n := length f;
+ if cycle f: f
+ elseif n = 0: f&cycle
+ else:
+ save p, q, t; pair p[], q[], t[];
+ t1 := pnt0(f); t2 := post0(f); t3 := pre1(f);
+ cbcontrols (p, t); % defines p1 to p4
+ t1 := pnt[n](f); t2 := pre[n](f); t3 := post[n-1](f);
+ cbcontrols (q, t); % defines q1 to q4
+ f..controls q2 and q3..opencbs (q1,q4,p4,p1)
+ ..controls p3 and p2..cycle
+ fi
+enddef;
+
+vardef qbclosed expr f =
+ if cycle f: f
+ else: save n; n := length f;
+ if n = 0: f&cycle
+ else:
+ save p; pair p[]; p := 4;
+ p1 := (3/2)[pnt[n](f), pre[n](f)];
+ p2 := 2[p1, pnt[n](f)];
+ p4 := (3/2)[pnt 0 (f), post0 (f)];
+ p3 := 2[p4, pnt 0 (f)];
+ f & mkqbs (p) & cycle
+ fi
+ fi
+enddef;
+
+vardef makesector expr p = (pathcenter p)--p--cycle enddef;
+vardef arccomplement expr p =
+ if cycle p: onepointpath (false, pnt0(p))
+ else:
+ setnumeric (nn) length p;
+ setpairs (pp) (pnt0(p), pnt[.5nn](p), pnt[nn](p));
+ arcpps (pp3,pp1,2*cornerangle(pp2,pp3,pp1))
+ fi
+enddef;
+
+vardef cutoffbefore (expr b) expr f =
+ save t, n; n := length f;
+ if n > 0:
+ for k = 1 upto n:
+ exitif (subpath (0,k) of f) intersects b;
+ endfor
+ if _Xtime < 0:
+ cuttings := pnt0 (f){0,0};
+ f
+ else:
+ cuttings := subpath (0,_Xtime) of f;
+ subpath (_Xtime, n) of f
+ fi
+ else: f
+ fi
+enddef;
+
+vardef cutoffafter (expr b) expr f =
+ setpath (g) cutoffbefore (b) reverse f;
+ cuttings := reverse cuttings;
+ reverse g
+enddef;
+
+vardef trimmedpath (expr btrim, etrim) expr f =
+ save g, h; path g, h;
+ g := invvconv (fullcircle scaled 2btrim) shifted pnt0(f);
+ h := invvconv (fullcircle scaled 2etrim) shifted pnt[length f] (f);
+ cutoffafter (h) cutoffbefore (g) f
+enddef;
+
+vardef predirection@# (expr p) =
+ - postdirection[length p - @#] (reverse p)
+enddef;
+
+vardef postdirection@# (expr p) =
+ save _n; _n := length (p);
+ setpair (v) __dir (subpath (@#, @# + _n) of p);
+ if v = origin:
+ v := - __dir (subpath (@#, @# - _n) of p);
+ fi
+ v
+enddef;
+
+vardef __dir (expr p) =
+ save v, w; pair v, w; w := pnt0 (p);
+ v := origin;
+ for n = 1 upto length (p):
+ v := post[n-1] (p) - w; exitif v <> origin;
+ v := pre [ n ] (p) - w; exitif v <> origin;
+ v := pnt [ n ] (p) - w; exitif v <> origin;
+ endfor
+ sgn v
+enddef;
+
+vardef trivial expr p = (__dir (p) = origin) enddef;
+
+newinternal hdwdr, hdten;
+boolean hfilled;
+
+def headshape (expr wr, tens, fil) =
+ interim hdwdr := wr;
+ interim hdten := if tens>0: tens else: default_tension fi;
+ if hdten < .75: hdten := .75; fi
+ setboolean (hfilled) fil;
+ mkheadpaths;
+enddef;
+def mkheadpaths =
+ save Arrowhead, Leftharpoon, Rightharpoon;
+ path Arrowhead, Leftharpoon, Rightharpoon,
+ Arrowhead.clear, Leftharpoon.clear, Rightharpoon.clear;
+ Rightharpoon := (0,0){down}..tension hdten..(.5hdwdr,-1);
+ Rightharpoon.clear := Rightharpoon--(.5hdwdr,0)--cycle;
+ Leftharpoon := (reverse Rightharpoon) xscaled -1;
+ Leftharpoon.clear := (reverse Rightharpoon.clear) xscaled -1;
+ Arrowhead := Leftharpoon & Rightharpoon;
+ Arrowhead.clear := Leftharpoon.clear & Rightharpoon.clear & cycle;
+ if hfilled:
+ Arrowhead := Arrowhead--cycle;
+ Rightharpoon := Rightharpoon--(0,-1)--cycle;
+ Leftharpoon := Leftharpoon--(0,-1)--cycle;
+ fi
+enddef;
+headshape (1,1,false);
+
+def head = ahead enddef;
+
+vardef ahead (expr clr, front, back, hwr, tens, filled) =
+ settension (_tn) tens; fixtension (_tn);
+ if front <> back:
+ setpair (side) (hwr/2) * ((front-back) rotated 90);
+ setpath (f) (back + side)..tension _tn..
+ {front-back}front{back-front}..tension _tn..(back - side);
+ if clearhead:
+ safeunfill (back - side)--(front-side)--(front+side)--
+ (back+side) & f & cycle;
+ colorsafedraw (background) (back - side)--(front-side)--
+ (front+side)--(back+side) & f & cycle;
+ fi
+ if filled:
+ f := f--cycle;
+ colorsafefill (clr) f;
+ fi
+ colorsafedraw (clr) f;
+ fi
+enddef;
+
+def headpath = Gheadpath (false) (Arrowhead) enddef;
+def headpathx = Gheadpath (true) (Arrowhead) enddef;
+
+def colorheadpath = colorGheadpath (false) (Arrowhead) enddef;
+def colorheadpathx = colorGheadpath (true) (Arrowhead) enddef;
+
+def Gheadpath (expr trim) (suffix ah) =
+ colorGheadpath (trim) (ah) (headcolor)
+enddef;
+vardef colorGheadpath
+(expr trim) (suffix ah) (expr clr, sc, rot, pos) expr f =
+ if (sc <> 0) and (known ah) and (path ah):
+ convertpath (_g) f;
+ setpair (_P) predirection[length _g] (_g);
+ if _P <> origin:
+ _P := _P rotated rot;
+ setnumeric (_ang) anglefromto (up, _P);
+ _P := pnt[length _g] (_g) - pos * _P;
+ setpair (_tip) if known ah.tip: ah.tip else: origin fi;
+
+ if trim:
+ if known ah.clear:
+ safeunfill (ah.clear shifted - _tip)
+ scaled sc
+ rotated _ang
+ shifted _P;
+ fi
+ setnumeric (_ys) max(bp, penwd, last_dot_size);
+ safeunfill cut_path
+ xscaled sc yscaled _ys
+ rotated _ang shifted _P;
+ fi
+ if cycle ah: colorsafefill else: colorsafedraw fi (clr)
+ (ah shifted -_tip)
+ scaled sc
+ rotated _ang
+ shifted _P;
+ fi
+ fi
+ f
+enddef;
+
+def tailpath (suffix sh) = colortailpath (sh) (headcolor) enddef;
+vardef colortailpath (suffix sh) (expr clr, sc, rot, pos) expr f =
+ if (sc <> 0) and (known sh) and (path sh):
+ convertpath (_g) f;
+ setpair(_P) postdirection0 (_g);
+ if _P <> origin:
+ _P := _P rotated rot;
+ if cycle sh: colorsafefill else: colorsafedraw fi (clr)
+ (sh if known sh.tip: shifted -sh.tip fi)
+ scaled sc
+ rotated anglefromto (up, _P)
+ shifted (pnt0 (_g) + pos * _P);
+ fi
+ fi
+ f
+enddef;
+
+def midpath (suffix sh) = colormidpath (sh) (headcolor) enddef;
+vardef colormidpath (suffix sh) (expr clr, sc, rot, pos) expr f =
+ if (sc <> 0) and (known sh) and (path sh):
+ convertpath (_g) f;
+ setnumeric (_t) pathtime[pos] (_g);
+ setpair (_P) postdirection[_t] (_g);
+ if _P <> origin:
+ _P := _P rotated rot;
+ if cycle sh: colorsafefill else: colorsafedraw fi (clr)
+ sh scaled sc
+ rotated anglefromto (up, _P)
+ shifted (pnt[_t] (_g));
+ fi
+ fi
+ f
+enddef;
+
+vardef signeddeviate primary X =
+ (uniformdeviate 1)[-X,X]
+enddef;
+vardef scaledeviate (expr W, A) =
+ 2 ** (signeddeviate W) * dir A
+enddef;
+vardef polardeviate primary R =
+ (uniformdeviate abs(R)) * dir uniformdeviate 360
+enddef;
+vardef xydeviate primary Z =
+ (signeddeviate (xpart Z), signeddeviate (ypart Z))
+enddef;
+
+vardef randompair (expr maxshift) =
+ if numeric maxshift: polardeviate (maxshift)
+ elseif pair maxshift: xydeviate (maxshift)
+ else: (0,0)
+ fi
+enddef;
+
+vardef detrivialized expr f =
+ save g; path p, g[]; g := 0;
+ for k = 1 upto length f:
+ p := subpath (k-1,k) of f;
+ if not trivial p: g[incr g] := p; fi
endfor
- _tot := pieangle[piewedge];
- pair piecenter; piecenter := cent;
+ if g = 0: onepointpath (cycle f, pnt0(f))
+ else: g1 for k = 2 upto g: &g[k] endfor if cycle f: &cycle fi
+ fi
+enddef;
+
+vardef randompath (expr maxshift, weirdness) expr f =
+ save g, n; path g;
+ g := detrivialized f;
+ n := length g;
+ if n = 0:
+ f shifted randompair (maxshift)
+ else:
+ save X, U, V;
+ pair X[], U[], V[];
+ if cycle g: n := n - 1; fi
+ for k = 0 upto n:
+ X[k] := pnt[k](g);
+ U[k] := X[k] - pre[k](g);
+ V[k] := post[k](g) - X[k];
+ endfor
+ save A, B;
+ for k := 0 upto n:
+ X[k] := X[k] shifted randompair (maxshift);
+ A := anglefromto (U[k],V[k]);
+ B := signeddeviate (30weirdness);
+ U[k] := X[k] - (U[k] zscaled scaledeviate (weirdness,B));
+ B := B - A + A * (2 ** signeddeviate weirdness);
+ V[k] := X[k] + (V[k] zscaled scaledeviate (weirdness,B));
+ endfor
+ X0 for k = 1 upto n:
+ .. controls V[k-1] and U[k] .. X[k]
+ endfor
+ if cycle g:
+ .. controls V[n] and U0 .. cycle
+ fi
+ fi
+enddef;
+
+vardef randomlines (expr maxshift) expr f =
+ save g, n; path g;
+ g := detrivialized f;
+ n := length g;
+ if n = 0:
+ f shifted randompair (maxshift)
+ else:
+ if cycle g: n := n - 1; fi
+ (pnt0(g) shifted randompair (maxshift))
+ for k = 1 upto n:
+ -- (pnt[k](g) shifted randompair (maxshift))
+ endfor
+ if cycle g:
+ -- cycle
+ fi
+ fi
+enddef;
+vardef parasegment (expr d, segs, f) =
+ if d = 0: f
+ else:
+ save u, v, t; pair u[], v[];
+ for n = 0 upto segs:
+ t := n/segs;
+ u[n] := postdirection [t] (f);
+ v[n] := pnt[t] (f) + (u[n] zscaled (0,d));
+ endfor
+ v0{u0}
+ for n = 1 upto segs: ...v[n]{u[n]} endfor
+ fi
+enddef;
+
+vardef parapath (expr d) expr f =
+ if d = 0:
+ f
+ else:
+ save a, g, h, p, q, s, t, u, v, w;
+ path g[], h, p[], q[];
+ numeric a, s, t;
+ pair u, v, w, w[];
+ s := emax (3, emin (segment_split, ceiling (max_points/5/length f)));
+ p := 0;
+ for i = 1 upto length f:
+ h := subpath (i-1, i) of f;
+ if not trivial h:
+ q[incr p] := h;
+ p[p] := parasegment (d, s, h);
+ fi
+ endfor
+ if p = 0:
+ f
+ else:
+ a := if d>0: - fi 180;
+ h := p1;
+ for i = 1 upto p-1:
+ u := predirection 1 (q[i]);
+ v := postdirection 0 (q[i+1]);
+ w1 := pnt 1 (q[i]) - (u zscaled (0,d));
+ w2 := pnt 0 (q[i+1]) - (v zscaled (0,d));
+ w3 := pnt [infinity] (h);
+ w4 := pnt 0 (p[i+1]);
+ g0 := arcpps(w3, w1, a);
+ g1 := h & g0;
+ g2 := arcpps(w2, w4, a) & p[i+1];
+ if (p[i] & g0) intersects reverse g2:
+ s := length g2 - _Ytime;
+ t := length h - length p[i] + _Xtime;
+ g1 := subpath (0, t) of g1;
+ g2 := subpath (s, length g2) of g2;
+ force_equal_ends (g1, g2);
+ h := g1 & g2;
+ else:
+ h := h .. p[i+1];
+ fi
+ endfor
+
+ if cycle f:
+ u := predirection 1 (q[p]);
+ v := postdirection 0 (q[1]);
+ w1 := pnt 1 (q[p]) - (u zscaled (0,d));
+ w2 := pnt 0 (q[1]) - (v zscaled (0,d));
+ w3 := pnt [infinity] (h);
+ w4 := pnt 0 (p[1]);
+ g3 := arcpps(w3, w1, a);
+ g0 := arcpps(w2, w4, a);
+ g1 := g0 & h & g3;
+ g2 := g0 & p[1];
+ if (p[p] & g3) intersects reverse g2:
+ s := length g2 - _Ytime;
+ t := length g0 + length h - length p[p] + _Xtime;
+ g1 := subpath (s, t) of g1;
+ force_equal_ends (g1, g1);
+ h := g1 & cycle;
+ else:
+ h := h..cycle;
+ fi
+ fi
+ h
+ fi
+ fi
+enddef;
+
+vardef turnangle@# (expr f) =
+ anglefromto(predirection@# (f), postdirection@#(f))
+enddef;
+
+def setdatadashes (text lst) =
+ save __type; __type := 0;
+ forsuffixes _itm = lst:
+ if knownnumericarray _itm :
+ copyarray (_itm) (__type[__type]);
+ next __type;
+ else: GBwarn "Improper dash pattern in setdatadashes.";
+ fi
+ endfor
+ if __type > 1:
+ save dashtype; dashtype := __type;
+ for _j = 0 upto dashtype - 1:
+ copyarray (__type[_j]) (dashtype[_j]);
+ endfor
+ else:
+ SetdataWarn "dashes";
+ fi
+enddef;
+def getdashpat expr n = dashtype[n mod dashtype] enddef;
+
+def SetdataWarn expr s =
+ GBwarn "command setdata"& s &"() failed. Previous values retained.";
+enddef;
+
+numeric Solid, Simpledash, Simpledot, Dotdash, Dotdashdot, Dotdashdash;
+dashpat (Solid) (0);
+dashpat (Simple_dash) (3bp, 4bp);
+dashpat (Simple_dot) (0, 4bp);
+dashpat (Dot_dash) (0, 4bp, 3bp, 4bp);
+dashpat (Dot_dash_dot) (0, 4bp, 3bp, 4bp, 0, 4bp);
+dashpat (Dot_dash_dash) (0, 4bp, 3bp, 4bp, 3bp, 4bp);
+
+numeric dashtype, dashtype[], dashtype[][];
+def defaultdashes =
+ setdatadashes (Solid, Simple_dash, Simple_dot,
+ Dot_dash, Dot_dash_dot, Dot_dash_dash);
+enddef;
+defaultdashes;
+
+def setdatasymbols (text lst) =
+ save __type; path __type[];
+ __type := 0;
+ for _itm = lst:
+ if (known _itm) and (path _itm):
+ __type[__type] := _itm;
+ next __type;
+ else:
+ GBwarn "Improper path in setdatasymbols().";
+ fi
+ endfor
+ if __type > 1:
+ save pointtype; pointtype := __type;
+ path pointtype[];
+ for _j = 0 upto pointtype - 1:
+ pointtype[_j] := __type[_j];
+ endfor
+ else:
+ SetdataWarn "symbols";
+ fi
+enddef;
+def getsymbol expr n := pointtype[n mod pointtype] enddef;
+
+def DeclareGBSymbols (text S) =
+ forsuffixes _itm = S:
+ path _itm;
+ path _itm.clear;
+ pair _itm.tip;
+ endfor
+enddef;
+DeclareGBSymbols(
+ Triangle, Square, Circle, Diamond, Star, Plus, Cross,
+ Asterisk, Crossbar, Leftbar, Rightbar, Righthook,
+ Lefthook, SolidTriangle, SolidSquare, SolidCircle,
+ SolidDiamond, SolidStar
+);
+
+vardef undo_cycle expr f = subpath (0, length f) of f enddef;
+
+SolidTriangle := (up--(dir 210)--(dir -30)--cycle) scaled .78;
+Triangle := undo_cycle SolidTriangle;
+
+Triangle.clear := SolidTriangle.clear :=
+ ((dir -30)--(cosd 30,1)--(cosd 210,1)--(dir 210)--up--cycle)
+ scaled .78;
+
+SolidSquare := (up--(-1,1)--(-1,-1)--(1,-1)--(1,1)--cycle) scaled .443;
+Square := undo_cycle SolidSquare;
+
+SolidCircle := fullcircle rotated 90;
+Circle := undo_cycle SolidCircle;
+Circle.clear := SolidCircle.clear :=
+ halfcircle--(-.5,.5)--(.5,.5)--cycle;
+
+SolidDiamond := (up--left--down--right--cycle)
+ scaled .522 yscaled 1.44;
+Diamond := undo_cycle SolidDiamond;
+Diamond.clear := SolidDiamond.clear :=
+ (right--(1,1)--(-1,1)--left--up--cycle) scaled .522 yscaled 1.44;
+
+Plus := ((0,0)--up--down--(0,0)--left--right) scaled .65;
+Plus.clear := (right--(1,1)--(-1,1)--(left)--cycle) scaled .65;
+
+Cross := ((0,0)--(dir 45)--(dir -135)--(0,0)--(dir -45)--(dir 135))
+ scaled .65;
+Cross.clear := ((0,0)--(dir -45)--dir(45)--(dir 135)--(dir -135)--cycle)
+ scaled .65;
+
+Asterisk := ((0,0)--up--down--(0,0)--(dir 30)--(dir -150)
+ --(0,0)--(dir -30)--(dir 150)) scaled .6;
+Asterisk.clear := ((0,0)--(dir -30)--(cosd 30,1)--(cosd 150,1)
+ --(dir -150)--cycle) scaled .6;
+
+Crossbar := ((0,0)--left--right) scaled .65;
+Crossbar.clear := rect (right,(-1,.5)) scaled .65;
+
+Leftbar := ((0,0)--left);
+Rightbar := ((0,0)--right);
+Leftbar.clear := rect((0,0),(-1,.5));
+Rightbar.clear := rect((0,0),(1,.5));
+
+Righthook := arcpps((0,0),(1,0),180);
+Lefthook := Righthook xscaled -1;
+Righthook.clear := Righthook--cycle;
+Lefthook.clear := Lefthook--cycle;
+
+vardef mkstar (expr n, m) (suffix A) =
+ save ang; ang := 360/n;
+ A1 := up; A3 := up rotated ang;
+ A2 = (whatever)[A1, A1 rotated ( ang*m)];
+ A2 = (whatever)[A3, A3 rotated (-ang*m)];
+ for i = 4 upto 2n:
+ A[i] := A[i-2] rotated ang;
+ endfor
+ A := 2n;
+ mkpoly (true, A)
+enddef;
+
+save _A; pair _A[];
+SolidStar := mkstar (5, 2, _A) scaled .84;
+Star := undo_cycle SolidStar;
+Star.clear := polyline (true)
+ (_A9, _A10, _A1, _A2, _A3, (xpart _A3, 1), (xpart _A9, 1)) scaled .84;
+SolidStar.clear := Star.clear;
+
+forsuffixes S =
+ Triangle, Square, Circle, Diamond, Star, Plus, Cross,
+ Asterisk, Crossbar, Leftbar, Rightbar, Righthook,
+ Lefthook, SolidTriangle, SolidSquare, SolidCircle,
+ SolidDiamond, SolidStar :
+ S.tip := point 0 of S;
+endfor
+vardef gcd (expr n, m) =
+ save a, b, r;
+ a := emax (abs(m), abs(n));
+ b := emin (abs(m), abs(n));
+ if b > 0:
+ forever:
+ r := a mod b;
+ exitif r < 1;
+ a := b; b := r;
+ endfor
+ b
+ else:
+ a
+ fi
+enddef;
+
+vardef lcm (expr n, m) =
+ n*m/gcd(n, m)
+enddef;
+
+path cut_path; cut_path := (.5,0)--(.5,.71)--(-.5,.71)--(-.5,0)--cycle;
+
+numeric pointtype; path pointtype[];
+def defaultsymbols =
+ setdatasymbols( Circle, Cross, SolidDiamond, Square, Plus,
+ Triangle, SolidCircle, Star, SolidTriangle);
+enddef;
+defaultsymbols;
+
+def setdatacolors (text lst) =
+ save __type; color __type[];
+ __type := 0;
+ for _itm = lst:
+ if (known _itm) and (color _itm):
+ __type[__type] := _itm;
+ next __type;
+ else: GBwarn "Improper color in setdatacolors().";
+ fi
+ endfor
+ if __type > 1:
+ save colortype; colortype := __type;
+ color colortype[];
+ for _j = 0 upto colortype - 1:
+ colortype[_j] := __type[_j];
+ endfor
+ else:
+ SetdataWarn "colors";
+ fi
+enddef;
+def getcolor expr n = colortype[n mod colortype] enddef;
+
+color dBlue, dOrange, dGreen, dMagenta, dCyan, dYellow;
+dBlue := 0.80blue + .2white;
+dOrange := 0.66yellow + .34red;
+dGreen := 0.80green;
+dMagenta := 0.85magenta;
+dCyan := 0.85cyan;
+dYellow := 0.85yellow;
+
+numeric colortype; color colortype[];
+def defaultcolors =
+ setdatacolors(black, red, dBlue, dOrange, dGreen,
+ dMagenta, dCyan, dYellow);
+enddef;
+defaultcolors;
+
+def computepie (suffix dat) (expr sign, ang, cent, rad) (text data) =
+begingroup
+ save _tot, _max, _toobig;
+ _max := 0; dat := 0;
+ for _val = data:
+ dat[incr dat] := _val;
+ _max := emax (_max, _val);
+ endfor
+ if dat=0: GBwarn "piechart attempted with empty list.";
+ _toobig := 1;
+ else:
+ _toobig := infinity/dat;
+ fi
+ if _max > _toobig:
+ for _idx = 1 upto dat:
+ dat[_idx] := dat[_idx]/_toobig;
+ endfor
+ fi
+ for _idx = 2 upto dat:
+ dat[_idx] := dat[_idx - 1] + dat[_idx];
+ endfor
+ _tot := dat[dat];
+ for _idx = dat downto 2:
+ dat[_idx] := ang + sign*dat[_idx-1]/_tot*360;
+ endfor
+ dat1 := ang; dat[dat + 1] := ang + 360sign;
+endgroup
+enddef;
+
+def piechart (expr sign, ang, cent, rad) (text data) =
+ save _dat;
+ computepie (_dat) (sign, ang, cent, rad) (data);
+ mkpiewedges (_dat, cent, rad);
+enddef;
+
+def mkpiewedges (suffix dat) (expr cent, rad) =
+ numeric piewedge, piedirection, pieangle, pieangle[];
+ pair piecenter, piedirection[];
path piewedge[];
- numeric piedirection; pair piedirection[];
- pieangle[piewedge + 1] = ang + sign*360;
- for _n = piewedge downto 1 :
- pieangle[_n] := ang + sign*pieangle[_n - 1]/_tot*360;
- piewedge[_n] =
- sector(cent, rad, pieangle[_n], pieangle[_n+1]);
- piedirection[_n] := dir(0.5[ pieangle[_n], pieangle[_n+1] ]);
+ piecenter := cent;
+ piedirection := pieangle := piewedge := dat;
+ for _idx = 1 upto dat:
+ pieangle[_idx] := dat[_idx];
+ piewedge[_idx] := sector (piecenter, rad, dat[_idx], dat[_idx+1]);
+ piedirection[_idx] := dir(0.5[ dat[_idx], dat[_idx+1] ]);
endfor
- piedirection := pieangle := piewedge;
enddef;
-def barchart (expr start, sep, r, vert)(text data) =
+def namedpiechart (suffix nm) (expr sign, ang, cent, rad) (text data) =
+ save _dat;
+ computepie (_dat) (sign, ang, cent, rad) (data);
+ setnumeric (nm) _dat;
+ pair nm.center, nm.direction[];
+ path nm.wedge[];
+ nm.center := cent;
+ for _idx = 1 upto _dat:
+ nm.wedge[_idx] := sector (cent, rad, _dat[_idx], _dat[_idx+1]);
+ nm.direction[_idx] := dir(0.5[ _dat[_idx], _dat[_idx+1] ]);
+ endfor
+enddef;
+
+def barchart (expr firstbar, sep, r, vert)(text data) =
numeric barbegin, barbegin[],
barend, barend[],
barlength, barlength[],
barstart, barstart[],
chartbar, barwd;
path chartbar[];
- chartbar := 0; barwd := r*sep;
- for _itm = data :
- barend[incr chartbar] := if pair _itm: ypart _itm else: _itm fi;
- barbegin[chartbar] := if pair _itm: xpart _itm else: 0 fi;
+ chartbar := 0; barwd := r*sep;
+ for _itm = data:
+ barend[incr chartbar] := if pair _itm: ypart _itm else: _itm fi;
+ barbegin[chartbar] := if pair _itm: xpart _itm else: 0 fi;
endfor
barbegin := barend := barlength := barstart := chartbar;
- for _n = 1 upto chartbar :
- barstart[_n] := start + sep*(_n-1);
- barlength[_n] := barend[_n];
- chartbar[_n] := rect ((barbegin[_n], 0), ( barend[_n], barwd) )
- shifted (0, barstart[_n]) if vert: xyswap fi;
+ for _nn = 1 upto chartbar:
+ barstart[_nn] := firstbar + sep*(_nn-1);
+ barlength[_nn] := barend[_nn];
+ chartbar[_nn] := rect ((barbegin[_nn], 0), ( barend[_nn], barwd))
+ shifted (0, barstart[_nn]) if vert: xyswap fi;
endfor
enddef;
+def namedbarchart (suffix nm) (expr first, sep, r, vert) (text data) =
+ save nm;
+begingroup
+ save _bb, _ee, _ww;
+ path nm.bar[];
+ nm := 0; _ww := r*sep;
+ for _itm = data:
+ _ee := if pair _itm: ypart _itm else: _itm fi;
+ _bb := if pair _itm: xpart _itm else: 0 fi;
+ nm.bar[incr nm] := rect ((_bb, 0), ( _ee, _ww) )
+ shifted (0, first + sep*(nm-1)) if vert: xyswap fi;
+ endfor
+endgroup
+enddef;
+
picture totalpicture;
boolean totalnull, currentnull;
def clearit =
@@ -2246,7 +3290,7 @@ enddef;
def keepit =
addto totalpicture also currentpicture;
currentpicture := nullpicture;
- totalnull := currentnull;
+ totalnull := totalnull or currentnull;
currentnull := true;
enddef;
@@ -2256,13 +3300,13 @@ def addto_currentpicture =
enddef;
def mergeit (text do) =
- if totalnull :
+ if totalnull:
do currentpicture
- elseif currentnull :
+ elseif currentnull:
do totalpicture
else:
begingroup
- save _v_; picture _v_;
+ save _v_; picture _v_;
_v_ := currentpicture;
addto _v_ also totalpicture;
do _v_
@@ -2270,13 +3314,12 @@ def mergeit (text do) =
fi
enddef;
-def shipit_ =
- mergeit (shipout)
-enddef;
-def shipit = shipit_ enddef;
+boolean noship; noship := false;
+def shipit = if noship: else: mergeit (shipout) fi enddef;
-numeric gcode; gcode := 0;
+numeric gcode; gcode := 0;
+input dvipsnam.mp;
% end grafbase.mp
endinput.
%%
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 20:28:26 +0000