mfpic 1.00 (30sep09)

git-svn-id: svn://tug.org/texlive/trunk@15602 c570f23f-e606-0410-a88d-b1316a301751

2 files changed, 424 insertions, 98 deletions

diff --git a/Master/texmf-dist/metapost/mfpic/dvipsnam.mp b/Master/texmf-dist/metapost/mfpic/dvipsnam.mp
index 1bc8d9f64c9..0529714a4d1 100644
--- a/Master/texmf-dist/metapost/mfpic/dvipsnam.mp
+++ b/Master/texmf-dist/metapost/mfpic/dvipsnam.mp
@@ -8,34 +8,34 @@
 %% 
 %% -------------------------------------------------------------------
 %% 
-%% Copyright 2002--2006, Daniel H. Luecking
+%% Copyright 2002--2009, Daniel H. Luecking
 %% 
 %% Mfpic may be distributed and/or modified under the conditions of the
-%% LaTeX Project Public License, either version 1.3b of this license or (at
+%% LaTeX Project Public License, either version 1.3c 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.
+%% and version 1.3c or later is part of all distributions of LaTeX version
+%% 2008/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.
 %% 
+%%% File: grafbase.dtx
+%%% A part of mfpic 1.00 2009/09/22
+%%%
 if unknown grafbaseversion:
-  vardef snapto expr t =
-    if unknown t:            0
-    elseif not (numeric t):  0
-    elseif t < 0:            0
-    elseif t > 1:            1
-    else:                    t
-    fi
-  enddef;
-  vardef cmyk (expr c, m, y, k) =
-    (snapto 1-c-k, snapto 1-m-k, snapto1-y-k)
-  enddef;
+  if unknown mpversion:
+    let cmykcolor=color;
+    vardef cmyk (expr c, m, y, k) =
+      (max(1-c-k,0), max(1-m-k,0), max(1-y-k,0))
+    enddef;
+  else:
+    vardef cmyk (expr c, m, y, k) =  (c, m, y, k)  enddef;
+  fi
 fi
 
-color Apricot, Aquamarine, Bittersweet, Black, Blue, BlueGreen,
+cmykcolor Apricot, Aquamarine, Bittersweet, Black, Blue, BlueGreen,
 BlueViolet, BrickRed, Brown, BurntOrange, CadetBlue, CarnationPink,
 Cerulean, CornflowerBlue, Cyan, Dandelion, DarkOrchid, Emerald,
 ForestGreen, Fuchsia, Goldenrod, Gray, Green, GreenYellow, JungleGreen,
diff --git a/Master/texmf-dist/metapost/mfpic/grafbase.mp b/Master/texmf-dist/metapost/mfpic/grafbase.mp
index 225150795f1..b231060dd5c 100644
--- a/Master/texmf-dist/metapost/mfpic/grafbase.mp
+++ b/Master/texmf-dist/metapost/mfpic/grafbase.mp
@@ -8,19 +8,22 @@
 %% 
 %% -------------------------------------------------------------------
 %% 
-%% Copyright 2002--2006, Daniel H. Luecking
+%% Copyright 2002--2009, Daniel H. Luecking
 %% 
 %% Mfpic may be distributed and/or modified under the conditions of the
-%% LaTeX Project Public License, either version 1.3b of this license or (at
+%% LaTeX Project Public License, either version 1.3c 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.
+%% and version 1.3c or later is part of all distributions of LaTeX version
+%% 2008/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.
 %% 
+%%% File: grafbase.dtx
+%%% A part of mfpic 1.00 2009/09/22
+%%%
 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.";
@@ -29,7 +32,7 @@ fi
 boolean grafbase; grafbase := true;
 
 string fileversion, filedate;
-fileversion := "0.9";  filedate := "2006/05/26";
+fileversion := "1.00";  filedate := "2009/09/22";
 
 message " Loading grafbase macros, version " & fileversion & " " &
    filedate & ".";
@@ -56,7 +59,7 @@ def checkversions (expr g)=
   fi
 enddef;
 
-checkversions (90);
+checkversions (100);
 
 if unknown base_name       :  input plain;
 elseif not string base_name:  input plain;
@@ -64,18 +67,37 @@ elseif base_name <> "plain":  input plain;
 fi
 
 boolean METAPOST;
+METAPOST := known color Geamparalele din Babadag;
+numeric metapostversion;
 
-if known color Geamparalele din Babadag:
-  METAPOST := true;
-else:
-  METAPOST := false;
-fi
 
 if not METAPOST:
   GBerrmsg ("wrong compiler.")
     "This file is for Metapost. For Metafont use grafbase.mf.";
 fi
 
+numeric metapostversion;
+boolean has_cmyk;
+boolean has_filenametemplate; % e.g., filenametemplate "%j.%n;
+boolean has_outputtemplate; % e.g., outputtemplate := "%j.%n;
+if unknown mpversion:
+  % prior to introduction of cmykcolor and output filename templates.
+  % Latest such version was 0.641.
+  metapostversion := 0.641;
+  has_cmyk       := false;
+  has_filenametemplate := false;
+  has_outputtemplate := false;
+else:
+  metapostversion := scantokens (mpversion);
+  has_cmyk := true;
+  has_filenametemplate := true;
+  if metapostversion < 1.200:
+    has_outputtemplate := false;
+  else:
+    has_outputtemplate := true;
+  fi
+fi
+
 if not boolean debug:  boolean debug;  debug := false;  fi
 
 def GBdebug =
@@ -143,6 +165,7 @@ enddef;
 
 boolean showbbox;  showbbox := false;
 
+if not has_cmyk:  let rgbcolor = color;  let cmykcolor = color;  fi
 def _wc_ =  withcolor  enddef;
 
 color currentcolor, drawcolor, fillcolor, hatchcolor,
@@ -152,54 +175,123 @@ currentcolor := fillcolor := drawcolor := hatchcolor :=
 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 numeric t:
+    if unknown t:  0
+    elseif t < 0:  0
+    elseif t > 1:  1
+    else:          t
+    fi
+  else:
+    GBerrmsg ("Improper expression type.")
+      "The argument to `snapto' must be a numeric.";
   fi
+
 enddef;
 
-vardef gray (expr g) =  (snapto g)*white  enddef;
+vardef rgbgray  (expr g) =  (snapto g) * white  enddef;
+vardef cmykgray (expr g) =  cmyk(0,0,0,1 - snapto g)  enddef;
 
-vardef makeclr (expr r, g, b) =
-  (r, g, b)
-enddef;
+if has_cmyk :
+  vardef grayscalegray (expr g) =  snapto g  enddef;
+  vardef gray (expr g) =  grayscalegray (g)  enddef;
+  vardef cmyk (expr c, m, y, k) =
+    (snapto c, snapto m, snapto y, snapto k)
+  enddef;
 
-vardef rgb (expr r, g, b) =
-  makeclr (snapto r, snapto g, snapto b)
+  def colorchoice (expr clr) (text D)(text N)(text R)(text C) =
+    if unknown clr:        D
+    elseif numeric clr:    N
+    elseif rgbcolor clr:   R
+    elseif cmykcolor clr:  C
+    else:                  D
+    fi
+  enddef;
+
+  vardef makecmyk primary clr =
+    colorchoice (clr)(cmykblack)(cmykgray(clr))
+    (rgbtocmyk(redpart clr,greenpart clr,bluepart clr))
+    (clr)
+  enddef;
+  vardef makergb primary clr =
+    colorchoice (clr)(rgbblack)(rgbgray(clr))(clr)
+    (cmyktorgb(cyanpart clr, magentapart clr, yellowpart clr, blackpart clr))
+  enddef;
+  vardef makegray primary clr =
+    colorchoice (clr)(grayscaleblack)(grayscalegray(clr))
+    (rgbtogray (redpart clr, greenpart clr, bluepart clr))
+    (cmyktogray(cyanpart clr, magentapart clr, yellowpart clr,
+        blackpart clr))
+  enddef;
+  vardef iscolor expr clr =
+    (rgbcolor clr) or (cmykcolor clr) or (numeric clr) or (boolean clr)
+  enddef;
+else:
+  vardef gray (expr g) =  rgbgray(g)  enddef;
+  vardef grayscalegray (expr g) =  rgbgray(g)  enddef;
+  vardef cmyk (expr c, m, y, k) =  rgb (1-c-k, 1-m-k, 1-y-k)  enddef;
+  def colorchoice (expr clr) (text D)(text N)(text R) =
+    if unknown clr:       D
+    elseif numeric clr:   N
+    elseif rgbcolor clr:  R
+    else:                 D
+    fi
+  enddef;
+  vardef makergb  primary clr =
+    colorchoice (clr)(rgbblack)(rgbgray(clr))(clr)
+  enddef;
+  vardef makegray primary clr =
+    colorchoice (clr)(rgbblack)(rgbgray(clr))
+      (rgbtogray (redpart clr, greenpart clr, bluepart clr))
+  enddef;
+  def makecmyk =  makergb  enddef;
+  vardef iscolor expr clr =  color clr enddef;
+fi
+
+vardef knowncolor expr clr =  (known clr) and (iscolor clr)  enddef;
+
+vardef forceclr (expr c) =
+  if unknown c :
+    if numeric c:  grayscaleblack
+    elseif rgbcolor c:   rgbblack
+    elseif cmykcolor c: cmykblack
+    else: black
+    fi
+  elseif numeric c:  gray (c)
+  elseif iscolor c:  c
+  else:  black
+  fi
 enddef;
+vardef named (suffix c) =  forceclr (c)  enddef;
 
-vardef cmyk (expr c, m, y, k) =
-  rgb (1-c-k, 1-m-k, 1-y-k)
+vardef togray (expr r, g, b) =
+  gray (sqrt((2r*r + 4g*g + b*b)/7))
 enddef;
 
-vardef RGB (expr R, G, B) =
-  rgb (R/255, G/255, B/255)
+vardef rgbtogray (expr r, g, b) =
+  togray(snapto r, snapto g, snapto b)
+enddef;
+vardef cmyktogray (expr c, m, y, k) =
+  rgbtogray (1-c-k,1-m-k,1-y-k)
 enddef;
 
-vardef named (suffix c) =
-  if unknown c:  black  else:  forceclr (c)  fi
+vardef cmyktorgb (expr c,m,y,k) =
+  rgb(1-c-k,1-m-k,1-y-k)
 enddef;
-vardef forceclr (expr c) =
-  if numeric c:    gray (c)
-  elseif color c:  c
-  else:            black
-  fi
+vardef rgbtocmyk (expr r,g,b) =
+  cmyk(1-r,1-g,1-b,0)
 enddef;
 
-color red, green, blue, cyan, magenta, yellow;
-red     := rgb (1, 0, 0);
-green   := rgb (0, 1, 0);
-blue    := rgb (0, 0, 1);
-cyan    := rgb (0, 1, 1);
-magenta := rgb (1, 0, 1);
-yellow  := rgb (1, 1, 0);
+vardef rgb (expr r, g, b) =
+  (snapto r, snapto g, snapto b)
+enddef;
+vardef RGB (expr R, G, B) =
+  rgb (R/255, G/255, B/255)
+enddef;
 
 def list (suffix v) (text lst) =
   v := 0;  for _itm = lst:  v[incr v] := _itm;  endfor
   if v = 0:
-    GBerrmsg ("no list to process!")
+    GBerrmsg ("No list to process!")
       "An attempt was made to produce an array from a "
     & "list of expressions having no valid entries.";
   fi
@@ -379,8 +471,10 @@ 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 setstring    =  setvariable (string)  enddef;
+def settransform =  setvariable (transform)  enddef;
+def setpen       =  setvariable (pen)  enddef;
 def settension (suffix tn) expr tens =
   setnumeric (tn) if tens > 0:  tens  else:  default_tension  fi;
 enddef;
@@ -406,6 +500,92 @@ def setsplit (suffix s) expr ss =
   setnumeric (s) emax (1, ceiling ss);
 enddef;
 
+if has_cmyk:
+  def setrgbcolor  =  setvariable (rgbcolor)  enddef;
+  def setcmykcolor =  setvariable (cmykcolor)  enddef;
+  def setcolor (suffix name) expr val =
+    if     boolean   val :  setboolean
+    elseif numeric   val :  setnumeric
+    elseif rgbcolor  val :  setrgbcolor
+    elseif cmykcolor val :  setcmykcolor
+    % this should give a suitable error message:
+    else:  setvariable (color)
+    fi  (name) val;
+  enddef;
+  def gsetcolor (suffix name) expr val =
+    if     boolean   val :  boolean name;
+    elseif numeric   val :  numeric name;
+    elseif rgbcolor  val :  rgbcolor name;
+    elseif cmykcolor val :  cmykcolor name;
+    else:  color name;
+    fi  name := val;
+  enddef;
+else:
+  def setrgbcolor  =  setcolor  enddef;
+  def setcmykcolor =  setcolor  enddef;
+  def setcolor = setvariable (color) enddef;
+  def gsetcolor = gsetvariable (color) enddef;
+fi
+
+setcolor(rgbblack) rgb(0,0,0);
+setcolor(red)      rgb(1,0,0);
+setcolor(green)    rgb(0,1,0);
+setcolor(blue)     rgb(0,0,1);
+setcolor(rgbwhite) rgb(1,1,1);
+setcolor(cmykwhite) cmyk(0,0,0,0);
+setcolor(cyan)      cmyk(1,0,0,0); % Maybe these should
+setcolor(magenta)   cmyk(0,1,0,0); % be rbg for backward
+setcolor(yellow)    cmyk(0,0,1,0); % compatibility?
+setcolor(cmykblack) cmyk(0,0,0,1);
+setcolor(grayscaleblack) gray(0);
+setcolor(grayscalewhite) gray(1);
+
+if has_outputtemplate:
+  def setoutputtemplate =  outputtemplate :=  enddef;
+elseif has_filenametemplate:
+  def setoutputtemplate =  filenametemplate  enddef;
+else:
+  def setoutputtemplate text garbage =  enddef;
+fi
+
+def romannumeral =  _romannumeral (true)  enddef;
+vardef _romannumeral (expr prefix, X) =
+  save Y, _tmp, U; string U;
+
+  Y.m := X div 1000;        % thousands digit
+    _tmp := X - 1000Y.m;    % hundreds digits and lower
+  Y.c := _tmp div 100;      % hundreds
+    _tmp := _tmp - 100Y.c;  % tens and units
+  Y.x := _tmp div 10;       % tens
+  Y.i := _tmp - 10Y.x;      % units
+
+  strrepeat("m", Y.m) &
+  romandigit(prefix, "c", "d", "m", Y.c) &
+  romandigit(prefix, "x", "l", "c", Y.x) &
+  romandigit(prefix, "i", "v", "x", Y.i)
+enddef;
+
+vardef romandigit (expr prefix, bot, mid, top, n) =
+  if n > 9 :    top & strrepeat(bot, n-10)   % shouldn't happen
+  elseif n > 8 :
+    if prefix:  bot & top                    % "ix"
+    else:       mid & bot & bot & bot & bot  % "viiii"
+    fi
+  elseif n > 4 :  mid & strrepeat (bot, n-5) % "v"--"viii"
+  elseif n > 3 :
+    if prefix:  bot & mid                    % "iv"
+    else:       bot & bot & bot & bot        % "iiii"
+    fi
+  else:         strrepeat (bot, n)           % ""--"iii" for 0--3
+  fi
+enddef;
+
+vardef strrepeat (expr st, rep) =
+  setstring (_sr) "";
+  for i = 1 upto rep:  _sr := _sr & st;  endfor
+  _sr
+enddef;
+
 transform ztr, vtr;
 def setztr =
   if debug:
@@ -530,7 +710,6 @@ 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 := makepicture (s);
@@ -702,6 +881,7 @@ 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;
@@ -713,12 +893,6 @@ 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 (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 =
   setnumeric (temp) 2 exp (-abs(X));
   if temp < reallysmall:
@@ -786,6 +960,20 @@ vardef atanh primary y =
   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 conj primary Z = (xpart Z, -ypart Z) enddef;
+
+vardef Moebius (expr A) primary Z =
+  save _D; pair _D;
+  _D := (1, 0) + (Z zscaled (conj A));
+  (Z + A)/(abs _D) rotated (- angle _D)
+enddef;
+vardef pshdist (expr Z,W) =  abs(Moebius(-W)(Z))  enddef;
+
 vardef polar primary p =  (xpart p) * dir (ypart p)  enddef;
 def id (expr x) =  x  enddef;
 
@@ -797,8 +985,10 @@ primarydef x**y =
   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:
@@ -1118,7 +1308,7 @@ enddef;
 def store (suffix fs) expr f =
 hide (
   if (not path f) and (not pair f):
-    GBerrmsg ("improper expression type.")
+    GBerrmsg ("Improper expression type.")
       "The second argument to `store' must be a path or pair.";
   fi
   if not path fs:  path fs;  fi
@@ -1371,7 +1561,6 @@ vardef gendashed (suffix pat) expr f =
         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:
@@ -1643,6 +1832,7 @@ vardef axis@# (expr len) =  headpath (len, 0, 0) axisline@#  enddef;
 vardef borderrect =
   rect((xneg+laxis,yneg+baxis),(xpos-raxis,ypos-taxis))
 enddef;
+
 numeric inside, outside, centered, onleft, onright, ontop, onbottom;
 inside   := -2;
 outside  := -1;
@@ -1945,12 +2135,27 @@ enddef;
 
 vardef turtle (text t) =
   setnumeric (_tu) 0;
-  pair _tu[];  _tu0 := origin;
-  for _a = t:  _tu[incr _tu] := _tu[_tu - 1] + _a;  endfor
+  setpair (_tmp) origin;
+  pair _tu[];
+  for _a = t:
+    _tmp := _tmp + _a;
+    _tu[incr _tu] := _tmp;
+  endfor
   if _tu = 0:  NoPoints("turtle", _tu);  fi
   mkpoly (false, _tu)
 enddef;
 
+vardef brownianpath (expr start, num, sc) =
+  setnumeric (_brp) 1;
+  setpair (_tmp) start;
+  pair _brp[];  _brp1 := _tmp;
+  for _idx := 1 upto num:
+    _tmp := _tmp + sc/(sqrt 2)*(normaldeviate,normaldeviate);
+    _brp[incr _brp] := _tmp;
+  endfor
+  mkpoly (false, _brp)
+enddef;
+
 vardef mksmooth (expr tens, cyclic) (suffix pts) =
   if pts = 1:  onepointpath (cyclic, pts1)
   else:
@@ -2055,7 +2260,7 @@ enddef;
 
 vardef mkqbezier (expr cyclic) (suffix pts) =
   pts1
-  if pts=1:  {0,0}
+  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] ]..
@@ -2070,8 +2275,7 @@ enddef;
 
 vardef qbezier (expr cyclic) (text t) =
   setpairs (_qbz) (t);
-  if _qbz=0:  NoPoints ("qbezier", _qbz);  fi
-  if _qbz=1:  onepointpath (cyclic, _qbz1)
+  if _qbz=0:  NoPoints ("qbezier", _qbz);
   else:
     if (cyclic and odd _qbz) or (not cyclic and even _qbz):
       _qbz[incr _qbz] := _qbz[_qbz-1];
@@ -2080,6 +2284,45 @@ vardef qbezier (expr cyclic) (text t) =
   fi
 enddef;
 
+vardef mkcbezier (expr cyclic) (suffix pts) =
+  pts1
+  if pts=1:  {0,0}
+  else:
+    for _i = 1 step 3 until pts - 3:
+      ..controls pts[_i+1] and pts[_i+2] .. pts[_i+3]
+    endfor
+    if cyclic:
+      ..controls  pts[pts - 1] and pts[pts]..cycle
+    fi
+  fi
+enddef;
+
+vardef cbezier (expr cyclic) (text t) =
+  setpairs (_cbz) (t);
+  if _cbz=0:  NoPoints ("qbezier", _cbz);
+  else:
+    % Need 0 mod 3 for cyclic, otherwise 1 mod 3
+    setnumeric (_mdt) _cbz mod 3;
+    if cyclic:
+      if _mdt <> 0:  _cbz[incr _cbz] := _cbz[_cbz-1];  fi
+      if _mdt = 1 :  _cbz[incr _cbz] := _cbz1;  fi
+    else: % need 1 more, duplicate next to last
+      if _mdt = 0:
+        _cbz := _cbz + 1;
+        _cbz[_cbz]   := _cbz[_cbz-1];
+        _cbz[_cbz-1] := _cbz[_cbz-2];
+      fi
+      if _mdt = 2: % need 2 more, duplicate last 2.
+        _cbz := _cbz + 2; % add 2 slots
+        _cbz[_cbz]   := _cbz[_cbz-2]; % fill them
+        _cbz[_cbz-1] := _cbz[_cbz-2]; % with last node
+        _cbz[_cbz-2] := _cbz[_cbz-3]; % orig last slot = orig previous.
+      fi
+    fi
+    mkcbezier (cyclic) (_cbz)
+  fi
+enddef;
+
 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
@@ -2127,6 +2370,7 @@ vardef qspline (expr cyclic) (text t) =
   fi
   mkqbs (_qs) if cyclic:  & cycle  fi
 enddef;
+
 vardef mkcbs (suffix b) =
   (b[1]+4b[2]+b[3])/6
   if b < 4:  {0,0}
@@ -2155,6 +2399,7 @@ vardef cspline (expr cyclic) (text t) =
   fi
   mkcbs (_cs) if cyclic:  & cycle  fi
 enddef;
+
 def init_spline_eqns (suffix pts) =
   save _spl_pre, _spl_post;
   pair _spl_pre[], _spl_post[];
@@ -2299,9 +2544,12 @@ vardef arcpps (expr begpt, endpt, sweep) =
 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));
