TTT_Model.hs

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))