module Main where

--- E-Empty, W-White, B-Black
data Cell = E | W | B deriving (Eq)

instance Show Cell where 
    show E = "."
    show W = "0"
    show B = "*"

inverse E = E
inverse W = B
inverse B = W

--- Row description
data Row = Row { c1 :: Cell,
                 c2 :: Cell,
                 c3 :: Cell,
                 c4 :: Cell,
                 c5 :: Cell,
                 c6 :: Cell,
                 c7 :: Cell,
                 c8 :: Cell }

instance Show Row where 
    show (Row c1 c2 c3 c4 c5 c6 c7 c8) =
        show c1 ++ " " ++ show c2 ++ " " ++ show c3 ++ " " ++ show c4 ++ " "
        ++ show c5 ++ " " ++ show c6 ++ " " ++ show c7 ++ " " ++ show c8 ++ " "

getCell (Row a _ _ _ _ _ _ _ ) 1 = a
getCell (Row _ a _ _ _ _ _ _ ) 2 = a
getCell (Row _ _ a _ _ _ _ _ ) 3 = a
getCell (Row _ _ _ a _ _ _ _ ) 4 = a
getCell (Row _ _ _ _ a _ _ _ ) 5 = a
getCell (Row _ _ _ _ _ a _ _ ) 6 = a
getCell (Row _ _ _ _ _ _ a _ ) 7 = a
getCell (Row _ _ _ _ _ _ _ a ) 8 = a

--- get modified row
modifyRow r _     []     = r
modifyRow r color cells  = 
    Row (cell 1) (cell 2) (cell 3) (cell 4) (cell 5) (cell 6) (cell 7) (cell 8)
    where 
        cell n = case (filter (\x -> x == n) cells) of
                    [] -> (getCell r n)    
                    _  -> color

--- Board description                  
data Board = Board { r1 :: Row,
                     r2 :: Row,
                     r3 :: Row,
                     r4 :: Row,
                     r5 :: Row,
                     r6 :: Row,
                     r7 :: Row,
                     r8 :: Row } 

instance Show Board where 
    show (Board r1 r2 r3 r4 r5 r6 r7 r8) =
        "Board: \n" 
        ++ "  1 2 3 4 5 6 7 8\n" 
        ++ "a " ++ show r1 ++ "\n" 
        ++ "b " ++ show r2 ++ "\n" 
        ++ "c " ++ show r3 ++ "\n" 
        ++ "d " ++ show r4 ++ "\n" 
        ++ "e " ++ show r5 ++ "\n" 
        ++ "f " ++ show r6 ++ "\n" 
        ++ "g " ++ show r7 ++ "\n" 
        ++ "h " ++ show r8 ++ "\n" 

getRow (Board a _ _ _ _ _ _ _ ) 1 = a
getRow (Board _ a _ _ _ _ _ _ ) 2 = a
getRow (Board _ _ a _ _ _ _ _ ) 3 = a
getRow (Board _ _ _ a _ _ _ _ ) 4 = a
getRow (Board _ _ _ _ a _ _ _ ) 5 = a
getRow (Board _ _ _ _ _ a _ _ ) 6 = a
getRow (Board _ _ _ _ _ _ a _ ) 7 = a
getRow (Board _ _ _ _ _ _ _ a ) 8 = a
    
--- get cell at specified position
get board row cell = (getCell (getRow board row) cell)

--- get modified board
modifyBoard b _     []            = b  
modifyBoard b color affectedCells = 
    Board (row 1) (row 2) (row 3) (row 4) (row 5) (row 6) (row 7) (row 8)
    where 
        row n = modifyRow (getRow b n) 
                          (color) 
                          (map (\(x,y) -> y) 
                               (filter (\(x, y) -> x == n) affectedCells))

--- get cells in specified direction (dx, dy) 
getTrace _ 0 _  _  = [] 
getTrace 0 _ _  _  = [] 
getTrace _ 9 _  _  = [] 
getTrace 9 _ _  _  = [] 
getTrace x y dx dy = [(x, y)] ++ (getTrace (x + dx) (y + dy) dx dy)

