После этого тема была вытащена на Хабр и образцово отхабрена.
Так как весь базар-вокзал - про 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
(Спасибо
Вот. С монадными трансформерами, как у
Мораль придумайте сами.