Trie and KV Types

hgeometry-combinatorial/hgeometry-combinatorial.cabal

@@ -141,15 +141,17 @@ library
 
         HGeometry.Permutation
 
-        HGeometry.Sequence.NonEmpty
         HGeometry.Sequence.Alternating
+        HGeometry.Sequence.NonEmpty
+        HGeometry.Sequence.KV
 
         HGeometry.Set.Util
         HGeometry.Sign
         HGeometry.StringSearch.KMP
 
         HGeometry.Tree.Binary.Static
         HGeometry.Tree.Util
+        HGeometry.Trie
 
         HGeometry.Unbounded
         HGeometry.Vector.NonEmpty.Util
@@ -193,6 +195,7 @@ test-suite hgeometry-combinatorial-hspec
        StringSearch.KMPSpec
        SetUtilSpec
        CyclicSpec
+       TrieSpec
 
     build-depends:
          hgeometry-combinatorial

hgeometry-combinatorial/src/HGeometry/Sequence/KV.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE UndecidableInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  HGeometry.Sequence.KV
+-- Copyright   :  (C) Frank Staals
+-- License     :  see the LICENSE file
+-- Maintainer  :  Frank Staals
+--
+-- Sequences of key value pairs.
+--
+--------------------------------------------------------------------------------
+module HGeometry.Sequence.KV
+  ( KV(..)
+  , empty
+  ) where
+
+import Control.Lens
+import Data.Bifoldable
+import Data.Bitraversable
+import Data.Foldable1
+import Data.Functor.Classes
+
+-----------------------------------------------------------------------------------------
+
+-- | An 'f' of key value pairs
+newtype KV f k v = KV (f (k,v))
+
+deriving instance (Show k, Show v, Show1 f) => Show (KV f k v)
+deriving instance (Eq k, Eq v, Eq1 f)       => Eq (KV f k v)
+deriving instance (Ord k, Ord v, Ord1 f)    => Ord (KV f k v)
+
+deriving instance Functor f     => Functor (KV f k)
+deriving instance Foldable f    => Foldable (KV f k)
+deriving instance Traversable f => Traversable (KV f k)
+
+instance Foldable1 f    => Foldable1 (KV f e) where
+  foldMap1 f (KV xs) = foldMap1 (foldMap1 f) xs
+
+instance Traversable1 f => Traversable1 (KV f e) where
+  traverse1 f (KV xs) = KV <$> traverse1 (traverse1 f) xs
+
+instance Functor f => Bifunctor (KV f) where
+  bimap f g (KV xs) = KV $ fmap (bimap f g) xs
+
+instance Foldable f => Bifoldable (KV f) where
+  bifoldMap f g (KV xs) = foldMap (bifoldMap f g) xs
+
+instance Traversable f => Bitraversable (KV f) where
+  bitraverse f g (KV xs) = KV <$> traverse (bitraverse f g) xs
+
+instance Functor f => FunctorWithIndex k (KV f k) where
+  imap f (KV xs) = KV $ fmap (\(k,v) -> (k,f k v)) xs
+
+instance Foldable f => FoldableWithIndex k (KV f k) where
+  ifoldMap f (KV xs) = foldMap (uncurry f) xs
+
+instance Traversable f => TraversableWithIndex k (KV f k) where
+  itraverse f (KV xs) = KV <$> traverse (\(k,v) -> (k,) <$> f k v) xs
+
+
+instance Semigroup (f (k,v)) => Semigroup (KV f k v) where
+  (KV xs) <> (KV ys) = KV $ xs <> ys
+
+instance Monoid (f (k,v)) => Monoid (KV f k v) where
+  mempty = empty
+
+-- | Produce an empty structure
+empty :: Monoid (f (k,v)) => KV f k v
+empty = KV mempty

hgeometry-combinatorial/src/HGeometry/Trie.hs

