?

Log in

No account? Create an account
dump -0f - /dev/mind
Я знаю Haskell, OCaml, GSM, эндофункторы и много других страшных слов
Кто про что, а я про двудольные графы 
5th-Nov-2009 09:03 pm
Надысь один мой френд написал пост про проверку двудольности графа на 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 - тоже можно, просто я так не пишу.

Мораль придумайте сами.
Comments 
5th-Nov-2009 07:20 pm (UTC)
монады есть в используемых функциях библиотеки графов?
5th-Nov-2009 07:21 pm (UTC)
Ну, там есть подмножество API с монадными обертками, но но нужно для экзотических случаев. Так что, считаем, что их там нет.
5th-Nov-2009 07:25 pm (UTC)
Posmotrel sra4 na habre. Grustno, vzroslie dyad'ki zh vrode vse.
2 misli:
1) Zhal', 4to ne na angliyskom - dal bi studentam domashnee zadanie poyti posratsya tam.
2) 2 realizaciya concise and clean, molodec.
5th-Nov-2009 08:00 pm (UTC)
> эпический тред про вывод типов в PHP

Читал. Вызывает смех одно называние ;-)

А как сделано, понравилось.
6th-Nov-2009 01:47 am (UTC)
Ну, смех смехом, а мой знакомый прикрутил к похапе другой синтаксис и вывод типов - и так пишет уже года три. Хиндли-Милнер это десятка два строчек, если не меньше.
5th-Nov-2009 09:01 pm (UTC)
оффтопик: шрифты поплыли. Safari, Opera, IE8 на Windows - всё одно:

5th-Nov-2009 09:08 pm (UTC)
Хм. Там же стилем только цвет меняется и bold ставится.

2all: Еще кто-то такое наблюдает?
5th-Nov-2009 09:14 pm (UTC)
Пост просится к перепосту на хабр(простите за тавтологию)
5th-Nov-2009 09:20 pm (UTC)
Похоже мир сходит с ума.
То забиватор вбрасывает говно на вентилятор и потом выискивает в навозной куче жемчужины (большей частью это нифига не жемчужины...)
То "the Программист На Хаскелле" бросает штангу в оппонента на RSDN и во весь RSDN в целом.
Теперь вот полемика докатилась до хабра.

Это что, ЛОР-инфекция, я не понимаю?!
(Deleted comment)
5th-Nov-2009 09:50 pm (UTC)
Знатный butthurt
(Deleted comment)
5th-Nov-2009 10:37 pm (UTC)
О, а можно ссылку на theПрограммиста и штангу на RSDN?
6th-Nov-2009 06:19 am (UTC)
А если без монады State, то не будет ли память отжираться?
6th-Nov-2009 08:42 am (UTC)
А с чего бы? Можно взять правила desugaring-а do-нотации и совершенно механически руками расписать этот код в "обычный", без всяких следов монад. Семантика у него останется та же самамя, просто везде явным образом протащится дополнительный параметр-состояние и манипуляции им.
6th-Nov-2009 09:18 am (UTC)
Второй вариант ваще зашибись, очень красиво! Я тоже хотел заюзать fgl в надежде на что-то подобное, но я только хотел, а ты заюзал :)
This page was loaded Nov 16th 2019, 9:54 pm GMT.