@@ -1,15 +1,29 @@
11{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
22
3−module Nock (tar, hax, fas, cell, atom, Annotation (..), Noun) where
4−
5−import Data.Bits
6−import Data.Functor ((<&>))
7−import Effectful
8−import Effectful.State.Static.Local qualified as SEL
9−import GHC.Base
10−import GHC.Num
11−import GHC.Num.BigNat (bigNatAddWord#, bigNatFromWord2#)
12−import Nock.Types
3+module Nock (tar, hax, fas, cell, atom, Annotation (..), Noun, RawNoun (..)) where
4+
5+import Control.DeepSeq (NFData)
6+import Data.Hashable
7+import GHC.Generics (Generic)
8+import Numeric.Natural
9+
10+data Annotation = Annotation
11+ { hash :: Int
12+ }
13+ deriving stock (Show, Generic)
14+ deriving anyclass (NFData)
15+
16+atom :: Natural -> Noun
17+atom nat = Atom nat Annotation {hash = hash nat}
18+
19+cell :: Noun -> Noun -> Noun
20+cell lhs rhs =
21+ Cell
22+ lhs
23+ rhs
24+ Annotation
25+ { hash = hash ((annotation lhs).hash, (annotation rhs).hash)
26+ }
1327
1428sig :: Noun
1529sig = atom 0
@@ -32,104 +46,95 @@ twoThree = cell two three
3246sigOne :: Noun
3347sigOne = cell sig one
3448
49+annotation :: RawNoun ann -> ann
50+annotation (Atom _ ann) = ann
51+annotation (Cell _ _ ann) = ann
52+
53+data RawNoun ann
54+ = Atom !Natural ann
55+ | Cell (RawNoun ann) (RawNoun ann) ann
56+ deriving stock (Generic, Show)
57+ deriving anyclass (NFData)
58+
59+instance Eq (RawNoun ann) where
60+ (Atom lhs _) == (Atom rhs _) = lhs == rhs
61+ (Cell lhslhs lhsrhs _) == (Cell rhslhs rhsrhs _) = lhslhs == rhslhs && lhsrhs == rhsrhs
62+ _ == _ = False
63+
64+hashEq :: Noun -> Noun -> Bool
65+hashEq (Atom lhsNat lhsAnn) (Atom rhsNat rhsAnn) =
66+ lhsAnn.hash == rhsAnn.hash && lhsNat == rhsNat
67+hashEq (Cell lhslhs lhsrhs lhsAnn) (Cell rhslhs rhsrhs rhsAnn) =
68+ lhsAnn.hash == rhsAnn.hash && hashEq lhslhs rhslhs && hashEq lhsrhs rhsrhs
69+hashEq _ _ = False
70+
71+type Noun = RawNoun Annotation
72+
3573wut :: Noun -> Noun
3674wut Cell {} = sig
3775wut Atom {} = one
3876
3977lus :: Noun -> Noun
40−lus ~(Atom nat _) = atom $ case nat of
41− (NS n) -> case addWordC# n 1## of
42− (# l, 0# #) -> NS l
43− (# l, c #) -> NB (bigNatFromWord2# (int2Word# c) l)
44− (NB n) -> NB (bigNatAddWord# n 1##)
78+lus ~(Atom nat _) = atom (nat + 1)
4579
46−tis :: Noun -> Noun -> Eff es Noun
47−tis lhs rhs = pure $ if lhs == rhs then sig else one
80+tis :: Noun -> Noun -> Noun
81+tis lhs rhs = if hashEq lhs rhs then sig else one
4882
49−fas# :: Word# -> Noun -> Noun
50−fas# lhs rhs =
83+fas :: Natural -> Noun -> Noun
84+fas lhs rhs =
5185 case lhs of
52− 1## -> rhs
53− 2## -> case rhs of
86+ 1 -> rhs
87+ 2 -> case rhs of
5488 ~(Cell lhs' _ _) -> lhs'
55− 3## -> case rhs of
89+ 3 -> case rhs of
5690 ~(Cell _ rhs' _) -> rhs'
57− n ->
58− let rest = fas# (uncheckedShiftRL# n 1#) rhs
59− in case and# 1## n of
60− 1## -> fas# 3## rest
61− _ -> fas# 2## rest
62−
63−fas :: Natural -> Noun -> Noun
64−fas (NS w) rhs = fas# w rhs
65−fas n rhs =
66− let rest = fas (unsafeShiftR n 1) rhs
67− in if testBit n 0
68− then fas 3 rest
69− else fas 2 rest
70−
71−hax# :: Word# -> Noun -> Noun -> Noun
72−hax# 1## b _ = b
73−hax# n b c =
74− let a = uncheckedShiftRL# n 1#
75− in case and# n 1## of
76− 1## -> hax# a (cell (fas# (n `xor#` 1##) c) b) c
77− _ -> hax# a (cell b (fas# (n `or#` 1##) c)) c
91+ n
92+ | n > 0 ->
93+ let (d, m) = divMod n 2
94+ in if m == 0
95+ then fas 2 (fas d rhs)
96+ else fas 3 (fas d rhs)
97+ _ -> undefined
7898
7999hax :: Natural -> Noun -> Noun -> Noun
80−hax (NS n) b c = hax# n b c
81100hax n b c =
82− let a = unsafeShiftR n 1
83− in if testBit n 0
84− then hax a (cell (fas (n - 1) c) b) c
85− else hax a (cell b (fas (n + 1) c)) c
101+ let (a, m) = divMod n 2
102+ in case n of
103+ 1 -> b
104+ _ | m == 0 -> hax a (cell b (fas (a + a + 1) c)) c
105+ _ -> hax a (cell (fas (a + a) c) b) c
86106
87−tar :: Noun -> Eff es Noun
107+tar :: Noun -> Noun
88108tar ~(Cell subject ~(Cell a b _) _) = tar' a b subject
89109
90−tar' :: Noun -> Noun -> Noun -> Eff es Noun
110+tar' :: Noun -> Noun -> Noun -> Noun
91111tar' b c subject = case b of
92112 Cell x y _ -> case c of
93− ~(Cell l k _) -> cell <$> tar' x y subject <*> tar' l k subject
94− Atom (NB _) _ -> undefined
95− Atom (NS n) _ -> case n of
96− 0## -> case c of
97− ~(Atom nat _) -> pure $ fas nat subject
98− 1## -> pure c
99− 3## -> case c of
100− ~(Cell l k _) -> wut <$> tar' l k subject
101− 4## -> case c of
102− ~(Cell l k _) -> lus <$> tar' l k subject
113+ ~(Cell l k _) -> cell (tar' x y subject) (tar' l k subject)
114+ Atom n _ -> case n of
115+ 0 -> case c of
116+ ~(Atom nat _) -> fas nat subject
117+ 1 -> c
118+ 3 -> case c of
119+ ~(Cell l k _) -> wut $ tar' l k subject
120+ 4 -> case c of
121+ ~(Cell l k _) -> lus $ tar' l k subject
103122 _ -> case c of
104123 ~(Cell x ~(Cell h j _) _) -> case n of
105− 2## -> case x of
106− ~(Cell l k _) ->
107− tar' l k subject >>= \case
108− ~formula@(Cell battery ~(Cell sample _ _) _) ->
109− -- if traceShowId battery == Nock.Jets.add
110− -- then error "Found it!"
111− tar' h j subject >>= \case
112− ~(Cell u v _) -> tar' u v formula
113− 5## -> case x of
114− ~(Cell l k _) -> do
115− p <- tar' h j subject
116− q <- tar' l k subject
117− tis p q
118− 7## -> case x of
119− ~(Cell l k _) -> tar' l k subject >>= tar' h j
120− 8## -> case x of
121− ~(Cell l k _) -> do
122− p <- tar' l k subject
123− tar' h j (cell p subject)
124− 9## -> tar' h j subject >>= tar' two (cell sigOne (cell sig x))
125− 6## -> do
126− p <- tar' four (cell four x) subject
127− q <- tar' sig p twoThree
128− tar' sig q (cell h j) >>= \case
129− ~(Cell u v _) -> tar' u v subject
130− 10## -> case x of
131− ~(Cell ~(Atom b' _) ~(Cell u v _) _) -> hax b' <$> tar' u v subject <*> tar' h j subject
132− 11## -> case x of
133− Cell _ ~(Cell u v _) _ -> tar' h j subject
124+ 2 -> case (tar' h j subject, x) of
125+ ~(~(Cell u v _), ~(Cell l k _)) -> tar' u v (tar' l k subject)
126+ 5 -> case x of
127+ ~(Cell l k _) -> tis (tar' h j subject) (tar' l k subject)
128+ 7 -> case x of
129+ ~(Cell l k _) -> tar' h j (tar' l k subject)
130+ 8 -> case x of
131+ ~(Cell l k _) -> tar' h j (cell (tar' l k subject) subject)
132+ 9 -> tar' two (cell sigOne (cell sig x)) (tar' h j subject)
133+ 6 -> case tar' sig (tar' sig (tar' four (cell four x) subject) twoThree) (cell h j) of
134+ ~(Cell u v _) -> tar' u v subject
135+ 10 -> case x of
136+ ~(Cell ~(Atom b' _) ~(Cell u v _) _) -> hax b' (tar' u v subject) (tar' h j subject)
137+ 11 -> case x of
138+ Cell _ ~(Cell u v _) _ -> tar' sig three (cell (tar' u v subject) (tar' h j subject))
134139 Atom _ _ -> tar' h j subject
135− _ -> undefined
140+ u -> error $ show u