-- | 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
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,BinTree a -> BinTree a -> Bool
BinTree a -> BinTree a -> Ordering
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
Ord,Int -> BinTree a -> ShowS
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)
ReadS [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 = forall a. a -> BinTree a
Leaf ()

-- | The monadic join operation of binary trees
graft :: BinTree (BinTree a) -> BinTree a
graft :: forall a. BinTree (BinTree a) -> BinTree a
graft = 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) = 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
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,BinTree' a b -> BinTree' a b -> Bool
BinTree' a b -> BinTree' a b -> Ordering
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
Ord,Int -> BinTree' a b -> ShowS
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)
ReadS [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 :: forall a b. BinTree' a b -> BinTree a
forgetNodeDecorations = 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) = 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       ) = forall a. a -> BinTree a
Leaf a
decor 

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

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

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


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

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

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

-- | Enumerates the leaves a tree, starting from 0, ignoring old labels
enumerateLeaves_ :: BinTree a -> BinTree Int
enumerateLeaves_ :: forall a. BinTree a -> BinTree Int
enumerateLeaves_ = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
kforall a. Num a => a -> a -> a
+a
1 , forall a. a -> BinTree a
Leaf a
k)
    Branch BinTree a
l BinTree a
r -> (a
k'', 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' :: forall a. BinTree a -> (Int, BinTree (a, Int))
enumerateLeaves' = forall {b} {a}. Num b => b -> BinTree a -> (b, BinTree (a, b))
go Int
0 where
  go :: b -> BinTree a -> (b, BinTree (a, b))
go !b
k BinTree a
t = case BinTree a
t of
    Leaf   a
y   -> (b
kforall a. Num a => a -> a -> a
+b
1 , forall a. a -> BinTree a
Leaf (a
y,b
k))
    Branch BinTree a
l BinTree a
r -> (b
k'', forall a. BinTree a -> BinTree a -> BinTree a
Branch BinTree (a, b)
l' BinTree (a, b)
r')  where
                    (b
k' ,BinTree (a, b)
l') = b -> BinTree a -> (b, BinTree (a, b))
go b
k  BinTree a
l
                    (b
k'',BinTree (a, b)
r') = b -> BinTree a -> (b, BinTree (a, b))
go b
k' BinTree a
r

-- | Enumerates the leaves a tree, starting from zero
enumerateLeaves :: BinTree a -> BinTree (a,Int)
enumerateLeaves :: forall a. BinTree a -> BinTree (a, Int)
enumerateLeaves = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. BinTree a -> Tree (Maybe a)
toRoseTree = forall a. BinTree a -> Tree (Maybe a)
go where
  go :: BinTree a -> Tree (Maybe a)
go (Branch BinTree a
t1 BinTree a
t2) = forall a. a -> [Tree a] -> Tree a
Node 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)       = forall a. a -> [Tree a] -> Tree a
Node (forall a. a -> Maybe a
Just a
x) [] 

toRoseTree' :: BinTree' a b -> Tree (Either b a)
toRoseTree' :: forall a b. BinTree' a b -> Tree (Either b a)
toRoseTree' = forall a b. BinTree' a b -> Tree (Either b a)
go where
  go :: BinTree' b a -> Tree (Either a b)
go (Branch' BinTree' b a
t1 a
y BinTree' b a
t2) = forall a. a -> [Tree a] -> Tree a
Node (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)         = forall a. a -> [Tree a] -> Tree a
Node (forall a b. b -> Either a b
Right b
x) [] 
  
--------------------------------------------------------------------------------
-- instances
  
instance Functor BinTree where
  fmap :: forall a b. (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) = 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) = forall a. a -> BinTree a
Leaf (a -> b
f a
x)
  
instance Foldable BinTree where
  foldMap :: forall m a. Monoid m => (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) forall a. Monoid a => a -> a -> a
`mappend` (BinTree a -> m
go BinTree a
right)  

instance Traversable BinTree where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(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) = forall a. a -> BinTree a
Leaf 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) = forall a. BinTree a -> BinTree a -> BinTree a
Branch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinTree a -> f (BinTree b)
go BinTree a
left 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 :: forall a. a -> BinTree a
pure    = forall a. a -> BinTree a
Leaf
  BinTree (a -> b)
u <*> :: forall a b. BinTree (a -> b) -> BinTree a -> BinTree b
<*> BinTree a
t = 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) = 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  ) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
f BinTree a
t

