module Main where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
import System


-- Kontenbewegungen
type Account = TVar Int

-- Abbuchen
simpleWithdraw :: Account -> Int -> STM ()
simpleWithdraw acc amount
  = do bal <- readTVar acc
       writeTVar acc (bal - amount) 
       
-- Gutschreiben
simpleDeposit :: Account -> Int -> STM ()
simpleDeposit acc amount 
  = simpleWithdraw acc (-amount) 
  
-- einfacher Transfer
simpleTransfer :: Account -> Account -> Int -> STM ()
simpleTransfer from to m 
  = do simpleWithdraw from m
       simpleDeposit to m
       
test0 :: IO ()
test0 = atomically 
        (do konto1 <- newTVar 50
            konto2 <- newTVar 100
            simpleTransfer konto2 konto1 75 
            val1 <- readTVar konto1
            val2 <- readTVar konto2
            return (val1, val2))
        >>= \(v1,v2) -> putStrLn ("Kontostand1: " ++ (show v1) ++ 
                                  "; Kontostand2: " ++ (show v2))

main0 :: IO ()
main0 = do (k1,k2) <- (atomically $ do konto1 <- newTVar 50
                                       konto2 <- newTVar 100
                                       return (konto1,konto2))
           forkIO (atomically $ simpleTransfer k1 k2 75)
           (v1,v2) <- atomically $ (do val1 <- readTVar k1
                                       val2 <- readTVar k2
                                       return (val1, val2))
           putStrLn ("Kontostand1: " ++ (show v1) ++ 
                     "; Kontostand2: " ++ (show v2))
           forkIO (atomically $ simpleTransfer k2 k1 70)
           (v1,v2) <- atomically $ (do val1 <- readTVar k1
                                       val2 <- readTVar k2
                                       return (val1, val2))
           putStrLn ("Kontostand1: " ++ (show v1) ++ 
                     "; Kontostand2: " ++ (show v2))
                                  
           
          
-- Problem: Es wird nicht ueberprueft, ob genuegend Geld 
--          auf dem Konto vorhanden ist

-- bessere Versionen
-- Abbuchen
withdraw :: Account -> Int -> STM ()
withdraw acc amount
  = do bal <- readTVar acc
       if amount > 0 && amount > bal 
        then retry  -- blockiere, bis Kontostand sich aendert
        else writeTVar acc (bal - amount) 
       
-- Gutschreiben
deposit :: Account -> Int -> STM ()
deposit acc amount 
  = withdraw acc (-amount) 
 
-- Transfer
transfer :: Account -> Account -> Int -> STM ()
transfer from to m 
  = do withdraw from m
       deposit to m

test1 :: IO ()
test1 = atomically 
        (do konto1 <- newTVar 50
            konto2 <- newTVar 100
            transfer konto1 konto2 75 
               `orElse` transfer konto2 konto1 75
            val1 <- readTVar konto1
            val2 <- readTVar konto2
            return (val1, val2))
        >>= \(v1,v2) -> putStrLn ("Kontostand1: " ++ (show v1) ++ 
                                  "; Kontostand2: " ++ (show v2))

main1 :: IO ()
main1 = do (k1,k2) <- (atomically $ do konto1 <- newTVar 50
                                       konto2 <- newTVar 100
                                       return (konto1,konto2))
           forkIO (atomically $ transfer k1 k2 75)
           (v1,v2) <- atomically $ (do val1 <- readTVar k1
                                       val2 <- readTVar k2
                                       return (val1, val2))
           putStrLn ("Kontostand1: " ++ (show v1) ++ 
                     "; Kontostand2: " ++ (show v2))
           forkIO (atomically $ transfer k2 k1 70)
           (v1,v2) <- atomically $ (do val1 <- readTVar k1
                                       val2 <- readTVar k2
                                       return (val1, val2))
           putStrLn ("Kontostand1: " ++ (show v1) ++ 
                     "; Kontostand2: " ++ (show v2))

--              
-- Verkaufsaktion
--
{- 
Gegeben Liste von Objekten mit Preisliste sowie 
Personen (Käufer und Verkäufer) mit Konto und Inventar.

Verkaufe erstes Objekt aus Liste, das der Verkäufer besitzt 
und das vom Käufer bezahlt werden kann.
-}

data Item = Tisch | Stuhl | Bett | Gitarre | Kissen
            deriving (Eq,Show)

data Person = Person {account   :: Account, 
                      inventory :: TVar [Item]} 

preisliste :: [(Item,Int)]
preisliste = [(Bett,200), (Tisch, 150), (Gitarre, 100), (Stuhl, 75), (Kissen, 25)
             ]

sellfromList :: [(Item,Int)] -> Person -> Person -> STM (Maybe (Item,Int))
sellfromList list buyer seller
  = do go list
  where go [] = return Nothing
        go (this@(item,price):rest)
          = do sellItem item price buyer seller
               return (Just this)
            `orElse` go rest

sellItem :: Item -> Int -> Person -> Person -> STM ()
sellItem item price buyer seller
  = do giveItem item (inventory seller) (inventory buyer)
       transfer (account buyer) (account seller) price
       
giveItem :: Item -> TVar [Item] -> TVar [Item] -> STM ()
giveItem item from to
  = do fromList <- readTVar from
       case removeItem item fromList of
         Nothing -> retry
         Just newList -> 
           do writeTVar from newList
              readTVar to >>= (writeTVar to . (item :))

removeItem :: Eq a => a -> [a] -> Maybe [a]
removeItem x xs 
  = case span (/= x) xs of
      (zs,(_:ys)) -> Just (zs++ys)
      _           -> Nothing 

newPerson :: Int -> [Item] -> STM Person
newPerson balance inventory =
    Person `liftM` newTVar balance
              `ap` newTVar inventory

test2 = 
  atomically (do
    alice <- newPerson 200 [Gitarre,Bett,Stuhl]
    bob   <- newPerson 150 [Tisch,Stuhl,Kissen]
    sellfromList preisliste bob alice)
  >>= \result -> do putStrLn (show result)
  
  
newSellfromList :: [(Item,Int)] -> Person -> Person -> STM (Maybe (Item,Int))
newSellfromList list buyer seller
  = maybeM . msum $ map sellOne list
    where sellOne this@(item,price) = do
            sellItem item price buyer seller
            return this

maybeM :: MonadPlus m => m a -> m (Maybe a)
maybeM m 
  = liftM Just m `mplus` return Nothing
  
test3 = 
  atomically (do
    alice <- newPerson 200 [Gitarre,Bett,Stuhl]
    bob   <- newPerson 150 [Tisch,Stuhl,Kissen]
    newSellfromList preisliste bob alice)
  >>= \result -> do putStrLn (show result)