Крестики нолики на двоих Haskell

{-^
Лабораторная 7. Вариант 6. Крестики-нолики. Минимаксный подход.
 
Игра «крестики-нолики» на доске 3 х 3. Пронумеруем клетки следующим образом:
 
 1 | 2 | 3 
---+---+---
 4 | 5 | 6 
---+---+---
 7 | 8 | 9 
 
Тогда позиция во время игры может быть представлена как data Pos = Pos [Integer] [Integer], 
где первый список содержит позиции игрока компьютера O, 
а второй — позиции противника человека Х.  
-}
 
module Main where
 
import Data.List         
import System.Random
 
 
data Pos = Pos [Integer] [Integer] deriving Show
 
-- ^ функция validPos :: Pos -> Bool, которая проверяет необходимые условия правильности позиции.
validPos :: Pos -> Bool
validPos (Pos [][]) = True
validPos (Pos ol xl) = res where          
  sp = (xl++ol)  
  res = all (\a -> a == True) [maximum sp < 10, minimum sp > 0, nub sp == sp, True] 
-- ^ Test
validPosTest = [validPos (Pos [][]),  validPos (Pos [1,0,-1] [4,5,11]),
                validPos (Pos [1,6,5] [4,5,11]), validPos (Pos [1,4] [5,7,9])]
               
-- ^ функция vacant :: Pos -> [Integer], которая возвращает пустые клетки для данной позиции. 
vacant :: Pos -> [Integer]
vacant (Pos ol xl) = res where
  sp = (xl++ol) 
  res = drop (length sp)(nub (sp ++ [1..9]))
vacantTest = [vacant (Pos [1,5] [2])]
 
-- ^ функция play :: Integer -> Pos -> Pos, которая возвращает позицию, 
-- где текущий игрок компьютер ставит свой знак в заданную клетку.
play :: Integer -> Pos -> Pos
play m (Pos o x) = (Pos ([m]++o) x)
playTest  = [play 1 (Pos [5] [2]),  play 3 (Pos [1,5] [2])]
 
play' :: Integer -> Pos -> Pos
play' m (Pos o x) = (Pos o ([m]++x)) 
playTest'  = [play' 1 (Pos [5] [2]),  play' 3 (Pos [1,5] [2])]
 
-- ^Строки, столбцы, диагонали доски 3Х3
rcd :: [[Integer]]
rcd = [[1,2,3], [4,5,6], [7,8,9], [1,4,7], [2,5,8], [3,6,9], [1,5,9], [3,5,7]]
 
-- ^Функция won :: Pos -> Bool, которая определяет, выиграл ли игрок компьютер. 
-- Например: won (Pos [1,5] [2,3]) == False; won (Pos [1,4,5,7] [2,3,9]) == True.
won :: Pos -> Bool
won (Pos xl o) = length (filter (\f -> (length f) == (length xl)) (map (\n -> nub (xl++n)) rcd)) > 0
wonTest = [won (Pos [1,5] [2,3]), won (Pos [1,4,5,7] [2,3,9]), won (Pos [9,7,1,5] [2,3,9])]
 
won' :: Pos -> Bool
won' (Pos o xl) = length (filter (\f -> (length f) == (length xl)) (map (\n -> nub (xl++n)) rcd)) > 0
wonTest' = [won (Pos [1,5] [2,3]), won (Pos [1,4,5,7] [2,3,9]), won (Pos [9,7,1,5] [2,3,9])]
 
{-^
Н. Нильсон "Принципы исскуственного интеллекта" c. 100
Статическая оценочная функция. Задается тремя условиями:
 1) Если в позиции Pos не выигрывает ни один из игроков, то scope(Pos) - 
   (число строк, столбцов и диагоналей, на данный момент целиком свободных 
    для игрока max (comp)) - (число строк, столбцов и диагоналей, на данный момент целиком свободных 
    для игрока min). Т.е. число строк, столбцов и диагоналей, на игровой доске 3Х3, в которых
    игрок min не поставил пока ни одного знака.
 2) Если в Pos выигрыш получает max, то scope(Pos) = очень большому числу
 3) Если в Pos выигрыш получает min, то scope(Pos) = очень большому отрицательному числу
-}
 
