StrategicGames
In dieser Aufgabe beschäftigen wir uns .
> {-# LANGUAGE MultiParamTypeClasses #-}
>
> module StrategicGames where
> import Data.List(maximumBy,transpose)
> import Data.List.Lens
> import Control.Lens.Combinators
> import Control.Lens.Operators
> import Control.Parallel.Strategies
> import Data.List.Extra
> import Control.Exception
> import Control.Monad
> data Player = One |Two | None deriving (Eq)
> nextPlayer One = Two
> nextPlayer Two = One
> instance Show Player where
> show One = "X"
> show Two = "0"
> show _ = " "
> class Show m => Game g m where
> start :: (g m)
> currentPlayer :: (g m) -> Player
> moves :: (g m) -> [m]
> makeMove :: g m -> m -> g m
> hasWinner :: g m -> Bool
> gameOver :: g m -> Bool
> gameOver g = null (moves g)||hasWinner g
> score :: g m -> Int
> score g
> |hasWinner g = -(winscore g)
> |otherwise = 0
> winscore :: g m -> Int
> winscore _ = 1000000
> searchDepth :: g m -> Int
> searchDepth g = 10
> ai :: g m -> AI (g m)
> ai _ = alphaBeta
> evalMoves :: g m -> [(m,Int)]
> evalMoves g = parMap
> (evalTuple2 r0 rdeepseq)
> (\m-> (m, (ai g) (searchDepth g) (makeMove g m)))
> (moves g)
> bestMove :: g m -> m
> bestMove g
> = fst
> $maximumBy (\(_,v1) (_,v2) ->if v1<v2 then LT else GT)
> $evalMoves g
> type AI a = Int -> a -> Int
> data Tree a = Node a [Tree a] deriving Show
> createGameTree g =
> Node g [createGameTree (makeMove g m) |m <- moves g]
> minimax depth g = -(minimax' depth $ createGameTree g)
> where
> minimax' _ (Node g []) = score g
> minimax' 0 (Node g _) = score g
> minimax' d (Node _ cs)
> = maximum $ map (negate . (minimax' d)) $ cs
> alphaBeta depth g
> = -alphaBeta' depth (-ws) (ws) (createGameTree g)
> where
> ws = winscore g
>
> alphaBeta' 0 _ _ (Node g _) = score g
> alphaBeta' _ _ _ (Node g []) = score g
> alphaBeta' d alpha beta (Node _ cs) = falte (alpha,beta) crs
> where
> crs = map (\c-> -(alphaBeta' (d-1)(-beta)(-alpha) c)) cs
>
> falte ab@(alpha,beta) (wert:werte)
> |wert >= beta = beta
> |wert > alpha = falte (wert,beta) werte
> |otherwise = falte ab werte
> falte (alpha,_) [] = alpha
> playUserMove a =
> catch
> (do
> print a
> putStrLn "Geben Sie jetzt Ihren Zug ein!"
> putStrLn "Mögliche Züge:"
> sequence $ map (putStrLn.show)$moves a
> line <- getLine
> let a1 = makeMove a $read line
> print a1
> return a1
> )
> (\e-> do
> print (e :: SomeException)
> playUserMove a
> )
> playAIMove a = do
> putStrLn "Nun überlege ich meinen Zug.."
> return$ makeMove a$ bestMove a
> playGame a
> |gameOver a = putStrLn "Das war ein Remis."
> playGame a = do
> a1 <- playUserMove a
> if (hasWinner a1) then putStrLn "Gratulation! Sie haben gewonnen."
> else if not$gameOver a1
> then do
> a2 <- playAIMove a1
> if (hasWinner a2)
> then do
> print a2
> putStrLn "Dieses Spiel hat der Rechner gewonnen."
> else playGame a2
> else playGame a1
> data TicTacToe a = TTT Player [Player]
> instance Show (TicTacToe m) where
> show (TTT npl board) = ""
> newtype P = P(Int, Int) deriving (Show,Read,Eq)
> instance Game TicTacToe P where
> start = TTT One [] --ToDo
> currentPlayer ttt = None --todo
> moves ttt = [] --ToDo
> makeMove ttt m = ttt --ToDo
> hasWinner ttt = False
> playTicTacToe = playGame (start :: TicTacToe P)
> data Muehle m = Brett
> { brett::[[Player]]
> , zuSetzen1::Int
> , zuSetzen2::Int
> , current::Player
> , aufFeld1::Int
> , aufFeld2::Int
> , nextMoves::[MuehleZug]
> }
> data MuehleZug = Setze (Int,Int) (Maybe (Int,Int))
> |Schiebe (Int,Int)(Int,Int) (Maybe (Int,Int))
> deriving (Show,Eq,Read)
> instance Show (Muehle m) where
> show (Brett{brett=brett, zuSetzen1=spieler1, zuSetzen2=spieler2}) =
> replaceall replacements template
> ++ take spieler1 (repeat 'X') ++ "\n"
> ++ take spieler2 (repeat 'O') ++ "\n"
> where
> template
> ="v----------a----------d\n"++
> "| | |\n"++
> "| w------b------e |\n"++
> "| | | | |\n"++
> "| | x--c--f | |\n"++
> "| | | | | |\n"++
> "s---t---u i---h---g\n"++
> "| | | | | |\n"++
> "| | r--o--l | |\n"++
> "| | | | |\n"++
> "| q------n------k |\n"++
> "| | |\n"++
> "p----------m----------j\n"
>
> replacements = map (\(c,pl)-> replace [c] (show pl))
> $zip ['a'..] (concat brett)
> replaceall rplfs str = foldl (\b f -> f b) str rplfs
> setxy (x,y) brett pl = brett & element x .~ (brett!!x & element y .~pl)
> mkIndex brett = map (\(x,rs)-> map (\(y,p)->((x,y),p))$zip [0,1..] rs)
> $zip [0,1..] brett
> getNeighbours (x,y) br
> |mod x 2==0 && y==1
> = [br !!mod (x+1)8!!y,br !!mod (x-1) 8!!y,br !!x!!0,br !!x!!2]
> |mod x 2==0
> = [br !!mod (x+1)8!!y,br !!mod (x-1) 8!!y,br !!x!!1]
> |otherwise
> = [br !!mod (x+1)8!!y,br !!mod (x-1) 8!!y]
> inMuehle (x,y) br
> |p==None = False
> |mod x 2==0
> = all ((==)r) rs
> || br!!(mod (x-1) 8)!!y==p && br!!(mod (x+1) 8)!!y==p
> |otherwise
> = br!!(mod (x+1) 8)!!y==p && br!!(mod (x+2) 8)!!y==p
> ||br!!(mod (x-1) 8)!!y==p && br!!(mod (x-2) 8)!!y==p
> where
> xs@(r:rs) = br!!x
> p = xs!!y
> nLets n [] = []
> nLets n xs = take n xs:nLets n (drop (n-1) xs)
> everySnd [] = []
> everySnd [x] = [x]
> everySnd (x:_:xs) = x:everySnd xs
> muehlen br = (everySnd br)
> ++ (concat$map ((nLets 3).(\xs->last xs:xs)) (transpose br))
> calcMoves b = b{nextMoves=muehleMoves b}
> instance Game Muehle MuehleZug where
> start =
> calcMoves$Brett (take 8$repeat [None,None,None]) 9 9 One 0 0 []
> currentPlayer = current
> moves g = nextMoves g
> makeMove g@(Brett{brett=br,zuSetzen1=p1,zuSetzen2=p2,current=cpl})
> (Setze (x,y) rm)
> = calcMoves$
> if cpl==One
> then Brett nb (p1-1) p2 np
> (1+aufFeld1 g) (maybe (aufFeld2 g)(\_->(aufFeld2 g)-1) rm) []
> else Brett nb p1 (p2-1) np
> (maybe (aufFeld1 g)(\_->(aufFeld1 g)-1) rm) (1+aufFeld2 g) []
> where
> gesetzt = setxy (x,y) br cpl
> nb = maybe gesetzt (\xy -> (setxy xy gesetzt None)) rm
> np = nextPlayer cpl
> makeMove g@(Brett{brett=br,zuSetzen1=p1,zuSetzen2=p2,current=cpl})
> (Schiebe (x,y) (u,v) rm)
> = calcMoves
> $Brett nb 0 0 (nextPlayer cpl)
> (if cpl==One
> then (aufFeld1 g)
> else (maybe (aufFeld1 g) (\_->(aufFeld1 g)-1)rm ) )
> (if cpl==Two
> then (aufFeld2 g)
> else (maybe (aufFeld2 g) (\_->(aufFeld2 g)-1)rm ) )
> []
> where
> gesetzt = setxy (u,v) (setxy (x,y) br None) cpl
> nb = maybe gesetzt (\xy -> (setxy xy gesetzt None)) rm
> hasWinner g = null$moves g
> score g@(Brett{brett=br,current=cu})
> |hasWinner g = -(winscore g)
> |otherwise = 1000*currents-1000*others
> + calcPairs cu - calcPairs (nextPlayer cu)
> where
> brc = concat br
> mue = muehlen br
> others = length$filter (== (nextPlayer cu)) brc
> currents = length$filter (== cu) brc
> pair p xs = (length$filter (==p) xs)==2
> && (length$filter (==None) xs)==1
> calcPairs p = 10*(length$filter (pair p) mue)
> searchDepth Brett{zuSetzen1=0,zuSetzen2=0,aufFeld1=a1,aufFeld2=a2}
> |a1<=4 && a2<=4 = 4
> |a1<=4 || a2<=4 = 4
> searchDepth Brett{zuSetzen1=p1,zuSetzen2=p2}
> |p1+p2 < 6 = 6
> |p1+p2 < 4 = 8
> |p1+p2 < 2 = 10
> searchDepth _ = 4
> muehleMoves g@(Brett{brett=br,zuSetzen1=p1,zuSetzen2=p2,current=cpl})
> |p1==0&&3 > aufFeld1 g || p2==0&&3 > aufFeld2 g = []
> |p1+p2>0 = setzen
> |3==if cpl == One then aufFeld1 g else aufFeld2 g = springen
> |otherwise = schieben
> where
> indexed = mkIndex br
> coindexed = concat indexed
> myIndex = map (\(from,(to,_)) -> (from,to))
> $filter (\(_,(_,pl))-> pl==None)
> $concat
> $map (\(pos,_)->(map (\x->(pos,x))$ getNeighbours pos indexed))
> $filter (\(pos,p)->p==cpl)
> $coindexed
> schieben = concat$map (mkRvs.mkSchiebe) myIndex
> mkSchiebe (from,to) = Schiebe from to Nothing
> mkRvs s
> |inMuehle to newBrett = [setRm (Just rm) s|(rm,_)<-removeables]
> |otherwise = [s]
> where
> to = getTo s
>
> Brett{brett=newBrett,current=newCurrent} = makeMove g s
> newIndexed = concat$mkIndex newBrett
> removeables
> = filter(\(pos,p)-> p==newCurrent
> &¬ (inMuehle pos newBrett)) newIndexed
> getTo (Schiebe _ to _) = to
> getTo (Setze to _) = to
> setRm rm (Schiebe from to _) = Schiebe from to rm
> setRm rm (Setze to _) = Setze to rm
> springen = concat$map (mkRvs.mkSchiebe) mySprungIndex
>
> mySprungIndex = map (\(from,(to,_)) -> (from,to))
> $concat
> $map
> (\(pos,_)->
> (map (\x->(pos,x))$filter (\(_,pl)->pl==None)coindexed))
> $filter (\(pos,p)->p==cpl)
> $coindexed
> setzen = concat$map (mkRvs.(\pos->Setze pos Nothing))
> $map fst$filter (\(_,p)->p==None)$concat$indexed
>
lhs
You are not logged in and therefore you cannot submit a solution.
Subato
