path: root/ws2015/ffp/blaetter/09/FFP_U09_Concurrent.hs

-- 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'