Explicitly implement (map -> hoon map) and write simple qc tests.

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<d
   where (c, d) = (mug a, mug b)
 
-morVal, gorVal ∷ NounVal a -> 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)

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
+    ]

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
         ]