euler-tour-tree (empty) → 0.1.0.0

raw patch · 6 files changed

+468/−0 lines, 6 filesdep +QuickCheckdep +Uniquedep +basesetup-changed

Dependencies added: QuickCheck, Unique, base, containers, euler-tour-tree, fingertree, hlint, keys, mtl, parser-combinators, sequence, tasty, tasty-hunit, tasty-quickcheck, transformers

Files

Setup.hs +2/−0
euler-tour-tree.cabal +76/−0
src/Data/EulerTourTree.hs +229/−0
test/HLint.hs +8/−0
test/PropertyTests.hs +51/−0
test/UnitTests.hs +102/−0

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ euler-tour-tree.cabal view

@@ -0,0 +1,76 @@+name:                euler-tour-tree+version:             0.1.0.0+synopsis:            Euler tour trees+-- description:         Cf README file+homepage:            https://github.com/k0ral/euler-tour-tree+license:             PublicDomain+author:              koral+maintainer:          koral@mailoo.org+category:            Data+build-type:          Simple+-- extra-source-files:  ChangeLog.md+cabal-version:       >=1.10+++source-repository head+  type:     git+  location: git://github.com/k0ral/euler-tour-tree.git+++flag enable-hlint-test+  description: Enable hlint test-suite+  manual: True+  default: False+++library+  exposed-modules:+    Data.EulerTourTree+    -- Data.EulerTourTree.Sized+  build-depends:       base >=4.9 && <4.11, containers, fingertree, mtl, parser-combinators, transformers, Unique+  hs-source-dirs:      src+  default-language:    Haskell2010+++test-suite unit-tests+    type: exitcode-stdio-1.0+    main-is: UnitTests.hs+    build-depends:+        euler-tour-tree -any,+        base >=4.9,+        containers,+        tasty -any,+        tasty-hunit -any+    default-language: Haskell2010+    hs-source-dirs: test+++test-suite property-tests+    type: exitcode-stdio-1.0+    main-is: PropertyTests.hs+    build-depends:+        euler-tour-tree -any,+        base >=4.9,+        containers,+        keys,+        QuickCheck,+        -- quickcheck-instances -any,+        sequence,+        tasty -any,+        tasty-quickcheck -any+    default-language: Haskell2010+    hs-source-dirs: test+++test-suite hlint-tests+    if flag(enable-hlint-test)+      buildable: True+    else+      buildable: False+    type: exitcode-stdio-1.0+    main-is: HLint.hs+    build-depends:+        base >=4.9,+        hlint -any+    default-language: Haskell2010+    hs-source-dirs: test

+ src/Data/EulerTourTree.hs view

