module Math.Combinat.Trees
(
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.Monad
import Control.Monad.ST
import Data.Array
import Data.Array.ST
import Data.List
import Data.Tree (Tree(..),Forest(..))
import System.Random
import Math.Combinat.Helper
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)
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