Warning: this is an htmlized version!
The original is across this link,
and the conversion rules are here.
-- gabriela-app.lua - application (as in "f(k)") and other extensions
-- Author:  Eduardo Ochs <eduardoochs@gmail.com>
-- Version: 2012mar30
-- Licence: GPL3
--
-- The latest upstream version of this can be found at:
--   http://angg.twu.net/dednat5/gabriela-app.lua
--   http://angg.twu.net/dednat5/gabriela-app.lua.html
--                    (find-dn5 "gabriela-app.lua")
-- This depends on:
--   http://angg.twu.net/dednat5/gabriela.lua
--   http://angg.twu.net/dednat5/gabriela.lua.html
--                    (find-dn5 "gabriela.lua")

-- Quick index:
-- «.contexts»			(to "contexts")
-- «.contexts-test»		(to "contexts-test")
-- «.def-lambda-app»		(to "def-lambda-app")
-- «.comprehension»		(to "comprehension")
-- «.comprehension-test»	(to "comprehension-test")
-- «.def-lambda-app-tests»	(to "def-lambda-app-tests")
-- «.grids»			(to "grids")
-- «.grids-tests»		(to "grids-tests")


dofile "gabriela.lua"   -- (find-dn5 "gabriela.lua")


-- «contexts»  (to ".contexts")
-- Contexts are used for variables and for substitutions.
Context = Class {
  type    = "Context",
  __index = {
    push  = function (ctxt, name, expr)
        local pair = {name, ctxt[name]}
	table.insert(ctxt.__stack, pair)
	ctxt[name] = expr
        return ctxt
      end,
    pop   = function (ctxt)
        local pair = table.remove(ctxt.__stack) or error("Empty __stack")
	local name, oldvalue = pair[1], pair[2]
	ctxt[name] = oldvalue
	return ctxt
      end,
    minus = function (ctxt, name)
        if ctxt[name] == nil then return ctxt end
        ctxt = copy(ctxt); ctxt[name] = nil; return ctxt
      end,
    keys     = function (ctxt) return sorted(keys(ctxt:minus("__stack"))) end,
    tostring = function (ctxt, sep)
        local ks = ctxt:keys()
        for i,name in ipairs(ks) do ks[i] = name.."="..tostring(ctxt[name]) end
        return mapconcat(id, ks, sep or ", ")
      end,
    print  = function (ctxt) print(ctxt); return ctxt end,
    vprint = function (ctxt) print(ctxt:tostring"\n"); return ctxt end,
  },
  __tostring = function (ctxt) return ctxt:tostring() end,
}

newcontext = function (T) T.__stack = {}; return Context(T) end

context = newcontext {}
defs    = newcontext {}



--[[
-- «contexts-test»  (to ".contexts-test")
-- Basic tests for contexts
* (eepitch-lua51)
* (eepitch-kill)
* (eepitch-lua51)
dofile "gabriela-app.lua"

c = newcontext {x=22, y=33}
c:print()
c:push("z", 44):print()
c:push("x", 99):print()
c:push("y", nil):print()
PP(c)
c:pop():print()
c:pop():print()
c:pop():print()
c:pop():print()   -- error

--]]



-- «def-lambda-app»  (to ".def-lambda-app")
-- A very simple implementation of definitions and application
Def    = function (name)       return Expr {[0]="De", name} end
App    = function (e1, e2)     return Expr {[0]="Ap", e1, e2} end
Lambda = function (name, expr) return Expr {[0]="\\", name, expr} end

