TTT.hs
Zum Vergleich:
TicTacToe GUI und Hauptprogramm, live implementiert im WS14/15.
OHNE rekursives DO, dafür mit 2. Schleifendurchlauf.
TTT.hs
—
Haskell source code,
3 KB (3831 bytes)
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 ]
Artikelaktionen