1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
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
|