--- get amount of opened cells
opened _    []    = 0 
opened cell cells = 
    case (trim_left E cells) of 
        (0, _)    -> 0
        (1, rest) -> case (trim_left (inverse cell) rest) of
                        (0, _)    -> 0
                        (k, rest) -> case (trim_left cell rest) of
                                        (0, _) -> 0
                                        (n, _) -> k      
        (n, _)    -> 0
    where
        trim_left _    []           = (0, []) 
        trim_left cell cells@(x:xs) = 
            if (cell == x) then
                              case (trim_left cell xs) of 
                                (count, rest) -> (count + 1, rest)
                           else
                              (0, cells)

--- get opened cells                              
getCells color board x y =
    case foldr (\(dx, dy) total -> total ++ openedInDirection dx dy) [] directions of 
        [] -> []
        cells@_ -> [(x,y)] ++ cells
    where
        directions = [( 1, 1), ( 1, 0), ( 1, -1),
                      ( 0, 1),          ( 0, -1),
                      (-1, 1), (-1, 0), (-1, -1)]
        openedInDirection dx dy =
            let trace = (getTrace x y dx dy)
                cells = map (\(x, y) -> get board x y) trace
            in  
                case (opened color cells) of 
                    0 -> []
                    n -> sublist n (tail trace)
            where 
                sublist 0  _     = []
                sublist n (x:xs) = [x] ++ sublist (n-1) xs  
                         

--- play game...
nextMove b color =
    do         
        putStrLn (show b)
        case (color) of 
           W -> putStrLn "White: "
           B -> putStrLn "Black: "
           
        input <- getLine 
        
        case (getCells color b (parse (head input)) (parse (head (tail input)))) of 
            []      -> nextMove b color -- re try move... 
            cells@_ -> nextMove (modifyBoard b color cells) (inverse color)
    where 
        parse 'a' = 1
        parse 'b' = 2
        parse 'c' = 3
        parse 'd' = 4
        parse 'e' = 5
        parse 'f' = 6
        parse 'g' = 7
        parse 'h' = 8
        parse '1' = 1
        parse '2' = 2
        parse '3' = 3
        parse '4' = 4
        parse '5' = 5
        parse '6' = 6
        parse '7' = 7
        parse '8' = 8
                
initial = Board (Row E E E E E E E E)
                (Row E E E E E E E E)
                (Row E E E E E E E E)
                (Row E E E W B E E E)
                (Row E E E B W E E E)
                (Row E E E E E E E E)
                (Row E E E E E E E E)
                (Row E E E E E E E E) 

main = nextMove initial W

parse x | x >= 'a' && x <= 'h' = Char.ord x - Char.ord 'a' + 1
        | x >= '1' && x <= '8' = Char.ord x - Char.ord '0'

tuple8 [x1,x2,x3,x4,x5,x6,x7,x8] = (x1,x2,x3,x4,x5,x6,x7,x8)
list8  (x1,x2,x3,x4,x5,x6,x7,x8) = [x1,x2,x3,x4,x5,x6,x7,x8]

tuple8x8 m = tuple8 (map tuple8 m) -- tuple8 . (map tuple8)
list8x8  m = map list8 (list8 m)   -- (map list8) . list8

SL>Сам себе не доверяешь?

NGG>tuple8 — забавно звучит

type Tuple8 t = (t,t,t,t,t,t,t,t)
type Row = Tuple8 Cell
type Board = Tuple8 Row

class Board brd c where -- c - тип ячейки, brd - контейнер
    at :: Ix x, Ix y => brd c -> (x,y) -> c
    row :: Ix y => brd c -> y -> [c]
    col :: Ix x => brd c -> x -> [c]
    initBoard :: c -> brd c
    boardFromRows :: [[c]] -> brd c
    boardFromCols :: [[c]] -> brd c
    boardSet :: Ix x, Ix y => brd c -> (x,y) -> c -> brd c
    boardDiff :: Ix x, Ix y => brd c -> [(x,y,c)] -> brd c

newtype MyBoard c = MyBoard (Array c)
instance Board MyBoard where
    at (MyBoard a) (x,y) = a ! (x+y*8) -- развёртка по строкам
    row b y = [at b (x,y) | x<-[0..7]]
    col b x = [at b (x,y) | y<-[0..7]]
    initBoard c = listArray (0,63) (repeat c)
    -- и т.д.

[1 of 1] Compiling Main             ( Main.hs, workspace\Reversi\out/Main.o )

