2016-11-24 12:10:00

4 files changed, 377 insertions, 14 deletions

diff --git a/metapost/context/base/mpiv/mp-base.mpiv b/metapost/context/base/mpiv/mp-base.mpiv
index 28eb57fb8..ecc9497da 100644
--- a/metapost/context/base/mpiv/mp-base.mpiv
+++ b/metapost/context/base/mpiv/mp-base.mpiv
@@ -458,8 +458,8 @@ enddef ;
 
 % special operators
 
-vardef incr suffix $ = $:=$+1; $ enddef ;
-vardef decr suffix $ = $:=$-1; $ enddef ;
+vardef incr suffix $ = $ := $ + 1 ; $ enddef ;
+vardef decr suffix $ = $ := $ - 1 ; $ enddef ;
 
 def reflectedabout(expr w,z) = % reflects about the line w..z
     transformed
diff --git a/metapost/context/base/mpiv/mp-mlib.mpiv b/metapost/context/base/mpiv/mp-mlib.mpiv
index 39d74b352..0c7dddf4c 100644
--- a/metapost/context/base/mpiv/mp-mlib.mpiv
+++ b/metapost/context/base/mpiv/mp-mlib.mpiv
@@ -1625,3 +1625,32 @@ enddef ;
 def comment expr str =
     special "metapost.comment[[" & str & "]]" ;
 enddef ;
