path: root/ws2015/ffp/blaetter/07/FFP_U07_Monaden2.hs

{-# LANGUAGE RankNTypes #-} -- I like being allowed to specify type signatures

-- Fortgeschrittene Funktionale Programmierung, 
--   LMU, TCS, Wintersemester 2015/16
--   Steffen Jost, Alexander Isenko
--
-- Übungsblatt 07. 2.12.2015
--
-- Thema: Monaden (Teil2)
--
-- 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 Control.Applicative
import Control.Monad

import Control.Monad.ST
import Data.STRef

import Data.Maybe (fromMaybe)

import Debug.Trace (traceShowId)

---- A7-1 I/O und "Hello World!"

-- a)
-- Lassen Sie das Programm von Folie 4-77 laufen!
-- Erstellen Sie dazu eine separate Datei mit dem 
-- Haskell-Quelltext.
-- Verwenden Sie GHC und nicht GHCI!
-- 
-- HINWEIS:
--  GHC erstellt nur eine ausführbare Datei,
--  falls die Funktion main existiert.
--  Falls Ihr Modul oder Ihre Funktion anders heisst,
--  so sollten Sie bei der Kompilation die
--  Option "-main-is" verwenden, also z.B.
--  "ghc MyFile.hs -main-is MyModule.myfoo"


-- b)
-- Schreiben Sie ein ausführbares Programm,
-- welches den Benutzer zur Eingabe einer Textzeile auffordert.
-- Ihr Programm soll abwechselnd 
--   - die Textzeile rückwärts ausgeben
--   - die Textzeile ausgeben, wobei 
--        A/Ä durch E, p durch b und k durch g ersetzt werden
-- Das Programm beendet sich, falls der Benutzer 
-- nichts eingibt und nur return drückt.
--
-- Beispielausführung:
--     Hallo Benutzer!
--     Sag was, ich sag's Dir dann umgekehrt:
--     Was ist ein Palindrom?
--     ?mordnilaP nie tsi saW
--     Sag emol ebbes lustiges:
--     Äpfel und Birnen                  
--     Ebfel und Birnen
--     Sag was, ich sag's Dir dann umgekehrt:
--
--     Bye bye!
-- 

main :: IO ()
main = do
  putStrLn "Hallo Benutzer!"
  main' actions
  putStrLn "Bye bye!"
  where
    actions = cycle [ ("Sag was, ich sag's Dir dann umgekehrt:", reverse)
                    , ("Sag emal ebbes lustiges:", dialekt)
                    ]
    main' ((str, a):as) = do
      putStrLn str
      l <- getLine
      when (not $ null l) $ do
        putStrLn $ a l
        main' as

dialekt :: String -> String
dialekt = map dialekt'
  where
    dialekt' 'A' = 'E'
    dialekt' 'Ä' = 'E'
    dialekt' 'p' = 'b'
    dialekt' 'k' = 'g'
    dialekt' x = x
  
  
             
---- A7-2 Allgemeine Monadische Funktionen
--
-- Implementieren Sie folgende Funktionen aus 
-- der Standarbibliothek selbst zu Fuss.
-- Sie dürfen DO-Notation einsetzen, wenn Sie möchten.
--
-- Zur Vermeidung von Namenskonflikten 
-- wurde jedem Funktionsnamen das Kürzel "my" vorangestellt.


-- a) reguläres foldl mit monadischer Funktion
--
myFoldM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
myFoldM _ a [] = return a
myFoldM f a (b:bs) = do
  a' <- (a `f` b)
  myFoldM f a' bs


-- b) Replizieren eines monadischen Wertes
-- Beispiel:
--     > myReplicateM 3 (return 7)
--     [7,7,7]
-- 
--     > myReplicateM 4 (putStr "X ")
--     X X X X [(),(),(),()]
--
myReplicateM :: (Monad m) => Int -> m a -> m [a]
myReplicateM 0 _ = return []
myReplicateM n a = do
  a' <- a
  (a' :) `liftM` myReplicateM (n - 1) a


-- c) Hintereinanderausführung zweier monadischer Funktionen 
-- (<=<) :: Monad m => (b -> m c) -> (a -> m b) -> a -> m c
--
myR2Lcomposition :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c)
myR2Lcomposition f g a = g a >>= f


  
-- A7-3 Anwenden der Zustandsmonade
--
-- Gegeben ist die korrekte Berechnung einer Wahrscheinlichkeit für einen Kampf in einem Strategiespiel.
-- Die Berechnung ist uns zu langsam. Da dabei viele wiederholte Berechnungen auftreten,
-- möchten wir die gesamte Berechnung durch explizite Memoisation mit einer Zustandsmonade beschleunigen!
--
-- IHRE AUFGABE: 
--     Berechnung der gegebenen Funktion "winchance" dramatisch beschleunigen!
-- 
-- Das Ergebnis soll natürlich unverändert sein! Deklarieren Sie also zum Vergleich 
-- eine neue Funktion "memoWinchance" mit gleichem Typ.
-- 
-- Dabei haben Sie die Wahl:
--   - Kreieren Sie eine Zustandsmonade zu Fuss, wie in der letzten Vorlesung demonstriert; oder
--   - Verwenden Sie die Module Control.Monad.ST und Data.STRef
--     Für letztere Variante folgt am Ende dieser Datei ein Programmbeispiel zur Verwendung: demoST
--
-- Warum die gegebene Wahrscheinlichkeitsberechnung richtig ist, ist für unser Lernziel unwichtig.
-- Der Hintergrund "Strategiespiel" dient nur der Illustration, damit die Aufgabe nicht zu langweilig wird.
-- Es ist also nicht schlimm, wenn Sie die Details davon nicht verstehen.
-- 

