From: Elijah Cohen <eli@eli173.com>
Date: Tue, 17 Dec 2024 22:12:01 +0000 (-0600)
Subject: gt, lt, /massive/ phi and psi bugs plugged
X-Git-Tag: v-12.13.13~9
X-Git-Url: https://git.eli173.com/?a=commitdiff_plain;h=4711910ccab064a2ab88501aef701fabb4174542;p=klapaucius

gt, lt, /massive/ phi and psi bugs plugged
---

diff --git a/demos.kl b/demos.kl
index 45960f9..31c455e 100644
--- a/demos.kl
+++ b/demos.kl
@@ -14,6 +14,18 @@
 (def U (L O))
 (def F (E T T E T))
 
+
+(def zd-identity I)
+(def zd-constant K)
+(def zd-compose B)
+(def zd-flip C)
+(def zd-duplicate W)
+(def zd-left t)
+(def zd-right nil)
+(def zd-recombine Phi)
+(def zd-under Psi)
+(def zd-conditional (B (B S) S))
+
 (def if I)
 
 (def church-and (B W (B C) I))
@@ -37,3 +49,15 @@
 (def map (B (B reverse) (B (B (Z (B (S (S (B (eq nil) (2 cdr)) (B car cdr))) (C B (S (B cons car) (Phi cons (Phi cons (S car (B (B car cdr) cdr)) (B car cdr)) (3 cdr))))))) (C (B B cons) (cons nil)))))
 
 (def fold (B (S (C (C (eq nil) nil) (Z (B (S (S (B (eq nil) (B cdr cdr)) (B car cdr))) (C B (S (B cons car) (Phi cons (S (S car (B car cdr)) (B car (2 cdr))) (3 cdr)))))))) cons))
+
+
+(def compose-all (rest (B (fold (B (C B unquote) B)) (cons I))))
+
+(def fibonacci-generator (Z (B (B (C (C C nil))) (B (Phi cons (Phi + car cdr)) (C B (Phi cons (Phi + car cdr) car))))))
+
+(def abstract-generator (Z (B (B (B (B (C (C C nil))))) (B (Phi B (B S (B cons))) (B (B W) (B (B B)))))))
+
+(def intermediary (Z (C (B B (B B (B C (B (B S) (B C (C (C Phi cdr) car)))))) (C (B (B B (Phi cons)) (C (C Phi car) cdr)) (C B cdr)))))
+(def withcons (B (B (B Z)) intermediary))
+
+(def tr-fac (B (S (Phi (eq 0) cdr car)) (C B (Phi cons (Phi * car cdr) (B (C - 1) cdr)))))
\ No newline at end of file
diff --git a/src/builtins.c b/src/builtins.c
index 840eac5..dfe2052 100644
--- a/src/builtins.c
+++ b/src/builtins.c
@@ -178,6 +178,10 @@ char* lookup_builtin(Sexpr* b) {
 			return ARITH_DIV_STR;
 		case ARITH_MOD:
 			return ARITH_MOD_STR;
+		case ARITH_GT:
+			return ARITH_GT_STR;
+		case ARITH_LT:
+			return ARITH_LT_STR;
 		default:
 			return "NOT FOUND (ARITH)";
 		}
diff --git a/src/builtins/arithmetic.c b/src/builtins/arithmetic.c
index ea9ab88..c13a0dc 100644
--- a/src/builtins/arithmetic.c
+++ b/src/builtins/arithmetic.c
@@ -131,6 +131,54 @@ Sexpr* a_mod(Sexpr* b, Sexpr* rest, Sexpr* env) {
 	return cons(from_uint(n % m), rest);
 }
 
