From 2a2e86e6c2022e3925e0ee62f5c7b66bbec03338 Mon Sep 17 00:00:00 2001
From: Hans Hagen <pragma@wxs.nl>
Date: Tue, 27 Mar 2001 00:00:00 +0200
Subject: stable 2001.03.27

---
 metapost/context/metafun.mp |   3 +-
 metapost/context/mp-char.mp |   6 +-
 metapost/context/mp-grph.mp | 241 ++++++++++++++++++++++++++++++++++
 metapost/context/mp-spec.mp |  83 ++++++++++++
 metapost/context/mp-tool.mp | 306 +++++++++++++++++++++++++++++++++++++++-----
 5 files changed, 606 insertions(+), 33 deletions(-)
 create mode 100644 metapost/context/mp-grph.mp

(limited to 'metapost')

diff --git a/metapost/context/metafun.mp b/metapost/context/metafun.mp
index 802264351..e8fd1a762 100644
--- a/metapost/context/metafun.mp
+++ b/metapost/context/metafun.mp
@@ -20,7 +20,7 @@
 %D \type {context} (the \TEX\ one) could lead to lost strings
 %D (and as a result in buggy boundingbox and special
 %D handling). By using the name \type {metatex} we make sure
-%D %D that we use (unless overloaded) the settings of \type
+%D that we use (unless overloaded) the settings of \type
 %D {mpost}. 
 
 if unknown ahangle : 
@@ -37,5 +37,6 @@ input mp-text.mp ;
 input mp-shap.mp ; 
 input mp-butt.mp ; 
 input mp-char.mp ; 
+input mp-grph.mp ; 
 
 dump ; endinput .
diff --git a/metapost/context/mp-char.mp b/metapost/context/mp-char.mp
index 8c0d53f75..373200fc2 100644
--- a/metapost/context/mp-char.mp
+++ b/metapost/context/mp-char.mp
@@ -331,7 +331,7 @@ def collapse_points =
   fi ;
 enddef ;
 
-vardef smoothed (expr a,b) =
+vardef smooth_connection (expr a,b) =
   sx := connection_smooth_size/grid_width ;
   sy := connection_smooth_size/grid_height ;
   if ypart a = ypart b :
