1 files changed, 543 insertions, 0 deletions

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
+