1 files changed, 110 insertions, 6 deletions

diff --git a/ws2015/FFP/blaetter/04/FFP_U04_Lazy.hs b/ws2015/FFP/blaetter/04/FFP_U04_Lazy.hs
index b84ad0b..36c0578 100644
--- a/ws2015/FFP/blaetter/04/FFP_U04_Lazy.hs
+++ b/ws2015/FFP/blaetter/04/FFP_U04_Lazy.hs
@@ -20,6 +20,9 @@ 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:
@@ -156,6 +159,8 @@ rel2S = Set.fromList . rel2
 -- 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
@@ -283,18 +288,23 @@ 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 :: 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 (App f x) = case f' of
-  (Abs v t) -> undefined
-  t         -> evalS m' t
+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
+    (m', f') = evalS m f
 evalS m x = (m, x)
 
 -- Dabei verfolgen wir folgende Auswertestrategie:
@@ -339,9 +349,103 @@ evalL0 ::Term -> (Memory, Term)
 evalL0 = evalL Map.empty
 
 evalL :: Memory -> Term -> (Memory, Term)
-evalL  = undefined -- !!! TODO !!!
+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