Warning: this is an htmlized version!
The original is across this link,
and the conversion rules are here.
-- gab.lua - Gabriela Avila's calculator for quantified
--   expressions, Lua version (full)
-- Author:  Eduardo Ochs <eduardoochs@gmail.com>
-- Version: 2012may13
-- Licence: GPL3
--
-- The latest upstream version of this can be found at:
--   http://angg.twu.net/dednat5/gab.lua
--   http://angg.twu.net/dednat5/gab.lua.html
--                    (find-dn5 "gab.lua")
--
-- Older version:
--   http://angg.twu.net/dednat5/gabriela.lua
--   http://angg.twu.net/dednat5/gabriela.lua.html
--                    (find-dn5 "gabriela.lua")
--   http://angg.twu.net/dednat5/gabriela-app.lua
--   http://angg.twu.net/dednat5/gabriela-app.lua.html
--                    (find-dn5 "gabriela-app.lua")


-- Quick index:
-- «.eoo.lua»		(to "eoo.lua")
-- «.Expr»		(to "Expr")
-- «.expr:infix»	(to "expr:infix")
-- «.constructors»	(to "constructors")
-- «.expr:tolisp»	(to "expr:tolisp")
-- «.expr:eval»		(to "expr:eval")
-- «.eval-quantifiers»	(to "eval-quantifiers")
-- «.Rect»		(to "Rect")
-- «.expr:print»	(to "expr:print")
-- «.expr:Dbg»		(to "expr:Dbg")
-- «.Context»		(to "Context")


-- 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")
-- «.old-parser»		(to "old-parser")
--   «.precedence-table»	(to "precedence-table")
--   «.precedence»		(to "precedence")
--   «.recursive-descent»	(to "recursive-descent")
--   «.parser-grammar»		(to "parser-grammar")
-- «.lpeg-parser»		(to "lpeg-parser")
-- «.pe»			(to "pe")
-- «.modal»			(to "modal")



--                   
--   ___  ___   ___  
--  / _ \/ _ \ / _ \ 
-- |  __/ (_) | (_) |
--  \___|\___/ \___/ 
--                   
-- «eoo.lua»  (to ".eoo.lua")
-- dofile "eoo.lua"  -- (find-dn5 "eoo.lua")
-- Just the relevant definitions from eoo.lua, to make this self-contained.
-- The documentation is at:
--   (find-dn5 "eoo.lua" "test-eoo")
--   (find-dn5 "eoo.lua" "box-diagram")
Class = {
    type   = "Class",
    __call = function (class, o) return setmetatable(o, class) end,
  }
setmetatable(Class, Class)
otype = function (o)  -- works like type, except on my "objects"
    local  mt = getmetatable(o)
    return mt and mt.type or type(o)
  end
-- end of eoo.lua