@@ -377,9 +377,9 @@ vardef connection_path =
   if reverse_connection : reverse fi (xypoints[1]--
   for i=2 upto xypoint-1 :
     if smooth :
-      smoothed(xypoints[i],xypoints[i-1])  ..
+      smooth_connection(xypoints[i],xypoints[i-1])  ..
       controls xypoints[i] and xypoints[i] ..
-      smoothed(xypoints[i],xypoints[i+1])  --
+      smooth_connection(xypoints[i],xypoints[i+1])  --
     else :
       xypoints[i]--
     fi
diff --git a/metapost/context/mp-grph.mp b/metapost/context/mp-grph.mp
new file mode 100644
index 000000000..26202d61a
--- /dev/null
+++ b/metapost/context/mp-grph.mp
@@ -0,0 +1,241 @@
+%D \module
+%D   [       file=mp-grph.mp,
+%D        version=2000.12.14,
+%D          title=\CONTEXT\ \METAPOST\ graphics,
+%D       subtitle=graphic text support, 
+%D         author=Hans Hagen,
+%D           date=\currentdate,
+%D      copyright={PRAGMA / Hans Hagen \& Ton Otten}]
+%C
+%C This module is part of the \CONTEXT\ macro||package and is
+%C therefore copyrighted by \PRAGMA. See licen-en.pdf for 
+%C details. 
+
+%D Under construction.
+
+if unknown context_tool :    input mp-tool ; fi ; 
+if   known context_grph : endinput         ; fi ; 
+
+boolean context_grph ; context_grph := true ; 
+
+string CRLF ; CRLF := char 10 & char 13 ; 
+
+picture _currentpicture_ ; 
+
+def protectgraphicmacros = 
+  save showtext ; 
+  save beginfig ; let beginfig = begingraphictextfig ;
+  save endfig   ; let endfig   = endgraphictextfig ;
+  save end      ; let end      = relax ; 
+  interim prologues := prologues ; 
+  interim linecap   := butt ; 
+  interim linejoin  := mitered ; 
+enddef ; 
+
+numeric currentgraphictext ; currentgraphictext := 0 ; 
+string  graphictextformat  ; graphictextformat  := "plain" ;
+string  graphictextstring  ; graphictextstring  := "" ; 
+string  graphictextfile    ; graphictextfile    := "dummy.mpo" ;
+
+def savegraphictext (expr str) = 
+  graphictextfile := jobname & ".mpo" ;
+  if (graphictextstring<>"") :
+    write graphictextstring to graphictextfile ;
+    graphictextstring := "" ; 
+  fi ; 
+  write str to graphictextfile ;
+  let erasegraphictextfile = relax ; 
+enddef ; 
+
+def erasegraphictextfile = 
+  graphictextfile := jobname & ".mpo" ;
+  write EOF to graphictextfile  ;
+  let erasegraphictextfile = relax ; 
+enddef ; 
+
+extra_beginfig := extra_beginfig & "erasegraphictextfile ;" ; 
+
+def begingraphictextfig (expr n) =
+  foundpicture := n ; scratchpicture := nullpicture ;
+enddef ;
+
+def endgraphictextfig =
+  if foundpicture = currentgraphictext : 
+    expandafter endinput 
+  else : 
+    scratchpicture := nullpicture ; 
+  fi ;
+enddef ;
+
+% def loadfigure (expr filename, n) =
+%   begingroup ;
+%   protectgraphicmacros ; % also save linewidth, color, options etc ?
+%   save sp ; picture sp ; sp := currentpicture ; 
+%   save ok ; boolean ok ; ok := false ; 
+%   def beginfig (expr m) = 
+%    if n=m : 
+%      currentpicture := sp ; ok := true ;
+%      def endfig = endinput ; enddef ; 
+%    else : 
+%      currentpicture := nullpicture ; 
+%    fi ; 
+%   enddef ; 
+%   let endfig = relax ; 
+%   readfile(filename) ; 
+%   if not ok : currentpicture := sp ; fi ; 
+%   endgroup ;
+% enddef ;
+
+def loadfigure primary filename = 
+  doloadfigure (filename) 
+enddef ; 
+
+def doloadfigure (expr filename) text figureattributes =
+  begingroup ;
+  save figurenumber, figurepicture, number ; 
+  numeric figurenumber  ; figurenumber  := 1 ; 
+  picture figurepicture ; figurepicture := currentpicture ; 
+  def number primary n = hide(figurenumber := n) enddef ; 
+  protectgraphicmacros ; 
+  currentpicture := nullpicture ; 
+  def beginfig (expr n) = 
+    currentpicture := nullpicture ; 
+    if figurenumber=n : let endfig = endinput ; fi ; 
+  enddef ; 
+  let endfig = relax ; 
+  readfile(filename) ; 
+  currentpicture := currentpicture shifted -llcorner currentpicture ;   
+  addto figurepicture also currentpicture figureattributes ;   
+  currentpicture := figurepicture  ; 
+  endgroup ;
+enddef ;
+
+def graphictext primary t =
+  dographictext(t)
+enddef ;
+
+def dographictext (expr t) text x_op_x =
+  begingroup ;
+  protectgraphicmacros ; 
+  if graphictextformat<>"" :
+    graphictextstring := 
+      "% format=" & graphictextformat & CRLF & graphictextstring ;
+    graphictextformat := "" ; 
+  fi ;
+  let normalwithshade = withshade ; 
+  save foundpicture, scratchpicture, str ;
+  save fill, draw, withshade, reversefill, outlinefill ;
+  numeric foundpicture ; picture scratchpicture ; string str ; 
+  currentgraphictext := currentgraphictext + 1 ;
+  savegraphictext ("\startTEXpage[scale=10000]" & t & "\stopTEXpage") ;
+  def draw expr p =
+    addto scratchpicture doublepath p withpen currentpen ;
+  enddef ;
+  def fill expr p =
+    addto scratchpicture contour p withpen currentpen ;
+  enddef ;
+  def f_op_f = enddef ; boolean f_color ; f_color := false ; 
+  def d_op_d = enddef ; boolean d_color ; d_color := false ; 
+  def s_op_s = enddef ; boolean s_color ; s_color := false ; 
+  boolean reverse_fill ; reverse_fill := false ;  
+  boolean outline_fill ; outline_fill := false ;  
+  def reversefill = 
+    hide(reverse_fill := true ) 
+  enddef ; 
+  def outlinefill = 
+    hide(outline_fill := true ) 
+  enddef ; 
+  def withshade primary c =
+    hide(def s_op_s = normalwithshade c enddef ; s_color := true )
+  enddef ;
+  def withfillcolor primary c =
+    hide(def f_op_f = withcolor c enddef ; f_color := true )
+  enddef ;
+  def withdrawcolor primary c =
+    hide(def d_op_d = withcolor c enddef ; d_color := true )
+  enddef ;
+  scratchpicture := nullpicture ;
+  addto scratchpicture doublepath origin x_op_x ; % pre-roll
+  for i within scratchpicture : % Below here is a dirty tricky test! 
+    if (urcorner dashpart i) = origin : outline_fill := false ; fi ; 
+  endfor ; 
+  scratchpicture := nullpicture ;
+  readfile(jobname & ".mpy") ; 
+  scratchpicture := (scratchpicture shifted -llcorner scratchpicture) scaled (1/10) ;
+  if not d_color and not f_color : d_color := true ; fi 
+  if s_color : d_color := false ; f_color := false ; fi ; 
+  if d_color and not reverse_fill : 
+    for i within scratchpicture : 
+      if f_color and outline_fill : 
+        addto currentpicture doublepath pathpart i _op_ x_op_x f_op_f 
+          dashed nullpicture ;
+      fi ; 
+      if filled i : 
+        addto currentpicture doublepath pathpart i _op_ x_op_x d_op_d ;
+      fi ; 
+    endfor ;
+  fi ;
+  if f_color : 
+    for i within scratchpicture :
+      if filled i : 
+        addto currentpicture contour pathpart i _op_ x_op_x f_op_f 
+          withpen pencircle scaled 0 ; 
+      fi ; 
+    endfor ;
+  fi ;
+  if d_color and reverse_fill : 
+    for i within scratchpicture :
+      if filled i : 
+        addto currentpicture doublepath pathpart i _op_ x_op_x d_op_d ;
+      fi ; 
+    endfor ;
+  fi ;
+  if s_color : 
+    for i within scratchpicture :
+      if filled i : 
+        addto currentpicture contour pathpart i _op_ x_op_x s_op_s ;
+      fi ; 
+    endfor ;
+  else : 
+    for i within scratchpicture :
+      if stroked i : 
+        addto currentpicture doublepath pathpart i _op_ x_op_x d_op_d ;
+      fi ; 
+    endfor ;
+  fi ; 
+  endgroup ;
+enddef ;
+
+def resetgraphictextdirective = 
+  graphictextstring := "" ; 
+enddef ; 
+
+def graphictextdirective text t = 
+  graphictextstring := graphictextstring & t & CRLF ; 
+enddef ; 
+
+endinput  
+
+% example
+
+input mp-grph ; 
+
+  graphictextformat := "context" ; 
+% graphictextformat := "plain" ; 
+% graphictextformat := "latex" ; graphictextdirective "\documentclass[]{article}" ;
+
+beginfig (1) ;
+  graphictext
+    "\vbox{\hsize10cm \input tufte }"
+    scaled 8
+    withdrawcolor blue
+    withfillcolor red
+    withpen pencircle scaled 2pt ;
+endfig ; 
+
+beginfig(1) ; 
+  loadfigure "gracht.mp" rotated 20 ; 
+  loadfigure "koe.mp" number 1 scaled 2 ; 
+endfig ; 
+
+end
diff --git a/metapost/context/mp-spec.mp b/metapost/context/mp-spec.mp
index 7fa743cbc..b23164c14 100644
--- a/metapost/context/mp-spec.mp
+++ b/metapost/context/mp-spec.mp
@@ -144,4 +144,87 @@ primarydef p withshade sc =
   p withcolor (_special_signal_/1000,_color_counter_/1000,sc/1000) 
 enddef ; 
 
+%D Figure inclusion. 
+
+numeric cef ; cef := 0 ; 
+
+def externalfigure primary filename = 
+  doexternalfigure (filename) 
+enddef ; 
+
+def doexternalfigure (expr filename) text transformation = 
+  begingroup ; save p, t ; picture p ; transform t ; 
+  p := nullpicture ; t := identity transformation ; 
+  flush_special(10, 9,
+    dddecimal (xxpart t, yxpart t, xypart t) & " " & 
+    dddecimal (yypart t,  xpart t,  ypart t) & " " & filename) ; 
+  addto p contour unitsquare scaled 0 ;
+  setbounds p to unitsquare transformed t ;   
+  _color_counter_ := _color_counter_ + 1 ; cef := cef + 1 ; 
+  draw p withcolor (_special_signal_/1000,_color_counter_/1000,cef/1000) ;
+  endgroup ; 
+enddef ; 
+
+%D Experimental: 
+
+numeric currenthyperlink ; currenthyperlink := 0 ; 
+
+def hyperlink primary t = dohyperlink(t) enddef ;
+def hyperpath primary t = dohyperpath(t) enddef ;
+
+def dohyperlink (expr destination) text transformation  = 
+  begingroup ; save somepath ; path somepath ; 
+  somepath := fullsquare transformation ; 
+  dohyperpath(destination) somepath ;
+  endgroup ; 
+enddef ; 
+
+def dohyperpath (expr destination) expr somepath = 
+  begingroup ; 
+  flush_special(20, 7,
+    ddecimal (xpart llcorner somepath, ypart llcorner somepath) & " " & 
+    ddecimal (xpart urcorner somepath, ypart urcorner somepath) & " " & destination) ; 
+  _color_counter_ := _color_counter_ + 1 ; 
+  currenthyperlink := currenthyperlink + 1 ; 
+  fill boundingbox unitsquare scaled 0 
+    withcolor 
+    (_special_signal_/1000,_color_counter_/1000,currenthyperlink/1000) ;
+  endgroup ; 
+enddef ; 
+
+% \setupinteraction[state=start]
+% \setupcolors     [state=start]
+% 
+% Hello There! \blank 
+% 
+% \startMPcode 
+% pickup pencircle scaled 5 ; 
+% draw fullcircle scaled 4cm withcolor red ;  
+% hyperpath "nextpage" boundingbox currentpicture ; 
+% draw origin withcolor blue ;
+% \stopMPcode
+% 
+% \blank Does it work or not? 
+% 
+% \startMPcode 
+% pickup pencircle scaled 5 ; 
+% draw fullcircle scaled 4cm withcolor red ;  
+% hyperpath "nextpage" fullcircle scaled 4cm ; 
+% draw origin withcolor blue ;
+% draw fullcircle scaled 4cm shifted (1cm,1cm);  
+% \stopMPcode
+% 
+% \blank Does it work or not? \page Hello There! \blank 
+% 
+% \startMPcode 
+% pickup pencircle scaled 5 ; 
+% draw fullcircle scaled 2cm shifted (-2cm,-1cm) ;  
+% draw fullcircle scaled 3cm shifted (2cm,1cm) withcolor red ;  
+% draw fullcircle scaled 1cm ;  
+% hyperlink "previouspage" scaled 3cm shifted (2cm,1cm) ; 
+% draw origin withcolor blue ; 
+% \stopMPcode
+% 
+% \blank Does it work or not?  
+
 endinput ; 
diff --git a/metapost/context/mp-tool.mp b/metapost/context/mp-tool.mp
index a3ad4927e..958cc3903 100644
--- a/metapost/context/mp-tool.mp
+++ b/metapost/context/mp-tool.mp
@@ -107,7 +107,7 @@ def stopsavingdata =
 enddef ;
 
 %D Instead of a keystroke eating save and allocation 
-%D sequence, you can use the \quote {new} alternatives to 
+%D sequence, you can use the \citeer {new} alternatives to 
 %D save and allocate in one command. 
 
 def newcolor     text v = forsuffixes i=v : save i ; color     i ; endfor ; enddef ;
@@ -527,6 +527,13 @@ enddef ;
 %   (-width/2,+height/2)..(-width/2-offset,0)..(-width/2,-height/2)..cycle)
 %enddef ;
 
