module Sol_Exercise_8 where
import Control.Applicative
import Control.Monad
import Data.Maybe (mapMaybe)
import Data.Ratio
import Test.QuickCheck hiding (NonEmptyList)
import Test.QuickCheck.Poly

{- Library -- nicht veraendern -}

type Coords = (Integer,Integer)

data Shape =
  Circle Integer |
  Rectangle Integer Integer -- Breite, Höhe
  deriving (Show, Eq)

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

insert :: Ord a => a -> Tree a -> Tree a
insert x Empty = Node x Empty Empty
insert x (Node a l r)
  | x < a = Node a (insert x l) r
  | x > a = Node a l (insert x r)
  | otherwise = Node a l r

delete :: Ord a => a -> Tree a -> Tree a
delete x Empty = Empty
delete x (Node a l r)
  | x == a     =  combine l r
  | x < a      =  Node a (delete x l) r
  | otherwise  =  Node a l (delete x r)

find :: Ord a => a -> Tree a -> Bool
find _ Empty  =  False
find x (Node a l r)
  | x == a     =  True
  | x < a      =  find x l
  | otherwise  =  find x r

combine :: Tree a -> Tree a -> Tree a
combine Empty r  =  r
combine l Empty  =  l
combine l r      =  Node m l r'  where (m,r') = delL r

delL :: Tree a -> (a, Tree a)
delL (Node a Empty r)  = (a, r)
delL (Node a l     r)  = (m, Node a l' r)  where (m,l') = delL l

-- allow QuickCheck to generate arbitrary values of type Tree
instance Arbitrary a => Arbitrary (Tree a) where
  arbitrary = sized tree
    where
    tree 0 = return Empty
    tree n | n > 0 = oneof [return Empty,
      liftM3 Node arbitrary (tree (n `div` 2)) (tree (n `div` 2))]

choose' :: (Maybe Integer, Maybe Integer) -> Gen (Maybe Integer)
choose' (Nothing, Nothing) = Just <$> arbitrary
choose' (Just min, Nothing) = Just <$> ((min+1+) . abs) <$> arbitrary
choose' (Nothing, Just max) = Just <$> ((max-1-) . abs) <$> arbitrary
choose' (Just min, Just max) = if min < max - 1 then Just <$> choose (min + 1, max - 1) else return Nothing

orderedTreeGen :: Gen (Tree Integer)
orderedTreeGen = rec Nothing Nothing
  where intGen = arbitrary :: Gen Integer
        rec min max = sized $ \size ->
          if size <= 1 then
            return Empty
          else do
            let resized = resize $ size `div` 2
            rawA <- choose' (min, max)
            case rawA of
              Just a -> do
                l <- resized $ rec min (Just a)
                r <- resized $ rec (Just a) max
                frequency
                  [ (1, return Empty)
                  , (size, return $ Node a l r)
                  ]
              Nothing -> return Empty

data RegEx =
  Any |
  One Char |
  OneIn [(Char, Char)] |
  Concat RegEx RegEx |
  Alt RegEx RegEx |
  Repeat RegEx

{- End Library -}

{- G1 -}

data Direction = L | R
  deriving (Show, Eq)

navigate :: [Direction] -> Tree a -> Maybe (Tree a)
navigate []       t            = Just t
navigate (L : ds) (Node _ l _) = navigate ds l
navigate (R : ds) (Node _ _ r) = navigate ds r
navigate _        _            = Nothing

{- Die gesuchte Datenstruktur ist ein sogenannter "Zipper".
Man wuerde dann nach dem Absteigen in einem Baum nicht die
Liste aller Parents speichern, sondern nur die *Werte* der
Parents und die zugehoerigen Geschwister.

Siehe auch <http://learnyouahaskell.com/zippers>, die
Definition von `Crumb` und `Breadcrumbs`.
-}


{- G2 -}

isOrderedTree :: Ord a => Tree a -> Bool
isOrderedTree = rec Nothing Nothing
  where checkMin Nothing _ = True
        checkMin (Just min) a = min < a
        checkMax Nothing _ = True
        checkMax (Just max) a = a < max

        rec _ _ Empty = True
        rec min max (Node a l r) =
          checkMin min a && checkMax max a &&
          rec min (Just a) l && rec (Just a) max r

flat :: Tree a -> [a]
flat Empty = []
flat (Node a l r) = flat l ++ a : flat r

treeFromList :: Ord a => [a] -> Tree a
treeFromList = foldl (flip insert) Empty

treeSort :: Ord a => [a] -> [a]
treeSort = flat . treeFromList

{-
Die Funktion `insert` steigt in dem Baum so bis zu einem Blatt ab, dass alle
Knoten links des Blattes kleiner und alle Knoten rechts des Blattes größer
sind.

Neben `insert` erhaelt auch `delete` die Suchbaumeigenschaft.
`find` benoetigt die Eigenschaft.

Betrachten wir auch die Hilfsfunktion `combine` und `delL`, so erhaelt `delL`
die Eigenschaft (wenn es definiert ist). `combine` dagegen erhaelt die
Eigenschaft im Allgemeinen nicht.
-}

isSorted :: Ord a => [a] -> Bool
isSorted (x1 : x2 : xs) = x1 < x2 && isSorted (x2 : xs)
isSorted _ = True

prop_treeSort_sorted :: [Int] -> Bool
prop_treeSort_sorted =
  isSorted . treeSort

prop_treeSort_elems :: [Int] -> Bool
prop_treeSort_elems xs =
  all (`elem` sorted) xs
  where sorted = treeSort xs


{- G3 -}

data NonEmptyList a =
  Single a |
  Cons a (NonEmptyList a)
  deriving (Show, Eq)

toList :: NonEmptyList a -> [a]
toList (Single a) = [a]
toList (Cons h t) = h : toList t

fromList [] = Nothing
fromList (x : xs) = Just (go x xs)
  where go x [] = Single x
        go x (y : ys) = Cons x (go y ys)

nHead :: NonEmptyList a -> a
nHead (Single a) = a
nHead (Cons a _) = a

nTail :: NonEmptyList a -> [a]
nTail (Single a) = []
nTail (Cons _ t) = toList t

nAppend :: NonEmptyList a -> NonEmptyList a -> NonEmptyList a
nAppend (Single a) xs = Cons a xs
nAppend (Cons h t) xs = h `Cons` nAppend t xs

{- Interne Tests fuer die Musterloesung -}

prop_ordered = forAll orderedTreeGen
  isOrderedTree

prop_fromList_ordered xs =
  isOrderedTree $ treeFromList (xs :: [OrdA])

prop_find_insert x = forAll orderedTreeGen $
  find x . insert x

prop_find_delete x y = forAll orderedTreeGen $ \t ->
  find x (delete y t) == (x /= y && find x t)

fromList' h [] = Single h
fromList' h (x:xs) = h `Cons` fromList' x xs

instance Arbitrary a => Arbitrary (NonEmptyList a) where
  arbitrary = fromList' <$> arbitrary <*> arbitrary

prop_append_eq :: NonEmptyList A -> NonEmptyList A -> Bool
prop_append_eq xs ys =
  Just (xs `nAppend` ys) == fromList (toList xs ++ toList ys)

prop_fromto :: NonEmptyList A -> Bool
prop_fromto xs =
  Just xs == fromList (toList xs)

props_all =
  [ property prop_ordered
  , property prop_fromList_ordered
  , property prop_find_insert
  , property prop_find_delete
  , property prop_append_eq
  , property prop_fromto
  ]

testAll = sequence_ $ map quickCheck props_all

{- Ende interne Tests -}


{- H1 -}

isHeap :: Ord a => Tree a -> Bool
isHeap Empty = True
isHeap (Node a l r) = rec a l && rec a r
  where rec min Empty = True
        rec min (Node a l r) = min < a && rec a l && rec a r


{- H2 -}

replace :: [Direction] -> Tree a -> Tree a -> Maybe (Tree a)
replace []       t' _            = Just t'
replace (L : ds) t' (Node a l r) = fmap (\t -> Node a t r) $ replace ds t' l
replace (R : ds) t' (Node a l r) = fmap (\t -> Node a l t) $ replace ds t' r
replace _        _  _            = Nothing


{- H3 -}

find' :: Ord a => a -> Tree a -> Bool
find' _ Empty = False
find' x (Node a l r) =
  case x `compare` a of
    LT -> find' x l
    EQ -> True
    GT -> find' x r

{- H4 -}

-- Eine generalisierte Variante von maybeMap ist in der Bibliothek
-- Data.Traversable als 'traverse' vorhanden
maybeMap :: (a -> Maybe b) -> [a] -> Maybe [b]
maybeMap f = sqn . map f
  where sqn [] = Just []
        sqn (x:xs) = case (x, sqn xs) of
            (Just x', Just xs') -> Just $ x' : xs'
            _ -> Nothing

inverses :: [Integer] -> Maybe [Rational]
inverses = maybeMap (\x -> case x of
    0 -> Nothing
    x -> Just $ 1 % x
    )

{-WETT-}
matches :: [RegEx] -> String -> Bool
matches [] s = null s
matches (Any : _) [] = False
matches (Any : rs) (_ : cs) = matches rs cs
matches (One _ : rs) [] = False
matches (One d : rs) (c : cs) = c == d && matches rs cs
matches (OneIn _ : _) [] = False
matches (OneIn [] : _) _ = False
matches (OneIn ((l, u) : lus) : rs) (c : cs) =
  if l <= c && c <= u then matches rs cs else matches (OneIn lus : rs) (c : cs)
matches (Concat r r' : rs) cs = matches (r : r' : rs) cs
matches (Alt r r' : rs) cs = matches (r : rs) cs || matches (r' : rs) cs
matches (Repeat _ : _) [] = False
matches (Repeat r : rs) cs = matches (r : rs) cs || matches (r : Repeat r : rs) cs

match :: RegEx -> String -> Bool
match r = matches [r]
{-TTEW-}