@@ -0,0 +1,229 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE ExplicitForAll        #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving    #-}+-- | Implementation of Euler tour trees.+--+-- > import qualified Data.EulerTourTree as ETTree+-- > import Data.EulerTourTree(EulerTourTree)+--+-- When specified, time complexity refers to the number /n/ of nodes in the input tree.+module Data.EulerTourTree+  ( EulerTourTree+    -- * Construction+  , empty+  , singleton+  , fromTree+    -- * Deconstruction+  , toTree+    -- * Query+  , root+  , member+  , size+    -- * Transformation+  , cutEdge+  , splice+  , reroot+  ) where++-- {{{ Imports+import           Control.Applicative             hiding (empty)+import           Control.Applicative.Combinators+import           Control.Monad+import           Control.Monad.State.Lazy+import           Control.Monad.Trans.Maybe+import           Data.FingerTree                 hiding (empty, null, singleton)+import qualified Data.FingerTree                 as FingerTree+import           Data.Foldable+import           Data.List.Unique+import           Data.Maybe+import           Data.Monoid+import           Data.Set                        (Set)+import qualified Data.Set                        as Set+import           Data.Tree+import           Debug.Trace+-- }}}++searchM :: MonadPlus m => Measured v a => (v -> v -> Bool) -> FingerTree v a -> m (FingerTree v a, a, FingerTree v a)+searchM f tree = case FingerTree.search f tree of+  Position before element after -> return (before, element, after)+  _                             -> mzero++initSafe :: Measured v a => FingerTree v a -> FingerTree v a+initSafe tree = case viewr tree of+  result :> _ -> result+  _           -> tree++tailSafe :: Measured v a => FingerTree v a -> FingerTree v a+tailSafe tree = case viewl tree of+  _ :< result -> result+  _           -> tree++newtype EulerTourNode node = EulerTourNode node++deriving instance (Eq node) => Eq (EulerTourNode node)+deriving instance (Ord node) => Ord (EulerTourNode node)+deriving instance (Show node) => Show (EulerTourNode node)++data EulerTourMonoid node = EulerTourMonoid+  (First node)+  (Set (node, node))+  (Last node)+  (Set node)+  (Sum Int)++deriving instance Show node => Show (EulerTourMonoid node)++instance Ord node => Monoid (EulerTourMonoid node) where+  mempty = EulerTourMonoid mempty mempty mempty mempty mempty+  EulerTourMonoid a b c d e `mappend` EulerTourMonoid a' b' c' d' e' = result where+    result = EulerTourMonoid (a <> a') (b <> bMiddle <> b') (c <> c') (d <> d') (e <> e')+    bMiddle = fromMaybe mempty $ do+      l <- getLast c+      f <- getFirst a'+      return $ Set.singleton (min l f, max l f)++instance Ord node => Measured (EulerTourMonoid node) (EulerTourNode node) where+  measure (EulerTourNode node) = EulerTourMonoid (pure node) mempty (pure node) (Set.singleton node) (pure 1)++firstVertex :: MonadPlus m => Ord node => EulerTourMonoid node -> m node+firstVertex (EulerTourMonoid first _ _ _ _) = maybe mzero return $ getFirst first++allNodes :: Ord node => EulerTourMonoid node -> Set node+allNodes (EulerTourMonoid _ _ _ nodes _) = nodes++vertexMember :: Ord node => node -> EulerTourMonoid node -> Bool+vertexMember node (EulerTourMonoid _ _ _ nodes _) = Set.member node nodes++edgeMember :: Ord node => (node, node) -> EulerTourMonoid node -> Bool+edgeMember (u, v) (EulerTourMonoid _ edges _ _ _) = Set.member (min u v, max u v) edges++tourSize :: EulerTourMonoid node -> Int+tourSize (EulerTourMonoid _ _ _ nodes _) = Set.size nodes+++-- | Euler-tour implementation of a tree structure. It is parameterized by a node type @node@.+--+-- Requirements:+--+-- - @node@ is ordered+-- - node values are unique+data EulerTourTree node where+  EulerTourTree :: Ord node => FingerTree (EulerTourMonoid node) (EulerTourNode node) -> EulerTourTree node++instance Ord node => Measured (Set (node, node), Set node, Sum Int) (EulerTourTree node) where+  measure (EulerTourTree tree) = (edges, nodes, size) where+    EulerTourMonoid _ edges _ nodes size = measure tree++-- | 'member' and 'size' are respectively faster than 'elem' and 'length' (which run in /O(n)/).+instance Foldable EulerTourTree where+  foldMap f etTree@(EulerTourTree _) = maybe mempty (foldMap f) $ toTree etTree++deriving instance Eq node => Eq (EulerTourTree node)+deriving instance Ord node => Ord (EulerTourTree node)+deriving instance Show node => Show (EulerTourTree node)+++-- | /O(1)/ Construct an empty Euler tour tree.+empty :: Ord node => EulerTourTree node+empty = EulerTourTree FingerTree.empty++-- | /O(1)/ Construct an Euler tour tree with a single element.+singleton :: Ord node => node -> EulerTourTree node+singleton node = EulerTourTree $ FingerTree.singleton $ EulerTourNode node++-- | /O(n)/ Construct an Euler tour tree from a 'Data.Tree'.+--+-- Fail if, and only if, node values are not unique.+fromTree :: MonadPlus m => Ord node => Tree node -> m (EulerTourTree node)+fromTree tree = do+  guard $ allUnique $ toList tree+  return $ EulerTourTree $ fromTree' tree+  where fromTree' (Node node forest) = EulerTourNode node <| mconcat (map ((\x -> x |> EulerTourNode node) . fromTree') forest)++type Parser node m = (MonadState (FingerTree (EulerTourMonoid node) (EulerTourNode node)) m, MonadPlus m)++-- | /O(n)/ Deconstruct an Euler tour tree into a 'Data.Tree'.+toTree :: MonadPlus m => Ord node => EulerTourTree node -> m (Tree node)+toTree (EulerTourTree fingerTree) = evalStateT parser fingerTree where+  parser = do+    EulerTourNode node <- anyToken+    forest <- parser `endBy` try (token $ EulerTourNode node)+    return $ Node node forest+  anyToken :: Ord node => Parser node m => m (EulerTourNode node)+  anyToken = do+    tree <- get+    case viewl tree of+      node :< tree' -> put tree' >> return node+      _             -> mzero+  token x = do+    t <- anyToken+    guard (t == x)+    return t+  try f = do+    a <- get+    f <|> (put a >> mzero)++-- | /O(1)/ Return the root of the tree. Fail if it is empty.+root :: MonadPlus m => Ord node => EulerTourTree node -> m node+root (EulerTourTree tree) = firstVertex $ measure tree++-- | /O(log n)/ Return 'True' if node is an element of the tree.+member :: Ord node => node -> EulerTourTree node -> Bool+member node (EulerTourTree tree) = vertexMember node $ measure tree++-- | /O(1)/ Return the number of elements in the tree.+size :: Ord node => EulerTourTree node -> Int+size (EulerTourTree fingerTree) = tourSize $ measure fingerTree++-- | /O(log n)/ Return 2 subtrees of @tree@ where @a@ is the subtree of nodes __a__bove @edge@, and @b@ is the subtree of nodes __b__elow @edge@.+--+-- Fail if @edge@ isn't found in @tree@+cutEdge :: MonadPlus m+        => Ord node+        => EulerTourTree node  -- ^ Denoted by @tree@+        -> (node, node)        -- ^ Denoted by @edge@+        -> m (EulerTourTree node, EulerTourTree node)  -- ^ Denoted by @(a, b)@+cutEdge (EulerTourTree tree) e@(a, b) = do+  (left, node, tree') <- searchM p1 tree+  (middle, node', right) <- searchM p2 $ node <| tree'+  let inside = node <| middle+      outside = left >< tailSafe right+  return (EulerTourTree inside, EulerTourTree outside)+  where p1 before after = edgeMember e before+        p2 before after = not (edgeMember e after)++-- | /O(log n)/ Attach @tree1@ as a child of @node@ in @tree2@.+--+-- Fail if @node@ isn't found in @tree2@, or if @tree1@ and @tree2@ have nodes in common.+splice :: MonadPlus m+       => Ord node+       => EulerTourTree node           -- ^ Denoted by @tree1@+       -> node                         -- ^ Denoted by @node@+       -> EulerTourTree node           -- ^ Denoted by @tree2@+       -> m (EulerTourTree node)+splice (EulerTourTree inviteeTree) node (EulerTourTree hostTree) = do+  guard $ null $ Set.intersection (allNodes $ measure inviteeTree) (allNodes $ measure hostTree)+  (left, _, right) <- searchM p hostTree+  let inviteeTree' = if FingerTree.null inviteeTree then inviteeTree else EulerTourNode node <| inviteeTree+  return $ EulerTourTree $ left >< inviteeTree' >< (EulerTourNode node <| right)+  where p before after = vertexMember node before && not (vertexMember node after)++-- | /O(log n)/ Rotate @tree@ such that @node@ is the new root.+--+-- Return 'Nothing' if @node@ isn't found in @tree@.+reroot :: MonadPlus m+       => Ord node+       => node                 -- ^ Denoted by @node@+       -> EulerTourTree node   -- ^ Denoted by @tree@+       -> m (EulerTourTree node)+reroot node (EulerTourTree tree) = do+  (left, _, tree') <- searchM p1 tree+  (middle, _, right) <- searchM p2 (etNode <| tree')+  return $ EulerTourTree $ middle >< (etNode <| initSafe right) >< (left |> etNode)+  where p1 before after = vertexMember node before+        p2 before after = not (vertexMember node after)+        etNode = EulerTourNode node

