Warning: this is an htmlized version!
The original is across this link,
and the conversion rules are here.
-- diagxy.lua
-- What is this: this file adds support for a forthish front-end to
-- Michael Barr's "diagxy" TeX package (that in its turn is a
-- front-end to xypic) to dednat3.lua. This is usually activated in
-- the following form: if dednat3 finds a line like
--   %L require "diagxy.lua"
-- in the TeX file it is processing it will run ``require "diagxy.lua"''
-- as Lua code, and that will load this and add an entry for "%D" to
-- dednat3's table of "interesting line heads"; after that all lines
-- in the TeX file that start with "%D" will be processed by
-- `diagheadcode', that will interpret what comes after the "%D" as
-- forthish code (see `dofs').

-- «.withoutdednat3»	(to "withoutdednat3")
-- «.nodes-and-arrows»	(to "nodes-and-arrows")
-- «.2D»		(to "2D")
-- «.dofs» 		(to "dofs")
-- «.diagram»		(to "diagram")
-- «.forthwords»	(to "forthwords")
-- «.diaghead»		(to "diaghead")


--%%%%
--%
--% «withoutdednat3»  (to ".withoutdednat3")
--%
--%%%%

-- In case we are loading this without loading dednat3.lua before (for
-- tinkering or debugging), provide dummy versions for some functions
-- and variables from dednat3.

-- (find-angg "dednat/dednat3.lua" "abbrevs")
-- (find-angg "dednat/dednat3.lua" "untabify")
-- (find-angg "dednat/dednat3.lua" "auxtreefunctions")

unabbrev = unabbrev or function (str) return str end
standardabbrevs = standardabbrevs or function () end
optionalhyperlink = optionalhyperlink or function () return "" end
untabify = untabify or function (str) return str end
linen = linen or -2222
sourcefname = sourcefname or "(no sourcefname)"


--%%%%
--%
--% «nodes-and-arrows»  (to ".nodes-and-arrows")
--%
--%%%%

-- The data structures for nodes and arrows:
--
-- nodes	an array of "node"s
-- nnodes	an integer
-- node.noden	an integer such that nodes[node.noden]==node
-- node.TeX	a string (in TeX). It becomes an Ni in \morphism...[N1`N2;L]
-- node.tex	a string, in TeX with abbreviations, or nil
-- node.tag	a string; in general we have nodes[node.tag]==node
-- node.x	an integer (given in Tk pixels)
-- node.y	an integer (given in Tk pixels)
--
-- arrows	an array of "arrow"s
-- narrows	an integer
-- arrow.arrown	an integer such that arrows[arrow.arrown]==arrow
-- arrow.from	an index: nodes[arrow.from] is the starting node
-- arrow.to	an index: nodes[arrow.to] is the ending node
-- arrow.shape	a string, e.g. "|->", or nil; nil means "->"
-- arrow.label	a string (in TeX). It becomes the L in \morphism...[N1`N2;L]
-- arrow.placement	a string, e.g. "a" for "label |a|bove arrow", or nil
-- arrow.slide	a string, e.g. "10pt", or nil
-- arrow.curve	a string, e.g. "^2em", or nil
-- arrow.special	a function or nil

dxyorigx = 100
dxyorigy = 100
dxyscale = 15
realx = function (x) return dxyscale*(x-dxyorigx) end
realy = function (y) return -dxyscale*(y-dxyorigy) end

nodes = {}
nnodes = 0
arrows = {}
narrows = 0

storenode = function (node)
    nnodes = nnodes+1
    node.noden = nnodes
    nodes[nnodes] = node
    if node.tag and not nodes[node.tag] then nodes[node.tag] = node end
    return node
  end

storearrow = function (arrow)
    narrows = narrows+1
    arrow.arrown = narrows
    arrows[narrows] = arrow
    return arrow
  end

arrowtoTeX = function (arrow)
    if arrow.special then
      return arrow.special(arrow)
    end
    local node1, node2 = nodes[arrow.from], nodes[arrow.to]
    local x1, y1 = realx(node1.x), realy(node1.y)
    local x2, y2 = realx(node2.x), realy(node2.y)
    local dx, dy = x2-x1, y2-y1
    local p, sh
    p = arrow.placement and "|"..arrow.placement.."|" or ""
    local slide, curve
    if arrow.slide then slide = "@<"..arrow.slide..">" end
    if arrow.curve then curve = "@/"..arrow.curve.."/" end
    if arrow.slide or arrow.curve then
      sh = format("/{@{%s}%s%s}/",
                  (arrow.shape or "->"), (slide or ""), (curve or ""))
    else
      sh = "/"..(arrow.shape or "->").."/"
    end
    return format("\\morphism(%d,%d)%s%s<%d,%d>[{%s}`{%s};{%s}]",
                  x1, y1, p, sh, dx, dy,
                  node1.TeX, node2.TeX, (arrow.label or ""))
  end

