Кто про что, а я про двудольные графы

import qualified Data.Map as M
import Data.Array
import Control.Monad.State

type Graph = Array Int [Int]

data Color = Red | Blue deriving Eq

isBipartite graph = run $ do

  -- Проверяем, получилось ли "двудольно" раскрасить все компоненты связности графа.
  -- Чтобы не реализовывать отдельно вычисление связных компонет, тупо пытаемся
  -- начать красить со всех узлов подряд - так ни одна компонента связности никуда от
  -- нас не денется
  allTrue [ paint True node Red | node <- indices graph ]
  where

    -- Пытаемся покрасить узел `node' цветом `color'. Если isSeed == True, то мы
    -- пытаемся начать красить одну из компонент связности графа. Если False - то мы
    -- уже вовсю ее красим.
    paint isSeed node color = do

      -- Каков текущий цвет этого узла?
      current <- gets (M.lookup node)
      case current of

        -- Если узел еще не крашен - красим его цветом `color', а все связанные с ним
        -- узлы красим цветом, отличным от `color'. Проверяем, получилось ли раскрасить
        -- без конфликтов.
        Nothing -> do modify (M.insert node color)
                      allTrue [ paint False edge (swap color) | edge <- graph!node ]

        -- Если узел уже покрашен, а мы пытались начать с него раскраску - пропускаем его
        -- Если же нам встретился покрашеный узел в ходе обхода компоненты связности, 
        -- проверим, нет ли конфликта в раскраске
        Just someColor -> if isSeed then return True
                                    else return (color == someColor)

    swap Red  = Blue
    swap Blue = Red

    -- Кому надо, тот и так понял, что тут написано, а остальные над этим не рефлексируют :)
    run = flip evalState M.empty
    allTrue actions = sequence actions >>= return . and

-- Ну, и пару тестов
bipartite = 
  array (0,8) [(0,[1]),(1,[0,2,8]),(2,[1,3]),(3,[2,6]),(4,[5,7]),(5,[4]),(6,[3]),(7,[4,8]),(8,[1,7])]
                
not_bipartite = 
  array (0,8) [(0,[1,2]),(1,[0,2,8]),(2,[1,3]),(3,[2,6]),(4,[5,7]),(5,[4]),(6,[3]),(7,[4,8]),(8,[1,7])]

main = do
  print $ isBipartite bipartite
  print $ isBipartite not_bipartite

import Data.Map hiding (map)
import Data.Graph.Inductive hiding (empty)

-- Граф двудольный, если после покраски концы всех ребер имеют разные цвета
isBipartite g = all (differentEndColors) (edges g)
  where
    -- Цвет узла хранится в ассоциативном массиве `coloring'
    differentEndColors (n1,n2) = coloring!n1 /= coloring!n2

    {-
     Этот массив создается из списка [(Node, Color)], где Color -
     это Bool. 
     Список получается так: сначала определяем, на каком
     "уровне" (в дереве поиска в ширину) находится тот или иной
     узел, затем превращаем номер уровня в цвет.
    -}
    coloring = fromList $ map level2color nodes2levels

    {-
     Чтобы определить, на каком уровне находится тот или иной узел:
     1)Разбиваем граф на компоненты связности (components)
     2)Берем первую вершину из каждой компоненты (head) и назначаем ей уровень 0
     3)Получившийся список стартовых вершин засовываем в библиотечную функцию `leveln',
       которая вычисляет уровень всех остальных узлов графа
     В результате получаем список [(узел, уровень)]
    -}
    nodes2levels = leveln (zip (map head $ components g) (repeat 0)) g

    -- Если уровень нечетный - будет цвет True, иначе - False
    level2color (node,lvl) = (node, odd lvl)

-- Перевод графа в вид, нужный для библиотеки
-- Data.Graph.Inductive
makeGraph :: [(Int,[Int])] -> Gr () ()
makeGraph g = mkUGraph vs es
  where vs = map fst g
        es = [(n1,n2) |  (n1,es) <- g, n2 <- es]

-- Ну, и пару тестов
bipartite = 
  [(0,[1]),(1,[0,2,8]),(2,[1,3]),(3,[2,6]),(4,[5,7]),(5,[4]),(6,[3]),(7,[4,8]),(8,[1,7])]
                
not_bipartite = 
  [(0,[1,2]),(1,[0,2,8]),(2,[1,3]),(3,[2,6]),(4,[5,7]),(5,[4]),(6,[3]),(7,[4,8]),(8,[1,7])]

main = do
  print $ isBipartite $ makeGraph bipartite
  print $ isBipartite $ makeGraph not_bipartite