|
Warning: this is an htmlized version!
The original is here, 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: