Алгоритм Крускала для невзвешенного графа на haskell

Очередная задачка от 1HaskellADay. В условии задан список ребер графа. Многие пути вдоль ребер предположительно зациклены, то есть если есть два пути от a к b и от b к c, то, возможно, в списке присутствует также путь от a к c; сюда же относятся вырожденные циклы, когда имеется несколько путей от a к b, либо имеются обратные пути от b к a. Целью задачи является удаление лишних (redundant) ребер графа, которые приводят к появлению циклов. Очевидно, разрешение цикла всегда связано с удалением произвольного ребра: скажем, в случае цикла (a, b, c) его разрешением может стать удаление любого из трех ребер (a, b), (b, c) и (a, c). Алгоритм Крускала находит минимальное остовное дерево (minimum spanning tree) для взвешенного неориентированного графа. Давайте предположим, что нам неважны направления ребер. В этом случае, принимая во внимание, что невзвешенный граф — это частный случай взвешенного, а дерево — это связный ациклический граф, алгоритм Крускала идеально подходит для решения нашей задачи. Напомню его суть. В случае взвешенного графа все ребра предварительно сортируются по весу (этот шаг гарантирует построение минимального дерева). Затем проходом по всем ребрам строится лес, постепенно объединяющийся в единое дерево, либо в список крупных деревьев, если исходный граф несвязан. В процессе прохода может оказаться, что очередное ребро сформирует цикл — в этом случае оно просто отбрасывается. Как определить, что ребро может сформировать цикл? Перед началом прохода все вершины (vertices) графа заносятся в специальную структуру, которая называется disjoint set. Эта структура представляет собой один или более наборов чисел, каждый из которых имеет своего представителя (representative) — это число, которое является меткой набора. На старте алгоритма все вершины разъединены и, составляя отдельные наборы, выставляют в качестве представителя самих себя. В процессе прохода по всем ребрам отдельные наборы будут объединяться, выбирая в качестве представителя одну из вершин в объединенном наборе. Соответственно, если в процессе прохода обеим вершинам очередного ребра соответствует один и тот же представитель, то это ребро отбрасывается, иначе обе вершины объединяются. Структура disjoint set гарантирует, что если одна из вершин уже была объединена в некоторый набор, то в случае ее объединения с другой вершиной, эта другая вершина вместе с набором, к которому она относится, объединится с первым набором, возможно сформировав нового представителя. Так постепенно формируется единый набор вершин (или несколько крупных). Алгоритм для работы с disjoint set часто называют union-find. Он гарантирует константное время объединения и поиска представителя. Я не собираюсь его здесь реализовывать, а лучше возьму одну из многочисленных существующих реализаций для языка haskell: Data.UnionFind.IO. Представленная в этом модуле реализация disjoint set не поддерживает поиск представителя для произвольного числа: только числа, уже добавленные в набор, корректно возвращают своего представителя. Поскольку мы добавляем все вершины в набор на старте, нам достаточно создать Map, ключами которого будут числа-вершины, а значениями — представления этих чисел в наборе disjoint set. Таким образом, мы сможем находить представителей вершин в процессе прохода по ребрам графа за логарифмическое время. Учитывая линейность прохода по ребрам, общий класс алгоритма должен соответствовать $O(n\log{}m)$, где n — число ребер исходного графа, а m — число вершин. Вот исходный код функции deredundancify, которая из исходного списка ребер строит список всех вершин графа и остовное дерево.

deredundancify :: [Edge] -> IO ([Vertex], [Edge])
deredundancify es = do
    let vs = map head . group . sort $ foldr (\(a, b) c -> a : b : c) [] es
    ps <- mapM fresh vs
    m  <- liftM M.fromList $ mapM (\a -> do b <- descriptor a; return (b, a)) ps
    let testNotCycle (a, b) = do
            let pa = fromJust $ M.lookup a m
                pb = fromJust $ M.lookup b m
            da <- descriptor pa
            db <- descriptor pb
            if da == db
                then return False
                else do
                    pa `union` pb
                    return True
    rs <- filterM testNotCycle es
    return (vs, rs)

Для того, чтобы все скомпилировалось, перед определением функции нужно добавить импорт некоторых модулей и определить синонимы типов Vertex и Edge.

import            Control.Monad               (liftM, filterM)
import            Data.List                   (sort, group)
import qualified  Data.Map                    as M
import            Data.UnionFind.IO
import            Data.Maybe                  (fromJust)

type Vertex = Int
type Edge   = (Int, Int)

Внутри функции deredundancify сначала строится список вершин vs, затем все вершины заносятся в структуру ps с помощью функции fresh из модуля Data.UnionFind.IO. Затем строится Map m, ключами которого являются представители (descriptor) исходного набора ps (которые вначале должны просто соответствовать вершинам vs), а значениями — исходные наборы из ps. Основная работа функции deredundancify заключается в формировании списка ребер rs, который будет соответствовать искомому остовному дереву. Список rs строится за счет применения фильтра testNotCycle к исходному списку ребер es. Фильтр testNotCycle ищет наборы pa и pb внутри m, получает их дескрипторы da и db и сравнивает их. Если дескрипторы равны, то данное ребро отбрасывается (функция возвращает False), иначе — pa и pb объединяются (union) и данное ребро заносится в список для остовного дерева (функция возвращает True). Собственно, это и есть решение задачи. Но давайте подумаем, как мы его проверим. Из большого списка ребер мы получим список чуть поменьше. И что нам с ним делать? Нужна какая-то визуализация. Очевидное решение — использовать GraphViz. В haskell есть байндинг для GraphViz. Давайте напишем функцию, которая будет выводить текст в формате dot, который GraphViz сможет использовать для изображения графов. Прежде всего, подключим модули GraphViz.

import            Data.Graph.Inductive        hiding (Edge)
import            Data.GraphViz
import            Data.GraphViz.Attributes
import            Data.GraphViz.Printing      (renderDot)
import            Data.Text.Lazy              (Text, unpack, pack)
import            System.Environment          (getArgs)

Последний импорт понадобится в функции main для парсинга аргументов командной строки. Вот функция mkDot.

mkDot :: [Vertex] -> [Edge] -> [GlobalAttributes] -> DotGraph Node
mkDot vs es attrs =
    let lvs = map (\a -> (a, pack $ show a)) vs
        les = map (\(a, b) -> (a, b, ())) es
        gr  = mkGraph lvs les :: Gr Text ()
    in graphToDot nonClusteredParams {globalAttributes = attrs} gr

Она принимает список вершин, список ребер и атрибуты GraphViz и возвращает промежуточное представление для данных dot. Давайте напишем функцию main, которая сможет выводить данные dot на экран.

main = do
    args     <- getArgs
    (vs, rs) <- deredundancify theGraph
    let attrs = [EdgeAttrs
                    [edgeEnds $ if "-l" `elem` args then NoDir else Forward]]
        dot   = mkDot vs (if "-o" `elem` args then theGraph else rs) attrs
    putStrLn $ unpack $ renderDot $ toDot dot

Теперь, после компиляции исходного кода, предварительно включив в него список ребер исходного графа theGraph, можно вывести исходный граф и искомое остовное дерево на картинку. Получение картинки исходного графа.

./deredundancify -o | dot -Tpng > original.png

Получение картинки остовного дерева исходного графа.

./deredundancify | dot -Tpng > deredundancified.png

Картинки для исходного дерева, представленного в оригинальном примере, получаются очень большими, поэтому я их положил на Google Drive: исходный граф, остовное дерево. Посмотрите и сравните: по картинкам становится понятно, что такое большое остовное дерево. Кстати, на выложенных картинках все ребра направлены, но по условиям нашей задачи граф неориентирован, поэтому по-хорошему стрелки на ребрах должны отсутствовать. Не проблема, если хотите картинки без стрелок — используйте опцию -l при вызове deredundancify. Исходный код решения задачи можно загрузить отсюда или отсюда. Update. Как обычно, ряд улучшений в исходном коде уже после публикации статьи. Все они касаются функции deredundancify. Во-первых, создание структуры ps для uninon-find и ассоциативного массива m можно объединить. Это потому, что вначале все наборы внутри ps состоят из отдельных вершин и их представителями являются собственно сами эти вершины. Во-вторых, я предпочитаю избегать конструкцию if-then-else в haskell. В данном случае в функции testNotCycle вместо нее можно определить логическую константу, применив оператор liftM2 (==) или liftM2 (/=) к значениям представителей вершин ребра, а необходимость объединения вершин определять с помощью функции when из модуля Control.Monad. Функция liftM2 определена в этом же модуле. Чтобы не плодить список импортированных из него функций, лучше переписать его импорт как

import            Control.Monad

В-третьих, поиск внутри m можно переписать в стрелочном стиле. Для этого нужно включить еще один импорт.

import            Control.Arrow

Я писал про стрелки в haskell в предыдущей статье. Теперь функция deredundancify выглядит так.

deredundancify :: [Edge] -> IO ([Vertex], [Edge])
deredundancify es = do
    let vs = map head . group . sort $ foldr (\(a, b) c -> a : b : c) [] es
    m  <- liftM M.fromList $ mapM (\v -> do p <- fresh v; return (v, p)) vs
    let testNotCycle e = do
            let ve = both (fromJust . flip M.lookup m) e
            notCycle <- uncurry (liftM2 (/=)) $ both descriptor ve
            when notCycle $ uncurry union ve
            return notCycle
            where both = join (***)
    rs <- filterM testNotCycle es
    return (vs, rs)

Я заменил запись аргумента функции testNotCycle (a, b) на e, поскольку стрелочная нотация прекрасно работает с кортежами и в ней не требуется знать его (кортежа) отдельные элементы. Функция both заворачивает стрелочный комбинатор (***) в функцию join из модуля Control.Monad, таким образом применяя свой аргумент-функцию к обоим элементам кортежа. И еще одна техника, которая позволит переписать монадные вычисления внутри отображения mapM при вычислении m в бесточечном стиле. Это стрелки Клейсли. Они импортируются из модуля Control.Arrow по умолчанию. Основная идея заключается в оборачивании всех функции, возвращающих монадные значения в тип Kleisli, а само монадное вычисление — в конструктор runKleisli, который возвращает монадный тип из комбинации стрелок.

m  <- liftM M.fromList $ mapM (runKleisli $ arr id &&& Kleisli fresh) vs

Здесь из функции id создается обычная стрелка с помощью явного конструктора arr. Несмотря на то, что функции являются стрелками, и мы ни разу до этого не использовали явные конструкторы стрелок в отношении функций, в данном случае без них не обойтись — ghc откажется компилировать код. Другая стрелка — стрелка Клейсли — создается из функции fresh, возвращающей монадное значение IO (Point a). Обе стрелки комбинируются стрелочным комбинатором (&&&). На выходе runKleisli получаем монадное вычисление пары (входное значение (то есть вершина), элемент структуры union-find). Не думаю, что новое тело функции deredundancify понятней, чем предыдущее (скорее наоборот), зато оно явно лаконичней. Ну и напоследок упражнение: записать тело функции правой свертки (\(a, b) c -> a : b : c), которую мы использовали для получения списка всех вершин графа, в бесточечном стиле с помощью стрелок. Причем с сохранением семантики и эффективности: то есть числа a и b должны стыковаться со списком c в заданном порядке, а конструкторы списка (:) нельзя заменять на операции конкатенации (++). Я напишу ответ, но не стану его объяснять.

curry $ fst . fst &&& uncurry ((:) . snd) >>> uncurry (:)

А это бесточечное решение без использования стрелок, тоже без объяснения.

let (<:) = flip (:) in flip $ uncurry . flip . ((<:) .) . (<:)

Update 2. Я все-таки решил привести здесь уменьшенные варианты изображений оригинального графа и его осто́вного дерева в дополнение к приведенным выше ссылкам на большие изображения, которые оказались настолько большими, что вставлять их в статью было бы просто безумием. Новые изображения обязаны своей компактностью выбору движка для рендеринга sfdp вместо стандартного dot, отказу от прорисовки форм вершин графа (вернее, теперь это форма point) и их идентификаторов, а также выбору полупрозрачных цветов для ребер и вершин. Чтобы достичь этого, мне пришлось внести небольшие дополнения в исходный код программы. Итак, изображение исходного графа без идентификаторов вершин, полученное как

./deredundancify -o -t | sfdp -Tpng > original_tiny.png

А это осто́вное дерево, полученное как

./deredundancify -t | sfdp -Tpng > deredundancified_tiny.png

На первой картинке много синих линий-ребер, на второй их практически не видно, зато красные кружки́-вершины связаны в более длинные цепочки. Все это выглядит здо́рово и весьма достоверно.