Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

repository initialized

  • Loading branch information...
commit 911aa8918495094485a2782408d394279953b3a0 0 parents
@ekmett authored
1  .gitignore
@@ -0,0 +1 @@
+dist
1  .travis.yml
@@ -0,0 +1 @@
+language: haskell
179 Data/LCA/Online.hs
@@ -0,0 +1,179 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.LCA.Online
+-- Copyright : (C) 2011-2012 Edward Kmett,
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : Edward Kmett <ekmett@gmail.com>
+-- Stability : experimental
+-- Portability : portable
+--
+-- Provides online calculation of the the lowest common ancestor in /O(log h)/
+-- by compressing the spine of the paths using a skew binary random access
+-- list.
+--
+-- Algorithms used here assume that the key values chosen for @k@ are
+-- globally unique.
+--
+----------------------------------------------------------------------------
+module Data.LCA.Online
+ ( Path
+ , empty
+ , cons
+ , null
+ , length
+ , isAncestorOf
+ , lca
+ , keep
+ , drop
+ , traverseWithKey
+ , (~=)
+ ) where
+
+import Control.Applicative
+import Data.Foldable
+import Data.Traversable
+import Data.Monoid
+import Prelude hiding (length, null)
+
+-- TODO: would a zeroless skew binary random access list reduce bookkeeping overhead?
+
+data Path k a
+ = Nil
+ | Cons {-# UNPACK #-} !Int -- ^ the number of elements @n@ in this entire skew list
+ {-# UNPACK #-} !Int -- ^ the number of elements @w@ in this binary tree node
+ (Tree k a) -- ^ a complete binary tree @t@ of with @w@ elements
+ (Path k a) -- ^ @n - w@ elements in a linked list @ts@, of complete trees in ascending order by size
+ deriving (Show, Read)
+
+instance Functor (Path k) where
+ fmap _ Nil = Nil
+ fmap f (Cons n k t ts) = Cons n k (fmap f t) (fmap f ts)
+
+instance Foldable (Path k) where
+ foldMap _ Nil = mempty
+ foldMap f (Cons n k t ts) = foldMap f t `mappend` foldMap f ts
+
+instance Traversable (Path k) where
+ traverse f Nil = pure Nil
+ traverse f (Cons n k t ts) = Cons n k <$> traverse f t <*> traverse f ts
+
+-- | Complete binary trees
+-- NB: we could ensure the complete tree invariant
+data Tree k a
+ = Bin k a (Tree k a) (Tree k a)
+ | Tip k a
+ deriving (Show, Read)
+
+instance Functor (Tree k) where
+ fmap f (Bin n a l r) = Bin n (f a) (fmap f l) (fmap f r)
+ fmap f (Tip n a) = Tip n (f a)
+
+instance Foldable (Tree k) where
+ foldMap f (Bin _ a l r) = f a `mappend` foldMap f l `mappend` foldMap f r
+ foldMap f (Tip _ a) = f a
+
+instance Traversable (Tree k) where
+ traverse f (Bin n a l r) = Bin n <$> f a <*> traverse f l <*> traverse f r
+ traverse f (Tip n a) = Tip n <$> f a
+
+traverseWithKey :: Applicative f => (k -> a -> f b) -> Path k a -> f (Path k b)
+traverseWithKey f Nil = pure Nil
+traverseWithKey f (Cons n k t ts) = Cons n k <$> traverseTreeWithKey f t <*> traverseWithKey f t
+
+-- | The empty path
+empty :: Path k a
+empty = Nil
+
+-- | /O(1)/
+length :: Path k a -> Int
+length Nil = 0
+length (Cons n _ _ _) = n
+
+-- | /O(1)/
+null :: Path k a -> Bool
+null Nil = True
+null _ = False
+
+-- | /O(1)/ Invariant: most operations assume that the keys @k@ are globally unique
+cons :: k -> a -> Path k a -> Path k a
+cons k a (Cons n w t (Cons _ w' t2 ts)) | w == w' = Cons (n + 1) (2 * w + 1) (Bin k a t t2) ts
+cons k a ts = Cons (length ts + 1) 1 (Tip k a) ts
+
+-- | /O(log (h - k))/ to @keep k@ elements of path of height @h@
+keep :: Int -> Path k a -> Path k a
+keep k Nil = Nil
+keep k xs@(Cons n w t ts)
+ | k >= n = xs
+ | otherwise = case compare k (n - w) of
+ GT -> keepT (k - n + w) w t ts
+ EQ -> ts
+ LT -> keep k ts
+
+-- | /O(log k)/ to @drop k@ elements from a path
+drop :: Int -> Path k a -> Path k a
+drop k xs = keep (length xs - k) xs
+
+-- | /O(log h)/ Compute the lowest common ancestor
+lca :: Eq k => Path k a -> Path k b -> Path k a
+lca xs ys = case compare nxs nys of
+ LT -> lca' xs (keep nxs ys)
+ EQ -> lca' xs ys
+ GT -> lca' (keep nys xs) ys
+ where
+ nxs = length xs
+ nys = length ys
+
+-- /O(log h)/ @xs `isAncestorOf` ys@ holds when @xs@ is a prefix starting at the root of path @ys@.
+isAncestorOf :: Eq k => Path k a -> Path k b -> Bool
+isAncestorOf xs ys = xs ~= keep (length xs) ys
+
+
+infix 4 ~=
+-- | /O(1)/ Compare to see if two trees have the same leaf key
+(~=) :: Eq k => Path k a -> Path k b -> Bool
+Nil ~= Nil = True
+Cons _ _ s _ ~= Cons _ _ t _ = sameT s t
+_ ~= _ = False
+
+-- * Utilities
+consT :: Int -> Tree k a -> Path k a -> Path k a
+consT w t ts = Cons (w + length ts) w t ts
+
+keepT :: Int -> Int -> Tree k a -> Path k a -> Path k a
+keepT n w (Bin k a l r) ts = case compare n w2 of
+ LT -> keepT n w2 r ts
+ EQ -> consT w2 r ts
+ GT | n == w - 1 -> consT w2 l (consT w2 r ts)
+ | otherwise -> keepT (n - w2) w2 l (consT w2 r ts)
+ where w2 = div w 2
+keepT _ _ _ ts = ts
+
+sameT :: Eq k => Tree k a -> Tree k b -> Bool
+sameT xs ys = root xs == root ys
+
+-- | invariant: both paths have the same number of elements and the same shape
+lca' :: Eq k => Path k a -> Path k b -> Path k a
+lca' Nil Nil = Nil
+lca' h@(Cons _ w x xs) (Cons _ _ y ys)
+ | sameT x y = h
+ | xs ~= ys = lcaT w x y xs
+ | otherwise = lca' xs ys
+lca' _ _ = error "lca: the impossible happened"
+
+lcaT :: Eq k => Int -> Tree k a -> Tree k b -> Path k a -> Path k a
+lcaT w (Tip i a) (Tip j _) ts = ts
+lcaT w (Bin i a la ra) (Bin j b lb rb) ts
+ | sameT la lb = consT w2 la (consT w2 ra ts)
+ | sameT ra rb = lcaT w2 la lb (consT w ra ts)
+ | otherwise = lcaT w2 ra rb ts
+ where w2 = div w 2
+
+traverseTreeWithKey :: Applicative f => (k -> a -> f b) -> Tree k a -> f (Tree k b)
+traverseTreeWithKey f (Bin k a l r) = Bin k <$> f k a <*> traverseTreeWithKey f l <*> traverseTreeWithKey f r
+traverseTreeWithKey f (Tip k a) = Tip k <*> f k a
+
+-- | /O(1)/
+root :: Tree k a -> k
+root (Tip k _) = k
+root (Bin k _ _ _) = k
111 Data/LCA/Online/Naive.hs
@@ -0,0 +1,111 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.LCA.Online.Naive
+-- Copyright : (C) 2011-2012 Edward Kmett,
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : Edward Kmett <ekmett@gmail.com>
+-- Stability : experimental
+-- Portability : portable
+--
+-- Naive online calculation of the the lowest common ancestor in /O(h)/
+----------------------------------------------------------------------------
+module Data.LCA.Online.Naive
+ ( Path
+ , empty
+ , cons
+ , null
+ , length
+ , isAncestorOf
+ , lca
+ , keep
+ , drop
+ , traverseWithKey
+ , (~=)
+ ) where
+
+import Control.Applicative
+import Data.Foldable hiding (toList)
+import Data.Traversable
+import Data.Monoid
+import Prelude hiding (length, null)
+
+-- TODO: would a zeroless skew binary random access list reduce bookkeeping overhead?
+
+data Path k a = Path {-# UNPACK #-} !Int [(k,a)]
+ deriving (Show, Read)
+
+toList :: Path k a -> [(k,a)]
+toList (Path _ xs) = xs
+
+instance Functor (Path k) where
+ fmap f (Path n xs) = Path n [ (k, f a) | (k,a) <- xs]
+
+instance Foldable (Path k) where
+ foldMap f (Path n xs) = foldMap (f . snd) xs
+
+instance Traversable (Path k) where
+ traverse f (Path n xs) = Path n $ traverse (\(k,a) -> (,) k <$> f a) xs
+
+traverseWithKey :: Applicative f => (k -> a -> f b) -> Path k a -> f (Path k b)
+traverseWithKey f (Path n xs) = Path n $ traverse (\(k,a) -> (,) k <$> f k a) xs
+
+-- | The empty path
+empty :: Path k a
+empty = Path 0 []
+
+-- | /O(1)/
+length :: Path k a -> Int
+length (Path n xs) = n
+
+-- | /O(1)/
+null :: Path k a -> Bool
+null (Path n xs) = n == 0
+
+-- | /O(1)/ Invariant: most operations assume that the keys @k@ are globally unique
+cons :: k -> a -> Path k a -> Path k a
+cons k a (Path n xs) = Path (n + 1) $ (k,a):xs
+
+-- | /O(h - k)/ to @keep k@ elements of path of height @h@
+keep :: Int -> Path k a -> Path k a
+keep k p@(Path n xs)
+ | k >= n = p
+ | otherwise = Path k (drop (n - k) xs)
+
+-- | /O(k)/ to @drop k@ elements from a path
+drop :: Int -> Path k a -> Path k a
+drop k p@(Path n xs)
+ | k >= n = empty
+ | otherwise = Path (n - k) (drop k xs)
+
+-- | /O(h)/ Compute the lowest common ancestor
+lca :: Eq k => Path k a -> Path k b -> Path k a
+lca xs ys = case compare nxs nys of
+ LT -> lca' nxs (toList xs) (keep nxs ys)
+ EQ -> lca' nxs (toList xs) (toList ys)
+ GT -> lca' nys (toList (keep nys xs)) (toList ys)
+ where
+ nxs = length xs
+ nys = length ys
+
+-- /O(h)/ @xs `isAncestorOf` ys@ holds when @xs@ is a prefix starting at the root of path @ys@.
+isAncestorOf :: Eq k => Path k a -> Path k b -> Bool
+isAncestorOf xs ys = xs ~= keep (length xs) ys
+
+infix 4 ~=
+-- | /O(1)/ Compare to see if two trees have the same leaf key
+(~=) :: Eq k => Path k a -> Path k b -> Bool
+Path _ [] ~= Path _ [] = True
+Path _ ((i,_):_) ~= Path _ ((j,_):_) = i == j
+_ ~= _ = False
+
+-- * Utilities
+consT :: Int -> Tree k a -> Path k a -> Path k a
+consT w t ts = Cons (w + length ts) w t ts
+
+-- | invariant: both paths have the same number of elements
+lca' :: Eq k => Int -> [(k,a)] -> [(k,b)] -> Path k a
+lca' k xss@((i,_):xs)) yss@((j,_):ys)) =
+ | i == j = xss
+ | otherwise = lca' (k - 1) xs ys
+lca' _ _ _ = empty
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright 2011-2012 Edward Kmett
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
7 Setup.lhs
@@ -0,0 +1,7 @@
+#!/usr/bin/runhaskell
+> module Main (main) where
+
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain
32 lca.cabal
@@ -0,0 +1,32 @@
+name: lca
+category: Data Structures
+version: 0.1
+license: BSD3
+cabal-version: >= 1.6
+license-file: LICENSE
+author: Edward A. Kmett
+maintainer: Edward A. Kmett <ekmett@gmail.com>
+stability: provisional
+homepage: http://github.com/ekmett/lca/
+bug-reports: http://github.com/ekmett/lca/issues
+copyright: Copyright (C) 2011-2012 Edward A. Kmett,
+synopsis: Logarithmic online lowest common ancestor calculation
+description: Logarithmic online lowest common ancestor calculation
+build-type: Simple
+extra-source-files: .travis.yml
+
+source-repository head
+ type: git
+ location: git://github.com/ekmett/lca.git
+
+library
+ other-extensions: CPP
+
+ build-depends:
+ base >= 4 && < 5
+
+ exposed-modules:
+ Data.LCA.Online
+ Data.LCA.Online.Naive
+
+ ghc-options: -Wall
Please sign in to comment.
Something went wrong with that request. Please try again.