-- | Binary trees, forests, etc. See:
--   Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 4A.
--
-- For example, here are all the binary trees on 4 nodes:
--
-- <<svg/bintrees.svg>>
--

{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
module Math.Combinat.Trees.Binary 
  ( -- * Types
    BinTree(..)
  , leaf 
  , graft
  , BinTree'(..)
  , forgetNodeDecorations
  , Paren(..)
  , parenthesesToString
  , stringToParentheses  
  , numberOfNodes
  , numberOfLeaves
    -- * Conversion to rose trees (@Data.Tree@)
  , toRoseTree , toRoseTree'
  , module Data.Tree 
    -- * Enumerate leaves
  , enumerateLeaves_ 
  , enumerateLeaves 
  , enumerateLeaves'
    -- * Nested parentheses
  , nestedParentheses 
  , randomNestedParentheses
  , nthNestedParentheses
  , countNestedParentheses
  , fasc4A_algorithm_P
  , fasc4A_algorithm_W
  , fasc4A_algorithm_U
    -- * Generating binary trees
  , binaryTrees
  , countBinaryTrees
  , binaryTreesNaive
  , randomBinaryTree
  , fasc4A_algorithm_R
    -- * ASCII drawing
  , asciiBinaryTree_
    -- * Graphviz drawing
  , Dot
  , graphvizDotBinTree
  , graphvizDotBinTree'
  , graphvizDotForest
  , graphvizDotTree  
    -- * Bijections
  , forestToNestedParentheses
  , forestToBinaryTree
  , nestedParenthesesToForest
  , nestedParenthesesToForestUnsafe
  , nestedParenthesesToBinaryTree
  , nestedParenthesesToBinaryTreeUnsafe
  , binaryTreeToForest
  , binaryTreeToNestedParentheses
  ) 
  where

--------------------------------------------------------------------------------

import Control.Applicative
import Control.Monad
import Control.Monad.ST

import Data.Array
import Data.Array.ST
import Data.Array.Unsafe

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.Numbers (factorial,binomial)

import Math.Combinat.Trees.Graphviz 
  ( Dot 
  , graphvizDotBinTree , graphvizDotBinTree' 
  , graphvizDotForest  , graphvizDotTree 
  )
import Math.Combinat.Classes
import Math.Combinat.Helper
import Math.Combinat.ASCII as ASCII

--------------------------------------------------------------------------------
-- * Types

-- | A binary tree with leaves decorated with type @a@.
data BinTree a
  = Branch (BinTree a) (BinTree a)
  | Leaf a
  deriving (BinTree a -> BinTree a -> Bool
(BinTree a -> BinTree a -> Bool)
-> (BinTree a -> BinTree a -> Bool) -> Eq (BinTree a)
forall a. Eq a => BinTree a -> BinTree a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BinTree a -> BinTree a -> Bool
$c/= :: forall a. Eq a => BinTree a -> BinTree a -> Bool
== :: BinTree a -> BinTree a -> Bool
$c== :: forall a. Eq a => BinTree a -> BinTree a -> Bool
Eq,Eq (BinTree a)
Eq (BinTree a)
-> (BinTree a -> BinTree a -> Ordering)
-> (BinTree a -> BinTree a -> Bool)
-> (BinTree a -> BinTree a -> Bool)
-> (BinTree a -> BinTree a -> Bool)
-> (BinTree a -> BinTree a -> Bool)
-> (BinTree a -> BinTree a -> BinTree a)
-> (BinTree a -> BinTree a -> BinTree a)
-> Ord (BinTree a)
BinTree a -> BinTree a -> Bool
BinTree a -> BinTree a -> Ordering
BinTree a -> BinTree a -> BinTree a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (BinTree a)
forall a. Ord a => BinTree a -> BinTree a -> Bool
forall a. Ord a => BinTree a -> BinTree a -> Ordering
forall a. Ord a => BinTree a -> BinTree a -> BinTree a
min :: BinTree a -> BinTree a -> BinTree a
$cmin :: forall a. Ord a => BinTree a -> BinTree a -> BinTree a
max :: BinTree a -> BinTree a -> BinTree a
$cmax :: forall a. Ord a => BinTree a -> BinTree a -> BinTree a
>= :: BinTree a -> BinTree a -> Bool
$c>= :: forall a. Ord a => BinTree a -> BinTree a -> Bool
> :: BinTree a -> BinTree a -> Bool
$c> :: forall a. Ord a => BinTree a -> BinTree a -> Bool
<= :: BinTree a -> BinTree a -> Bool
$c<= :: forall a. Ord a => BinTree a -> BinTree a -> Bool
< :: BinTree a -> BinTree a -> Bool
$c< :: forall a. Ord a => BinTree a -> BinTree a -> Bool
compare :: BinTree a -> BinTree a -> Ordering
$ccompare :: forall a. Ord a => BinTree a -> BinTree a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (BinTree a)
Ord,Int -> BinTree a -> ShowS
[BinTree a] -> ShowS
BinTree a -> String
(Int -> BinTree a -> ShowS)
-> (BinTree a -> String)
-> ([BinTree a] -> ShowS)
-> Show (BinTree a)
forall a. Show a => Int -> BinTree a -> ShowS
forall a. Show a => [BinTree a] -> ShowS
forall a. Show a => BinTree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BinTree a] -> ShowS
$cshowList :: forall a. Show a => [BinTree a] -> ShowS
show :: BinTree a -> String
$cshow :: forall a. Show a => BinTree a -> String
showsPrec :: Int -> BinTree a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> BinTree a -> ShowS
Show,ReadPrec [BinTree a]
ReadPrec (BinTree a)
Int -> ReadS (BinTree a)
ReadS [BinTree a]
(Int -> ReadS (BinTree a))
-> ReadS [BinTree a]
-> ReadPrec (BinTree a)
-> ReadPrec [BinTree a]
-> Read (BinTree a)
forall a. Read a => ReadPrec [BinTree a]
forall a. Read a => ReadPrec (BinTree a)
forall a. Read a => Int -> ReadS (BinTree a)
forall a. Read a => ReadS [BinTree a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BinTree a]
$creadListPrec :: forall a. Read a => ReadPrec [BinTree a]
readPrec :: ReadPrec (BinTree a)
$creadPrec :: forall a. Read a => ReadPrec (BinTree a)
readList :: ReadS [BinTree a]
$creadList :: forall a. Read a => ReadS [BinTree a]
readsPrec :: Int -> ReadS (BinTree a)
$creadsPrec :: forall a. Read a => Int -> ReadS (BinTree a)
Read)

leaf :: BinTree ()
leaf :: BinTree ()
leaf = () -> BinTree ()
forall a. a -> BinTree a
Leaf ()

-- | The monadic join operation of binary trees
graft :: BinTree (BinTree a) -> BinTree a
graft :: BinTree (BinTree a) -> BinTree a
graft = BinTree (BinTree a) -> BinTree a
forall a. BinTree (BinTree a) -> BinTree a
go where
  go :: BinTree (BinTree a) -> BinTree a
go (Branch BinTree (BinTree a)
l BinTree (BinTree a)
r) = BinTree a -> BinTree a -> BinTree a
forall a. BinTree a -> BinTree a -> BinTree a
Branch (BinTree (BinTree a) -> BinTree a
go BinTree (BinTree a)
l) (BinTree (BinTree a) -> BinTree a
go BinTree (BinTree a)
r)
  go (Leaf   BinTree a
t  ) = BinTree a
t 

--------------------------------------------------------------------------------