instance Monad BinTree where
  return :: forall a. a -> BinTree a
return    = forall a. a -> BinTree a
Leaf
  >>= :: forall a b. 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) = 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
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
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
Ord,Int -> Paren -> ShowS
[Paren] -> ShowS
Paren -> String
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]
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 = 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 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
_ -> forall a. HasCallStack => String -> a
error String
"stringToParentheses: invalid character"

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

forestToNestedParentheses :: Forest a -> [Paren]
forestToNestedParentheses :: forall a. Forest a -> [Paren]
forestToNestedParentheses = forall a. Forest a -> [Paren]
forest where
  -- forest :: Forest a -> [Paren]
  forest :: [Tree a] -> [Paren]
forest = 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 forall a. a -> [a] -> [a]
: [Tree a] -> [Paren]
forest [Tree a]
sf forall a. [a] -> [a] -> [a]
++ [Paren
RightParen]

forestToBinaryTree :: Forest a -> BinTree ()
forestToBinaryTree :: forall a. Forest a -> BinTree ()
forestToBinaryTree = forall a. Forest a -> BinTree ()
forest where
  -- forest :: Forest a -> BinTree ()
  forest :: [Tree a] -> BinTree ()
forest = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. BinTree a -> BinTree a -> BinTree a
Branch BinTree ()
leaf forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
      [] -> forall a. a -> Maybe a
Just Forest ()
forest
      [Paren]
_  -> forall a. Maybe a
Nothing
  where  
    parseForest :: [Paren] -> ( [Paren] , Forest () )
    parseForest :: [Paren] -> ([Paren], Forest ())
parseForest [Paren]
ps = 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) -> forall a b. b -> Either a b
Right ([Paren]
qs, forall a. a -> [Tree a] -> Tree a
Node () Forest ()
ts)
      [Paren]
_ -> forall a b. a -> Either a b
Left [Paren]
orig
    parseTree [Paren]
qs = forall a b. a -> Either a b
Left [Paren]
qs

nestedParenthesesToForestUnsafe :: [Paren] -> Forest ()
nestedParenthesesToForestUnsafe :: [Paren] -> Forest ()
nestedParenthesesToForestUnsafe = forall a. Maybe a -> a
fromJust 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
      [] -> forall a. a -> Maybe a
Just BinTree ()
forest
      [Paren]
_  -> forall a. Maybe a
Nothing
  where  
    parseForest :: [Paren] -> ( [Paren] , BinTree () )
    parseForest :: [Paren] -> ([Paren], BinTree ())
parseForest [Paren]
ps = let ([Paren]
rest,[BinTree ()]
ts) = forall b c a. (b -> Either c (b, a)) -> b -> (c, [a])
unfoldEither [Paren] -> Either [Paren] ([Paren], BinTree ())
parseTree [Paren]
ps in ([Paren]
rest , forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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) -> forall a b. b -> Either a b
Right ([Paren]
qs, BinTree ()
ts)
      [Paren]
_ -> forall a b. a -> Either a b
Left [Paren]
orig
    parseTree [Paren]
qs = forall a b. a -> Either a b
Left [Paren]
qs
    
nestedParenthesesToBinaryTreeUnsafe :: [Paren] -> BinTree ()
nestedParenthesesToBinaryTreeUnsafe :: [Paren] -> BinTree ()
nestedParenthesesToBinaryTreeUnsafe = forall a. Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Paren] -> Maybe (BinTree ())
nestedParenthesesToBinaryTree

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

binaryTreeToForest :: BinTree a -> Forest ()
binaryTreeToForest :: forall a. BinTree a -> Forest ()
binaryTreeToForest = forall a. BinTree a -> Forest ()
worker where
  worker :: BinTree a -> Forest ()
