module NinetyNineProblems where

import           Control.Arrow
import           Control.Monad
import           Data.Function
import           Data.List
import           Data.Maybe
import           Data.Ord
import qualified Data.Tree     as T
import           System.Random

-- Find the last element of a list.
myLast :: [a] -> a
myLast = foldl (\_ x -> x) lastError
    where lastError = error "empty list"

-- Find the last but one element of a list
myButLast :: [a] -> a
myButLast = head . tail . reverse

-- Find the number K element of a list.
-- The first element in the list is number 1.
elementAt :: [a] -> Int -> a
elementAt list i = list !! (i-1)

-- Find the number of elements of a list.
myLength :: [a] -> Int
myLength []     = 0
myLength (_:xs) = 1 + myLength xs

-- Reverse a list.
myReverse :: [a] -> [a]
myReverse = foldl (flip (:)) []

-- Find out whether a list a palindrome.
-- A palindrome can be read forward or backward.
isPalindrome :: Eq a => [a] -> Bool
isPalindrome xs = xs == reverse xs

-- Flatten a nested list structure.
data NestedList a = Elem a | List [NestedList a]
flatten :: NestedList a -> [a]
flatten (Elem x ) = [x]
flatten (List xs) = foldr ((++) . flatten) [] xs

-- Eliminate consecutive duplicates of list elements.
compress :: Eq a => [a] -> [a]
compress (x:ys@(y:_))
    | x == y    = compress ys
    | otherwise = x : compress ys
compress ys = ys

-- Pack consecutive duplicates of list elements into sub-lists.
-- If a list contains repeated elements,
-- they should be placed in separate sub-lists.
pack :: Eq a => [a] -> [[a]]
pack []     = []
pack (x:xs) = (x:ys) : pack zs
    where (ys,zs) = span (==x) xs

-- Run-length encoding of a list.
-- Consecutive duplicates of elements are encoded as lists (N E)
-- where N is the number of duplicates of the elements E.
encode :: Eq a => [a] -> [(Int, a)]
encode = map (length &&& head) . pack

-- Modified run-length encoding.
-- Only elements with duplicates are transferred as (N E) lists.
data ListItem a = Single a | Multiple Int a
                  deriving (Show)
encodeModified :: Eq a => [a] -> [ListItem a]
encodeModified = map encodeHelper . encode
    where encodeHelper (1,x) = Single x
          encodeHelper (n,x) = Multiple n x

-- Decode a run-length encoded list.
decodeModified :: [ListItem a] -> [a]
decodeModified = concatMap decodeHelper
    where decodeHelper (Single i)     = [i]
          decodeHelper (Multiple n i) = replicate n i

-- Yet another modified run-length encoding of a list.
-- Simplify the result list by replacing the singleton list (1 X) by X.
encodeDirect :: Eq a => [a] -> [ListItem a]
encodeDirect [] = []
encodeDirect (x:xs)
    | count == 1 = Single x         : encodeDirect xs
    | otherwise  = Multiple count x : encodeDirect rest
    where (matched, rest) = span (==x) xs
          count = 1 + length matched

-- Duplicate the elements of a list.
dupli :: [a] -> [a]
dupli []     = []
dupli (x:xs) = x:x:dupli xs

-- Replicate the elements of a list a given number of times.
repli :: [a] -> Int -> [a]
repli = flip $ concatMap . replicate

-- Drop every # N element from a list.
dropEvery :: [a] -> Int -> [a]
dropEvery [] _ = []
dropEvery l n  = take (n-1) l ++ dropEvery (drop n l) n

-- Split a list into two parts;
-- the length of the first part is given.
split :: [a] -> Int -> [[a]]
split l n = take n l : [drop (n+1) l]

-- Extract a slice from a list.
slice :: [a] -> Int -> Int -> [a]
slice l b e = drop (b-1) $ take e l

-- Rotate a list N places to the left.
rotate :: [a] -> Int -> [a]
rotate l o -- TODO: figure out why this is non-exhaustive
    | o >= 0 = drop o l ++ take o l
    | o < 0  = drop (length l + o) l ++ take (length l + o) l

-- Remove the # K element from a list.
removeAt :: Int -> [a] -> [a]
removeAt n l = take (n-1) l ++ drop n l

-- Insert an element at a given position into a list.
insertAt :: a -> [a] -> Int -> [a]
insertAt x xs i = take (i-1) xs ++ x : drop (i-1) xs

-- Create a list containing all integers within a given range.
range :: Int -> Int -> [Int]
range a b = [a..b]

-- Extract a given number of randomly selected elements from a list.
rndSelect :: [a] -> Int -> IO [a]
rndSelect l n = map (l !!) <$> indices
    where indices = take n . nub . randomRs (0, length l - 1) <$> getStdGen

-- Draw N different random numbers from the set 1..M.
diffSelect :: Int -> Int -> IO [Int]
diffSelect n m = take n . nub . randomRs (1, m) <$> getStdGen

-- Generate a random permutation of the elements of a list.
rndPermu :: [a] -> IO [a]
rndPermu l = rndSelect l $ length l

-- Generate the combinations of K distinct objects
-- chosen from the N elements of a list.
combinations :: Int -> [a] -> [[a]]
combinations k l = filter ((k==) . length) (subsequences l)

-- Group the elements of a set into disjoint subsets.
combination :: Int -> [a] -> [([a],[a])]
combination 0 xs = [([],xs)]
combination _ [] = []
combination n (x:xs) = ts ++ ds
    where ts = [ (x:ys,zs) | (ys,zs) <- combination (n-1) xs ]
          ds = [ (ys,x:zs) | (ys,zs) <- combination n xs ]

myGroup :: [Int] -> [a] -> [[[a]]]
myGroup [] _      = [[]]
myGroup (n:ns) xs = [ g:gs | (g,rs) <- combination n xs, gs <- myGroup ns rs]

-- Sorting a list of lists according to length of sub-lists.
lsort :: [[a]] -> [[a]]
lsort = sortOn length

-- Sorting a list of lists according to their length frequency.
lfsort :: [[a]] -> [[a]]
lfsort = concat . lsort . groupBy ((==) `on` length) . lsort

-- Determine whether a given integer number is prime.
isPrime :: (Integral a) => a -> Bool
isPrime n | n < 4 = n > 1
isPrime n         = all ((/=0) . mod n) $ 2:3:[x + i | x <- [6,12..s], i <- [-1,1]]
    where s = floor $ sqrt $ fromIntegral n

-- Determine the greatest common divisor of two positive integer numbers.
myGCD :: Int -> Int -> Int
myGCD a 0 = abs a
myGCD a b = myGCD b (a `mod` b)

-- Determine whether two positive integer numbers are coprime.
-- Two numbers are coprime if their greatest common divisor equals 1.
coprime :: Int -> Int -> Bool
coprime a b = gcd a b == 1

-- Calculate Euler's totient function.
-- Euler's totient function is defined as the number of positive integers
-- that are coprime to m.
totient :: Int -> Int
totient n = length [ x | x <- [1..n], coprime x n]

-- Determine the prime factors of a given positive integer.
-- Construct a flat lists containing the prime factor in ascending order.
primeFactors :: Integral a => a -> [a]
primeFactors 1 = []
primeFactors n = let divisors = dropWhile ((/=0) . mod n) [2..ceiling $ sqrt $ fromIntegral n]
                 in let prime = if null divisors then n else head divisors
                    in (prime :) $ primeFactors $ div n prime

-- Determine the prime factors of a given positive integer.
-- Construct a list containing the prime factors and their multiplicity.
primeFactorsMult :: Integral a => a -> [(a, Int)]
primeFactorsMult n = map swap $ encode $ primeFactors n
    where swap (x,y) = (y,x)

