#!/usr/bin/env lua50
-- dednat4.lua - a TeX preprocessor to typeset trees and diagrams
-- Written by Eduardo Ochs <[email protected]>, 2004jan22
-- Current revision: 2006jul19. Last changes:
--   2006jul19 - added arrow.Label; allow abbrevs in arrow.label
--   2006jul?? - added the arg "ignorespecial" to diag-out
--   2006jun24 - added support for ":"-deductions
-- See: http://angg.twu.net/dednat4.html
-- License: GPL
--
-- «.heads»		(to "heads")
-- «.processfile»	(to "processfile")
-- «.abbrevs»		(to "abbrevs")
-- «.abbrev-head»	(to "abbrev-head")
-- «.tex-head»		(to "tex-head")
-- «.dntfiles»		(to "dntfiles")
-- «.process»		(to "process")
-- «.lua-head»		(to "lua-head")
-- «.tree-lib»		(to "tree-lib")
-- «.tree-out»		(to "tree-out")
-- «.tree-head»		(to "tree-head")
-- «.diag-out»		(to "diag-out")
-- «.diagram»		(to "diagram")
-- «.diag-2d»		(to "diag-2d")
-- «.diag-forth»	(to "diag-forth")
-- «.diag-forth-parser»	(to "diag-forth-parser")
-- «.diag-words»	(to "diag-words")
-- «.diag-arrows»	(to "diag-arrows")
-- «.diag-head»		(to "diag-head")
-- «.main»		(to "main")

-- Some data structures and variables:

-- For heads:
-- A "head" is a table with these fields:
--   head.headstr     a prefix string, e.g. "%:"; set by registerhead
--   head.beforefirst = function (linestr) or nil
--   head.aftereach   = function (linestr)
--   head.afterlast   = function () or nil
-- The table "heads" is an array of headstr -> head. 

-- For processfile:
-- sourcefname is the file name of the file being processed.
-- linen       is the current line number.
-- linestr     is the text of the current line.
-- flines      is an array of linestrs (i.e., flines[linen] is a linestr).

-- For abbrevs:
-- abbrevs   is a table; abbrevs[str] is the expansion of str, or nil if none.
-- isprefix  is a table, generated from abbrevs; isprefix[str] is a boolean.

-- For trees:
-- A "tline" is a table with these fields:
--   tline.linen  an integer
--   tline.text   a  string
--   tline.segs   a  list of "seg"s
-- The table "tlines" is an array of linen -> tline.
-- It only has entries for the "%:" lines.
-- A "seg" is a table with these fields:
--   seg.linen  an integer
--   seg.segn   an integer - for any seg s we have tlines[s.linen][s.segn]==s
--   seg.lcol   an integer
--   seg.rcol   an integer
--   seg.text   a  string

-- For Forth:
-- ...

-- For diagrams:
-- ...





-- Add the curent directory to LUA_PATH (if in standalone mode).
-- (find-es "lua5" "require")
--
if not library then
  local _, __, arg0path = string.find(arg[0], "^(.*)/[^/]*$")
  if arg0path then
    LUA_PATH = (LUA_PATH or os.getenv("LUA_PATH") or "?;?.lua")..
               ";"..arg0path.."/?"
  end
end

require "edrxlib.lua"

getn    = table.getn
gsub    = string.gsub
strbyte = string.byte
strlen  = string.len
strrep  = string.rep
strsub  = string.sub
tinsert = table.insert
tremove = table.remove

do
local
reps = {"        ", "       ", "      ", "     ", "    ", "   ", "  ", " "}
--reps={"--------", "-------", "------", "-----", "----", "---", "--", "-"}
untabify = function (str, col)
    local pos, newstr, _, nontab, tab = 0, ""
    col = col or 0	-- 0-based: ((col mod 8)==2) -> (tab -> 6 spaces)
    while 1 do
      _, pos, nontab, tab = string.find(str, "^([^\t]*)(\t?)", pos+1)
      if tab=="" then
        return newstr..nontab
      end
      col = math.mod(col + string.len(nontab), 8)
      newstr = newstr..nontab..reps[col+1]
      col = 0
    end
  end
end

readfile = function (fname)
    local f = assert(io.open(fname, "r"))
    local bigstr = f:read("*a")
    f:close()
    return bigstr
  end
writefile = function (fname, bigstr)
    local f = assert(io.open(fname, "w+"))
    f:write(bigstr)
    f:close()
  end