-- | A binary tree with leaves and internal nodes decorated 
-- with types @a@ and @b@, respectively.
data BinTree' a b
  = Branch' (BinTree' a b) b (BinTree' a b)
  | Leaf' a
  deriving (BinTree' a b -> BinTree' a b -> Bool
(BinTree' a b -> BinTree' a b -> Bool)
-> (BinTree' a b -> BinTree' a b -> Bool) -> Eq (BinTree' a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b. (Eq b, Eq a) => BinTree' a b -> BinTree' a b -> Bool
/= :: BinTree' a b -> BinTree' a b -> Bool
$c/= :: forall a b. (Eq b, Eq a) => BinTree' a b -> BinTree' a b -> Bool
== :: BinTree' a b -> BinTree' a b -> Bool
$c== :: forall a b. (Eq b, Eq a) => BinTree' a b -> BinTree' a b -> Bool
Eq,Eq (BinTree' a b)
Eq (BinTree' a b)
-> (BinTree' a b -> BinTree' a b -> Ordering)
-> (BinTree' a b -> BinTree' a b -> Bool)
-> (BinTree' a b -> BinTree' a b -> Bool)
-> (BinTree' a b -> BinTree' a b -> Bool)
-> (BinTree' a b -> BinTree' a b -> Bool)
-> (BinTree' a b -> BinTree' a b -> BinTree' a b)
-> (BinTree' a b -> BinTree' a b -> BinTree' a b)
-> Ord (BinTree' a b)
BinTree' a b -> BinTree' a b -> Bool
BinTree' a b -> BinTree' a b -> Ordering
BinTree' a b -> BinTree' a b -> BinTree' a b
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a b. (Ord b, Ord a) => Eq (BinTree' a b)
forall a b. (Ord b, Ord a) => BinTree' a b -> BinTree' a b -> Bool
forall a b.
(Ord b, Ord a) =>
BinTree' a b -> BinTree' a b -> Ordering
forall a b.
(Ord b, Ord a) =>
BinTree' a b -> BinTree' a b -> BinTree' a b
min :: BinTree' a b -> BinTree' a b -> BinTree' a b
$cmin :: forall a b.
(Ord b, Ord a) =>
BinTree' a b -> BinTree' a b -> BinTree' a b
max :: BinTree' a b -> BinTree' a b -> BinTree' a b
$cmax :: forall a b.
(Ord b, Ord a) =>
BinTree' a b -> BinTree' a b -> BinTree' a b
>= :: BinTree' a b -> BinTree' a b -> Bool
$c>= :: forall a b. (Ord b, Ord a) => BinTree' a b -> BinTree' a b -> Bool
> :: BinTree' a b -> BinTree' a b -> Bool
$c> :: forall a b. (Ord b, Ord a) => BinTree' a b -> BinTree' a b -> Bool
<= :: BinTree' a b -> BinTree' a b -> Bool
$c<= :: forall a b. (Ord b, Ord a) => BinTree' a b -> BinTree' a b -> Bool
< :: BinTree' a b -> BinTree' a b -> Bool
$c< :: forall a b. (Ord b, Ord a) => BinTree' a b -> BinTree' a b -> Bool
compare :: BinTree' a b -> BinTree' a b -> Ordering
$ccompare :: forall a b.
(Ord b, Ord a) =>
BinTree' a b -> BinTree' a b -> Ordering
$cp1Ord :: forall a b. (Ord b, Ord a) => Eq (BinTree' a b)
Ord,Int -> BinTree' a b -> ShowS
[BinTree' a b] -> ShowS
BinTree' a b -> String
(Int -> BinTree' a b -> ShowS)
-> (BinTree' a b -> String)
-> ([BinTree' a b] -> ShowS)
-> Show (BinTree' a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show b, Show a) => Int -> BinTree' a b -> ShowS
forall a b. (Show b, Show a) => [BinTree' a b] -> ShowS
forall a b. (Show b, Show a) => BinTree' a b -> String
showList :: [BinTree' a b] -> ShowS
$cshowList :: forall a b. (Show b, Show a) => [BinTree' a b] -> ShowS
show :: BinTree' a b -> String
$cshow :: forall a b. (Show b, Show a) => BinTree' a b -> String
showsPrec :: Int -> BinTree' a b -> ShowS
$cshowsPrec :: forall a b. (Show b, Show a) => Int -> BinTree' a b -> ShowS
Show,ReadPrec [BinTree' a b]
ReadPrec (BinTree' a b)
Int -> ReadS (BinTree' a b)
ReadS [BinTree' a b]
(Int -> ReadS (BinTree' a b))
-> ReadS [BinTree' a b]
-> ReadPrec (BinTree' a b)
-> ReadPrec [BinTree' a b]
-> Read (BinTree' a b)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall a b. (Read b, Read a) => ReadPrec [BinTree' a b]
forall a b. (Read b, Read a) => ReadPrec (BinTree' a b)
forall a b. (Read b, Read a) => Int -> ReadS (BinTree' a b)
forall a b. (Read b, Read a) => ReadS [BinTree' a b]
readListPrec :: ReadPrec [BinTree' a b]
$creadListPrec :: forall a b. (Read b, Read a) => ReadPrec [BinTree' a b]
readPrec :: ReadPrec (BinTree' a b)
$creadPrec :: forall a b. (Read b, Read a) => ReadPrec (BinTree' a b)
readList :: ReadS [BinTree' a b]
$creadList :: forall a b. (Read b, Read a) => ReadS [BinTree' a b]
readsPrec :: Int -> ReadS (BinTree' a b)
$creadsPrec :: forall a b. (Read b, Read a) => Int -> ReadS (BinTree' a b)
Read)

forgetNodeDecorations :: BinTree' a b -> BinTree a
forgetNodeDecorations :: BinTree' a b -> BinTree a
forgetNodeDecorations = BinTree' a b -> BinTree a
forall a b. BinTree' a b -> BinTree a
go where
  go :: BinTree' a b -> BinTree a
go (Branch' BinTree' a b
left b
_ BinTree' a b
right) = BinTree a -> BinTree a -> BinTree a
forall a. BinTree a -> BinTree a -> BinTree a
Branch (BinTree' a b -> BinTree a
go BinTree' a b
left) (BinTree' a b -> BinTree a
go BinTree' a b
right)
  go (Leaf'   a
decor       ) = a -> BinTree a
forall a. a -> BinTree a
Leaf a
decor 

--------------------------------------------------------------------------------

instance HasNumberOfNodes (BinTree a) where
  numberOfNodes :: BinTree a -> Int
numberOfNodes = BinTree a -> Int
forall p a. Num p => BinTree a -> p
go where
    go :: BinTree a -> p
go (Leaf   a
_  ) = p
0
    go (Branch BinTree a
l BinTree a
r) = BinTree a -> p
go BinTree a
l p -> p -> p
forall a. Num a => a -> a -> a
+ BinTree a -> p
go BinTree a
r p -> p -> p
forall a. Num a => a -> a -> a
+ p
1

instance HasNumberOfLeaves (BinTree a) where
  numberOfLeaves :: BinTree a -> Int
numberOfLeaves = BinTree a -> Int
forall p a. Num p => BinTree a -> p
go where
    go :: BinTree a -> p
go (Leaf   a
_  ) = p
1
    go (Branch BinTree a
l BinTree a
r) = BinTree a -> p
go BinTree a
l p -> p -> p
forall a. Num a => a -> a -> a
+ BinTree a -> p
go BinTree a
r 


instance HasNumberOfNodes (BinTree' a b) where
  numberOfNodes :: BinTree' a b -> Int
numberOfNodes = BinTree' a b -> Int
forall p a b. Num p => BinTree' a b -> p
go where
    go :: BinTree' a b -> p
go (Leaf'   a
_    ) = p
0
    go (Branch' BinTree' a b
l b
_ BinTree' a b
r) = BinTree' a b -> p
go BinTree' a b
l p -> p -> p
forall a. Num a => a -> a -> a
+ BinTree' a b -> p
go BinTree' a b
r p -> p -> p
forall a. Num a => a -> a -> a
+ p
1

instance HasNumberOfLeaves (BinTree' a b) where
  numberOfLeaves :: BinTree' a b -> Int
numberOfLeaves = BinTree' a b -> Int
forall p a b. Num p => BinTree' a b -> p
go where
    go :: BinTree' a b -> p
go (Leaf'   a
_    ) = p
1
    go (Branch' BinTree' a b
l b
_ BinTree' a b
r) = BinTree' a b -> p
go BinTree' a b
l p -> p -> p
forall a. Num a => a -> a -> a
+ BinTree' a b -> p
go BinTree' a b
r 

--------------------------------------------------------------------------------
-- * Enumerate leaves

-- | Enumerates the leaves a tree, starting from 0, ignoring old labels
enumerateLeaves_ :: BinTree a -> BinTree Int
enumerateLeaves_ :: BinTree a -> BinTree Int
enumerateLeaves_ = (Int, BinTree Int) -> BinTree Int
forall a b. (a, b) -> b
snd ((Int, BinTree Int) -> BinTree Int)
-> (BinTree a -> (Int, BinTree Int)) -> BinTree a -> BinTree Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> BinTree a -> (Int, BinTree Int)
forall a a. Num a => a -> BinTree a -> (a, BinTree a)
go Int
0 where
  go :: a -> BinTree a -> (a, BinTree a)
go !a
k BinTree a
t = case BinTree a
t of
    Leaf   a
_   -> (a
ka -> a -> a
forall a. Num a => a -> a -> a
+a
1 , a -> BinTree a
forall a. a -> BinTree a
Leaf a
k)
    Branch BinTree a
l BinTree a
r -> (a
k'', BinTree a -> BinTree a -> BinTree a
forall a. BinTree a -> BinTree a -> BinTree a
Branch BinTree a
l' BinTree a
r')  where
                    (a
k' ,BinTree a
l') = a -> BinTree a -> (a, BinTree a)
go a
k  BinTree a
l
                    (a
k'',BinTree a
r') = a -> BinTree a -> (a, BinTree a)
go a
k' BinTree a
r

-- | Enumerates the leaves a tree, starting from zero, and also returns the number of leaves
enumerateLeaves' :: BinTree a -> (Int, BinTree (a,Int))
enumerateLeaves' :: BinTree a -> (Int, BinTree (a, Int))
enumerateLeaves' = Int -> BinTree a -> (Int, BinTree (a, Int))
forall a a. Num a => a -> BinTree a -> (a, BinTree (a, a))
go Int
0 where
  go :: a -> BinTree a -> (a, BinTree (a, a))
go !a
k BinTree a
t = case BinTree a
t of
    Leaf   a
y   -> (a
ka -> a -> a
forall a. Num a => a -> a -> a
+a
1 , (a, a) -> BinTree (a, a)
forall a. a -> BinTree a
Leaf (a
y,a
k))
    Branch BinTree a
l BinTree a
r -> (a
k'', BinTree (a, a) -> BinTree (a, a) -> BinTree (a, a)
forall a. BinTree a -> BinTree a -> BinTree a
Branch BinTree (a, a)
l' BinTree (a, a)
r')  where
                    (a
k' ,BinTree (a, a)
l') = a -> BinTree a -> (a, BinTree (a, a))
go a
k  BinTree a
l
                    (a
k'',BinTree (a, a)
r') = a -> BinTree a -> (a, BinTree (a, a))
go a
k' BinTree a
r

-- | Enumerates the leaves a tree, starting from zero
enumerateLeaves :: BinTree a -> BinTree (a,Int)
enumerateLeaves :: BinTree a -> BinTree (a, Int)
enumerateLeaves = (Int, BinTree (a, Int)) -> BinTree (a, Int)
forall a b. (a, b) -> b
snd ((Int, BinTree (a, Int)) -> BinTree (a, Int))
-> (BinTree a -> (Int, BinTree (a, Int)))
-> BinTree a
-> BinTree (a, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinTree a -> (Int, BinTree (a, Int))
forall a. BinTree a -> (Int, BinTree (a, Int))
enumerateLeaves'

--------------------------------------------------------------------------------
-- * conversion to 'Data.Tree'

-- | Convert a binary tree to a rose tree (from "Data.Tree")
toRoseTree :: BinTree a -> Tree (Maybe a)
toRoseTree :: BinTree a -> Tree (Maybe a)
toRoseTree = BinTree a -> Tree (Maybe a)
forall a. BinTree a -> Tree (Maybe a)
go where
  go :: BinTree a -> Tree (Maybe a)
go (Branch BinTree a
t1 BinTree a
t2) = Maybe a -> Forest (Maybe a) -> Tree (Maybe a)
forall a. a -> Forest a -> Tree a
Node Maybe a
forall a. Maybe a
Nothing  [BinTree a -> Tree (Maybe a)
go BinTree a
t1, BinTree a -> Tree (Maybe a)
go BinTree a
t2]
  go (Leaf a
x)       = Maybe a -> Forest (Maybe a) -> Tree (Maybe a)
forall a. a -> Forest a -> Tree a
Node (a -> Maybe a
forall a. a -> Maybe a
Just a
x) [] 

toRoseTree' :: BinTree' a b -> Tree (Either b a)
toRoseTree' :: BinTree' a b -> Tree (Either b a)
toRoseTree' = BinTree' a b -> Tree (Either b a)
forall b a. BinTree' b a -> Tree (Either a b)
go where
  go :: BinTree' b a -> Tree (Either a b)
go (Branch' BinTree' b a
t1 a
y BinTree' b a
t2) = Either a b -> Forest (Either a b) -> Tree (Either a b)
forall a. a -> Forest a -> Tree a
Node (a -> Either a b
forall a b. a -> Either a b
Left  a
y) [BinTree' b a -> Tree (Either a b)
go BinTree' b a
t1, BinTree' b a -> Tree (Either a b)
go BinTree' b a
t2]
  go (Leaf' b
x)         = Either a b -> Forest (Either a b) -> Tree (Either a b)
forall a. a -> Forest a -> Tree a
Node (b -> Either a b
forall a b. b -> Either a b
Right b
x) [] 
  
--------------------------------------------------------------------------------
-- instances
  
instance Functor BinTree where
  fmap :: (a -> b) -> BinTree a -> BinTree b
fmap a -> b
f = BinTree a -> BinTree b
go where
    go :: BinTree a -> BinTree b
go (Branch BinTree a
left BinTree a
right) = BinTree b -> BinTree b -> BinTree b
forall a. BinTree a -> BinTree a -> BinTree a
Branch (BinTree a -> BinTree b
go BinTree a
left) (BinTree a -> BinTree b
go BinTree a
right)
    go (Leaf a
x) = b -> BinTree b
forall a. a -> BinTree a
Leaf (a -> b
f a
x)
  
instance Foldable BinTree where
  foldMap :: (a -> m) -> BinTree a -> m
foldMap a -> m
f = BinTree a -> m
go where
    go :: BinTree a -> m
go (Leaf a
x) = a -> m
f a
x
    go (Branch BinTree a
left BinTree a
right) = (BinTree a -> m
go BinTree a
left) m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` (BinTree a -> m
go BinTree a
right)  

instance Traversable BinTree where
  traverse :: (a -> f b) -> BinTree a -> f (BinTree b)
traverse a -> f b
f = BinTree a -> f (BinTree b)
go where 
    go :: BinTree a -> f (BinTree b)
go (Leaf a
x) = b -> BinTree b
forall a. a -> BinTree a
Leaf (b -> BinTree b) -> f b -> f (BinTree b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x
    go (Branch BinTree a
left BinTree a
right) = BinTree b -> BinTree b -> BinTree b
forall a. BinTree a -> BinTree a -> BinTree a
Branch (BinTree b -> BinTree b -> BinTree b)
-> f (BinTree b) -> f (BinTree b -> BinTree b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinTree a -> f (BinTree b)
go BinTree a
left f (BinTree b -> BinTree b) -> f (BinTree b) -> f (BinTree b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinTree a -> f (BinTree b)
go BinTree a
right

instance Applicative BinTree where
  pure :: a -> BinTree a
pure    = a -> BinTree a
forall a. a -> BinTree a
Leaf
  BinTree (a -> b)
u <*> :: BinTree (a -> b) -> BinTree a -> BinTree b
<*> BinTree a
t = BinTree (a -> b) -> BinTree b
forall a. BinTree (a -> a) -> BinTree a
go BinTree (a -> b)
u where
    go :: BinTree (a -> a) -> BinTree a
go (Branch BinTree (a -> a)
l BinTree (a -> a)
r) = BinTree a -> BinTree a -> BinTree a
forall a. BinTree a -> BinTree a -> BinTree a
Branch (BinTree (a -> a) -> BinTree a
go BinTree (a -> a)
l) (BinTree (a -> a) -> BinTree a
go BinTree (a -> a)
r)
    go (Leaf   a -> a
f  ) = (a -> a) -> BinTree a -> BinTree a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
f BinTree a
t

instance Monad BinTree where
  return :: a -> BinTree a
return    = a -> BinTree a
forall a. a -> BinTree a
Leaf
  >>= :: BinTree a -> (a -> BinTree b) -> BinTree b
(>>=) BinTree a
t a -> BinTree b
f = BinTree a -> BinTree b
go BinTree a
t where
    go :: BinTree a -> BinTree b
go (Branch BinTree a
l BinTree a
r) = BinTree b -> BinTree b -> BinTree b
forall a. BinTree a -> BinTree a -> BinTree a
Branch (BinTree a -> BinTree b
go BinTree a
l) (BinTree a -> BinTree b
go BinTree a
r)
    go (Leaf   a
y  ) = a -> BinTree b
f a
y 

--------------------------------------------------------------------------------
-- * Nested parentheses

data Paren 
  = LeftParen 
  | RightParen 
  deriving (Paren -> Paren -> Bool
(Paren -> Paren -> Bool) -> (Paren -> Paren -> Bool) -> Eq Paren
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Paren -> Paren -> Bool
$c/= :: Paren -> Paren -> Bool
== :: Paren -> Paren -> Bool
$c== :: Paren -> Paren -> Bool
Eq,Eq Paren
Eq Paren
-> (Paren -> Paren -> Ordering)
-> (Paren -> Paren -> Bool)
-> (Paren -> Paren -> Bool)
-> (Paren -> Paren -> Bool)
-> (Paren -> Paren -> Bool)
-> (Paren -> Paren -> Paren)
-> (Paren -> Paren -> Paren)
-> Ord Paren
Paren -> Paren -> Bool
Paren -> Paren -> Ordering
Paren -> Paren -> Paren
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Paren -> Paren -> Paren
$cmin :: Paren -> Paren -> Paren
max :: Paren -> Paren -> Paren
$cmax :: Paren -> Paren -> Paren
>= :: Paren -> Paren -> Bool
$c>= :: Paren -> Paren -> Bool
> :: Paren -> Paren -> Bool
$c> :: Paren -> Paren -> Bool
<= :: Paren -> Paren -> Bool
$c<= :: Paren -> Paren -> Bool
< :: Paren -> Paren -> Bool
$c< :: Paren -> Paren -> Bool
compare :: Paren -> Paren -> Ordering
$ccompare :: Paren -> Paren -> Ordering
$cp1Ord :: Eq Paren
Ord,Int -> Paren -> ShowS
[Paren] -> ShowS
Paren -> String
(Int -> Paren -> ShowS)
-> (Paren -> String) -> ([Paren] -> ShowS) -> Show Paren
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Paren] -> ShowS
$cshowList :: [Paren] -> ShowS
show :: Paren -> String
$cshow :: Paren -> String
showsPrec :: Int -> Paren -> ShowS
$cshowsPrec :: Int -> Paren -> ShowS
Show,ReadPrec [Paren]
ReadPrec Paren
Int -> ReadS Paren
ReadS [Paren]
(Int -> ReadS Paren)
-> ReadS [Paren]
-> ReadPrec Paren
-> ReadPrec [Paren]
-> Read Paren
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Paren]
$creadListPrec :: ReadPrec [Paren]
readPrec :: ReadPrec Paren
$creadPrec :: ReadPrec Paren
readList :: ReadS [Paren]
$creadList :: ReadS [Paren]
readsPrec :: Int -> ReadS Paren
$creadsPrec :: Int -> ReadS Paren
Read)

parenToChar :: Paren -> Char
parenToChar :: Paren -> Char
parenToChar Paren
LeftParen = Char
'('
parenToChar Paren
RightParen = Char
')'

parenthesesToString :: [Paren] -> String
parenthesesToString :: [Paren] -> String
parenthesesToString = (Paren -> Char) -> [Paren] -> String
forall a b. (a -> b) -> [a] -> [b]
map Paren -> Char
parenToChar

stringToParentheses :: String -> [Paren]
stringToParentheses :: String -> [Paren]
stringToParentheses [] = []
stringToParentheses (Char
x:String
xs) = Paren
p Paren -> [Paren] -> [Paren]
forall a. a -> [a] -> [a]
: String -> [Paren]
stringToParentheses String
xs where
  p :: Paren
p = case Char
x of
    Char
'(' -> Paren
LeftParen
    Char
')' -> Paren
RightParen
    Char
_ -> String -> Paren
forall a. HasCallStack => String -> a
error String
"stringToParentheses: invalid character"

--------------------------------------------------------------------------------
-- * Bijections

forestToNestedParentheses :: Forest a -> [Paren]
forestToNestedParentheses :: Forest a -> [Paren]
forestToNestedParentheses = Forest a -> [Paren]
forall a. [Tree a] -> [Paren]
forest where
  -- forest :: Forest a -> [Paren]
  forest :: [Tree a] -> [Paren]
forest = (Tree a -> [Paren]) -> [Tree a] -> [Paren]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree a -> [Paren]
tree 
  -- tree :: Tree a -> [Paren]
  tree :: Tree a -> [Paren]
tree (Node a
_ [Tree a]
sf) = Paren
LeftParen Paren -> [Paren] -> [Paren]
forall a. a -> [a] -> [a]
: [Tree a] -> [Paren]
forest [Tree a]
sf [Paren] -> [Paren] -> [Paren]
forall a. [a] -> [a] -> [a]
++ [Paren
RightParen]

forestToBinaryTree :: Forest a -> BinTree ()
forestToBinaryTree :: Forest a -> BinTree ()
forestToBinaryTree = Forest a -> BinTree ()
forall a. [Tree a] -> BinTree ()
forest where
  -- forest :: Forest a -> BinTree ()
  forest :: [Tree a] -> BinTree ()
forest = (BinTree () -> BinTree () -> BinTree ())
-> BinTree () -> [BinTree ()] -> BinTree ()
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr BinTree () -> BinTree () -> BinTree ()
forall a. BinTree a -> BinTree a -> BinTree a
Branch BinTree ()
leaf ([BinTree ()] -> BinTree ())
-> ([Tree a] -> [BinTree ()]) -> [Tree a] -> BinTree ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree a -> BinTree ()) -> [Tree a] -> [BinTree ()]
forall a b. (a -> b) -> [a] -> [b]
map Tree a -> BinTree ()
tree 
  -- tree :: Tree a -> BinTree ()
  tree :: Tree a -> BinTree ()
tree (Node a
_ [Tree a]
sf) = case [Tree a]
sf of
    [] -> BinTree ()
leaf
    [Tree a]
_  -> [Tree a] -> BinTree ()
forest [Tree a]
sf 
   
nestedParenthesesToForest :: [Paren] -> Maybe (Forest ())
nestedParenthesesToForest :: [Paren] -> Maybe (Forest ())
nestedParenthesesToForest [Paren]
ps = 
  case [Paren] -> ([Paren], Forest ())
parseForest [Paren]
ps of 
    ([Paren]
rest,Forest ()
forest) -> case [Paren]
rest of
      [] -> Forest () -> Maybe (Forest ())
forall a. a -> Maybe a
Just Forest ()
forest
      [Paren]
_  -> Maybe (Forest ())
forall a. Maybe a
Nothing
  where  
    parseForest :: [Paren] -> ( [Paren] , Forest () )
    parseForest :: [Paren] -> ([Paren], Forest ())
parseForest [Paren]
ps = ([Paren] -> Either [Paren] ([Paren], Tree ()))
-> [Paren] -> ([Paren], Forest ())
forall b c a. (b -> Either c (b, a)) -> b -> (c, [a])
unfoldEither [Paren] -> Either [Paren] ([Paren], Tree ())
parseTree [Paren]
ps
    parseTree :: [Paren] -> Either [Paren] ( [Paren] , Tree () )  
    parseTree :: [Paren] -> Either [Paren] ([Paren], Tree ())
parseTree orig :: [Paren]
orig@(Paren
LeftParen:[Paren]
ps) = let ([Paren]
rest,Forest ()
ts) = [Paren] -> ([Paren], Forest ())
parseForest [Paren]
ps in case [Paren]
rest of
      (Paren
RightParen:[Paren]
qs) -> ([Paren], Tree ()) -> Either [Paren] ([Paren], Tree ())
forall a b. b -> Either a b
Right ([Paren]
qs, () -> Forest () -> Tree ()
forall a. a -> Forest a -> Tree a
Node () Forest ()
ts)
      [Paren]
_ -> [Paren] -> Either [Paren] ([Paren], Tree ())
forall a b. a -> Either a b
Left [Paren]
orig
    parseTree [Paren]
qs = [Paren] -> Either [Paren] ([Paren], Tree ())
forall a b. a -> Either a b
Left [Paren]
qs

nestedParenthesesToForestUnsafe :: [Paren] -> Forest ()
nestedParenthesesToForestUnsafe :: [Paren] -> Forest ()
nestedParenthesesToForestUnsafe = Maybe (Forest ()) -> Forest ()
forall a. Maybe a -> a
fromJust (Maybe (Forest ()) -> Forest ())
-> ([Paren] -> Maybe (Forest ())) -> [Paren] -> Forest ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Paren] -> Maybe (Forest ())
nestedParenthesesToForest

nestedParenthesesToBinaryTree :: [Paren] -> Maybe (BinTree ())
nestedParenthesesToBinaryTree :: [Paren] -> Maybe (BinTree ())
nestedParenthesesToBinaryTree [Paren]
ps = 
  case [Paren] -> ([Paren], BinTree ())
parseForest [Paren]
ps of 
    ([Paren]
rest,BinTree ()
forest) -> case [Paren]
rest of
      [] -> BinTree () -> Maybe (BinTree ())
forall a. a -> Maybe a
Just BinTree ()
forest
      [Paren]
_  -> Maybe (BinTree ())
forall a. Maybe a
Nothing
  where  
    parseForest :: [Paren] -> ( [Paren] , BinTree () )
    parseForest :: [Paren] -> ([Paren], BinTree ())
parseForest [Paren]
ps = let ([Paren]
rest,[BinTree ()]
ts) = ([Paren] -> Either [Paren] ([Paren], BinTree ()))
-> [Paren] -> ([Paren], [BinTree ()])
forall b c a. (b -> Either c (b, a)) -> b -> (c, [a])
unfoldEither [Paren] -> Either [Paren] ([Paren], BinTree ())
parseTree [Paren]
ps in ([Paren]
rest , (BinTree () -> BinTree () -> BinTree ())
-> BinTree () -> [BinTree ()] -> BinTree ()
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr BinTree () -> BinTree () -> BinTree ()
forall a. BinTree a -> BinTree a -> BinTree a
Branch BinTree ()
leaf [BinTree ()]
ts)
    parseTree :: [Paren] -> Either [Paren] ( [Paren] , BinTree () )  
    parseTree :: [Paren] -> Either [Paren] ([Paren], BinTree ())
parseTree orig :: [Paren]
orig@(Paren
LeftParen:[Paren]
ps) = let ([Paren]
rest,BinTree ()
ts) = [Paren] -> ([Paren], BinTree ())
parseForest [Paren]
ps in case [Paren]
rest of
      (Paren
RightParen:[Paren]
qs) -> ([Paren], BinTree ()) -> Either [Paren] ([Paren], BinTree ())
forall a b. b -> Either a b
Right ([Paren]
qs, BinTree ()
ts)
      [Paren]
_ -> [Paren] -> Either [Paren] ([Paren], BinTree ())
forall a b. a -> Either a b
Left [Paren]
orig
    parseTree [Paren]
qs = [Paren] -> Either [Paren] ([Paren], BinTree ())
forall a b. a -> Either a b
Left [Paren]
qs
    
nestedParenthesesToBinaryTreeUnsafe :: [Paren] -> BinTree ()
nestedParenthesesToBinaryTreeUnsafe :: [Paren] -> BinTree ()
nestedParenthesesToBinaryTreeUnsafe = Maybe (BinTree ()) -> BinTree ()
forall a. Maybe a -> a
fromJust (Maybe (BinTree ()) -> BinTree ())
-> ([Paren] -> Maybe (BinTree ())) -> [Paren] -> BinTree ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Paren] -> Maybe (BinTree ())
nestedParenthesesToBinaryTree

binaryTreeToNestedParentheses :: BinTree a -> [Paren]
binaryTreeToNestedParentheses :: BinTree a -> [Paren]
binaryTreeToNestedParentheses = BinTree a -> [Paren]
forall a. BinTree a -> [Paren]
worker where
  worker :: BinTree a -> [Paren]
worker (Branch BinTree a
l BinTree a
r) = Paren
LeftParen Paren -> [Paren] -> [Paren]
forall a. a -> [a] -> [a]
: BinTree a -> [Paren]
worker BinTree a
l [Paren] -> [Paren] -> [Paren]
forall a. [a] -> [a] -> [a]
++ Paren
RightParen Paren -> [Paren] -> [Paren]
forall a. a -> [a] -> [a]
: BinTree a -> [Paren]
worker BinTree a
r
  worker (Leaf a
_) = []

binaryTreeToForest :: BinTree a -> Forest ()
binaryTreeToForest :: BinTree a -> Forest ()
binaryTreeToForest = BinTree a -> Forest ()
forall a. BinTree a -> Forest ()
worker where
  worker :: BinTree a -> Forest ()
worker (Branch BinTree a
l BinTree a
r) = () -> Forest () -> Tree ()
forall a. a -> Forest a -> Tree a
Node () (BinTree a -> Forest ()
worker BinTree a
l) Tree () -> Forest () -> Forest ()
forall a. a -> [a] -> [a]
: BinTree a -> Forest ()
worker BinTree a
r
  worker (Leaf a
_) = []

--------------------------------------------------------------------------------
-- * Nested parentheses

-- | Generates all sequences of nested parentheses of length @2n@ in
-- lexigraphic order.
-- 
-- Synonym for 'fasc4A_algorithm_P'.
--
nestedParentheses :: Int -> [[Paren]]
nestedParentheses :: Int -> [[Paren]]
nestedParentheses = Int -> [[Paren]]
fasc4A_algorithm_P

-- | Synonym for 'fasc4A_algorithm_W'.
randomNestedParentheses :: RandomGen g => Int -> g -> ([Paren],g)
randomNestedParentheses :: Int -> g -> ([Paren], g)
randomNestedParentheses = Int -> g -> ([Paren], g)
forall g. RandomGen g => Int -> g -> ([Paren], g)
fasc4A_algorithm_W

-- | Synonym for 'fasc4A_algorithm_U'.
nthNestedParentheses :: Int -> Integer -> [Paren]
nthNestedParentheses :: Int -> Integer -> [Paren]
nthNestedParentheses = Int -> Integer -> [Paren]
fasc4A_algorithm_U

countNestedParentheses :: Int -> Integer
countNestedParentheses :: Int -> Integer
countNestedParentheses = Int -> Integer
countBinaryTrees

-- | Generates all sequences of nested parentheses of length 2n.
-- Order is lexicographical (when right parentheses are considered 
-- smaller then left ones).
-- Based on \"Algorithm P\" in Knuth, but less efficient because of
-- the \"idiomatic\" code.
fasc4A_algorithm_P :: Int -> [[Paren]]
fasc4A_algorithm_P :: Int -> [[Paren]]
fasc4A_algorithm_P Int
0 = [[]]
fasc4A_algorithm_P Int
1 = [[Paren
LeftParen,Paren
RightParen]]
fasc4A_algorithm_P Int
n = (([Paren], [Paren]) -> ([Paren], Maybe ([Paren], [Paren])))
-> ([Paren], [Paren]) -> [[Paren]]
forall b a. (b -> (a, Maybe b)) -> b -> [a]
unfold ([Paren], [Paren]) -> ([Paren], Maybe ([Paren], [Paren]))
next ( [Paren]
start , [] ) where 
  start :: [Paren]
start = [[Paren]] -> [Paren]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Paren]] -> [Paren]) -> [[Paren]] -> [Paren]
forall a b. (a -> b) -> a -> b
$ Int -> [Paren] -> [[Paren]]
forall a. Int -> a -> [a]
replicate Int
n [Paren
RightParen,Paren
LeftParen]  -- already reversed!
   
  next :: ([Paren],[Paren]) -> ( [Paren] , Maybe ([Paren],[Paren]) )
  next :: ([Paren], [Paren]) -> ([Paren], Maybe ([Paren], [Paren]))
next ( (Paren
a:Paren
b:[Paren]
ls) , [] ) = ([Paren], [Paren]) -> ([Paren], Maybe ([Paren], [Paren]))
next ( [Paren]
ls , Paren
bParen -> [Paren] -> [Paren]
forall a. a -> [a] -> [a]
:Paren
aParen -> [Paren] -> [Paren]
forall a. a -> [a] -> [a]
:[] )
  next ( lls :: [Paren]
lls@(Paren
l:[Paren]
ls) , rrs :: [Paren]
rrs@(Paren
r:[Paren]
rs) ) = ( [Paren]
visit , Maybe ([Paren], [Paren])
new ) where
    visit :: [Paren]
visit = [Paren] -> [Paren]
forall a. [a] -> [a]
reverse [Paren]
lls [Paren] -> [Paren] -> [Paren]
forall a. [a] -> [a] -> [a]
++ [Paren]
rrs
    new :: Maybe ([Paren], [Paren])
new = 
      {- debug (reverse ls,l,r,rs) $ -} 
      case Paren
l of 
        Paren
RightParen -> ([Paren], [Paren]) -> Maybe ([Paren], [Paren])
forall a. a -> Maybe a
Just ( [Paren]
ls , Paren
LeftParenParen -> [Paren] -> [Paren]
forall a. a -> [a] -> [a]
:Paren
RightParenParen -> [Paren] -> [Paren]
forall a. a -> [a] -> [a]
:[Paren]
rs )
        Paren
LeftParen  -> 
          {- debug ("---",reverse ls,l,r,rs) $ -}
          ([Paren], [Paren])
-> ([Paren], [Paren]) -> Maybe ([Paren], [Paren])
findj ( [Paren]
lls , [] ) ( [Paren] -> [Paren]
forall a. [a] -> [a]
reverse (Paren
RightParenParen -> [Paren] -> [Paren]
forall a. a -> [a] -> [a]
:[Paren]
rs) , [] ) 
  next ([Paren], [Paren])
_ = String -> ([Paren], Maybe ([Paren], [Paren]))
forall a. HasCallStack => String -> a
error String
"fasc4A_algorithm_P: fatal error shouldn't happen"

  findj :: ([Paren],[Paren]) -> ([Paren],[Paren]) -> Maybe ([Paren],[Paren])
  findj :: ([Paren], [Paren])
-> ([Paren], [Paren]) -> Maybe ([Paren], [Paren])
findj ( [] , [Paren]
_ ) ([Paren], [Paren])
_ = Maybe ([Paren], [Paren])
forall a. Maybe a
Nothing
  findj ( lls :: [Paren]
lls@(Paren
l:[Paren]
ls) , [Paren]
rs) ( [Paren]
xs , [Paren]
ys ) = 
    {- debug ((reverse ls,l,rs),(reverse xs,ys)) $ -}
    case Paren
l of
      Paren
LeftParen  -> case [Paren]
xs of
        (Paren
a:Paren
_:[Paren]
as) -> ([Paren], [Paren])
-> ([Paren], [Paren]) -> Maybe ([Paren], [Paren])
findj ( [Paren]
ls, Paren
RightParenParen -> [Paren] -> [Paren]
forall a. a -> [a] -> [a]
:[Paren]
rs ) ( [Paren]
as , Paren
LeftParenParen -> [Paren] -> [Paren]
forall a. a -> [a] -> [a]
:Paren
aParen -> [Paren] -> [Paren]
forall a. a -> [a] -> [a]
:[Paren]
ys )
        [Paren]
_ -> ([Paren], [Paren])
-> ([Paren], [Paren]) -> Maybe ([Paren], [Paren])
findj ( [Paren]
lls, [] ) ( [Paren] -> [Paren]
forall a. [a] -> [a]
reverse [Paren]
rs [Paren] -> [Paren] -> [Paren]
forall a. [a] -> [a] -> [a]
++ [Paren]
xs , [Paren]
ys) 
      Paren
RightParen -> ([Paren], [Paren]) -> Maybe ([Paren], [Paren])
forall a. a -> Maybe a
Just ( [Paren] -> [Paren]
forall a. [a] -> [a]
reverse [Paren]
ys [Paren] -> [Paren] -> [Paren]
forall a. [a] -> [a] -> [a]
++ [Paren]
xs [Paren] -> [Paren] -> [Paren]
forall a. [a] -> [a] -> [a]
++ [Paren] -> [Paren]
forall a. [a] -> [a]
reverse (Paren
LeftParenParen -> [Paren] -> [Paren]
forall a. a -> [a] -> [a]
:[Paren]
rs) [Paren] -> [Paren] -> [Paren]
forall a. [a] -> [a] -> [a]
++ [Paren]
ls , [] )
  findj ([Paren], [Paren])
_ ([Paren], [Paren])
_ = String -> Maybe ([Paren], [Paren])
forall a. HasCallStack => String -> a
error String
"fasc4A_algorithm_P: fatal error shouldn't happen"
    
-- | Generates a uniformly random sequence of nested parentheses of length 2n.    
-- Based on \"Algorithm W\" in Knuth.
fasc4A_algorithm_W :: RandomGen g => Int -> g -> ([Paren],g)
fasc4A_algorithm_W :: Int -> g -> ([Paren], g)
fasc4A_algorithm_W Int
n' g
rnd = (g, Integer, Integer, [Paren]) -> ([Paren], g)
forall g.
RandomGen g =>
(g, Integer, Integer, [Paren]) -> ([Paren], g)
worker (g
rnd,Integer
n,Integer
n,[]) where
  n :: Integer
n = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n' :: Integer  
  -- the numbers we use are of order n^2, so for n >> 2^16 
  -- on a 32 bit machine, we need big integers.
  worker :: RandomGen g => (g,Integer,Integer,[Paren]) -> ([Paren],g)
  worker :: (g, Integer, Integer, [Paren]) -> ([Paren], g)
worker (g
rnd,Integer
_,Integer
0,[Paren]
parens) = ([Paren]
parens,g
rnd)
  worker (g
rnd,Integer
p,Integer
q,[Paren]
parens) = 
    if Integer
xInteger -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<(Integer
qInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1)Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*(Integer
qInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
p) 
      then (g, Integer, Integer, [Paren]) -> ([Paren], g)
forall g.
RandomGen g =>
(g, Integer, Integer, [Paren]) -> ([Paren], g)
worker (g
rnd' , Integer
p   , Integer
qInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1 , Paren
LeftParen Paren -> [Paren] -> [Paren]
forall a. a -> [a] -> [a]
:[Paren]
parens)
      else (g, Integer, Integer, [Paren]) -> ([Paren], g)
forall g.
RandomGen g =>
(g, Integer, Integer, [Paren]) -> ([Paren], g)
worker (g
rnd' , Integer
pInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1 , Integer
q   , Paren
RightParenParen -> [Paren] -> [Paren]
forall a. a -> [a] -> [a]
:[Paren]
parens)
    where 
      (Integer
x,g
rnd') = (Integer, Integer) -> g -> (Integer, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR ( Integer
0 , (Integer
qInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
p)Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*(Integer
qInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
pInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1)Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1 ) g
rnd

-- | Nth sequence of nested parentheses of length 2n. 
-- The order is the same as in 'fasc4A_algorithm_P'.
-- Based on \"Algorithm U\" in Knuth.
fasc4A_algorithm_U 
  :: Int               -- ^ n
  -> Integer           -- ^ N; should satisfy 1 <= N <= C(n) 
  -> [Paren]
fasc4A_algorithm_U :: Int -> Integer -> [Paren]
fasc4A_algorithm_U Int
n' Integer
bign0 = [Paren] -> [Paren]
forall a. [a] -> [a]
reverse ([Paren] -> [Paren]) -> [Paren] -> [Paren]
forall a b. (a -> b) -> a -> b
$ (Integer, Integer, Integer, Integer, [Paren]) -> [Paren]
worker (Integer
bign0,Integer
c0,Integer
n,Integer
n,[]) where
  n :: Integer
n = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n' :: Integer
  c0 :: Integer
c0 = (Integer -> Integer -> Integer) -> Integer -> [Integer] -> Integer
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
f Integer
1 [Integer
2..Integer
n]  
  f :: a -> a -> a
f a
c a
p = ((a
4a -> a -> a
forall a. Num a => a -> a -> a
*a
pa -> a -> a
forall a. Num a => a -> a -> a
-a
2)a -> a -> a
forall a. Num a => a -> a -> a
*a
c) a -> a -> a
forall a. Integral a => a -> a -> a
`div` (a
pa -> a -> a
forall a. Num a => a -> a -> a
+a
1) 
  worker :: (Integer,Integer,Integer,Integer,[Paren]) -> [Paren]
  worker :: (Integer, Integer, Integer, Integer, [Paren]) -> [Paren]
worker (Integer
_   ,Integer
_,Integer
_,Integer
0,[Paren]
parens) = [Paren]
parens
  worker (Integer
bign,Integer
c,Integer
p,Integer
q,[Paren]
parens) = 
    if Integer
bign Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
c' 
      then (Integer, Integer, Integer, Integer, [Paren]) -> [Paren]
worker (Integer
bign    , Integer
c'   , Integer
p   , Integer
qInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1 , Paren
RightParenParen -> [Paren] -> [Paren]
forall a. a -> [a] -> [a]
:[Paren]
parens)
      else (Integer, Integer, Integer, Integer, [Paren]) -> [Paren]
worker (Integer
bignInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
c' , Integer
cInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
c' , Integer
pInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1 , Integer
q   , Paren
LeftParen Paren -> [Paren] -> [Paren]
forall a. a -> [a] -> [a]
:[Paren]
parens)
    where
      c' :: Integer
c' = ((Integer
qInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1)Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*(Integer
qInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
p)Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
c) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` ((Integer
qInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
p)Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*(Integer
qInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
pInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1))
  
--------------------------------------------------------------------------------
-- * Generating binary trees

-- | Generates all binary trees with @n@ nodes. 
--   At the moment just a synonym for 'binaryTreesNaive'.
binaryTrees :: Int -> [BinTree ()]
binaryTrees :: Int -> [BinTree ()]
binaryTrees = Int -> [BinTree ()]
binaryTreesNaive

-- | # = Catalan(n) = \\frac { 1 } { n+1 } \\binom { 2n } { n }.
--
-- This is also the counting function for forests and nested parentheses.
countBinaryTrees :: Int -> Integer
countBinaryTrees :: Int -> Integer
countBinaryTrees Int
n = Int -> Int -> Integer
forall a. Integral a => a -> a -> Integer
binomial (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
n) Int
n Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` (Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
    
-- | Generates all binary trees with n nodes. The naive algorithm.
binaryTreesNaive :: Int -> [BinTree ()]
binaryTreesNaive :: Int -> [BinTree ()]
binaryTreesNaive Int
0 = [ BinTree ()
leaf ]
binaryTreesNaive Int
n = 
  [ BinTree () -> BinTree () -> BinTree ()
forall a. BinTree a -> BinTree a -> BinTree a
Branch BinTree ()
l BinTree ()
r 
  | Int
i <- [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] 
  , BinTree ()
l <- Int -> [BinTree ()]
binaryTreesNaive Int
i 
  , BinTree ()
r <- Int -> [BinTree ()]
binaryTreesNaive (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i) 
  ]

-- | Generates an uniformly random binary tree, using 'fasc4A_algorithm_R'.
randomBinaryTree :: RandomGen g => Int -> g -> (BinTree (), g)
randomBinaryTree :: Int -> g -> (BinTree (), g)
randomBinaryTree Int
n g
rnd = (BinTree ()
tree,g
rnd') where
  (BinTree' Int Int
decorated,g
rnd') = Int -> g -> (BinTree' Int Int, g)
forall g. RandomGen g => Int -> g -> (BinTree' Int Int, g)
fasc4A_algorithm_R Int
n g
rnd      
  tree :: BinTree ()
tree = (Int -> ()) -> BinTree Int -> BinTree ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Int -> ()
forall a b. a -> b -> a
const ()) (BinTree Int -> BinTree ()) -> BinTree Int -> BinTree ()
forall a b. (a -> b) -> a -> b
$ BinTree' Int Int -> BinTree Int
forall a b. BinTree' a b -> BinTree a
forgetNodeDecorations BinTree' Int Int
decorated

-- | Grows a uniformly random binary tree. 
-- \"Algorithm R\" (Remy's procudere) in Knuth.
-- Nodes are decorated with odd numbers, leaves with even numbers (from the
-- set @[0..2n]@). Uses mutable arrays internally.
fasc4A_algorithm_R :: RandomGen g => Int -> g -> (BinTree' Int Int, g)
fasc4A_algorithm_R :: Int -> g -> (BinTree' Int Int, g)
fasc4A_algorithm_R Int
n0 g
rnd = (BinTree' Int Int, g)
res where
  res :: (BinTree' Int Int, g)
res = (forall s. ST s (BinTree' Int Int, g)) -> (BinTree' Int Int, g)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (BinTree' Int Int, g)) -> (BinTree' Int Int, g))
-> (forall s. ST s (BinTree' Int Int, g)) -> (BinTree' Int Int, g)
forall a b. (a -> b) -> a -> b
$ do
    STUArray s Int Int
ar <- (Int, Int) -> Int -> ST s (STUArray s Int Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0,Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
n0) Int
0
    g
rnd' <- g -> Int -> STUArray s Int Int -> ST s g
forall g s. RandomGen g => g -> Int -> STUArray s Int Int -> ST s g
worker g
rnd Int
1 STUArray s Int Int
ar
    Array Int Int
links <- STUArray s Int Int -> ST s (Array Int Int)
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
Data.Array.Unsafe.unsafeFreeze STUArray s Int Int
ar
    (BinTree' Int Int, g) -> ST s (BinTree' Int Int, g)
forall (m :: * -> *) a. Monad m => a -> m a
return (Array Int Int -> BinTree' Int Int
forall t. (Integral t, Ix t) => Array t t -> BinTree' t t
toTree Array Int Int
links, g
rnd')
  toTree :: Array t t -> BinTree' t t
toTree Array t t
links = t -> BinTree' t t
f (Array t t
linksArray t t -> t -> t
forall i e. Ix i => Array i e -> i -> e
!t
0) where
    f :: t -> BinTree' t t
f t
i = if t -> Bool
forall a. Integral a => a -> Bool
odd t
i 
      then BinTree' t t -> t -> BinTree' t t -> BinTree' t t
forall a b. BinTree' a b -> b -> BinTree' a b -> BinTree' a b
Branch' (t -> BinTree' t t
f (t -> BinTree' t t) -> t -> BinTree' t t
forall a b. (a -> b) -> a -> b
$ Array t t
linksArray t t -> t -> t
forall i e. Ix i => Array i e -> i -> e
!t
i) t
i (t -> BinTree' t t
f (t -> BinTree' t t) -> t -> BinTree' t t
forall a b. (a -> b) -> a -> b
$ Array t t
linksArray t t -> t -> t
forall i e. Ix i => Array i e -> i -> e
!(t
it -> t -> t
forall a. Num a => a -> a -> a
+t
1)) 
      else t -> BinTree' t t
forall a b. a -> BinTree' a b
Leaf' t
i  
  worker :: RandomGen g => g -> Int -> STUArray s Int Int -> ST s g
  worker :: g -> Int -> STUArray s Int Int -> ST s g
worker g
rnd Int
n STUArray s Int Int
ar = do 
    if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n0
      then g -> ST s g
forall (m :: * -> *) a. Monad m => a -> m a
return g
rnd
      else do
        STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
ar (Int
n2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
b)   Int
n2
        Int
lk <- STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
ar Int
k
        STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
ar (Int
n2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
b) Int
lk
        STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
ar Int
k        (Int
n2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
        g -> Int -> STUArray s Int Int -> ST s g
forall g s. RandomGen g => g -> Int -> STUArray s Int Int -> ST s g
worker g
rnd' (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) STUArray s Int Int
ar      
    where  
      n2 :: Int
n2 = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n
      (Int
x,g
rnd') = (Int, Int) -> g -> (Int, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0,Int
4Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
3) g
rnd
      (Int
k,Int
b) = Int
x Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
2
      
--------------------------------------------------------------------------------      
-- * ASCII drawing  

-- | Draws a binary tree in ASCII, ignoring node labels.
--
-- Example:
--
-- > autoTabulate RowMajor (Right 5) $ map asciiBinaryTree_ $ binaryTrees 4
--
asciiBinaryTree_ :: BinTree a -> ASCII
asciiBinaryTree_ :: BinTree a -> ASCII
asciiBinaryTree_ = [String] -> ASCII
ASCII.asciiFromLines ([String] -> ASCII)
-> (BinTree a -> [String]) -> BinTree a -> ASCII
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String], Int) -> [String]
forall a b. (a, b) -> a
fst (([String], Int) -> [String])
-> (BinTree a -> ([String], Int)) -> BinTree a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinTree a -> ([String], Int)
forall a. BinTree a -> ([String], Int)
go where

  go :: BinTree a -> ([String],Int)
  go :: BinTree a -> ([String], Int)
go (Leaf a
x) = ([],Int
0)
  go (Branch BinTree a
t1 BinTree a
t2) = ( [String]
new , Int
j1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
m ) where
    ([String]
ls1,Int
j1) = BinTree a -> ([String], Int)
forall a. BinTree a -> ([String], Int)
go BinTree a
t1
    ([String]
ls2,Int
j2) = BinTree a -> ([String], Int)
forall a. BinTree a -> ([String], Int)
go BinTree a
t2
    w1 :: Int
w1 = [String] -> Int
forall (t :: * -> *) a. Foldable t => [t a] -> Int
blockWidth [String]
ls1
    w2 :: Int
w2 = [String] -> Int
forall (t :: * -> *) a. Foldable t => [t a] -> Int
blockWidth [String]
ls2
    m :: Int
m = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
w1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
j1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
j2Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
    s :: Int
s = Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
w1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
j1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
j2)
    spaces :: [String]
spaces = [Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
s Char
' ']
    ls :: [String]
ls = [[String]] -> [String]
hConcatLines [ [String]
ls1 , [String]
spaces , [String]
ls2 ]
    top :: [String]
top = [ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
j1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*(Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\\" | Int
i<-[Int
1..Int
m] ]
    new :: [String]
new = [String] -> [String]
mkLinesUniformWidth ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
vConcatLines [ [String]
top , [String]
ls ] 
        
  blockWidth :: [t a] -> Int
blockWidth [t a]
ls = case [t a]
ls of
    (t a
l:[t a]
_) -> t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
l
    []    -> Int
0

instance DrawASCII (BinTree ()) where
  ascii :: BinTree () -> ASCII
ascii = BinTree () -> ASCII
forall a. BinTree a -> ASCII
asciiBinaryTree_ 

--------------------------------------------------------------------------------