@@ -1,19 +1,14 @@
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 (NFData, force)
65import Data.Bits
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
6+import Data.Functor ((<&>))
7+import Effectful
8+import Effectful.State.Static.Local qualified as SEL
129import GHC.Base
13−import GHC.Conc (par)
14−import GHC.Generics (Generic)
1510import GHC.Num
16−import Nock.Jets
11+import GHC.Num.BigNat (bigNatAddWord#, bigNatFromWord2#)
1712import Nock.Types
1813
1914sig :: Noun
@@ -42,13 +37,17 @@ wut Cell {} = sig
4237wut Atom {} = one
4338
4439lus :: Noun -> Noun
45−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##)
4645
47−tis :: Noun -> Noun -> Noun
48−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
4948
50−fasWord :: Word# -> Noun -> Noun
51−fasWord lhs rhs =
49+fas# :: Word# -> Noun -> Noun
50+fas# lhs rhs =
5251 case lhs of
5352 1## -> rhs
5453 2## -> case rhs of
@@ -56,72 +55,80 @@ fasWord lhs rhs =
5655 3## -> case rhs of
5756 ~(Cell _ rhs' _) -> rhs'
5857 n ->
59− let rest = fasWord (uncheckedShiftRL# n 1#) rhs
58+ let rest = fas# (uncheckedShiftRL# n 1#) rhs
6059 in case and# 1## n of
61− 1## -> fasWord 3## rest
62− _ -> fasWord 2## rest
60+ 1## -> fas# 3## rest
61+ _ -> fas# 2## rest
6362
6463fas :: Natural -> Noun -> Noun
65−fas (NS w) rhs = fasWord w rhs
64+fas (NS w) rhs = fas# w rhs
6665fas n rhs =
6766 let rest = fas (unsafeShiftR n 1) rhs
6867 in if testBit n 0
6968 then fas 3 rest
7069 else fas 2 rest
7170
72−haxWord :: Word# -> Noun -> Noun -> Noun
73−haxWord _ _ tree | traceShow tree False = undefined
74−haxWord 1## newValue _ = newValue
75−haxWord place newValue ~(Cell lhs rhs _) =
76− let a = uncheckedShiftRL# place 1#
77− in case and# place 1## of
78− 1## -> cell (haxWord a newValue lhs) rhs
79− _ -> cell lhs (haxWord a newValue rhs)
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
8078
8179hax :: Natural -> Noun -> Noun -> Noun
82−hax (NS w) newValue rhs = haxWord w newValue rhs
83−hax place newValue ~(Cell lhs rhs _) =
84− let a = unsafeShiftR place 1
85− in if testBit place 0
86− then cell (hax a newValue lhs) rhs
87− else cell lhs (hax a newValue rhs)
88−
89−tar :: 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
9088tar ~(Cell subject ~(Cell a b _) _) = tar' a b subject
9189
92−tar' :: Noun -> Noun -> Noun -> Noun
90+tar' :: Noun -> Noun -> Noun -> Eff es Noun
9391tar' b c subject = case b of
9492 Cell x y _ -> case c of
95− ~(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
9694 Atom (NB _) _ -> undefined
9795 Atom (NS n) _ -> case n of
9896 0## -> case c of
99− ~(Atom nat _) -> fas nat subject
100− 1## -> c
97+ ~(Atom nat _) -> pure $ fas nat subject
98+ 1## -> pure c
10199 3## -> case c of
102− ~(Cell l k _) -> wut $ tar' l k subject
100+ ~(Cell l k _) -> wut <$> tar' l k subject
103101 4## -> case c of
104− ~(Cell l k _) -> lus $ tar' l k subject
102+ ~(Cell l k _) -> lus <$> tar' l k subject
105103 _ -> case c of
106104 ~(Cell x ~(Cell h j _) _) -> case n of
107105 2## -> case x of
108− ~(Cell l k _) -> case tar' l k subject of
109− ~(formula@(Cell battery ~(Cell sample _ _) _)) ->
110− -- if traceShowId battery == Nock.Jets.add
111− -- then error "Found it!"
112− case (tar' h j subject) of
113− ~(Cell u v _) -> tar' u v formula
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
114113 5## -> case x of
115− ~(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
117+ tis p q
116118 7## -> case x of
117− ~(Cell l k _) -> tar' h j (tar' l k subject)
119+ ~(Cell l k _) -> tar' l k subject >>= tar' h j
118120 8## -> case x of
119− ~(Cell l k _) -> tar' h j (cell (tar' l k subject) subject)
120− 9## -> tar' two (cell sigOne (cell sig x)) (tar' h j subject)
121− 6## -> case tar' sig (tar' sig (tar' four (cell four x) subject) twoThree) (cell h j) of
122− ~(Cell u v _) -> tar' u v subject
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
123130 10## -> case x of
124− ~(Cell ~(Atom b' _) ~(Cell u v _) _) -> hax b' (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
125132 11## -> case x of
126133 Cell _ ~(Cell u v _) _ -> tar' h j subject
127134 Atom _ _ -> tar' h j subject