splitintolines = function (str)
    local lines = {}
    local rest = string.gsub (str, "([^\n]*)\n", function (line)
        table.insert(lines, line)
      end)
    if rest ~= "" then table.insert(lines, rest) end
    return lines
  end


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

heads = {}

registerhead = function (headstr, head)
    head.headstr = headstr
    heads[headstr] = head
  end
registerhead("", {})

headfor = function (linestr)
    if linestr then
      return heads[string.sub(linestr, 1, 3)] or
             heads[string.sub(linestr, 1, 2)] or
             heads[string.sub(linestr, 1, 1)] or
             heads[""]
    end
  end



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

processfile = function (fname, ismetatex)
    local _sourcefname, _linen, _linestr, _head, _flines, _tlines =
           sourcefname,  linen,  linestr,  head,  flines,  tlines
    sourcefname = fname
    linen = 1
    flines = splitintolines(readfile(fname))
    tlines = {}
    flines.ismetatex = ismetatex
    while 1 do
      linestr = flines[linen]
      if not linestr then
	break
      end
      head = headfor(linestr)
      local beforefirst = head.beforefirst or function () end
      local aftereach   = head.aftereach   or function () end
      if head.afterlast then
	beforefirst(linestr)
	aftereach(linestr)
	while headfor(flines[linen+1]) == head do
	  linen = linen + 1
	  linestr = flines[linen]
	  aftereach(linestr);
	end
	head.afterlast()
      else
	aftereach(linestr)
      end
      linen = linen + 1
    end
    local tmpflines = flines
     sourcefname,  linen,  linestr,  head,  flines,  tlines =
    _sourcefname, _linen, _linestr, _head, _flines, _tlines
    return tmpflines
  end


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

isprefix = {}
abbrevs = {}
addabbrev = function (abbrev, expansion)
    for i = 1,string.len(abbrev)-1 do
      isprefix[string.sub(abbrev, 1, i)] = true
    end
    abbrevs[abbrev] = expansion
  end

unabbrev = function (str)
    local len, newstr, i = string.len(str), "", 1
    local j, teststr, longest
    while i<=len do
      longest = nil     -- the longest substring starting at i that is an abbrev
      for j=i,len do
        teststr = string.sub(str, i, j)
        if abbrevs[teststr] then longest = teststr
        else
          if not isprefix[teststr] then break end
        end
      end
      if longest then                        -- if str[i] starts an abbrev then
        newstr = newstr .. abbrevs[longest]  -- add the expansion of the abbrev
        i = i + string.len(longest)
      else
        newstr = newstr .. string.sub(str, i, i)   -- else add str[i]
        i = i + 1
      end
    end
    return newstr
  end

-- these are mainly for tests and demos:
addabbrevs = function (...)
    for i=1,getn(arg),2 do
      addabbrev(arg[i], arg[i+1])
    end
  end
standardabbrevs = function ()
    addabbrevs(
      "->^", "\\ton ",   "`->", "\\ito ", "-.>", "\\tnto ",
      "=>",  "\\funto ", "<->", "\\bij ", "->",  "\\to ",
      "|-",  "\\vdash ", "|->", "\\mto ", "\"",  " ")
  end


--%%%%
--%
--% «abbrev-head»  (to ".abbrev-head")
--%
--%%%%

abbrevheadcode1 = function ()
    local _, __, abbrev, expansion = string.find(linestr, "^%%:*(.-)*(.-)*")
    addabbrev(abbrev, expansion)
  end
registerhead("%:*", {
  aftereach = abbrevheadcode1
})


--%%%%
--%
--% «tex-head»  (to ".tex-head")
--%
--%%%%

outtexlines = {}
texheadunabbrev = function (str)
    return string.gsub(linestr, "\\abr(%b{})", function (s)
        return unabbrev(string.sub(s, 2, -2))
      end)
  end
texheadcode1 = function (linestr)
    if flines.ismetatex then
      outtexlines[linen] = texheadunabbrev(linestr)
    end
  end
registerhead("", {
  aftereach = texheadcode1
})


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

dntfile = io.stdout
dntprint = function (str)
    dntfile:write(str, "\n")
  end

undefs = ""
remembertoundefine = function (dedordiag, name)
    undefs = undefs.."  \\undef"..dedordiag.."{"..name.."}\n"
  end

setdntfile = function ()
    if dntfile and dntfile ~= io.stdout then io.close(dntfile) end
    if dntn then dntextrasuffix = "-" .. dntn end
    dntfname = stemfname .. ".dnt" .. (dntextrasuffix or "")
    dntfile = assert(io.open(dntfname, "w+"))
    dntprint(undefs)
    undefs = ""
  end