Main.hs:113:41:
    Couldn't match expected type `(Int, Int)'
       against inferred type `IO Position'
      Expected type: Board -> (Int, Int)
      Inferred type: Player
    In the expression: wPlayer
    In a case alternative: W -> wPlayer

module Main where 

import Data.Char

---------------------
--- Board 
---------------------

data Cell = E | W | B deriving Eq 

inverse W = B 
inverse B = W 

data Board = Board [Cell]  

initBoard = Board--0 1 2 3 4 5 6 7 
                  [E,E,E,E,E,E,E,E, -- 0 
                   E,E,E,E,E,E,E,E, -- 1
                   E,E,E,E,E,E,E,E, -- 2
                   E,E,E,B,W,E,E,E, -- 3
                   E,E,E,W,B,E,E,E, -- 4
                   E,E,E,E,E,E,E,E, -- 5
                   E,E,E,E,E,E,E,E, -- 6
                   E,E,E,E,E,E,E,E] -- 7

updateBoard (Board cells) color updatedCells =
    Board (update cells 0 (sort updatedCells))
    where
        sort []     = []
        sort (x:xs) = (sort (filter (x>) xs)) ++ [x] ++ (sort (filter (x<) xs)) 
            
        update []     _    _                  = []
        update cs     _    []                 = cs
        update (c:cs) indx (i:is) | i == indx = color : update cs (indx+1) is
                                  | otherwise = c : update cs (indx+1) (i:is) 

type Position = (Int, Int) 

toIndex (row, cell) = row * 8 + cell

cellAt (Board cells) p =  cells !! (toIndex p)        

isOutOfRange (row, cell) = row < 0 || row > 7 || cell < 0 || cell > 7 

---------------------
--- Rules 
---------------------

takenCells _     E     _        = [] 
takenCells board color position = 
    case concat (map openedCells (traces position)) of
        [] -> []
        ps -> position : ps 
    where
        traces p =
            foldr (((:).) (trace p)) [] moves 
            where  
                moves = 
                    map move [(-1,  1), (0,  1), (1,  1), 
                              (-1,  0),          (1,  0), 
                              (-1, -1), (0, -1), (1, -1)] 
                    where                       
                        move (dx, dy) (x, y) = (x + dx, y + dy) 
                trace p _ | isOutOfRange p = []   
                trace p next               = p : trace (next p) next 
        leftTrim e (x:xs) | e == x = case leftTrim e xs of (count, rest) -> (count + 1, rest) 
        leftTrim _ lst             = (0, lst) 
        openedCells psn =
            case map (cellAt board) psn of
                (E:cs)    -> case leftTrim (inverse color) cs of
                                (0, _)     -> []
                                (_, [])    -> []
                                (_, (E:_)) -> []
                                (n, _)     -> take n (tail psn)
                otherwise -> []

move board color position = updateBoard board color (map toIndex (takenCells board color position)) 

moveAllowed board color position = [] /= (takenCells board color position)
    
hasMoves board color = [] /= filter (moveAllowed board color) [(x,y) | x<-[0..7], y<-[0..7]]
        
---------------------
--- Game engine
---------------------
     
instance Show Cell where
    show E = "."
    show W = "0"
    show B = "*"

instance Show Board where
    show (Board cells) =
        "  1 2 3 4 5 6 7 8 " ++ concat (map showRow (zip ['a'..'h'] [0,8..56]))
        where
            showRow (label, n) = "\n" ++ [label] ++ concat (map ((" "++).show.(cells!!)) [n+x|x<-[0..7]])

type Player = Board -> IO Position 

playGame :: Player -> Player -> Board -> Cell -> IO () 
playGame wPlayer bPlayer board color  =
    do  
        print board

        case hasMoves board color of 
            False -> case hasMoves board (inverse color) of
                        False -> print "Game over."
                        True  -> nextMove board (inverse color)   
            True  -> makeMove ((case color of 
                                    W -> wPlayer
                                    B -> bPlayer) board)  -- Ошибка тут. Как быть?!
    where
        nextMove = playGame wPlayer bPlayer
        makeMove p | isOutOfRange p         = nextMove board color 
                   | moveAllowed board color p  = nextMove (move board color p) (inverse color) 
                   | otherwise              = nextMove board color 
      
---------------------
--- Players 
---------------------

human :: Cell -> Player    
human color board =
    do 
        case color of 
           W -> print "White:"
           B -> print "Black:"
           
        input <- getLine
        
        return ((parse (head input)), (parse (head (tail input))))
    where
        parse x | 'a' <= x && x <= 'h' = ord x - ord 'a'
                | '1' <= x && x <= '8' = ord x - ord '1'
                | otherwise            = -1
    
main = playGame (human W) (human B) initBoard W

        openedCells ps = -- возвращает координаты открытых "ячеек" 
            case map (cellAt board) ps of
                (E:cs)    -> case leftTrim (inverse color) cs of
                                (0, _)     -> []
                                (_, [])    -> []
                                (_, (E:_)) -> []
                                (n, _)     -> take n (tail ps)
                otherwise -> []
            where
                leftTrim e (x:xs) | e == x = case leftTrim e xs of (count, rest) -> (count + 1, rest) 
                leftTrim _ lst             = (0, lst)

instance Show Board where
    show (Board cells) =
        "  1 2 3 4 5 6 7 8 " ++ (showRow (map toChar cells) ['a'..'h']) 
        where
            showRow []                           _      = [] 
            showRow (c1:c2:c3:c4:c5:c6:c7:c8:cs) (k:ks) = 
                '\n':k:' ':c1:' ':c2:' ':c3:' ':c4:' ':c5:' ':c6:' ':c7:' ':c8:(showRow cs ks)
            toChar E = '.'
            toChar W = '0'
            toChar B = '*'

openedCells ps = openedCells' selected
    where
        leftTrim e xs = let (es, ys) = partition (==e) xs in (length es, ys) 

        selected = map (cellAt board) ps

        (n, cells) = leftTrim (inverse color) (tail selected)

        openedCells' (E:cs) | n /= 0 && head cells /= E = take n (tail ps)
        openedCells' _                                  = []

NGG>++ — в методе Sort (кстати, как называется "стандартный" метод сортировки? ) и при печати доски...

NGG>Если заменить ++, на : это станет менее императивно?

Main.hs:117:47:
    Couldn't match expected type `IO b' against inferred type `Game'
      Expected type: Position -> IO b
      Inferred type: Position -> Game
    In the second argument of `(>>=)', namely `updateGame'
    In the expression: (makeMove game) >>= updateGame

