--- lam.core --- core procedures

local dump = require("dump")
local type = require("type")
local assert_arity, assert_type = type.assert_arity, type.assert_type
local null = type.null
local error = require("util").error

local function fold (kons, knil, r)
	if r == null then
		return knil
	else
		local step, early_return = kons(r[1], knil)
		if early_return then return early_return end
		return fold(kons, step, r[2])
	end
end

local env = {}

---[[ EQUIVALENCE ]]---

env["eqv?"] = function (r)
	assert_arity(r,2,2)
	return r[1] == r[2][1]
end
-- from what i understand of the spec, it's okay that eqv? and eq? are the same
env["eq?"] = env["eqv?"]

---[[ VALUES ]]---

env.values = function (r)
	return table.unpack(type.totable(r))
end

---[[ TYPES ]]---

env["boolean?"] = function (r)
	assert_arity(r,1,1)
	return r[1] == false or r[1] == true
end

env["port?"] = function (r)
	assert_arity(r,1,1)
	return type.isp(r[1], "input-port") or type.isp(r[1], "output-port")
end

for _, t in ipairs {
	"symbol",
	-- todo: vector
	"procedure",
	"pair",
	"number",
	"string",
	"port",
} do
	env[t.."?"] = function (r)
		assert_arity(r,1,1)
		return type.isp(r[1], t)
	end
end

---[[ CONVERTING BETWEEN TYPES ]]---

env["symbol->string"] = function (r)
	assert_arity(r,1,1)
	assert_type(r[1], "symbol")
	return type.string(r[1])
end

env["string->symbol"] = function (r)
	assert_arity(r,1,1)
	assert_type(r[1], "string")
	return r[1].v
end

env["number->string"] = function (r) -- (z . radix)
	assert_arity(r,1,2)
	assert_type(r[1], "number")
	-- todo: assert radix type
	local z, radix = r[1], r[2][1] or 10
	local n = {}
	if radix == 10 then return type.string(z) end
	repeat
		local mod = z % radix
		if mod > 9 then
			mod = string.sub("abcdefghijklmnopqrstuvwxyz", mod-9, 1)
		end
		table.insert(n, 1, z % radix)
		z = math.floor(z/radix)
	until z == 0
	return type.string(n)
end

env["string->number"] = function (r) -- (z . radix)
	assert_arity(r,1,2)
	assert_type(r[1], "string")
	-- todo: assert radix type
	print(require('dump').dump(r))
	return tonumber(r[1].v, r[2][1]) or false
end

env["char->integer"] = function (r)
	assert_arity(r,1,1)
	assert_type(r[1], "char")
	return r[1].u
end

env["integer->char"] = function (r)
	assert_arity(r,1,1)
	assert_type(r[1], "number") -- todo: check integer
	return type.character(r[1])
end

env["string->list"] = function (r)
	assert_arity(r,1,1)
	assert_type(r[1], "string")
	local t = {}
	for _, c in ipairs(r[1]) do
		table.insert(t, type.character(c))
	end
	return type.list(t)
end

env["list->string"] = function (r)
	assert_arity(r,1,1)
	if not type.listp(r[1]) then
		error("not a list", r[1])
	end
	local t = {}
	for _, c in ipairs(type.totable(r[1])) do
		table.insert(t, c.v)
	end
	return type.string(t)
end

---[[ NUMBERS ]]---

env["="] = function (r)
	if r[1] == nil then return true end
	if r[2] == nil then return true end
	while r[2] ~= null do
		if r[1] ~= r[2][1] then return false end
		r = r[2]
	end
	return true
end

env["<"] = function (r)
	if r[1] == nil then return true end
	if r[2] == nil then return true end
	while r[2] ~= null do
		if r[1] >= r[2][1] then return false end
		r = r[2]
	end
	return true
end
env[">"] = function (r)
	if r[1] == nil then return true end
	if r[2] == nil then return true end
	while r[2] ~= null do
		if r[1] <= r[2][1] then return false end
		r = r[2]
	end
	return true
end
env["<="] = function (r) return not env[">"](r) end
env[">="] = function (r) return not env["<"](r) end

env["+"] = function (r)
	return fold(function (a, b) return a + b end, 0, r)
end

env["-"] = function (r)
	if r == null then return -1 end
	if r[2] == null then return (- r[1]) end
	return fold(function (a, b)
			return a - b
	end, r[1], r[2])
end

env["*"] = function (r)
	local function go (a, b)
		if a == 0 or b == 0 then
			return 0, 1
		end
		return a * b
	end
	return fold(go, 1, r)
end

env["/"] = function (r)
	assert_arity(r,1)
	if r[2] == null then return (1 / r[1]) end
	return fold(function (a, b) return a / b end,
		r[1], r[2])
end

---[[ STRINGS ]]---

env["string-append"] = function (r)
	assert_arity(r,1)
	local ss = type.totable(r)
	local new = {}
	for i, s in ipairs(ss) do
		new[i] = s.v
	end
	return type.string(table.concat(new))
end

---[[ INPUT / OUTPUT ]]---

env.dump = function (r)
	assert_arity(r,1,1)
	return dump.dump(r[1])
end

env.display = function (r)
	assert_arity(r,1,1)
	io.write(tostring(r[1]))
	io.flush()
end

env.newline = function (r)
	assert_arity(r,0,0)
	io.write("\n")
	io.flush()
end

--------
return {
	environment = env,
}