catalans.hs

{-# OPTIONS_GHC -Wall #-}

import Control.Monad(join)
import Data.List(foldl', permutations, sort)
import System.Environment(getArgs)

factorial ::
  Integer
  -> Integer
factorial n =
  foldl' (*) 1 [1..n]

-- https://en.wikipedia.org/wiki/Catalan_number
catalan ::
  Integer
  -> Integer
catalan n =
  factorial (2 * n) `div` (join (*) (factorial n) * (n + 1))

isos ::
  Integer
  -> Integer
isos n =
  factorial n * catalan (n - 1)

listof ::
  [(String, String, String, String)]
listof =
  map (\n -> ("n: " ++ show n, "n!: " ++ show (factorial n), "C(n): " ++ show (catalan n), "n! * C(n): " ++ show (isos n)))
    [1..]

main ::
  IO ()
main =
  do  args <- getArgs
      case args of
        [] ->
          putStrLn "enter an argument"
        h:_ ->
          case reads h of
            (n, _):_ ->
              mapM_ (\(a, b, c, d) -> putStrLn (a ++ "      " ++ b ++ "      " ++ c ++ "      " ++ d)) (take n listof)
            _ ->
              putStrLn "the argument is not an Int"

----

data Tree a =
  Leaf a
  | Node (Tree a) (Tree a)
  deriving (Eq, Ord, Show)

instance Functor Tree where
  fmap f (Leaf a) =
    Leaf (f a)
  fmap f (Node x y) =
    Node (fmap f x) (fmap f y)

instance Applicative Tree where
  pure =
    Leaf
  Leaf f <*> x =
    fmap f x
  Node x y <*> r =
    Node (x <*> r) (y <*> r)

instance Monad Tree where
  return =
    Leaf
  Leaf a >>= f =
    f a
  Node x y >>= f =
    Node (x >>= f) (y >>= f)

{-
> let r = func [1,2,3] in mapM_ (putStrLn . printTree) r
{1 {2 3}}
{{1 2} 3}
{2 {1 3}}
{{2 1} 3}
{3 {2 1}}
{{3 2} 1}
{2 {3 1}}
{{2 3} 1}
{3 {1 2}}
{{3 1} 2}
{1 {3 2}}
{{1 3} 2}
-}
printTree ::
  Show a =>
  Tree a
  -> String
printTree (Leaf a) =
  show a
printTree (Node x y) =
  concat
    [
      "{"
    , printTree x
    , " "
    , printTree y
    , "}"
    ]
leafpair ::
  a
  -> a
  -> Tree a
leafpair a b =
  Node (Leaf a) (Leaf b)

-- $setup
-- >>> import Data.List(length)

-- | Given a list of values, generate all unique full binary trees (data in leaves).
--
-- prop> \x -> not (null x) ==> let r = {- big lists take a while -} take 5 x in toInteger (length (func r)) == isos (toInteger (length r))

func ::
  [a]
  -> [Tree a]
func r =
  permutations r >>= tree

tree ::
  [a]
  -> [Tree a]
tree [a] =
  [Leaf a]
tree x =
  let -- this is gross
      parts q = zipWith (\n -> (const . splitAt n) q) [0..] q
  in  parts x >>= (\(q, r) -> Node <$> tree q <*> tree r)

-- |
--
-- prop> functest1
functest1 ::
  Ord a =>
  a
  -> Bool
functest1 a =
  let expect =
        [Leaf a]
      actual =
        func [a]
  in  expect .==. actual

-- |
--
-- prop> functest2
functest2 ::
  Ord a =>
  a
  -> a
  -> Bool
functest2 a b =
  let expect =
        [
          leafpair a b
        , leafpair b a
        ]
      actual =
        func [a, b]
  in  expect .==. actual

-- |
--
-- prop> functest3
functest3 ::
  Ord a =>
  a
  -> a
  -> a
  -> Bool
functest3 a b c =
  let expect =
        [
          Node (leafpair a b) (Leaf c)
        , Node (leafpair a c) (Leaf b)
        , Node (leafpair b c) (Leaf a)
        , Node (leafpair b a) (Leaf c)
        , Node (leafpair c a) (Leaf b)
        , Node (leafpair c b) (Leaf a)
        , Node (Leaf a) (leafpair b c)
        , Node (Leaf a) (leafpair c b)
        , Node (Leaf b) (leafpair c a)
        , Node (Leaf b) (leafpair a c)
        , Node (Leaf c) (leafpair a b)
        , Node (Leaf c) (leafpair b a)
        ]
      actual =
        func [a, b, c]
  in  expect .==. actual

-- |
--
-- prop> functest4
functest4 ::
  Ord a =>
  a
  -> a
  -> a
  -> a
  -> Bool
functest4 a b c d =
  let expect =
        [
          Node (Node (leafpair a b) (Leaf c)) (Leaf d)
        , Node (Leaf a) (Node (Leaf b) (leafpair c d))
        , Node (Node (Leaf a) (leafpair b c)) (Leaf d)
        , Node (Leaf a) (Node (leafpair b c) (Leaf d))
        , Node (leafpair a b) (leafpair c d)
        , Node (Node (leafpair b a) (Leaf c)) (Leaf d)
        , Node (Leaf b) (Node (Leaf a) (leafpair c d))
        , Node (Node (Leaf b) (leafpair a c)) (Leaf d)
        , Node (Leaf b) (Node (leafpair a c) (Leaf d))
        , Node (leafpair b a) (leafpair c d)
        , Node (Node (leafpair c b) (Leaf a)) (Leaf d)
        , Node (Leaf c) (Node (Leaf b) (leafpair a d))
        , Node (Node (Leaf c) (leafpair b a)) (Leaf d)
        , Node (Leaf c) (Node (leafpair b a) (Leaf d))
        , Node (leafpair c b) (leafpair a d)
        , Node (Node (leafpair b c) (Leaf a)) (Leaf d)
        , Node (Leaf b) (Node (Leaf c) (leafpair a d))
        , Node (Node (Leaf b) (leafpair c a)) (Leaf d)
        , Node (Leaf b) (Node (leafpair c a) (Leaf d))
        , Node (leafpair b c) (leafpair a d)
        , Node (Node (leafpair c a) (Leaf b)) (Leaf d)
        , Node (Leaf c) (Node (Leaf a) (leafpair b d))
        , Node (Node (Leaf c) (leafpair a b)) (Leaf d)
        , Node (Leaf c) (Node (leafpair a b) (Leaf d))
        , Node (leafpair c a) (leafpair b d)
        , Node (Node (leafpair a c) (Leaf b)) (Leaf d)
        , Node (Leaf a) (Node (Leaf c) (leafpair b d))
        , Node (Node (Leaf a) (leafpair c b)) (Leaf d)
        , Node (Leaf a) (Node (leafpair c b) (Leaf d))
        , Node (leafpair a c) (leafpair b d)
        , Node (Node (leafpair d c) (Leaf b)) (Leaf a)
        , Node (Leaf d) (Node (Leaf c) (leafpair b a))
        , Node (Node (Leaf d) (leafpair c b)) (Leaf a)
        , Node (Leaf d) (Node (leafpair c b) (Leaf a))
        , Node (leafpair d c) (leafpair b a)
        , Node (Node (leafpair c d) (Leaf b)) (Leaf a)
        , Node (Leaf c) (Node (Leaf d) (leafpair b a))
        , Node (Node (Leaf c) (leafpair d b)) (Leaf a)
        , Node (Leaf c) (Node (leafpair d b) (Leaf a))
        , Node (leafpair c d) (leafpair b a)
        , Node (Node (leafpair c b) (Leaf d)) (Leaf a)
        , Node (Leaf c) (Node (Leaf b) (leafpair d a))
        , Node (Node (Leaf c) (leafpair b d)) (Leaf a)
        , Node (Leaf c) (Node (leafpair b d) (Leaf a))
        , Node (leafpair c b) (leafpair d a)
        , Node (Node (leafpair d b) (Leaf c)) (Leaf a)
        , Node (Leaf d) (Node (Leaf b) (leafpair c a))
        , Node (Node (Leaf d) (leafpair b c)) (Leaf a)
        , Node (Leaf d) (Node (leafpair b c) (Leaf a))
        , Node (leafpair d b) (leafpair c a)
        , Node (Node (leafpair b d) (Leaf c)) (Leaf a)
        , Node (Leaf b) (Node (Leaf d) (leafpair c a))
        , Node (Node (Leaf b) (leafpair d c)) (Leaf a)
        , Node (Leaf b) (Node (leafpair d c) (Leaf a))
        , Node (leafpair b d) (leafpair c a)
        , Node (Node (leafpair b c) (Leaf d)) (Leaf a)
        , Node (Leaf b) (Node (Leaf c) (leafpair d a))
        , Node (Node (Leaf b) (leafpair c d)) (Leaf a)
        , Node (Leaf b) (Node (leafpair c d) (Leaf a))
        , Node (leafpair b c) (leafpair d a)
        , Node (Node (leafpair d a) (Leaf b)) (Leaf c)
        , Node (Leaf d) (Node (Leaf a) (leafpair b c))
        , Node (Node (Leaf d) (leafpair a b)) (Leaf c)
        , Node (Leaf d) (Node (leafpair a b) (Leaf c))
        , Node (leafpair d a) (leafpair b c)
        , Node (Node (leafpair a d) (Leaf b)) (Leaf c)
        , Node (Leaf a) (Node (Leaf d) (leafpair b c))
        , Node (Node (Leaf a) (leafpair d b)) (Leaf c)
        , Node (Leaf a) (Node (leafpair d b) (Leaf c))
        , Node (leafpair a d) (leafpair b c)
        , Node (Node (leafpair a b) (Leaf d)) (Leaf c)
        , Node (Leaf a) (Node (Leaf b) (leafpair d c))
        , Node (Node (Leaf a) (leafpair b d)) (Leaf c)
        , Node (Leaf a) (Node (leafpair b d) (Leaf c))
        , Node (leafpair a b) (leafpair d c)
        , Node (Node (leafpair d b) (Leaf a)) (Leaf c)
        , Node (Leaf d) (Node (Leaf b) (leafpair a c))
        , Node (Node (Leaf d) (leafpair b a)) (Leaf c)
        , Node (Leaf d) (Node (leafpair b a) (Leaf c))
        , Node (leafpair d b) (leafpair a c)
        , Node (Node (leafpair b d) (Leaf a)) (Leaf c)
        , Node (Leaf b) (Node (Leaf d) (leafpair a c))
        , Node (Node (Leaf b) (leafpair d a)) (Leaf c)
        , Node (Leaf b) (Node (leafpair d a) (Leaf c))
        , Node (leafpair b d) (leafpair a c)
        , Node (Node (leafpair b a) (Leaf d)) (Leaf c)
        , Node (Leaf b) (Node (Leaf a) (leafpair d c))
        , Node (Node (Leaf b) (leafpair a d)) (Leaf c)
        , Node (Leaf b) (Node (leafpair a d) (Leaf c))
        , Node (leafpair b a) (leafpair d c)
        , Node (Node (leafpair d a) (Leaf c)) (Leaf b)
        , Node (Leaf d) (Node (Leaf a) (leafpair c b))
        , Node (Node (Leaf d) (leafpair a c)) (Leaf b)
        , Node (Leaf d) (Node (leafpair a c) (Leaf b))
        , Node (leafpair d a) (leafpair c b)
        , Node (Node (leafpair a d) (Leaf c)) (Leaf b)
        , Node (Leaf a) (Node (Leaf d) (leafpair c b))
        , Node (Node (Leaf a) (leafpair d c)) (Leaf b)
        , Node (Leaf a) (Node (leafpair d c) (Leaf b))
        , Node (leafpair a d) (leafpair c b)
        , Node (Node (leafpair a c) (Leaf d)) (Leaf b)
        , Node (Leaf a) (Node (Leaf c) (leafpair d b))
        , Node (Node (Leaf a) (leafpair c d)) (Leaf b)
        , Node (Leaf a) (Node (leafpair c d) (Leaf b))
        , Node (leafpair a c) (leafpair d b)
        , Node (Node (leafpair d c) (Leaf a)) (Leaf b)
        , Node (Leaf d) (Node (Leaf c) (leafpair a b))
        , Node (Node (Leaf d) (leafpair c a)) (Leaf b)
        , Node (Leaf d) (Node (leafpair c a) (Leaf b))
        , Node (leafpair d c) (leafpair a b)
        , Node (Node (leafpair c d) (Leaf a)) (Leaf b)
        , Node (Leaf c) (Node (Leaf d) (leafpair a b))
        , Node (Node (Leaf c) (leafpair d a)) (Leaf b)
        , Node (Leaf c) (Node (leafpair d a) (Leaf b))
        , Node (leafpair c d) (leafpair a b)
        , Node (Node (leafpair c a) (Leaf d)) (Leaf b)
        , Node (Leaf c) (Node (Leaf a) (leafpair d b))
        , Node (Node (Leaf c) (leafpair a d)) (Leaf b)
        , Node (Leaf c) (Node (leafpair a d) (Leaf b))
        , Node (leafpair c a) (leafpair d b)
        ]
      actual =
        func [a, b, c, d]
  in  expect .==. actual

(.==.) ::
  Ord a =>
  [a]
  -> [a]
  -> Bool
x .==. y =
  sort x == sort y

---- addendum

-- | This implementation is gross. Make it better?
--
-- >>> parts' []
-- []
--
-- parts' [1]
-- [([],[1])]
--
-- parts' [1,2]
-- [([],[1,2]),([1],[2])]
--
-- >>> parts' [1,2,3]
-- [([],[1,2,3]),([1],[2,3]),([1,2],[3])]
--
-- >>> parts' [1,2,3,4]
-- [([],[1,2,3,4]),([1],[2,3,4]),([1,2],[3,4]),([1,2,3],[4])]
--
-- >>> parts' [1,2,3,4,5]
-- [([],[1,2,3,4,5]),([1],[2,3,4,5]),([1,2],[3,4,5]),([1,2,3],[4,5]),([1,2,3,4],[5])]
parts' ::
  [a]
  -> [([a], [a])]
parts' q =
  zipWith (\n -> (const . splitAt n) q) [0..] q

{-

mkNode4 =
  let r = permutations "abcd"
      s (a, b, c, d) =
        [
          "Node (Node (leafpair " ++ a ++ " " ++ b ++ ") (Leaf " ++ c ++ ")) (Leaf " ++ d ++ ")"
        , "Node (Leaf " ++ a ++ ") (Node (Leaf " ++ b ++ ") (leafpair " ++ c ++ " " ++ d ++ "))"
        , "Node (Node (Leaf " ++ a ++ ") (leafpair " ++ b ++ " " ++ c ++ ")) (Leaf " ++ d ++ ")"
        , "Node (Leaf " ++ a ++ ") (Node (leafpair " ++ b ++ " " ++ c ++ ") (Leaf " ++ d ++ "))"
        , "Node (leafpair " ++ a ++ " " ++ b ++ ") (leafpair " ++ c ++ " " ++ d ++ ")"
        ]
  in  intercalate "\n, " (r >>= \[a, b, c, d] -> s ([a], [b], [c], [d]))
-}

{-

data ListDerivative a =
  ListDerivative [a] [a]
  deriving (Eq, Show)

toListDerivative ::
  [a]
  -> ListDerivative a
toListDerivative =
  ListDerivative []

moveRight ::
  ListDerivative a 
  -> Maybe (ListDerivative a)
moveRight (ListDerivative _ []) =
  Nothing
moveRight (ListDerivative x (h:t)) =
  Just (ListDerivative (h:x) t)

moveLeft ::
  ListDerivative a 
  -> Maybe (ListDerivative a)
moveLeft (ListDerivative [] _) =
  Nothing
moveLeft (ListDerivative (h:t) x) =
  Just (ListDerivative t (h:x))

instance Functor ListDerivative where
  fmap f (ListDerivative x y) =
    ListDerivative (fmap f x) (fmap f y)

instance Foldable ListDerivative where
  foldMap f (ListDerivative x y) =
    foldMap f (reverse x ++ y)

duplicateListDerivative ::
  ListDerivative a
  -> ListDerivative (ListDerivative a)
duplicateListDerivative =
  extendListDerivative id

extendListDerivative ::
  (ListDerivative a -> b)
  -> ListDerivative a
  -> ListDerivative b
extendListDerivative k r@(ListDerivative x y) =
  let dups q =
        unfoldr (fmap (k >>= (,)) . q) r
  in  ListDerivative
        (dups moveLeft)
        (dups moveRight)

pairListDerivative ::
  ListDerivative a
  -> ([a], [a])
pairListDerivative =
  foldListDerivative (,)

modifyLeftListDerivative ::
  ([a] -> [a])
  -> ListDerivative a
  -> ListDerivative a
modifyLeftListDerivative k (ListDerivative x y) =
  ListDerivative (k x) y

modifyRightListDerivative ::
  ([a] -> [a])
  -> ListDerivative a
  -> ListDerivative a
modifyRightListDerivative k (ListDerivative x y) =
  ListDerivative x (k y)

foldListDerivative ::
  ([a] -> [a] -> b)
  -> ListDerivative a
  -> b
foldListDerivative k (ListDerivative x y) =
  k x y

swapListDerivative ::
  ListDerivative a
  -> ListDerivative a
swapListDerivative (ListDerivative x y) =
  ListDerivative y x
-}