@@ -4,7 +4,10 @@ module Nock (tar, hax, fas, cell, atom, Annotation (..), Noun, RawNoun (..)) whe
44
55import Control.DeepSeq (NFData)
66import Data.Hashable
7+import Data.MemoTrie (memo)
8+import Debug.Trace (traceShowId)
79import GHC.Generics (Generic)
10+import GHC.Word (Word64)
811import Numeric.Natural
912
1013data Annotation = Annotation
@@ -80,29 +83,34 @@ lus ~(Atom nat _) = atom (nat + 1)
8083tis :: Noun -> Noun -> Noun
8184tis lhs rhs = if hashEq lhs rhs then sig else one
8285
83−fas :: Natural -> Noun -> Noun
84−fas lhs rhs =
85− case lhs of
86− 1 -> rhs
87− 2 -> case rhs of
88− ~(Cell lhs' _ _) -> lhs'
89− 3 -> case rhs of
90− ~(Cell _ rhs' _) -> rhs'
91− n
92− | n > 0 ->
93− let (d, m) = divMod n 2
94− in if m == 0
95− then fas 2 (fas d rhs)
96− else fas 3 (fas d rhs)
97− _ -> undefined
86+fas' :: Word64 -> Noun -> Noun
87+fas' n = case (traceShowId n) of
88+ 1 -> id
89+ 2 -> \ ~(Cell x _ _) -> x
90+ 3 -> \ ~(Cell _ x _) -> x
91+ _ ->
92+ let (d, m) = divMod n 2
93+ next = fas d
94+ in if m == 0
95+ then \x ->
96+ ( case next x of
97+ ~(Cell y _ _) -> y
98+ )
99+ else \x ->
100+ ( case next x of
101+ ~(Cell _ y _) -> y
102+ )
103+
104+fas :: Word64 -> Noun -> Noun
105+fas = memo fas'
98106
99107hax :: Natural -> Noun -> Noun -> Noun
100108hax n b c =
101109 let (a, m) = divMod n 2
102110 in case n of
103111 1 -> b
104− _ | m == 0 -> hax a (cell b (fas (a + a + 1) c)) c
105− _ -> hax a (cell (fas (a + a) c) b) c
112+ _ | m == 0 -> hax a (cell b (fas (fromIntegral $ a + a + 1) c)) c
113+ _ -> hax a (cell (fas (fromIntegral $ a + a) c) b) c
106114
107115tar :: Noun -> Noun
108116tar ~(Cell subject ~(Cell a b _) _) = tar' a b subject
@@ -113,7 +121,7 @@ tar' b c subject = case b of
113121 ~(Cell l k _) -> cell (tar' x y subject) (tar' l k subject)
114122 Atom n _ -> case n of
115123 0 -> case c of
116− ~(Atom nat _) -> fas nat subject
124+ ~(Atom nat _) -> fas (fromIntegral nat) subject
117125 1 -> c
118126 3 -> case c of
119127 ~(Cell l k _) -> wut $ tar' l k subject