@@ -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 Data.Hashable
5+import Data.Bits
6−import Debug.Trace (trace, traceShowId)
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
9−import Test.QuickCheck.Arbitrary.Generic
9+import GHC.Base
11−data Annotation = Annotation
11+import GHC.Num.BigNat (bigNatAddWord#, bigNatFromWord2#)
12− { hash :: Int
12+import Nock.Types
14− deriving stock (Show)
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
@@ -31,83 +17,119 @@ sig = atom 0
31one :: Noun
17one :: Noun
32one = atom 1
18one = atom 1
34−annotation :: RawNoun ann -> ann
20+two :: Noun
35−annotation (Atom _ ann) = ann
21+two = atom 2
36−annotation (Cell _ _ ann) = ann
38−data RawNoun ann
23+three :: Noun
39− = Atom !Natural ann
24+three = atom 3
40− | Cell (RawNoun ann) (RawNoun ann) ann
41− deriving stock (Generic, Show)
43−instance Eq (RawNoun ann) where
26+four :: Noun
44− (Atom lhs _) == (Atom rhs _) = lhs == rhs
27+four = atom 4
45− (Cell lhslhs lhsrhs _) == (Cell rhslhs rhsrhs _) = lhslhs == rhslhs && lhsrhs == rhsrhs
48−hashEq :: Noun -> Noun -> Bool
29+twoThree :: Noun
49−hashEq (Atom lhsNat lhsAnn) (Atom rhsNat rhsAnn) =
30+twoThree = cell two three
50− lhsAnn.hash == rhsAnn.hash && lhsNat == rhsNat
51−hashEq (Cell lhslhs lhsrhs lhsAnn) (Cell rhslhs rhsrhs rhsAnn) =
52− lhsAnn.hash == rhsAnn.hash && hashEq lhslhs rhslhs && hashEq lhsrhs rhsrhs
55−type Noun = RawNoun Annotation
32+sigOne :: Noun
57wut :: Noun -> Noun
35wut :: Noun -> Noun
58wut Cell {} = sig
36wut Cell {} = sig
59wut Atom {} = one
37wut Atom {} = one
61lus :: Noun -> Noun
39lus :: Noun -> Noun
62−lus ~(Atom nat _) = atom (nat + 1)
40+lus ~(Atom nat _) = atom $ case nat of
63−
41+ (NS n) -> case addWordC# n 1## of
43+ (# l, c #) -> NB (bigNatFromWord2# (int2Word# c) l)
44+ (NB n) -> NB (bigNatAddWord# n 1##)
64−tis :: Noun -> Noun
46+tis :: Noun -> Noun -> Eff es Noun
65−tis ~(Cell lhs rhs _) = if hashEq lhs rhs then sig else one
47+tis lhs rhs = pure $ if lhs == rhs then sig else one
67−fas :: Noun -> Noun
49+fas# :: Word# -> Noun -> Noun
68−fas ~(Cell ~(Atom lhs _) rhs _) =
50+fas# lhs rhs =
69− case traceShowId lhs of
51+ case lhs of
70− 1 -> rhs
52+ 1## -> rhs
71− 2 -> case rhs of
53+ 2## -> case rhs of
72 ~(Cell lhs' _ _) -> lhs'
54 ~(Cell lhs' _ _) -> lhs'
73− 3 -> case rhs of
55+ 3## -> case rhs of
74 ~(Cell _ rhs' _) -> rhs'
56 ~(Cell _ rhs' _) -> rhs'
76− | n > 0 ->
58+ let rest = fas# (uncheckedShiftRL# n 1#) rhs
77− let (d, m) = divMod n 2
59+ in case and# 1## n of
63+fas :: Natural -> Noun -> Noun
64+fas (NS w) rhs = fas# w rhs
66+ let rest = fas (unsafeShiftR n 1) rhs
71+hax# :: Word# -> Noun -> Noun -> Noun
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
79+hax :: Natural -> Noun -> Noun -> Noun
80+hax (NS n) b c = hax# n b c
82+ let a = unsafeShiftR n 1
78− in if m == 0
83+ in if testBit n 0
79− then fas (cell (atom 2) (fas (cell (atom d) rhs)))
84+ then hax a (cell (fas (n - 1) c) b) c
80− else fas (cell (atom 3) (fas (cell (atom d) rhs)))
85+ else hax a (cell b (fas (n + 1) c)) c
87+tar :: Noun -> Eff es Noun
88+tar ~(Cell subject ~(Cell a b _) _) = tar' a b subject
90+tar' :: Noun -> Noun -> Noun -> Eff es Noun
91+tar' b c subject = case b of
92+ Cell x y _ -> case c of
93+ ~(Cell l k _) -> cell <$> tar' x y subject <*> tar' l k subject
81− _ -> undefined
94+ Atom (NB _) _ -> undefined
84−hax ~(Cell ~(Atom n _) ~(Cell a b _) _) =
85− let (d, m) = divMod n 2
86− in case n of
95+ Atom (NS n) _ -> case n of
87− 1 -> a
96+ 0## -> case c of
88− _ | m == 0 -> hax (cell (atom d) (cell (cell a (fas (cell (atom $ n + 1) b))) b))
97+ ~(Atom nat _) -> pure $ fas nat subject
89− _ -> hax (cell (atom d) (cell (cell (fas (cell (atom $ n - 1) b)) a) b))
98+ 1## -> pure c
91−tar :: Noun -> Noun
100+ ~(Cell l k _) -> wut <$> tar' l k subject
92−tar ~(Cell a ~(Cell b c _) _) = case b of
101+ 4## -> case c of
93− Cell x y _ -> cell (tar (cell a (cell x y))) (tar (cell a c))
102+ ~(Cell l k _) -> lus <$> tar' l k subject
94− Atom n _ -> case n of
97− 3 -> wut $ tar $ cell a c
98− 4 -> lus $ tar $ cell a c
99 _ -> case c of
103 _ -> case c of
100− ~(Cell x y _) -> case n of
104+ ~(Cell x ~(Cell h j _) _) -> case n of
101− 2 -> tar $ cell (tar $ cell a x) (tar $ cell a y)
105+ 2## -> case x of
102− 5 -> tis $ cell (tar $ cell a x) (tar $ cell a y)
106+ ~(Cell l k _) ->
103− 7 -> tar $ cell (tar $ cell a x) y
107+ tar' l k subject >>= \case
104− 8 -> tar $ cell (cell (tar $ cell a x) a) y
108+ ~formula@(Cell battery ~(Cell sample _ _) _) ->
105− 9 -> tar $ cell (tar $ cell a y) $ cell (atom 2) (cell (cell sig one) (cell sig x))
109+ -- if traceShowId battery == Nock.Jets.add
106− 6 -> case y of
110+ -- then error "Found it!"
107− ~(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))
111+ tar' h j subject >>= \case
112+ ~(Cell u v _) -> tar' u v formula
115+ p <- tar' h j subject
116+ q <- tar' l k subject
119+ ~(Cell l k _) -> tar' l k subject >>= tar' h j
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))
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
108− 10 -> case x of
130+ 10## -> case x of
109− ~(Cell l k _) -> hax $ cell l $ cell (tar (cell a k)) $ tar $ cell a y
131+ ~(Cell ~(Atom b' _) ~(Cell u v _) _) -> hax b' <$> tar' u v subject <*> tar' h j subject
110− 11 -> case x of
132+ 11## -> case x of
111− Cell _ k _ -> tar $ cell (cell (tar $ cell a k) (tar $ cell a y)) $ cell sig (atom 3)
133+ Cell _ ~(Cell u v _) _ -> tar' h j subject
112− Atom _ _ -> tar $ cell a y
134+ Atom _ _ -> tar' h j subject
113− u -> error $ show u
135+ _ -> undefined