Haskell <-> Hoon conversions for map and set.

pkg/king/lib/Arvo/Common.hs

@@ -1,6 +1,5 @@
 module Arvo.Common
   ( KingId(..), ServId(..)
-  , NounTree(..), NounMap, NounSet
   , Json, JsonNode(..)
   , Desk(..), Mime(..)
   , Lane(..), Port(..), Turf(..)
@@ -105,23 +104,6 @@ data Mime = Mime Path File
 deriveNoun ''Mime
 
 
--- Trees, Maps, and Sets -------------------------------------------------------
-
-data NounTreeNode a = HTN
-    { ntnNode :: a
-    , ntnLeft :: NounTree a
-    , ntnRite :: NounTree a
-    }
-  deriving (Eq, Ord, Show)
-
-type NounTree a = Nullable (NounTreeNode a)
-
-type NounMap k v = NounTree (k, v)
-type NounSet a   = NounTree a
-
-deriveNoun ''NounTreeNode
-
-
 -- Json ------------------------------------------------------------------------
 
 type Json = Nullable JsonNode
@@ -129,7 +111,7 @@ type Json = Nullable JsonNode
 data JsonNode
     = JNA [Json]
     | JNB Bool
-    | JNO (NounMap Cord Json)
+    | JNO (HoonMap Cord Json)
     | JNN Knot
     | JNS Cord
   deriving (Eq, Ord, Show)

pkg/king/lib/Arvo/Event.hs

@@ -1,9 +1,9 @@
 module Arvo.Event where
 
 import UrbitPrelude hiding (Term)
+import Noun.Tree (HoonSet, HoonMap)
 
 import Arvo.Common (KingId(..), ServId(..))
-import Arvo.Common (NounMap, NounSet)
 import Arvo.Common (Desk, Mime)
 import Arvo.Common (Header(..), HttpEvent)
 import Arvo.Common (AmesDest, Ipv4, Ipv6, Port, Turf)
@@ -39,7 +39,7 @@ deriveNoun ''PUrl
 data Seed = Seed Ship Life Ring (Maybe Oath)
   deriving (Eq, Ord, Show)
 
-type Public = (Life, NounMap Life Pass)
+type Public = (Life, HoonMap Life Pass)
 
 data Dnses = Dnses { dPri::Cord, dSec::Cord, dTer::Cord }
   deriving (Eq, Ord, Show)
@@ -50,7 +50,7 @@ type ContNum = Word
 data EthPoint = EthPoint
     { epOwn :: (EthAddr, EthAddr, EthAddr, EthAddr)
     , epNet :: Maybe (Life, Pass, ContNum, (Bool, Ship), Maybe Ship)
-    , epKid :: Maybe (EthAddr, NounSet Ship)
+    , epKid :: Maybe (EthAddr, HoonSet Ship)
     }
   deriving (Eq, Ord, Show)
 
@@ -61,20 +61,20 @@ data EthEventId = EthEventId
   deriving (Eq, Ord, Show)
 
 data EthBookmark = EthBookmark
-    { ebHeard       :: NounSet EthEventId
+    { ebHeard       :: HoonSet EthEventId
     , ebLatestBlock :: Atom
     }
   deriving (Eq, Ord, Show)
 
-data Snap = Snap (NounMap Ship Public)
+data Snap = Snap (HoonMap Ship Public)
-                 (Dnses, NounMap Ship EthPoint)
+                 (Dnses, HoonMap Ship EthPoint)
                  EthBookmark
   deriving (Eq, Ord, Show)
 
 data Dawn = MkDawn
     { dSeed :: Seed
     , dShip :: Ship
-    , dCzar :: NounMap Ship (Life, Pass)
+    , dCzar :: HoonMap Ship (Life, Pass)
     , dTurf :: [Turf]
     , dBloq :: Bloq
     , dNode :: (Maybe PUrl)

pkg/king/lib/Noun.hs

@@ -8,6 +8,7 @@ module Noun
     , module Noun.Jam
     , module Noun.Tank
     , module Noun.TH
+    , module Noun.Tree
     , _Cue
     , LoadErr(..)
     , loadFile
@@ -18,6 +19,7 @@ import Control.Lens
 
 import Data.Word
 import Noun.Atom
+import Noun.Tree
 import Noun.Conversions
 import Noun.Convert
 import Noun.Core

pkg/king/lib/Noun/Tree.hs

@@ -0,0 +1,216 @@
+{-# LANGUAGE DuplicateRecordFields, DisambiguateRecordFields #-}
+
+module Noun.Tree
+    ( HoonSet, setToHoonSet, setFromHoonSet
+    , HoonMap, mapToHoonMap, mapFromHoonMap
+    ) where
+
+import ClassyPrelude
+import Control.Lens  hiding (non)
+
+import Noun.Atom
+import Noun.Conversions ()
+import Noun.Convert
+import Noun.Core
+import Noun.TH
+
+import Data.Bits        (shiftR, xor)
+import Data.Hash.Murmur (murmur3)
+import GHC.Natural      (Natural)
+
+
+-- Types -----------------------------------------------------------------------
+
+data NounVal a = NounVal
+    { non ∷ Noun
+    , val ∷ !a
+    }
+
+data HoonTreeNode a = NTN
+    { n ∷ NounVal a
+    , l ∷ HoonTree a
+    , r ∷ HoonTree a
+    }
+  deriving (Eq, Ord, Show)
+
+data HoonTree a = E | Node (HoonTreeNode a)
+  deriving (Eq, Ord, Show)
+
+pattern N n l r = Node (NTN n l r)
+
+newtype HoonSet a = HoonSet { unHoonSet ∷ HoonTree a }
+  deriving newtype (Eq, Ord, Show, FromNoun, ToNoun)
+
+newtype HoonMap k v = HoonMap { unHoonMap ∷ HoonTree (k, v) }
+  deriving newtype (Eq, Ord, Show, FromNoun, ToNoun)
+
+
+-- Instances -------------------------------------------------------------------
+
+instance Eq (NounVal a) where
+  (==) = on (==) non
+
+instance Ord (NounVal a) where
+  compare = comparing non
+
+instance ToNoun (NounVal a) where
+  toNoun = non
+
+instance Show a => Show (NounVal a) where
+  show = show . val
+
+instance FromNoun a => FromNoun (NounVal a) where
+    parseNoun x = NounVal x <$> parseNoun x
+
+instance ToNoun a => ToNoun (HoonTree a) where
+    toNoun E        = A 0
+    toNoun (Node n) = toNoun n
+
+instance FromNoun a => FromNoun (HoonTree a) where
+    parseNoun (A 0) = pure E
+    parseNoun n     = Node <$> parseNoun n
+
+deriveNoun ''HoonTreeNode
+
+
+-- Mug -------------------------------------------------------------------------
+
+type Nat = Natural
+
+slowMug :: Noun -> Nat
+slowMug = trim 0xcafe_babe . \case
+    A a   -> a
+    C h t -> mix (slowMug h) $ mix 0x7fff_ffff (slowMug t)
+  where
+    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 = xor
+
+-- Murmur3
+muk :: Nat -> Nat -> Nat -> Nat
+muk seed len =
+    fromIntegral . murmur3 (word32 seed) . resize . view atomBytes
+  where
+    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
+
+int :: Integral i => i -> Int
+int = fromIntegral
+
+word32 :: Integral i => i -> Word32
+word32 = fromIntegral
+
+bex :: Nat -> Nat
+bex = (2^)
+
+end :: Nat -> Nat -> Nat -> Nat
+end blockSize blocks n =
+  n `mod` (bex (bex blockSize * blocks))
+
+rsh :: Nat -> Nat -> Nat -> Nat
+rsh blockSize blocks n =
+    shiftR n $ fromIntegral $ (bex blockSize * blocks)
+
+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 = slowMug
+
+
+-- Order -----------------------------------------------------------------------
+
+{-
+    Orders in ascending double mug hash order, collisions fall back to dor.
+-}
+mor ∷ Noun -> Noun -> Bool
+mor a b = if c == d then dor a b else c < d
+  where
+    c = mug $ A $ mug a
+    d = mug $ A $ mug b
+
+{-
+    Orders in ascending tree depth.
+-}
+dor ∷ Noun -> Noun -> Bool
+dor a       b       | a == b = True
+dor (A a)   (C _ _)          = True
+dor (C x y) (A b)            = False
+dor (A a)   (A b)            = a < b
+dor (C x y) (C p q) | x == p = dor y q
+dor (C x y) (C p q)          = dor x p
+
+{-
+    Orders in ascending +mug hash order.
+
+    Collisions fall back to dor.
+-}
+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 = on mor non
+gorVal = on gor non
+
+
+--------------------------------------------------------------------------------
+
+nounVal ∷ ToNoun a => Iso' a (NounVal a)
+nounVal = iso to val
+  where
+    to x = NounVal (toNoun x) x
+
+treeToList :: ∀a. HoonTree a -> [a]
+treeToList = go []
+  where
+    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 = setFromList . treeToList . unHoonSet
+
+mapFromHoonMap :: Ord k => HoonMap k v -> Map k v
+mapFromHoonMap = mapFromList . treeToList . unHoonMap
+
+setToHoonSet ∷ ∀a. (Ord a, ToNoun a) ⇒ Set a → HoonSet a
+setToHoonSet = HoonSet . foldr put E . fmap (view nounVal) . setToList
+  where
+    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
+
+    lef x a = put x (r a) & \case
+        E                           → error "bad-put"
+        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"
+        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
+  where
+    muck (HoonSet x) = HoonMap x

pkg/king/package.yaml

@@ -59,6 +59,7 @@ dependencies:
   - megaparsec
   - mtl
   - multimap
+  - murmur3
   - network
   - optparse-applicative
   - para