#!/usr/bin/env lforth
# (eev "cd ~/LFORTH/; ./yoneda.lforth")
# (find-lforth "lforth")
# (find-lforth "stdlib.lforth")
# (find-lforth "kernel.lua")
# (find-lforth "README")
# (find-lua50ref "getglobals")
# (find-lua50ref "Pattern Item" "followed by -")

[lua
    heads["h_var"] = function ()
        dspush(mem[ip]); ip = rspop(); state = states.forthret
      end
    dncterms = {}
    newdnc = function (tbl)
	local name = tbl.name
        dncterms[name] = tbl
        prim(name, function () dspush(dncterms[name]) end)
        return tbl
      end
  lua]

:lua pp:
    local name = getword()
    local value = newdnc {name=name, cctype="atom"}
    compile(name, "h_var", value)
    dspush(value)
  lua;
:lua newarrow:
    local whicharrow = getword()
    prim(whicharrow, function ()
        local r = dspop()
        local l = dspop()
        local lname, rname
        if l.cctype=="atom" then lname=l.name else lname="("..l.name..")" end
        if r.cctype=="atom" then rname=r.name else rname="("..r.name..")" end
        local this = newdnc {lname=l.name, rname=r.name,
                             name=lname..whicharrow..rname,
                             cctype="arrow", cc=whicharrow}
        dspush(this)
      end)
  lua;
:lua pp;pp
    local r = dspop()
    local l = dspop()
    dspush(newdnc {lname=l.name, rname=r.name,
                   name=l.name..";"..r.name,
                   cctype=";", cc=";"})
  lua;  

newarrow: |->
newarrow: <->
newarrow: =>
newarrow: -.>

pp: a drop
pp: x drop
pp: a^F drop
pp: x^F drop

# (a;x=>x^F)-.>(a^F<->(x-.>((a|->x)|->x^F)))

   a x  x^F
      =>
  pp;pp         a^F    x     a   x
                              |->     x^F
                                   |->
                        -.>
                   <->
            -.>

field: name
field: cctype
field: cc

:lua ->dnc ds[1] = dncterms[ds[1]] lua;
field: lname	: .l .lname ->dnc ;
field: rname	: .r .rname ->dnc ;

  dup .name .
  dup .l .name .
  dup .r .name .
  drop

  x-.>((a|->x)|->x^F)
  dup .name .
      .cc .