@@ -0,0 +1,114 @@
1+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
2+
3+module Nock (tar, cell, atom, Annotation (..), Noun, RawNoun (..)) where
4+
5+import Data.Hashable
6+import GHC.Generics (Generic)
7+import Numeric.Natural
8+
9+data Annotation = Annotation
10+ { hash :: Int
11+ }
12+ deriving stock (Show)
13+
14+zero :: Natural
15+zero = 0
16+
17+atom :: Natural -> Noun
18+atom nat = Atom nat Annotation {hash = hash nat}
19+
20+cell :: Noun -> Noun -> Noun
21+cell lhs rhs =
22+ Cell
23+ lhs
24+ rhs
25+ Annotation
26+ { hash = hash ((annotation lhs).hash, (annotation rhs).hash)
27+ }
28+
29+sig :: Noun
30+sig = atom 0
31+
32+one :: Noun
33+one = atom 1
34+
35+annotation :: RawNoun ann -> ann
36+annotation (Atom _ ann) = ann
37+annotation (Cell _ _ ann) = ann
38+
39+data RawNoun ann
40+ = Atom !Natural ann
41+ | Cell (RawNoun ann) (RawNoun ann) ann
42+ deriving stock (Generic, Show)
43+
44+instance Eq (RawNoun ann) where
45+ (Atom lhs _) == (Atom rhs _) = lhs == rhs
46+ (Cell lhslhs lhsrhs _) == (Cell rhslhs rhsrhs _) = lhslhs == rhslhs && lhsrhs == rhsrhs
47+ _ == _ = False
48+
49+hashEq :: Noun -> Noun -> Bool
50+hashEq (Atom lhsNat lhsAnn) (Atom rhsNat rhsAnn) =
51+ lhsAnn.hash == rhsAnn.hash && lhsNat == rhsNat
52+hashEq (Cell lhslhs lhsrhs lhsAnn) (Cell rhslhs rhsrhs rhsAnn) =
53+ lhsAnn.hash == rhsAnn.hash && hashEq lhslhs rhslhs && hashEq lhsrhs rhsrhs
54+hashEq _ _ = False
55+
56+type Noun = RawNoun Annotation
57+
58+wut :: Noun -> Noun
59+wut Cell {} = sig
60+wut Atom {} = one
61+
62+lus :: Noun -> Noun
63+lus ~(Atom nat _) = atom (nat + 1)
64+
65+tis :: Noun -> Noun
66+tis ~(Cell lhs rhs _) = if hashEq lhs rhs then sig else one
67+
68+fas :: Noun -> Noun
69+fas ~(Cell ~(Atom lhs _) rhs _) =
70+ case lhs of
71+ 1 -> rhs
72+ 2 -> case rhs of
73+ ~(Cell lhs' _ _) -> lhs'
74+ 3 -> case rhs of
75+ ~(Cell _ rhs' _) -> rhs'
76+ n
77+ | n > 0 ->
78+ let (d, m) = divMod n 2
79+ in if m == 0
80+ then fas (cell (atom 2) (fas (cell (atom d) rhs)))
81+ else fas (cell (atom 3) (fas (cell (atom d) rhs)))
82+ _ -> undefined
83+
84+hax :: Noun -> Noun
85+hax ~(Cell ~(Atom n _) ~(Cell a b _) _) =
86+ let (d, m) = divMod n 2
87+ in case n of
88+ 1 -> a
89+ _ | m == 0 -> hax (cell (atom d) (cell (cell a (fas (cell (atom $ n + 1) b))) b))
90+ _ -> hax (cell (atom d) (cell (cell (fas (cell (atom $ n + n) b)) a) b))
91+
92+tar :: Noun -> Noun
93+tar ~(Cell a ~(Cell b c _) _) = case b of
94+ Cell x y _ -> cell (tar (cell a (cell x y))) (tar (cell a c))
95+ Atom n _ -> case n of
96+ 0 -> fas $ cell c a
97+ 1 -> c
98+ 3 -> wut $ tar $ cell a c
99+ 4 -> lus $ tar $ cell a c
100+ _ -> case c of
101+ ~(Cell x y _) -> case n of
102+ 2 -> tar $ cell (tar $ cell a x) (tar $ cell a y)
103+ 5 -> tis $ cell (tar $ cell a x) (tar $ cell a y)
104+ 7 -> tar $ cell (tar $ cell a x) y
105+ 8 -> tar $ cell (cell (tar $ cell a x) a) y
106+ 9 -> tar $ cell (tar $ cell a y) $ cell (atom 2) (cell (cell sig one) (cell sig x))
107+ 6 -> case y of
108+ ~(Cell l k _) -> tar $ cell a $ tar $ cell (cell l k) $ cell sig $ tar $ cell (cell (atom 2) (atom 3)) $ cell sig $ tar $ cell a (cell (atom 4) (cell (atom 4) x))
109+ 10 -> case x of
110+ ~(Cell l k _) -> hax $ cell l $ cell (tar (cell a k)) $ tar $ cell a y
111+ 11 -> case c of
112+ Cell l k _ -> tar $ cell (cell (tar $ cell a l) (tar $ cell a k)) $ cell sig (atom 3)
113+ Atom l _ -> tar $ cell a y
114+ _ -> undefined