{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.LCA.Online.Naive
-- Copyright   :  (C) 2011-2015 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
  , uncons
  , view
  , null
  , length
  , isAncestorOf
  , lca
  , keep
  , drop
  , traverseWithKey
  , toList
  , fromList
  , (~=)
  ) where

import Control.Applicative hiding (empty)
import qualified Data.Foldable as F
import Data.LCA.View

#if __GLASGOW_HASKELL__ < 710
import Data.Traversable
#endif

import qualified Prelude
import Prelude hiding
  ( drop
  , length
  , null
  )

-- $setup
-- >>> let length = Data.LCA.Online.Naive.length

-- | An uncompressed 'Path' with memoized length.
data Path a = Path {-# UNPACK #-} !Int [(Int,a)]
  deriving (Int -> Path a -> ShowS
[Path a] -> ShowS
Path a -> String
(Int -> Path a -> ShowS)
-> (Path a -> String) -> ([Path a] -> ShowS) -> Show (Path a)
forall a. Show a => Int -> Path a -> ShowS
forall a. Show a => [Path a] -> ShowS
forall a. Show a => Path a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Path a] -> ShowS
$cshowList :: forall a. Show a => [Path a] -> ShowS
show :: Path a -> String
$cshow :: forall a. Show a => Path a -> String
showsPrec :: Int -> Path a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Path a -> ShowS
Show, ReadPrec [Path a]
ReadPrec (Path a)
Int -> ReadS (Path a)
ReadS [Path a]
(Int -> ReadS (Path a))
-> ReadS [Path a]
-> ReadPrec (Path a)
-> ReadPrec [Path a]
-> Read (Path a)
forall a. Read a => ReadPrec [Path a]
forall a. Read a => ReadPrec (Path a)
forall a. Read a => Int -> ReadS (Path a)
forall a. Read a => ReadS [Path a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Path a]
$creadListPrec :: forall a. Read a => ReadPrec [Path a]
readPrec :: ReadPrec (Path a)
$creadPrec :: forall a. Read a => ReadPrec (Path a)
readList :: ReadS [Path a]
$creadList :: forall a. Read a => ReadS [Path a]
readsPrec :: Int -> ReadS (Path a)
$creadsPrec :: forall a. Read a => Int -> ReadS (Path a)
Read)