+ test/HLint.hs view

@@ -0,0 +1,8 @@+import qualified Language.Haskell.HLint as HLint (hlint)+import           System.Exit+++main :: IO ()+main = do+  result <- HLint.hlint [ "test/", "src/" ]+  if null result then exitSuccess else exitFailure

+ test/PropertyTests.hs view

@@ -0,0 +1,51 @@+import           Data.EulerTourTree++import           Data.Foldable+import           Data.Key+import           Data.Monoid+import           Data.Sequence         hiding (empty)+import           Data.Tree+import           Test.QuickCheck.Gen+import           Test.Tasty+import           Test.Tasty.QuickCheck+++-- Unsafe version of fromTree+fromTree' :: Ord node => Tree node -> EulerTourTree node+fromTree' tree = let Just a = fromTree tree in a+++main :: IO ()+main = defaultMain $ testGroup "Property tests"+  [ fromToTree+  , spliceEmpty+  ]++fromToTree :: TestTree+fromToTree = testProperty "toTree . fromTree == id" $ do+  tree <- genTree+  let intermediate = fromTree tree+      result = toTree =<< intermediate+  return $ counterexample (show tree <> "\n" <> show intermediate <> "\n" <> show result) $+    Just tree == result++spliceEmpty :: TestTree+spliceEmpty = testProperty "splice empty == id" $ do+  tree <- fromTree' <$> genTree+  node <- genElement tree+  let result = splice empty node tree+  return $ counterexample (show tree <> "\n" <> show node <> "\n" <> show result) $ Just tree == result+++genElement :: Foldable f => f a -> Gen a+genElement = elements . toList++genTree :: Gen (Tree (Seq Int))+genTree = genTreeDepth =<< elements [1..1]++genTreeDepth :: Int -> Gen (Tree (Seq Int))+genTreeDepth n = mapWithKey (\key _ -> key) <$> genTreeDepth' n++genTreeDepth' :: Int -> Gen (Tree ())+genTreeDepth' 0 = return $ Node () []+genTreeDepth' n = Node () <$> vectorOf 5 (genTreeDepth' $ n-1)

