{-# LANGUAGE ConstraintKinds, TypeOperators, KindSignatures, MultiParamTypeClasses, AllowAmbiguousTypes, FunctionalDependencies, FlexibleInstances #-}
module Muster2 where

import Prelude hiding (traverse,Sum,Product,Min,Max,lookup)
import GHC.Exts (Constraint)

{- Aufgabe 1 -}

data Vote = Pro | Contra | Draw deriving Show

-- isomorph ist z.B. Maybe Bool

voteToMaybeBool :: Vote -> Maybe Bool
voteToMaybeBool Pro = Just True
voteToMaybeBool Contra = Just False
voteToMaybeBool Draw = Nothing

-- oder Either () (Either () ())

voteToEitherEither :: Vote -> Either () (Either () ())
voteToEitherEither Pro = Right (Right ())
voteToEitherEither Contra = Right (Left ())
voteToEitherEither Draw = Left ()

-- oder Maybe (Maybe ())

voteToMaybeMaybe :: Vote -> Maybe (Maybe ())
voteToMaybeMaybe Pro = Just (Just ())
voteToMaybeMaybe Contra = Just Nothing
voteToMaybeMaybe Draw = Nothing

{- Aufgabe 2 -}

data Tree a = Branch (Tree a) (Tree a) | Leaf a deriving Show

traverse :: Tree a -> [a]
traverse (Leaf a) = [a]
traverse (Branch l r) = traverse l ++ traverse r

{- Aufgabe 3 -}

data Machine a b = Stopped
                 | Emit b (Machine a b)
                 | Await (a -> Machine a b)

{- Aufgabe 4 -}

data List a = Nil | a ::: List a deriving Show

instance Eq a => Eq (List a) where
    Nil == Nil = True
    Nil == (_:::_) = False
    (_:::_) == Nil = False
    (a:::as) == (b:::bs) = (a == b) && (as == bs)

{- Aufgabe 5 -}

data Nat = Zero | Succ Nat deriving Show

instance Eq Nat where
    Zero == Zero = True
    (Succ a) == (Succ b) = a == b
    _ == _ = False

instance Ord Nat where
    compare Zero Zero = EQ
    compare (Succ _) Zero = GT
    compare Zero (Succ _) = LT
    compare (Succ a) (Succ b) = compare a b

{- Aufgabe 6 -}

data ListMap k v = LM [(k,v)]

lmLookup :: Eq k => ListMap k v -> k -> Maybe v
lmLookup (LM []) _ = Nothing
lmLookup (LM ((k,v):xs)) k' | k == k' = Just v
                            | otherwise = lmLookup (LM xs) k'

{- Aufgabe 7 -}

data TreeMap k v = Node k v (TreeMap k v) (TreeMap k v) | EmptyT

{- Aufgabe 8 -}

tmLookup :: Ord k => TreeMap k v -> k -> Maybe v
tmLookup EmptyT _ = Nothing
tmLookup (Node k v l r) k' | k' == k = Just v
                           | k' > k = tmLookup r k'
                           | otherwise = tmLookup l k'
                                         
{- Aufgabe 9 -}

-- Es gibt keine in Bezug auf das Plenum sinnvolle Monoid-Instanz.
-- Allerdings lassen sich durchaus unsinnige Instanzen schreiben, z.B.:

instance Monoid Vote where
    mempty = Draw
    mappend Draw x = x
    mappend Pro Contra = Draw
    mappend Contra Pro = Draw
    mappend x _ = x

-- diese ist nicht assoziativ, obwohl wir dies von Monoiden erwarten wuerden:
-- (Pro <> Pro) <> Contra = Draw
-- Pro <> (Pro <> Contra) = Pro

{- Aufgabe 10 -}

-- Geht nicht! Falle: Es gibt kein neutrales Element. Ansonsten waere Branch das ideale mappend.

{- Aufgabe 11 -}

instance Functor Tree where
    fmap f (Leaf a) = Leaf (f a)
    fmap f (Branch l r) = Branch (fmap f l) (fmap f r)

instance Applicative Tree where
    pure = Leaf
    (Leaf f) <*> (Leaf a) = Leaf (f a)
    (Branch lf rf) <*> a = Branch (lf <*> a) (rf <*> a)
    f <*> (Branch l r) = Branch (f <*> l) (f <*> r)

{- Aufgabe 12 -}

instance Functor (Machine a) where
    fmap _ Stopped = Stopped
    fmap f (Emit b next) = Emit (f b) (fmap f next)
    fmap f (Await next) = Await (fmap f . next)

-- Um ueber die Eingabewerte fmappen zu koennen, muessten
-- a) die Typparameter umgekehrt sein und
-- b) die Funktion bijektiv sein, und wir muessten die Umkehrfunktion kennen

{- Aufgabe 13 -}

instance Functor (TreeMap k) where
    fmap _ EmptyT = EmptyT
    fmap f (Node k v l r) = Node k (f v) (fmap f l) (fmap f r)

-- Applicative ist nicht moeglich, weil wir pure nicht implementieren koennen (woher den Schluessel nehmen?)
-- Ebenso: Wie sollen bei <*> die Schluessel von Funktionen und Argumenten kombiniert werden?

instance Ord k => Monoid (TreeMap k v) where
    mempty = EmptyT
    EmptyT `mappend` a = a
    a `mappend` EmptyT = a
    n1@(Node k1 v1 l1 r1) `mappend` n2@(Node k2 v2 l2 r2)
        | k1 >= k2 = Node k1 v1 (l1 `mappend` n2) r1
        | otherwise = Node k2 v2 l2 (r2 `mappend` n1)

instance (Eq k, Eq v) => Eq (TreeMap k v) where
    EmptyT == EmptyT = True
    (Node k1 v1 l1 r1) == (Node k2 v2 l2 r2) = k1==k2 && v1==v2 && l1==l2 && r1==r2
    _ == _ = False

{- Aufgabe 14 -}

-- Beispiel 1

data Wrapper a = The a | Wrap (Wrapper a) deriving Show

instance Functor Wrapper where
    fmap f (The a) = Wrap (The (f a))
    fmap f (Wrap w) = Wrap (fmap f w)

-- fmap (f . g) (The a) === Wrap (The (f (g a)))
-- fmap f (fmap g (The a)) === Wrap (Wrap (The (f (g a))))
--  ==> Linearitaet nicht erfuellt!
-- fmap id (The a) === Wrap (The a)
--  ==> id ist kein neutrales Element!

-- Beispiel 2

data Counter a = C Int a

instance Functor Counter where
    fmap f (C i a) = C (i+1) (f a)

-- fmap (f . g) (C 1 a) === C 2 (f (g a))
-- fmap f (fmap g (C 1 a)) === C 3 (f (g a))
--  ==> Linearitaet nicht erfuellt!
-- fmap id (C 1 a) === C 2 a
--  ==> id ist kein neutrales Element!

-- Beispiel 3

instance Functor List where
    fmap f Nil = Nil
    fmap f (x ::: xs) = f x ::: (f x ::: fmap f xs)

-- fmap (f . g) (a ::: Nil) === f (g a) ::: (f (g a) ::: Nil)
-- fmap f (fmap g (a ::: Nil)) === f (g a) ::: (f (g a) ::: (f (g a) ::: (f (g a) ::: Nil)))
--  ==> Linearitaet nicht erfuellt!
-- fmap id (a ::: Nil) === a ::: (a ::: Nil)
--  ==> id ist kein neutrales Element!

-- Beispiel 4

data Perhaps a = Yep a | Nope deriving Show

instance Functor Perhaps where
    fmap _ _ = Nope

-- fmap (f . g) _ === Nope
-- fmap f (fmap g _) === Nope
--  ==> Linearitaet IST erfuellt.
-- fmap id (Yep a) = Nope
--  ==> aber id ist kein neutrales Element!

-- Beispiel 5

data LTree a = LNode a (LTree a) (LTree a) | LLeaf deriving Show

instance Functor LTree where
    -- Baum wird bei jedem fmap nach links rotiert
    fmap _ LLeaf = LLeaf
    fmap f (LNode a l LLeaf) = LNode (f a) (fmap f l) LLeaf
    fmap f (LNode a l (LNode ra rl rr)) = 
        LNode (f ra) (fmap f (LNode a l rl)) (fmap f rr)

-- fmap (id.id) (LNode 3 (LNode 4 LLeaf LLeaf) (LNode 5 LLeaf (LNode 6 LLeaf LLeaf))) === LNode 5 (LNode 3 (LNode 4 LLeaf LLeaf) LLeaf) (LNode 6 LLeaf LLeaf)
--  ==> id ist kein neutrales Element!
-- fmap id $ fmap id (LNode 3 (LNode 4 LLeaf LLeaf) (LNode 5 LLeaf (LNode 6 LLeaf LLeaf))) === LNode 6 (LNode 5 (LNode 3 (LNode 4 LLeaf LLeaf) LLeaf) LLeaf) LLeaf
--  ==> Linearitaet ist auch nicht erfuellt

-- Beispiel 6

data PingPong a = Ping a | Pong a

instance Functor PingPong where
    fmap f (Ping a) = Pong (f a)
    fmap f (Pong a) = Ping (f a)
                      

-- fmap (f . g) (Ping a) = Pong (f (g a))
-- fmap f (fmap g (Ping a)) = Ping (f (g a))
--  ==> Linearitaet ist nicht erfuellt!
-- fmap id (Ping a) = Pong a
--  ==> id ist kein neutrales Element!

-- Beispiel 7

data IntReader a = IntReader (Int -> a)

instance Functor IntReader where
    fmap f (IntReader r) = IntReader $ \a -> f $ r (a*2)

-- fmap (f . g) (IntReader $ \a -> a+1) === IntReader $ \a -> f (g (a*2+1))
-- fmap f (fmap g (IntReader $ \a -> a+1)) === IntReader $ \a -> f (g (a*4+1))
--  => Linearitaet ist nicht erfuellt!
-- fmap id (IntReader $ \a -> a+1) === IntReader $ \a -> a*2+1
--  => id ist kein neutrales Element!

-- Beispiel 8

data IntReader2 a = IntReader2 (Int -> a)

instance Functor IntReader2 where
    fmap f (IntReader2 r) = IntReader2 $ \_ -> f $ r 1

-- fmap (f . g) (IntReader2 $ \a -> a+1) === IntReader2 $ \_ -> f (g 2)
-- fmap f (fmap g (IntReader2 $ \a -> a+1)) === IntReader2 $ \_ -> f (g 2)
--  => Linearitaet IST erfuellt!
-- fmap id (IntReader2 $ \a -> a+1) === IntReader2 $ \_ -> 2
--  => aber id ist kein neutrales Element!

{- Aufgabe 15 -}

newtype Sum a = Sum a
newtype Product a = Product a

instance Num a => Monoid (Sum a) where
    mempty = Sum 0
    mappend (Sum a) (Sum b) = Sum (a+b)

instance Num a => Monoid (Product a) where
    mempty = Product 1
    mappend (Product a) (Product b) = Product (a*b)
                                      
{- Aufgabe 16 -}

newtype Dual a = Dual a

instance Monoid a => Monoid (Dual a) where
    mempty = Dual mempty
    mappend (Dual a) (Dual b) = Dual (mappend b a)

{- Aufgabe 17 -}

-- Wrapper notwendig um nicht mit der in Prelude definierten Instanz zu kollidieren (bloedes Prelude, immer nimmt es uns den Spass schon weg)

newtype a ~> b = F { ($$) :: (a -> b) }

instance Monoid b => Monoid (a ~> b) where
    mempty = F (const mempty)
    mappend f g = F $ \a -> mappend (f $$ a) (g $$ a)

{- Aufgabe 18 -}

newtype Endo a = Endo { appEndo :: a -> a }

instance Monoid (Endo a) where
    mempty = Endo id
    mappend (Endo f) (Endo g) = Endo (f . g)

-- Functor ist nicht implementierbar, da die Funktion bijektiv sein und wir die Umkehrfunktion kennen muessten

{- Aufgabe 19 -}

-- traverse: Nein, denn Tree ist kein Monoid. Waere (10) loesbar, waere traverse aber ein Homomorphismus, denn genau diese Anforderungen haben wir dort gestellt.
-- fmap(17): Ja, denn fmap (f <> g) a === (f <> g) . a === (f . a) <> (g . a) === fmap f a <> fmap g a und fmap mempty a === mempty . a === const mempty . a === mempty
-- fmap(18): Ja, ergibt sich schon aus den Funktorregeln: fmap (f <> g) = fmap (f . g) = fmap f . fmap g = fmap f <> fmap g und fmap mempty = fmap id = id = mempty
-- length auf Sum: Ja, denn length (a++b) = length a + length b
-- length auf Product, Min, Max: Nein (trivial)
-- sum auf Sum: Ja, denn sum (a++b) = sum a + sum b
-- sum auf Product, Min, Max: Nein (trivial)
-- fib auf Sum: Nein, Gegenbeispiel fib 4 + fib 5 = fib 6 /= fib 9
-- fib auf Product: Nein, Gegenbeispiel fib 4 * fib 5 = 15 /= 6765 = fib 20
-- fib auf Min, Max: Ja, denn fib ist monoton wachsend.
-- (*2) auf Sum: Ja, denn a*2 + b*2 = (a+b)*2
-- (*2) auf Product: Nein, denn a*2*b*2 = a*b*4 /= a*b*2
-- (*2) auf Min, Max: Ja, denn (*2) ist streng monoton wachsend

{- Aufgabe 20 -}

-- In der Algebra werden primaer Homomorphismen auf *Vektorraeumen* betrachtet, und dann wird zusaetzlich gefordert, dass c*(f x) = f (c*x). Wir haben es aber in Haskell normalerweise nicht mit Vektorraeumen zu tun, aber sehr haeufig mit Monoiden, womit der Begriff des Monoiden-Homomorphismus wichtiger wird.

-- Fuer Isomorphismen wird in der Algebra nicht nur Bijektivitaet gefordert, sondern auch dass es sich um einen Homomorphismus handelt. Obwohl wir schon einen schwaecheren Homomorphismusbegriff verwenden, wuerde das bedeuten, dass wir nur bei Monoiden von Isomorphie reden koennten. Daher ist es sinnvoller, den Isomorphismusbegriff aus der Kategorientheorie zu uebernehmen (=> nur Bijektivitaet).

{- Aufgabe 21 -}

-- Beispiele: head, tail, fromJust, fromRight sind typische Yolomorphismen.
-- Extrembeispiele: unsafePerformIO :: IO a -> a, unsafeCoerce :: a -> b
-- (die du hoffentlich niemals(!) nutzen wirst)

-- Vor allem head, tail, fromJust und fromRight werden schnell mal aus Fluechtigkeit an Stellen benutzt, wo gar nicht sicher ist, dass die Liste tatsaechlich nicht leer ist, oder Nothing bzw. Left vorkommen kann. In fast jedem Fall ist es sinnvoller, auf Patterns zu matchen (mit case-of oder let-/where-bindings). Ansonsten fliegt das Programm in Randfaellen dann doch in die Luft.

{- Aufgabe 22 -}

instance Num Nat where
    Zero + x = x
    Succ x + y = Succ (x+y)

    Zero * _ = Zero
    Succ x * y = x*y + y

    x - Zero = x
    Zero - Succ _ = error "Arithmetic underflow"
    Succ x - Succ y = x - y

    negate Zero = Zero
    negate (Succ _) = error "Arithmetic underflow"

    abs x = x

    signum Zero = Zero
    signum _ = Succ Zero

    fromInteger 0 = Zero
    fromInteger n | n < 0 = error "Arithmetic underflow"
                  | otherwise = Succ (fromInteger (n-1))

{- Aufgabe 23 -}

data Complex r = Complex { _Im :: r, _Re :: r } deriving Show

instance Floating r => Num (Complex r) where
    a + b = Complex (_Re a+_Re b) (_Im a+_Im b)
    a - b = Complex (_Re a-_Re b) (_Im a-_Im b)
    a * b = Complex (_Re a*_Re b - _Im a*_Im b) (_Re a*_Im b + _Im a*_Re b)
    negate a = Complex (-_Re a) (-_Im a)
    abs a = Complex (sqrt((_Re a)^2 + (_Im a)^2)) 0
    signum a = Complex (_Re a / _Re (abs a)) (_Im a / _Re (abs a))
    fromInteger n = Complex (fromInteger n) 0

instance Eq r => Eq (Complex r) where
    a == b = (_Im a == _Im b) && (_Re a == _Re b)

-- Ord laesst sich nicht instanziieren, da komplexe Zahlen nicht geordnet sind
                    
{- Aufgabe 24 -}

data Ratio a = Ratio { numerator :: a, denominator :: a } deriving Show

normalize :: Integral a => Ratio a -> Ratio a
normalize (Ratio n d) = let x = gcd n d in Ratio (div n x) (div d x)
             
instance Integral a => Num (Ratio a) where
    Ratio n1 d1 + Ratio n2 d2 = let d3 = lcm d1 d2 in normalize $ Ratio (n1*d3 `div` d1 + n2*d3 `div` d2) d3
    Ratio n1 d1 * Ratio n2 d2 = normalize (Ratio (n1*n2) (d1*d2))
    negate (Ratio n d) = Ratio (negate n) d
    x - y = x + negate y
    abs (Ratio n d) = Ratio (abs n) d
    signum (Ratio n d) = Ratio (signum n) 1
    fromInteger n = Ratio (fromInteger n) 1

instance (Integral a,Eq a) => Eq (Ratio a) where
    a == b =
        let a' = normalize a
            b' = normalize b
        in (numerator a' == numerator b') && (denominator a' == denominator b')

instance (Integral a,Ord a) => Ord (Ratio a) where
    compare (Ratio n1 d1) (Ratio n2 d2) =
        let d = lcm d1 d2
            n1' = n1*d `div` d1
            n2' = n2*d `div` d2
        in compare n1' n2'

{- Aufgabe 25+26 -}

-- Einschraenkung auf Ord, da sonst nicht fuer TreeMap instanziierbar;
-- d.h. leider, dass lookup auch fuer ListMap den Constraint Ord k hat
class Map m where
    lookup :: Ord k => m k v -> k -> Maybe v

instance Map ListMap where
    lookup = lmLookup
    -- :: Ord k => ListMap k v -> k -> Maybe v

instance Map TreeMap where
    lookup = tmLookup
    -- :: Ord k => TreeMap k v -> k -> Maybe v

-- Mit ConstraintKinds + MultiParamTypeClasses + KindSignatures + FunctionalDependencies + AllowAmbiguousTypes geht das viel cooler ;)
-- (gegen so eine Spracherweiterungsschlacht gibt es jedoch auch berechtigte Kritik)
class Map2 (c :: * -> Constraint) m | m -> c where
    lookup2 :: c k => m k v -> k -> Maybe v

instance Map2 Eq ListMap where
    lookup2 = lmLookup
    -- :: Eq k => ListMap k v -> k -> Maybe v

instance Map2 Ord TreeMap where
    lookup2 = tmLookup
    -- :: Ord k => TreeMap k v -> k -> Maybe v


-- Mehr Spaß
data IndexMap k v = IM [v] deriving Show

imLookup :: IndexMap Nat v -> Nat -> Maybe v
imLookup (IM []) _ = Nothing
imLookup (IM (a:_)) Zero = Just a
imLookup (IM (_:as)) (Succ n) = imLookup (IM as) n

-- Mit FlexibleInstances
instance Map2 ((~) Nat) IndexMap where
    lookup2 = imLookup

-- > lookup2 (IM [5,6,7]) 0
-- > lookup2 (IM "Baumhaus") 3
-- Versuch das mit der primitiven Map-Klasse ;)