-- | Convert a 'Path' to a list of @(ID, value)@ pairs.
toList :: Path a -> [(Int,a)]
toList :: Path a -> [(Int, a)]
toList (Path Int
_ [(Int, a)]
xs) = [(Int, a)]
xs
{-# INLINE toList #-}

-- | Build a 'Path' from a list of @(ID, value)@ pairs.
fromList :: [(Int,a)] -> Path a
fromList :: [(Int, a)] -> Path a
fromList [(Int, a)]
xs = Int -> [(Int, a)] -> Path a
forall a. Int -> [(Int, a)] -> Path a
Path ([(Int, a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [(Int, a)]
xs) [(Int, a)]
xs
{-# INLINE fromList #-}

instance Functor Path where
  fmap :: (a -> b) -> Path a -> Path b
fmap a -> b
f (Path Int
n [(Int, a)]
xs) = Int -> [(Int, b)] -> Path b
forall a. Int -> [(Int, a)] -> Path a
Path Int
n [ (Int
k, a -> b
f a
a) | (Int
k,a
a) <- [(Int, a)]
xs]

instance F.Foldable Path where
  foldMap :: (a -> m) -> Path a -> m
foldMap a -> m
f (Path Int
_ [(Int, a)]
xs) = ((Int, a) -> m) -> [(Int, a)] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap (a -> m
f (a -> m) -> ((Int, a) -> a) -> (Int, a) -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, a) -> a
forall a b. (a, b) -> b
snd) [(Int, a)]
xs
#if __GLASGOW_HASKELL__ >= 710
  length :: Path a -> Int
length = Path a -> Int
forall a. Path a -> Int
length
  null :: Path a -> Bool
null   = Path a -> Bool
forall a. Path a -> Bool
null
#endif

-- | /O(1)/ Determine the length of a 'Path'.
length :: Path a -> Int
length :: Path a -> Int
length (Path Int
n [(Int, a)]
_) = Int
n
{-# INLINE length #-}

-- | /O(1)/ Returns 'True' iff the 'Path' is 'empty'.
null :: Path a -> Bool
null :: Path a -> Bool
null (Path Int
n [(Int, a)]
_) = Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
{-# INLINE null #-}

instance Traversable Path where
  traverse :: (a -> f b) -> Path a -> f (Path b)
traverse a -> f b
f (Path Int
n [(Int, a)]
xs) = Int -> [(Int, b)] -> Path b
forall a. Int -> [(Int, a)] -> Path a
Path Int
n ([(Int, b)] -> Path b) -> f [(Int, b)] -> f (Path b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Int, a) -> f (Int, b)) -> [(Int, a)] -> f [(Int, b)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Int
k,a
a) -> (,) Int
k (b -> (Int, b)) -> f b -> f (Int, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a) [(Int, a)]
xs

-- | Traverse a 'Path' with access to the node IDs.
traverseWithKey :: Applicative f => (Int -> a -> f b) -> Path a -> f (Path b)
traverseWithKey :: (Int -> a -> f b) -> Path a -> f (Path b)
traverseWithKey Int -> a -> f b
f (Path Int
n [(Int, a)]
xs) = Int -> [(Int, b)] -> Path b
forall a. Int -> [(Int, a)] -> Path a
Path Int
n ([(Int, b)] -> Path b) -> f [(Int, b)] -> f (Path b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Int, a) -> f (Int, b)) -> [(Int, a)] -> f [(Int, b)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Int
k,a
a) -> (,) Int
k (b -> (Int, b)) -> f b -> f (Int, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> a -> f b
f Int
k a
a) [(Int, a)]
xs
{-# INLINE traverseWithKey #-}

-- | The empty 'Path'
empty :: Path a
empty :: Path a
empty = Int -> [(Int, a)] -> Path a
forall a. Int -> [(Int, a)] -> Path a
Path Int
0 []

-- | /O(1)/ Invariant: most operations assume that the keys @k@ are globally unique
--
-- Extend the path with a new node ID and value.
cons :: Int -> a -> Path a -> Path a
cons :: Int -> a -> Path a -> Path a
cons Int
k a
a (Path Int
n [(Int, a)]
xs) = Int -> [(Int, a)] -> Path a
forall a. Int -> [(Int, a)] -> Path a
Path (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ([(Int, a)] -> Path a) -> [(Int, a)] -> Path a
forall a b. (a -> b) -> a -> b
$ (Int
k,a
a)(Int, a) -> [(Int, a)] -> [(Int, a)]
forall a. a -> [a] -> [a]
:[(Int, a)]
xs
{-# INLINE cons #-}

-- | /O(1)/ Extract the node ID and value from the newest node on the 'Path'.
uncons :: Path a -> Maybe (Int, a, Path a)
uncons :: Path a -> Maybe (Int, a, Path a)
uncons (Path Int
_ []) = Maybe (Int, a, Path a)
forall a. Maybe a
Nothing
uncons (Path Int
n ((Int
k,a
a):[(Int, a)]
xs)) = (Int, a, Path a) -> Maybe (Int, a, Path a)
forall a. a -> Maybe a
Just (Int
k,a
a,Int -> [(Int, a)] -> Path a
forall a. Int -> [(Int, a)] -> Path a
Path (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [(Int, a)]
xs)
{-# INLINE uncons #-}

-- | /O(1)/ Extract the node ID and value from the newest node on the 'Path', slightly faster than 'uncons'.
view :: Path a -> View Path a
view :: Path a -> View Path a
view (Path Int
_ []) = View Path a
forall (f :: * -> *) a. View f a
Root
view (Path Int
n ((Int
k,a
a):[(Int, a)]
xs)) = Int -> a -> Path a -> View Path a
forall (f :: * -> *) a. Int -> a -> f a -> View f a
Node Int
k a
a (Int -> [(Int, a)] -> Path a
forall a. Int -> [(Int, a)] -> Path a
Path (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [(Int, a)]
xs)
{-# INLINE view #-}

-- | /O(h - k)/ to @'keep' k@ elements of 'Path' of 'length' @h@
keep :: Int -> Path a -> Path a
keep :: Int -> Path a -> Path a
keep Int
k p :: Path a
p@(Path Int
n [(Int, a)]
xs)
  | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n    = Path a
p
  | Bool
otherwise = Int -> [(Int, a)] -> Path a
forall a. Int -> [(Int, a)] -> Path a
Path Int
k ([(Int, a)] -> Path a) -> [(Int, a)] -> Path a
forall a b. (a -> b) -> a -> b
$ Int -> [(Int, a)] -> [(Int, a)]
forall a. Int -> [a] -> [a]
Prelude.drop (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k) [(Int, a)]
xs
{-# INLINE keep #-}

-- | /O(k)/ to @'drop' k@ elements from a 'Path'
drop :: Int -> Path a -> Path a
drop :: Int -> Path a -> Path a
drop Int
k (Path Int
n [(Int, a)]
xs)
  | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n    = Path a
forall a. Path a
empty
  | Bool
otherwise = Int -> [(Int, a)] -> Path a
forall a. Int -> [(Int, a)] -> Path a
Path (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k) (Int -> [(Int, a)] -> [(Int, a)]
forall a. Int -> [a] -> [a]
Prelude.drop Int
k [(Int, a)]
xs)
{-# INLINE drop #-}

-- | /O(h)/ @xs `isAncestorOf` ys@ holds when @xs@ is a prefix starting at the root of 'Path' @ys@.
isAncestorOf :: Path a -> Path b -> Bool
isAncestorOf :: Path a -> Path b -> Bool
isAncestorOf Path a
xs Path b
ys = Path a
xs Path a -> Path b -> Bool
forall a b. Path a -> Path b -> Bool
~= Int -> Path b -> Path b
forall a. Int -> Path a -> Path a
keep (Path a -> Int
forall a. Path a -> Int
length Path a
xs) Path b
ys
{-# INLINE isAncestorOf #-}

infix 4 ~=
-- | /O(1)/ Compare to see if two trees have the same root key
(~=) :: Path a -> Path b -> Bool
Path Int
_ []        ~= :: Path a -> Path b -> Bool
~= Path Int
_ []        = Bool
True
Path Int
_ ((Int
i,a
_):[(Int, a)]
_) ~= Path Int
_ ((Int
j,b
_):[(Int, b)]
_) = Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j
Path a
_                ~= Path b
_                = Bool
False
{-# INLINE (~=) #-}

-- | /O(h)/ Compute the lowest common ancestor of two paths
--
-- >>> let fromList' = fromList . map (flip (,) ())
-- >>> length (lca (fromList' [1, 2, 3, 4, 5, 6]) (fromList' [7, 8, 3, 4, 5, 6]))
-- 4
lca :: Path a -> Path b -> Path a
lca :: Path a -> Path b -> Path a
lca Path a
xs0 Path b
ys0 = case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
nxs Int
nys of
    Ordering
LT -> Int -> [(Int, a)] -> [(Int, b)] -> Path a
forall a b. Int -> [(Int, a)] -> [(Int, b)] -> Path a
go Int
nxs (Path a -> [(Int, a)]
forall a. Path a -> [(Int, a)]
toList Path a
xs0) (Path b -> [(Int, b)]
forall a. Path a -> [(Int, a)]
toList (Int -> Path b -> Path b
forall a. Int -> Path a -> Path a
keep Int
nxs Path b
ys0))
    Ordering
EQ -> Int -> [(Int, a)] -> [(Int, b)] -> Path a
forall a b. Int -> [(Int, a)] -> [(Int, b)] -> Path a
go Int
nxs (Path a -> [(Int, a)]
forall a. Path a -> [(Int, a)]
toList Path a
xs0) (Path b -> [(Int, b)]
forall a. Path a -> [(Int, a)]
toList Path b
ys0)
    Ordering
GT -> Int -> [(Int, a)] -> [(Int, b)] -> Path a
forall a b. Int -> [(Int, a)] -> [(Int, b)] -> Path a
go Int
nys (Path a -> [(Int, a)]
forall a. Path a -> [(Int, a)]
toList (Int -> Path a -> Path a
forall a. Int -> Path a -> Path a
keep Int
nys Path a
xs0)) (Path b -> [(Int, b)]
forall a. Path a -> [(Int, a)]
toList Path b
ys0)
  where
    nxs :: Int
nxs = Path a -> Int
forall a. Path a -> Int
length Path a
xs0
    nys :: Int
nys = Path b -> Int
forall a. Path a -> Int
length Path b
ys0
    go :: Int -> [(Int, a)] -> [(Int, b)] -> Path a
go Int
k xss :: [(Int, a)]
xss@((Int
i,a
_):[(Int, a)]
xs) ((Int
j,b
_):[(Int, b)]
ys)
      | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j    = Int -> [(Int, a)] -> Path a
forall a. Int -> [(Int, a)] -> Path a
Path Int
k [(Int, a)]
xss
      | Bool
otherwise = Int -> [(Int, a)] -> [(Int, b)] -> Path a
go (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [(Int, a)]
xs [(Int, b)]
ys
    go Int
_ [(Int, a)]
_ [(Int, b)]
_ = Path a
forall a. Path a
empty
{-# INLINE lca #-}