bumpdntfile = function ()
    dntn = (dntn or 0) + 1
    setdntfile()
    outtexlines[linen] = "\\input "..dntfname
  end


--%%%%
--%
--% «lua-head»  (to ".lua-head")
--%
--%%%%

luaheadcode0 = function ()
    luacode = ""
    luacodestartlinen = linen
  end
luaheadcode1 = function (linestr)
    luacode = luacode .. string.sub(linestr, 3) .. "\n"
  end
luaheadcode2 = function ()
    local chunkname = "\"%L\" chunk starting at line "..luacodestartlinen
    assert(loadstring(luacode, chunkname))()
  end
registerhead("%L", {
  beforefirst = luaheadcode0,
  aftereach   = luaheadcode1,
  afterlast   = luaheadcode2
})


--%%%%
--%
--% «tree-lib»  (to ".tree-lib")
--%
--%%%%

dolinenumbers = "eev"
optionalhyperlink = function (pre, linen, post)
    if dolinenumbers == "eev" then
     return format("%s(find-fline \"%s\" %d)%s", pre, sourcefname, linen, post)
    elseif dolinenumbers then
      return format("%sfile %s line %d%s", pre, sourcefname, linen, post)
    else
      return ""
    end
  end

barcharandtext = function (barseg)
    local _, __, text
    _, __, text = string.find(barseg.text, "^-+(.*)")
    if text then return "-",text end
    _, __, text = string.find(barseg.text, "^=+(.*)")
    if text then return "-",text end
    _, __, text = string.find(barseg.text, "^:+(.*)")
    if text then return ":",text end
    errprintf("Bad bar at line %d, col %d: %s\n", barseg.linen, barseg.lcol,
      barseg.text)
  end

relativeplacement = function (upperseg, lowerseg)
    if upperseg.rcol <= lowerseg.lcol then return "L" end
    if upperseg.lcol >= lowerseg.rcol then return "R" end
    return "I"
  end

nextseg = function (seg) return tlines[seg.linen].segs[seg.segn+1] end

firstsegabove = function (lowerseg, nlines)
    local upperseg
    upperseg = tlines[lowerseg.linen - (nlines or 1)] and
               tlines[lowerseg.linen - (nlines or 1)].segs[1]
    while upperseg and relativeplacement(upperseg, lowerseg)=="L" do
        upperseg = nextseg(upperseg)
      end
    if upperseg and relativeplacement(upperseg, lowerseg)=="I" then
      return upperseg
    end
  end

nextsegabove = function (upperseg, lowerseg)
    local nextupperseg = nextseg(upperseg)
    return nextupperseg and
      relativeplacement(nextupperseg, lowerseg)=="I" and nextupperseg
  end

stuffabovenode = function (lowerseg)
    local barseg, firstupperseg, upperseg, n
    barseg = firstsegabove(lowerseg)
    if not barseg then return -1 end
    firstupperseg = firstsegabove(barseg)
    if not firstupperseg then return 0, barseg end
    n = 1
    upperseg = firstupperseg
    while 1 do
      upperseg = nextsegabove(upperseg, barseg)
      if upperseg then n = n+1 else return n, barseg, firstupperseg end
    end
  end


--%%%%
--%
--% «tree-out»  (to ".tree-out")
--%
--%%%%

mathstrut = mathstrut or "\\mathstrut "

tex_node_tatsuta = function (indent, lowerseg)
    local n, barseg, upperseg = stuffabovenode(lowerseg)
    if not barseg then
      return indent..mathstrut..unabbrev(lowerseg.text)
    end
    local barchar, bartext = barcharandtext(barseg)
    local rulemodifier =
      (barchar=="=" and "=" or (barchar==":" and "*" or "")) ..
      (bartext=="" and "" or "[{"..unabbrev(bartext).."}]")
    local newindent = indent.." "
    local uppertex
    if n==0 then
      return format("%s\\infer%s{ %s%s }{ }", indent, rulemodifier,
          mathstrut, unabbrev(lowerseg.text))
    else
      uppertex = tex_node_tatsuta(newindent, upperseg)
      for i=2,n do
        upperseg = nextseg(upperseg)
        uppertex = uppertex .. " &\n" .. tex_node_tatsuta(newindent, upperseg)
      end
    end
    return format("%s\\infer%s{ %s%s }{\n%s }",
        indent, rulemodifier,
        mathstrut, unabbrev(lowerseg.text),
        uppertex)
  end

