diff --git a/pkg/king/lib/Noun/Tree.hs b/pkg/king/lib/Noun/Tree.hs index 64c34301e5..409e6f09f8 100644 --- a/pkg/king/lib/Noun/Tree.hs +++ b/pkg/king/lib/Noun/Tree.hs @@ -56,17 +56,17 @@ instance Ord (NounVal a) where instance ToNoun (NounVal a) where toNoun = non -instance Show a => Show (NounVal a) where +instance Show a ⇒ Show (NounVal a) where show = show . val -instance FromNoun a => FromNoun (NounVal a) where +instance FromNoun a ⇒ FromNoun (NounVal a) where parseNoun x = NounVal x <$> parseNoun x -instance ToNoun a => ToNoun (HoonTree a) where +instance ToNoun a ⇒ ToNoun (HoonTree a) where toNoun E = A 0 toNoun (Node n) = toNoun n -instance FromNoun a => FromNoun (HoonTree a) where +instance FromNoun a ⇒ FromNoun (HoonTree a) where parseNoun (A 0) = pure E parseNoun n = Node <$> parseNoun n @@ -77,60 +77,60 @@ deriveNoun ''HoonTreeNode type Nat = Natural -slowMug :: Noun -> Nat +slowMug ∷ Noun → Nat slowMug = trim 0xcafe_babe . \case - A a -> a - C h t -> mix (slowMug h) $ mix 0x7fff_ffff (slowMug t) + A a → a + C h t → mix (slowMug h) $ mix 0x7fff_ffff (slowMug t) where - trim :: Nat -> Nat -> Nat + trim ∷ Nat → Nat → Nat trim syd key = if 0/=ham then ham else trim (succ syd) key where haz = muk syd (met 3 key) key ham = mix (rsh 0 31 haz) (end 0 31 haz) -mix :: Nat -> Nat -> Nat +mix ∷ Nat → Nat → Nat mix = xor -- Murmur3 -muk :: Nat -> Nat -> Nat -> Nat +muk ∷ Nat → Nat → Nat → Nat muk seed len = fromIntegral . murmur3 (word32 seed) . resize . view atomBytes where - resize :: ByteString -> ByteString + resize ∷ ByteString → ByteString resize buf = case compare (length buf) (int len) of - EQ -> buf - LT -> error "bad-muk" - GT -> error "bad-muk" --- LT -> buf <> replicate (len - length buf) 0 --- GT -> take len buf + EQ → buf + LT → error "bad-muk" + GT → error "bad-muk" +-- LT → buf <> replicate (len - length buf) 0 +-- GT → take len buf -int :: Integral i => i -> Int +int ∷ Integral i ⇒ i → Int int = fromIntegral -word32 :: Integral i => i -> Word32 +word32 ∷ Integral i ⇒ i → Word32 word32 = fromIntegral -bex :: Nat -> Nat +bex ∷ Nat → Nat bex = (2^) -end :: Nat -> Nat -> Nat -> Nat +end ∷ Nat → Nat → Nat → Nat end blockSize blocks n = n `mod` (bex (bex blockSize * blocks)) -rsh :: Nat -> Nat -> Nat -> Nat +rsh ∷ Nat → Nat → Nat → Nat rsh blockSize blocks n = shiftR n $ fromIntegral $ (bex blockSize * blocks) -met :: Nat -> Nat -> Nat +met ∷ Nat → Nat → Nat met bloq = go 0 where go c 0 = c go c n = go (succ c) (rsh bloq 1 n) -- XX TODO -mug ∷ Noun -> Nat +mug ∷ Noun → Nat mug = slowMug @@ -139,7 +139,7 @@ mug = slowMug {- Orders in ascending double mug hash order, collisions fall back to dor. -} -mor ∷ Noun -> Noun -> Bool +mor ∷ Noun → Noun → Bool mor a b = if c == d then dor a b else c < d where c = mug $ A $ mug a @@ -148,7 +148,7 @@ mor a b = if c == d then dor a b else c < d {- Orders in ascending tree depth. -} -dor ∷ Noun -> Noun -> Bool +dor ∷ Noun → Noun → Bool dor a b | a == b = True dor (A a) (C _ _) = True dor (C x y) (A b) = False @@ -161,34 +161,34 @@ dor (C x y) (C p q) = dor x p Collisions fall back to dor. -} -gor ∷ Noun -> Noun -> Bool +gor ∷ Noun → Noun → Bool gor a b = if c==d then dor a b else c NounVal a -> Bool +morVal, gorVal ∷ NounVal a → NounVal a → Bool morVal = on mor non gorVal = on gor non -------------------------------------------------------------------------------- -nounVal ∷ ToNoun a => Iso' a (NounVal a) +nounVal ∷ ToNoun a ⇒ Iso' a (NounVal a) nounVal = iso to val where to x = NounVal (toNoun x) x -treeToList :: ∀a. HoonTree a -> [a] +treeToList ∷ ∀a. HoonTree a → [a] treeToList = go [] where - go :: [a] -> HoonTree a -> [a] + go ∷ [a] → HoonTree a → [a] go acc = \case E → acc Node (NTN v l r) → go (go (val v : acc) l) r -setFromHoonSet :: Ord a => HoonSet a -> Set a +setFromHoonSet ∷ Ord a ⇒ HoonSet a → Set a setFromHoonSet = setFromList . treeToList . unHoonSet -mapFromHoonMap :: Ord k => HoonMap k v -> Map k v +mapFromHoonMap ∷ Ord k ⇒ HoonMap k v → Map k v mapFromHoonMap = mapFromList . treeToList . unHoonMap setToHoonSet ∷ ∀a. (Ord a, ToNoun a) ⇒ Set a → HoonSet a @@ -197,20 +197,44 @@ setToHoonSet = HoonSet . foldr put E . fmap (view nounVal) . setToList put x = \case E → N x E E Node a | x == n a → Node a - Node a | gorVal x (n a) → rit x a - Node a → lef x a + Node a | gorVal x (n a) → lef x a + Node a → rit x a - lef x a = put x (r a) & \case - E → error "bad-put" + rit x a = put x (r a) & \case + E → error "bad-put-set" Node c | morVal (n a) (n c) → N (n a) (l a) (Node c) Node c → N (n c) (N (n a) (l a) (l c)) (r c) - rit x a = put x (l a) & \case - E → error "bad-put" + lef x a = put x (l a) & \case + E → error "bad-put-set" Node c | morVal (n a) (n c) → N (n a) (Node c) (r a) Node c → N (n c) (l c) (N (n a) (r c) (r a)) -mapToHoonMap ∷ (ToNoun k, ToNoun v, Ord k, Ord v) ⇒ Map k v → HoonMap k v -mapToHoonMap = muck . setToHoonSet . setFromList . mapToList +p ∷ (ToNoun a, ToNoun b) ⇒ NounVal (a,b) → NounVal a +p = view (from nounVal . to fst . nounVal) + +pq ∷ (ToNoun a, ToNoun b) ⇒ NounVal (a,b) → (NounVal a, NounVal b) +pq = boof . view (from nounVal) where - muck (HoonSet x) = HoonMap x + boof (x, y) = (x ^. nounVal, y ^. nounVal) + +mapToHoonMap ∷ ∀k v. (ToNoun k, ToNoun v, Ord k, Ord v) ⇒ Map k v → HoonMap k v +mapToHoonMap = HoonMap . foldr put E . fmap (view nounVal) . mapToList + where + put ∷ NounVal (k, v) → HoonTree (k, v) → HoonTree (k, v) + put kv@(pq -> (b, c)) = \case + E → N kv E E + Node a | kv == n a → Node a + Node a | b == p (n a) → N kv (l a) (r a) + Node a | gorVal b (p $ n a) → lef kv a + Node a → rit kv a + + lef kv@(pq -> (b, c)) a = put kv (l a) & \case + E → error "bad-put-map" + Node d | morVal (p $ n a) (p $ n d) → N (n a) (Node d) (r a) + Node d → N (n d) (l d) (N (n a) (r d) (r a)) + + rit kv@(pq -> (b, c)) a = put kv (r a) & \case + E → error "bad-put-map" + Node d | morVal (p $ n a) (p $ n d) → N (n a) (l a) (Node d) + Node d → N (n d) (N (n a) (l a) (l d)) (r d) diff --git a/pkg/king/test/HoonMapSetTests.hs b/pkg/king/test/HoonMapSetTests.hs new file mode 100644 index 0000000000..f21d14ef13 --- /dev/null +++ b/pkg/king/test/HoonMapSetTests.hs @@ -0,0 +1,44 @@ +module HoonMapSetTests (tests) where + +import UrbitPrelude + +import Test.QuickCheck hiding ((.&.)) +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Tasty.TH + + +-- Utils ----------------------------------------------------------------------- + +roundTrip :: ∀a. Eq a => (a -> a) -> a -> Bool +roundTrip f x = f x == x + +newtype SmallNoun = SN Noun + deriving newtype (Eq, Ord, Show, ToNoun) + +instance Arbitrary SmallNoun where + arbitrary = SN <$> oneof [a, c, ac, ca, cc] + where + a = A . fromIntegral <$> (arbitrary :: Gen Word8) + c = C <$> a <*> a + ac = C <$> a <*> c + ca = C <$> c <*> a + cc = C <$> c <*> c + +-- Props ----------------------------------------------------------------------- + +mapRoundtrip :: Map SmallNoun SmallNoun -> Bool +mapRoundtrip = roundTrip (mapFromHoonMap . mapToHoonMap) + +setRoundtrip :: Set SmallNoun -> Bool +setRoundtrip = roundTrip (setFromHoonSet . setToHoonSet) + + +-- Utils ----------------------------------------------------------------------- + +tests :: TestTree +tests = + testGroup "Map/Set Conversions" + [ testProperty "Map Rountrip" mapRoundtrip + , testProperty "Set Rountrip" setRoundtrip + ] diff --git a/pkg/king/test/Main.hs b/pkg/king/test/Main.hs index e729eef930..009e75d863 100644 --- a/pkg/king/test/Main.hs +++ b/pkg/king/test/Main.hs @@ -16,6 +16,7 @@ import qualified DeriveNounTests import qualified ArvoTests import qualified AmesTests import qualified BehnTests +import qualified HoonMapSetTests main :: IO () main = do @@ -27,4 +28,5 @@ main = do , AmesTests.tests , LogTests.tests , BehnTests.tests + , HoonMapSetTests.tests ]