{-
  * Copyright (c): Uwe Schmidt, FH Wedel
  *
  * You may study, modify and distribute this source code
  * FOR NON-COMMERCIAL PURPOSES ONLY.
  * This copyright message has to remain unchanged.
  *
  * Note that this document is provided 'as is',
  * WITHOUT WARRANTY of any kind either expressed or implied.
-}

module Tree2
where

import Prelude hiding ( head, tail
                      , last, init
                      )
import qualified Prelude as P
import ShowTree

data Tree a = Nil
            | Leaf a
            | Fork (Tree a) (Tree a)
            deriving (Show)

-- invariant:
-- Nil only as root

invTree :: Tree a -> Bool
invTree Nil          = True
invTree (Leaf _x)    = True
invTree (Fork Nil r) = False
invTree (Fork l Nil) = False
invTree (Fork l r)   = invTree l && invTree r

-- slow flatten

flatten :: Tree a -> [a]
flatten Nil        = []
flatten (Leaf x)   = [x]
flatten (Fork l r) = flatten l ++ flatten r

-- fast flatten

flatten1 :: Tree a -> [a]
flatten1 t = go t []
  where
    go Nil        acc = acc
    go (Leaf x)   acc = x : acc
    go (Fork l r) acc = (go l . go r) acc

flatten1' :: Tree a -> [a]
flatten1' t = go t []
  where
    go Nil        = id
    go (Leaf x)   = (x :)
    go (Fork l r) = go l . go r

-- simple minded build, builds lists as trees

build0 :: [a] -> Tree a
build0 xs = foldr (<++>) Nil (map Leaf xs)

-- smart but a bit slow build due to splitAt and length

build1 :: [a] -> Tree a
build1 []  = Nil
build1 [x] = Leaf x
build1 xs  = Fork (build1 l) (build1 r)
  where
    (l, r) = splitAt (length xs `div` 2) xs

-- smart and fast build

build2 :: [a] -> Tree a
build2 xs
  | null xs   = Nil
  | otherwise = build' (map Leaf xs)
  where
    build' [t] = t
    build' ts  = build' (merge ts)

    merge (t1 : t2 : ts) = Fork t1 t2 : merge ts
    merge ts             = ts

-- some test trees

t0, t1, t2, t100 :: Tree Int
t0   = build0 [1..9]
t1   = build1 [1..9]
t2   = build2 [1..9]
t100 = build1 [1..100]

-- list like functions for trees

head :: Tree a -> a
head Nil         = error "head: empty list"
head (Leaf x)    = x
head (Fork l _r) = head l

last :: Tree a -> a
last Nil         = error "last: empty list"
last (Leaf x)    = x
last (Fork _l r) = last r

-- <++> is ++ for trees

infixr 5 <++>
(<++>) :: Tree a -> Tree a -> Tree a
Nil <++> t2  = t2
t1  <++> Nil = t1
t1  <++> t2  = Fork t1 t2

cons :: a -> Tree a -> Tree a
cons x t = Leaf x <++> t

snoc :: Tree a -> a -> Tree a
snoc t x = t <++> Leaf x

tail :: Tree a -> Tree a
tail Nil        = error "tail: empty tree"
tail (Leaf _x)  = Nil
tail (Fork l r) = tail l <++> r

init :: Tree a -> Tree a
init Nil        = error "init: empty tree"
init (Leaf _x)  = Nil
init (Fork l r) = l <++> init r

viewL :: Tree a -> Maybe (a, Tree a)
viewL Nil       = Nothing
viewL (Leaf x)  = Just (x, Nil)
viewL (Fork l r)= Just (x, r1 <++> r)
                  where
                    Just (x, r1) = viewL l

viewR :: Tree a -> Maybe (Tree a, a)
viewR Nil       = Nothing
viewR (Leaf x)  = Just (Nil, x)
viewR (Fork l r)= Just (l1 <++> l, x)
                  where
                    Just (l1, x) = viewR r

mapTree :: (a -> b) -> Tree a -> Tree b
mapTree f Nil        = Nil
mapTree f (Leaf x)   = Leaf (f x)
mapTree f (Fork l r) = Fork (mapTree f l) (mapTree f r)

instance Functor Tree where
  fmap = mapTree

filterTree :: (a -> Bool) -> Tree a -> Tree a
filterTree p Nil        = Nil
filterTree p (Leaf x)
    | p x               = Leaf x
    | otherwise         = Nil
filterTree p (Fork l r) = filterTree p l <++> filterTree p r

-- nice try:
-- filterTree p (Fork l r) = filterTree p l `Fork` filterTree p r

sumTree :: Num a => Tree a -> a
sumTree Nil        = 0
sumTree (Leaf x)   = x
sumTree (Fork l r) = sumTree l + sumTree r

size :: Tree a -> Int
size Nil        = 0
size (Leaf _)   = 1
size (Fork l r) = size l + size r

minpath :: Tree a -> Int
minpath Nil        = 0
minpath (Leaf _)   = 1
minpath (Fork l r) = (minpath l `min` minpath r) + 1

maxpath :: Tree a -> Int
maxpath Nil        = 0
maxpath (Leaf _)   = 1
maxpath (Fork l r) = (maxpath l `max` maxpath r) + 1

fold :: (b -> b -> b) -> (a -> b) -> b ->
        Tree a -> b
fold op f c Nil        = c
fold op f c (Leaf x)   = f x
fold op f c (Fork l r) = fold op f c l `op` fold op f c r

fold' :: (b -> b -> b) -> (a -> b) -> b ->
         Tree a -> b
fold' op f c = fold''
  where
    fold'' Nil        = c
    fold'' (Leaf x)   = f x
    fold'' (Fork l r) = fold'' l `op` fold'' r

sumTree' :: Num a => Tree a -> a
sumTree' = fold (+) id 0

size' :: Tree a -> Int
size' = fold (+) (const 1) 0

minpath' :: Tree a -> Int
minpath' = fold (\ x y -> x `min` y + 1) (const 1) 0

maxpath' :: Tree a -> Int
maxpath' = fold (\ x y -> x `max` y + 1) (const 1) 0

notNil :: Tree a -> Bool
notNil = fold (&&) (const True) False

-- slow flatten with fold

flatten' :: Tree a -> [a]
flatten' = fold (++) (\ x -> [x]) []

-- fast flatten, O(n)

flatten'' :: Tree a -> [a]
flatten'' = go []
  where
    go acc Nil = acc
    go acc (Leaf x) = x : acc
    go acc (Fork l r) = go (go acc r) l

-- mapTree with fold, like map for lists with foldr

mapTree' :: (a -> b) -> Tree a -> Tree b
mapTree' f = fold Fork (Leaf . f) Nil

-- --------------------
--
-- conversion of trees into pseudo graphics

showTree :: Show a => Tree a -> String
showTree = formatStringNTree . toNTree
  where
    toNTree Nil        = NTree "Nil" []
    toNTree (Leaf x)   = NTree ("Leaf " ++ show x) []
    toNTree (Fork l r) = NTree "Fork" [toNTree l, toNTree r]

-- formatted print of trees
printTree :: Show a => Tree a -> IO ()
printTree = putStrLn . showTree

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