+vardef roundedsquare (expr width, height, offset) =
+  ((offset,0)--(width-offset,0){right}          ..
+   (width,offset)--(width,height-offset){up}    ..
+   (width-offset,height)--(offset,height){left} ..
+   (0,height-offset)--(0,offset){down}          .. cycle)  
+enddef ;
+
 %D Some colors.
 
 color cyan    ; cyan    = (0,1,1) ;
@@ -635,13 +642,32 @@ primarydef p randomshifted s =
   endgroup 
 enddef ; 
 
+%primarydef p randomized s =
+%  for i=0 upto length(p)-1 : 
+%   ((point       i    of p) randomshifted s) .. controls 
+%   ((postcontrol i    of p) randomshifted s) and 
+%   ((precontrol (i+1) of p) randomshifted s) .. 
+%  endfor cycle 
+%enddef ;
+
 primarydef p randomized s =
-  for i=0 upto length(p)-1 : 
-   ((point       i    of p) randomshifted s) .. controls 
-   ((postcontrol i    of p) randomshifted s) and 
-   ((precontrol (i+1) of p) randomshifted s) .. 
-  endfor cycle 
-enddef ;
+  (if path p : 
+    for i=0 upto length(p)-1 :
+      ((point       i    of p) randomshifted s) .. controls 
+      ((postcontrol i    of p) randomshifted s) and 
+      ((precontrol (i+1) of p) randomshifted s) .. 
+    endfor 
+    if cycle p : 
+      cycle 
+    else :
+      ((point length(p) of p) randomshifted s) 
+    fi
+  elseif pair p :
+   p randomshifted s  
+  else :
+   p + uniformdeviate s  
+  fi)  
+enddef ; 
 
 %D Rather fundamental. 
 