@@ -0,0 +1,64 @@
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  HGeometry.Trie
+-- Copyright   :  (C) Frank Staals
+-- License     :  see the LICENSE file
+-- Maintainer  :  Frank Staals
+--
+-- A Trie type
+--
+--------------------------------------------------------------------------------
+module HGeometry.Trie
+  ( TrieF(..)
+
+  ) where
+
+import Control.Lens
+import Data.Bifoldable
+import Data.Bitraversable
+import Data.Foldable1
+import Data.Functor.Apply ((<.*>))
+import Data.Functor.Classes
+import Data.Semigroup.Traversable
+
+--------------------------------------------------------------------------------
+
+-- | The Trie data type, parameterized by the data structure storing the children.
+data TrieF f e v = Node v (f e (TrieF f e v))
+
+deriving instance (Show v, Show e, Show2 f) => Show (TrieF f e v)
+deriving instance (Eq v, Eq e, Eq2 f)       => Eq (TrieF f e v)
+deriving instance (Ord v, Ord e, Ord2 f)    => Ord (TrieF f e v)
+
+deriving instance (Functor (f e))     => Functor (TrieF f e)
+deriving instance (Foldable (f e))    => Foldable (TrieF f e)
+deriving instance (Traversable (f e)) => Traversable (TrieF f e)
+
+-- instance Foldable (f e) => Foldable1 (TrieF f e) where
+--   foldMap1 f (Node v chs) = let Endo g = foldMap (\x -> Endo $ \x0 -> x0 <> foldMap1 f x) chs
+--                             in g (f v)
+-- somehow the order is wrong here...
+
+instance Foldable (f e) => Foldable1 (TrieF f e) where
+  foldMap1 f (Node v chs) = case foldMap (Just . foldMap1 f) chs of
+                              Nothing -> f v
+                              Just s  -> f v <> s
+  -- foldMap1 = foldMap1Default
+
+  -- f (Node v chs) = let Endo g = foldMap (\x -> Endo $ \x0 -> x0 <> foldMap1 f x) chs
+  --                           in g (f v)
+
+
+instance Traversable (f e) => Traversable1 (TrieF f e) where
+  traverse1 f (Node v chs) =
+    Node <$> f v <.*> traverse1Maybe (traverse1 f) chs
+
+
+instance Bifunctor f => Bifunctor (TrieF f) where
+  bimap f g (Node v chs) = Node (g v) (bimap f (bimap f g) chs)
+
+instance Bifoldable f => Bifoldable (TrieF f) where
+  bifoldMap f g (Node v chs) = g v <> bifoldMap f (bifoldMap f g) chs
+
+instance Bitraversable f => Bitraversable (TrieF f) where
+  bitraverse f g (Node v chs) = Node <$> g v <*> bitraverse f (bitraverse f g) chs

hgeometry-combinatorial/test/TrieSpec.hs

@@ -0,0 +1,43 @@
+module TrieSpec(spec) where
+
+-- import           Control.Lens
+import           Data.Foldable1
+import qualified Data.List.NonEmpty as NonEmpty
+import qualified Data.Map as Map
+import           HGeometry.Sequence.KV
+import           HGeometry.Trie
+import           Test.Hspec
+
+--------------------------------------------------------------------------------
+
+spec :: Spec
+spec = describe "Trie tests" $ do
+         it "fold1 Map" $
+           fold1 myTrie `shouldBe` "rootfoograndchildbar"
+         it "foldable1 to list Map" $
+           toNonEmpty myTrie `shouldBe` NonEmpty.fromList ["root","foo","grandchild","bar"]
+
+         it "fold1 KV" $
+           fold1 myTrie2 `shouldBe` "rootfoograndchildbar"
+         it "foldable1 to list KV" $
+           toNonEmpty myTrie2 `shouldBe` NonEmpty.fromList ["root","foo","grandchild","bar"]
+
+
+
+myTrie :: TrieF Map.Map Int String
+myTrie = Node "root" (Map.fromAscList [ (1,Node "foo" (Map.fromAscList
+                                                        [(10, Node "grandchild" Map.empty)]
+                                                      )
+                                        )
+                                      , (2,Node "bar" Map.empty)
+                                      ]
+
+                     )
+
+
+myTrie2 :: TrieF (KV []) Int String
+myTrie2 = Node "root" (KV [ (1,Node "foo" (KV [(10, Node "grandchild" empty)]))
+                          , (2,Node "bar" empty)
+                          ]
+
+                     )