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