- 1
- 2
- 3
- 4
- 5
- 6
- 7
- 8
- 9
- 10
- 11
- 12
- 13
- 14
- 15
- 16
- 17
- 18
- 19
- 20
- 21
- 22
- 23
- 24
- 25
- 26
- 27
- 28
- 29
- 30
- 31
- 32
- 33
- 34
- 35
- 36
- 37
- 38
- 39
- 40
- 41
- 42
- 43
- 44
- 45
- 46
- 47
- 48
- 49
- 50
- 51
- 52
- 53
- 54
- 55
- 56
- 57
- 58
- 59
- 60
- 61
- 62
- 63
- 64
- 65
- 66
- 67
- 68
- 69
- 70
- 71
- 72
- 73
- 74
- 75
- 76
- 77
- 78
- 79
- 80
- 81
- 82
{-# LANGUAGE FlexibleInstances #-}
module Connect where
import Data.List
data Color = Black | White deriving (Show, Eq)
data Start = Begin | End deriving (Show, Eq)
data Tree a = Node a [Tree a] deriving (Eq)
instance Show (Tree (Int,Int)) where
show = showTree 0
showTree :: Int -> Tree (Int,Int) -> String
showTree n (Node a s) = show a ++ "\n" ++ replicate n ' ' ++ concatMap (showTree (n+1)) s
elemTree :: Eq a => a -> Tree a -> Bool
elemTree e (Node a []) = if a == e then True else False
elemTree e (Node a s) = if a == e then True else any (e `elemTree`) s
resultFor :: [String] -> Maybe Color
resultFor = check
charToColor :: Char -> Color
charToColor 'X' = Black
charToColor 'O' = White
charToColor _ = error "Bad data!"
check :: [[Char]] -> Maybe Color
check s = if (null iob || null ioe) && (null ixb || null ixe)
then Nothing
else let whb = any (\t -> any (`elemTree` t) ioe) $ map (go White Begin s []) iob
whe = any (\t -> any (`elemTree` t) iob) $ map (go White End s []) ioe
blb = any (\t -> any (`elemTree` t) ixe) $ map (go Black Begin s []) ixb
ble = any (\t -> any (`elemTree` t) ixb) $ map (go Black End s []) ixe
in if whb || whe then Just White else if blb || ble then Just Black else Nothing
where
iob = map (\y -> (0,y)) $ elemIndices 'O' (s !! 0)
ioe = map (\y -> (length s,y)) $ elemIndices 'O' (last s)
ixb = map (\x -> (x,0)) $ elemIndices 'X' (map head s)
ixe = map (\x -> (x,length (s!!0))) $ elemIndices 'X' (map last s)
search :: Foldable t =>
Color
-> [[Char]] -> t (Int, Int) -> (Int, Int) -> Maybe [(Int, Int)]
search color arr from (cx, cy) = (\x -> if null x then Nothing else Just x) $ map fst $ filter snd $ concatMap
(\x -> map
(\y -> testCell color arr from (cx, cy) (x,y))
(filter (\yy -> yy >= 0 && yy < length (arr!!0)) [cy-1, cy, cy+1]))
(filter (\xx -> xx >= 0 && xx < length arr) [cx-1,cx,cx+1])
testCell :: Foldable t =>
Color
-> [[Char]]
-> t (Int, Int)
-> (Int, Int)
-> (Int, Int)
-> ((Int, Int), Bool)
testCell color arr from (cx, cy) (x,y)
|x == cx && y == cy = ((x,y),False)
|cx - x == 1 && cy - y == 1 = ((x,y),False)
|x - cx == 1 && y - cy == 1 = ((x,y),False)
|(x,y) `elem` from = ((x,y),False)
|arr !! x !! y /= '.' && color == charToColor (arr !! x !! y) = ((x,y),True)
|otherwise = ((x,y),False)
go :: Color
-> Start
-> [[Char]]
-> [(Int, Int)]
-> (Int, Int)
-> Tree (Int, Int)
go c s arr from (x,y)
|(c,s) == (White, Begin) && x == length arr - 1 = Node (x,y) []
|(c,s) == (White, End) && x == 0 = Node (x,y) []
|(c,s) == (Black, Begin) && y == length (arr !! 0) -1 = Node (x,y) []
|(c,s) == (Black, End) && y == 0 = Node (x,y) []
|otherwise = let f = search c arr from (x,y)
in case f of
Nothing -> Node (x,y) []
Just r -> Node (x,y) $ map (go c s arr ((x,y):from)) r