--[[
storenode {TeX="a", tag="a", x=100, y=100}
storenode {TeX="b", tag="b", x=140, y=100}
PP(nodes)
storearrow {from="a", to="b", shape="|->",
            slide="5pt", label="up", placement="a"}
storearrow {from="a", to="b", shape=".>"}
print(arrowtoTeX(arrows[1]))
print(arrowtoTeX(arrows[2]))
--]]


--%%%%
--%
--% «2D»  (to ".2D")
--%
--%%%%

-- The only special data structure used in the 2D support is the array
-- "xs", of cols->Tkcols; only the first position of each x spec is
-- stored in it. Example: if
--   "100  140  "   this xspecstr and then
--   "  +10     "   this xspecstr are fed to dxy2Dx, then we'll have
--    0123456789    xs[0]=100, xs[2]=110], xs[5]=140.

xs = {}
prevy = nil

dxy2Dgetword = function (str, pos)
    if not str or string.len(str)<=pos then return end
    local _, endpos, spaces, word = string.find(str, "^( *)([^ ]+)", pos+1)
    if not word then return end
    local wordpos = pos + string.len(spaces)
    return endpos, wordpos, word
  end

dxy2Dx = function (xspecstr, pos)
    local wordpos, word
    pos = pos or 0
    while 1 do
      pos, wordpos, word = dxy2Dgetword(xspecstr, pos)
      if not word then break end
      local _, __, sign, n = string.find(word, "^(%+?)([0-9.]+)$")
      if n then		-- words that are not like nn or +nn are ignored
        if sign=="" then
          xs[wordpos] = tonumber(n)
        else		-- sign=="+": add n to the previous x
          local prevx
          for j=wordpos-1,0,-1 do
	    if xs[j] then prevx=xs[j]; break end
          end
          if not prevx then
            error("line "..linen.." col "..pos..": no prevx")
          end
          xs[wordpos] = prevx+tonumber(n)
        end
      end
    end
  end

dxy2D = function (str, pos, insteadofstorenode)
    local wordpos, yword, y
    pos, wordpos, yword = dxy2Dgetword(str, pos or 0)
    if not yword then return end	-- blank lines are ignored
    local _, __, sign, n = string.find(yword, "^(%+?)([0-9.]+)$")
    if n then		-- lines not starting with a y spec are ignored
      if sign=="" then
        y = tonumber(n)
      else
        if not prevy then error("line "..linen.." col "..pos..": no prevy") end
        y = tonumber(n)+prevy
      end
      prevy = y
      while 1 do
        pos, wordpos, word = dxy2Dgetword(str, pos)
        if not word then break end
	for i=wordpos,wordpos+string.len(word)-1 do
          if xs[i] then
            (insteadofstorenode or storenode)({tag=word, x=xs[i], y=y})
            break
          end		-- words without an x are ignored
        end
      end
    end
  end

--[[
dxy2Dx("   100 140 +20"); PP(xs)
dxy2Dx("    +10      +3"); PP(xs)
 dxy2D("55  a    b^ool ", 0, P)
 dxy2D("+5 a^F  ign  h ", 0, P)
--]]


--%%%%
--%
--% «dofs»  (to ".dofs")
--%
--%%%%

-- (find-angg "LFORTH/kernel.lua")
-- (find-angg "LFORTH/kernel.lua" "getword")
-- (find-es "lua5" "0-based")
-- lua50e 'P(string.find("012345678", "^(23456)", 1+2))	--> 1+2 7 "23456"'

ds = {}
dspush = function (v) table.insert(ds, 1, v); return v end
dspop  = function () return table.remove(ds, 1) end

depths = {}
depthspush = function (v) table.insert(depths, 1, v); return v end
depthspop  = function () return table.remove(depths, 1) end

