From ee0def33f5b3fe2666b1441120660e730f9fc885 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 26 Sep 2019 13:29:19 -0700 Subject: [PATCH] Haskell <-> Hoon conversions for map and set. --- pkg/king/lib/Arvo/Common.hs | 20 +--- pkg/king/lib/Arvo/Event.hs | 14 +-- pkg/king/lib/Noun.hs | 2 + pkg/king/lib/Noun/Tree.hs | 216 ++++++++++++++++++++++++++++++++++++ pkg/king/package.yaml | 1 + 5 files changed, 227 insertions(+), 26 deletions(-) create mode 100644 pkg/king/lib/Noun/Tree.hs diff --git a/pkg/king/lib/Arvo/Common.hs b/pkg/king/lib/Arvo/Common.hs index 3ad2057a09..e396afbf7c 100644 --- a/pkg/king/lib/Arvo/Common.hs +++ b/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) diff --git a/pkg/king/lib/Arvo/Event.hs b/pkg/king/lib/Arvo/Event.hs index 385f1bdaa3..0c39951954 100644 --- a/pkg/king/lib/Arvo/Event.hs +++ b/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) - (Dnses, NounMap Ship EthPoint) +data Snap = Snap (HoonMap Ship Public) + (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) diff --git a/pkg/king/lib/Noun.hs b/pkg/king/lib/Noun.hs index 7c84d4bfad..c90fc7479b 100644 --- a/pkg/king/lib/Noun.hs +++ b/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 diff --git a/pkg/king/lib/Noun/Tree.hs b/pkg/king/lib/Noun/Tree.hs new file mode 100644 index 0000000000..64c34301e5 --- /dev/null +++ b/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 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 diff --git a/pkg/king/package.yaml b/pkg/king/package.yaml index d20954366e..c6d7961cd1 100644 --- a/pkg/king/package.yaml +++ b/pkg/king/package.yaml @@ -59,6 +59,7 @@ dependencies: - megaparsec - mtl - multimap + - murmur3 - network - optparse-applicative - para