-- Calculate Euler's totient function (improved).
-- If the list of the prime factors of a number m is known
-- in the from of prime factors and their multiplicity.
-- i.e. (p1 m1) (p2 m2) (p3 m3) ...
-- The totient can be calculated with the following formula:
-- phi(m) = (p1 - 1) * p1 ** (m1 - 1) *
--          (p2 - 1) * p2 ** (m2 - 1) *
--          (p3 - 1) * p3 ** (m3 - 1) * ...
totientImproved :: Integral a => a -> a
totientImproved m = product [(p-1) * p ^ (c-1) | (p,c) <- primeFactorsMult m]

-- A list of prime numbers.
-- Given a range of integers by its lower and upper limit,
-- construct a list of all prime numbers in that range.
primesR :: Integral a => a -> a -> [a]
primesR a b = takeWhile (<=b) $ dropWhile (<a) $ filter isPrime [1..]

-- Goldbach's conjecture.
-- Goldbach's conjecture says
-- that every positive even number greater than 2
-- is the sum of two prime numbers.
goldbach :: Integral p => p -> [(p, p)]
goldbach n = halve [ (x,y) | x <- pr, y <- pr, x+y==n ]
    where pr = primesR 2 (n-2)
          halve xs = take (l `div` 2) xs
              where l = length xs

-- Given a range of integers by its lower and upper limit,
-- print a list of all even numbers and their Goldbach composition.
goldbachList :: Integral p => p -> p -> [(p, p)]
goldbachList n m = concatMap goldbach $ dropWhile (<4) $ filter even [n..m]

goldbachList' :: Integral a => a -> a -> a -> [(a, a)]
goldbachList' n m i = filter (\(x,y) -> x > i && y > i) $ goldbachList n m

-- Define predicates and', or', nand', nor', xor', impl' and equ'
-- Then write a function which prints the truth table
-- of a given logical expression in two variables.
not' :: Bool -> Bool
not' True  = False
not' False = True

and' :: Bool -> Bool -> Bool
and' True True = True
and' _ _       = False

or' :: Bool -> Bool -> Bool
or' False False = False
or' _ _         = True

nand' :: Bool -> Bool -> Bool
nand' a b = not' $ and' a b

nor' :: Bool -> Bool -> Bool
nor' False False = True
nor' a b         = not' $ or' a b

xor' :: Bool -> Bool -> Bool
xor' True False = True
xor' False True = True
xor' _ _        = False

impl' :: Bool -> Bool -> Bool
impl' a b = not' a `or'` b

equ' :: Bool -> Bool -> Bool
equ' True True   = True
equ' False False = True
equ' _ _         = False

table :: Show a => (Bool -> Bool -> a) -> IO ()
table f = mapM_ putStrLn [show a ++ " " ++ show b ++ " " ++ show (f a b)
                         | a <- [True, False], b <- [True, False]]

-- Generalize the above problem in such a way
-- that the logical expression may contain any number of logical variables.
infixl 4 `or'`
infixl 4 `nor'`
infixl 5 `xor'`
infixl 6 `and'`
infixl 6 `nand'`
infixl 7 `equ'`

tablen :: Show a => Int -> ([Bool] -> a) -> IO ()
tablen n f = mapM_ putStrLn [toStr a ++ " => " ++ show (f a) | a <- args n]
    where args x      = replicateM x [True, False]
          toStr       = unwords . map (\x -> show x ++ space x)
          space True  = "  "
          space False = " "

-- An n-bit Gray code is a sequence of n-bit strings
-- constructed according to certain rules.
gray :: Integral a => a -> [String]
gray 0 = [""]
gray n = foldr (\s acc -> ("0" ++ s):("1" ++ s):acc) [] $ gray (n-1)

-- We suppose a set of symbols with their frequencies,
-- given as a list of fr(S,F) terms.
-- Our objective is to construct a list hc(S,C) terms,
-- where C is the Huffman code word for the symbol S.
-- The task shall be performed by the function defined
-- as follows: huffman(Fs,Hs) where Hs is the Huffman code table
-- for the frequency table Fs
data HTree a = Leaf a | HBranch (HTree a) (HTree a)
               deriving Show

