FFP 09

1 files changed, 328 insertions, 0 deletions

diff --git a/ws2015/ffp/blaetter/09/FFP_U09_Concurrent.hs b/ws2015/ffp/blaetter/09/FFP_U09_Concurrent.hs
new file mode 100644
index 0000000..99026c0
--- /dev/null
+++ b/ws2015/ffp/blaetter/09/FFP_U09_Concurrent.hs
@@ -0,0 +1,328 @@
+-- Fortgeschrittene Funktionale Programmierung, 
+--   LMU, TCS, Wintersemester 2015/16
+
+--   Steffen Jost, Alexander Isenko
+--
+-- Übungsblatt 09. 16.12.2015
+--
+-- Thema: Ausnahmen & Nebenläufigkeit
+--
+-- Hinweis:
+--   Für diese Übung ist ein Rechner mit mehreren Kernen
+--   nützlich, aber nicht zwingend notwendig.
+--   Wenn Sie möchten, dann Benutzen Sie einfach einen 
+--   Mehrkern-Rechner am CIP-Pool der Informatik. Hinweise
+--   zum Remote-Login am CIP-Pool finden Sie am Anfang des 
+--   vorherigen Übungsblattes.
+-- 
+--   
+-- Anweisungen:  
+--
+--   Gehen Sie diese Datei durch und bearbeiten Sie 
+--   alle Vorkommen von undefined bzw. die mit -- !!! TODO !!!
+--   markierten Stellen. Testen Sie Ihre Lösungen mit GHC!
+--  
+
+
+import Data.List
+import Data.Typeable
+import Control.Exception
+import Control.Monad
+import Control.Concurrent
+import Control.DeepSeq
+
+import Data.Ord (comparing)
+
+import System.Environment (getArgs)
+
+-- Zum Umschalten zwischen den Aufgaben umkommentieren,
+-- oder besser die Aufgaben in einzelne Dateien auftrennen.
+main = main' [ ("1", main_A8_1)
+             , ("2", main_A8_2)
+             , ("3", main_A8_3)
+             ]
+
+main' :: [(String, IO ())] -> IO ()
+main' as = do
+  args <- getArgs
+  let
+    handler (x, a)
+      | x `elem` args = a
+      | otherwise = return ()
+  mapM_ handler as
+
+
+-- A8-1 Ausnahmen
+--
+-- a) 
+-- Definieren Sie eine Funktion "myHead",
+-- welche wie "head" aus der Standardbibliothek funktioniert,
+-- aber stattdessen eine von Ihnen selbst-definierte
+-- Ausnahme wirft. 
+-- 
+
+data EmptyListException = EmptyListException
+                        deriving (Show, Typeable)
+
+instance Exception EmptyListException
+
+myHead :: [a] -> a
+myHead [] = throw EmptyListException
+myHead (a:_) = a
+
+main_A8_1 :: IO ()
+main_A8_1 = do
+    putStrLn "Jetzt sollten drei Werte kommen, aber keine Exception:"
+    print $ myHead     [1,2,undefined] -- Zeile nicht ändern! 
+    h1 <- mySafeHead [3,4,undefined]   -- Zeile nicht ändern!
+    print h1
+    h2 <- mySafeHead empty
+    print h2
+    putStrLn "Jetzt sollte gleich eine benutzerdefinierte Exception kommen:"
+    print $ myHead   empty
+  where
+      empty = [] :: [Int] -- Typangabe für leere Liste, 
+                          -- damit Show-Instance festgelegt wird.
+                          -- HINWEIS: 
+                          -- Das ist gar nicht albern, denn 
+                          -- "print ([] :: String)" soll ja etwas
+                          -- anderes ausgeben als
+                          -- "print ([] :: [Int])"!
+  
+  
+-- b) 
+-- Implementieren Sie "mySafeHead" unter Verwendung
+-- von "myHead", indem Sie die Ausnahme abfangen und behandeln.
+--
+-- Hinweis: 
+-- Ausnahmen können nur innerhalb der IO-Monade gefangen werden.
+
+
+mySafeHead :: [a] -> IO (Maybe a)
+-- mySafeHead [] = return Nothing -- Gilt hier nicht als Lösung! Zu Übungszwecken bitte myHead mit catch/try einsetzen!
+mySafeHead = handle (\EmptyListException -> return Nothing) . (fmap Just) . evaluate . myHead
+    
+
+    
+    
+-- A8-2 Paralleles Rechnen mit Nebenläufigkeit
+--
+-- Auch wenn es eigentlich nicht der Sinn der Sache ist:
+-- Nebenläufigkeit kann ebenfalls dazu verwendet werden,
+-- die Ausführung eines Programmes durch Ausnutzung mehrerer
+-- Prozessorkerne zu beschleunigen.
+--
+-- Das folgende Programm führt vier unterschiedlich aufwändige 
+-- Berechnungen durch (Aufgabenstellung folgt weiter unten):
+
+main_A8_2 :: IO ()
+main_A8_2 = main' [ ("seq", main_A8_2_seq)
+                  , ("a", main_A8_2_a)
+                  , ("b", main_A8_2_b)
+                  ]
+
+type Task = Integer -> [String]
+
+main_A8_2_seq :: IO ()
+main_A8_2_seq = do 
+  putStrLn "Ein paar interessante Fakten:"
+  putStrLn " "
+  mapM_ putStrLn $ taskA nA
+  mapM_ putStrLn $ taskB nB
+  mapM_ putStrLn $ taskC nC
+  mapM_ putStrLn $ taskD nD
+  putStrLn " "
+  putStrLn "Höchst interessant, oder?"
+             
+    
+-- Hilfsfunktionen, zur Erzeugung von Rechnenlast,
+-- zur Lösung der Aufgabe sind diese unbedeutend.
+--
+-- HINWEIS:
+-- Die Werte sind zur Ausführung mit GHC -O2 auf aktueller Hardware gedacht
+-- Bei Ausführung in GHCI sind die Werte anzupassen (halbieren?).
+-- Idealerweise sollte jeder Task ca. 10 Sekunden Laufzeit benötigen.
+  
+nA = 14
+  
+taskA :: Task
+taskA n = ["* Ein Hanoi-Turm der Höhe " ++ (show n)
+          ,"  braucht genau " ++ (show steps) ++ " Schritte zum versetzen." ]
+  where
+    steps = length $ hanoi n 1 3
+
+hanoi :: (Num a, Eq a) => a -> a -> a -> [(a,a)]          
+hanoi 1 i j = [(i,j)]
+hanoi n i j = 
+       hanoi n' i otherTower
+    ++ [(i,j)] 
+    ++ hanoi n' otherTower j
+  where
+    n'         = n-1
+    otherTower = 1+2+3-i-j
+        
+nB = 30
+  
+taskB :: Task
+taskB n = ["* Die " ++ (show n) ++ ". Fibonacci-Zahl" 
+          ,"  lautet: " ++ (show fn) ]
+  where
+    fn = fib n
+
+fib :: (Ord a, Num a, Num b) => a -> b
+fib 0 = 0 -- absichtlich langsame Berechnung
+fib n | n <= 1    = 1
+      | otherwise = fib (n-1) + fib (n-2)
+    
+nC = 11728
+    
+taskC :: Task
+taskC n = ["* Die Fakultät von " ++ (show n)
+          ,"  ist eine Zahl mit " ++ (show l) ++ " Stellen." ]
+  where
+    fn = product [1..n]
+    l  = length $ show fn
+
+nD = 279
+    
+taskD :: Task
+taskD n = ["* Die Anzahl der Collatz-Schritte von " ++ (show n) ++ " bis 1 "
+          ,"  beträgt genau " ++ (show cn)] 
+  where
+    cn = numCSteps n
+    
+    
+collatzStep :: Integral a => a -> a
+collatzStep n 
+  | even n    = n `div` 2
+  | otherwise = 3*n+1    
+
+numCSteps :: Integral a => a -> a  
+numCSteps n = ncs 0 n
+  where -- Hinweis: Es ist unbekannt, ob es immer terminiert.
+    ncs steps 1 = steps
+    ncs steps m = ncs (succ steps) (collatzStep m)
+    
+  
+-- a) 
+-- Verändern Sie das gegebene Hauptprogramm so, dass 
+-- die vier Ergebnisse so schnell wie möglich ausgegeben werden.
+-- Das am schnellsten zu berechnende Ergebnis soll also zuerst ausgegeben werden,
+-- das am langsamsten zu berechnende Ergebnis am Ende.
+-- Die einzelnen Zeilen einer Aufgabe sollen auch zusammen ausgegeben werden!
+--
+-- Hinweis: 
+-- Sie sehen zwar keine Beschleunigung, wenn Sie nur einen Prozessorkern 
+-- zur Verfügung haben, aber Sie sehen trotzdem, dass 
+-- die leichteste Aufgabe (taskD) als erste ausgegeben wird,
+-- wenn Sie die Aufgabe richtig gelöst haben!
+
+main_A8_2_a :: IO ()
+main_A8_2_a = do
+  putStrLn "Ein paar interessante Fakten:"
+  putStrLn " "
+  runPar [ taskA nA
+         , taskB nB
+         , taskC nC
+         , taskD nD
+         ]
+  putStrLn " "
+  putStrLn "Höchst interessant, oder?"
+  where
+    runPar as = do
+      rChan <- newChan
+      mapM_ (forkIO . (writeChan rChan $!!)) as
+      replicateM_ (length as) (readChan rChan >>= mapM_ putStrLn)
+    
+  
+-- b)  
+-- Verändern Sie das Hauptprogramm so, dass die Berechnungen
+-- zwar parallel ausgeführt werden, aber das die gesamte Ausgabe
+-- in einem Schritt nach Ende der langsamsten Berechnung erfolgt,
+-- in der gleichen Reihenfolge des ursprünglichen Programmes.
+
+main_A8_2_b :: IO ()
+main_A8_2_b = do
+  putStrLn "Ein paar interessante Fakten:"
+  putStrLn " "
+  runPar [ taskA nA
+         , taskB nB
+         , taskC nC
+         , taskD nD
+         ]
+  putStrLn " "
+  putStrLn "Höchst interessant, oder?"
+  where
+    runPar as = do
+      rChan <- newChan
+      mapM_ (forkIO . (writeChan rChan $!!)) as'
+      rs <- replicateM (length as) (readChan rChan)
+      mapM_ putStrLn . join $ map snd $ sortBy (comparing fst) rs
+      where
+        as' = zip ([0..] :: [Integer]) as
+  
+  
+  
+-- A8-3 Dead Locks und Race-Conditions
+--
+-- Was passiert in folgendem Programm?
+-- Wieso kommt es zu einem Dead-Lock?
+-- Überlegen Sie sich Möglichkeiten, dies zu vermeiden!
+
+{-
+  Neither `md` nor `workerC` ever actually get used
+
+  It suffices to show that a scheduling exists for which
+  a deadlock occurs.
+
+  Consider: A.1, B.1, B'.1, A.2, B.2, B'.2
+
+
+  To prevent deadlocks with only minimal changes to semantics
+  consider using one `MVar (Integer, Integer, Integer)`.
+
+  However in the authors opinion considerable changes to the
+  semantics are preferable.
+-}
+
+main_A8_3 :: IO ()
+main_A8_3 = do
+  ma <- newMVar 0
+  mb <- newMVar 0
+  mc <- newMVar 0
+  md <- newMVar 0
+  forkIO $ forever $ workerA ma mb -- thread A
+  forkIO $ forever $ workerB mb mc -- thread B
+  forkIO $ forever $ workerB mc ma -- thread B'
+  replicateM_ 1000 $ do
+    a <- readMVar ma    
+    b <- readMVar mb     
+    c <- readMVar mc
+    d <- readMVar md
+    print (a,b,c,d)
+    threadDelay 4000
+
+workerA :: MVar Integer -> MVar Integer -> IO ()
+workerA mx my = do
+  x <- takeMVar mx -- A.1
+  y <- takeMVar my -- A.2
+  let x' = x+1    
+  let y' = y-1
+  putMVar my $! y'
+  putMVar mx $! x'
+
+workerB :: MVar Integer -> MVar Integer -> IO ()
+workerB mx my = do 
+  x <- takeMVar mx -- B.1 / B'.1
+  y <- takeMVar my -- B.2 / B'.2
+  putMVar mx $! collatzStep x
+  putMVar my $! collatzStep y
+
+workerC :: MVar Integer -> MVar Integer -> IO ()
+workerC mx my = do 
+  x <- takeMVar mx
+  let x' = if x < 42 then fib x else 0
+  putMVar mx $! x'
+  y <- takeMVar my
+  let y' = y + x'
+  putMVar my $! y'