TTT.hs

Dateiinhalt

{-
  LIVE coded during Lecture "Fortgeschrittene Funktionale Programmierung", 23.01.2015
  Steffen Jost, LFE TCS, LMU Munich, Bavaria

  ANMERKUNGEN:

  * Der Code ist hier unverändert wie in der Vorlesung erstellt.
  Teilweise ist der Code durch den Zeitdruck recht häßlich,
  z.B. viel zu kurze Bezeichner, teilweise irreführende Namen
    - Verwendung unsicherer Funktion wie fromJust
    - Es wäre sinnvoller am Ende von applyMove zu prüfen,
      ob der Computerspieler dran ist und diesen dann aufzurufen.        
    
-}


import Data.Maybe
import qualified Data.Map as Map
import Data.IORef
import Control.Applicative
import Control.Monad
import Control.Concurrent
import Graphics.UI.Gtk

import TTT_Model
import TTT_AI

gameSize         = 3
winSize          = 3
startPlayer      = X
computerPlayer   = O
computerStrength = 12


data App = App {  state   :: IORef State
               ,  status  :: Label
               ,  buttons :: Map.Map Pos Button
               }

main :: IO ()
main = do
  putStrLn "Tic Tac Toe starting."

  spielRef <- newIORef $ newGame gameSize winSize startPlayer
  spiel   <- readIORef spielRef

  initGUI
  window <- windowNew
  vbox   <- vBoxNew False 10
  label  <- labelNew (Just $ showStatus spiel)
  table  <- tableNew (size $ spiel) (size $ spiel) True

  set window [windowTitle := "Tic Tac Toe"
             ,windowDefaultWidth  := 270
             ,windowDefaultHeight := 270
             ,containerBorderWidth := 10
             ,containerChild := vbox ]
  boxPackStart vbox table PackGrow    10
  boxPackStart vbox label PackNatural 10

  let positions = [ Pos (x,y) | x<-[1..size spiel], y<-[1..size spiel] ]
  let createButton m p@(Pos (x,y)) = do
        b <- buttonNew
        set b [ buttonRelief := ReliefHalf ] 
        tableAttachDefaults table b (x-1) x (y-1) y
        return $ Map.insert p b m
  buttons <- foldM createButton Map.empty positions
  let app = App { state   = spielRef
                , status  = label
                , buttons = buttons
                }
  forM_ positions $ \p -> do
    let b = fromJust $ Map.lookup p buttons
    onClicked b $ buttonPress p app
  onDestroy window mainQuit
  widgetShowAll window
  
  timeoutAddFull (yield >> return True) priorityDefaultIdle 100 -- ADDED
  mainGUI

buttonPress :: Pos -> App -> IO ()
buttonPress p app = do
  applyMove app (startPlayer,p)
  -- triggerComputerMove app (in Vorlesung hier platziert, verschoben zu apply)


applyMove :: App -> Move -> IO ()
applyMove app mv@(player,pos) = do
  putStrLn $ "Attempt Move " ++ (show mv)
  spiel <- readIORef $ state app
  case makeMove spiel mv of
    Nothing -> do
      putStrLn $ "Illegal Move " ++ (show mv)
      when (isNothing $ turn spiel) $ resetGame app  -- ADDED to reset game at end      
    (Just spiel2) -> do
      writeIORef (state app) spiel2
      let b = fromJust $ Map.lookup pos $ buttons app
      set b [ buttonLabel := show $ player ]
      set (status app) [ labelLabel := showStatus spiel2 ]
      widgetShowAll $ status app
      when (turn spiel2 == Just computerPlayer) $ triggerComputerMove app

triggerComputerMove :: App -> IO ()
triggerComputerMove app = do
  -- | mainIterationDo False -- ADDED another possibility to update GUI once
  spiel <- readIORef $ state app  
  void $ forkIO $ -- ADDED
    case computerMove computerStrength spiel of
      Nothing   -> putStrLn "Computer has no moves."
      (Just mv) -> do putStrLn ("Computer:"++show mv)
                      postGUIAsync $ -- ADDED
                        applyMove app mv

resetGame :: App -> IO () -- ADDED
resetGame app = do 
  let freshGame = newGame gameSize winSize startPlayer
  writeIORef (state app) freshGame
  forM_ (Map.elems $ buttons app) (\b -> set b [ buttonLabel := " " ])
  set (status app) [ labelLabel := showStatus freshGame ]