worker (Branch BinTree a
l BinTree a
r) = forall a. a -> [Tree a] -> Tree a
Node () (BinTree a -> Forest ()
worker BinTree a
l) 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 :: forall g. RandomGen g => Int -> g -> ([Paren], g)
randomNestedParentheses = 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 = forall b a. (b -> (a, Maybe b)) -> b -> [a]
unfold ([Paren], [Paren]) -> ([Paren], Maybe ([Paren], [Paren]))
next ( [Paren]
start , [] ) where 
  start :: [Paren]
start = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ 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
bforall a. a -> [a] -> [a]
:Paren
aforall 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 = forall a. [a] -> [a]
reverse [Paren]
lls forall a. [a] -> [a] -> [a]
++ [Paren]
rrs
    new :: Maybe ([Paren], [Paren])
new = 
      {- debug (reverse ls,l,r,rs) $ -} 
      case Paren
l of 
        Paren
RightParen -> forall a. a -> Maybe a
Just ( [Paren]
ls , Paren
LeftParenforall a. a -> [a] -> [a]
:Paren
RightParenforall a. a -> [a] -> [a]
:[Paren]
rs )
        Paren
LeftParen  -> 
          {- debug ("---",reverse ls,l,r,rs) $ -}
          ([Paren], [Paren])
-> ([Paren], [Paren]) -> Maybe ([Paren], [Paren])
findj ( [Paren]
lls , [] ) ( forall a. [a] -> [a]
reverse (Paren
RightParenforall a. a -> [a] -> [a]
:[Paren]
rs) , [] ) 
  next ([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])
_ = 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
RightParenforall a. a -> [a] -> [a]
:[Paren]
rs ) ( [Paren]
as , Paren
LeftParenforall a. a -> [a] -> [a]
:Paren
aforall a. a -> [a] -> [a]
:[Paren]
ys )
        [Paren]
_ -> ([Paren], [Paren])
-> ([Paren], [Paren]) -> Maybe ([Paren], [Paren])
findj ( [Paren]
lls, [] ) ( forall a. [a] -> [a]
reverse [Paren]
rs forall a. [a] -> [a] -> [a]
++ [Paren]
xs , [Paren]
ys) 
      Paren
RightParen -> forall a. a -> Maybe a
Just ( forall a. [a] -> [a]
reverse [Paren]
ys forall a. [a] -> [a] -> [a]
++ [Paren]
xs forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
reverse (Paren
LeftParenforall a. a -> [a] -> [a]
:[Paren]
rs) forall a. [a] -> [a] -> [a]
++ [Paren]
ls , [] )
  findj ([Paren], [Paren])