@@ -982,12 +1008,31 @@ vardef thefreelabel (expr str, loc, ori) =
   setbounds s to boundingbox s enlarged freelabeloffset ; 
   p := fullcircle scaled (2*length(loc-ori)) shifted ori ;
   q := freesquare xyscaled (urcorner s - llcorner s) ;
-  l := point (xpart (p intersectiontimes (ori--loc))) of q ;
-setbounds s to boundingbox s enlarged -freelabeloffset ; % new  
+%  l := point (xpart (p intersectiontimes (ori--loc))) of q ;
+  l := point xpart (p intersectiontimes 
+   (ori--((1+eps)*arclength(ori--loc)*unitvector(loc-ori)))) of q ;
+  setbounds s to boundingbox s enlarged -freelabeloffset ; % new  
  %draw boundingbox s shifted -l withpen pencircle scaled .5pt withcolor red ; 
   (s shifted -l) 
 enddef ; 
 
+% better? 
+
+vardef thefreelabel (expr str, loc, ori) =
+  save s, p, q, l ; picture s ; path p, q ; pair l ;
+  interim labeloffset := freelabeloffset ;
+  s := if string str : thelabel(str,loc) else : str shifted -center str shifted loc fi ;
+  setbounds s to boundingbox s enlarged freelabeloffset ;
+  p := fullcircle scaled (2*length(loc-ori)) shifted ori ;
+  q := freesquare xyscaled (urcorner s - llcorner s) ;
+  l := point xpart (p intersectiontimes (ori--loc shifted (loc-ori))) of q ;
+  setbounds s to boundingbox s enlarged -freelabeloffset ; % new
+  draw boundingbox s shifted -l withpen pencircle scaled .5pt withcolor red ;
+  (s shifted -l)
+enddef ;
+
+
+
 vardef freelabel (expr str, loc, ori) = 
   draw thefreelabel(str,loc,ori) ;
 enddef ; 