tex_tree_tatsuta = function (treetagseg, treelabel, treerootseg)
    return format("\\defded{%s}{%s\n%s }\n",
                  treelabel, optionalhyperlink("    % ", treetagseg.linen, ""),
                  tex_node_tatsuta(" ", treerootseg))
  end

tex_node_paultaylor = function (indent, lowerseg)
    local n, barseg, upperseg = stuffabovenode(lowerseg)
    if not barseg then
      return unabbrev(lowerseg.text)
    end
    local barchar, bartext = barcharandtext(barseg)
    local justifies = (barchar=="=" and "\\Justifies" or
                       (barchar==":" and "\\leadsto" or "\\justifies"))
    local using = (bartext=="" and "" or "\\using "..unabbrev(bartext).." ")
    local newindent = indent.."   "
    local uppertex, segtex, istree, previstree
    if n==0 then
      return "\\[ "..using..justifies.."\n"..
             indent..unabbrev(lowerseg.text).." \\]", "tree"
    else
      uppertex, istree = tex_node_paultaylor(newindent, upperseg)
      for i=2,n do
        upperseg = nextseg(upperseg)
        previstree = istree
	segtex, istree = tex_node_paultaylor(newindent, upperseg)
        if previstree or istree then quad = "" else quad = " \\quad" end
        uppertex = uppertex..quad.."\n"..
                   newindent..segtex
      end
    end
    return "\\[ "..uppertex.." "..using..justifies.."\n"..
           indent..unabbrev(lowerseg.text).." \\]", "tree"
  end

tex_tree_paultaylor = function (treetagseg, treelabel, treerootseg)
  return "\\defded{"..treelabel.."}{"..
         optionalhyperlink("    % ", treetagseg.linen, "")..
         "\n  \\begin{prooftree}\n  "..
            tex_node_paultaylor("  ", treerootseg)..
         "\n  \\end{prooftree}}"
end

tex_tree_function = tex_tree_tatsuta
-- tex_tree_function = tex_tree_paultaylor


--%%%%
--%
--% «tree-head»  (to ".tree-head")
--%
--%%%%

tlines = {}
treetagsegs = {}

splitintosegs = function (tline)
    local col, nsegs, _, __, spaces, text = 1, 0
    tline.segs = {}
    while 1 do
      _, __, spaces, text = string.find(tline.text, "^( *)([^ ]*)", col)
      if text and text ~= "" then
        nsegs = nsegs + 1
        local nspaces, nchars = string.len(spaces), string.len(text)
        tline.segs[nsegs] = {linen=tline.linen, segn=nsegs,
          lcol=col+nspaces, rcol=col+nspaces+nchars, text=text}
        col = col + nspaces + nchars
      else
        break
      end
    end
  end

processtreetags = function (tline)
    seg = tline.segs[1]
    while seg do
      if string.sub(seg.text, 1, 1)=="^" then
        local treelabel = string.sub(seg.text, 2)
        if treetagsegs[treelabel] then
          errprintf("Tree redefined: tree %s, lines %d and %d\n",
            treelabel, tline.linen, treetagsegs[treelabel].linen)
        end
        local treerootseg = firstsegabove(seg, 2)
        if not treerootseg then
          errprintf("No root seg: line %d, tree %s\n", tline.linen, treelabel)
        end
        dntprint(tex_tree_function(seg, treelabel, treerootseg))
	remembertoundefine("ded", treelabel)
      end
      seg = nextseg(seg)
    end
  end

treeheadcode1 = function ()
    tlines[linen] = {linen=linen, text=untabify(string.sub(linestr, 3), 2)}
    splitintosegs(tlines[linen])
    processtreetags(tlines[linen])
  end

registerhead("%:", {
  aftereach = treeheadcode1
})



--%%%%
--%
--% «diag-out»  (to ".diag-out")
--%
--%%%%

-- The data structures for nodes and arrows:
--
-- nodes	an array of "node"s
-- 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
-- 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.label	a string, in TeX with abbreviations, or nil
-- 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 = {}
arrows = {}

storenode = function (node)
    tinsert(nodes, node)
    node.noden = getn(nodes)
    if node.tag and not nodes[node.tag] then nodes[node.tag] = node end
    return node
  end

storearrow = function (arrow)
    tinsert(arrows, arrow)
    arrow.arrown = getn(arrows)
    return arrow
  end

