Dmitry Astapov (_adept_) wrote,
Dmitry Astapov
_adept_

Categories:

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

Надысь один мой френд написал пост про проверку двудольности графа на Haskell. После чего другой мой френд взял его код и откомментировал. После чего третий мой френд разразился язвительным постом-комментарием на эту тему (именно в комментариях к этому посту есть эпический тред про вывод типов в PHP и иже с ними).

После этого тема была вытащена на Хабр и образцово отхабрена.

Так как весь базар-вокзал - про Haskell, я тоже хочу добавить пару слов.

Я не буду комментировать все, что написано, я скажу про сам алгоритм. Если б мне пришлось бы его реализовывать на Haskell, то я либо нашел бы чужой исходник и перелицевал бы его прачтически дословно. И у меня получилось бы что-то такое (т.к. исходник был бы наверняка на каком-то императивном языке):


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



(Спасибо lomeo за ценные комментарии и идею поста)

Вот. С монадными трансформерами, как у antilamer - тоже можно, просто я так не пишу.

Мораль придумайте сами.
Tags: haskell
Subscribe

  • Post a new comment

    Error

    default userpic

    Your IP address will be recorded 

    When you submit the form an invisible reCAPTCHA check will be performed.
    You must follow the Privacy Policy and Google Terms of use.
  • 33 comments