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