From 64e52cd0cf9b0ceabb976b03d1b67478b1bd0de7 Mon Sep 17 00:00:00 2001 From: haxala1r Date: Thu, 6 Nov 2025 23:02:16 +0300 Subject: [PATCH] Added more math operations, generalized and simplified existing math operations, added some list operations for the lisp lists --- lib/ast.ml | 34 ++++++++++++++++++ lib/interpreterStdlib.ml | 76 ++++++++++++++++++++++++++-------------- 2 files changed, 83 insertions(+), 27 deletions(-) diff --git a/lib/ast.ml b/lib/ast.ml index a746c02..c954c1d 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -25,6 +25,40 @@ type lisp_val = recursive with lisp_val *) and environment = (string, lisp_val) Hashtbl.t list +(* It is clear that we need some primitives for working with the lisp + data structures. + + For example, the LCons and LNil values, together, form a linked list. + This is the intended form of all source code in lisp, yet because + we are using our own implementation of a linked list instead of + ocaml's List, we can not use its many functions. + + It may be tempting to switch to a different implementation. + Remember however, that classic lisp semantics allow for the + CDR component of a cons cell (the part that would point to the + next member) to be of a type other than the list itself. + *) + +let reverse vs = + let rec aux prev = function + | LNil -> prev + | LCons (v, next) -> aux (LCons (v, prev)) next + | _ -> invalid_arg "cannot reverse non-list!" + in aux LNil vs + +let map f = + let rec aux accum = function + | LNil -> reverse accum + | LCons (v, next) -> aux (LCons (f v, accum)) next + | _ -> invalid_arg "cannot map over non-list!" + in aux LNil + +let reduce init f = + let rec aux accum = function + | LNil -> accum + | LCons (v, next) -> aux (f accum v) next + | _ -> invalid_arg "cannot reduce over non-list!" + in aux init let rec dbg_print_one v = let pf = Printf.sprintf in diff --git a/lib/interpreterStdlib.ml b/lib/interpreterStdlib.ml index a83433b..49a260d 100644 --- a/lib/interpreterStdlib.ml +++ b/lib/interpreterStdlib.ml @@ -1,33 +1,52 @@ open Ast;; +(* I feel like the more I get into functional programming, the more insane my code + becomes. What the fuck is this? why do I have a set of functions that combine + binary operators over an arbitrarily long list? I have like. 4 operators. None + of this matters. + + But it's just so... beautiful. + *) +let mathop_do_once int_op float_op = function + | (LDouble v1, LDouble v2) -> LDouble (float_op v1 v2) + | (LDouble v1, LInt v2) -> LDouble (float_op v1 (float_of_int v2)) + | (LInt v1, LDouble v2) -> LDouble (float_op (float_of_int v1) v2) + | (LInt v1, LInt v2) -> LInt (int_op v1 v2) + | _ -> invalid_arg "invalid arguments to mathematical operator" + +let mathop_do_once_curried int_op float_op = + let f = mathop_do_once int_op float_op in + fun x -> fun y -> f (x, y) + +let mathop_reduce fi ff init vs = + let curried = mathop_do_once_curried fi ff in + reduce init curried vs + +let cast_int_to_double = function + | LInt x -> LDouble (float x) + | LDouble x -> LDouble x + | _ -> invalid_arg "can't cast_int_to_double!" + let add _ vs = - let rec aux accum = function - | LCons (a, b) -> - (match accum, a with - | LInt x , LInt y -> aux (LInt (x + y)) b - | LDouble x, LInt y -> aux (LDouble (x +. (float_of_int y))) b - | LInt x, LDouble y -> aux (LDouble ((float_of_int x) +. y)) b - | LDouble x, LDouble y -> aux (LDouble (x +. y)) b - | _ -> invalid_arg "invalid args to +") - | LNil -> accum - | _ -> invalid_arg "invalid args to +" - in aux (LInt 0) vs -let sub _ vs = - let rec aux accum = function - | LNil -> accum - | LCons (a, b) -> (match accum, a, b with - | LNil, LDouble x, LNil -> LDouble (-. x) - | LNil, LInt x, LNil -> LInt (-x) - | LNil, LDouble _, _ - | LNil, LInt _, _ -> aux a b - | LInt x, LInt y, _ -> aux (LInt (x - y)) b - | LInt x, LDouble y, _ -> aux (LDouble ((float_of_int x) -. y)) b - | LDouble x, LDouble y, _ -> aux (LDouble (x -. y)) b - | LDouble x, LInt y, _ -> aux (LDouble (x -. (float_of_int y))) b - | _ -> invalid_arg "invalid argument to -") - | _ -> invalid_arg "argument to -" - in aux LNil vs - + mathop_reduce (+) (+.) (LInt 0) vs +let sub _ = function + | LCons (x, LNil) -> ((mathop_do_once (-) (-.)) (LInt 0, x)) + | LCons (x, rest) -> mathop_reduce (-) (-.) x rest + | _ -> invalid_arg "invalid argument list passed to (-)" +let mul _ vs = + mathop_reduce ( * ) ( *. ) (LInt 1) vs +let div _ vs = + let div_one = mathop_do_once ( / ) ( /. ) in + match vs with + (* (/ x) is equal to 1 / x *) + | LCons (x, LNil) -> div_one (LDouble 1., cast_int_to_double x) + | LCons (x, LCons (y, LNil)) -> div_one (cast_int_to_double x, y) + | _ -> invalid_arg "invalid argument list passed to (/)" + +let rem _ = function + | LCons (x, LCons (y, LNil)) -> + mathop_do_once (mod) (mod_float) (cast_int_to_double x, cast_int_to_double y) + | _ -> invalid_arg "invalid argument list passed to (rem)" let car _ vs = @@ -123,8 +142,11 @@ let init_script = " let init_default_env () = add_builtin "+" add; add_builtin "-" sub; + add_builtin "*" mul; + add_builtin "/" div; add_builtin "car" car; add_builtin "cdr" cdr; + add_builtin "rem" rem; add_builtin "cons" cons; add_special "def" lisp_define; add_builtin "set" lisp_set;