3 files changed, 940 insertions, 0 deletions

diff --git a/ws2015/ffp/blaetter/02/FFP_U02_Typklassen.hs b/ws2015/ffp/blaetter/02/FFP_U02_Typklassen.hs
new file mode 100644
index 0000000..5f2d936
--- /dev/null
+++ b/ws2015/ffp/blaetter/02/FFP_U02_Typklassen.hs
@@ -0,0 +1,206 @@
+-- Fortgeschrittene Funktionale Programmierung,
+--   LMU, TCS, Wintersemester 2015/16
+--   Steffen Jost, Alexander Isenko
+--
+-- Übungsblatt 02. 28.10.2015
+--
+-- Thema:
+--
+-- Anweisung:
+--   Gehen Sie diese Datei durch und bearbeiten Sie
+--   alle Vorkommen von undefined bzw. die mit -- !!! TODO !!!
+--   markierten Stellen. Testen Sie Ihre Lösungen mit GHCi!
+
+
+-- | A2-1 Funktionsdefinitionen
+--
+-- Implementieren Sie folgende grundlegenden,
+-- bekannten Funktionen in Haskell.
+-- Selbst wenn Sie die Funktion nicht kennen,
+-- sollte Ihnen der Typ die korrekte Lösung ermöglichen!
+--
+
+import Prelude hiding (uncurry,flip,(.),map,zip,zipWith,zip,foldl)
+
+import qualified Data.Map as P
+
+-- Hinweis: Das import-Statement müssen Sie jetzt noch nicht verstehen,
+--   es ist nur notwendig zur Vermeidung von Namenskonflikten mit der
+--   Standardbibliothek, welche die meisten dieser Funktionen bereits enthält.
+
+-- a) Uncurrying
+--    > uncurry (/) (1,2) == 0.5
+uncurry :: (a -> b -> c) -> ((a,b) -> c)
+uncurry f (a,b) = f a b
+
+-- b) Anwendung einer Funktion mit zwei Argumenten auf ein Paar
+--    > (1,2) ||> (/) == 0.5
+(||>) :: (a,b) -> (a -> b -> c) -> c
+p ||> f = uncurry f p
+
+
+-- c) Vertauschung der Reihenfolge der Funktionsargumente
+--    > flip (/) 2 1 == 0.5
+flip :: (a -> b -> c) -> (b -> a -> c)
+flip f b a = f a b
+
+
+-- d) Funktionskomposition
+--    > ((\x->x+3) . (\y->y*2)) 1 == 5
+(.) :: (b -> c) -> (a -> b) -> a -> c
+(.) f g x = f $ g x
+
+
+-- e) Map (im Gegensatz zu A1-3 dieses Mal ohne List-Comprehension)
+--    > map (+10) [1,2,3,4] == [11,12,13,14]
+map :: (a -> b) -> [a] -> [b]
+map _ [] = []
+map f (x:xs) = f x : map f xs
+
+
+-- f) zip:
+--    > zip ['a','b','c'] [1,2,3,4,5] = [('a',1),('b',2),('c',3)]
+zip :: [a] -> [b] -> [(a,b)]
+zip [] _ = []
+zip _ [] = []
+zip (x:xs) (y:ys) = (x, y) : zip xs ys
+
+
+-- g) Zippen mit Funktionsanwendung:
+--    > zipWith (+) [1..] [1..3] == [2,4,6]
+zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
+zipWith f xs ys = map (uncurry f) $ zip xs ys
+
+
+-- h) Falten nach links:
+--    > foldl (flip (:)           ) [] [1..3] == [3,2,1]
+--    > foldl (\acc x ->  x : acc)) [] [1..3] == [3,2,1]
+foldl :: (b -> a -> b) -> b -> [a] -> b
+foldl _ x [] = x
+foldl f x (y:ys) = foldl f (f x y) ys
+
+
+
+-- | A2-2 LambdaTerme
+--
+--   Betrachten Sie die Lösung zur A1-1 g):
+
+data LambdaTerm = LVar Char
+                | LAbs Char       LambdaTerm
+                | LApp LambdaTerm LambdaTerm
+
+-- Ein paar Lambda Terme zum Testen:
+lTerm_x   = LVar 'x'
+lTerm_y   = LVar 'y'
+lTerm_id  = LAbs 'x' lTerm_x
+lTerm_xx  = LApp lTerm_x lTerm_x
+lTerm_t   = LAbs 'x' $ LApp lTerm_y lTerm_xx
+lTerm_yk  = LAbs 'y' $ LApp lTerm_t lTerm_t
+
+-- a) Implementieren Sie eine Eq-Instanz für den Datentyp LambdaTerm!
+--
+--    (Wer Lambda-Kalkül kennt: Zur Vereinfachung der Aufgabe
+--     ignorieren wir die übliche alpha-Äquivalenz, d.h.
+--     (LAbs 'x' $ LVar 'x') und (LAbs 'y' $ LVar 'y')
+--     dürfen als verschieden betrachtet werden)
+
+instance Eq LambdaTerm where
+  (LVar a) == (LVar b) = a == b
+  (LVar _) == _ = False
+  (LAbs a t_a) == (LAbs b t_b) = a == b && t_a == t_b
+  (LAbs _ _) == _ = False
+  (LApp t_a t'_a) == (LApp t_b t'_b) = t_a == t_b && t'_a == t'_b
+  (LApp _ _) == _ = False
+
+-- b) Implementieren Sie die eine Show-Instanz für LambdaTerm.
+--    Achten Sie dabei auf eine korrekte Klammerung, aber
+--    verschwenden Sie erst einmal keine Zeit darauf,
+--    überflüssige Klammern zu vermeiden.
+
+instance Show LambdaTerm where
+  show (LVar a) = "LVar '" ++ pure a ++ "'"
+  show (LAbs a t) = "LAbs '" ++ pure a ++ "' (" ++ show t ++ ")"
+  show (LApp t t') = "LApp (" ++ show t ++ ") (" ++ show t' ++ ")"
+
+
+-- | A2-3 Klassendeklaration
+--
+-- a) Deklarieren Sie eine Klasse "FinMap" für endliche partielle Abbildungen, welche folgende Operationen bereitsstellt:
+--   1) "emptyM" liefert eine leere Abbildung
+--   2) "insertM x a m" fügt die Abbildung  [x->a] in die Abbildung m ein.
+--                      Falls x schon enthalten war, dann wird es überschrieben.
+--   3) "lookupM x m" liefert Nothing zurück, falls x nicht in m enthalten ist;
+--                    ansonsten wird der für x gespeicherte Wert z zurückgeliefert (in Just verpackt)
+--                    Die Funktion "lookupM" darf dabei annehmen, dass für x eine Vergleichsoperation vorliegt!?!
+
+class FinMap m where
+  emptyM :: m k v
+  insertM :: Ord k => k -> v -> m k v -> m k v
+  lookupM :: Ord k => k -> m k v -> Maybe v
+  -- Can we get around using constraints here without using the MultiParamTypeClasses language extension?
+
+-- b) Machen Sie folgenden Datentyp zu einer Instanz der Typklasse Map:
+
+-- data AL a b = AL [(a,b)]
+newtype AL a b = AL [(a,b)]  -- Äquivalent zur vorherigen Zeile.
+                             -- newtype kann und darf verwenden werden,
+                             -- wenn man nur einen Konstruktor mit nur einem Argument hat.
+                             -- Dies erlaubt GHC eine Optimierung durchzuführen.
+               deriving (Show, Read, Eq)
+
+instance FinMap AL where
+  emptyM = AL $ []
+  insertM x a (AL m) = AL $ (x, a) : [p | p@(x', _) <- m, x' /= x]
+  lookupM x (AL m) = listToMaybe [y | (x', y) <- m, x' == x] -- Due to lazyness this is no slower than explicitly short-circuiting the search
+    where
+      -- This is part of Data.Maybe
+      listToMaybe [] = Nothing
+      listToMaybe (x:_) = Just x
+
+
+---- Werte zum anschließendem Testen, auskommentieren,
+---- sobald Klasse und Instanz definiert wurden:
+testMap0  :: AL Int Bool
+testMap0 = emptyM
+testMap1 = insertM 1 False testMap0
+testMap2 = insertM 3 False testMap1
+testMap3 = insertM 4 True  testMap2
+testMap4 = insertM 2 True  testMap3
+
+
+-- Hinweis:
+--    Partielle Abbildungen wie hier durch Assoziationslisten zu implementieren,
+--    ist nicht bensonders effizient, da der Zugriff auf ein Element im Allgemeinen
+--    den Aufwand O(n) hat (man muss die ganze Liste abklappern - es könnte sich ja
+--    um das letzte Element der Liste handeln).
+--    Mit Suchbäumen läßt sich der Aufwand bekanntermaßen auf O(log n) reduzieren.
+--    Wer noch Lust & Zeit hat, kann versuchen, dies selbst zu implementieren
+--    und zur einer weiteren Instanz von FinMap machen.
+--
+--    Die Standardbibliothek sieht zur Abstraktion hier keine solche Klasse vor,
+--    sondern bietet lediglich eine konkrete, effiziente Implementierung von
+--    endlichen Abbildungen an: Data.Map, welche wir in der kommenden Vorlesung
+--    betrachten werden.
+--
+--    Dies kann man natürlich ganz schnell zu einer Instanz von FinMap machen. Wie?
+
+data Map k v = Tip
+             | Branch k v (Map k v) (Map k v)
+
+instance FinMap Map where
+  emptyM = Tip
+  insertM k v Tip = Branch k v Tip Tip
+  insertM k v (Branch k' v' lt gt)
+    | k == k' = Branch k v lt gt
+    | k < k' = Branch k' v' (insertM k v lt) gt
+    | otherwise = Branch k' v' lt (insertM k v gt)
+  lookupM _ Tip = Nothing
+  lookupM k (Branch k' v' lt gt)
+    | k == k' = Just v'
+    | k < k' = lookupM k lt
+    | otherwise = lookupM k gt
+
+instance FinMap P.Map where
+  emptyM = P.empty
+  insertM = P.insert
+  lookupM = P.lookup
diff --git a/ws2015/ffp/blaetter/03/FFP_U03_Funktoren.hs b/ws2015/ffp/blaetter/03/FFP_U03_Funktoren.hs
new file mode 100644
index 0000000..88ee00f
--- /dev/null
+++ b/ws2015/ffp/blaetter/03/FFP_U03_Funktoren.hs
@@ -0,0 +1,191 @@
+-- Fortgeschrittene Funktionale Programmierung,
+--   LMU, TCS, Wintersemester 2015/16
+--   Steffen Jost, Alexander Isenko
+--
+-- Übungsblatt 03 am 3.11.2015
+--
+-- Thema:
+--
+-- Anweisung:
+--   Gehen Sie diese Datei durch und bearbeiten Sie
+--   alle Vorkommen von undefined bzw. die mit -- !!! TODO !!!
+--   markierten Stellen. Testen Sie Ihre Lösungen mit GHCi!
+--
+--
+
+import Data.List (groupBy)
+import Data.Function (on)
+
+-- Bearbeiten Sie zuerst Übungsblatt 02 vollständig!
+
+
+---- A3-1 Funktoren
+--
+-- Machen Sie folgende Datentypen zur einer Instanz der Klasse Functor.
+-- Versuchen Sie dabei, möglichst nicht in die Folien zu schauen!
+-- (Falls Sie doch in die Folien schauen, dann möglichst nur 2-25 und 2-31ff.;
+-- da die Beispiele 2-28 und 2-29 nahezu die komplette Lösung verraten.)
+
+
+-- a)
+data Options a = None | One a | Two a a | Three a a a
+ deriving (Ord, Show)
+
+-- Wenn wir nur die ersten beiden Konstuktoren von "Options" betrachten,
+-- dann haben wir genau den Datentyp "Maybe"  aus der Standardbibliothek.
+
+instance Functor Options where
+  fmap _ None = None
+  fmap f (One a) = One (f a)
+  fmap f (Two a b) = Two (f a) (f b)
+  fmap f (Three a b c) = Three (f a) (f b) (f c)
+
+-- Zum Testen:
+testO0 = None
+testO1 = One 4.2
+testO2 = Two 4.2 6.9
+-- Tests auskommentierbar, sobald Functor Instanz definiert:
+testa1 = None == fmap (+2) testO0
+testa2 = Two 8.4 13.8 == fmap (*2) testO2
+
+
+-- b)
+data Tree a = Node a [Tree a]
+ deriving (Eq, Show)
+
+--Hilfsfunktion
+leaf :: a -> Tree a
+leaf x = Node x []
+
+instance Functor Tree where
+  fmap f (Node a xs) = Node (f a) $ map (fmap f) xs
+
+-- Zum Testen:
+testT1 = Node 1 [Node 2 [Node 3 [], leaf 4, Node 5 [leaf 6, leaf 7, leaf 8]], leaf 9, Node 10 [leaf 11]]
+testT2 = Node False [Node True [Node False [],leaf True,Node False [leaf True,leaf False,leaf True]],leaf False,Node True [leaf False]]
+-- Test auskommentierbar, sobald Functor Instanz definiert:
+testb1 = testT2 == (fmap even testT1)
+
+
+
+
+---- A3-2 Funktor (->) a
+--
+-- Die Standardbibliothek definiert eine Funktor-Instanz für den Typ "(->) a".
+-- Wir wollen hier herausfinden, was dies bedeutet:
+--
+-- Der Typ "(->) a" ist ein Typ mit einem ``Loch'',
+-- so wie die Typen "Tree" oder "[ ]" auch.
+-- Die runde Klammer bedeutet lediglich Präfix-Notation anstatt Infix-Notation.
+-- Wenn wir also einen Typ "b" hineingeben wird daraus der Typ (im vertrauten Infix)
+--    a -> b
+-- ganz analog wird aus "Tree" oder "[ ]" zu "Tree b" oder "[b]".
+--
+
+-- a) Welchen konkreten Typ bekommt die Funktion "fmap"
+--    für die Funktor-Instanz von "(->) a"?
+--
+--    Hinweis: Ein Beispiel findet sich auf Folie 2-26.
+--             Oben ist der allgemeine Typ von fmap angegeben.
+--             Unten dann nochmal konkreter für die Listen-Instanz.
+
+{-
+  fmap :: Functor f => (a -> b) -> f a -> f b
+  fmap :: (a -> b) -> (x -> a) -> (x -> b)
+-}
+
+-- b) Die Standardbibliothek enthält bereits eine Funktion des in a) gefundenen Typs!
+--    Wie heisst diese Funktion und was macht sie?
+--    Testen Sie anschließend in GHCI, ob sie die Funktion
+--    tatsächlich mit fmap vertauschen können!
+--
+--    Hinweis: Diese Funktion wird Ihnen in einer Vorlesung über
+--             funktionaler Programmierung  mit Sicherheit begegnet sein,
+--             da sie von fundamentaler Bedeutung ist.
+--             (Jedoch sicherlich nicht als Funktor behandelt... ;) )
+
+{-
+  fmap ist hier identisch zu (.)
+  λ ((\a -> (a, a)) `fmap` (+ 2)) 2
+  (4,4)
+-}
+
+
+
+
+---- A3-3 Unendliche Listen
+--
+-- a) Definieren Sie die unendliche Liste alle Zweierpotenzen: [1,2,4,8,16,32,64,128,256,..]
+
+quadrate :: [Integer]
+quadrate = map (2^) [0..]
+
+quadrate' :: [Integer] -- More efficient (probably)
+quadrate' = 1 : [2 * x | x <- quadrate']
+
+-- Zum Testen:
+q1 = take 5 quadrate
+-- > q1
+-- [1,2,4,8,16]
+q2 = quadrate !! 10
+-- > q2
+-- 1024
+
+
+-- b) Definieren Sie eine unendliche Liste, welche alle
+--    erdenklichen Strings aus den Buchstaben ['a','b','c','d'].
+--    Die Reihenfolge ist relativ egal, aber kürzere Strings sollen vor längeren Erscheinen;
+--    d.h. "dd" kommt nach "b", aber vor "abc"
+
+alleVariablen :: [String]
+alleVariablen = seed : alleVariablen' [seed]
+  where
+    seed = ""
+    vars = ['a','b','c','d']
+    alleVariablen' prevs = now ++ alleVariablen' now
+      where
+        now = [v : p | v <- vars, p <- prevs]
+
+alleVariablen' :: [String] -- Preferred.
+alleVariablen' = "" : [v : p | p <- alleVariablen', v <- vars]
+  where
+    vars = ['a', 'b', 'c', 'd']
+    
+-- Zum Testen:
+check l x = (map length . groupBy ((==) `on` length)) (take x l)
+
+-- Beispielimplementierung (muss nicht identisch sein):
+-- > take 30 alleVariablen
+-- [""
+-- ,"a"  ,"b"  ,"c"  ,"d"
+-- ,"aa" ,"ab" ,"ac" ,"ad" ,"ba" ,"bb" ,"bc" ,"bd" ,"ca" ,"cb","cc","cd","da","db","dc","dd"
+-- ,"aaa","aab","aac","aad","aba","abb","abc","abd","aca"]
+--
+-- Prüfe Längen:
+-- > check alleVariablen 30
+-- [1,4,16,9]
+
+
+
+
+-- A3-4 Instanzen
+-- Wer sich mit Klassen und Instanzen noch nicht so sicher fühlt,
+-- sollte zur Übung die automatisch abgeleiteten Instanzdeklaration
+-- für die Datentypdeklarationen in A3-1 von Hand deklarieren;
+-- also z.B.
+--   von "Options" zur Typklassen "Eq"
+--   von "Tree a"  zur Typklasse "Ord"
+--
+-- sie müssen oben in den Datentypdeklarationen dann natürlich
+-- die entsprechenden Klassen aus Zeile mit "deriving" herauslöschen
+-- da es ja immer nur _eine_ Instanzdeklaration pro Typ/Klassen-Paar geben darf
+
+instance Eq a => Eq (Options a) where
+  None == None = True
+  One a == One a' = a == a'
+  Two a b == Two a' b' = a == a' && b == b'
+  Three a b c == Three a' b' c' = a == a' && b == b' && c == c'
+  _ == _ = False
+
+instance Ord a => Ord (Tree a) where
+  compare (Node x xs) (Node x' xs') = compare x x' `mappend` compare xs xs'
diff --git a/ws2015/ffp/blaetter/04/FFP_U04_Lazy.hs b/ws2015/ffp/blaetter/04/FFP_U04_Lazy.hs
new file mode 100644
index 0000000..36c0578
--- /dev/null
+++ b/ws2015/ffp/blaetter/04/FFP_U04_Lazy.hs
@@ -0,0 +1,543 @@
+-- Fortgeschrittene Funktionale Programmierung, 
+--   LMU, TCS, Wintersemester 2015/16
+--   Steffen Jost, Alexander Isenko
+--
+-- Übungsblatt 04. 11.11.2015
+--
+-- Thema:
+--
+-- Anweisung: 
+--   Gehen Sie diese Datei durch und bearbeiten Sie 
+--   alle Vorkommen von undefined bzw. die mit -- !!! TODO !!!
+--   markierten Stellen. Testen Sie Ihre Lösungen mit GHCi!
+--  
+--
+
+import qualified Data.Map as Map
+import Data.Map (Map)
+import qualified Data.Set as Set
+import Data.Set (Set)
+import qualified Data.List as List ((\\))
+
+import Data.Maybe (fromMaybe)
+import Data.Tuple (swap)
+
+import Control.Applicative (Applicative(..), (<$>))
+
+---- A4-1 Verzögerte Auswertung
+-- Gegeben ist folgendes Programm:
+xs    = [1..]
+foo x = 2 * x
+ys    = foo <$> xs
+rs    = take 1 $ drop 1 ys
+
+{-Skizzieren Sie mit Papier und Bleistift,
+  wie am Ende der Speicher aussieht, wenn lediglich
+    rs
+  ausgewertet wurde (z.B. durch Anzeige am Bildschirm).
+
+  Welche Strukturen gibt es im Speicher?
+  Wie viele Thunks befinden sich noch im Speicher?
+  Auf welche Adressen zeigen xs, ys, rs in den von Ihnen skizzierten Speicher?
+
+  Hinweise:
+  - An jeder Speicheraddresse sollte sich entweder ein Thunk (also ein Programmausdruck)
+  oder ein Wert befinden.
+  - Für Datentypen wird der Wert dargestellt als Tupel aus Konstruktor
+  und den Speicheraddressen seiner Argumente.
+  - Funktionsdefinitonen lassen wir zur Vereinfachung aus dem Speicher heraus.
+  - Speicheraddressen dürfen Sie völlig willkürlich wählen
+
+  BEISPIEL:
+
+  -- Programm:
+  zs = [27..]
+  ts = take 1 $ drop 2 zs
+  x  = head ts
+
+  -- Nach Auswertung von x haben wir den Zustand:
+
+  [ <01>,(:),<11>,<02> | <02>,(:),<12>,<03> | <03>,(:),<13>,<04> | <04>,"[30..]"
+  | <11>,Int,27 | <12>,Int,27+1 | <13>,Int,29
+  | <21>,(:),<13>,<22> | <22>,[]
+  ]
+
+  Thunks: <04>,<12>
+
+  zs -> <01>
+  ts -> <21>
+  x  -> <13>
+  -}
+
+{-
+
+| 10 | (:) 1 <30>         |
+| 20 | [3..]              |
+| 30 | (:) 2 <20>         |
+| 40 | (:) <50> <60>      |
+| 50 | (*) 2 <20>         |
+| 60 | 4                  |
+| 61 | (<$>) ((*) 2) <20> |
+| 70 | (:) <60> <71>      |
+| 71 | []                 |
+
+Thunks: 20, 50, 61
+  
+xs = <10>
+ys = <40>
+rs = <70>
+
+-}
+
+
+---- A4-2 Zirkularität
+-- a)
+-- Schreiben Sie ein zirkuläres Programm transcl,
+-- welches zu einer gegebenen Relation r :: a -> [a]
+-- und einer als Liste gegebenen Menge,
+-- die transitive Hülle dieser Menge zu der Relation berechnet.
+--
+-- Eine Relation r :: a -> [a] ist dabei so kodiert,
+-- das r x die Menge aller Elemente ist, welche zu x in Relation stehen.
+--
+-- HINWEIS:
+-- Das Ergebnis soll eine Menge modellieren, es darf also kein Element
+-- doppelt vorkommen. Die Reigenfolge der Elemente in der Liste ist aber egal.
+--
+-- BEISPIELE:
+--
+-- > transCl rel1 [22]
+-- [33,44]
+-- > transCl rel1 [2,5]
+-- [2,5,4,6,8,1,3,7,9]
+--
+-- > sort $ transCl rel2 [42,8,9]
+-- [1,2,4,5,7,8,9,10,11,13,14,16,17,20,21,22,26,28,32,34,40,42,52,64]
+--
+-- HINWEIS: Folgen Sie dem nub2 Beispiel aus Folie 3-30
+
+
+transCl :: Eq a => (a -> [a]) -> [a] -> [a]
+transCl r xs = res
+  where
+    res = build xs 0
+    
+    build [] _ = []
+    build xs n = xs' ++ build xs' (n + length xs')
+      where
+        xs' = strikeKnown n $ concatMap r xs
+
+    strikeKnown _ [] = []
+    strikeKnown 0 xs = xs
+    strikeKnown n (x:xs)
+      | x `elem` take n res = strikeKnown n xs
+      | otherwise = x : strikeKnown n xs
+
+-- Zum Testen:
+rel1 :: Integer -> [Integer]
+rel1 11                 = [22]
+rel1 22                 = [33]
+rel1 33                 = [44]
+rel1 n
+  | even n, n>=1, n<=9 = [2,4,6,8]
+  | odd n,  n>=1, n<=9 = [1,3,5,7,9]
+  | otherwise          = [n]
+
+rel1S :: Integer -> Set Integer
+rel1S = Set.fromList . rel1
+
+rel2 :: Integer -> [Integer]
+rel2 n
+  | even n    = [n,n `div` 2]
+  | otherwise = [3*n+1,n]
+
+rel2S :: Integer -> Set Integer
+rel2S = Set.fromList . rel2
+
+
+-- b)
+-- Implementieren Sie die Aufgabe noch mal ganz schnell
+-- ohne Rücksicht auf Zirkularität oder Effizienz,
+-- sondern ganz bequem mit der Standardbibliothek für Data.Set
+       
+-- The implementation below seems to me no nicer than a :(
+
+transClS :: (Ord a) => (a -> Set a) -> Set a -> Set a
+transClS rel xs = build xs Set.empty
+  where
+    res = build xs Set.empty
+
+    build xs known
+      | Set.null xs = Set.empty
+      | otherwise   = xs' `Set.union` build xs' (xs' `Set.union` known)
+      where
+        xs' = Set.foldr Set.union Set.empty (Set.map rel xs) Set.\\ known
+
+
+
+
+---- A4-3 Verzögerte Auswertung
+{-Ein Kollege von Dr Jost meinte einmal, dass man Dinge am Besten durch Implementation erlernt.
+  Also wollen wir in dieser Aufgabe verzögerte Auswertung für einen Fragment von Haskell Implementieren.
+  Wir machen uns das Leben einfach und nehemen nur folgendes, minimales Fragment her:
+    * Variablen                 z.B.    "y"
+    * Anonyme Funktionen        z.B.    "\x->x"
+    * Funktionsanwendung        z.B.    "(\x->x) y" evaluiert zu "y"
+  Wir verzichten also auf sehr viel: keine Pattern-Matching, kein if-then-else,...
+  ...sogar auf Basisdatentypen wie Int oder Bool verzichten wir!
+
+  Die Terme unseres Sprach-Fragments modellieren wir durch folgenden Datentyp:
+  -}
+
+data Term = Var Variable | Abs Variable Term | App Term Term
+  deriving (Eq)
+
+type Variable = String
+
+{-
+  Einige Hilfsfunktionen, sowie einige Beispiel-Terme sind weiter unten,
+  im Anhang dieser Datei definiert. Ebenso wurde eine vernünftige Show-Instanz vorgegeben.
+  so dass die Terme wie Haskell-Code ausschauen:
+  *Main> Abs "x" (App (Var "f") (Var "x" ))
+  \x -> f x
+
+  Von den Hilfsfunktionen sollten Sie eigentlich nur
+    subst :: (Variable, Term) -> Term -> Term
+  benötigen. Der Ausdruck "subst (x,t1) t2" bedeutet "t2[t1/x]",
+  also im Ausdruck t2 werden alle Vorkommen von x durch t1 ersetzt.
+
+
+  NEBENBEMERKUNG;
+  zum Lösen dieser Aufgabe nicht wichtig:
+
+  Richtig, es handelt sich dabei erneut um den Lambda-Kalkül,
+  wie wir ihn schon in Aufgaben A1-1g und A2-2 kennengelernt haben.
+  Anstatt "\x->x" würde man im Lambda-Kalkül eher "λx.x" schreiben, aber
+  das ist auch der einzige Unterschied. O
+  bwohl wir hier auf so viel verzichten, handelt es sich übrigens immer noch um eine Turing-Vollständige Sprache!
+  Also wollen wir hier die verzögerte Auswertestrategie anhand des Lambda-Kalküls üben...  ;)
+-}
+
+
+-- a) Einfache Auswertung
+--
+-- Wir schreiben uns zuerst eine simple Auswertung von Lambda-Ausdrücken, also
+-- eine Funktion "eval :: Term -> Term". Das vorgehen ist wie folgt:
+--
+--  1) Variablen werten zu sich selbst aus (d.h. sind bereits ausgewertet); nichts zu tun.
+--
+--  2) Abstraktionen sind auch bereits ausgewertet; nichts zu tun.
+--     (Wenn man will, dann könnte man auch erst noch den Rumpf auswerten, soweit möglich.
+--      Dies ist eine reine Definitionsfrage, darf jeder machen wie er will.
+--      Im Allgemeinen wird nicht unter einem Lambda reuduziert, aber beim Testen
+--      werden die Terme leichter verständlich, wenn man unter dem Lambda reduziert.)
+--
+--  3) Zum Auswerten einer Applikationen "App" muss man zuerst die Funktion auswerten.
+--     Erhält man einen Lambda-Ausdruck "Abs", so ersetzt man alle Vorkommen
+--     der abstrahierten Variable durch das zuvor ausgewertete Funktionsargument.
+--     (Ansonsten liefert man einfach die gesamte Applikation zurück.)
+--
+-- Hinweis: Im 3. Fall muss man noch aufpassen, das keine freien Variablen eingefangen werden.
+--          Glücklicherweise ist dies für uns bereits implementiert. Verwenden Sie einfach die Funktion "subst"
+--          zur Substitution des Funktionsparameters im Rumpf der Funktion.
+--          (Die Funktion "subst" ist weiter unten im Anhang dieser Datei definiert.)
+--
+-- Einfache Implementierung der Auswertung :
+eval :: Term -> Term
+eval (App f x) = case eval f of
+  (Abs v t) -> eval $ subst (v, x) t
+  t         -> eval $ t
+eval x = x
+
+
+{- Beispiele, ohne Auswertung unter einem Lambda, Konstanten cK, c1, usw. sind weiter unten, im Anhang der Datei definiert.
+
+*Main> eval $ App (App cK c1) vX
+\f -> \a -> f a
+
+*Main> eval $ App cISNULL (App cSUCC c0)
+\x -> \y -> y
+
+-}
+
+
+-- b)
+--
+-- Da Haskell eine Sprache mit verzögerter Auswertung ist,
+-- vererbt sich dies bereits auch auf unsere Implementierung von eval:
+--   *Main> eval $ App (App cK c1) cOmega
+--   \f -> \x -> f x
+--
+-- Bei der Auswertestrategie "Call-By-Value" sollte dies eigentlich gar nicht auswerten,
+-- da cOmega nicht endlich auswertbar ist.
+--
+-- Eine Möglichkeit ist es, die Auswertung genauer zu simulieren.
+-- Dazu nutzen wir jetzt eine Map zur Modellierung unseres Speichers:
+
+type Memory = Map Variable Term
+
+-- Ein Wert des Typs "Memory" bildet also Werte des Typs "Variable" auf Werte des Typs "Term" ab.
+--
+-- Zur Anzeige eines Terms benötigen wir nun natürlich auch den Speicher, um den Kontext der Variablen zu haben.
+-- Verwenden Sie zur Anzeige also diese gegebene Funktion:
+showMem :: (Memory,Term) -> Term
+showMem (m,t) = Map.foldlWithKey (\r v s -> subst (v,s) r) t m
+
+-- Diese Anzeige bauchen wir gleich in unsere Auswertefunktion ein:
+evalStrict :: Term -> Term
+evalStrict t = showMem $ evalS0 t
+
+-- Die Funktion evalS0 ist nur eine Kurzform, um die Auswertung mit leerem Speicher zu starten:
+evalS0 :: Term -> (Memory, Term)
+evalS0 = evalS Map.empty
+
+-- Ihre Aufgabe ist es also, evalS zu implementieren:
+
+evalS :: Memory -> Term -> (Memory, Term)
+evalS m x@(Var v) = (,) m $ fromMaybe x $ Map.lookup v m
+evalS m t@(App f x) = case f' of
+  (Abs v t) -> let
+    usedVars = Set.unions $ (Map.keysSet m'' :) $ map freeVars $ Map.elems m''
+    v' = generateFreshVar usedVars
+    (m'', x') = evalS m' x
+    m''' = Map.insert v' x' m''
+    in evalS m''' $ subst (v,Var v') t
+  _         -> (m, t)
+  where
+    (m', f') = evalS m f
+evalS m x = (m, x)
+
+-- Dabei verfolgen wir folgende Auswertestrategie:
+--
+--   1) Der Wert einer Variablen wird im Speicher nachgeschlagen.
+--      Freie Variablen werten nach wie vor zu sich selbst aus.
+--
+--   2) Unverändert: Abstraktionen sind bereits ausgewertet.
+--
+--   3) Bei der Auswertung von Applikationen verzichten wir auf Substitution.
+--      Stattdessen legen wir das ausgewertete Argument im Speicher
+--      unter der abstrahierten Variable ab.
+--
+-- Im Fall 3) treten einige Probleme auf:
+--  - Der Speicher muss durch die rekursiven Aufruf von evalS hindurchgefädelt werden.
+--    Es sollte immer nur auf den neuesten Speicher zugegriffen werden,
+--    damit die Modellierung stimmt!
+--
+--  - OPTIONAL: Wenn es aber nur einen Speicher gibt, kann es zu Namenskonflikten im Speicher
+--    kommen. Dies kann vermieden werden, wenn Variable vor dem Speichern in frische Variablen
+--    umbenannt werden. Verwenden Sie dazu die Hilfsfunktionen: freeVars, generateFreshVar & subst.
+--
+-- Wenn Sie es richtig gemacht haben, sollte das obige Beispiel mit cOmega jetzt nicht mehr terminieren.
+
+
+-- c) Nun wollen wir es wieder verbessern, in dem wir verzögerte Auswertung explizit simulieren.
+--
+--    Im Fall 1) updaten wir den Speicher nach der Auswertung des abgespeicherten Terms,
+--    um wiederholte Auswertung zu vermeiden.
+--    (Der Einfachheit verzichten wir auf eine Prüfung/Flag ob im Speicher ein Thunk ist oder nicht:
+--     wir werten und updaten immer - wenn es schon ein Wert war, dann geht die Auswertung ja schnell)
+--
+--    Fall 2) Abs bleibt Unverändert
+--
+--    Im Fall 3) App legen wir also nur den unausgewerten Term im Speicher ab.
+--
+
+evalLazy :: Term -> Term
+evalLazy t = showMem $ evalL0 t
+
+evalL0 ::Term -> (Memory, Term)
+evalL0 = evalL Map.empty
+
+evalL :: Memory -> Term -> (Memory, Term)
+evalL m x@(Var v) = case Map.lookup v m of
+  Nothing -> (m, x)
+  Just t -> let
+    (m', t') = evalL m t
+    in (Map.insert v t' m', t')
+evalL m t@(App f x) = case f' of
+  (Abs v t) -> let
+    usedVars = Set.unions $ (Map.keysSet m' :) $ map freeVars $ Map.elems m'
+    v' = generateFreshVar usedVars
+    m'' = Map.insert v' x m'
+    in evalL m'' $ subst (v,Var v') t
+  _         -> (m, t)
+  where
+    (m', f') = evalL m f
+evalL m x = (m, x)
+
+
+
+ -- I am of the considered opinion that the above exercises call for State. Therefore:
+
+data State s a = State { unState :: s -> (a, s) }
+
+instance Functor (State s) where
+  fmap f (State g) = State ((\(a, s) -> (f a, s)) . g)
+
+instance Applicative (State s) where
+  pure a = State (\s -> (a, s))
+  (State f) <*> (State g) = State (\s -> (\(g', s) -> (\(f', s') -> (f' g', s')) $ f s) $ g s)
+
+instance Monad (State s) where
+  return = pure
+  (State f) >>= g = State ((\(a, s) -> (unState $ g a) s) . f)
+
+get :: State s s
+get = State (\s -> (s, s))
+
+put :: s -> State s ()
+put s = State (\_ -> ((), s))
+
+modify :: (s -> s) -> State s ()
+modify f = (f <$> get) >>= put
+
+evalStrict' :: Term -> Term
+evalStrict' t = showMem $ evalS0' t
+  where
+    evalS0' = evalS' Map.empty
+
+evalLazy' :: Term -> Term
+evalLazy' t = showMem $ evalL0' t
+  where
+    evalL0' = evalL' Map.empty
+
+evalS' :: Memory -> Term -> (Memory, Term)
+evalS' m t = swap $ (unState $ eval t) m
+  where
+    eval :: Term -> State Memory Term
+    eval t@(Var v) = (fromMaybe t . Map.lookup v) <$> get
+    eval t@(App f x) = do
+      f' <- eval f
+      case f' of
+        (Abs v t) -> do
+          x' <- eval x
+          mem <- get
+          let
+            boundInTerms = Set.unions . map freeVars $ Map.elems mem
+            usedVars = boundInTerms `Set.union` Map.keysSet mem
+            v' = generateFreshVar usedVars
+          modify $ Map.insert v' x'
+          eval $ subst (v, Var v') t
+        _         -> pure t
+    eval t = pure t
+
+evalL' :: Memory -> Term -> (Memory, Term)
+evalL' m t = swap $ (unState $ eval t) m
+  where
+    eval :: Term -> State Memory Term
+    eval t@(Var v) = do
+      t' <- Map.lookup v <$> get
+      case t' of
+        Nothing -> return t
+        Just t  -> do
+          t' <- eval t
+          modify $ Map.insert v t'
+          return t'
+    eval t@(App f x) = do
+      f' <- eval f
+      case f' of
+        (Abs v t) -> do
+          mem <- get
+          let
+            boundInTerms = Set.unions . map freeVars $ Map.elems mem
+            usedVars = boundInTerms `Set.union` Map.keysSet mem
+            v' = generateFreshVar usedVars
+          modify $ Map.insert v' x
+          eval $ subst (v, Var v') t
+        _         -> pure t
+    eval t = pure t
+
+-----------------------------------------------------------------------
+-- ANHANG
+--
+-- Für erweiterten Komfort gegeben wir noch einige Definitionen vor!
+--
+
+
+-- Hier einige Lambda-Terme zum Testen:
+vX = Var "x"
+vY = Var "y"
+vZ = Var "z"
+lTest1 = App (App vX vY) vZ
+lTest2 = App vX (App vY  vZ)
+
+-- Combinators       (allgmein bekannte Lambda-Terme)
+cI      = Abs "x" $ Var "x"                            -- \x   -> x
+cK      = Abs "x" $ Abs "y" $ Var "x"                  -- \x y -> x
+cS      = Abs "z" $ Abs "y" $ Abs "x" $ App (App (Var "z") (Var "x")) (App (Var "y") (Var "x")) -- \z y x -> (z x) (y x)
+cT      = Abs "x" $ App (Var "x") (Var "x")            -- \x -> x x
+cOmega  = App cT cT                                    -- (\x -> x x) (\x -> x x)
+
+-- Church Booleans  (wer keine eingebauten Datentypen hat, bastelt sich halt selbst welche, so wie es uns Alonzo Church zeigte)
+cTRUE   = Abs "x" $ Abs "y" $ Var "x"                       -- \x y -> x
+cFALSE  = Abs "x" $ Abs "y" $ Var "y"                       -- \x y -> y
+cCOND   = Abs "x" $ Abs "y" $ Abs "z" $ App (App vX vY) vZ  -- \x y z -> (x y) z
+
+-- Church Numerals  (wer keine eingebauten Zahlen hat, kann sich auch diese selbst stricken)
+c0      = Abs "f" $ Abs "x" $ Var "x"                  -- \f x -> x
+c1      = Abs "f" $ Abs "x" $ App (Var "f") (Var "x")  -- \f x -> f x
+c2      = eval $ App cSUCC c1                          -- \f -> \x -> f (f x)
+c3      = eval $ App cSUCC c2                          -- \f -> \x -> f (f (f x))
+cSUCC   = Abs "n" $ Abs "f" $ Abs "x" $ App (Var "f") $ App (App (Var "n" ) (Var "f")) (Var "x") -- \n f x -> f ((n f) x)
+cPLUS   = Abs "m" $ Abs "n" $ Abs "f" $ Abs "x" $ App (App (Var "m") (Var "f")) $ App (App (Var "n" ) (Var "f")) (Var "x") -- \m n f x -> (m f) ((n f) x)
+cISNULL = Abs "x" $ App (App (Var "x") (Abs "x" cFALSE)) cTRUE -- \x -> x (\x -> (\x y -> y))) (\x y -> x))
+
+-- Lambda Terme hübsch anzeigen, in Haskell Notation, also anstatt "λf.λx.f x" schreiben wir hier "\f-> \x-> f x".
+instance Show Term where
+  showsPrec _ (Var x)   = showString x
+  showsPrec n (App s t) = showParen (n>1) $ (showsPrec 1 s) . showString " " . showsPrec 2 t
+  showsPrec n (Abs x t) = showParen (n>0) $ showString ('\\':x) . showString " -> " . showsPrec n t
+
+-----------------------------
+-- Nützliche Hilfsfunktionen
+--
+
+-- Substitution, welche das Einfangen freier Variablen verhindert.
+-- Alle _freien_ Vorkommen einer Variable werden durch einen Term ersetzt.
+-- Gebundene Variablen werden ggf. ersetzt, damit es nicht zu Namenskonflikten kommt:
+--         [y/x]        ( \y -> x y                       ) == \z -> y z
+-- subst ("x", Var "y") (Abs "y" $ App (Var "x") (Var "y"))
+--
+-- Wenn wir die Variable "x" durch den Term "y" ersetzen wollen, dann müssen wir
+-- aufpassen, dass keine gebundenen Variablen 'eingefangen' werden, denn
+-- "\y->x y" ist ja äquivalent zu "\z ->x z".
+-- Also soll auch "(\y->x y)[y/x]" äquivalent zu "(\z ->x z)[y/x]" == "\z->y z" sein.
+-- Wenn wir aber nur blind einsetzen würden, gilt das nicht, denn wir bekämen "\y->y y".
+--
+
+subst :: (Variable, Term) -> Term -> Term
+subst (x,e) o@(Var y)
+  | x == y    = e
+  | otherwise = o
+subst s (App e1 e2) = App (subst s e1) (subst s e2)
+subst s@(x,e) o@(Abs y e1)
+  | x == y                 = o
+  | y `Set.notMember` fv_e = Abs y (subst s e1)
+  | otherwise              = Abs freshV (subst (x,e) $ subst (y, Var freshV) e1) -- avoiding capture
+  where
+    fv_e   = freeVars e
+    fv_e1  = freeVars e1
+    freshV = generateFreshVar (fv_e `Set.union` fv_e1)
+
+
+-- Freie Variablen eines Terms
+freeVars :: Term -> Set Variable
+freeVars (Var x)     = Set.singleton x
+freeVars (App e1 e2) = Set.union (freeVars e1) (freeVars e2)
+freeVars (Abs x  e1) = Set.delete x $ freeVars e1
+
+-- Frische Variable berechnen
+generateFreshVar :: Set Variable -> Variable
+generateFreshVar vs
+  | v `Set.notMember` vs = v
+  | otherwise            = succString $ Set.findMax vs
+  where
+    v  = "a"
+
+-- Note that Ord String has "z" > "aa", so succString s = s ++ "a" would suffice
+-- Ensure that "s" < succString "s"
+succString :: String -> String
+succString     ""  = "a"
+succString ('z':s) = 'z' : succString s
+succString ( c :s) = (succ c) : s
+