module Math.Combinat.Trees
(
BinTree(..)
, leaf
, module Data.Tree
, Paren(..)
, parenthesesToString
, stringToParentheses
, forestToNestedParentheses
, forestToBinaryTree
, nestedParenthesesToForest
, nestedParenthesesToForestUnsafe
, nestedParenthesesToBinaryTree
, nestedParenthesesToBinaryTreeUnsafe
, binaryTreeToForest
, binaryTreeToNestedParentheses
, nestedParentheses
, fasc4A_algorithm_P
, binaryTrees
, countBinaryTrees
, binaryTreesNaive
)
where
import Data.List
import Data.Tree (Tree(..),Forest(..))
import Math.Combinat.Helper
data BinTree a
= Branch (BinTree a) (BinTree a)
| Leaf a
deriving (Eq,Ord,Show,Read)
leaf :: BinTree ()
leaf = Leaf ()
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
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 , [] )
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)
]
data Ctx a
= Top
| L (Ctx a) (BinTree a)
| R (BinTree a) (Ctx a)
type Loc a = (BinTree a, Ctx a)
left :: Loc a -> Loc a
left (Branch l r , c) = (l , L c r)
left (Leaf _ , _) = error "left: Leaf"
right :: Loc a -> Loc a
right (Branch l r , c) = (r , R l c)
right (Leaf _ , _) = error "right: Leaf"
top :: BinTree a -> Loc a
top t = (t, Top)
up :: Loc a -> Loc a
up (t, L c r) = (Branch t r, c)
up (t, R l c) = (Branch l t, c)
up (t, Top ) = error "up: top"
upmost :: Loc a -> Loc a
upmost l@(t, Top) = l
upmost l = upmost (up l)
modify :: (BinTree a -> BinTree a) -> Loc a -> Loc a
modify f (t, c) = (f t, c)