@@ -1006,35 +1051,85 @@ enddef ;
 numeric anglelength ; anglelength := 20pt ;
 numeric anglemethod ; anglemethod :=    1 ;
 
-vardef anglebetween (expr a, b, str) = % path path string 
+% vardef anglebetween (expr a, b, str) = % path path string 
+%   save pointa, pointb, common, middle, offset ;
+%   pair pointa, pointb, common, middle, offset ;
+%   save curve ; path curve ; 
+%   save where ; numeric where ; 
+%   if round point 0 of a = round point 0 of b : 
+%     common := point 0 of a ;
+%   else :
+%     common := a intersectionpoint b ;
+%   fi ; 
+%   pointa := point anglelength on a ; 
+%   pointb := point anglelength on b ; 
+%   where  := turningnumber (common--pointa--pointb--cycle) ; 
+%   middle := ((common--pointa) rotatedaround (pointa,-where*90))
+%                             intersectionpoint 
+%             ((common--pointb) rotatedaround (pointb, where*90)) ;  
+%   if     anglemethod = 0 :
+%     curve  := pointa{unitvector(middle-pointa)}.. pointb; 
+%     middle := point .5 along curve ; 
+%     curve  := common ;  
+%   elseif anglemethod = 1 :  
+%     curve  := pointa{unitvector(middle-pointa)}.. pointb; 
+%     middle := point .5 along curve ; 
+%   elseif anglemethod = 2 :  
+%     middle := common rotatedaround(.5[pointa,pointb],180) ; 
+%     curve  := pointa--middle--pointb ; 
+%   elseif anglemethod = 3 :    
+%     curve  := pointa--middle--pointb ; 
+%   elseif anglemethod = 4 :    
+%     curve  := pointa..controls middle..pointb ; 
+%     middle := point .5 along curve ; 
+%   fi ; 
+%   draw thefreelabel(str, middle, common) withcolor black ;
+%   curve
+% enddef ;
+
+vardef anglebetween (expr a, b, str) = % path path string
   save pointa, pointb, common, middle, offset ;
   pair pointa, pointb, common, middle, offset ;