+  save full, diam, chord, ang;
+  full := signof (rad) 360;
+  diam  := 2rad;
+  chord := abs(endpt-begpt);
+  if chord < abs(diam):
+    ang := if not small:  full -  fi  2*asin (chord/diam);
   else:  ang := signof (rad) 180;
   fi
   arcpps (begpt, endpt, ang)
@@ -2331,30 +2579,37 @@ vardef ellipse (expr center, radx, rady, angle) =
   fullcircle xscaled (2*radx) yscaled (2*rady) rotated angle
     shifted center
 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) =
   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;
   full := signof (sweep) 360;
   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[];
   n := length p;
@@ -2404,6 +2659,54 @@ vardef ninepointcircle expr t =
   circleppp (medianpt 0 of t, medianpt 1 of t, medianpt 2 of t)
 enddef;
 
+vardef pshcircle (expr disk, ctr, rad) =
+  if disk:
+    if rad >= 1 :
+      if rad > 1:
+        GBerrmsg ("Impossible pseudohyperbolic circle.")
+          "The radius of a pseudohyperbolic circle can be at most 1.";
+      fi
+      circle ((0,0),1)
+    elseif abs(ctr) >= 1 :
+      if abs(ctr) > 1:
+        GBerrmsg ("Impossible pseudohyperbolic circle.")
+          "The center of a pseudohyperbolic circle must be in"
+          & "the unit disk.";
+      fi
+      onepointpath (true,ctr)
+    else:
+      % compute Euclidean center and radius (and a denominator used twice
+      % in calculations).
+      save _r, _dnm;
+      _r := abs(ctr);
+      _dnm := 1 - _r*_r*rad*rad;
+      circle ( (1 - rad*rad)/_dnm*ctr, rad*(1 - _r*_r)/_dnm)
+    fi
+  else:
+    if rad >= 1 :
+      GBerrmsg ("Impossible pseudohyperbolic circle.")
+        "The radius of a pseudohyperbolic circle must be less than 1.";
+      onepointpath (true,ctr)
+    elseif ypart ctr <= 0:
+      if ypart ctr < 0:
+        GBerrmsg ("Impossible pseudohyperbolic circle.")
+          "The center of a pseudohyperbolic circle must be in"
+          & "the upper half-plane.";
+      fi
+      onepointpath (true,ctr)
+    else:
+      % compute Euclidean center and radius (and a denominator used twice
+      % in calculations).
+      % Euclidean center at  xpart ctr + (1 + R^2)/(1 - R^2)*ypart ctr
+      % Euclidean radius  4R/(1 - R^2)*ypart ctr
+      save _y, _dnm;
+      _y := ypart ctr;
+      _dnm := 1 - rad*rad;
+      circle ( (xpart ctr, (1 + rad*rad)/_dnm * _y), 2rad/_dnm*_y)
+    fi
+  fi
+enddef;
+
 vardef barycenter expr t =
   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