-- 
-- BESCHREIBUNG UND MODELLIERUNG DES STRATEGIESPIELS
-- 
-- In einem Strategiespiel kämpfen verschiedene fantastische Monster gegeneinander.
-- Eine Monster besitzt zwei Werte: Kampfstärke und Trefferpunkte:
--

data Monster = Monster Int Int deriving (Show,Eq,Ord)
-- HINWEIS: Hier könnte man Record-Syntax gut einsetzen. Wir verzichten jedoch darauf,
--          da Record-Syntax noch nicht in der Vorlesung behandelt wurde.

strength  :: Monster -> Int
strength (Monster s _) = s

hitpoints :: Monster -> Int
hitpoints (Monster _ h) = h

takeHit :: Monster -> Monster
takeHit (Monster s h) = Monster s $ h-1

-- Einige Standard-Monster zum Testen:
crow  = Monster  5 1
human = Monster 10 2
orc   = Monster 20 1
dwarf = Monster 15 2
elf   = Monster 25 2
giant = Monster 20 4
knight= Monster 35 2

-- Ein Kampf zwischen zwei Parteien in diesem Spiel läuft wie folgt ab:
--
-- Die Monster eines Kampfe zwischen zwei gegnerischen Parteien sind
-- jeweils in einem Stapel geordnet: 
-- also eine Liste von Angreifern und eine Liste von Verteidigern.
-- Es kämpfen immer nur jeweils die beiden Monster an vorderster Front der beiden Stapel gegeneinander.
-- 
-- Beide Monster würfeln eine Zahl zwischen 0 und 99 und vergleichen diese mit Ihrer eigenen Stärke.
-- Ist die gewürfelte Zahl kleiner als die Stärke, so verliert das gegnerische Monster einen Trefferpunkt;
-- beide Würfelwürfe werden jedoch wiederholt, falls beide Monster Ihren Stärketest gleichzeitig bestehen oder beide durchfallen,
-- es verliert also immer nur genau eines der beiden obersten Monster einen Trefferpunkt.
-- 
-- Sobald ein Monster 0 Trefferpunkte hat, wird es aus dem Stapel entfernt.
-- Die verbleibenden Monster kämpfen, bis einer der beiden gegnerischen Stapel leer ist.
--
-- Um uns im Spiel einen Vorteil zu verschaffen, möchten wir die Gewinnwahrscheinlichkeit
-- für zwei gegebene Stacks von Monstern im Voraus ausrechnen.
-- Dies haben wir auch schnell in Haskell implementiert:
--
-- Die Funktion winchance berechnet uns die Gewinnwahrscheinlichkeit
-- für den ersten Stapel aus (d.h. mindestens ein Angreifermonster überlebt).

dice = 100

winchance :: [Monster] -> [Monster] -> Double
winchance [] _  = 0
winchance _  [] = 1
winchance allatt@(a:att) alldef@(d:def) 
  | hitpoints a <= 0 = winchance    att alldef -- remove dead attacker
  | hitpoints d <= 0 = winchance allatt    def -- remove dead defender
  | otherwise = 
      let attchance = nextHitchance dice (strength a) (strength d) -- chance for next hit by attacker on defender
          defchance = 1 - attchance                                -- chance for next hit by defender on attacker
          atthit = winchance         allatt (takeHit d:def) -- attacker's winchance if defender took a hit
          defhit = winchance (takeHit a:att)        alldef  -- attacker's winchance if attacker took a hut
      in (attchance * atthit) + (defchance * defhit) -- overall winchance for first stack
                
