fixed jamcue

1 files changed, 69 insertions, 0 deletions

diff --git a/ocaml/lib/noun.ml b/ocaml/lib/noun.ml
new file mode 100644
index 0000000..c59ec80
--- /dev/null
+++ b/ocaml/lib/noun.ml
@@ -0,0 +1,69 @@
+(** Noun type and basic operations *)
+
+(** A noun is either an atom (arbitrary-precision integer) or a cell (pair of nouns) *)
+type noun =
+  | Atom of Z.t  (** Arbitrary-precision integer using Zarith *)
+  | Cell of noun * noun  (** Pair of nouns *)
+
+(** Exception raised on nock evaluation errors *)
+exception Exit
+
+(** Create an atom from an int *)
+let atom n = Atom (Z.of_int n)
+
+(** Create a cell *)
+let cell a b = Cell (a, b)
+
+(** Test if a noun is a cell *)
+let is_cell = function
+  | Cell _ -> true
+  | Atom _ -> false
+
+(** Test if a noun is an atom *)
+let is_atom = function
+  | Atom _ -> true
+  | Cell _ -> false
+
+(** Get head of a cell *)
+let head = function
+  | Cell (h, _) -> h
+  | Atom _ -> raise Exit
+
+(** Get tail of a cell *)
+let tail = function
+  | Cell (_, t) -> t
+  | Atom _ -> raise Exit
+
+(** Fragment/axis lookup: slot(n, noun)
+    This implements the tree-addressing scheme:
+    - 1 is the root
+    - 2 is head, 3 is tail
+    - For n > 1: if even, go left; if odd, go right
+*)
+let rec slot n noun =
+  if Z.equal n Z.one then
+    noun
+  else if Z.equal n Z.zero then
+    raise Exit
+  else
+    let bit = Z.testbit n 0 in  (* Check if odd *)
+    let parent = Z.shift_right n 1 in
+    let sub = slot parent noun in
+    if bit then tail sub else head sub
+
+(** Equality test for nouns *)
+let rec equal a b =
+  match a, b with
+  | Atom x, Atom y -> Z.equal x y
+  | Cell (ah, at), Cell (bh, bt) -> equal ah bh && equal at bt
+  | _, _ -> false
+
+(** Increment an atom *)
+let inc = function
+  | Atom n -> Atom (Z.succ n)
+  | Cell _ -> raise Exit
+
+(** Pretty-print a noun *)
+let rec pp_noun fmt = function
+  | Atom n -> Format.fprintf fmt "%s" (Z.to_string n)
+  | Cell (a, b) -> Format.fprintf fmt "[%a %a]" pp_noun a pp_noun b