@@ -2478,8 +2781,10 @@ 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) =
@@ -2606,6 +2911,7 @@ vardef qbclosed expr f =
 enddef;
 
 vardef makesector expr p =  (pathcenter p)--p--cycle  enddef;
+
 vardef arccomplement expr p =
   if cycle p:  onepointpath (false, pnt0(p))
   else:
@@ -2763,6 +3069,8 @@ vardef colorGheadpath
   f
 enddef;
 
+path cut_path;  cut_path := (.5,0)--(.5,.71)--(-.5,.71)--(-.5,0)--cycle;
+
 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):
@@ -2878,6 +3186,7 @@ vardef randomlines (expr maxshift) expr f =
       fi
   fi
 enddef;
+
 vardef parasegment (expr d, segs, f) =
   if d = 0:  f
   else:
@@ -3013,7 +3322,7 @@ def setdatasymbols (text lst) =
       __type[__type] := _itm;
       next __type;
     else:
-      GBwarn "Improper path in setdatasymbols().";
+      GBwarn "Improper symbol in setdatasymbols().";
     fi
   endfor
   if __type > 1:
@@ -3117,6 +3426,7 @@ forsuffixes S =
  SolidDiamond, SolidStar :
   S.tip := point 0 of S;
 endfor
+
 vardef gcd (expr n, m) =
   save a, b, r;
   a := emax (abs(m), abs(n));