--                                                  _   
--  _ __ ___   __ _ _ __   ___ ___  _ __   ___ __ _| |_ 
-- | '_ ` _ \ / _` | '_ \ / __/ _ \| '_ \ / __/ _` | __|
-- | | | | | | (_| | |_) | (_| (_) | | | | (_| (_| | |_ 
-- |_| |_| |_|\__,_| .__/ \___\___/|_| |_|\___\__,_|\__|
--                 |_|                                  
--
-- And here are "mapconcat" and friends, from my init file:
-- (find-angg "LUA/lua50init.lua" "map" "mapconcat")
-- (find-lua51manualw3m "#pdf-table.concat")
map = function (f, A, i, j)
    local B = {}
    for k=(i or 1),(j or #A) do table.insert(B, (f(A[k]))) end
    return B
  end
mapconcat = function (f, A, sep, i, j)
    return table.concat(map(f, A, i, j), sep)
  end
foldl = function (f, a, B, i, j)
    for k=(i or 1),(j or #B) do a = f(a, B[k]) end
    return a
  end
id  = function (...) return ... end
sorted = function (T, lt) table.sort(T, lt); return T end
keys = function (T)
    local ks = {}
    for k,_ in pairs(T) do table.insert(ks, k) end
    return ks
  end
min = function (a, b) return a < b and a or b end
max = function (a, b) return a < b and b or a end
unpack = unpack or table.unpack
-- end of mapconcat



--  _____                 
-- | ____|_  ___ __  _ __ 
-- |  _| \ \/ / '_ \| '__|
-- | |___ >  <| |_) | |   
-- |_____/_/\_\ .__/|_|   
--            |_|         
--
-- «Expr»  (to ".Expr")
-- «expr:infix»  (to ".expr:infix")
Expr = Class {
  type    = "Expr",
  __index = {
    print  = function (e) print(e); return e end,  -- uses __tostring
  },
  __tostring = function (e) return tostring(e:infix()) end,
  __add = function (e1, e2) return Expr {[0]="+", e1, e2} end,
  __sub = function (e1, e2) return Expr {[0]="-", e1, e2} end,
  __mul = function (e1, e2) return Expr {[0]="*", e1, e2} end,
  __div = function (e1, e2) return Expr {[0]="/", e1, e2} end,
  __unm = function (e1)     return Expr {[0]="u-", e1} end,
}

-- Constructors
-- «constructors»  (to ".constructors")
Num  = function (n)  return Expr {[0]="n", n} end
Var  = function (s)  return Expr {[0]="v", s} end
Bool = function (b)  return Expr {[0]="b", b} end

Unm = function (e1) return - e1 end
Mul = function (e1, e2) return e1 * e2 end
Div = function (e1, e2) return e1 / e2 end
Add = function (e1, e2) return e1 + e2 end
Sub = function (e1, e2) return e1 - e2 end

Eq  = function (e1, e2) return Expr {[0]="==", e1, e2} end
Lt  = function (e1, e2) return Expr {[0]="<",  e1, e2} end
Le  = function (e1, e2) return Expr {[0]="<=", e1, e2} end
Ge  = function (e1, e2) return Expr {[0]=">=", e1, e2} end
Gt  = function (e1, e2) return Expr {[0]="<",  e1, e2} end
Neq = function (e1, e2) return Expr {[0]="!=", e1, e2} end

Not = function (e1)     return Expr {[0]="nt", e1} end
And = function (e1, e2) return Expr {[0]="&",  e1, e2} end
Or  = function (e1, e2) return Expr {[0]="or", e1, e2} end
Imp = function (e1, e2) return Expr {[0]="->", e1, e2} end

Tuple = function (...)  return Expr {[0]="()", ...} end
Set   = function (...)  return Expr {[0]="{}", ...} end

-- Fa  = function (e1, e2, e3) return Expr {[0]="Fa", e1, e2, e3} end
-- Ex  = function (e1, e2, e3) return Expr {[0]="Ex", e1, e2, e3} end

Fa  = function (e1, e2) return Expr {[0]="Fa", e1, e2} end
Ex  = function (e1, e2) return Expr {[0]="Ex", e1, e2} end

True  = Bool(true)
False = Bool(false)

--                         ___                         _       
-- __   ____ _ _ __ ___   ( _ )     ___ ___  _ __  ___| |_ ___ 
-- \ \ / / _` | '__/ __|  / _ \/\  / __/ _ \| '_ \/ __| __/ __|
--  \ V / (_| | |  \__ \ | (_>  < | (_| (_) | | | \__ \ |_\__ \
--   \_/ \__,_|_|  |___/  \___/\/  \___\___/|_| |_|___/\__|___/
--                                                             
-- Convenience: some expressions (variables and numeric constants)
-- that I use in tests
_0 = Num(0)
_1 = Num(1)
_2 = Num(2)
_3 = Num(3)
_4 = Num(4)
_5 = Num(5)
a = Var "a"
b = Var "b"
c = Var "c"
d = Var "d"
k = Var "k"
x = Var "x"
y = Var "y"





--  _        _ _           
-- | |_ ___ | (_)___ _ __  
-- | __/ _ \| | / __| '_ \ 
-- | || (_) | | \__ \ |_) |
--  \__\___/|_|_|___/ .__/ 
--                  |_|    
--
-- «expr:tolisp»  (to ".expr:tolisp")
-- A Lisp-ish representation.
-- Note that our Exprs use 0-based arrays, not cons cells.
--   (find-elnode "Cons Cell Type")
--   (find-elnode "Box Diagrams")
tolisp = function (e)
    if     type(e) == "number" then return e
    elseif type(e) == "string" then return "\""..e.."\""
    elseif otype(e) == "Expr"  then
      return "("..tolisp(e[0]).." "..mapconcat(tolisp, e, " ")..")"
    else   return "<"..tostring(e)..">"
    end
  end
Expr.__index.tolisp = function (e) return tolisp(e) end
Expr.__index.lprint = function (e) print(e:tolisp()); return e end



--  _        __ _      
-- (_)_ __  / _(_)_  __
-- | | '_ \| |_| \ \/ /
-- | | | | |  _| |>  < 
-- |_|_| |_|_| |_/_/\_\
--                     

Expr.__index.infix = function (e, b)
    local op, e1, e2, e3 = e[0], e[1], e[2], e[3]
    local t, str
    if     op == "v"  then t, str = 200, e[1]
    elseif op == "n"  then t, str = 200, tostring(e[1])
    elseif op == "b"  then t, str = 200, e[1] and "T" or "F"
    elseif op == "u-" then t, str = 9, "-"..e1:infix(100)
    elseif op == "*"  then t, str = 8, e1:infix(7).."*"..e2:infix(8)
    elseif op == "/"  then t, str = 8, e1:infix(7).."*"..e2:infix(8)
    elseif op == "+"  then t, str = 7, e1:infix(6).."+"..e2:infix(7)
    elseif op == "-"  then t, str = 7, e1:infix(6).."-"..e2:infix(7)
    elseif op == "==" then t, str = 6, e1:infix(6).." == "..e2:infix(6)
    elseif op == "<=" then t, str = 6, e1:infix(6).." <= "..e2:infix(6)
    elseif op == ">=" then t, str = 6, e1:infix(6).." >= "..e2:infix(6)
    elseif op == "<"  then t, str = 6, e1:infix(6).." < " ..e2:infix(6)
    elseif op == ">"  then t, str = 6, e1:infix(6).." > " ..e2:infix(6)
    elseif op == "!=" then t, str = 6, e1:infix(6).." != "..e2:infix(6)
    elseif op == "nt" then t, str = 5, "not "..e1:infix(4)
    elseif op == "&"  then t, str = 4, e1:infix(3).." & " ..e2:infix(4)
    elseif op == "or" then t, str = 3, e1:infix(2).." or "..e2:infix(3)
    elseif op == "->" then t, str = 2, e1:infix(2).." -> "..e2:infix(2)
    elseif op == "()" then t, str = 200,   "("..e:infixs()..")"
    elseif op == "{}" then t, str = 200,   "{"..e:infixs().."}"
    elseif op == "Fa" then t, str = 1, "Fa "..e1:infix()..". "..e2:infix()
    elseif op == "Ex" then t, str = 1, "Ex "..e1:infix()..". "..e2:infix()
    -- elseif op == "Fa" then t, str = 1, "Fa "..e1:infix().." in "..
    --                                           e2:infix()..". "..e3:infix()
    -- elseif op == "Ex" then t, str = 1, "Ex "..e1:infix().." in "..
    --                                           e2:infix()..". "..e3:infix()
    elseif op == "Dg" then str, t = e1:infix()
    --#ifdef HAS_LAMBDA
    elseif 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:infix().."."..e2:infix()
    --#endif HAS_LAMBDA
    --#ifdef HAS_COMPREHENSION
    -- subset, set of images, generator, filter, collect
    elseif op == "Su" then t, str = 200, "{"..e1:infix().." | "..
                                              e:infixs(", ", 2, #e-1).."}"
    elseif op == "So" then t, str = 200, "{"..e[#e]:infix().." | "..
                                              e:infixs(", ", 1, #e-1).."}"
    elseif op == "<-" then t, str = 200, e1:infix().." <- "..e2:infix()
    --#endif HAS_COMPREHENSION
    --#endif HAS_MODAL
    elseif op == "Mo" then t, str = 200, e1
    --#ifdef HAS_MODAL
    --                else str, t = e:infix_other(b)  -- all extensions
                      else error("Bad expr:"..tolisp(e))
    end
    if b and t <= b then str = "("..str..")" end
    return str, t
  end
Expr.__index.infixs = function (e, sep, i, j)
    return mapconcat(e.infix, e, (sep or ", "), i, j)
  end






--                  _ 
--   _____   ____ _| |
--  / _ \ \ / / _` | |
-- |  __/\ V / (_| | |
--  \___| \_/ \__,_|_|
--                    

-- «expr:eval»  (to ".expr:eval")
-- Evaluation.
-- To avoid making the code above too big we inject new methods into
-- Expr, using a low-level syntax for that:
--     Expr.__index.newmethod = function (e, a, b, c) ... end

etype  = function (e) return otype(e) == "Expr" and e[0] end
Expr.__index.neval = function (e)
    local ee = e:eval()
    if etype(ee) == "n" then return ee[1] end
    error("Not a number: "..tostring(ee))
  end
Expr.__index.beval = function (e)
    local ee = e:eval()
    if etype(ee) == "b" then return ee[1] end
    error("Not a boolean: "..tostring(ee))
  end
Expr.__index.seval = function (e)
    local ee = e:eval()
    if etype(ee) == "{}" then return ee end
    error("Not a set: "..tostring(ee))
  end
Expr.__index.eval_components = function (e)
    local A = map(e.eval, e)
    A[0] = e[0]
    return Expr(A)
  end

_and = function (P, Q) return P and Q end
_or  = function (P, Q) return P or  Q end
_imp = function (P, Q) return (not P) or Q end
context = {}
Expr.__index.eval = function (e)
    local op, e1, e2, e3 = e[0], e[1], e[2], e[3]
    if     op == "n" then return e
    elseif op == "b" then return e
    elseif op == "v" then return context[e1] or error("Undef: "..e1)
    elseif op == "u-" then return Num(- e1:neval())
    elseif op == "*"  then return Num(e1:neval() * e2:neval())
    elseif op == "/"  then return Num(e1:neval() / e2:neval())
    elseif op == "+"  then return Num(e1:neval() + e2:neval())
    elseif op == "-"  then return Num(e1:neval() - e2:neval())
    elseif op == "==" then return Bool(e1:neval() == e2:neval())
    elseif op == "<=" then return Bool(e1:neval() <= e2:neval())
    elseif op == ">=" then return Bool(e1:neval() >= e2:neval())
    elseif op == "<"  then return Bool(e1:neval() <  e2:neval())
    elseif op == ">"  then return Bool(e1:neval() >  e2:neval())
    elseif op == "!=" then return Bool(e1:neval() ~= e2:neval())
    elseif op == "nt" then return Bool(not e1:beval())
    elseif op == "&"  then return Bool(_and(e1:beval(), e2:beval()))
    elseif op == "or" then return Bool(_or (e1:beval(), e2:beval()))
    elseif op == "->" then return Bool(_imp(e1:beval(), e2:beval()))
    elseif op == "{}" then return e:eval_components()
    elseif op == "()" then return e:eval_components()
    elseif op == "Fa" then return Bool(e1[1]:_fold(true,_and,_beval, e1[2], e2))
    elseif op == "Ex" then return Bool(e1[1]:_fold(false,_or,_beval, e1[2], e2))
    -- elseif op == "Fa" then return Bool(e1:_fold(true, _and, _beval, e2, e3))
    -- elseif op == "Ex" then return Bool(e1:_fold(false, _or, _beval, e2, e3))
    elseif op == "Dg" then return e1:DbgEval()    -- defined elsewhere
                      else return e:eval_other()  -- all extensions
    end
  end


--                          _   _  __ _               
--   __ _ _   _  __ _ _ __ | |_(_)/ _(_) ___ _ __ ___ 
--  / _` | | | |/ _` | '_ \| __| | |_| |/ _ \ '__/ __|
-- | (_| | |_| | (_| | | | | |_| |  _| |  __/ |  \__ \
--  \__, |\__,_|\__,_|_| |_|\__|_|_| |_|\___|_|  |___/
--     |_|                                            

-- «eval-quantifiers»  (to ".eval-quantifiers")
-- The evaluation code for "Fa" and "Ex" calls "_fold" and "_beval",
-- that are defined below.
Expr.__index.varname = function (e)
    if etype(e) == "v" then return e[1] end
    error("Not a variable: "..tostring(ee))
  end
Expr.__index.as = function (var, value, expr)
    local vname    = var:varname()
    local oldvalue = context[vname]
    context[vname] = value
    local result   = expr:eval()
    context[vname] = oldvalue
    return result
  end
Expr.__index._fold = function (var, r, op, normalize, set, expr)
    for _,value in ipairs(set) do
        r = op(r, normalize(var:as(value, expr)))
      end
    return r
  end

_beval = function (e) return e:beval() end

Expr.__index.peval  = function (e)
    local result = e:eval()
    print(tostring(e).."  -->  "..tostring(result))
    return result
  end


-- __        ___                
-- \ \      / / |__   ___ _ __  
--  \ \ /\ / /| '_ \ / _ \ '_ \ 
--   \ V  V / | | | |  __/ | | |
--    \_/\_/  |_| |_|\___|_| |_|
--                              
-- Obsolete?
Expr.__index.When = function (var, value, expr)
    return "When "  ..tostring(var)..
           "="      ..tostring(value)..
           ":  "    ..tostring(expr)..
           "  -->  "..tostring(var:as(value, expr))
  end
Expr.__index.Whens = function (var, set, expr)
    for _,value in ipairs(set) do
      print(var:When(value, expr))
    end
  end



--  ____           _   
-- |  _ \ ___  ___| |_ 
-- | |_) / _ \/ __| __|
-- |  _ <  __/ (__| |_ 
-- |_| \_\___|\___|\__|
--                     
-- «Rect»  (to ".Rect")
-- Rectangles (for trees)
-- (find-luamanualw3m "#pdf-string.rep")
strrep = function (str, n) return string.rep(str, max(0, n)) end
strpad = function (str, n, char) return str..strrep(char or " ", n-#str) end
copy = function (A)
    local B = {}
    for k,v in pairs(A) do B[k] = v end
    setmetatable(B, getmetatable(A))
    return B
  end

stringtorect = function (str, height)
    local lines = splitlines(str)
    lines.w     = foldl(max, 0, map(string.len, lines))
    return Rect(lines):raise(height or 0)
  end
torect = function (o, height)
    if otype(o) == "Rect" then return o end
    if otype(o) == "Expr" then return o:torect() end
    return stringtorect(tostring(o), height)
  end

Rect = Class {
  type    = "Rect",
  __index = {
    copy = function (rect) return copy(rect) end,
    min  = function (rect)
        for i=1,-100000,-1 do if rect[i-1] == nil then return i end end
      end,
    max  = function (rect) return #rect end,
    raise = function (rect, n)
        if n == "b" then n = rect:max()-1 end
        for i=rect:min(),rect:max()+n do rect[i-n] = rect[i] end
        return rect
      end,
    lower = function (rect, n)
        if n == "t" then n = -rect:min()+1 end
        for i=rect:max(),rect:min()-n,-1 do rect[i+n] = rect[i] end
        return rect
      end,
    lowert = function (rect)
        return rect:min() == 1 and rect or rect:copy():lower("t")
      end,
    --
    get  = function (rect, y) return rect[y] or "" end,
    getp = function (rect, y, c) return strpad(rect:get(y), rect.w, c) end,
    adjw = function (rect, y) rect.w = max(rect.w, #rect:get(y)) end,
    set  = function (rect, y, str, fill)
        for i=y+1,rect:min()-1 do rect[i] = fill or "" end
        for i=#rect+1,y-1      do rect[i] = fill or "" end
	rect[y] = str
	rect:adjw(y)
	return rect
      end,
    under  = function (rect, str)
        return rect:copy():set(rect:min()-2, str, "|"):lower(2)
      end,
    under_ = function (rect, str, n)
        return rect:under(strpad(str, rect.w+(n or 2), "_"))
      end,
  },
  __tostring = function (rect)
      return mapconcat(id, rect, "\n", rect:min(), rect:max())
    end,
  __concat = function (r1, r2)
      r1 = torect(r1)
      r2 = torect(r2)
      r3 = Rect {w=0}
      for y=min(r1:min(), r2:min()),max(r1:max(), r2:max()) do 
        r3:set(y, r1:getp(y, " ")..r2:get(y))
      end
      r3.l = r1.l
      r3.r = r2.r
      return r3
    end,
}

rectconcat = function (op, rects)
    if #rects == 0 then return torect(op) end
    if #rects == 1 then return torect(rects[1]):under(op) end
    local out = torect(rects[1]):under_(op)
    for i=2,#rects-1 do out = out..torect(rects[i]):under_(".") end
    return out..torect(rects[#rects]):under(".")
  end


Expr.__index.torect = function (e)
    local op, e1 = e[0], e[1]
    if op == "n" then return torect(e1) end
    if op == "v" then return torect(e1) end
    if op == "b" then return torect(e:infix()) end
    -- local subrects = map(Expr.__index.torect, e)
    local subrects = map(torect, e)
    return rectconcat (op, subrects)
  end

-- «expr:print»  (to ".expr:print")
-- Some methods for printing
Expr.__index.rprint = function (e) print(e:torect()); return e end
Expr.__index.preval  = function (e)
    print(tostring(e))
    print(torect(e))
    print()
    local result = e:eval()
    print("  -->  "..tostring(result))
    print()
    return result
  end



--  ____  _           
-- |  _ \| |__   __ _ 
-- | | | | '_ \ / _` |
-- | |_| | |_) | (_| |
-- |____/|_.__/ \__, |
--              |___/ 
--
-- «expr:Dbg»  (to ".expr:Dbg")
-- Support for debugging (verbose subexpressions)
Expr.__index.Dbg     = function (e1) return Expr {[0]="Dg", e1} end
Expr.__index.DbgEval = function (expr)
    local result = expr:eval()
    print(contextstring()..tostring(expr).."  -->  "..tostring(result))
    return result
  end
contextstring = function ()
    local sk = sorted(keys(context))
    local f = function (name) return name.."="..tostring(context[name]) end
    return "["..mapconcat(f, sk, " ").."]  "
  end




--   ____            _            _   
--  / ___|___  _ __ | |_ _____  _| |_ 
-- | |   / _ \| '_ \| __/ _ \ \/ / __|
-- | |__| (_) | | | | ||  __/>  <| |_ 
--  \____\___/|_| |_|\__\___/_/\_\\__|
--                                    
-- «Context»  (to ".Context")
-- 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 {}




--  _                 _         _       
-- | | __ _ _ __ ___ | |__   __| | __ _ 
-- | |/ _` | '_ ` _ \| '_ \ / _` |/ _` |
-- | | (_| | | | | | | |_) | (_| | (_| |
-- |_|\__,_|_| |_| |_|_.__/ \__,_|\__,_|
--                                      
-- «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 (var, expr) return Expr {[0]="\\", var, expr} 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 == "Su" then return _evalcompr(e)
    elseif op == "So" 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
    if f[1][0]  ~= "v"    then error("x must ber a var")  end
    local f0, fvarname, fexpr = f[0], f[1][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



--   ____                               _                    _             
--  / ___|___  _ __ ___  _ __  _ __ ___| |__   ___ _ __  ___(_) ___  _ __  
-- | |   / _ \| '_ ` _ \| '_ \| '__/ _ \ '_ \ / _ \ '_ \/ __| |/ _ \| '_ \ 
-- | |__| (_) | | | | | | |_) | | |  __/ | | |  __/ | | \__ \ | (_) | | | |
--  \____\___/|_| |_| |_| .__/|_|  \___|_| |_|\___|_| |_|___/_|\___/|_| |_|
--                      |_|                                                

-- «comprehension»  (to ".comprehension")
-- (find-dn5 "gab-tests.lua" "comprehension-1")
-- 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]="Su", ...} end
Setof   = function (...)      return Expr {[0]="So", ...} end
Gen     = function (var, set) return Expr {[0]="<-", var, set} end

_evalcompr_ = function (es, collect, i)
    local e, op, e1, e2 = es[i], es[i][0], es[i][1], es[i][2]
    if i == #es then collect(e:eval()); return end
    if op == "<-" then                  -- generator
      if e1[0] ~= "v" then error("Not a var") end
      local varname = e1[1]
      local set     = e2:seval()
      for _,value in ipairs(set) do
        context:push(varname, value)
        _evalcompr_(es, collect, i+1)
        context:pop()
      end
    else                                -- filter
      if not e:beval() then return end  --  on F: abort
      _evalcompr_(es, collect, i+1)     --  on T: continue
    end
  end

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




--             _     _     
--   __ _ _ __(_) __| |___ 
--  / _` | '__| |/ _` / __|
-- | (_| | |  | | (_| \__ \
--  \__, |_|  |_|\__,_|___/
--  |___/                  
--
-- «grids»  (to ".grids")
-- Some functions to create tables.
-- Too many things are hardcoded at the moment.
--
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

P = Def "P"

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),
}




--        _     _                                  
--   ___ | | __| |  _ __   __ _ _ __ ___  ___ _ __ 
--  / _ \| |/ _` | | '_ \ / _` | '__/ __|/ _ \ '__|
-- | (_) | | (_| | | |_) | (_| | |  \__ \  __/ |   
--  \___/|_|\__,_| | .__/ \__,_|_|  |___/\___|_|   
--                 |_|                             
-- Moved to:
-- (find-dn5 "gab-oldparser.lua")
-- «old-parser»  (to ".old-parser")
--   «precedence-table»   (to ".precedence-table")
--   «precedence»         (to ".precedence")
--   «recursive-descent»  (to ".recursive-descent")
--   «parser-grammar»     (to ".parser-grammar")




--  _                                                   
-- | |_ __   ___  __ _   _ __   __ _ _ __ ___  ___ _ __ 
-- | | '_ \ / _ \/ _` | | '_ \ / _` | '__/ __|/ _ \ '__|
-- | | |_) |  __/ (_| | | |_) | (_| | |  \__ \  __/ |   
-- |_| .__/ \___|\__, | | .__/ \__,_|_|  |___/\___|_|   
--   |_|         |___/  |_|                             
--
-- «lpeg-parser»  (to ".lpeg-parser")
-- A reimplementation in LPEG of the recursive-descent parser

if userocks
then userocks(); loadlpeg()  -- (find-angg "LUA/lua50init.lua" "loadlpeg")
else require "lpeg"          -- (find-vldifile "liblua5.1-lpeg2.list")
end

-- require "lpeg"
P  = lpeg.P
V  = lpeg.V
Cc = lpeg.Cc
Ct = lpeg.Ct
Cb = lpeg.Cb
Cg = lpeg.Cg

local ispattern = function (o)
     return getmetatable(o) == getmetatable(lpeg.P"")
  end
local set = function (name, o)
    if ispattern(o) then return o:Cg(name) else return lpeg.Cc(o):Cg(name) end
  end
local get    = function (name) return lpeg.Cb(name) end
local group  = function (cmds) return lpeg.Cg(cmds) end
local applys = function (e, T) return T[#T](e, unpack(T, 1, #T-1)) end


ops = {}
newbinop = function (l, t, r, str)
    for op in str:gmatch("[^ ]+") do ops[op] = {l=l, t=t, r=r} end
  end
newbinop(10, 11, 12, "->")
newbinop(12, 13, 14, "or")
newbinop(14, 15, 16, "&")
newbinop(18, 17, 18, "== <= >= < > !=    <-")
newbinop(18, 19, 20, "+ -")
newbinop(20, 21, 22, "* /")

above    = function (lop, rop) return lop == "" or ops[lop].r < ops[rop].t end
is_binop = function (subj, pos, c) if ops[c] then return true, c end end
is_under = function (subj, pos, lop, op)
    if above(lop, op) then return true, op end
  end

pack_num    = function (str)        return Num(tonumber(str)) end
pack_var    = function (str)        return Var(str) end
pack_bin    = function (e1, op, e2) return Expr {[0]=op, e1, e2} end
pack_app    = function (e1, e2)     return App(e1, e2) end
pack_tuple  = function (L)        return #L==1 and L[1] or Tuple(unpack(L)) end
pack_qlexpr = function (ql, a, b)   -- quantifiers and lambda
    if ql == "Fa" then return Fa(a, b) end
    if ql == "Ex" then return Ex(a, b) end
    if ql == "\\" then return Lambda(a, b) end
  end

-- Sets come in four flavors:
--   {e1<-e2 | P, Q}       => Subset(e1<-e2, P, Q, e1}
--   {e      | a<-A, b<-B} => Setof(a<-A, b<-B, e}
--   {a, b, c}             => Set(a, b, c)
--   {}                    => Set()
pack_subset = function (e, L)
    table.insert(L, e[1])
    return Subset(e, unpack(L))
  end
pack_setof = function (e, L)     
    table.insert(L, e)
    return Setof(unpack(L))
  end
pack_set = function (a, b, c)
    if b == "|" and a[0] == "<-" then return pack_subset(a, c) end
    if b == "|" and a[0] ~= "<-" then return pack_setof (a, c) end
    if a == "" or a == nil then return Set() end
    return Set(a, unpack(b or {}))
  end

sp       = lpeg.S" \t\n"^0
sP       = function (str) return sp * P(str) end

Expr_grammar = {
  "Expr",     -- initial rule name
  Alpha       = lpeg.R"AZ" + lpeg.R"az",
  Alphanum    = lpeg.R"AZ" + lpeg.R"az" + lpeg.R"09" + P"_",
  Num         = sp * (lpeg.R"09"^1):C()              / pack_num,
  Var         = sp * (V"Alpha" * V"Alphanum"^0):C()  / pack_var,
  --
  Commaexprs  = (sP"," * V"Expr")^0,
  Exprs       = V"Expr" * V"Commaexprs",
  Parenexpr   = (sP"(" * V"Exprs" * sP")"):Ct()      / pack_tuple,
  Setexpr     = sP"{" *
                ( sP"}" * Cc""
                + V"Expr" *
                  ( sP"}"
                  + V"Commaexprs":Ct() * sP"}"
                  + sp * P"|":C() * V"Exprs":Ct() * sP"}")) / pack_set,
  --
  Ql          = sp * (P"Fa" + P"Ex" + P"\\"):C(),
  Qlexpr      = V"Ql" * V"Expr" * sP"." * V"Expr"       / pack_qlexpr,
  --
  Binop       = sp * ((lpeg.P(2):Cmt(is_binop) +
                       lpeg.P(1):Cmt(is_binop))),
  Binop_under = (get"lop" * V"Binop"):Cmt(is_under),
  Binop_setlop = set("lop", V"Binop_under") * get("lop"),
  --
  Expr_wos    = V"Parenexpr"
              + V"Setexpr"
              + V"Qlexpr"
              + V"Num"
              + V"Var",
  Complement  = group(V"Binop_setlop" * V"Expr_under" * Cc(pack_bin)):Ct()
              + (V"Parenexpr" * Cc(pack_app)):Ct(),
  Expr_under  = (V"Expr_wos" * V"Complement"^0):Cf(applys),
  Expr        = group(set("lop", "") * V"Expr_under"),
}
Expr_pattern  = lpeg.P(Expr_grammar)

lpeg.prmatch = function (patt, ...) PP(patt:match(...)) end
etest = function (str)
    local e = Expr_pattern:match(str)
    print(e)
    print(e:torect())
  end
eteste = function (str)
    local e = Expr_pattern:match(str)
    print(e)
    print(e:torect())
    print(e:eval())
  end

-- «pe»  (to ".pe")
-- pe:  parse expression
-- pev: parse expression, evaluate, print all
-- pep: parse expression and print (do not evaluate)
pe = function (str) return Expr_pattern:match(str) end
pep = function (str) return pe(str):print():rprint() end
pev = function (str) return pe(str):print():rprint():eval():print() end



--  __  __           _       _ 
-- |  \/  | ___   __| | __ _| |
-- | |\/| |/ _ \ / _` |/ _` | |
-- | |  | | (_) | (_| | (_| | |
-- |_|  |_|\___/ \__,_|\__,_|_|
--                             
-- «modal»  (to ".modal")
-- (find-angg "LUA/canvas3.lua")
-- (find-angg "LUA/canvas3.lua" "ZDag-functions")

-- It should be easy to make the logic of the calculator more
-- flexible... at present it is boolean, two-valued, with the same
-- truth values as the underlying Lua.

Vee_ = function (s)
    local a, b, c = s:sub(1,1), s:sub(2,2), s:sub(3,3)
    return Rect {w=3, a.." "..b, " "..c}
  end
Vee = function (s)
    return Expr {[0]="Mo", Vee_(s)}
  end

-- (find-angg "LUA/canvas3.lua" "ZDag-functions")
-- A "shape" is a string made of digits, newlines, and spaces.
-- A "short" is a string made of "0"s and "1"s.
-- For example:
-- reh_shape = " 1\n"  ..
--             "2 3\n" ..
--             "4"
-- and "0101" is a short that represents an open set on Reh
-- in a compact form.

cton = function (c) return tonumber(c, 36) end
intoshape = function (shape, short)
    local f = function (c) return short:sub(cton(c), cton(c)) end
    return (shape:gsub("(%w)", f))
  end
shapetoarrows = function (shape)
    local lines = splitlines(shape)
    local arrows = {}
    local registerbpm = function (v1, v2)
        if v1 and v2 then table.insert(arrows, {v1, v2}) end
      end
    for y=1,#lines-1 do
      for x=1,#lines[y] do
        local c  = cton(lines[y  ]:sub(x,   x  ))
        local sw = cton(lines[y+1]:sub(x-1, x-1))
        local s  = cton(lines[y+1]:sub(x,   x  ))
        local se = cton(lines[y+1]:sub(x+1, x+1))
        registerbpm(c, sw)    -- is southwest a black pawn's move?
        registerbpm(c, s)     -- is south     a black pawn's move?
        registerbpm(c, se)    -- is southeast a black pawn's move?
      end
    end
    return arrows
  end
shapetocoords = function (shape)
    local lines = splitlines(shape)
    local coords = {}
    for y=1,#lines do
      for x=1,#lines[y] do
        local c  = cton(lines[y]:sub(x, x))
	if c then coords[c] = {x, y} end
      end
    end
    return coords
  end





-- This is just a library.
print("Loading: gab.lua")
io.stdout:setvbuf("no")    -- (find-es "lua5" "setvbuf")






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