@@ -1,33 +1,15 @@
11{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
22
3−module Nock (tar, hax, fas, cell, atom, Annotation (..), Noun, RawNoun (..)) where
3+module Nock (tar, hax, fas, cell, atom, Annotation (..), Noun) where
44
5−import Control.DeepSeq (force)
6−import Control.Parallel.Strategies
75import Data.Bits
8−import Data.Hashable
9−import Debug.Trace
10−import GHC.Conc (par)
11−import GHC.Generics (Generic)
12−import Numeric.Natural
13−
14−newtype Annotation = Annotation
15− { hash :: Int
16− }
17− deriving stock (Show, Generic)
18− deriving anyclass (NFData)
19−
20−atom :: Natural -> Noun
21−atom nat = Atom nat Annotation {hash = hash nat}
22−
23−cell :: Noun -> Noun -> Noun
24−cell lhs rhs =
25− Cell
26− lhs
27− rhs
28− Annotation
29− { hash = hash ((annotation lhs).hash, (annotation rhs).hash)
30− }
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
3113
3214sig :: Noun
3315sig = atom 0
@@ -50,97 +32,104 @@ twoThree = cell two three
5032sigOne :: Noun
5133sigOne = cell sig one
5234
53−annotation :: RawNoun ann -> ann
54−annotation (Atom _ ann) = ann
55−annotation (Cell _ _ ann) = ann
56−
57−data RawNoun ann
58− = Atom !Natural ann
59− | Cell (RawNoun ann) (RawNoun ann) ann
60− deriving stock (Generic, Show)
61− deriving anyclass (NFData)
62−
63−instance Eq (RawNoun ann) where
64− (Atom lhs _) == (Atom rhs _) = lhs == rhs
65− (Cell lhslhs lhsrhs _) == (Cell rhslhs rhsrhs _) =
66− let rhsRes = lhsrhs == rhsrhs
67− in (force rhsRes `par` lhslhs == rhslhs) && rhsRes
68− _ == _ = False
69−
70−hashEq :: Noun -> Noun -> Bool
71−hashEq (Atom lhsNat lhsAnn) (Atom rhsNat rhsAnn) =
72− let normalEq = lhsNat == rhsNat
73− in (force normalEq `par` lhsAnn.hash == rhsAnn.hash) && normalEq
74−hashEq (Cell lhslhs lhsrhs lhsAnn) (Cell rhslhs rhsrhs rhsAnn) =
75− let normalEq = hashEq lhslhs rhslhs && hashEq lhsrhs rhsrhs
76− in (force normalEq `par` lhsAnn.hash == rhsAnn.hash) && normalEq
77−hashEq _ _ = False
78−
79−type Noun = RawNoun Annotation
80−
8135wut :: Noun -> Noun
8236wut Cell {} = sig
8337wut Atom {} = one
8438
8539lus :: Noun -> Noun
86−lus ~(Atom nat _) = atom (nat + 1)
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##)
8745
88−tis :: Noun -> Noun -> Noun
89−tis lhs rhs = if hashEq lhs rhs then sig else one
46+tis :: Noun -> Noun -> Eff es Noun
47+tis lhs rhs = pure $ if lhs == rhs then sig else one
9048
91−fas :: Natural -> Noun -> Noun
92−fas lhs rhs =
49+fas# :: Word# -> Noun -> Noun
50+fas# lhs rhs =
9351 case lhs of
94− 1 -> rhs
95− 2 -> case rhs of
52+ 1## -> rhs
53+ 2## -> case rhs of
9654 ~(Cell lhs' _ _) -> lhs'
97− 3 -> case rhs of
55+ 3## -> case rhs of
9856 ~(Cell _ rhs' _) -> rhs'
9957 n ->
100− let rest = fas (unsafeShiftR n 1) rhs
101− in if testBit n 0
102− then fas 3 rest
103− else fas 2 rest
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
10478
10579hax :: Natural -> Noun -> Noun -> Noun
80+hax (NS n) b c = hax# n b c
10681hax n b c =
10782 let a = unsafeShiftR n 1
108− in case n of
109− 1 -> b
110− _ | testBit n 0 -> hax a (cell (fas (n - 1) c) b) c
111− _ -> hax a (cell b (fas (n + 1) c)) c
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
11286
113−tar :: Noun -> Noun
87+tar :: Noun -> Eff es Noun
11488tar ~(Cell subject ~(Cell a b _) _) = tar' a b subject
11589
116−tar' :: Noun -> Noun -> Noun -> Noun
90+tar' :: Noun -> Noun -> Noun -> Eff es Noun
11791tar' b c subject = case b of
11892 Cell x y _ -> case c of
119− ~(Cell l k _) -> cell (tar' x y subject) (tar' l k subject)
120− Atom n _ -> case n of
121− 0 -> case c of
122− ~(Atom nat _) -> fas nat subject
123− 1 -> c
124− 3 -> case c of
125− ~(Cell l k _) -> wut $ tar' l k subject
126− 4 -> case c of
127− ~(Cell l k _) -> lus $ tar' l k subject
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
128103 _ -> case c of
129104 ~(Cell x ~(Cell h j _) _) -> case n of
130− 2 -> case (tar' h j subject, x) of
131− ~(~(Cell u v _), ~(Cell l k _)) -> tar' u v (tar' l k subject)
132− 5 -> case x of
133− ~(Cell l k _) -> tis (tar' h j subject) (tar' l k subject)
134− 7 -> case x of
135− ~(Cell l k _) -> tar' h j (tar' l k subject)
136− 8 -> case x of
137− ~(Cell l k _) -> tar' h j (cell (tar' l k subject) subject)
138− 9 -> tar' two (cell sigOne (cell sig x)) (tar' h j subject)
139− 6 -> case tar' sig (tar' sig (tar' four (cell four x) subject) twoThree) (cell h j) of
140− ~(Cell u v _) -> tar' u v subject
141− 10 -> case x of
142− ~(Cell ~(Atom b' _) ~(Cell u v _) _) -> hax b' (tar' u v subject) (tar' h j subject)
143− 11 -> case x of
144− Cell _ ~(Cell u v _) _ -> tar' sig three (cell (tar' u v subject) (tar' h j subject))
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
145134 Atom _ _ -> tar' h j subject
146− u -> error $ show u
135+ _ -> undefined