module Main where 

import Data.Char
import Data.List 

---------------------
--- Board and Rules 
---------------------

data Cell = E | W | B deriving Eq 

inverse W = B 
inverse B = W 

data Board = Board [Cell]  

instance Show Board where
    --- display board 
    show (Board cells) =
        "  1 2 3 4 5 6 7 8 \n" ++ (showRow (map toChar cells) ['a'..'h']) 
        where
            showRow []                           _      = [] 
            showRow (c1:c2:c3:c4:c5:c6:c7:c8:cs) (k:ks) = 
                k:' ':c1:' ':c2:' ':c3:' ':c4:' ':c5:' ':c6:' ':c7:' ':c8:'\n':(showRow cs ks)
            toChar E = '.'
            toChar W = '0'
            toChar B = '*'

--- create board with updated cells
updateBoard (Board cells) cell updatedCells =
    Board (update cells 0 (sort updatedCells))
    where
        update []     _    _                  = []
        update cs     _    []                 = cs
        update (c:cs) indx (i:is) | i == indx = cell : update cs (indx+1) is
                                  | otherwise = c : update cs (indx+1) (i:is) 
--- check whether index in correct range 
isValidIndex n = 0 <= n && n <= 63

-- get cells acording specified indices
toCells (Board cells) = map (cells !!) 

--- convert position to index 
toIndex (row, cell) | 0 <= row && row <=7 && 0 <= cell && cell <= 7 = row * 8 + cell
                    | otherwise                                     = -1

