module Math.Combinat.Trees.Binary
(
BinTree(..)
, leaf
, BinTree'(..)
, forgetNodeDecorations
, module Data.Tree
, Paren(..)
, parenthesesToString
, stringToParentheses
, forestToNestedParentheses
, forestToBinaryTree
, nestedParenthesesToForest
, nestedParenthesesToForestUnsafe
, nestedParenthesesToBinaryTree
, nestedParenthesesToBinaryTreeUnsafe
, binaryTreeToForest
, binaryTreeToNestedParentheses
, nestedParentheses
, randomNestedParentheses
, nthNestedParentheses
, countNestedParentheses
, fasc4A_algorithm_P
, fasc4A_algorithm_W
, fasc4A_algorithm_U
, binaryTrees
, countBinaryTrees
, binaryTreesNaive
, randomBinaryTree
, fasc4A_algorithm_R
)
where
import Control.Applicative
import Control.Monad
import Control.Monad.ST
import Data.Array
import Data.Array.ST
import Data.List
import Data.Tree (Tree(..),Forest(..))
import Data.Monoid
import Data.Foldable (Foldable(foldMap))
import Data.Traversable (Traversable(traverse))
import System.Random
import Math.Combinat.Helper
import Math.Combinat.Numbers (factorial,binomial)
data BinTree a
= Branch (BinTree a) (BinTree a)
| Leaf a
deriving (Eq,Ord,Show,Read)
leaf :: BinTree ()
leaf = Leaf ()
data BinTree' a b
= Branch' (BinTree' a b) b (BinTree' a b)
| Leaf' a
deriving (Eq,Ord,Show,Read)
forgetNodeDecorations :: BinTree' a b -> BinTree a
forgetNodeDecorations (Branch' left _ right) =
Branch (forgetNodeDecorations left) (forgetNodeDecorations right)
forgetNodeDecorations (Leaf' decor) = Leaf decor
instance Functor BinTree where
fmap f (Branch left right) = Branch (fmap f left) (fmap f right)
fmap f (Leaf x) = Leaf (f x)
instance Foldable BinTree where
foldMap f (Leaf x) = f x
foldMap f (Branch left right) = (foldMap f left) `mappend` (foldMap f right)
instance Traversable BinTree where
traverse f (Leaf x) = Leaf <$> f x
traverse f (Branch left right) = Branch <$> traverse f left <*> traverse f right
data Paren = LeftParen | RightParen deriving (Eq,Ord,Show,Read)
parenToChar :: Paren -> Char
parenToChar LeftParen = '('
parenToChar RightParen = ')'
parenthesesToString :: [Paren] -> String
parenthesesToString = map parenToChar
stringToParentheses :: String -> [Paren]
stringToParentheses [] = []
stringToParentheses (x:xs) = p : stringToParentheses xs where
p = case x of
'(' -> LeftParen
')' -> RightParen
_ -> error "stringToParentheses: invalid character"
forestToNestedParentheses :: Forest a -> [Paren]
forestToNestedParentheses = forest where
forest = concatMap tree
tree (Node _ sf) = LeftParen : forest sf ++ [RightParen]
forestToBinaryTree :: Forest a -> BinTree ()
forestToBinaryTree = forest where
forest = foldr Branch leaf . map tree
tree (Node _ sf) = case sf of
[] -> leaf
_ -> forest sf
nestedParenthesesToForest :: [Paren] -> Maybe (Forest ())
nestedParenthesesToForest ps =
case parseForest ps of
(rest,forest) -> case rest of
[] -> Just forest
_ -> Nothing
where
parseForest :: [Paren] -> ( [Paren] , Forest () )
parseForest ps = unfoldEither parseTree ps
parseTree :: [Paren] -> Either [Paren] ( [Paren] , Tree () )
parseTree orig@(LeftParen:ps) = let (rest,ts) = parseForest ps in case rest of
(RightParen:qs) -> Right (qs, Node () ts)
_ -> Left orig
parseTree qs = Left qs
nestedParenthesesToForestUnsafe :: [Paren] -> Forest ()
nestedParenthesesToForestUnsafe = fromJust . nestedParenthesesToForest
nestedParenthesesToBinaryTree :: [Paren] -> Maybe (BinTree ())
nestedParenthesesToBinaryTree ps =
case parseForest ps of
(rest,forest) -> case rest of
[] -> Just forest
_ -> Nothing
where
parseForest :: [Paren] -> ( [Paren] , BinTree () )
parseForest ps = let (rest,ts) = unfoldEither parseTree ps in (rest , foldr Branch leaf ts)
parseTree :: [Paren] -> Either [Paren] ( [Paren] , BinTree () )
parseTree orig@(LeftParen:ps) = let (rest,ts) = parseForest ps in case rest of
(RightParen:qs) -> Right (qs, ts)
_ -> Left orig
parseTree qs = Left qs
nestedParenthesesToBinaryTreeUnsafe :: [Paren] -> BinTree ()
nestedParenthesesToBinaryTreeUnsafe = fromJust . nestedParenthesesToBinaryTree
binaryTreeToNestedParentheses :: BinTree a -> [Paren]
binaryTreeToNestedParentheses = worker where
worker (Branch l r) = LeftParen : worker l ++ RightParen : worker r
worker (Leaf _) = []
binaryTreeToForest :: BinTree a -> Forest ()
binaryTreeToForest = worker where
worker (Branch l r) = Node () (worker l) : worker r
worker (Leaf _) = []
nestedParentheses :: Int -> [[Paren]]
nestedParentheses = fasc4A_algorithm_P
randomNestedParentheses :: RandomGen g => Int -> g -> ([Paren],g)
randomNestedParentheses = fasc4A_algorithm_W
nthNestedParentheses :: Int -> Integer -> [Paren]
nthNestedParentheses = fasc4A_algorithm_U
countNestedParentheses :: Int -> Integer
countNestedParentheses = countBinaryTrees
fasc4A_algorithm_P :: Int -> [[Paren]]
fasc4A_algorithm_P 0 = []
fasc4A_algorithm_P 1 = [[LeftParen,RightParen]]
fasc4A_algorithm_P n = unfold next ( start , [] ) where
start = concat $ replicate n [RightParen,LeftParen]
next :: ([Paren],[Paren]) -> ( [Paren] , Maybe ([Paren],[Paren]) )
next ( (a:b:ls) , [] ) = next ( ls , b:a:[] )
next ( lls@(l:ls) , rrs@(r:rs) ) = ( visit , new ) where
visit = reverse lls ++ rrs
new =
case l of
RightParen -> Just ( ls , LeftParen:RightParen:rs )
LeftParen ->
findj ( lls , [] ) ( reverse (RightParen:rs) , [] )
findj :: ([Paren],[Paren]) -> ([Paren],[Paren]) -> Maybe ([Paren],[Paren])
findj ( [] , _ ) _ = Nothing
findj ( lls@(l:ls) , rs) ( xs , ys ) =
case l of
LeftParen -> case xs of
(a:_:as) -> findj ( ls, RightParen:rs ) ( as , LeftParen:a:ys )
_ -> findj ( lls, [] ) ( reverse rs ++ xs , ys)
RightParen -> Just ( reverse ys ++ xs ++ reverse (LeftParen:rs) ++ ls , [] )
fasc4A_algorithm_W :: RandomGen g => Int -> g -> ([Paren],g)
fasc4A_algorithm_W n' rnd = worker (rnd,n,n,[]) where
n = fromIntegral n' :: Integer
worker :: RandomGen g => (g,Integer,Integer,[Paren]) -> ([Paren],g)
worker (rnd,_,0,parens) = (parens,rnd)
worker (rnd,p,q,parens) =
if x<(q+1)*(qp)
then worker (rnd' , p , q1 , LeftParen :parens)
else worker (rnd' , p1 , q , RightParen:parens)
where
(x,rnd') = randomR ( 0 , (q+p)*(qp+1)1 ) rnd
fasc4A_algorithm_U
:: Int
-> Integer
-> [Paren]
fasc4A_algorithm_U n' bign0 = reverse $ worker (bign0,c0,n,n,[]) where
n = fromIntegral n' :: Integer
c0 = foldl f 1 [2..n]
f c p = ((4*p2)*c) `div` (p+1)
worker :: (Integer,Integer,Integer,Integer,[Paren]) -> [Paren]
worker (_ ,_,_,0,parens) = parens
worker (bign,c,p,q,parens) =
if bign <= c'
then worker (bign , c' , p , q1 , RightParen:parens)
else worker (bignc' , cc' , p1 , q , LeftParen :parens)
where
c' = ((q+1)*(qp)*c) `div` ((q+p)*(qp+1))
binaryTrees :: Int -> [BinTree ()]
binaryTrees = binaryTreesNaive
countBinaryTrees :: Int -> Integer
countBinaryTrees n = binomial (2*n) n `div` (1 + fromIntegral n)
binaryTreesNaive :: Int -> [BinTree ()]
binaryTreesNaive 0 = [ leaf ]
binaryTreesNaive n =
[ Branch l r
| i <- [0..n1]
, l <- binaryTreesNaive i
, r <- binaryTreesNaive (n1i)
]
randomBinaryTree :: RandomGen g => Int -> g -> (BinTree (), g)
randomBinaryTree n rnd = (tree,rnd') where
(decorated,rnd') = fasc4A_algorithm_R n rnd
tree = fmap (const ()) $ forgetNodeDecorations decorated
fasc4A_algorithm_R :: RandomGen g => Int -> g -> (BinTree' Int Int, g)
fasc4A_algorithm_R n0 rnd = res where
res = runST $ do
ar <- newArray (0,2*n0) 0
rnd' <- worker rnd 1 ar
links <- unsafeFreeze ar
return (toTree links, rnd')
toTree links = f (links!0) where
f i = if odd i
then Branch' (f $ links!i) i (f $ links!(i+1))
else Leaf' i
worker :: RandomGen g => g -> Int -> STUArray s Int Int -> ST s g
worker rnd n ar = do
if n > n0
then return rnd
else do
writeArray ar (n2b) n2
lk <- readArray ar k
writeArray ar (n21+b) lk
writeArray ar k (n21)
worker rnd' (n+1) ar
where
n2 = n+n
(x,rnd') = randomR (0,4*n3) rnd
(k,b) = x `divMod` 2