+
+% This overloads a dummy:
+
+vardef uniquelist(suffix list) =
+    % this can be optimized by passing all values at once and returning
+    % a result but for now this is ok .. we need an undef foo
+    save i, j, h ;
+    if known lis[0] :
+        i := 0 ;
+        j := -1 ;
+    else :
+        i := 1 ;
+        j := 0 ;
+    fi ;
+    h := lua.mp.newhash() ;
+    forever :
+        exitif unknown list[i] ;
+        if not lua.mp.inhash(h,list[i]) :
+            j := j + 1 ;
+            list[j] := list[i] ;
+            lua.mp.tohash(h,list[i]) ;
+        fi ;
+        i := i + 1 ;
+    endfor ;
+    for n = j+1 step 1 until i-1 :
+        dispose(list[n])
+    endfor ;
+    lua.mp.disposehash(h) ;
+enddef ;
diff --git a/metapost/context/base/mpiv/mp-node.mpiv b/metapost/context/base/mpiv/mp-node.mpiv
new file mode 100644
index 000000000..e511ca20c
--- /dev/null
+++ b/metapost/context/base/mpiv/mp-node.mpiv
@@ -0,0 +1,116 @@
+%D \module
+%D   [       file=mp-node.mpiv,
+%D        version=1998.02.15,
+%D          title=\CONTEXT\ \METAPOST\ graphics,
+%D       subtitle=Node Based Graphics,
+%D         author=Alan Braslau,
+%D           date=\currentdate,
+%D      copyright={Alan Braslau & \CONTEXT\ Development Team}]
+%C
+%C This module is part of the \CONTEXT\ macro||package and is
+%C therefore copyrighted by \PRAGMA. See mreadme.pdf for
+%C details.
+
+%D Ths crossing macros were written as part of this module but as they
+%D can be of use elsewhere they are defined in mp-tool.
+
+if known context_node : endinput ; fi ;
+
+boolean context_node ; context_node := true ;
+
+% returns a picture
+
+vardef makenode@#(suffix p)(text t) =
+    save i ; numeric i ;
+    for a = t :
+        if not known i : % first argument is the index
+            i = a ;
+            if not picture p.pic[i] : picture p.pic[] ; fi
+                %
+                % note that one needs to declare "path p[] ; picture p[]pic[] ;"
+                % before calling node() if one is to use a pseudo-array for p
+                % because "picture p1.pic[] ;" is not a valid syntax!
+                %
+        else :
+            if known p.pic[i] :
+                addto p.pic[i] also
+            else :
+                p.pic[i] :=
+            fi
+            if     picture a           : a
+            elseif string  a           : textext@#(a)
+            elseif numeric a           : textext@#(decimal a)
+            elseif ((boolean a) and a) : image(draw origin)
+            else                       : nullpicture
+            fi ;
+        fi
+    endfor
+enddef ;
+
+vardef node@#(suffix p)(text t) =
+    makenode@#(p)(t) ;
+    for a = t :
+        if known p.pic[a] :
+            p.pic[a] if known p : shifted point a of p fi
+        else :
+            nullpicture
+        fi
+        exitif true ;
+    endfor
+enddef ;
+
+% returns a path
+
+vardef fromto@#(expr d)(suffix p)(expr f)(suffix q)(text s) =
+    save r, t, l ;
+    path r[] ; numeric t ; picture l ;
+    for a = s :
+        if not known t :
+            t = a ;
+            r0 = if ((not numeric d) and
+                     (point f of p = point f of q) and
+                     (point t of p = point t of q)) :
+                     subpath (f,t) of p
+                 else :
+                     point f of p -- point t of q
+                 fi ;
+            save deviation ; numeric deviation ;
+            deviation := if numeric d: d else: 0 fi ;
+            r1 = if deviation=0 : r0
+                else :
+                    point 0 of r0 ..
+                    unitvector direction .5length r0 of r0 rotated 90
+                        scaled deviation * arclength r0
+                        shifted point .5length r0 of r0 ..
+                    point length r0 of r0
+                fi ;
+        else :
+            if known l :
+                addto l also
+            else :
+                l :=
+            fi
+                 if     picture a           : a
+                 elseif string a            : textext@#(a)
+                 elseif numeric a           : textext@#(decimal a)
+                 elseif ((boolean a) and a) : image(draw origin withpen currentpen scaled 4)
+                 else                       : nullpicture
+                 fi ;
+        fi
+    endfor
+    r2 = r1
+        if known p.pic[f if cycle p: mod length p fi] :
+            cutbefore boundingbox (p.pic[f if cycle p: mod length p fi] shifted point f of p)
+        fi
+        if known q.pic[t if cycle q: mod length q fi] :
+            cutafter  boundingbox (q.pic[t if cycle q: mod length q fi] shifted point t of q)
+        fi
+        ;
+    if known l :
+        l := l shifted point .5length r2 of r2 ;
+        draw l ;
+        (r2 if str @# = "" : crossingunder l fi)
+    else :
+        r2
+    fi
+enddef ;
diff --git a/metapost/context/base/mpiv/mp-tool.mpiv b/metapost/context/base/mpiv/mp-tool.mpiv
index 3923c283b..ba137c1e9 100644
--- a/metapost/context/base/mpiv/mp-tool.mpiv
+++ b/metapost/context/base/mpiv/mp-tool.mpiv
@@ -104,6 +104,27 @@ vardef image@#(text t) =
     fi
 enddef ;
 
+%D Variables
+
+def dispose suffix s =
+    begingroup ;
+    save ss ;
+    if     numeric   s : numeric   ss
+    elseif boolean   s : boolean   ss
+    elseif pair      s : pair      ss
+    elseif path      s : path      ss
+    elseif picture   s : picture   ss
+    elseif string    s : string    ss
+    elseif transform s : transform ss
+    elseif color     s : color     ss
+    elseif rgbcolor  s : rgbcolor  ss
+    elseif cmykcolor s : cmykcolor ss
+    else             s : numeric   ss
+    fi ;
+    s := ss ;
+    endgroup ;
+enddef ;
+
 %D Colors:
 
 newinternal nocolormodel   ; nocolormodel   := 1 ;
@@ -352,6 +373,42 @@ enddef;
 %     mfun_a_b
 % enddef ;
 
+%D Here are some special ones, cooked up in the process of Alan's mp-node
+%D module:
+
+vardef boundingradius primary p =
+    if picture p :
+        max(
+            abs((llcorner p) shifted -center p),
+            abs((lrcorner p) shifted -center p),
+            abs((urcorner p) shifted -center p),
+            abs((ulcorner p) shifted -center p)
+        )
+    elseif pen p :
+        boundingradius image(draw makepath p ;)
+    elseif path p :
+        boundingradius image(draw p ;)
+    fi
+enddef ;
+
+vardef boundingcircle primary p =
+    fullcircle scaled 2boundingradius p shifted center p
+enddef ;
+
+vardef boundingpoint@#(expr p) =
+    if picture p : % pen?
+        (                 mfun_labxf@# *ulcorner p
+         +                mfun_labyf@# *lrcorner p
+         +(1-mfun_labxf@#-mfun_labyf@#)*urcorner p)
+    elseif path p :
+        boundingpoint@#(image(draw p ;))
+   %elseif pair p :
+   %    p
+   %else :
+   %    origin
+    fi
+enddef ;
+
 %D Some missing functions can be implemented rather straightforward (thanks to
 %D Taco and others):
 
@@ -1501,10 +1558,14 @@ def set_ahlength (text t) =
     ahlength := (ahfactor*pen_size(t)) ;
 enddef ;
 
+% vardef pen_size (text t) =
+%     save p ; picture p ; p := nullpicture ;
+%     addto p doublepath (top origin -- bot origin) t ;
+%     (ypart urcorner p - ypart lrcorner p)
+% enddef ;
+
 vardef pen_size (text t) =
-    save p ; picture p ; p := nullpicture ;
-    addto p doublepath (top origin -- bot origin) t ;
-    (ypart urcorner p - ypart lrcorner p)
+    (ypart top origin - ypart bot origin)
 enddef ;
 
 %D The next two macros are adapted versions of plain
@@ -1595,16 +1656,16 @@ enddef ;
 
 def mfun_with_arrow_path (text t) =
     if autoarrows :
-        set_ahlength(t)
-    fi ;
+        set_ahlength(t) ;
+    fi
     t
     endgroup ;
 enddef ;
 
 def mfun_with_arrow_picture (text t) =
     if autoarrows :
-        set_ahlength(t)
-    fi ;
+        set_ahlength(t) ;
+    fi
     mfun_arrow_count := 0 ;
     mfun_arrow_snippets := stroked_paths(mfun_arrow_picture) ;
     for i within mfun_arrow_picture :
@@ -2978,13 +3039,31 @@ fulltriangle := point 0   along fullcircle
 %D of quick sort routines. Here we have a variant that permits a
 %D method.
 
+% vardef listsize(suffix list) =
+%     numeric len ; len := 0 ;
+%     forever :
+%         exitif unknown list[len+1] ;
+%         len := len + 1 ;
+%     endfor ;
+%     len
+% enddef ;
+
 vardef listsize(suffix list) =
-    numeric len ; len := 0 ;
+    numeric len ; len := 1 ;
+    forever :
+        exitif unknown list[len] ;
+        len := len + 1 ;
+    endfor ;
+    len if unknown list[0] : - 1 fi
+enddef ;
+
+vardef listlast(suffix list) =
+    numeric len ; len := if known list[0] : 0 else : 1 fi  ;
     forever :
-        exitif unknown list[len+1] ;
         len := len + 1 ;
+        exitif unknown list[len] ;
     endfor ;
-    len
+    len - 1
 enddef ;
 
 vardef mfun_quick_sort(suffix list)(expr _min_, _max_)(text what) =
@@ -3024,9 +3103,11 @@ vardef mfun_quick_sort(suffix list)(expr _min_, _max_)(text what) =
 enddef ;
 
 vardef sortlist(suffix list)(text what) =
-    save _max_ ; numeric _max_ ; _max_ := listsize(list) ;
+    save _max_ ; numeric _max_ ;
     save _mid_ ; numeric _mid_ ;
     save temp ;
+  % _max_ := listsize(list) ;
+    _max_ := listlast(list) ;
     if pair list[_max_] :
         pair temp ;
     else :
@@ -3038,10 +3119,15 @@ vardef sortlist(suffix list)(text what) =
         numeric _mid_ ;
     fi ;
     if _max_ > 1 :
-        mfun_quick_sort(list)(1,_max_)(what) ;
+      % mfun_quick_sort(list)(1,_max_)(what) ;
+        mfun_quick_sort(list)(if known list[0] : 0 else : 1 fi,_max_)(what) ;
     fi ;
 enddef ;
 
+vardef uniquelist(suffix list) =
+    % this one will be defined later
+enddef ;
+
 vardef copylist(suffix list, target) =
     save i ; i := 1 ;
     forever :
@@ -3148,3 +3234,135 @@ def do_drawpathwithpoints(expr p) text t =
         draw _p_ ;
     fi ;
 enddef ;
+
+%D These new helpers are by Alan and are used in for instance the mp-node
+%D module.
+
+newinternal crossingoption ; crossingoption := 0 ;
+newinternal crossingscale  ; crossingscale  := 20 ;
+
+% primary, secondary or tertiary? always hard to decide but primary makes sense
+
+vardef infotext(expr txt, ysize) =
+    textext("\infofont" & if numeric txt : decimal fi txt) ysized ysize
+enddef ;
+
+primarydef p crossingunder q =
+    begingroup
+    save pic ; picture pic ; pic := nullpicture ;
+    if picture p :
+        for i within p :
+            if stroked i :
+                addto pic also image(draw pathpart i crossingunder q) ;
+            fi
+        endfor
+    elseif path p :
+        save n, m, t, a, b, c, r, h ;
+        numeric n, m, t[] ;
+        path a, b, c, r, hold[] ;
+        c := makepath(currentpen scaled crossingscale) ;
+        r := if picture q : boundingbox fi q ;
+        t[0] := n := m := 0 ;
+        a := p ;
+save last ; numeric last ; last := infinity ;
+        forever : % find all intersections
+            clearxy ; z = a intersectiontimes r ;
+exitif x = last ; % prevent loop
+last := x ;
+% maybe we need a threshold for x ;
+% message(decimal x & "+" & decimal m) ;
+            if (x < 0) and (m > 0) :
+                a := hold[m] ; m := m - 1 ;
+                clearxy ; z = a intersectiontimes r ;
+            else :
+                exitif x < 0 ;
+            fi
+            (t[incr n], whatever) = p intersectiontimes point x of a ;
+            if x = 0 :
+                a := a cutbefore c shifted point x of a ;
+            elseif x = length a :
+                a := a cutafter  c shifted point x of a ;
+            else : % before or after?
+                b := subpath (0,x) of a cutafter  c shifted point x of a ;
+                a := subpath (x,length a) of a cutbefore c shifted point x of a ;
+                clearxy ; z = a intersectiontimes r ;
+                if x < 0 :
+                    a := b ;
+                else :
+                    clearxy ; z = b intersectiontimes r ;
+                    if x >= 0 :
+                        hold[incr m] := b ;
+                    fi
+                fi
+            fi
+        endfor
+
+        if n = 0 : % No crossings, we return the PATH
+            save pic ; path pic ; pic := p ;
+        else : % n>0
+            sortlist(t,) ;
+            % we add too much, maybe a test is needed
+            t[incr n] = length p if cycle p : + t[1] fi ;
+% save tt[] ; numeric tt[] ; uniquelist(t,tt) ; t := tt ;
+            % Now, n>1 !
+            % t[0] is the first point of the path and t[n] is the last point
+            % (or the first intersection beyond the length if cyclic)
+            m := 0 ;
+            for i=if cycle p: 2 else: 1 fi upto n :
+                % skip the first segment if cyclic
+                % as it gets repeated (fully) at the end.
+                a := subpath (t[i-1],t[i]) of p
+                    if i > 1 :
+                        cutbefore (c shifted point t[i-1] of p)
+                    fi
+                    if (i < n) or (cycle p) :
+                        cutafter  (c shifted point t[i]   of p)
+                    fi ;
+                if (not picture q) or (a outsideof q) :
+                    if crossingoption > 0 :
+                        addto pic also infotext (
+                            if crossingoption = 1 :
+                                incr(m)
+                            elseif crossingoption = 2 :
+                                i if cycle p: -1 fi
+                            fi
+                            ,crossingscale/5)
+                        shifted point t[i] of p ;                        ;
+                    fi ;
+                    addto pic doublepath a withpen currentpen ;
+                fi
+            endfor
+        fi
+    fi
+    pic
+    endgroup
+enddef ;
+
+primarydef p insideof q =
+    begingroup
+        save pth, pic, t ;
+        path pth ; picture pic ;
+        pic := if path q : image(draw q;) else : q fi ;
+        pth := p -- center pic ;
+        (t, whatever) = pth intersectiontimes boundingbox pic ;
+        t < 0
+    endgroup
+enddef ;
+
+primarydef p outsideof q =
+    not (p insideof q)
+enddef ;
+
+%D Also handy:
+
+vardef circularpath(expr n) =
+    reverse (for i=0 step 2/n until 8-2/n+2eps: point i of fullcircle .. endfor cycle) rotated 90
+enddef ;
+
+vardef squarepath(expr n) =
+    for i=0 step 1/n until 4-1/n + 2eps: point i of fullsquare -- endfor cycle
+enddef ;
+
+vardef linearpath(expr n) =
+    origin for i=1/n step 1/n until 1-1/n + 2eps: -- point i of (origin--(1,0)) endfor
+enddef ;