-- Die Funktion nextHitchance 100 x y rechnet uns die Chance aus,
-- das ein Monster mit Stärke x gegen ein Monster mit Stärke y den nächsten Treffer landet.
-- Möglicherweise auftretende Wiederholungen der Würfelwürfe haben wir
-- mit Hilfe der Mathematik über die Grenzwerte unendlicher Reihen bereits vereinfacht:
              
nextHitchance :: Int -> Int -> Int -> Double
nextHitchance die attstr defstr = a*d' / (d*a' + a*d')
  where    
    a  = (fromIntegral attstr)/(fromIntegral die)
    a' = if a > 1 then 0 else 1 - a
    d  = (fromIntegral defstr)/(fromIntegral die)
    d' = if d > 1 then 0 else 1 - d
    
{-    
Der Code funktioniert auch prinzipiell:

> nextHitchance 100 10 20
0.30769230769230776

> winchance [orc,dwarf,elf,giant] [human,human,human,knight,knight]
0.35168883031403275

> winchance [human,human,human,knight,knight] [orc,dwarf,elf,giant] 
0.6483111696859674

> winchance [orc,orc,orc,dwarf,dwarf,giant,giant] [human,human,human,elf,elf,knight,knight]
0.33760541326192256

jedoch zeigt das letzte Beispiel, dass die Berechnung sehr lange dauern kann!
    
Dabei wird jedoch oft das Gleiche frisch berechnet:
Zum Beispiel bei der Berechnung von "winchance [orc,elf] [human,dwarf]"
wird zwei mal "winchance [elf] [dwarf]" frisch ausgerechnet.
Einmal unter der Annahme, dass zuerst der orc stirbt, und 
dann nochmal unter der Annahme das zuerst der mensch besiegt wurde.

Es bietet sich daher an, die Werte von winchance in einer Tabelle abzulegen, 
z.B.    Map ([Monster],[Monster]) Double
Ein Aufruf von memoWinchance schaut zuerst in dieser Tabelle nach,
ob die Wahrscheinlichkeit für diesen kompletten (Rest-)Kampf bereits bekannt ist.
Falls ja, wird schnell der bekannte Wert zurückgegeben.
Falls nein, wird der Wert berechnet und anschliessend in die Tabelle eingetragen.
Beachten Sie, das bei der Berechnung eines Wertes die Tabelle bereits wachsen kann!

Hinweis: Da die Tabelle für verschieden Stacks schnell groß werden kann,
verzichten wir darauf, diese zwischen verschiedenen Aufrufen von winchance
im Speicher zu halten. Nur während der Rekursion in einer Hilfsfunktion 
von winchance führen wir die Tabelle immer mit.
-}

type MM = Map ([Monster], [Monster]) Double -- MM stands for MonsterManual
    
memoWinchance :: [Monster] -> [Monster] -> Double
memoWinchance atts defs = runST (newSTRef Map.empty >>= memoWinchance' atts defs)

memoWinchance' :: forall s. [Monster] -> [Monster] -> STRef s MM -> ST s Double
memoWinchance' [] _ _ = return 0 -- We do this here so we don't clutter our manual with entries for empty lists
memoWinchance' _ [] _ = return 1
memoWinchance' atts defs mmRef = recall >>= fromMaybeM (winchance >>= memoize)
  where
    recall = Map.lookup (atts, defs) <$> readSTRef mmRef
    memoize x = modifySTRef mmRef (Map.insert (atts, defs) x) >> return x
    winchance = winchance' atts defs mmRef
    fromMaybeM x Nothing = x
    fromMaybeM _ (Just x) = return x

winchance' :: forall s. [Monster] -> [Monster] -> STRef s MM -> ST s Double
winchance' allatts@(a:atts) alldefs@(d:defs) mmRef 
  | hitpoints a <= 0 = memoWinchance' atts alldefs mmRef
  | hitpoints d <= 0 = memoWinchance' allatts defs mmRef
  | otherwise = do
      let attchance = nextHitchance dice (strength a) (strength d)
          defchance = 1 - attchance
      atthit <- memoWinchance'           allatts (takeHit d:defs) mmRef
      defhit <- memoWinchance' (takeHit a:atts)          alldefs  mmRef
      return $ (attchance * atthit) + (defchance * defhit)
               
--
-- Simples Beispiel zur Verwendung der ST-Monade:
-- 
demoST :: (Integer, [Char])
demoST = runST $ do
    somerefA <- newSTRef 0
    somerefB <- newSTRef "A"
    increment somerefA
    increment somerefA  
    modifySTRef somerefB $ \s -> s ++ "B"
    increment somerefA
    a <- readSTRef somerefA
    b <- readSTRef somerefB
    increment somerefA
    increment somerefA
    return (a,b)  
  where 
    increment ref = do
      x <- readSTRef ref
      let y = succ x
      writeSTRef ref y