_ ([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 :: forall g. RandomGen g => Int -> g -> ([Paren], g)
fasc4A_algorithm_W Int
n' g
rnd = forall g.
RandomGen g =>
(g, Integer, Integer, [Paren]) -> ([Paren], g)
worker (g
rnd,Integer
n,Integer
n,[]) where
  n :: Integer
n = 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 :: forall g.
RandomGen g =>
(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
xforall a. Ord a => a -> a -> Bool
<(Integer
qforall a. Num a => a -> a -> a
+Integer
1)forall a. Num a => a -> a -> a
*(Integer
qforall a. Num a => a -> a -> a
-Integer
p) 
      then forall g.
RandomGen g =>
(g, Integer, Integer, [Paren]) -> ([Paren], g)
worker (g
rnd' , Integer
p   , Integer
qforall a. Num a => a -> a -> a
-Integer
1 , Paren
LeftParen forall a. a -> [a] -> [a]
:[Paren]
parens)
      else forall g.
RandomGen g =>
(g, Integer, Integer, [Paren]) -> ([Paren], g)
worker (g
rnd' , Integer
pforall a. Num a => a -> a -> a
-Integer
1 , Integer
q   , Paren
RightParenforall a. a -> [a] -> [a]
:[Paren]
parens)
    where 
      (Integer
x,g
rnd') = forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR ( Integer
0 , (Integer
qforall a. Num a => a -> a -> a
+Integer
p)forall a. Num a => a -> a -> a
*(Integer
qforall a. Num a => a -> a -> a
-Integer
pforall a. Num a => a -> a -> a
+Integer
1)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 = forall a. [a] -> [a]
reverse 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n' :: Integer
  c0 :: Integer
c0 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {a}. Integral a => a -> a -> a
f Integer
1 [Integer
2..Integer
n]  
  f :: a -> a -> a
f a
c a
p = ((a
4forall a. Num a => a -> a -> a
*a
pforall a. Num a => a -> a -> a
-a
2)forall a. Num a => a -> a -> a
*a
c) forall {a}. Integral a => a -> a -> a
`div` (a
pforall 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 forall a. Ord a => a -> a -> Bool
<= Integer
c' 
      then (Integer, Integer, Integer, Integer, [Paren]) -> [Paren]
worker (Integer
bign    , Integer
c'   , Integer
p   , Integer
qforall a. Num a => a -> a -> a
-Integer
1 , Paren
RightParenforall a. a -> [a] -> [a]
:[Paren]
parens)
      else (Integer, Integer, Integer, Integer, [Paren]) -> [Paren]
worker (Integer
bignforall a. Num a => a -> a -> a
-Integer
c' , Integer
cforall a. Num a => a -> a -> a
-Integer
c' , Integer
pforall a. Num a => a -> a -> a
-Integer
1 , Integer
q   , Paren
LeftParen forall a. a -> [a] -> [a]
:[Paren]
parens)
    where
      c' :: Integer
c' = ((Integer
qforall a. Num a => a -> a -> a
+Integer
1)forall a. Num a => a -> a -> a
*(Integer
qforall a. Num a => a -> a -> a
-Integer
p)forall a. Num a => a -> a -> a
*Integer
c) forall {a}. Integral a => a -> a -> a
`div` ((Integer
qforall a. Num a => a -> a -> a
+Integer
p)forall a. Num a => a -> a -> a
*(Integer
qforall a. Num a => a -> a -> a
-Integer
pforall 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 = forall a. Integral a => a -> a -> Integer
binomial (Int
2forall a. Num a => a -> a -> a
*Int
n) Int
n forall {a}. Integral a => a -> a -> a
`div` (Integer
1 forall a. Num a => a -> a -> a
+ 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 = 
  [ forall a. BinTree a -> BinTree a -> BinTree a
Branch BinTree ()
l BinTree ()
r 
  | Int
i <- [Int
0..Int
nforall a. Num a => a -> a -> a
-Int
1] 
  , BinTree ()
l <- Int -> [BinTree ()]
binaryTreesNaive Int
i 
  , BinTree ()
r <- Int -> [BinTree ()]
binaryTreesNaive (Int
nforall a. Num a => a -> a -> a
-Int
1forall 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 :: forall g. RandomGen g => Int -> g -> (BinTree (), g)
randomBinaryTree Int
n g
rnd = (BinTree ()
tree,g
rnd') where
  (BinTree' Int Int
decorated,g
rnd') = forall g. RandomGen g => Int -> g -> (BinTree' Int Int, g)
fasc4A_algorithm_R Int
n g
rnd      
  tree :: BinTree ()
tree = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const ()) forall a b. (a -> b) -> a -> b
$ 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 :: forall g. RandomGen g => 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 a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
    STUArray s Int Int
ar <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0,Int
2forall a. Num a => a -> a -> a
*Int
n0) Int
0
    g
rnd' <- 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 <- 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
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall {i}. (Integral i, Ix i) => Array i i -> BinTree' i i
toTree Array Int Int
links, g
rnd')
  toTree :: Array i i -> BinTree' i i
toTree Array i i
links = i -> BinTree' i i
f (Array i i
linksforall i e. Ix i => Array i e -> i -> e
!i
0) where
    f :: i -> BinTree' i i
f i
i = if forall a. Integral a => a -> Bool
odd i
i 
      then forall a b. BinTree' a b -> b -> BinTree' a b -> BinTree' a b
Branch' (i -> BinTree' i i
f forall a b. (a -> b) -> a -> b
$ Array i i
linksforall i e. Ix i => Array i e -> i -> e
!i
i) i
i (i -> BinTree' i i
f forall a b. (a -> b) -> a -> b
$ Array i i
linksforall i e. Ix i => Array i e -> i -> e
!(i
iforall a. Num a => a -> a -> a
+i
1)) 
      else forall a b. a -> BinTree' a b
Leaf' i
i  
  worker :: RandomGen g => g -> Int -> STUArray s Int Int -> ST s g
  worker :: forall g s. RandomGen g => g -> Int -> STUArray s Int Int -> ST s g
worker g
rnd Int
n STUArray s Int Int
ar = do 
    if Int
n forall a. Ord a => a -> a -> Bool
> Int
n0
      then forall (m :: * -> *) a. Monad m => a -> m a
return g
rnd
      else do
        forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
ar (Int
n2forall a. Num a => a -> a -> a
-Int
b)   Int
n2
        Int
lk <- 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
        forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
ar (Int
n2forall a. Num a => a -> a -> a
-Int
1forall a. Num a => a -> a -> a
+Int
b) Int
lk
        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
n2forall a. Num a => a -> a -> a
-Int
1)
        forall g s. RandomGen g => g -> Int -> STUArray s Int Int -> ST s g
worker g
rnd' (Int
nforall a. Num a => a -> a -> a
+Int
1) STUArray s Int Int
ar      
    where  
      n2 :: Int
n2 = Int
nforall a. Num a => a -> a -> a
+Int
n
      (Int
x,g
rnd') = forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0,Int
4forall a. Num a => a -> a -> a
*Int
nforall a. Num a => a -> a -> a
-Int
3) g
rnd
      (Int
k,Int
b) = Int
x 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_ :: forall a. BinTree a -> ASCII
asciiBinaryTree_ = [String] -> ASCII
ASCII.asciiFromLines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. BinTree a -> ([String], Int)
go where

  go :: BinTree a -> ([String],Int)
  go :: forall a. BinTree a -> ([String], Int)
go (Leaf a
x) = ([],Int
0)
  go (Branch BinTree a
t1 BinTree a
t2) = ( [String]
new , Int
j1forall a. Num a => a -> a -> a
+Int
m ) where
    ([String]
ls1,Int
j1) = forall a. BinTree a -> ([String], Int)
go BinTree a
t1
    ([String]
ls2,Int
j2) = forall a. BinTree a -> ([String], Int)
go BinTree a
t2
    w1 :: Int
w1 = forall {t :: * -> *} {a}. Foldable t => [t a] -> Int
blockWidth [String]
ls1
    w2 :: Int
w2 = forall {t :: * -> *} {a}. Foldable t => [t a] -> Int
blockWidth [String]
ls2
    m :: Int
m = forall a. Ord a => a -> a -> a
max Int
1 forall a b. (a -> b) -> a -> b
$ (Int
w1forall a. Num a => a -> a -> a
-Int
j1forall a. Num a => a -> a -> a
+Int
j2forall a. Num a => a -> a -> a
+Int
2) forall {a}. Integral a => a -> a -> a
`div` Int
2
    s :: Int
s = Int
2forall a. Num a => a -> a -> a
*Int
m forall a. Num a => a -> a -> a
- (Int
w1forall a. Num a => a -> a -> a
-Int
j1forall a. Num a => a -> a -> a
+Int
j2)
    spaces :: [String]
spaces = [forall a. Int -> a -> [a]
replicate Int
s Char
' ']
    ls :: [String]
ls = [[String]] -> [String]
hConcatLines [ [String]
ls1 , [String]
spaces , [String]
ls2 ]
    top :: [String]
top = [ forall a. Int -> a -> [a]
replicate (Int
j1forall a. Num a => a -> a -> a
+Int
mforall a. Num a => a -> a -> a
-Int
i) Char
' ' forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
2forall a. Num a => a -> a -> a
*(Int
iforall a. Num a => a -> a -> a
-Int
1)) Char
' ' forall a. [a] -> [a] -> [a]
++ String
"\\" | Int
i<-[Int
1..Int
m] ]
    new :: [String]
new = [String] -> [String]
mkLinesUniformWidth 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]
_) -> forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
l
    []    -> Int
0

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

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