Personal tools

User talk:Mimoso

From HaskellWiki

(Difference between revisions)
Jump to: navigation, search
(Removing all content from page)
Line 1: Line 1:
 +
--Othello (Reversi). Manuel Hernández, April 2011.
 +
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)
 +
<nowiki>Insert non-formatted text here</nowiki>

Revision as of 23:50, 4 April 2011

--Othello (Reversi). Manuel Hernández, April 2011. 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) Insert non-formatted text here