+ test/UnitTests.hs view

@@ -0,0 +1,102 @@+import           Data.EulerTourTree++import           Data.Tree+import           Test.Tasty+import           Test.Tasty.HUnit+++-- Unsafe version of fromTree+fromTree' :: Ord node => Tree node -> EulerTourTree node+fromTree' tree = let Just a = fromTree tree in a++main :: IO ()+main = defaultMain $ testGroup "Unit tests"+  [ cutEdgeTest+  , memberTest+  , rerootTest+  , rootTest+  , sizeTest+  , spliceTest+  ]++testTree1 :: EulerTourTree Int+testTree1 = fromTree' $ Node 0+  [ Node 10+    [ Node 11 []+    , Node 12 [] ]+  , Node 20+    [ Node 21 []+    , Node 22 [] ] ]++testTree2 :: EulerTourTree Int+testTree2 = fromTree' $ Node 100+  [ Node 110+    [ Node 111 []+    , Node 112 []+    ]+  , Node 120+    [ Node 121 []+    , Node 122 []+    ]+  ]+++cutEdgeTest :: TestTree+cutEdgeTest = testCase "cutEdge" $ do+  cutEdge empty (0, 1) @?= Nothing+  cutEdge testTree1 (10, 11) @?= Just (fromTree' $ Node 11 [], fromTree' $ Node 0+   [ Node 10+     [ Node 12 [] ]+   , Node 20+     [ Node 21 []+     , Node 22 [] ] ])++memberTest :: TestTree+memberTest = testCase "member" $ do+  member 0 testTree1  @?= True+  member 1 testTree1  @?= False+  member 12 testTree1 @?= True+  member 21 testTree1 @?= True+  member 23 testTree1 @?= False++rerootTest :: TestTree+rerootTest = testCase "reroot" $ do+  reroot 0 empty @?= Nothing+  reroot 12 testTree1 @?= Just (fromTree' $ Node 12+    [ Node 10+      [ Node 0+        [ Node 20+          [ Node 21 []+          , Node 22 [] ] ]+        , Node 11 [] ] ] )++rootTest :: TestTree+rootTest = testCase "root" $ do+  root (empty :: EulerTourTree Int) @?= Nothing+  root (singleton 1) @?= Just 1+  root testTree1 @?= Just 0++sizeTest :: TestTree+sizeTest = testCase "size" $ do+  size (empty :: EulerTourTree Int) @?= 0+  size (singleton 1) @?= 1+  size testTree1 @?= 7+  size testTree2 @?= 7++spliceTest :: TestTree+spliceTest = testCase "splice" $ do+  splice testTree2 12 empty @?= Nothing+  splice testTree2 12 testTree1 @?= Just (fromTree' $ Node 0+    [ Node 10+      [ Node 11 []+      , Node 12+          [ Node 100+            [ Node 110+              [ Node 111 []+              , Node 112 [] ]+            , Node 120+              [ Node 121 []+              , Node 122 [] ] ] ] ]+    , Node 20+      [ Node 21 []+      , Node 22 [] ] ] )