score :: Pos -> Integer
score (Pos ol xl) = 
  if won (Pos ol xl) 
  then 1000000000  -- max (comp) победил
  else if won' (Pos ol xl)
       then -1000000000 -- max проиграл
       else (rcdEmpty xl) - (rcdEmpty ol) 
--
rcdEmpty :: [Integer] -> Integer
rcdEmpty l = (sum $ concat (map (\m -> map (\r -> if (elem m r) then 0 else 1) rcd) l))
 
scoreTest  = [score (Pos [5] [1]), score (Pos [5] [4]), score (Pos [4] [5]),
              score (Pos [4] [2]), score (Pos [1] [4])]
 
-- max
evalMax :: Pos -> Integer
evalMax pos = 
  maximum (map (\y -> evalMin y) (map (\x -> (play x pos)) (vacant pos)) )
 
evalMax' pos = 
  (map (\y -> (y, evalMin y)) (map (\x -> (play x pos)) (vacant pos)) )
  
-- min
evalMin :: Pos -> Integer
evalMin pos = 
  minimum (map (\y -> score y) (map (\x -> (play' x pos)) (vacant pos)) )
 
evalMin' pos = (map (\y -> score y) (map (\x -> (play' x pos)) (vacant pos)) )
 
-- Последний ход компьютера?
lastPlay :: Pos -> Integer
lastPlay (Pos o x) = head o
 
-- Сравнение позиций для сортировки функцией sortBy
cmpPos :: (Pos, Integer) -> (Pos, Integer) -> Ordering
cmpPos p1 p2 = if (snd p1) > (snd p2) then GT else LT
 