+ Sexpr* a_gt(Sexpr* b, Sexpr* rest, Sexpr* env) {
+	if(ARITH_GT_ARGS != u64_get_num_args(b)) {
+		return cons(b, rest);
+	}
+	Sexpr* args = b->value.b.args;
+	Sexpr* i = eval(clone(car(args)), env);
+	Sexpr* j = eval(clone(car(cdr(args))), env);
+#ifdef TYPECHECK
+	if((unquote(i)->type != UINT) || (unquote(j)->type != UINT)) {
+		ERR("%: ", "arguments not uints");
+		sexpr_free(b);
+		sexpr_free(i);
+		sexpr_free(j);
+		return cons(from_nil(), rest);
+	}
+#endif
+		K_UINT_TYPE m = unquote(i)->value.u;
+		K_UINT_TYPE n = unquote(j)->value.u;
+		sexpr_free(b);
+		sexpr_free(i);
+		sexpr_free(j);
+		return cons(m > n ? from_nil(): from_t(), rest);
+}
+
+Sexpr* a_lt(Sexpr* b, Sexpr* rest, Sexpr* env) {
+	if(ARITH_LT_ARGS != u64_get_num_args(b)) {
+		return cons(b, rest);
+	}
+	Sexpr* args = b->value.b.args;
+	Sexpr* i = eval(clone(car(args)), env);
+	Sexpr* j = eval(clone(car(cdr(args))), env);
+#ifdef TYPECHECK
+	if((unquote(i)->type != UINT) || (unquote(j)->type != UINT)) {
+		ERR("%: ", "arguments not uints");
+		sexpr_free(b);
+		sexpr_free(i);
+		sexpr_free(j);
+		return cons(from_nil(), rest);
+	}
+#endif
+		K_UINT_TYPE m = unquote(i)->value.u;
+		K_UINT_TYPE n = unquote(j)->value.u;
+		sexpr_free(b);
+		sexpr_free(i);
+		sexpr_free(j);
+		return cons(m < n ? from_nil() : from_t(), rest);
+}
+
 
 Sexpr* x_arith_dispatch(Sexpr* b, Sexpr* rest, Sexpr* env) {
 	uint64_t code = b->value.b.opcode & 0xff;
@@ -146,6 +194,10 @@ Sexpr* x_arith_dispatch(Sexpr* b, Sexpr* rest, Sexpr* env) {
 		return a_div(b, rest, env);
 	case ARITH_MOD:
 		return a_mod(b, rest, env);
+	case ARITH_GT:
+		return a_gt(b, rest, env);
+	case ARITH_LT:
+		return a_lt(b, rest, env);
 	default:
 		return from_nil();
 	}
@@ -158,6 +210,8 @@ Sexpr* load_arith_env(Sexpr* env) {
 	load_builtin(ARITH_MUL_STR, (ARITH_PREFIX << 8) | ARITH_MUL, env);
 	load_builtin(ARITH_DIV_STR, (ARITH_PREFIX << 8) | ARITH_DIV, env);
 	load_builtin(ARITH_MOD_STR, (ARITH_PREFIX << 8) | ARITH_MOD, env);
+	load_builtin(ARITH_GT_STR, (ARITH_PREFIX << 8) | ARITH_GT, env);
+	load_builtin(ARITH_LT_STR, (ARITH_PREFIX << 8) | ARITH_LT, env);
 	
 	return env;
 }
diff --git a/src/builtins/arithmetic.h b/src/builtins/arithmetic.h
index 00900ce..efa64db 100644
--- a/src/builtins/arithmetic.h
+++ b/src/builtins/arithmetic.h
@@ -21,6 +21,12 @@
 #define ARITH_MOD 0x04
 #define ARITH_MOD_ARGS 2
 #define ARITH_MOD_STR "%"
+#define ARITH_GT 0x05
+#define ARITH_GT_ARGS 2
+#define ARITH_GT_STR ">"
+#define ARITH_LT 0x06
+#define ARITH_LT_ARGS 2
+#define ARITH_LT_STR "<"
 
 Sexpr* x_arith_dispatch(Sexpr* s, Sexpr* rest, Sexpr* env);
 Sexpr* load_arith_env(Sexpr* env);
diff --git a/src/builtins/combinators.c b/src/builtins/combinators.c
index 0aa2fdb..7a0741d 100644
--- a/src/builtins/combinators.c
+++ b/src/builtins/combinators.c
@@ -100,7 +100,7 @@ Sexpr* c_phi(Sexpr* b, Sexpr* rest, Sexpr* env) {
 	Sexpr* d2 = clone(d);
 	Sexpr* bd = cons(bee, cons(d, from_nil()));
 	Sexpr* cd = cons(c, cons(d2, from_nil()));
-	Sexpr* ret = cons(a, cons(bd, cons(cd, from_nil())));
+	Sexpr* ret = cons(a, cons(bd, cons(cd, rest)));
 	sexpr_free(b);
 	return ret;
 }
@@ -117,7 +117,7 @@ Sexpr* c_psi(Sexpr* b, Sexpr* rest, Sexpr* env) {
 	Sexpr* bee2 = clone(bee);
 	Sexpr* bd = cons(bee, cons(d, from_nil()));
 	Sexpr* bc = cons(bee2, cons(c, from_nil()));
-	Sexpr* ret = cons(a, cons(bc, cons(bd, from_nil())));
+	Sexpr* ret = cons(a, cons(bc, cons(bd, rest)));
 	sexpr_free(b);
 	return ret;
 }
diff --git a/src/test.c b/src/test.c
index ecbf8fa..a273ec2 100644
--- a/src/test.c
+++ b/src/test.c
@@ -9,6 +9,7 @@
 #include "dict.h"
 #include "eval.h"
 #include "builtins.h"
+#include "util.h"
 
 void assert_eq(Sexpr* env, char* a, char* b) {
 	Sexpr* ap = parse(a);
@@ -23,6 +24,7 @@ void assert_eq(Sexpr* env, char* a, char* b) {
 	}
 	else {
 		printf("\033[1m\033[31mFAILED\033[0m: %s != %s\n", a, b);
+		printf("got %s and %s\n", ao, bo);
 	}
 	sexpr_free(av);
 	sexpr_free(bv);
@@ -383,10 +385,85 @@ void eval_tests() {
 void many_asserts() {
 	Sexpr* env = init_dict();
 	env = load_env(env);
+	env = load_file(env, "demos.kl");
 
+	// copy-paste this thing as needed
+	assert_eq(env, "", "");
+
+	printf("basics\n");
 	assert_eq(env, "(+ 4 4)", "8");
-	assert_eq(env, "(* 3 4)", "8");
+	assert_eq(env, "(* 3 4)", "12");
+	assert_eq(env, "((+ 3) 7)", "10");
+	assert_eq(env, "atom 55", "t");
+	assert_eq(env, "atom (quote (1 2 3))", "nil");
+	assert_eq(env, "(cons 1 (cons 2 nil))", "(list 1 2)");
+	// the following two are problems... maybe
+	assert_eq(env, "(car (cons 1 2))","quote 1"); // PROBLEM
+	assert_eq(env, "(cdr (cons 1 2))", "quote 2"); // PROBLEM
+	assert_eq(env, "(eq 1 1)", "t");
+	assert_eq(env, "(eq 1 2)", "nil");
+	assert_eq(env, "(eq 1 (quote 1))", "t"); // PROBLEM
+	assert_eq(env, "eq (cons 1 2) (cons 1 2)", "t");
+	assert_eq(env, "eq (cons 1 2) (cons 1 3)", "nil");
+	assert_eq(env, "eq (quote (1 2)) (cons 1 (cons 2 nil))", "t"); // PROBLEM
+	assert_eq(env, "not 54", "nil");
+	assert_eq(env, "not nil", "t");
+	assert_eq(env, "def asdf 545", "545");
+	assert_eq(env, "asdf", "545");
+	//assert_eq(env, "notyetdefined", "nil"); // it's fine don't worry, just suppressing a message
+	assert_eq(env, "- 100 20", "* 10 8");
+	assert_eq(env, "/ 100 19", "% 13 8");
+
+	printf("combinators\n");
+	assert_eq(env, "I + 4 5", "9");
+	assert_eq(env, "S + (+ 4) 3", "10");
+	assert_eq(env, "K 5 6", "5");
+	assert_eq(env, "K I 5 6", "6");
+	assert_eq(env, "S K I 5", "5");
+	assert_eq(env, "K S (I (S K S I)) + (+ 4) 3", "10");
+	assert_eq(env, "B car cdr (quote (1 2 3))", "quote 2"); // PROBLEM
+	assert_eq(env, "C - 3 10", "7");
+	assert_eq(env, "W * 3", "9");
+	assert_eq(env, "R 5 * 3", "15");
+	assert_eq(env, "t 4 5", "4");
+	assert_eq(env, "nil 4 5", "5");
+	assert_eq(env, "5 (+ 3) 4", "19");
+
+	assert_eq(env, "t (cons 1 2) (cons 2 1)", "(cons 1 2)");
+	assert_eq(env, "(Z (B B S (C (eq 0) 1) (B B S * (C B (C - 1)))) 6)", "720");
+
+
+	printf("strings\n");
+	assert_eq(env, "strlen \"hi\"", "2");
+	assert_eq(env, "strcat \"hi \" \"there\"", "\"hi there\"");
+	assert_eq(env, "strat 5 \"hello world\"", "\"o\"");
+	assert_eq(env, "strexpand \"test\"", "list \"t\" \"e\" \"s\" \"t\"");
+	assert_eq(env, "substr \"oo\" \"looopy", "list 2 3");
+	assert_eq(env, "strtok \" /\" \"this is/a test\"", "list \"this\" \"is\" \"a\" \"test\"");
+
+	printf("meta\n");
+	assert_eq(env, "utob 512", "+");
+	assert_eq(env, "btou +", "512");
+	assert_eq(env, "parse \"cons 4 5\"", "quote (cons 4 5)"); // PROBLEM
+	assert_eq(env, "getargs +", "B car list nil"); // PROBLEM
+	assert_eq(env, "getargs (+ 5)", "list 5");
+
+	printf("with demos\n");
+	assert_eq(env, "fac 5", "120");
+	assert_eq(env, "range 5", "list 1 2 3 4 5");
+	assert_eq(env, "reverse (range 3)", "(list 3 2 1)");
+	assert_eq(env, "nth 5 (range 10)", "5");
+	assert_eq(env, "len (range 10)", "10");
+	assert_eq(env, "map (+ 4) (range 10)", "(list 5 6 7 8 9 10 11 12 13 14)");
+	assert_eq(env, "fold + (range 10)", "55");
+	assert_eq(env, "", "");
+	assert_eq(env, "", "");
+	assert_eq(env, "", "");
+	assert_eq(env, "", "");
+
+	
 
+	
 	sexpr_free(env);
 }
 
@@ -457,7 +534,7 @@ void isolating_problem() {
 void run_tests(){
 	//isolating_problem();
 	//test_string_parsing();
-	eval_tests();
+	//eval_tests();
 	many_asserts();
 	//memtest_eval();
 	//mem_testing();