-  save curve ; path curve ; 
-  save where ; numeric where ; 
-  if round point 0 of a = round point 0 of b : 
+  save curve ; path curve ;
+  save where ; numeric where ;
+  if round point 0 of a = round point 0 of b :
     common := point 0 of a ;
   else :
     common := a intersectionpoint b ;
-  fi ; 
-  pointa := point anglelength on a ; 
-  pointb := point anglelength on b ; 
-  where := turningnumber (common--pointa--pointb--cycle) ; 
-  if     anglemethod = 1 :  
-    curve := pointa{pointa rotated (where*90)} .. pointb ; 
-    middle := point .5 along curve ; 
-  elseif anglemethod = 2 :  
-    middle := common rotatedaround(.5[pointa,pointb],180) ; 
-    curve := pointa--middle--pointb ; 
-  elseif anglemethod = 3 :    
-    middle := ((common--pointa) rotatedaround (pointa,-where*90))
-                              intersectionpoint 
-              ((common--pointb) rotatedaround (pointb, where*90)) ;  
-    curve := pointa--middle--pointb ; 
-  fi ; 
+  fi ;
+  pointa := point anglelength on a ;
+  pointb := point anglelength on b ;
+  where  := turningnumber (common--pointa--pointb--cycle) ;
+  middle := (reverse(common--pointa) rotatedaround (pointa,-where*90))
+                            intersection_point
+            (reverse(common--pointb) rotatedaround (pointb, where*90)) ;
+  if not intersection_found :
+    middle := point .5 along
+      ((reverse(common--pointa) rotatedaround (pointa,-where*90)) --
+       (       (common--pointb) rotatedaround (pointb, where*90))) ;
+  fi ;
+  if     anglemethod = 0 :
+    curve  := pointa{unitvector(middle-pointa)}.. pointb;
+    middle := point .5 along curve ;
+    curve  := common ;
+  elseif anglemethod = 1 :
+    curve  := pointa{unitvector(middle-pointa)}.. pointb;
+    middle := point .5 along curve ;
+  elseif anglemethod = 2 :
+    middle := common rotatedaround(.5[pointa,pointb],180) ;
+    curve  := pointa--middle--pointb ;
+  elseif anglemethod = 3 :
+    curve  := pointa--middle--pointb ;
+  elseif anglemethod = 4 :
+    curve  := pointa..controls middle..pointb ;
+    middle := point .5 along curve ;
+  fi ;
   draw thefreelabel(str, middle, common) withcolor black ;
   curve
 enddef ;
 
