@@ -1,14 +1,19 @@
11{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
22
3−module Nock (tar, hax, fas, cell, atom, Annotation (..), Noun) where
3+module Nock (tar, hax, fas, cell, atom, Annotation (..), Noun, RawNoun (..)) where
44
5+import Control.DeepSeq (NFData, force)
56import Data.Bits
6−import Data.Functor ((<&>))
7−import Effectful
8−import Effectful.State.Static.Local qualified as SEL
7+import Data.Hashable
8+import Data.Text.Lazy qualified as TL
9+import Data.Text.Lazy.Builder qualified as TLB
10+import Data.Text.Lazy.Builder.Int qualified as TLB
11+import Debug.Trace
912import GHC.Base
13+import GHC.Conc (par)
14+import GHC.Generics (Generic)
1015import GHC.Num
11−import GHC.Num.BigNat (bigNatAddWord#, bigNatFromWord2#)
16+import Nock.Jets
1217import Nock.Types
1318
1419sig :: Noun
@@ -37,17 +42,13 @@ wut Cell {} = sig
3742wut Atom {} = one
3843
3944lus :: 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##)
45+lus ~(Atom nat _) = atom (nat + 1)
4546
46−tis :: Noun -> Noun -> Eff es Noun
47−tis lhs rhs = pure $ if lhs == rhs then sig else one
47+tis :: Noun -> Noun -> Noun
48+tis lhs rhs = if hashEq lhs rhs then sig else one
4849
49−fas# :: Word# -> Noun -> Noun
50−fas# lhs rhs =
50+fasWord :: Word# -> Noun -> Noun
51+fasWord lhs rhs =
5152 case lhs of
5253 1## -> rhs
5354 2## -> case rhs of
@@ -55,80 +56,71 @@ fas# lhs rhs =
5556 3## -> case rhs of
5657 ~(Cell _ rhs' _) -> rhs'
5758 n ->
58− let rest = fas# (uncheckedShiftRL# n 1#) rhs
59+ let rest = fasWord (uncheckedShiftRL# n 1#) rhs
5960 in case and# 1## n of
60− 1## -> fas# 3## rest
61− _ -> fas# 2## rest
61+ 1## -> fasWord 3## rest
62+ _ -> fasWord 2## rest
6263
6364fas :: Natural -> Noun -> Noun
64−fas (NS w) rhs = fas# w rhs
65+fas (NS w) rhs = fasWord w rhs
6566fas n rhs =
6667 let rest = fas (unsafeShiftR n 1) rhs
6768 in if testBit n 0
6869 then fas 3 rest
6970 else fas 2 rest
7071
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
72+haxWord :: Word# -> Noun -> Noun -> Noun
73+haxWord 1## newValue _ = newValue
74+haxWord place newValue ~(Cell lhs rhs _) =
75+ let a = uncheckedShiftRL# place 1#
76+ in case and# place 1## of
77+ 1## -> cell (haxWord a newValue lhs) rhs
78+ _ -> cell lhs (haxWord a newValue rhs)
7879
7980hax :: Natural -> Noun -> Noun -> Noun
80−hax (NS n) b c = hax# n b c
81−hax 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
86−
87−tar :: Noun -> Eff es Noun
81+hax (NS w) newValue rhs = haxWord w newValue rhs
82+hax place newValue ~(Cell lhs rhs _) =
83+ let a = unsafeShiftR place 1
84+ in if testBit place 0
85+ then cell (hax a newValue lhs) rhs
86+ else cell lhs (hax a newValue rhs)
87+
88+tar :: Noun -> Noun
8889tar ~(Cell subject ~(Cell a b _) _) = tar' a b subject
8990
90−tar' :: Noun -> Noun -> Noun -> Eff es Noun
91+tar' :: Noun -> Noun -> Noun -> Noun
9192tar' b c subject = case b of
9293 Cell x y _ -> case c of
93− ~(Cell l k _) -> cell <$> tar' x y subject <*> tar' l k subject
94+ ~(Cell l k _) -> cell (tar' x y subject) (tar' l k subject)
9495 Atom (NB _) _ -> undefined
9596 Atom (NS n) _ -> case n of
9697 0## -> case c of
97− ~(Atom nat _) -> pure $ fas nat subject
98− 1## -> pure c
98+ ~(Atom nat _) -> fas nat subject
99+ 1## -> c
99100 3## -> case c of
100− ~(Cell l k _) -> wut <$> tar' l k subject
101+ ~(Cell l k _) -> wut $ tar' l k subject
101102 4## -> case c of
102− ~(Cell l k _) -> lus <$> tar' l k subject
103+ ~(Cell l k _) -> lus $ tar' l k subject
103104 _ -> case c of
104105 ~(Cell x ~(Cell h j _) _) -> case n of
105106 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
107+ ~(Cell l k _) -> case tar' l k subject of
108+ ~(formula@(Cell battery ~(Cell sample _ _) _)) ->
109+ if battery == Nock.Jets.dec
110+ then error "Found it!"
111+ else case (tar' h j subject) of
112112 ~(Cell u v _) -> tar' u v formula
113113 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
114+ ~(Cell l k _) -> tis (tar' h j subject) (tar' l k subject)
118115 7## -> case x of
119− ~(Cell l k _) -> tar' l k subject >>= tar' h j
116+ ~(Cell l k _) -> tar' h j (tar' l k subject)
120117 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
118+ ~(Cell l k _) -> tar' h j (cell (tar' l k subject) subject)
119+ 9## -> tar' two (cell sigOne (cell sig x)) (tar' h j subject)
120+ 6## -> case tar' sig (tar' sig (tar' four (cell four x) subject) twoThree) (cell h j) of
121+ ~(Cell u v _) -> tar' u v subject
130122 10## -> case x of
131− ~(Cell ~(Atom b' _) ~(Cell u v _) _) -> hax b' <$> tar' u v subject <*> tar' h j subject
123+ ~(Cell ~(Atom b' _) ~(Cell u v _) _) -> hax b' (tar' u v subject) (tar' h j subject)
132124 11## -> case x of
133125 Cell _ ~(Cell u v _) _ -> tar' h j subject
134126 Atom _ _ -> tar' h j subject