-- ^Функция bestMove :: Pos -> Integer, Возвращающую клетку в которую нужно сделать лучший ход. 
--  Например: bestMove (Pos [1,5] [2,3]) == 4.
bestMove :: Pos -> Integer
bestMove (Pos ol xl) =  lastPlay (fst (last (sortBy (\s1 s2 -> cmpPos s1 s2) (evalMax' (Pos ol xl)))))
 
bestMoveTest = [bestMove (Pos [1,5] [2,3]), bestMove (Pos [1,4,8] [3,5,7]), bestMove (Pos [1,2] [7,8])]
 
-- ^Программа, которая  в интерактивном режиме играет с человеком, 
--  отображая изменение состояния игрового поля.
 
replace :: Eq a => [a] -> [a] -> [a] -> [a]
replace [] _ _ = []
replace s find repl =
  if take (length find) s == find
  then repl ++ (replace (drop (length find) s) find repl)
  else [head s] ++ (replace (tail s) find repl)
 
{-^
Для вывода позиции на экран преобразует стуктуру данных Pos в
строковое представление номеров, нулей и крестов. 
Первый список это будут ходы компа которые обозначим символом O.
-}
 
makeStringPos :: Pos -> String
makeStringPos (Pos o x) = res where
  empty =  "\n123\n456\n789\n"
  res = add' (add' empty x "X") o "O"
 
makeStringPos' :: Pos -> String
makeStringPos' (Pos o x) = res where
  empty =  "\n 1 | 2 | 3 \n---+---+---\n 4 | 5 | 6 \n---+---+---\n 7 | 8 | 9 \n"
  res = add' (add' empty x "X") o "O"
 
add' :: String -> [Integer] -> String -> String
add' s [] a = s
add' s (r:rs) a = add' (replace s (show r) a) rs a
 
game :: Pos -> IO ()
game (Pos x o) = do  
  putStr "Vacant course: "
  putStrLn $ show (vacant (Pos x o))
  putStrLn (makeStringPos' (Pos x o))        
  if null$ vacant (Pos x o)
    then
    if won (Pos x o) 
    then do putStrLn "Winner comp ;)" 
    else if won' (Pos x o)
         then do  putStrLn "Winner humman ;("
         else do  putStrLn "Drawn game :)"
    else do
    putStrLn "Your course:"
    pos <- getLine 
    let newPos = play' ((read pos)::Integer) (Pos x o)
    putStrLn (show newPos)                
    if validPos newPos
      then do 
      if won' newPos 
        then do 
        putStrLn (makeStringPos' newPos)
        putStrLn "Winner humman ;("
        else if (null $ vacant newPos) == False
             then do
               let forHumPos = (play (bestMove newPos) newPos)
               putStr "Comp course: "
               putStrLn $ show (lastPlay forHumPos)    
               if won forHumPos                               
                 then  do  putStrLn (makeStringPos' forHumPos) ; putStrLn "Winner comp ;)"
                 else do game forHumPos 
             else do putStrLn (makeStringPos' newPos); putStrLn "Drawn game :)"
      else do putStrLn("\nInvalid course! Repeat!\n"); game (Pos x o)
                       
main = do
    putStrLn "Daggers-Zeroes games."  
    game (Pos [][])

module Main(main) where
 
import Data.List         
 
data Pos = Pos [Int] [Int] deriving Show
 
-- ^ функция validPos :: Pos -> Bool, которая проверяет необходимые условия правильности позиции.
validPos :: Pos -> Bool
validPos (Pos [][]) = True
validPos (Pos ol xl) = res where          
  sp = xl++ol
  res = and [maximum sp < 10, minimum sp > 0, nub sp == sp, True] 
               
-- ^ функция vacant :: Pos -> [Int], которая возвращает пустые клетки для данной позиции. 
vacant :: Pos -> [Int]
vacant (Pos ol xl) = res where
  sp = xl++ol 
  res = drop (length sp)(nub (sp ++ [1..9]))
 
-- ^ функция play :: Int -> Pos -> Pos, которая возвращает позицию, 
-- где текущий игрок компьютер ставит свой знак в заданную клетку.
play :: Int -> Pos -> Pos
play m (Pos o x) = Pos (m:o) x
 
play' :: Int -> Pos -> Pos
play' m (Pos o x) = Pos o (m:x)
 
-- ^Строки, столбцы, диагонали доски 3Х3
rcd :: [[Int]]
rcd = [[1,2,3], [4,5,6], [7,8,9], [1,4,7], [2,5,8], [3,6,9], [1,5,9], [3,5,7]]
 
-- ^Функция isWon :: [Int] -> Bool, которая определяет, выиграл ли игрок компьютер. 
isWon :: [Int] -> Bool 
isWon x = any (all (`elem` x)) rcd
 
replace :: Eq a => [a] -> [a] -> [a] -> [a]
replace [] _ _ = []
replace s find repl =
  if take (length find) s == find
  then repl ++ replace (drop (length find) s) find repl
  else head s : replace (tail s) find repl
 
{-^
Для вывода позиции на экран преобразует стуктуру данных Pos в
строковое представление номеров, нулей и крестов. 
Первый список это будут ходы компа которые обозначим символом O.
-}
 
makeStringPos' :: Pos -> String
makeStringPos' (Pos o x) = res where
  empty =  "\n 1 | 2 | 3 \n---+---+---\n 4 | 5 | 6 \n---+---+---\n 7 | 8 | 9 \n"
  res = add' (add' empty x "X") o "O"
 
add' :: String -> [Int] -> String -> String
add' s [] _ = s
add' s (r:rs) a = add' (replace s (show r) a) rs a
 
gamerChar :: Bool -> Char 
gamerChar False = 'O'
gamerChar _     = 'X'
 
game :: Bool -> Pos -> IO ()
game bGamer (Pos x o) 
        | isWon o = showPos >> putStrLn "Winner gamer X" 
        | isWon x = showPos >> putStrLn "Winner gamer O"
        | null$ vacant (Pos x o) = showPos >> putStrLn "Drawn game :)"
        | otherwise = do
    putStr "Vacant course: "
    print $ vacant $ Pos x o
    showPos        
    putStrLn $ "Your course, gamer " ++ (gamerChar bGamer :" :")
    pos <- getLine 
    let newPos = (if bGamer then play' else play) (read pos ::Int) (Pos x o)
    if validPos newPos
      then game (not bGamer) newPos
      else putStrLn "\nInvalid course! Repeat!\n" >> game bGamer (Pos x o)
  where showPos = putStrLn (makeStringPos' (Pos x o))
    
main :: IO ()   
main = do
    putStrLn "Daggers-Zeroes games."  
    game True (Pos [][])

-- ^Строки, столбцы, диагонали доски 3Х3
rcd :: [[Int]]
rcd = [[1,2,3], [4,5,6], [7,8,9], [1,4,7], [2,5,8], [3,6,9], [1,5,9], [3,5,7]]