huffman :: (Ord a1, Ord a2, Num a1) => [(a2, a1)] -> [(a2, String)]
huffman freq = sortBy (comparing fst) $ serialize $
               htree $ sortBy (comparing fst) [(w, Leaf x) | (x,w) <- freq]
    where htree [(_, t)] = t
          htree ((w1,t1):(w2,t2):wts) =
              htree $ insertBy (comparing fst) (w1 + w2, HBranch t1 t2) wts
          serialize (HBranch l r) =
              [(x, '0':code) | (x, code) <- serialize l] ++
              [(x, '1':code) | (x, code) <- serialize r]
          serialize (Leaf x) = [(x, "")]

-- A binary tree is either empty or it is composed of a root element
-- and two successors, which are binary trees themselves.
data Tree a = Empty | Branch a (Tree a) (Tree a)
              deriving (Show, Eq)
leaf :: a -> Tree a
leaf x = Branch x Empty Empty

-- Construct completely balanced binary trees.
-- The number of nodes in its left sub-tree
-- and the number of nodes in its right sub-tree are almost equal,
-- which means their difference is not greater than one.
-- Write a function to construct completely balanced binary trees
-- for a given number of nodes.
-- The function should generate all solutions via backtracking.
-- Put the letter 'x' as information into all nodes of the tree.
cbalTree :: Integral a => a -> [Tree Char]
cbalTree 0 = [Empty]
cbalTree 1 = [leaf 'x']
cbalTree n = if odd n
             then [ Branch 'x' l r | l <- cbalTree ((n-1) `div` 2),
                    r <- cbalTree ((n-1) `div` 2) ]
             else concat [ [Branch 'x' l r, Branch 'x' r l] | l <- cbalTree ((n-1) `div` 2),
                           r <- cbalTree (n `div` 2)]

-- Symmetric binary trees
-- Let us call a binary tree symmetric
-- if you can draw a vertical line through the root node
-- and then the right sub-tree is the mirror image of the left sub-tree.
-- Write a function to check whether a given binary tree is symmetric.
symmetric :: Tree a -> Bool
symmetric t = mirror t t
    where mirror Empty          Empty          = True
          mirror (Branch _ a b) (Branch _ x y) = mirror a y && mirror b x
          mirror _              _              = False

-- Binary search trees
-- Write a function to construct a binary search tree
-- from a list of integer numbers.
construct :: (Ord a, Foldable t) => t a -> Tree a
construct = foldl (flip add) Empty
    where add x Empty = Branch x Empty Empty
          add x t@(Branch y l r) = case compare x y of
                                     LT -> Branch y (add x l) r
                                     GT -> Branch y l (add x r)
                                     EQ -> t

-- Construct all symmetric,
-- completely balanced binary trees with a given number of nodes.
symCbalTrees :: Integral a => a -> [Tree Char]
symCbalTrees n = if even n then [] else
                     [ Branch 'x' t (reverseTree t) | t <- cbalTree (n `div` 2) ]
    where reverseTree Empty = Empty
          reverseTree (Branch x l r) = Branch x (reverseTree r) (reverseTree l)

-- In a height-balanced binary tree,
-- the following property holds for every node:
-- The height of its left sub-tree
-- and the height of its right sub-tree are almost equal,
-- which means their difference is not greater than one.
-- Construct a list of all height-balanced binary trees
-- with the given element and the given maximum height.
hbalTree :: a -> Int -> [Tree a]
hbalTree x h = trees !! h
    where trees = [Empty] : [leaf x] :
                  zipWith combine (tail trees) trees
          combine ts shortts = [Branch x l r |
                               (ls, rs) <- [(shortts, ts), (ts, ts), (ts, shortts)],
                               l <- ls, r <- rs]