-- get cell' indices taken after move at specified position
takenCells board color n | color /= E && isValidIndex n = 
    takenCells' (concat (map openedCells [[n,n-1..l],  [n..r],
                                          [n,n-8..u],  [n,n+8..d],
                                          [n,n-9..lu], [n,n+9..rd],
                                          [n,n-7..ru], [n,n+7..ld]])) 
    where
        takenCells' [] = []
        takenCells' ns = n : ns

        openedCells ns | length ns < 3 = [] 
                       | otherwise     = take (countOpened (toCells board ns)) (tail ns)

        countOpened (E:cs) = countOpened' (partition (==(inverse color)) cs)
        countOpened _      = 0
        
        countOpened' (ns, rs) | rs == [] || (head rs) == E = 0
                              | otherwise                  = length ns
                
        (row, cell) = (div n 8, mod n 8)
        (l, r) = (row * 8, row * 8 + 7)
        (u, d) = (cell, cell + 56)
        (lu, rd) = let k = row - cell in if (k < 0) then (-k, k * 8 + 63) else (k * 8, -k + 63)
        (ru, ld) = let k = row + cell in if (k < 7) then (k, k * 8) else (k * 8 - 49, -k + 56) 

---------------------
--- Game engine
---------------------

type Position = (Int, Int) 
     
type Player = Board -> IO Position 
 
data Game = Game { board :: Board,  
                   whitePlayer :: Player, 
                   blackPlayer :: Player,
                   color :: Cell,
                   finished :: Bool }
--- start new game 
mkGame whitePlayer blackPlayer = Game (Board [E,E,E,E,E,E,E,E, 
                                              E,E,E,E,E,E,E,E,
                                              E,E,E,E,E,E,E,E,
                                              E,E,E,B,W,E,E,E,
                                              E,E,E,W,B,E,E,E,
                                              E,E,E,E,E,E,E,E,
                                              E,E,E,E,E,E,E,E,
                                              E,E,E,E,E,E,E,E])
                                       whitePlayer
                                       blackPlayer
                                       W
                                       False
--- get player move
makeMove game@(Game board _ _ _ _) = 
    (currentPlayer game) board
    where 
        currentPlayer (Game _ wPlayer _       W _) = wPlayer
        currentPlayer (Game _ _       bPlayer B _) = bPlayer
    
--- check whether current and next players have moves
hasMoves (Game board _ _ color _) =
    (hasMoves' color, hasMoves' (inverse color))
    where  
        hasMoves' color = []/= filter (([]/=).(takenCells board color)) [n | n<-[0..63]]
        
--- play one move   
play :: Game -> Game                                       
play game@(Game board wPlayer bPlayer color finished) =
    play' (hasMoves game)
    where
        play' :: (Bool, Bool) -> Game
        play' (True, _)  = (makeMove game) >>= updateGame -- apply move     <---- !ОТВАЛИВАЕТСЯ В ЭТОЙ СТРОЧКЕ
        play' (_, True)  = play game { color = (inverse color) } -- skip move   
        play' (_, False) = game { finished = True } -- game finished
        
        affectedCells = takenCells board color

        isLegalMove m = isValidIndex m && [] /= affectedCells m
        
        updateGame :: Position -> Game
        updateGame p = updateGame' (toIndex p)
        updateGame' m | isLegalMove m =  game { board = updateBoard board color (affectedCells m),
                                                color = inverse color }
                      | otherwise     =  play game -- retry move                  

--- play before game over
playLoop game = 
    do
        print (board game)
        playLoop' (play game) 
    where 
        playLoop' g@(Game _ _ _ _ False) = playLoop g
        playLoop' g@(Game _ _ _ _ True) = print "Game over."
                    
---------------------
--- Players 
---------------------

human :: Cell -> Player
human color board =
    do 
        case color of 
           W -> print "White:"
           B -> print "Black:"
           
        input <- getLine
        
        return ((parse (head input)), (parse (head (tail input))))
    where
        parse x | 'a' <= x && x <= 'h' = ord x - ord 'a'
                | '1' <= x && x <= '8' = ord x - ord '1'
                | otherwise            = -1
             
main = playLoop (mkGame (human W) (human B))

NGG>Main.hs:117:47:
NGG>    Couldn't match expected type `IO b' against inferred type `Game'
NGG>      Expected type: Position -> IO b
NGG>      Inferred type: Position -> Game
NGG>    In the second argument of `(>>=)', namely `updateGame'
NGG>    In the expression: (makeMove game) >>= updateGame
NGG>

NGG>Может есть линка "для дураков", где даны "решения" подробных проблем? Или на халяву не получится проскачить эту тему и придётся разбираться-таки с монадами по-честному?

(>>=) :: Monad m => m a -> (a -> m b) -> m b
-- в нашем случае монада - это IO, то есть
(>>=) :: IO a -> (a -> IO b) -> IO b