1 files changed, 164 insertions, 0 deletions
diff --git a/ocaml/nock.ml b/ocaml/nock.ml
new file mode 100644
index 0000000..34065b8
--- /dev/null
+++ b/ocaml/nock.ml
@@ -0,0 +1,164 @@
+open Noun
+
+(** Nock interpreter
+
+    Based on the reference implementation from vere/pkg/noun/nock.c
+
+    The Nock spec has 12 opcodes (0-11):
+    - 0: slot/fragment lookup
+    - 1: constant
+    - 2: nock (recursion)
+    - 3: is-cell test
+    - 4: increment
+    - 5: equality test
+    - 6: if-then-else
+    - 7: composition
+    - 8: push
+    - 9: call with axis
+    - 10: hint (ignored in reference implementation)
+    - 11: scry (errors in reference implementation)
+*)
+
+(** Main nock evaluation function: nock(subject, formula)
+
+    In Nock notation: *[subject formula]
+
+    This is a direct port of _n_nock_on from nock.c:157-396
+*)
+let rec nock_on bus fol =
+  match fol with
+  | Cell (hib, gal) when is_cell hib ->
+      (* [a b] -> compute both sides and cons *)
+      let poz = nock_on bus hib in
+      let riv = nock_on bus gal in
+      cell poz riv
+
+  | Cell (Atom op, gal) ->
+      (match Z.to_int op with
+      | 0 ->
+          (* /[axis subject] - slot/fragment lookup *)
+          if not (is_atom gal) then raise Exit
+          else slot (match gal with Atom n -> n | _ -> raise Exit) bus
+
+      | 1 ->
+          (* =[constant subject] - return constant *)
+          gal
+
+      | 2 ->
+          (* *[subject formula new_subject] - evaluate with new subject *)
+          if not (is_cell gal) then raise Exit;
+          let b_gal = head gal in
+          let c_gal = tail gal in
+          let seb = nock_on bus b_gal in
+          let nex = nock_on bus c_gal in
+          nock_on seb nex
+
+      | 3 ->
+          (* ?[subject formula] - is-cell test *)
+          let gof = nock_on bus gal in
+          if is_cell gof then atom 0 else atom 1
+
+      | 4 ->
+          (* +[subject formula] - increment *)
+          let gof = nock_on bus gal in
+          inc gof
+
+      | 5 ->
+          (* =[subject formula] - equality test *)
+          let wim = nock_on bus gal in
+          if not (is_cell wim) then raise Exit;
+          let a = head wim in
+          let b = tail wim in
+          if equal a b then atom 0 else atom 1
+
+      | 6 ->
+          (* if-then-else *)
+          if not (is_cell gal) then raise Exit;
+          let b_gal = head gal in
+          let cd_gal = tail gal in
+          if not (is_cell cd_gal) then raise Exit;
+          let c_gal = head cd_gal in
+          let d_gal = tail cd_gal in
+
+          let tys = nock_on bus b_gal in
+          let nex = match tys with
+            | Atom n when Z.equal n Z.zero -> c_gal
+            | Atom n when Z.equal n Z.one -> d_gal
+            | _ -> raise Exit
+          in
+          nock_on bus nex
+
+      | 7 ->
+          (* composition: *[*[subject b] c] *)
+          if not (is_cell gal) then raise Exit;
+          let b_gal = head gal in
+          let c_gal = tail gal in
+          let bod = nock_on bus b_gal in
+          nock_on bod c_gal
+
+      | 8 ->
+          (* push: *[[*[subject b] subject] c] *)
+          if not (is_cell gal) then raise Exit;
+          let b_gal = head gal in
+          let c_gal = tail gal in
+          let heb = nock_on bus b_gal in
+          let bod = cell heb bus in
+          nock_on bod c_gal
+
+      | 9 ->
+          (* call: *[*[subject c] axis] *)
+          if not (is_cell gal) then raise Exit;
+          let b_gal = head gal in
+          let c_gal = tail gal in
+          if not (is_atom b_gal) then raise Exit;
+
+          let seb = nock_on bus c_gal in
+          let nex = slot (match b_gal with Atom n -> n | _ -> raise Exit) seb in
+          nock_on seb nex
+
+      | 10 ->
+          (* hint - in reference implementation, hints are mostly ignored *)
+          let nex =
+            if is_cell gal then
+              (* [[hint-tag hint-value] formula] *)
+              tail gal
+            else
+              (* [hint-tag formula] where hint-value is implicit *)
+              gal
+          in
+          nock_on bus nex
+
+      | 11 ->
+          (* scry - not implemented in reference nock, raises error *)
+          raise Exit
+
+      | _ ->
+          (* Invalid opcode *)
+          raise Exit
+      )
+
+  | _ ->
+      (* Invalid formula structure *)
+      raise Exit
+
+(** Convenience function: nock(subject, formula) *)
+let nock subject formula =
+  nock_on subject formula
+
+(** slam: apply gate to sample
+    slam(gate, sample) = *[gate [9 2 [0 1] [0 6] [1 sample] [0 7]]]
+
+    In practice this evaluates the gate (which is a core with a formula at axis 2)
+    with a modified sample (at axis 6).
+*)
+let slam gat sam =
+  let cor = cell (head gat) (cell sam (tail (tail gat))) in
+  let formula = slot (Z.of_int 2) cor in
+  nock_on cor formula
+
+(** kick: fire gate without changing sample
+    kick(gate) = *[gate 9 2 0 1]
+*)
+let kick gat =
+  let formula = slot (Z.of_int 2) gat in
+  nock_on gat formula