From 04beefb7169a9a1a3d44737786e0ef76ba676aba Mon Sep 17 00:00:00 2001
From: Case Duckworth
Date: Sat, 23 Mar 2024 15:50:56 -0500
Subject: Add a bunch of base functions

---
 base.lua | 230 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 229 insertions(+), 1 deletion(-)

(limited to 'base.lua')

diff --git a/base.lua b/base.lua
index 6dc71e4..b6e3a30 100644
--- a/base.lua
+++ b/base.lua
@@ -2,9 +2,78 @@
 
 local base = {}
 local type = require "type"
-local isNull = type.isNull
+local isNull, isa, totable = type.isNull, type.isa, type.totable
+local math = math
 
 base.env = {
+	-- Equivalence
+	["eqv?"] =
+		function (r)
+			local a, b = r.car, r.cdr.car
+			if a == b then
+				return true
+			else
+				return false
+			end
+ 		end,
+	-- ["eq?"] = function (r) end, -- how would this be different to eqv?
+	-- Numbers
+	["number?"] = function (r) return isa(r.car, "Number") end,
+	-- ["complex?"] = function (r) end,
+	-- ["real?"] = function (r) end,
+	-- ["rational?"] = function (r) end,
+	-- ["integer?"] = function (r) end,
+	-- ["exact?"] = function (r) end,
+	-- ["inexact?"] = function (r) end,
+	-- ["exact-integer?"] = function (r) end,
+	-- ["finite?"] = function (r) end,
+	-- ["infinite?"] = function (r) end,
+	["="] =
+		function (r)
+			local n, r = r.car, r.cdr
+			while r.cdr do
+				if n ~= r.car then return false end
+				r = r.cdr
+			end
+			return true
+		end,
+	["<"] =
+		function (r)
+			local n, r = r.car, r.cdr
+			while r.cdr do
+				if n >= r.car then return false end
+				r = r.cdr
+			end
+			return true
+		end,
+	[">"] =
+		function (r)
+			local n, r = r.car, r.cdr
+			while r.cdr do
+				if n <= r.car then return false end
+				r = r.cdr
+			end
+			return true
+		end,
+	["<="] =
+		function (r)
+			local n, r = r.car, r.cdr
+			while r.cdr do
+				if n > r.car then return false end
+				r = r.cdr
+			end
+			return true
+		end,
+	[">="] =
+		function (r)
+			local n, r = r.car, r.cdr
+			while r.cdr do
+				if n < r.car then return false end
+				r = r.cdr
+			end
+			return true
+		end,
+	-- Math
 	["+"] =
 		function (r)
 			local r, a = r, 0
@@ -23,6 +92,165 @@ base.env = {
 			end
 			return a
 		end,
+	["*"] =
+		function (r)
+			local r, a = r, 1
+			while r.cdr do
+				if r.cdr == 0 then return 0 end
+				r, a = r.cdr, a * r.car
+			end
+			return a
+		end,
+	["/"] =
+		function (r)
+			if isNull(r) then error("Wrong arity") end
+			if isNull(r.cdr) then return (1 / r.car) end
+			local r, a = r.cdr, r.car
+			while r.cdr do
+				r, a = r.cdr, a / r.car
+			end
+			return a
+		end,
+	quotient =
+		function (r)
+		end,
+	remainder =
+		function (r)
+		end,
+	modulo =
+		function (r)
+		end,
+	-- numerator = function (r) end,
+	-- denominator = function (r) end,
+	abs = function (r) return math.abs(r.car) end,
+	floor = -- largest integer <= x
+		function (r) return math.floor(r.car) end,
+	ceiling = -- smallest integer >= x
+		function (r) return math.ceil(r.car) end,
+	truncate = -- smallest |integer| <= |x|
+		function (r)
+			local i, _ = math.modf(r.car)
+			return i
+		end,
+	round = -- closest integer to x (ties go even)
+		function (r)
+			local i, f = math.modf(r.car)
+			if f == 0.5 then
+				if i % 2 == 0 then
+					return i
+				else
+					return i+1
+				end
+			else
+				return i -- is this right?
+			end
+		end,
+	-- Trig
+	exp = function (r) return math.exp(r.car) end,
+	log = function (r) return math.log(r.car) end,
+	pi = math.pi, -- extension
+	sin = function (r) return math.sin(r.car) end,
+	cos = function (r) return math.cos(r.car) end,
+	tan = function (r) return math.tan(r.car) end,
+	asin = function (r) return math.asin(r.car) end,
+	acos = function (r) return math.acos(r.car) end,
+	atan = -- the two-argument variant of atan computes
+		-- (angle (make-rectangular x y)), even in implementations that
+		-- don't support general complex numbers [ed. note: whatever
+		-- that means] --- atan2 ???
+		function (r) return math.atan(r.car) end,
+	sqrt = function (r) return math.sqrt(r.car) end,
+	expt = function (r) return r.car ^ r.cdr.car end,
+	-- ["make-rectangular"] = function (r) end,
+	-- ["make-polar"] = function (r) end,
+	-- ["real-part"] = function (r) end,
+	-- ["imag-part"] = function (r) end,
+	-- ["magnitude"] = function (r) end,
+	-- ["angle"] = function (r) end,
+	-- ["exact->inexact"] = function (r) end,
+	-- ["inexact->exact"] = function (r) end,
+	["number->string"] =
+		function (r)
+			-- this will be somewhat complicated
+		end,
+	["string->number"] =
+		function (r)
+			local n = r.car
+			if not isNull(r.cdr) then
+				local radix = r.cdr.car
+			end
+			-- This is technically an extension to r5rs
+			return tonumber(n, radix)
+		end,
+	-- Pairs
+	["pair?"] = function (r) end,
+	cons = function (r) return type.Cons(r.car, r.cdr.car) end,
+	car = function (r) return r.car.car end,
+	cdr = function (r) return r.car.cdr end,
+	["set-car!"] = function (r) r.car.car = r.cdr.car end,
+	["set-cdr!"] = function (r) r.car.cdr = r.cdr.car end,
+	-- cxr
+	["null?"] = function (r) return isNull(r.car) end,
+	["list?"] = function (r) return type.isList(r.car) end,
+	list = function (r) return r end, -- r is already a list
+	-- Symbols
+	["symbol?"] = function (r) return isa(r.car, "Symbol") end,
+	["symbol->string"] = function (r) return type.String(r.car) end,
+	["string->symbol"] = function (r) return type.Symbol(r.car.value) end,
+	-- Characters
+	["char?"] = function (r) end,
+	["char=?"] = function (r) end,
+	["char<?"] = function (r) end,
+	["char>?"] = function (r) end,
+	["char<=?"] = function (r) end,
+	["char>=?"] = function (r) end,
+	["char->integer"] = function (r) end,
+	["integer->char"] = function (r) end,
+	-- Strings
+	["string?"] = function (r) end,
+	["make-string"] = function (r) end,
+	["string-length"] = function (r) end,
+	["string-ref"] = function (r) end,
+	-- ["string-set!"] = function (r) end, -- not sure if i'll implement
+	-- Vectors
+	["vector?"] = function (r) end,
+	["make-vector"] = function (r) end,
+	["vector-length"] = function (r) end,
+	["vector-ref"] = function (r) end,
+	["vector-set!"] = function (r) end,
+	-- Control
+	["procedure?"] = function (r) end,
+	apply = function (r) end,
+	["call-with-current-continuation"] = function (r) end,
+	values = function (r) end,
+	["call-with-values"] = function (r) end,
+	["dynamic-wind"] = function (r) end,
+	-- Eval
+	eval = function (r) end,
+	["scheme-report-environment"] = function (r) end,
+	["null-environment"] = function (r) end,
+	-- Ports
+	["input-port?"] = function (r) end,
+	["output-port?"] = function (r) end,
+	["current-input-port"] = function (r) end,
+	["current-output-port"] = function (r) end,
+	["open-input-file"] = function (r) end,
+	["open-output-file"] = function (r) end,
+	["close-input-port"] = function (r) end,
+	["close-output-port"] = function (r) end,
+	-- Input
+	read = function (r) end,
+	["read-char"] = function (r) end,
+	["peek-char"] = function (r) end,
+	["eof-object?"] = function (r) end,
+	["char-ready?"] = function (r) end,
+	-- Output
+	write = function (r) end,
+	display = function (r) end,
+	newline = function (r) end,
+	["write-char"] = function (r) end,
+	-- System
+	load = function (r) end,
 }
 
 ---
-- 
cgit 1.4.1-21-gabe81