TTT_Model.hs
Tic Tac Toe Game Model
TTT_Model.hs
—
Haskell source code,
6 KB (7037 bytes)
Dateiinhalt
{-# LANGUAGE NamedFieldPuns #-} {- Tic Tac Toe Game Model -} module TTT_Model where import Data.Maybe import qualified Data.Map as Map import Data.List import Data.Tree import Control.Monad data Player = X | O deriving (Eq, Ord, Show) nextPlayer :: Player -> Player nextPlayer X = O nextPlayer O = X -- newtype to avoid accidental confusion with (Int, Int) -- Postions start a (1,1) newtype Pos = Pos (Int,Int) deriving (Eq, Ord, Show) -- Modelling the Board type Board a = Map.Map Pos a emptyBoard :: Board (Maybe Player) emptyBoard = Map.empty getPos :: Board (Maybe Player) -> Pos -> Maybe Player getPos b p = join $ Map.lookup p b setPos :: Board (Maybe Player) -> Move -> Board (Maybe Player) setPos b (pl,ps) = Map.insert ps (Just pl) b mbSetPos :: Board (Maybe Player) -> Move -> Maybe (Board (Maybe Player)) mbSetPos b (pl,ps) = maybeInsert ps (Just pl) b getPosS :: State -> Pos -> Maybe Player getPosS st = getPos $ board st -- No need for newtype, since Player and Pos are specific types already type Move = (Player, Pos) ------------- -- The actual game state data State = State { turn :: Maybe Player -- whose turn? , winner :: Maybe Player -- winner or draw? , board :: Board (Maybe Player) -- Game Board , lastMove :: Move , lastMScore :: Double , size :: Int , winsize :: Int -- |, futures :: [State] } ------------- -- Debugging Functions: showStatus :: State -> String showStatus st | (Just p) <- turn st = "Spieler am Zug: " ++ show p | (Just p) <- winner st = "Gewinner: " ++ show p | otherwise = "Unentschieden" instance Show State where show st = let b = board st sb = [[ head $ maybe " " show $ getPos b $ Pos(x,y) | x <- [1..size st] ] | y <- [1..size st]] in '\n':(intercalate "\n" sb) ++ '\n':showStatus st printState :: State -> IO () -- for Debugging printState st = do let b = board st forM_ [1..size st] $ \y -> do forM_ [1..size st] $ \x -> do putStr $ maybe " " show $ getPos b $ Pos (x,y) putStrLn "" putStrLn $ showStatus st ------------- -- Actual functions to export, apart from AI newGame :: Int -> Int -> Player -> State newGame size winsize startPlayer = State { turn = Just startPlayer , winner = Nothing , board = emptyBoard , lastMove = (nextPlayer startPlayer, Pos (0,0)) -- invalid last move , lastMScore = 0 , size = size , winsize = winsize } makeMove :: State -> Move -> Maybe State makeMove st mv@(pl,pos) | turn st == Just pl -- correct player's turn , inRange st pos -- pos is on the board , (Just newBoard) <- mbSetPos (board st) mv -- pos is free on the board = Just $ updateState $ st { board = newBoard, lastMove = mv } | otherwise = Nothing makeMoveMonadStyle :: State -> Move -> Maybe State -- equivalent to makeMove makeMoveMonadStyle st mv@(pl,pos) = do act_pl <- turn st unless (pl == act_pl) $ fail $ "Not the turn of player " ++ show pl unless (inRange st pos) $ fail $ "Illegal Position " ++ show pos newBoard <- mbSetPos (board st) mv return $ updateState $ st { board = newBoard, lastMove = mv } ------------- -- Helpers inRange :: State -> Pos -> Bool inRange st (Pos (x,y)) = x > 0 && y > 0 && x <= size st && y <= size st updateState :: State -> State -- check victory conditions for lastMove updateState st@(State {lastMove, board, winsize}) | winsize <= floor lastMScore = st { turn = Nothing, winner = Just pl, lastMScore } | null $ possibleMoves st = st { turn = Nothing, winner = Nothing, lastMScore } | otherwise = st { turn = Just $ nextPlayer pl, lastMScore } where (pl,ps) = lastMove lastMScore = moveScore winsize board lastMove moveScore :: Int -> Board (Maybe Player) -> Move -> Double moveScore win board (pl,ps@(Pos(mx,my))) = boundedMaximum (fromIntegral win) [(walk goWest 1 ps) + (walk goEast 0 ps) ,(walk goNorth 1 ps) + (walk goSouth 0 ps) ,(walk goNorthEast 1 ps) + (walk goSouthWest 0 ps) ,(walk goNorthWest 1 ps) + (walk goSouthEast 0 ps) ] where walk dir n ps | (Just oc) <- getPos board ps' = if oc == pl then walk dir (n+1) ps' else n + 0.3 | otherwise = n where ps' = dir ps goWest,goEast,goSouth,goNorth :: Pos -> Pos goWest (Pos (x,y)) = Pos(x+1,y) goEast (Pos (x,y)) = Pos(x-1,y) goSouth (Pos (x,y)) = Pos(x,y+1) goNorth (Pos (x,y)) = Pos(x,y-1) goNorthWest (Pos (x,y)) = Pos(x+1,y-1) goNorthEast (Pos (x,y)) = Pos(x-1,y-1) goSouthEast (Pos (x,y)) = Pos(x-1,y+1) goSouthWest (Pos (x,y)) = Pos(x+1,y+1) possibleMoves :: State -> [Pos] possibleMoves (State {size, board}) = [ ps | x <- [1..size], y <- [1..size] , let ps = Pos (x,y) , isNothing $ getPos board ps ] allmoves :: State -> [State] allmoves st | (Just pl) <- turn st = let mvs = allmoves_mem !! size st -- with memoizing -- mvs = possibleMoves st -- uses Map.lookup sts = map (\p -> makeMove st (pl,p)) mvs in catMaybes sts | otherwise = [] allmoves_mem = []:[]:[[ Pos (x,y) | x<- [1..n], y <- [1..n]] | n <- [2..]] -- |allrows st = [[Pos (x,y)| x <-[1..size st]]| y <-[1..size st]] -- |allcols st = [[Pos (x,y)| y <-[1..size st]]| x <-[1..size st]] -- |alldiag st = [ [Pos (x,x)| x <-[1..size st]] -- |,[Pos (x,(size st)-x+1)| x <-[1..size st]]] -- |row st (Pos (_,n)) = [Pos (x,n)| x <-[1..size st]] -- |column st (Pos (n,_)) = [Pos (n,y)| y <-[1..size st]] -- |diags st pos = filter (elem pos) $ alldiag st ------------- -- Generic Utility Functions maybeInsert :: Ord k => k -> a -> Map.Map k a -> Maybe (Map.Map k a) maybeInsert ky vl mp | (Nothing, new) <- Map.insertLookupWithKey (\_ _ old -> old) ky vl mp = Just new | otherwise = Nothing boundedMaximum :: (Ord b) => b -> [b] -> b boundedMaximum ub [] = error "boundedMaximum called on empty list" boundedMaximum ub (h:t) = cMaux h t where cMaux mx [] = mx cMaux mx (h:t) | ub <= h = h | mx < h = cMaux h t | otherwise = cMaux mx t boundedMinimum :: (Ord b) => b -> [b] -> b boundedMinimum lb [] = error "boundedMinimum called on empty list" boundedMinimum lb (h:t) = cMaux h t where cMaux mi [] = mi cMaux mi (h:t) | lb >= h = h | mi > h = cMaux h t | otherwise = cMaux mi t --------- -- TESTS g1 = fromJust $ makeMove (newGame 3 2 X) (X,Pos(1,1)) g2 = fromJust $ makeMove g1 (O,Pos(1,3)) g3 = fromJust $ makeMove g2 (X,Pos(3,3)) g4 = fromJust $ makeMove g3 (O,Pos(2,3)) h3 = fromJust $ makeMove g2 (X,Pos(2,1))
Artikelaktionen