arrowtoTeX = function (arrow, ignorespecial)
    if arrow.special and not ignorespecial 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 label
    if     arrow.Label then label = arrow.Label
    elseif arrow.label then label = unabbrev(arrow.label)
                       else label = ""
    end
    -- 2006aug02: a hack: explicit label placement.
    -- When lplacement is not nil (say, "^<>(0.4)") write the label at
    -- the right of lplacement, intead of writing it in "[{%s}`{%s};{HERE}]".
    -- Warning: when we use lplacement the letter in arrow.placement is ignored.
    local lplacement
    if arrow.lplacement then
      lplacement = format("%s{%s}", arrow.lplacement, label)
    end
    local p = arrow.placement and "|"..arrow.placement.."|" or ""
    local slide, curve, sh
    if arrow.slide then slide = "@<"..arrow.slide..">" end
    if arrow.curve then curve = "@/"..arrow.curve.."/" end
    if arrow.slide or arrow.curve or arrow.lplacement then -- 2006aug02
      sh = format("/{@{%s}%s%s%s}/", (arrow.shape or "->"),
		  (lplacement 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,
		  lplacement and "" or format("{%s}", label))
  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]))
--]]

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

diagram = function (str)
    diagramname = str
    diagramstartlinen = linen
    dxyorigx = 100
    dxyorigy = 100
    dxyscale = 15
    nodes = {}
    arrows = {}
    xs = {}
    prevy = nil
  end

diagramtoTeX = function ()
    for i=1,getn(nodes) 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,getn(arrows) 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())
    dntprint(diagramdef)
    remembertoundefine("diag", diagramname)
  end



--%%%%
--%
--% «diag-2d»  (to ".diag-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)
--]]



--%%%%
--%
--% «diag-forth»  (to ".diag-forth")
--%
--%%%%

-- (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) tinsert(ds, 1, v); return v end
dspop  = function () return tremove(ds, 1) end

depths = {}
depthspush = function (v) tinsert(depths, 1, v); return v end
depthspop  = function () return tremove(depths, 1) end

forths = forths or {}
forths["drop"] = dspop
forths["swap"] = function () ds[2], ds[1] = ds[1], ds[2] end
forths["(("] = function () depthspush(getn(ds)) end
forths["))"] = function ()
    if not depths[1] then
      error("line "..linen.." col "..p.wordpos..": missing `))'")
    end
    for i=getn(ds)-1,depthspop(),-1 do tremove(ds, 1) end
  end
forths["@"] = function ()
    dspush(ds[table.getn(ds) - depths[1] - getwordasluaexpr()])
  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

-- «diag-forth-parser»  (to ".diag-forth-parser")

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

getword = function ()
    local _, __, afterspaces, word, afterword, newline =
      string.find(p.text, "^ *()([^ \n]*)()(\n?)", p.pos+1)
    -- PP(_, __, afterspaces, word, afterword, newline)
    if word ~= "" then
      p.stuffpos, p.pos = afterspaces-1, afterword-1
      return word
    elseif newline ~= "" then
      p.stuffpos, p.pos = afterword-1, afterword
      return newline
    end
    p.pos = nil
  end
getrestofline = function ()
    local _, __, stuffpos, stuff, newpos =
      string.find(p.text, "^ ?()([^\n]*)()", p.pos+1)
    p.stuffpos, p.pos = stuffpos-1, newpos-1
    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

asluaexpr = function (str)
    return assert(loadstring("return "..str))()
  end
getwordasluaexpr = function () return asluaexpr(getword()) 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["\n"] = function () end
forths["#"] = getrestofline
macro = function (str) return function () dofs(str) end end


--%%%%
--%
--% «diag-words»  (to ".diag-words")
--%
--%%%%

-- 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

--[[
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"
--]]


--%%%%
--%
--% «diag-arrows»  (to ".diag-arrows")
--%
--%%%%

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

forths[".plabel="] = function ()
    ds[1].placement = getword()
    ds[1].label = getword()
  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
forths["--"] = function () pusharrow("--") end
forths["."] = function () pusharrow(".") end


--%%%%
--%
--% «diag-head»  (to ".diag-head")
--%
--%%%%

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

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

if registerhead then
  registerhead("%D", {
    aftereach = diagheadcode1
  })
end


--%%%%
--%
--% «diag-extensions»
--%
--%%%%



-- (find-angg "dednat/dednat2.lua" "tatsuta_do_node")
-- (find-lua50ref "Precedence")

-- (find-es "tex" "ptproof")



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

removesuffix = function (suffix, str)
    if strsub(str, -strlen(suffix)) == suffix then
      return strsub(str, 1, -strlen(suffix)-1)
    end
  end

