|
|
| Line 1: |
Line 1: |
| - | --Othello (Reversi). Manuel Hernández, April 2011.
| |
| - | --Happy to be here!
| |
| - | import Random
| |
| - | import List
| |
| | | | |
| - | data Element = O | X | E | L deriving (Eq,Show)
| |
| - | data ArbolG = T Board [ArbolG] deriving Show
| |
| - | type Board = [Element]
| |
| - | data ArbolG1 = T1 (Element,Integer,Board,Int,Int) [ArbolG1] deriving Show
| |
| - | --Bug? Hugs does not accept "vectors" from size > 5 to show
| |
| - | data ArbolG3 = T3 (Element, -- Player
| |
| - | Integer, -- Mov
| |
| - | Board, -- Position
| |
| - | (Int,Int,Int) -- (num Xs, num Os, num Movs)
| |
| - | ) [ArbolG3] deriving Show
| |
| - |
| |
| - | data ArbolG4 = T4 (Element, -- Player
| |
| - | [Integer], -- Mov
| |
| - | (Int,Int,Int) -- (num Xs, num Os, num Movs)
| |
| - | ) [ArbolG4] deriving Show
| |
| - |
| |
| - | data MvVal = MvVal {mov::Integer, xs :: Int, os :: Int} deriving Show
| |
| - |
| |
| - | lcoords = concat [[(x+1)..(x+8)]| x<-[10,20..80]]
| |
| - |
| |
| - | coords pos = zipWith (\x y -> (x,y)) lcoords pos
| |
| - |
| |
| - | expandx pos ((ini,X),(cand, O)) =
| |
| - | let (delta,av) = (cand-ini,cand+delta)
| |
| - | es = findCoords av (coords pos)
| |
| - | in if null es then [] else
| |
| - | let h = snd (head es) in
| |
| - | case h of
| |
| - | X -> []
| |
| - | E -> [(cand,O),(av,E)]
| |
| - | O -> let rest = expandoX pos delta (av, O) in
| |
| - | if null rest then [] else (cand, O):rest
| |
| - |
| |
| - | expandoX pos delta (av, O) =
| |
| - | let av1 = av + delta
| |
| - | es = findCoords av1 (coords pos)
| |
| - | in if null es then [] else
| |
| - | let h = snd (head es) in
| |
| - | case h of
| |
| - | X -> []
| |
| - | E -> [(av, O),(av1, E)]
| |
| - | O -> let rest= expandoX pos delta (av1, O) in
| |
| - | if null rest then [] else (av, O):rest
| |
| - |
| |
| - | expando pos ((ini,O),(cand, X)) =
| |
| - | let
| |
| - | (delta,av) = (cand-ini,cand+delta)
| |
| - | es = findCoords av (coords pos)
| |
| - | in
| |
| - | if null es then [] else
| |
| - | let h = snd (head es) in
| |
| - | case h of
| |
| - | O -> []
| |
| - | E -> [(cand, X),(av, E)]
| |
| - | X -> let rest = expandxO pos delta (av, X) in
| |
| - | if null rest then [] else (cand, X):rest
| |
| - |
| |
| - | expandxO pos delta (av, X) = let
| |
| - | av1 = av + delta
| |
| - | es = findCoords av1 (coords pos) in
| |
| - | if null es then [] else
| |
| - | let h = snd (head es) in
| |
| - | case h of
| |
| - | O -> []
| |
| - | E -> [(av, X),(av1, E)]
| |
| - | X -> let rest= expandxO pos delta (av1, X) in
| |
| - | if null rest then [] else (av, X):rest
| |
| - |
| |
| - | allNum player pos = (nub . sort)
| |
| - | (map (fst) (validMoves player pos))
| |
| - |
| |
| - | validMoves player pos = map last (allMoves player pos)
| |
| - |
| |
| - | allMoves player pos = filter (/=[]) (movs player pos)
| |
| - |
| |
| - | movs player pos = if player==X then
| |
| - | map (expandx pos) (concat (onlyNBos X pos))
| |
| - | else
| |
| - | map (expando pos) (concat (onlyNBos O pos))
| |
| - |
| |
| - | candidates (init, ls) = zip (repeat init) ls
| |
| - |
| |
| - | findF e coors = (filter (\x -> (snd x)==e) coors)
| |
| - |
| |
| - | findCoords m coors = (filter (\x -> (fst x) == m) coors)
| |
| - |
| |
| - | neighbs e1 pos (n, e) = ((n, e),(only e1
| |
| - | (concat
| |
| - | [findCoords x (coords pos)| x<-dirs n])))
| |
| - | -- Para hallar los vecinos a una ficha X
| |
| - | onlyNBos player pos = map (candidates . (neighbs (change player) pos))
| |
| - | (findF player (coords pos))
| |
| - |
| |
| - | only e ls = filter (\x -> (snd x)==e) ls
| |
| - |
| |
| - | dirs n | elem n ([22..27]++[32..37]++[42..47]++[52..57]++[62..67]++[72..77])
| |
| - | = map (+n) [-11,-10,-9,-1,1,9,10,11]
| |
| - | | elem n [12..17] = map (+n) [-1,1,9,10,11]
| |
| - | | elem n [82..87] = map (+n) [-1,1,-9,-10,-11]
| |
| - | | elem n [21,31..71] = map (+n) [-10,-9,1,10,11]
| |
| - | | elem n [28,38..78] = map (+n) [-11,-10,-1,9,10]
| |
| - | | elem n [11] = [12,22,21]
| |
| - | | elem n [88] = [87,77,78]
| |
| - | | elem n [81] = [71,72,82]
| |
| - | | elem n [18] = [17,27,28]
| |
| - |
| |
| - | numTTT::Int
| |
| - | numTTT= 64
| |
| - |
| |
| - | part8 [] = []
| |
| - | part8 (a:bs) = (take 8 (a:bs)):(part8 (drop 8 (a:bs)))
| |
| - |
| |
| - | posIni::[Element]
| |
| - | posIni = (take 24 (repeat E))++[E,E,E,X,O,E,E,E,
| |
| - | E,E,E,O,X,E,E,E]++(take 24 (repeat E))
| |
| - |
| |
| - | to a = snd (head (filter (\x -> a==fst x) (zip lcoords [1..64])))
| |
| - |
| |
| - | maxV (MvVal n1 a1 b1) (MvVal n2 a2 b2) | a1<=a2 = MvVal n2 a2 b2
| |
| - | | otherwise = MvVal n1 a1 b1
| |
| - |
| |
| - | findMaxV ls = foldr (maxV) (MvVal 0 (-1000) 0) ls
| |
| - |
| |
| - | showB [] = ""
| |
| - | showB (a:bs) = (show a)++"\n"++(showB bs)
| |
| - |
| |
| - | showBoard pos = putStr (" _ _ _ _ _ _ _ _ \n"
| |
| - | ++[xchange x|x<-(showB (part8 pos))])
| |
| - |
| |
| - | xchange x | x==',' = '|'
| |
| - | | x=='E' = '_'
| |
| - | | otherwise = x
| |
| - |
| |
| - | count player pos = length (filter (==player) pos)
| |
| - |
| |
| - | validCoord player pos = nub (strip (validMoves player pos))
| |
| - |
| |
| - | strip [] = []
| |
| - | strip ((n, x):ls) = fst (n, x):strip ls
| |
| - | ------------------------------begin wrt X---------------------
| |
| - | allVBasic player g pos =
| |
| - | T1 (player,g,pos,count X pos,count O pos) ls
| |
| - | where
| |
| - | ls = [T1 (mMoveVirtual player k pos) [] | k <- (allNum player pos)]
| |
| - |
| |
| - | barrer player (T1 (p,m,pos,n1,n2) []) = allVBasic player m pos
| |
| - | barrer player (T1 (p,m,pos,n1,n2) (c:cs)) =
| |
| - | T1 (player,m,pos,count X pos,count O pos)
| |
| - | (map (barrer (change player)) (c:cs))
| |
| - |
| |
| - | genTree player pos n = take n (iterate (barrer player) (T1 (X,0,pos,2,2) []))
| |
| - | --Realmente sólo se utilizan jugador=X y posición=pos
| |
| - |
| |
| - | mMoveVirtual player n pos =
| |
| - | let newpos = (applyMove
| |
| - | (apply player (nub (concat
| |
| - | (filter (\x->fst (head x)==n)
| |
| - | (map reverse
| |
| - | (allMoves player pos)))))) pos)
| |
| - | in (player, n, newpos, count X newpos, count O newpos)
| |
| - | --Dato: (jugador,movimiento,posición,cuantosX,cuantosO)
| |
| - |
| |
| - | sortby [] = []
| |
| - | sortby ((a1,b1):bs) = sortby [x | x<- bs, snd x < b1]++[(a1,b1)]++
| |
| - | sortby [x | x<- bs, snd x >= b1]
| |
| - | newPos player n pos =
| |
| - | applyMove
| |
| - | (apply player (nub (concat
| |
| - | (filter (\x->fst (head x)==n)
| |
| - | (map reverse
| |
| - | (allMoves player pos)))))) pos
| |
| - | mMvVirtual player n pos =
| |
| - | let newpos = (applyMove
| |
| - | (apply player (nub (concat
| |
| - | (filter (\x->fst (head x)==n)
| |
| - | (map reverse
| |
| - | (allMoves player pos)))))) pos)
| |
| - | in MvVal n (count X newpos) (count O newpos)
| |
| - |
| |
| - | transTree (T1 (n,mov,pos,xs,os) []) = T4 (n,[mov],(xs-os,os,nm)) []
| |
| - | where
| |
| - | nm = length (allNum n pos)
| |
| - | transTree (T1 (n,mov,pos,xs,os) (a:bs)) = T4 (n,[mov],(xs,os,nm)) ls
| |
| - | where
| |
| - | ls = (map transTree (a:bs))
| |
| - | nm = length (allNum n pos)
| |
| - |
| |
| - | minimax (T4 (n,[mov],(numberOfxs,numberOfos,nm)) [])
| |
| - | |nm==0 = ([mov],-70) -- -70 o 70?
| |
| - | minimax (T4 (n,[mov],(numberOfxs,numberOfos,nm)) [])
| |
| - | |nm>0 = ([mov],-numberOfxs)
| |
| - | minimax (T4 (n,[mov],(numberOfxs,numberOfos,nm)) (a:bs)) = (ms,n)
| |
| - | where
| |
| - | ls = (negP (minList' (map minimax (a:bs))))
| |
| - | (mvT,val) = ls
| |
| - | ms = (mov:mvT) -- ++[mov]
| |
| - | n = val
| |
| - |
| |
| - | app ls (ms,t) = (ls++ms,t)
| |
| - | negP (a,b) = (a,-b)
| |
| - |
| |
| - | bestMv player pos n =
| |
| - | minimax (transTree (last (genTree player pos n)))
| |
| - |
| |
| - | minList ls = foldr (min) (1000) ls
| |
| - | minP (a1,b1) (a2,b2) = if b1<b2 then (a1,b1) else (a2,b2)
| |
| - | minList' ls = foldr (minP) ([],1000) ls
| |
| - |
| |
| - | mMove player n pos = showBoard (applyMove
| |
| - | (apply player (nub (concat
| |
| - | (filter (\x->fst (head x)==n)
| |
| - | (map reverse
| |
| - | (allMoves player pos)))))) pos)
| |
| - | ---------------------------end wrt X-----------------------------
| |
| - | apply player [] = []
| |
| - | apply player ((n,e):ls) = (n,player):apply player ls
| |
| - |
| |
| - | applyMove [] pos = pos
| |
| - | applyMove ((n,player):ls) pos = applyMove ls (sustn player (to n) pos)
| |
| - |
| |
| - | sustn :: (Num a, Ord a) => b -> a -> [b] -> [b]
| |
| - | sustn a 1 (c:cs) = (a:cs)
| |
| - | sustn a n (c:cs) | n>1 = c:(sustn a (n-1) cs)
| |
| - |
| |
| - | change X = O
| |
| - | change O = X
| |
| - |
| |
| - | ------Ahora ya juega muy bien :) (xs - os)
| |
| - |
| |
| - | calcMov :: Board -> IO()
| |
| - | calcMov pos = do
| |
| - | --Report winner..., missing
| |
| - | let
| |
| - | bm = head (tail (fst (bestMv X pos 3)))
| |
| - | newpos1 = newPos X bm pos
| |
| - | mMove X bm pos
| |
| - | putStr $ show bm
| |
| - | putStr $ "\n"
| |
| - | putStrLn $ "Fichas negras: " ++ (show (count X newpos1))
| |
| - | putStrLn $ "Fichas blancas: " ++ (show (count O newpos1))
| |
| - | putStrLn $ (show (allNum O newpos1))++"\n"
| |
| - | putStr "Tu movimiento: "
| |
| - | input <- getLine
| |
| - | let square = (read input) :: Integer
| |
| - | -- putStr (show square)
| |
| - | let
| |
| - | newpos2 = newPos O square newpos1
| |
| - | mMove O square newpos1
| |
| - | putStrLn $ "Fichas negras: "++ (show (count X newpos2))
| |
| - | putStrLn $ "Fichas blancas: "++ (show (count O newpos2))
| |
| - | calcMov (newPos O square newpos2)
| |
| - |
| |
| - | main = calcMov posIni
| |
| - |
| |
| - | --Variants:
| |
| - | --a) Three players (or more)
| |
| - | --b) Scattering pieces over the board
| |
| - | --c) Boards with obstacles (squares, or diamonds, for example)
| |
| - | --d) Boards with distinct geometrical forms.
| |
| - | --e) Boards with distinct square geometry.
| |
| - | --f) Random static token
| |
| - | --g) Factor number betrayed
| |
| - | --h) ¿Dimensions?
| |
| - | --i) Special turns (like to put a token over an arbitrary square)
| |