-- Construct height-balanced binary trees with a given number of nodes.
hbalTreeNodes :: a -> Int -> [Tree a]
hbalTreeNodes _ 0 = [Empty]
hbalTreeNodes x n = concatMap toFilteredTrees [minHeight .. maxHeight]
    where toFilteredTrees = filter ((n ==) . countNodes) . hbalTree x

          -- Similar to the Fibonacci sequence but adds 1 in each step.
          minNodesSeq = 0:1:zipWith ((+).(1+)) minNodesSeq (tail minNodesSeq)

          minHeight = ceiling $ logBase 2 $ fromIntegral (n+1)
          maxHeight = fromJust (findIndex (>n) minNodesSeq) - 1

          countNodes Empty          = 0
          countNodes (Branch _ l r) = countNodes l + countNodes r + 1

-- Count the leaves of a binary tree
-- A leaf is a node with no successors.
-- Write a function to count them.
countLeaves :: Num p => Tree a -> p
countLeaves Empty                  = 0
countLeaves (Branch _ Empty Empty) = 1
countLeaves (Branch _ l r)         = countLeaves l + countLeaves r

-- Collect the leaves of a binary tree in a list
leaves :: Tree a -> [a]
leaves t = leaves' t []
    where leaves' Empty xs                  = xs
          leaves' (Branch x Empty Empty) xs = x:xs
          leaves' (Branch _ l r) xs         = leaves' l $ leaves' r xs

-- Collect the internal nodes of a binary tree in a list
internals :: Tree a -> [a]
internals t = internals' t []
    where internals' Empty xs                  = xs
          internals' (Branch _ Empty Empty) xs = xs
          internals' (Branch x l r) xs         = (x:) $ internals' l $ internals' r xs

-- Collect the nodes at a given level in a list
-- A node of a binary tree is at level N
-- if the path from the root to the node has length N-1.
-- The root node is at level 1.
-- Write a function to collect all nodes at a given level in a list.
atLevel :: Tree a -> Int -> [a]
atLevel t n = levels t !! (n-1)
    where levels Empty          = repeat []
          levels (Branch a l r) = [a] : zipWith (++) (levels l) (levels r)

-- Construct a complete binary tree
-- A complete binary tree with height H is defined as follows:
-- 1. The levels 1,2,3,...,H-1 contain the maximum number of nodes.
-- 2. In level H, which may contain less than
--    the maximum possible number of nodes,
--    all the nodes are "left-adjusted".
--    This means that in a level-order tree
--    traversal all internal nodes come first,
--    the leaves come second, and empty successors come last.
-- Particularly, complete binary trees are used
-- as data structures (or addressing schemes) for heaps.
-- We can assign an address number to each node in a complete binary tree
-- by enumerating the nodes in level-order,
-- starting at the root with number 1.
-- For every node X with address A the following property holds:
-- The address of X's left and right successors are 2*A and 2*A+1,
-- respectively, if they exist.
-- This fact can be used to elegantly construct
-- a complete binary tree structure.
completeBinaryTree :: Int -> Tree Char
completeBinaryTree n = generateTree 1
    where generateTree x
              | x > n     = Empty
              | otherwise = Branch 'x' (generateTree (2*x)) (generateTree (2*x+1))

isCompleteBinaryTree :: Tree a -> Bool
isCompleteBinaryTree t = treeEqual t $ completeBinaryTree $ treeNodes t
    where treeNodes Empty          = 0
          treeNodes (Branch _ l r) = 1 + treeNodes l + treeNodes r
          treeEqual Empty Empty                       = True
          treeEqual (Branch _ l1 r1) (Branch _ l2 r2) = treeEqual l1 l2 && treeEqual r1 r2
          treeEqual _ _                               = False

-- Given a binary tree, as a preparation for drawing the tree,
-- a layout algorithm is required
-- to determine the position of each node in a rectangular grid.
-- In one layout strategy,
-- the position of a node v is obtained by the following two rules:
-- 1. x(v) is equal to the position of the node v in the in-order sequence
-- 2. y(v) is equal to the depth of the node v in the tree
-- Write a function to annotate each node of the tree with a position,
-- where (1,1) in the top left corner
-- or the rectangle bounding the drawn tree.
-- The auxiliary function is passed the x-coordinate
-- for the left-most node of the sub-tree, and the sub-tree itself.
-- It returns the sub-tree annotated with positions,
-- plus the count of Branch node in the sub-tree.
type Pos = (Int, Int)