processtex = function (fname)
    stemfname = removesuffix(".tex", fname)
    if not stemfname then error("Filename must end with .tex") end
    setdntfile()
    processfile(fname)
    io.close(dntfile)
  end
processmetatex = function (fname)
    stemfname = removesuffix(".metatex", fname)
    setdntfile()
    outtexfname = stemfname .. ".tex"
    local flines = processfile(fname, "metatex")
    io.close(dntfile)
    outtexfile = assert(io.open(outtexfname, "w+"))
    for i=1,getn(flines) do
      outtexfile:write(outtexlines[i] or "%", "\n")
    end
    io.close(outtexfile)
  end

processtexormetatex = function (fname)
    if removesuffix(".tex", fname) then
      processtex(fname)
    elseif removesuffix(".metatex", fname) then
      processmetatex(fname)
    else
      error("Filename must end with .tex or .metatex")
    end
  end



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

-- (find-lua50ref "Input and Output Facilities")
-- (find-lua50ref "file:write")
-- (find-lua50ref "string.find")

if not library then
  if arg[1] == "-e" then
    assert(loadstring(arg[2]))()
  elseif arg[1] then
      processtexormetatex(arg[1])
  end
end


-- To do: change the above "main" code to something that uses options
-- in a clearer way, like this:
--   dednat4 -o foo.dnt -ot foo.tex -i foo.metatex
--   dednat4 -o bar.dnt             -i bar.tex

-- Code borrowed from blogme for inspiration:

-- do
--   local i = 1
--   local infname, outfname
--   while i <= arg.n do
--     local a, b = arg[i], arg[i+1]
--     if     a == "-o" then outfname = b; i = i+2
--     elseif a == "-i" then blogme_test(b, outfname); i = i+2
--     elseif a == "-p" then relativepathto_prefix = b; i = i+2
--     elseif a == "-e" then assert(loadstring(b))(); i = i+2
--     else print("Unrecognized option: " .. a); os.exit(1)
--     end
--   end
-- end





--[[
#*
rm -Rv /tmp/dn4/
mkdir  /tmp/dn4/
cd     /tmp/dn4/

cat > dntest.metatex <<'%%%'
bla
%L standardabbrevs()
%:
%:     -
%:     c  d
%:     ====?
%:  a  a->b
%:  -------
%:     b
%:
%:  ^tree1
%:
%D diagram miniadj
%D 2Dx     100   140
%D 2D 140 a^L <= a
%D 2D      -     -
%D 2D      | <-> |
%D 2D      v     v
%D 2D 100  b => b^R
%D a (( a^L => drop b |-> drop b^R => )) b^R |->
%D enddiagram
$\abr{a-.>(b<->c)}$
%%%

~/dednat4/dednat4.lua dntest.metatex

#*
# (find-fline "/tmp/dn4/")
# (find-fline "/tmp/dn4/dntest.tex")
# (find-fline "/tmp/dn4/dntest.dnt")
# (find-angg "LATEX/edrx.sty" "diag")
# (find-es "xypic" "diagxydemo0")

#*
mkdir  /tmp/dn4/
cd     /tmp/dn4/
unzip -a -o $S/ftp/ftp.math.mcgill.ca/pub/barr/diagxy.zip
cp $S/http/www.ctan.org/tex-archive/macros/latex/contrib/proof/proof.sty .
cp ~/dednat4/demodefs.tex .

#*
mkdir  /tmp/dn4/
cd     /tmp/dn4/
cp ~/dednat4/demodefs.tex .

cat > main.tex <<'%%%'
\documentclass[oneside]{book}

\usepackage{proof}
\usepackage{amsmath}
\usepackage{amssymb}
%
\input diagxy
\xyoption{curve}
%
\input demodefs.tex

\begin{document}
\input dntest.dnt
\input dntest.tex
$$\ded{tree1} \qquad \diag{miniadj}$$
\end{document}
%%%

latex main.tex && xdvi main.dvi &

#*

# (find-fline "/tmp/dn4/")
# (find-fline "/oldfs/7/pandahome/edrx/LATEX/")



]]

--[[
P(untabify("34\t\t01234567\t0123\t", 3))
P("3456701234567012345670123456701234567")
--]]

-- (find-vtutil4 "vtfontlib.lua")
-- (find-lua50ref "")
-- (find-angg "LUA/lua50init.lua")

-- Local Variables:
-- coding: raw-text-unix
-- End: