module Main where

-- Erweitere einfachen Auswerter arithmetischer Ausdruecke um 
-- 1. Fehlerbehandlung
-- 2. Zaehler der durchgefuehrten Operationen (Zustand)
-- 3. Ausgabeprotokoll der Operationen

-- Ausgangsauswerter 

data Expr = Con Int | Bin Op Expr Expr deriving Show
data Op   = Add | Sub | Mul | Div deriving (Show,Eq)

eval ::  Expr -> Int
eval (Con a)      = a
eval (Bin op a b) = sem op (eval a) (eval b)

sem :: Op -> (Int -> Int -> Int)
sem Add = (+)
sem Sub = (-)
sem Mul = (*)
sem Div = div

success, failure :: Expr
success = Bin Sub (Bin Mul (Con 12) (Con 4)) (Bin Add (Con 1) (Con 5))
failure = Bin Div (Con 1) (Con 0)

-- Erweiterung um Fehlerbehandlung
data Result a  = Raise Exception | Return a   deriving Show
type Exception = String

evalF              :: Expr -> Result Int
evalF (Con a)      = Return a
evalF (Bin op a b) = case evalF a of
                      Raise e  -> Raise e
                      Return n ->
                        case evalF b of
                          Raise e  -> Raise e
                          Return m -> if op == Div && m == 0
                                      then Raise "Divide by zero"
                                      else Return (sem op n m)


-- Erweiterung um Zählerzustand
type Count a = Int -> (a, Int)

evalC                :: Expr -> Count Int
evalC (Con a)      x = (a,x)
evalC (Bin op a b) x = let (n,y) = evalC a x
                           (m,z) = evalC b y
                       in  (sem op n m, z+1)


-- Erweiterung um Ausgabe
type Output a = (a, String)

evalW                :: Expr -> Output Int
evalW e@(Con a)       = (a,write e a)
evalW e@(Bin op a b)  = let (n,as) = evalW a
                            (m,bs) = evalW b
                            r      = sem op n m
                       in  (r, as ++ bs ++ write e r)


write :: Expr -> Int -> String
write e n = "eval (" ++ show e ++ ") => " ++ show n ++ "\n"


-- >>>>> jeweils starke Modifikationen erforderlich


-- Alternativer Ansatz:
-- ---------------------
-- Monadischer Auswerter 
-- ---------------------
evalM              :: Expr -> Id Int
evalM (Con a)      = return a
evalM (Bin op a b) = evalM a >>= \ n ->
                     evalM b >>= \ m ->
                     return (sem op n m)

-- Identitaetsmonade
newtype Id a = Id a deriving Show

instance Monad Id where
  return  a =  Id a
  (Id a) >>= f = f a


-- Fehlerbehandlungsmonade
instance Monad Result where
  return  a  = Return a
  a >>= f    = case a of
                 Raise e  -> Raise e
                 Return n -> f n

-- .... und entsprechend erweiterter Auswerter
evalFM              :: Expr -> Result Int
evalFM (Con a)      = return a
evalFM (Bin op a b) = evalFM a >>= \ n ->
                      evalFM b >>= \ m ->
                      if m == 0 && op == Div
                        then Raise "Division durch Null"
                        else return (sem op n m)

-- Zustandsmonade
newtype CountM a = Count (Int -> (a, Int)) 

apply             :: CountM a -> Int -> (a, Int)
apply (Count f) i =  f i

instance Monad CountM where
  return a   = Count (\ i -> (a,i))
  g >>= f    = Count (\ i -> let (n,j) = apply g i
                             in  apply (f n) j)

-- .... und entsprechend erweiterter Auswerter
evalCM              :: Expr -> CountM Int
evalCM (Con a)      = return a
evalCM (Bin op a b) = evalCM a >>= \ n ->
                      evalCM b >>= \ m ->
                      incr >>
                      return (sem op n m)
  where incr :: CountM ()
        incr =  Count (\ i -> ((),i+1))


-- Ausgabemonade
newtype OutputM a = Output (a, String) deriving Show
pair :: OutputM a -> (a, String)
pair (Output p) = p

instance Monad OutputM where
  return a   = Output (a, "")
  a >>= f    = let (n, cs)  = pair a
                   (m, cs2) = pair (f n)
               in  Output (m, cs ++ cs2)

-- .... und entsprechend erweiterter Auswerter
evalWM              :: Expr -> OutputM Int
evalWM e@(Con a)      = output (write e a) >> return a
evalWM e@(Bin op a b) = evalWM a >>= \ n ->
                        evalWM b >>= \ m ->
                        let res = sem op n m
                        in  output (write e res) >> return res

output :: String -> OutputM ()
output cs = Output ((),cs)


-- Listen- und Maybe-Monade 
{- 
-- Listenmonade
instance Monad [] where
  return :: a -> [a]
  (>>=)  :: [a] -> (a -> [b]) -> [b]
  
  return x = [x]
  xs >>= f = concatMap f xs
    

-- Maybe-Monade
instance Monad Maybe where
  return :: a -> Maybe a
  (>>=)  :: Maybe a -> (a -> Maybe b) -> Maybe b
  
  return x = Just x
  (Just x) >>= f = f x
  Nothing  >>= f = Nothing

-}

-- Beispiele
-- Kartesiche Produktbildung
cartesian :: Monad m => m a -> m b -> m (a,b)
cartesian xs ys = do x <- xs; y <- ys; return (x,y)

-- Constraint Solving
-- Bestimme zu positiver ganzer Zahl alle Paare positiver ganzer Zahlen, 
-- deren Produkt die Zahl ergibt
multiplyTo :: Int -> [(Int,Int)]
multiplyTo n =
  do  x <- [1..n]
      y <- [x..n]
      if x*y == n then return (x,y) else []