Expr.__index.infix_other = function (e, b)
    local op, e1, e2, e3 = e[0], e[1], e[2], e[3]
    local t, str
    if     op == "De" then t, str = 200, e1
    elseif op == "Ap" then t, str = 200, e1:infix(3).."("..e2:infix()..")"
    elseif op == "\\" then t, str = 3,   "\\"..e1.."."..e2:infix()
    -- Bonus: set comprehension
    -- subset, set of images, generator, filter, collect
    elseif op == "Cs" then t, str = 200, "{"..e1:infix().." | "..
                                              e:infixs(", ", 2, #e-1).."}"
    elseif op == "Ci" then t, str = 200, "{"..e[#e]:infix().." | "..
                                              e:infixs(", ", 1, #e-1).."}"
    elseif op == "Cg" then t, str = 200, e1:infix().." in "..e2:infix()
    elseif op == "Cf" then t, str = 200, e1:infix()
    elseif op == "Co" then t, str = 200, e1:infix()
    -- all other things
                      else error("Bad expr")
    end
    return str, t
  end

Expr.__index.eval_other = function (e)
    local op, e1, e2, e3 = e[0], e[1], e[2], e[3]
    if     op == "De" then return defs[e1]:eval()
    elseif op == "\\" then return e
    elseif op == "Ap" then return _app(e1:eval(), e2:eval())
    elseif op == "Cs" then return _evalcompr(e)
    elseif op == "Ci" then return _evalcompr(e)
                      else print(tolisp(e)); error("Bad expr")
    end
  end

_app = function (f, a)
    if otype(f) ~= "Expr" then error("f must be an expr") end
    if otype(a) ~= "Expr" then error("a must be an expr") end
    local f0, fvarname, fexpr = f[0], f[1], f[2]
    if f0 ~= "\\" then error("f must be a lambda form") end
    context:push(fvarname, a)
    local result = fexpr:eval()
    context:pop()
    return result
  end

--[[
-- «def-lambda-app-tests»  (to ".def-lambda-app-tests")
-- Basic tests for lambda and app
* (eepitch-lua51)
* (eepitch-kill)
* (eepitch-lua51)
dofile "gabriela-app.lua"
f = Lambda("x", x + _2)
f7 = App(f, _3 + _4)
f:print()
f:peval()
f7:print()
f7:lprint()
f7:rprint()
f7:peval()

P = Def "P"
defs.P = Lambda("x", Le(x, _2))
App(P, _1):peval()
App(P, _2):peval()
App(P, _3):peval()

--]]



-- «comprehension»  (to ".comprehension")
-- Inspired by:
--   (find-es "haskell" "comprehension")
--   http://www.haskell.org/tutorial/goodies.html#tut-list-comps
--   http://www.haskell.org/onlinereport/exps.html#list-comprehensions
--   http://www.haskell.org/haskellwiki/List_comprehension
--   http://en.wikipedia.org/wiki/List_comprehension

Subset  = function (...)      return Expr {[0]="Cs", ...} end
Setof   = function (...)      return Expr {[0]="Ci", ...} end
Gen     = function (var, set) return Expr {[0]="Cg", var, set} end
Filt    = function (expr)     return Expr {[0]="Cf", expr} end
Collect = function (expr)     return Expr {[0]="Co", expr} end

_evalcompr_ = function (e, i)
    local op, e1, e2 = e[i][0], e[i][1], e[i][2]
    if     op == "Co" then _collect(e1:eval())
    elseif op == "Cf" then
      if not e1:beval() then return end
      _evalcompr_(e, i+1)
    elseif op == "Cg" then
      local varname = e1[1]
      local set     = e2:seval()
      -- print(tolisp(varname), tolisp(e2), tolisp(set))
      for _,value in ipairs(set) do
        context:push(varname, value)
        _evalcompr_(e, i+1)
        context:pop()
      end
    else print(i, op, e1, e2); error("what?")
    end
  end

_evalcompr = function (e)
    local old_collect = _collect
    local results = Set()
    _collect = function (e) table.insert(results, e) end
    _evalcompr_(e, 1)
    _collect = old_collect
    return results
  end


--[[
-- «comprehension-test»  (to ".comprehension-test")
* (eepitch-lua51)
* (eepitch-kill)
* (eepitch-lua51)
dofile "gabriela-app.lua"
_10 = Num(10)
A = Set(_1, _2, _3)
B = Setof(Gen(x, A), Gen(y, A), Filt(Le(x, y)), Collect(_10*x+y))
C = Setof(Gen(x, A), Gen(y, A), Filt(Le(x, y)), Collect(Tuple(x, y)))
D = Subset(Gen(x, A), Filt(Neq(x, _2)), Collect(x))
    Setof(Gen(x, A), Collect(Tuple(x, x*x))):preval()
B:preval()
C:preval()
D:preval()

--]]





-- «grids»  (to ".grids")
-- Some functions to create tables.
-- Too many things are hardcoded at the moment.
--
k = Var "k"
P = Def "P"

withdef = function (name, def, expr)
    defs:push(name, def)
    local result = expr:eval()
    defs:pop()
    return result
  end

cell = function (x, y)
    if y == 1 then return Cols[x] end
    if x == 1 then return Ps[y-1] end
    return withdef("P", Lambda("k", Ps[y-1]), Cols[x])
  end
column = function (x)
    local C = Rect {w=0}
    for y=1,#Ps+1 do C:set(y, cell(x, y):infix()) end
    return C
  end
columns = function (x1, x2)
    x1 = x1 or 1
    x2 = x2 or #Cols
    local result = column(x1)
    for x=x1+1,x2 do result = result.."  "..column(x) end
    return result
  end

efold = function (f, a, ...)
    local result = a
    for _,b in ipairs {...} do result = f(result, b) end
    return result
  end
Ors  = function (...) return efold(Or,  ...) end
Ands = function (...) return efold(And, ...) end

P1, P2, P3, P4 = App(P, _1), App(P, _2), App(P, _3), App(P, _4)
defs.E_1 = Ors (    P2, P3    )
defs.E_2 = Ors (P1, P2, P3, P4)
defs.E_3 = Ands(    P2, P3    )
defs.E_4 = Ands(P1, P2, P3, P4)
defs["E'_1"] = Or (Ors (P1, P2, P3), Ors (P2, P3, P4))
defs["E'_2"] = And(Ors (P1, P2, P3), Ors (P2, P3, P4))
defs["E'_3"] = Or (Ands(P1, P2, P3), Ands(P2, P3, P4))
defs["E'_4"] = And(Ands(P1, P2, P3), Ands(P2, P3, P4))

P123or   = Ors (P1, P2, P3)
P123and  = Ands(P1, P2, P3)
P234or   = Ors (P2, P3, P4)
P234and  = Ands(P2, P3, P4)
P123or   = Ex(k, Set(_1, _2, _3), App(P, k))
P123and  = Fa(k, Set(_1, _2, _3), App(P, k))
P234or   = Ex(k, Set(_2, _3, _4), App(P, k))
P234and  = Fa(k, Set(_2, _3, _4), App(P, k))
defs["E'_1"] = Or (P123or,  P234or)
defs["E'_2"] = And(P123or,  P234or)
defs["E'_3"] = Or (P123and, P234and)
defs["E'_4"] = And(P123and, P234and)

Cols = {
  App(P,  k),
  P1, P2, P3, P4,
  Def("E_1"), Def("E_2"), Def("E_3"), Def("E_4"),
}
Ps = {
   Ge(    k, _2),
   Ge( _2*k, _2),
   Eq(    k, _1),
   Lt(    k, _1),
  Neq(    k, _2),
  Neq(    k, _3),
  And(Neq(k, _2), Neq(k, _3)),
  Neq(    k, _0),
}




--[[
-- «grids-tests»  (to ".grids-tests")
-- Test the code for drawing tables
* (eepitch-lua51)
* (eepitch-kill)
* (eepitch-lua51)
dofile "gabriela-app.lua"
defs:vprint()
print(columns())

Cols = {
  App(P,  k),
  P1, P2, P3, P4,
  False,
  Def("E_4"), Def("E'_3"), Def("E_3"), Def("E_1"), Def("E'_2"), Def("E_2"),
  True,
}
Ps = {
   False,
   Ge(k, _4),
   Or(Eq(k, _1), Eq(k, _4)),
   Ge(k, _3),
   Or(Eq(k, _2), Eq(k, _3)),
   Ge(k, _2),
   True,
}
defs:vprint()
= columns()

--]]









-- Local Variables:
-- coding:             raw-text-unix
-- ee-anchor-format:   "«%s»"
-- End: