Personal tools

User talk:Mimoso

From HaskellWiki

(Difference between revisions)
Jump to: navigation, search
(Replacing page with '--Othello (Reversi). Manuel Hernández, April 2011. import Random import List')
(Undo revision 42933 by Rmason (Talk). -- Rmason did this probably by mistake, so I'm reverting)
 
(20 intermediate revisions by 2 users not shown)
Line 1: Line 1:
--Othello (Reversi). Manuel Hernández, April 2011.
+
== Othello (Reversi), by Mimoso. April 2011. ==
  +
  +
  +
<haskell>
 
import Random
 
import Random
 
import List
 
import List
  +
  +
data Element = O | X | E | L deriving (Eq,Show)
  +
data TreeG = T Board [TreeG] deriving Show
  +
type Board = [Element]
  +
data TreeG1 = T1 (Element,Integer,Board,Int,Int) [TreeG1] deriving Show
  +
  +
data TreeG3 = T3 (Element, -- Player
  +
Integer, -- Mov
  +
Board, -- Position
  +
(Int,Int,Int) -- (num Xs, num Os, num Movs)
  +
) [TreeG3] deriving Show
  +
  +
data TreeG4 = T4 (Element, -- Player
  +
[Integer], -- Mov
  +
(Int,Int,Int) -- (num Xs, num Os, num Movs)
  +
) [TreeG4] deriving Show
  +
  +
data MvVal = MvVal {mov::Integer, xs :: Int, os :: Int} deriving Show
  +
  +
--A board:
  +
  +
-- 11 12 13 14 15 16 17 18
  +
-- 21 22 23 24 25 26 27 28
  +
-- ... xy-10
  +
-- ... xy-1<-xy ->xy+1
  +
-- ... xy+10
  +
-- 81 82 83 84 85 86 87 88
  +
  +
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])))
  +
-- To find the neighborhoods...
  +
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]
  +
  +
numBoard::Int
  +
numBoard= 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)]
  +
  +
sweep player (T1 (p,m,pos,n1,n2) []) = allVBasic player m pos
  +
sweep player (T1 (p,m,pos,n1,n2) (c:cs)) =
  +
T1 (player,m,pos,count X pos,count O pos)
  +
(map (sweep (change player)) (c:cs))
  +
  +
genTree player pos n = take n (iterate (sweep player) (T1 (X,0,pos,2,2) []))
  +
  +
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: (player, movement, position, howmanyX, howmanyO)
  +
  +
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)
  +
--Simple minimax:
  +
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) -- positive, it is "greedy"
  +
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)))
  +
  +
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
  +
  +
-- The strength of playing depends on the eval functio as well as the search depth
  +
  +
calcMov :: Board -> IO()
  +
calcMov pos = do
  +
--Report winner..., missing
  +
let
  +
bm = head (tail (fst (bestMv X pos 3))) -- Empty list..., missing
  +
newpos1 = newPos X bm pos
  +
mMove X bm pos
  +
putStr $ show bm
  +
putStr $ "\n"
  +
putStrLn $ "Black: " ++ (show (count X newpos1))
  +
putStrLn $ "White: " ++ (show (count O newpos1))
  +
putStrLn $ (show (allNum O newpos1))++"\n"
  +
putStr "Your move: "
  +
input <- getLine
  +
let square = (read input) :: Integer
  +
-- putStr (show square)
  +
let
  +
newpos2 = newPos O square newpos1
  +
mMove O square newpos1
  +
putStrLn $ "Black: "++ (show (count X newpos2))
  +
putStrLn $ "White: "++ (show (count O newpos2))
  +
calcMov (newPos O square newpos2)
  +
  +
main = calcMov posIni
  +
</haskell>
  +
  +
--Variants:
  +
# Three players (or more)
  +
# Scattering pieces over the board
  +
# Boards with obstacles (squares, or diamonds, for example)
  +