+
+
 % Stack
 
 picture currentpicturestack[] ; 
@@ -1213,4 +1308,157 @@ enddef ;
 
 def condition primary b = if b : "true" else : "false" fi enddef ; 
 
+% undocumented
+
+primarydef p stretched s = 
+  begingroup
+  save pp ; path pp ; pp := p scaled s ;
+  (pp shifted ((point 0 of p) - (point 0 of pp)))  
+  endgroup
+enddef ; 
+
+% yes or no, untested -) 
+
+def xshifted expr dx = shifted(dx,0) enddef ;  
+def yshifted expr dy = shifted(0,dy) enddef ;  
+
+% also handy 
+
+% right: str = readfrom ("abc" & ".def" ) ; 
+% wrong: str = readfrom  "abc" & ".def"   ;
+
+def readfile (expr name) = 
+  if (readfrom (name) <> EOF) : 
+    scantokens("input " & name & " ") 
+  fi  
+enddef ; 
+
+% permits redefinition of end in macro 
+
+inner end ; 
+
+% real fun
+
+color color_map[][][] ;
+
+%color_map_resolution := 1000 ;
+%
+%def r_color primary c = round(color_map_resolution*redpart   c) enddef ;
+%def g_color primary c = round(color_map_resolution*greenpart c) enddef ;
+%def b_color primary c = round(color_map_resolution*bluepart  c) enddef ;
+
+def r_color primary c = redpart   c enddef ;
+def g_color primary c = greenpart c enddef ;
+def b_color primary c = bluepart  c enddef ;
+
+def remapcolor(expr old, new) =
+  color_map[r_color old][g_color old][b_color old] := new ;
+enddef ;
+
+def remappedcolor(expr c) =
+  if known color_map[r_color c][g_color c][b_color c] :
+    color_map[r_color c][g_color c][b_color c]
+  else :
+    c
+  fi
+enddef ;
+
+let normalwithcolor = withcolor ;
+
+def remapcolors =
+  def withcolor primary c = normalwithcolor remappedcolor(c) enddef ;
+enddef ;
+
+def normalcolors =
+  let withcolor = normalwithcolor ;
+enddef ;
+
+def refill  suffix c = do_repath (1) (c) enddef ;
+def redraw  suffix c = do_repath (2) (c) enddef ;
+def recolor suffix c = do_repath (0) (c) enddef ;
+
+def do_repath (expr mode) (suffix c) text t =
+  begingroup ;
+  if mode=0 : save withcolor ; remapcolors ; fi ; 
+  save _c_, _f_, _b_ ; picture _c_ ; color _f_ ; path _b_ ; 
+  _c_ := c ; _b_ := boundingbox c ; c := nullpicture ; 
+  for i within _c_ : 
+    _f_ := (redpart i, greenpart i, bluepart i) ;
+    if     bounded i : 
+      setbounds c to pathpart i ; 
+    elseif clipped i : 
+      clip c to pathpart i ; 
+    elseif stroked i : 
+      addto c doublepath pathpart i 
+        dashed dashpart i withpen penpart i 
+        withcolor (redpart i, greenpart i, bluepart i) 
+        if mode=2 : t fi ;
+    elseif filled  i : 
+      addto c contour pathpart i 
+      withcolor (redpart i, greenpart i, bluepart i) 
+      if mode=1 : t if _f_ = background : withcolor background fi fi ;
+    fi ;
+  endfor ;   
+  setbounds c to _b_ ; 
+  endgroup ; 
+enddef ; 
+
+% After a question of Denis on how to erase a z variable, Jacko 
+% suggested to assign whatever to x and y. So a clearz 
+% variable can be defined as: 
+%
+% vardef clearz@# = 
+%   x@# := whatever ; 
+%   y@# := whatever ; 
+% enddef ; 
+%
+% but Jacko suggested a redefinition of clearxy: 
+%
+% def clearxy text s =
+%  clearxy_index_:=0; 
+%  for $:=s: 
+%    clearxy_index_:=clearxy_index_+1; endfor;
+%  if clearxy_index_=0: 
+%    save x,y;
+%  else: 
+%    forsuffixes $:=s: x$:=whatever; y$:=whatever; endfor;
+%  fi
+% enddef;
+%
+% which i decided to simplify to: 
+
+def clearxy text s =
+  if false for $ := s : or true endfor : 
+    forsuffixes $ := s : x$ := whatever ; y$ := whatever ; endfor ;
+  else : 
+    save x, y ;
+  fi
+enddef ;
+
+% so now we can say: clearxy ; as well as clearxy 1, 2, 3 ; 
+
+% show x0 ; z0 = (10,10) ; 
+% show x0 ; x0 := whatever ; y0 := whatever ; 
+% show x0 ; z0 = (20,20) ;
+% show x0 ; clearxy 0 ; 
+% show x0 ; z0 = (30,30) ;
+
+primarydef p smoothed d =
+  (p llmoved (-xpart paired(d),0) -- p lrmoved (-xpart paired(d),0) {right} .. 
+   p lrmoved (0,-ypart paired(d)) -- p urmoved (0,-ypart paired(d)) {up}    .. 
+   p urmoved (-xpart paired(d),0) -- p ulmoved (-xpart paired(d),0) {left}  ..
+   p ulmoved (0,-ypart paired(d)) -- p llmoved (0,-ypart paired(d)) {down}  .. cycle) 
+enddef ;
+
+primarydef p cornered c = 
+  ((point 0 of p) shifted (c*(unitvector(point 1 of p - point 0 of p))) -- 
+   for i=1 upto length(p) :
+     (point i-1 of p) shifted (c*(unitvector(point i   of p - point i-1 of p))) -- 
+     (point i   of p) shifted (c*(unitvector(point i-1 of p - point i   of p))) ..
+     controls point i of p .. 
+   endfor cycle) 
+enddef ;
+
+% done 
+
 endinput ;
-- 
cgit v1.2.3