diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/euler-tour-tree.cabal b/euler-tour-tree.cabal new file mode 100644 --- /dev/null +++ b/euler-tour-tree.cabal @@ -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 diff --git a/src/Data/EulerTourTree.hs b/src/Data/EulerTourTree.hs new file mode 100644 --- /dev/null +++ b/src/Data/EulerTourTree.hs @@ -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 diff --git a/test/HLint.hs b/test/HLint.hs new file mode 100644 --- /dev/null +++ b/test/HLint.hs @@ -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 diff --git a/test/PropertyTests.hs b/test/PropertyTests.hs new file mode 100644 --- /dev/null +++ b/test/PropertyTests.hs @@ -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) diff --git a/test/UnitTests.hs b/test/UnitTests.hs new file mode 100644 --- /dev/null +++ b/test/UnitTests.hs @@ -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 [] ] ] )