layout :: Tree a -> Tree (a, Pos)
layout t = fst (layoutAux 1 1 t)
    where layoutAux x _ Empty          = (Empty, x)
          layoutAux x y (Branch a l r) = (Branch (a, (x',y)) l' r', x'')
              where (l', x')  = layoutAux x (y+1) l
                    (r', x'') = layoutAux (x'+1) (y+1) r

-- Re-implement the layout function using an alternative layout method:
-- On a given level, the horizontal distance
-- between neighboring nodes is constant.
-- The auxiliary function is passed the x- and y-coordinates
-- for the root of the sub-tree,
-- the horizontal separation between the root and its child nodes,
-- and the sub-tree itself.
-- It returns the sub-tree annotated with positions.
layout' :: Tree a -> Tree (a, Pos)
layout' t = layoutAux x1 1 sep1 t
    where layoutAux _ _ _ Empty            = Empty
          layoutAux x y sep (Branch a l r) = Branch (a, (x,y))
                                             (layoutAux (x-sep) (y+1) (sep `div` 2) l)
                                             (layoutAux (x+sep) (y+1) (sep `div` 2) r)
          x1   = 2^(d-1) - 2^(d-ld) + 1
          sep1 = 2^(d-2)
          d    = depth t
              where depth :: Tree a -> Int
                    depth Empty          = 0
                    depth (Branch _ l r) = max (depth l) (depth r) + 1
          ld   = leftDepth t
              where leftDepth :: Tree a -> Int
                    leftDepth Empty          = 0
                    leftDepth (Branch _ l _) = leftDepth l + 1

-- Re-implement the layout function using yet another layout method:
-- A very compact layout
-- while maintaining a certain symmetry in every node.
-- Hint: Consider the horizontal distance
-- between a node and its successor nodes.
-- How tight can you pack together two sub-trees
-- to construct the combined binary tree?
-- The auxiliary function is passed the x- and y-coordinates
-- for the root of the sub-tree and the sub-tree itself.
-- It returns:
-- 1. a list of distances the laid-out tree
--    extends to the left at each level
-- 2. the sub-tree annotated with positions
-- 3. a list of distances the laid-out tree
--    extends to the right at each level
-- These distances are usually positive,
-- but may be 0 or negative in the case of a skewed tree.
-- To put two subtrees side by side,
-- we must determine the least even separation
-- so that they do not overlap on any level.
-- Having determined the separation,
-- we can compute the extents of the composite tree.
-- The definitions of layout and its auxiliary function use local recursion
-- to compute the x-coordinates.
-- This works because nothing else depends on these coordinates.
layout'' :: Tree a -> Tree (a, Pos)
layout'' t = t'
    where (list, t', _) = layoutAux x1 1 t
          x1 = maximum list + 1
          layoutAux :: Int -> Int -> Tree a -> ([Int], Tree (a, Pos), [Int])
          layoutAux _ _ Empty = ([], Empty, [])
          layoutAux x y (Branch a l r) = (ll', Branch (a, (x,y)) l' r', rr')
              where (ll, l', lr) = layoutAux (x-sep) (y+1) l
                    (rl, r', rr) = layoutAux (x+sep) (y+1) r
                    sep = maximum (0:zipWith (+) lr rl) `div` 2 + 1
                    (ll', rr') = (0 : overlay (map (+sep) ll) (map (subtract sep) rl),
                                  0 : overlay (map (+sep) rr) (map (subtract sep) lr))
                        where overlay :: [a] -> [a] -> [a]
                              -- overlay is js = is padded out
                              -- to at least the length of js
                              -- using any extra elements of js
                              overlay [] js         = js
                              overlay is []         = is
                              overlay (i:is) (_:js) = i : overlay is js

-- Write two functions:
-- One for converting a binary tree to its string representation,
-- the other which does the inverse.
treeToString :: Tree Char -> String
treeToString Empty                  = ""
treeToString (Branch x Empty Empty) = [x]
treeToString (Branch x l r)         = x : '(' : treeToString l ++ "," ++ treeToString r ++ ")"

stringToTree :: (Monad m) => String -> m (Tree Char) -- TODO: Fix the return type of this function
stringToTree ""  = return Empty
stringToTree [x] = return $ Branch x Empty Empty
stringToTree str = tfs str >>= \ ("", t) -> return t
    where tfs a@(x:_) | x == ',' || x == ')' = return (a, Empty)
          tfs (x:y:xs)
              | y == ',' || y == ')' = return (y:xs, Branch x Empty Empty)
              | y == '('             = do (',':xs', l)  <- tfs xs
                                          (')':xs'', r) <- tfs xs'
                                          return (xs'', Branch x l r)
          tfs _ = fail "bad parse"

-- Pre-order and in-order sequences of binary trees.
-- 1. Write two functions that construct the pre-order and in-order sequences
--    of a given binary tree, respectively.
--    The results should be atoms.
-- 2. Given a pre-order string, produce a binary tree
--    such that its pre-order string is identical to the given one.
-- 3. Given a pre-order and an in-order string with unique node chars,
--    produce the corresponding binary tree.
treeToPreorder :: Tree Char -> String
treeToPreorder Empty          = ""
treeToPreorder (Branch x l r) = x : treeToPreorder l ++ treeToPreorder r

treeToInorder :: Tree Char -> String
treeToInorder Empty          = ""
treeToInorder (Branch x l r) = treeToInorder l ++ x : treeToInorder r

preToTree :: String -> Tree Char
preToTree ""     = Empty
preToTree (c:cs) = Branch c Empty (preToTree cs)

preInTree :: Monad m => String -> String -> m (Tree Char)
preInTree [] []        = return Empty
preInTree (x:xs) io = do (lio,_:rio) <- return $ break (==x) io
                         (lpo,rpo)   <- return $ splitAt (length lio) xs
                         l           <- preInTree lpo lio
                         r           <- preInTree rpo rio
                         return $ Branch x l r
preInTree _ _          = fail "Not a valid input"

-- Dot-string representation of binary trees.
-- We consider again binary trees with nodes
-- that are identified by single lower-case letters.
-- Such a tree can be represented by the pre-order sequence
-- of its nodes in which dots are inserted
-- where an empty sub-tree is encountered during the tree traversal.
dsToTree :: String -> Tree Char
dsToTree = fst . dsToTreeAux
    where dsToTreeAux []       = (Empty, "")
          dsToTreeAux ('.':xs) = (Empty, xs)
          dsToTreeAux (x:xs)   = (Branch x l r, rest')
              where (l, rest)  = dsToTreeAux xs
                    (r, rest') = dsToTreeAux rest

treeToDs :: Tree Char -> String
treeToDs Empty          = "."
treeToDs (Branch x l r) = x : treeToDs l ++ treeToDs r

-- A multi-way tree is composed of a root element
-- and a set of successors which are multi-way trees themselves.
-- A multi-way tree is never empty.
-- The set of successor trees is sometimes called a forest.
-- Define a datatype for multi-way trees.
-- data Tree a = Node a [Tree a]
--               deriving (Eq, Show)

-- Count the nodes of a multi-way tree.
nnodes :: T.Tree a -> Int
nnodes (T.Node _ ts) = 1 + sum (map nnodes ts)

-- Tree construction from a node string.
-- We suppose that the nodes of a multi-way tree contain single characters.
-- In the depth-first order sequence of its nodes,
-- a special character ^ has been inserted whenever,
-- during the tree traversal,
-- the move is a backtrack to the previous level.
stringToTTree :: String -> T.Tree Char
stringToTTree []     = error "Empty input"
stringToTTree (x:xs) = T.Node x (fst (stringToTTrees xs))
    where stringToTTrees [] = ([], [])
          stringToTTrees (y:ys)
              | y == '^'  = ([], ys)
              | otherwise = (T.Node x trees : trees', rest')
              where (trees, rest)   = stringToTTrees ys
                    (trees', rest') = stringToTTrees rest

tTreeToString :: T.Tree Char -> String
tTreeToString (T.Node x ts)
    = [x] ++ intercalate "^" (map tTreeToString ts) ++ "^"

-- Determine the internal path length of a tree.
-- We define the internal path length
-- of a multi-way tree as the total sum
-- of the path lengths from the root to all nodes of the tree.
ipl :: T.Tree a -> Int
ipl = ipl' 0
    where ipl' d (T.Node _ ts) = d + sum (map (ipl' (d+1)) ts)

-- Construct the bottom-up order sequence of the tree nodes.
bottomUp :: T.Tree a -> [a]
bottomUp t = bottomUpAux t []
    where bottomUpAux :: T.Tree a -> [a] -> [a]
          bottomUpAux (T.Node x ts) xs = foldr bottomUpAux (x:xs) ts

-- Write two functions:
-- One for converting a multi-way tree to a list using Lisp syntax;
-- the other for doing the inverse.
-- TODO: The solution uses Monad,
--       return back and try to understand it,
--       after learning Monad.

-- Write functions to convert
-- between the different graph representations.
data Graph a = Graph [a] [(a, a)]
               deriving (Show, Eq)

newtype Adjacency a = Adj [(a, [a])]
                      deriving (Show, Eq)

newtype Friendly a = Edge [(a, a)]
                     deriving (Show, Eq)

graphToAdj :: Eq a => Graph a -> Adjacency a
graphToAdj (Graph [] _)      = Adj []
graphToAdj (Graph (x:xs) ys) = Adj ((x, ys >>= f) : zs)
    where f (a, b)
            | a == x    = [b]
            | b == x    = [a]
            | otherwise = []
          Adj zs = graphToAdj (Graph xs ys)

adjToGraph :: Eq a => Adjacency a -> Graph a
adjToGraph (Adj []) = Graph [] []
adjToGraph (Adj ((v, a):vs)) = Graph (v : xs) ((a >>= f) ++ ys)
    where f x = if (v, x) `elem` ys || (x, v) `elem` ys
                then []
                else [(v, x)]
          Graph xs ys = adjToGraph (Adj vs)

graphToFri :: Eq a => Graph a -> Friendly a
graphToFri (Graph [] _) = Edge []
graphToFri (Graph xs ys) = Edge (ys ++ zip g g)
    where g = filter (\x -> all (\(a, b) -> x /= a && x /= b) ys) xs


friToGraph :: Eq a => Friendly a -> Graph a
friToGraph (Edge []) = Graph [] []
friToGraph (Edge vs) = Graph xs ys
    where xs = foldr acc [] $ concatMap (\(a, b) -> [a, b]) vs
          ys = filter (uncurry (/=)) vs
          acc z zs = if z `elem` zs then zs else z : zs

adjToFri :: Eq a => Adjacency a -> Friendly a
adjToFri = graphToFri . adjToGraph

friToAdj :: Eq a => Friendly a -> Adjacency a
friToAdj = graphToAdj . friToGraph

-- Write a function that, given two nodes a and b in a graph,
-- returns all the a-cyclic paths from a to b.
paths :: Eq t => t -> t -> [(t, t)] -> [[t]]
paths source sink edges
    | source == sink = [[sink]]
    | otherwise = [source:path | edge<-edges, (fst edge) == source,
                   path<-(paths (snd edge) sink [e|e<-edges, e/=edge])]

-- Cycle from a given node
-- cycle :: Int -> [(Int, Int)] -> [[Int]] -- TODO: Find out how to make this solution work
-- cycle n g = search n []
--     where search [] result = result
--           search cur result = search (go active) (arrive ++ result)
--               where split = partition end cur
--                     end s = (last s == n) && (length s/= 1)
--                     active = snd split
--                     arrive = fst split
--                     go ls = [ x ++ [snd y] | x <- ls, y <- g, last x == fst y, not (snd y `elem` tail x)]