forths = forths or {}
forths["drop"] = dspop
forths["swap"] = function () ds[2], ds[1] = ds[1], ds[2] end
forths["(("] = function () depthspush(table.getn(ds)) end
forths["))"] = function ()
    if not depths[1] then
      error("line "..linen.." col "..p.wordpos..": missing `))'")
    end
    for i=table.getn(ds)-1,depthspop(),-1 do table.remove(ds, 1) end
  end

pushtag = function (tag) dspush(assert(nodes[tag], tag..": no such node")) end
pusharrow = function (shape)
    dspush(storearrow {from=ds[2].noden, to=ds[1].noden, shape=shape})
  end

dof = function (word)
    if forths[word] then forths[word]() 
    elseif nodes[word] then dspush(nodes[word])		-- diagxy-specific
    else error("No such word: "..word)
    end
  end

p = {text=str, pos=0, word=nil, wordpos=nil, stuffpos=nil}

getword = function ()
    local _, __, spaces, word = string.find(p.text, "^( *)([^ ]+)", p.pos+1)
    if _ then
      p.stuffpos, p.pos = p.pos+string.len(spaces), __
      return word
    end
    p.pos = nil
  end
getrestofline = function ()
    local stuff = string.sub(p.text, p.pos+1+1)
    p.stuffpos, p.pos = p.pos+1, string.len(p.text)
    return stuff
  end
getuntilquote = function ()
    local _, __, stuff = string.find(p.text, "^ (.-)\"", p.pos+1)
    if not _ then error("line "..linen..": no closing quote") end
    p.stuffpos, p.pos = p.pos+1, __
    return stuff
  end

dofs = function (str, pos)
    local oldp = p
    p = {text=str, pos=(pos or 0)}
    while 1 do
      p.word = getword()
      if not p.word then p = oldp; return end
      p.wordpos = p.stuffpos
      dof(p.word)
    end
  end

forths["#"] = getrestofline

--[[
forths["Pw"] = function () P(getword()) end
forths["Pq"] = function () P(getuntilquote()) end
forths["Prl"] = function () P(getrestofline()) end
s = " Pw  a-word  Pq  until quote\"  Prl  rest of line  "
P(s); dofs(s)
--]]


--%%%%
--%
--% «diagram»  (to ".diagram")
--%
--%%%%

diagram = function (str)
    diagramname = str
    diagramstartlinen = linen or -2222
    dxyorigx = 100
    dxyorigy = 100
    dxyscale = 15
    nodes = {}
    nnodes = 0
    arrows = {}
    narrows = 0
    xs = {}
    prevy = nil
  end

diagramtoTeX = function ()
    for i=1,nnodes do
      local node = nodes[i]
      if not node.tex then node.tex = node.tag end
      if not node.TeX then node.TeX = unabbrev(node.tex) end
    end
    local bigstr = ""
    for i=1,narrows do
      bigstr = bigstr.."  "..arrowtoTeX(arrows[i]).."\n"
    end
    return bigstr
  end

-- (find-angg "dednat/dednat3.lua" "processing.a.file" "Tree redefined")
-- (find-angg "LATEX/edrx.sty" "ded")
-- TO DO: support \place, warn at redefinitions

enddiagram = function ()
    local diagramdef = format("\\defdiag{%s}{%s\n%s}",
        diagramname, optionalhyperlink("    % ", diagramstartlinen, ""),
	diagramtoTeX())
    print(diagramdef)
  end

--%%%%
--%
--% «forthwords»  (to ".forthwords")
--%
--%%%%

-- Note that "drop", "((", and "))" have already been defined.

forths["diagram"] = function ()
    diagram(getword() or error("Missing diagram name"))
  end
forths["enddiagram"] = enddiagram

forths["2Dx"] = function ()
    getrestofline()
    dxy2Dx(p.text, p.stuffpos)
  end
forths["2D"] = function ()
    getrestofline()
    dxy2D(p.text, p.stuffpos)
  end

forths["->"] = function () pusharrow("->") end
forths["=>"] = function () pusharrow("=>") end
forths[".>"] = function () pusharrow(".>") end
forths[":>"] = function () pusharrow(":>") end
forths["-->"] = function () pusharrow("-->") end
forths["==>"] = function () pusharrow("==>") end
forths["|->"] = function () pusharrow("|->") end
forths["|-->"] = function () pusharrow("|-->") end
forths["`->"] = function () pusharrow("^{ (}->") end
forths[">->"] = function () pusharrow(" >->") end
forths["->>"] = function () pusharrow("->>") end
forths["<->"] = function () pusharrow("<->") end

