board-games-0.2: src/Game/VierGewinnt.hs
module Game.VierGewinnt (
Spieler(..),
Spielstand,
Zug,
anfangundzuege,
berechneSpielstand,
brettVon,
grundstellung,
istMatt,
moeglicheZuege,
wertung,
) where
{- <plaintext>
http://sim.mathematik.uni-halle.de/~helmut/Fun/Game.VierGewinnt/vierg.hs
VIER-GEWINNT IN HASKELL
Idee und Programmierung: Joerg Wensch und Helmut Podhaisky
{wensch,podhaisky}@mathematik.uni-halle.de
Version vom Mai 2002
Kopierrechte nach GPL
(GNU GENERAL PUBLIC LICENSE, siehe http://www.gnu.org/)
-}
import qualified Data.List.Key as Key
import Data.Array (Array, Ix, array, range, inRange, listArray, (!), (//), )
import Data.Maybe (isNothing, catMaybes, )
{-
Es gibt die Dateneinheit Spielstand. Zu ihr gehoert immer eine
Sofortwertung. Neue Zuege koennen nur mit doTheMove aus einem alten
Spielstand abgeleitet werden. So sind inkrementelle Bewertungsfunktionen
leicht implementierbar. Die Positionsbewertung erfolgt mit einem
(vorzeichenbehafteten) Integerwert. Alle Sonderfaelle lassen sich in
diesen Integerwert hineinpressen. Z.B. so:
+ posinfty >= matt in 7 => matt in 3 >= 500 Materialpunkte >= 10
Materialpunkte >= patt in 10 >= patt in 1 >= sofortpatt >= - 10
materialpunkte >= matt in 7 >= -neginfty
Besonderheiten fuer Vier-Gewinnt:
Es gibt 69 Vierer. Wir werten nur diese, unabhaengig von der konkreten
Lage mit 0 1 5 oder 50 Punkten fuer 0,1,2 oder 3 Steine (und Luft
sonst).
Das muss ein Fehler sein:
In folgender Spielsituation tut der Computer was ganz dummes,
er verhindert nicht den Vierer.
putStr (game (Computer, [1,4,4,4,6,3,3,7,3,4,5,6,3,3,1,6,2,2,2,4,5,2]))
-}
type Brett = Array (Int,Int) (Maybe Spieler)
type Fuellstand = Array Int Int
type Wertung = Int
type Zug = Int
data Spieler =
Computer
| Mensch
deriving (Show,Read,Eq,Ord,Ix)
{-
instance Ix a => Ix Maybe a where
a general Ix instance for Maybe cannot be defined,
because if the lower index bound is Nothing
then we do not know the next larger index of the form (Just i).
This is a problem e.g. for Maybe Int
-}
data Spielstand =
S {brettVon :: Brett,
fuellstandVon :: Fuellstand,
amZug :: Spieler,
wertung :: Wertung,
anfangundzuege :: (Spieler, [Zug])}
brettGroesse :: ((Int,Int),(Int,Int))
brettGroesse = ((1,1),(7,6))
posinfty, neginfty :: Wertung
posinfty = 10000
neginfty = -10000
gegner :: Spieler -> Spieler
gegner Mensch = Computer
gegner Computer = Mensch
moeglicheZuege :: Spielstand -> [Int]
moeglicheZuege spielstand =
let brett = brettVon spielstand
in filter (\i -> isNothing (brett!(i,6))) [1..7]
computerAmZug :: Spielstand -> Bool
computerAmZug spielstand =
amZug spielstand == Computer
istMatt, istPatt :: Spielstand -> Bool
istMatt spielstand = abs (wertung spielstand) >= 5000
istPatt spielstand = null (moeglicheZuege spielstand)
doTheMove :: Spielstand->Zug->Spielstand
doTheMove spielstand zug =
S neuesBrett neuerFuellstand derGegner neueWertung (anfang,zuege)
where
altesBrett,neuesBrett :: Brett
altesBrett = brettVon spielstand
alterFuellstand = fuellstandVon spielstand
drann = amZug spielstand
derGegner = gegner drann
alteWertung = wertung spielstand
neueWertung = updateWertung alteWertung altesBrett neuesBrett (zug,j)
neuesBrett=altesBrett // (((zug,j),Just drann):[])
neuerFuellstand=alterFuellstand // ((zug,j):[])
j=alterFuellstand!zug + 1
(anfang,altezuege)= anfangundzuege spielstand
zuege=altezuege++(zug:[])
_fmtWertung :: Wertung -> String
_fmtWertung w =
if -5000 < w && w < 5000
then show w
else " Matt in " ++ show (6000 - abs w)
updateWertung :: Int -> Brett-> Brett -> (Int,Int) -> Wertung
updateWertung alteWertung altesBrett neuesBrett (i,j)
= neueWertung
where
aktiv = aktiveVierer!(i,j)
alt = sum (map (werte . map (altesBrett!)) aktiv)
neu = sum (map (werte . map (neuesBrett!)) aktiv)
neueWertung :: Wertung
neueWertung =
if abs neu >= 5000
then maxmin neu
else maxmin (alteWertung + neu - alt)
maxmin x = max (min x 6000) (-6000)
w :: Int -> Int
w x = [0,1,5,50,posinfty] !! x
werte xs =
let xsm = catMaybes xs
{- effizienter?
steine = accumArray (+) 0 (Computer, Mensch)
(map (\x->(x,1)) xsm)
computerSteine = steine ! Computer
menschSteine = steine ! Mensch
-}
computerSteine = length (filter (Computer ==) xsm)
menschSteine = length (filter (Mensch ==) xsm)
in if computerSteine>0 && menschSteine>0
then 0
else w computerSteine - w menschSteine
aktiveVierer :: Array (Int,Int) [[(Int,Int)]]
aktiveVierer = array brettGroesse
(map (\ix -> (ix, uncurry viererVon ix)) (range brettGroesse))
viererVon :: Int -> Int -> [[(Int, Int)]]
viererVon i j = filter (elem (i,j)) alleVierer
alleVierer :: [[(Int,Int)]]
alleVierer = [ [(i+l*ii,j+l*jj) | l<-[0..3] ]
| (i,j) <- range brettGroesse,
(ii,jj) <- inc i j ]
where
inc i j = filter (\(ii,jj) ->
inRange brettGroesse (i+3*ii,j+3*jj))
[(0,1),(1,-1),(1,0),(1,1)]
grundstellung :: Spieler -> Spielstand
grundstellung x = S leeresBrett leererFuellstand x 0 (x,[])
where
leeresBrett=listArray brettGroesse (repeat Nothing)
leererFuellstand=listArray (1,7) (repeat 0)
-- Korrektur der Matt-Vorhersage-Zuege
bewertungsKorrektur :: Wertung->Wertung
bewertungsKorrektur w
| w > 5000 = w-1
| w < -5000 = w+1
| otherwise = w
{-
Wir berechnen die Stellungsbewertung zum gegebenen Brett mit einer
vorgegebenen Tiefe einschliesslich der Zuege zu dieser Stellung.
----------------------
Alpha-Beta-Suche:
Ebene 0 X
Ebene 1 A B C
Ebene 2 a b c d e ...
wert(X)=max(A,B,C)
wert(A)=min(a,b)
wert(B)=min(c,d,e)
Wir moechten nun den Wert von B abschaetzen. D.h. wir wollen wissen,
ob wert(B)<= wert(A) ist. Das ist bereits dann der Fall, wenn
wert(c)<=wert(A) ist. Dann brauchen wir d und e gar nicht mehr
anzusehen, denn es gilt wert(X) >= max (A, min (c,d,e)).
Auswerten mit Schranke:
w(A) = max (-inf, min (a,b))
wert(B) <= w(B) = max (w(A), min (c,d,e))
w(C) = max (W(B), min (...)
scanl (\x,y->f(x,X)) w(A) [B,C,D] = [w(a),f(w(a),B),f(f(w(a),B),C) ...]
also: f=(\x,y-> max (x,min(kinder y)))
----------------------
Weil ein Matt in 5 schlechter als ein Matt in 3 ist, muss beim
Zusammensetzen der Wertung vom Tochterknoten zum Mutterknoten u.U. eine
Bewertungskorrektur durchgefuehrt werden.
-}
tiefe0 :: Int
tiefe0 = 0
search :: Int->Spielstand->(Wertung,[Zug])
search suchTiefe spielstand =
bewerteKnoten suchTiefe tiefe0 posinfty spielstand
bewerteKnoten :: Int->Int->Int->Spielstand->(Wertung,[Zug])
bewerteKnoten suchTiefe tiefe bound spielstand
| tiefe == suchTiefe = (wertung spielstand,[])
| istMatt spielstand = (wertung spielstand,[])
| istPatt spielstand = (0,[])
| tiefe < suchTiefe = bestesKind
| otherwise = error "bewerteKnoten: unmoeglicher Fall"
where
zuege1 = moeglicheZuege spielstand
kinder1= map (doTheMove spielstand) zuege1
-- Den jeweils besten Zug zuerst ausprobieren, dann
-- fallen viele Faelle spaeter schneller weg.
(kinder,zuege) = unzip
((if computerAmZug spielstand
then reverse
else id)
(Key.sort (wertung . fst) (zip kinder1 zuege1)))
godown :: Int -> Spielstand -> (Wertung,[Zug])
godown=bewerteKnoten suchTiefe (tiefe+1)
godown1 (w,_) = godown w
wkind1=godown newbound (head kinder)
werteKinder = scanl (godown1) wkind1 (tail kinder)
paareWertZug = zip werteKinder zuege
bestesKind = verbinden (minmax' paareWertZug)
(minmax,newbound) =
if computerAmZug spielstand
then (maximum,neginfty)
else (minimum,posinfty)
worseThan bound0 =
if computerAmZug spielstand
then bound0 + 5
else bound0 - 5
rel :: Ord a => a->a->Bool
rel =
if computerAmZug spielstand
then (>)
else (<)
minmax' paareWertZug0 =
if any (\x->rel (fst (fst x)) (bewertungsKorrektur bound))
paareWertZug0
then ((worseThan (bewertungsKorrektur bound),[]),0)
else minmax paareWertZug0
verbinden ((wert,zuege0),zug)=(bewertungsKorrektur wert,zug:zuege0)
------------------------------------------------------
suchTiefeGesamt :: Int
suchTiefeGesamt = 6
berechneSpielstand :: (Spieler,[Zug]) -> Spielstand
berechneSpielstand (erster,zuege) =
let spielstand = foldl doTheMove (grundstellung erster) zuege
in if istMatt spielstand || not (computerAmZug spielstand)
then spielstand
else doTheMove spielstand
(head $ snd (search suchTiefeGesamt spielstand))