@@ -3134,11 +3444,9 @@ vardef gcd (expr n, m) =
 enddef;
 
 vardef lcm (expr n, m) =
-  n*m/gcd(n, m)
+  n/gcd(n, m)*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,
@@ -3147,39 +3455,57 @@ enddef;
 defaultsymbols;
 
 def setdatacolors (text lst) =
-  save __type;  color __type[];
-  __type := 0;
+  setnumeric (__type) 0;
+  % First, just count and store the known colors in the list
   for _itm = lst:
-    if (known _itm) and (color _itm):
-      __type[__type] := _itm;
+    if knowncolor _itm :
+      if __type = 0 :  def _datacolors =  _itm  enddef;
+      else:
+        expandafter  def
+        expandafter _datacolors
+        expandafter =  _datacolors, _itm enddef;
+      fi
       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];
+    save colortype, _tmpstr;
+    colortype := 0;
+    % colortype[] is an array of strings:
+    string colortype[], _tmpstr;
+    for _itm = _datacolors: %
+    % Each string is the name of some color variable
+      _tmpstr := "colortype_"&romannumeral(colortype);
+      setcolor (scantokens(_tmpstr)) _itm;
+      colortype[colortype] := _tmpstr;
+      next colortype;
     endfor
   else:
     SetdataWarn "colors";
   fi
 enddef;
-def getcolor expr n =  colortype[n mod colortype]  enddef;
+def getcolor expr n = (scantokens (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;  string colortype[];
 
-numeric colortype;  color colortype[];
+setcolor (dRed)     (1, 0, 0);
+setcolor (dBlue)    (.2,.2,1);
+setcolor (dOrange)  (1,.34,0);
+setcolor (dGreen)   (0,.80,0);
+setcolor (dBlack)     cmykblack;
+if has_cmyk :
+  setcolor (dCyan)    cyan;
+  setcolor (dMagenta) magenta;
+  setcolor (dYellow)  yellow;
+else: % rgb colors seem to be lighter than the cmyk equivalents.
+  setcolor (dCyan)    cmyk(.85,0,0,.15);
+  setcolor (dMagenta) cmyk(0,.85,0,.15);
+  setcolor (dYellow)  cmyk(0,0,.85,.15);
+fi
 def defaultcolors =
-  setdatacolors(black, red, dBlue, dOrange, dGreen,
-    dMagenta, dCyan, dYellow);
+  setdatacolors(dBlack, dRed, dBlue, dOrange,
+    dGreen, dMagenta, dCyan, dYellow);
 enddef;
 defaultcolors;