forths["<-"] = function () pusharrow("<-") end
forths["<="] = function () pusharrow("<=") end
forths["<."] = function () pusharrow("<.") end
forths["<:"] = function () pusharrow("<:") end
forths["<--"] = function () pusharrow("<--") end
forths["<=="] = function () pusharrow("<==") end
forths["<-|"] = function () pusharrow("<-|") end
forths["<--|"] = function () pusharrow("<--|") end
forths["<-'"] = function () pusharrow("<-^{) }") end
forths["<-<"] = function () pusharrow("<-< ") end
forths["<<-"] = function () pusharrow("<<-") end

forths["-"] = function () pusharrow("-") end
forths["--"] = function () pusharrow("--") end
forths["."] = function () pusharrow(".") end

settex = function (tag, str) nodes[tag].tex = str end
setTeX = function (tag, str) nodes[tag].TeX = str end
setp = function (tag, str) nodes[tag].placement = str end
setslide = function (tag, str) nodes[tag].slide = str end
setcurve = function (tag, str) nodes[tag].curve = str end

forths[".tex="]   = function () ds[1].tex = getword() end
forths[".TeX="]   = function () ds[1].TeX = getword() end
forths[".TeX=\""] = function () ds[1].TeX = getuntilquote() end
forths[".p="]     = function () ds[1].placement = getword() end
forths[".slide="] = function () ds[1].slide = getword() end
forths[".curve="] = function () ds[1].curve = getword() end

forths[".label="]   = function () ds[1].label = getword() end
forths[".label=\""] = function () ds[1].label = getuntilquote() end

--[[
diagram "miniadj"
dxy2Dx "      100   140 "
dxy2D  " 140 a^L <= a   "
dxy2D  "      -     -   "
dxy2D  "      |     |   "
dxy2D  "      v     v   "
dxy2D  " 100  b => b^R  "
PP("nodes =", nodes)
pushtag "a^L"; pushtag "a"; dof "<="
pushtag "a^L"; pushtag "b"; dof "|->"
pushtag "a"; pushtag "b^R"; dof "|->"
pushtag "b"; pushtag "b^R"; dof "=>"
PP("arrows =", arrows)
enddiagram()
--]]
--[[
dofs "diagram miniadj"
dofs "2Dx      100   140 "
dofs "2D  140 a^L <= a   "
dofs "2D       -     -   "
dofs "2D       |     |   "
dofs "2D       v     v   "
dofs "2D  100  b => b^R  "
dofs "a^L a <=   a^L b |->   a b^R |->   b b^R =>"
dofs "enddiagram"
--]]


--%%%%
--%
--% «diaghead»  (to ".diaghead")
--%
--%%%%

-- (find-angg "dednat/dednat3.lua" "luahead")
-- Tell dednat3 to treat "%D" lines as strings to be dofs'd.

diagheadcode = function ()
    dofs(untabify(linestr), 2)
  end

if registerhead then
  registerhead("%D", {code=diagheadcode})
end



--[[
diagram "miniadj"
dxy2Dx "      100   140 "
dxy2D  " 140 a^L <= a   "
dxy2D  "      -     -   "
dxy2D  "      |     |   "
dxy2D  "      v     v   "
dxy2D  " 100  b => b^R  "
dofs " a (( a^L => drop b |-> drop b^R => )) b^R |-> "
enddiagram()
--]]
--[[
diagram "limij"
dofs "2Dx         100        +60        +60           +60   "
dofs "2D  140     x <======= j=>x ====> i=>x <======= x     "
dofs "2D          -            -          -           -     "
dofs "2D          |     <->    |   |->    |   <->     |     "
dofs "2D          v            v          v           v     "
dofs "2D  100 lim_j.y_j ==> j=>y_j <== i=>y_j <== lim_i.y_j "
dofs ""
dofs "lim_j.y_j .TeX=\" \lim_j y_j\""
dofs "lim_i.y_j .TeX=\" \lim_i y_j\""
dofs " x (( j=>x <= drop i=>x => drop x <= drop lim_i.y_j |-> )) "
dofs "   lim_j.y_j |-> drop j=>y_j => drop i=>y_j <= drop lim_i.y_j <="
dofs " (( j=>x j=>y_j |-> )) (( i=>x i=>y_j |-> )) "
enddiagram()
--]]

--[[
#*
cd ~/dednat/
lua50 diagxy.lua
#*
]]