День добрый, уважаемые.

После ветки "В чём выгода от функциональных языков?" решил написать моЩную программку, а именно реверси с графическим интерфейсов и АИ. Но путь к большому открывается через малое, поэтому пока наборосал конольный вариант для игры сам-с-собой.

Хотелось бы услышать сторонее мнение относительно "качества" кода. Что можно сделать лучше, а что ещё лучше? В какую сторону копать
С удовольствием приму ссылки на исходники программ на хаскел, которые можно принять за "идеал" красоты кода.

Собственно код:

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