# Boards with distinct geometrical forms.
  +
# Boards with distinct square geometry.
  +
# Random static token
  +
# Factor number betrayed
  +
# ¿Dimensions? I am thinking... 3D Othello.
  +
# Special turns (like to put a token over an arbitrary square)
  +
# Hexa "squares"
  +
  +
  +
I suggest to use the OpenGL library to make an interface.
  +
  +
For future editing: [http://www.wikipedia.org Wikipedia]
  +
[[Category:Programming]]
  +
[[Category:Games]]
  +
[[Category:Artificial Intelligence]]

Latest revision as of 12:27, 16 November 2011

[edit] Othello (Reversi), by Mimoso. April 2011.

import Random
import List
 
data Element = O | X | E | L deriving (Eq,Show)
data TreeG = T Board [TreeG] deriving Show
type Board = [Element]
data TreeG1 = T1 (Element,Integer,Board,Int,Int) [TreeG1] deriving Show
 
data TreeG3 = T3 (Element, -- Player
                   Integer, -- Mov
                   Board, -- Position
                   (Int,Int,Int) -- (num Xs, num Os, num Movs) 
                   ) [TreeG3] deriving Show
 
data TreeG4 = T4 (Element, -- Player
                   [Integer], -- Mov
                   (Int,Int,Int) -- (num Xs, num Os, num Movs) 
                   ) [TreeG4] deriving Show
 
data MvVal = MvVal {mov::Integer, xs :: Int, os :: Int} deriving Show
 
--A board:
 
-- 11 12 13 14 15 16 17 18
-- 21 22 23 24 25 26 27 28
--  ...       xy-10
--  ... xy-1<-xy ->xy+1
--  ...       xy+10
-- 81 82 83 84 85 86 87 88
 
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])))
-- To find the neighborhoods...
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]
 
numBoard::Int
numBoard= 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)]
 
sweep player (T1 (p,m,pos,n1,n2) []) = allVBasic player m pos
sweep player (T1 (p,m,pos,n1,n2) (c:cs)) = 
           T1 (player,m,pos,count X pos,count O pos) 
                 (map (sweep (change player)) (c:cs))
 
genTree player pos n = take n (iterate (sweep player) (T1 (X,0,pos,2,2) []))
 
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: (player, movement, position, howmanyX, howmanyO)
 
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)
--Simple minimax: 
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) -- positive, it is "greedy" 
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)))
 
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
 
-- The strength of playing depends on the eval functio as well as the search depth
 
calcMov :: Board -> IO()
calcMov pos = do
        --Report winner..., missing
        let 
          bm = head (tail (fst (bestMv X pos 3))) -- Empty list..., missing
          newpos1 = newPos X bm pos
        mMove X bm  pos
        putStr $ show bm
        putStr $ "\n"
        putStrLn $ "Black: " ++ (show (count X newpos1))
        putStrLn $ "White: " ++ (show (count O newpos1))
        putStrLn $ (show (allNum O newpos1))++"\n"
        putStr "Your move: "
        input <- getLine
        let square = (read input) :: Integer
--        putStr (show square)
        let 
          newpos2 = newPos O square newpos1
        mMove O square newpos1  
        putStrLn $ "Black: "++ (show (count X newpos2))                
        putStrLn $ "White: "++ (show (count O newpos2))                
        calcMov (newPos O square newpos2)          
 
main = calcMov posIni

--Variants:

  1. Three players (or more)
  2. Scattering pieces over the board
  3. Boards with obstacles (squares, or diamonds, for example)
  4. Boards with distinct geometrical forms.
  5. Boards with distinct square geometry.
  6. Random static token
  7. Factor number betrayed
  8. ¿Dimensions? I am thinking... 3D Othello.
  9. Special turns (like to put a token over an arbitrary square)
  10. Hexa "squares"


I suggest to use the OpenGL library to make an interface.

For future editing: Wikipedia