Kruskal's Algorithm in Haskell?

A place to discuss the implementation and style of computer programs.

Moderators: phlip, Moderators General, Prelates

bieber
Posts: 223
Joined: Thu Mar 13, 2008 12:13 am UTC

Kruskal's Algorithm in Haskell?

Postby bieber » Sat Oct 10, 2009 7:18 am UTC

I've started learning Haskell, and I feel like I'm beginning to get the concepts behind functional programming, so I decided to play around with it a little before I moved on (right now I know the basics of defining functions with pattern matching, list comprehensions, and working with basic data types, lists and tuples). I figured a good exercise would be trying to implement Kruskal's algorithm with it, since we were just going over how to implement it (in an imperative language, of course) in Comp Sci today.

So I set about doing it, and at first I figured there should be a way to do it all with a single elegant list comprehension...but I couldn't quite make that work, so I just went for a straight-forward recursive definition that I think should work, except that it's dependent on a function that determines whether or not adding an edge to the MST will form a circuit, which is in turn dependent on a function that determines the parent of a node in a tree graph, that I can't quite seem to make work right. In class we were told to use disjoint sets to keep track of the parents of all the nodes as we went along, which works great, but I can't seem to reconcile it with the functional paradigm, since it's a strictly imperative technique that uses arrays.

Rambling aside, I was wondering if anyone has any suggestion as to how I could most efficiently implement the parent and loop functions, or just replace them altogether with some more clever technique. Do I just need to break down and make the whole thing iterative? Do most algorithms just not adapt well? Here's the mess of code I've thrown together so far, if anyone feels like figuring out how I could fix it (I realize at the moment that my parent implementation isn't working because the graph is undirected, but I haven't quite figured out how to make it work)

Code: Select all

--A QuickSort implementation to sort the edges used initially

qs :: Ord b => (a -> b) -> [a] -> [a]

qs _ [] = []
qs eval (pivot: rest) = qs eval left ++ (pivot : qs eval right)
    where
    left = [x | x <- rest, (eval x) < (eval pivot)]
    right = [x | x <- rest, (eval x) >= (eval pivot)]
   
--A graph is a list of three-tuples, formatted as:
--(begin, end, weight) :: (Char, Char, Int)

--Here's a simple graph to test the algorithm with
testGraph :: [(Char, Char, Int)]
testGraph = [('a', 'b', 8), ('a', 'c', 1), ('a', 'd', 6),
             ('b', 'c', 4), ('b', 'd', 2),
             ('c', 'd', 3), ('c', 'e', 1),
             ('d', 'e', 9)]

--Kruskal's MST algorithm

--The base function calls the recursive function with the graph's edges sorted
--in descending order by edge weight, so the first recursive calls that actually
--get considered are those with the lowest edge weights
mst :: [(Char, Char, Int)] -> [(Char, Char, Int)]
mst x = mstRec (qs (\(x, y, z) -> -z) x)

mstRec :: [(Char, Char, Int)] -> [(Char, Char, Int)]

--MST for an empty graph is an empty graph
mstRec [] = []

--The head of the list will always be the worst-case weighted edge.  If adding
--the worst possible edge wouldn't produce a loop in the graph when added to the
--MST one iteration before, then we add it to the end of the MST one iteration
--before this one
mstRec (worst: rest)
    | not(loops worst (mstRec rest)) = mstRec rest ++ [worst]
    | otherwise = mstRec rest

--Determines whether adding an edge to a graph will produce a loop
loops :: (Char, Char, Int) -> [(Char, Char, Int)] -> Bool
loops _ [] = False

--Determines the ultimate parent of a graph node on an MST
parent :: Char -> [(Char, Char, Int)] -> Char
parent node graph
    | length findParent == 0 = node
    | otherwise = parent (findParent !! 0) graph
    where
    bySource=[y | (x, y, z) <- graph, x==node]
    byDest=[x | (x, y, z) <- graph, y==node]   
    findParent
        | not(length bySource == 0) = bySource
        | not(length byDest == 0) = byDest
        | otherwise = []

dosboot
Posts: 143
Joined: Sun Jul 01, 2007 5:26 am UTC

Re: Kruskal's Algorithm in Haskell?

Postby dosboot » Mon Oct 12, 2009 8:14 am UTC

If this is correct then I'm pleased:

Code: Select all

{-
http://en.wikipedia.org/wiki/Kruskal%27s_algorithm

    * create a forest F (a set of trees), where each vertex in the graph is a separate tree
    * create a set S containing all the edges in the graph
    * while S is nonempty
          o remove an edge with minimum weight from S
          o if that edge connects two different trees, then add it to the forest, combining two trees into a single tree
          o otherwise discard that edge.
-}

import Data.List

adjacent :: e -> e -> Bool
adjacent = undefined

--adds edge 'e' to forest 'ts' ("trees") as per description
f :: [[e]] -> e -> [[e]]
f ts e =
    let (ts1,ts2) = partition (any $ adjacent e) ts
        forms_cycle es = (==2) . length $ filter (adjacent e) es
    in case ts1 of
         [t1,t2] -> (e:t1 ++ t2) : ts2             --e bridges two non-singleton trees
         [] -> [e] : ts2                           --e bridges two singleton trees
         [t] -> if (forms_cycle t) then t : ts2 else (e:t) : ts2  --e adjacent to exactly one tree

--takes a list of all edges sorted by weight, minimum weight first, and returns a minimum spanning forest
kruskal :: [e] -> [e]
kruskal [] = []
kruskal es = head $ foldl' f [] es


You are better off using the Data.List sort over writing your own. Anything that can be done imperatively can be done in Haskell to several possible degrees of imperativeness, and you'd want to implement it however would be most elegant first.

bieber
Posts: 223
Joined: Thu Mar 13, 2008 12:13 am UTC

Re: Kruskal's Algorithm in Haskell?

Postby bieber » Wed Oct 21, 2009 5:49 am UTC

Thanks for the suggestion, although I'm afraid your code is a little over my head (agh, I feel like such a n00b moving into functional programming). I finally managed to get a simple MST program working with the little knowledge I do have of Haskell, by passing states along in the recursive function, and implementing basically a disjoint sets data structure using tuples. Feel free to criticize any of the myriad stupid mistakes in style I've probably made throughout here, anyone who's interested.

Code: Select all

module Main
where

import IO
import Data.List

-- An edge is a three-tuple, source followed by dest followed by weight
data Edge = Edge String String Int

-- Functions for edges
edgeSrc :: Edge -> String
edgeSrc (Edge a _ _) = a

edgeDest :: Edge -> String
edgeDest (Edge _ b _) = b

edgeWeight :: Edge -> Int
edgeWeight (Edge _ _ c) = c

showEdge :: Edge -> String
showEdge (Edge a b c) = "Edge from " ++ (show  a) ++ " to " ++ (show b) ++
                        " with weight " ++ (show  c)
                       
ordEdge :: Edge -> Edge -> Ordering
ordEdge (Edge _ _ a) (Edge _ _ b)
    | a == b = EQ
    | a < b = LT
    | a > b = GT

-- A graph is just a list of edges
type Graph = [Edge]

showGraph :: Graph -> String
showGraph g = "Graph\n-----\n" ++ (foldl (++) "" [showEdge x ++ "\n" | x <- g])

-- The MST function
mst :: Graph -> Graph
mst g = mstRec g [] [ (x, x) | x <- (points g)]

mstRec :: Graph -> Graph -> [(String, String)] -> Graph
mstRec [] progress sets = progress
mstRec (e:es) progress sets
    | joined (edgeSrc e) (edgeDest e) sets = mstRec es progress sets
    | otherwise = mstRec es (e : progress) (join (edgeSrc e) (edgeDest e) sets)

-- Functions to operate on disjoint sets
-- A disjoint set is given as a list of pairs of Strings, the first string being
-- the point, the second string being its parent

parent :: String -> [(String, String)] -> String
parent elem sets
    |fst match == snd match = fst match
    |otherwise = parent (snd match) sets
    where
        match = head ([ (x, y) |(x, y) <- sets, x == elem])

joined :: String -> String -> [(String, String)] -> Bool
joined x y sets = (parent x sets) == (parent y sets)

join :: String -> String -> [(String, String)] -> [(String, String)]
join x y sets
    | joined x y sets = sets
    | otherwise = newY : rest
    where
        newY = (fst oldY, x)
        oldY = head [(a, b) | (a, b) <- sets, a==(parent y sets)]
        rest = [(a, b) | (a, b) <- sets, a /= (parent y sets)]
   

-- Finds all the points in a graph
points :: Graph -> [String]
points g = pointsRec g []

pointsRec :: Graph -> [String] -> [String]
pointsRec [] s = s
pointsRec (e:es) s = pointsRec es (first ++ second ++ s) where
    first
        | not(elem (edgeSrc e) s ) = [edgeSrc e]
        | otherwise = []
    second
        | edgeSrc e == edgeDest e = []
        | not(elem (edgeDest e) s) = [edgeDest e]
        | otherwise = []


main = do
    putStrLn "Enter the initial graph, by its edges"
    startGraph <- getUserGraph 'y'
    let ordGraph = Data.List.sortBy ordEdge startGraph
    putStrLn ""
    putStrLn (showGraph ordGraph)
    putStrLn "Calculating MST...\n\n"
    let finalGraph = mst ordGraph
    putStrLn (showGraph finalGraph)
   
   
-- Gets a graph from the user

getUserGraph :: Char -> IO Graph
getUserGraph cont = if cont=='y' then
    do
        putStrLn "Source: "
        src <- getLine
        putStrLn "Destination: "
        dest <- getLine
        putStrLn "Weight: "
        weight <- getLine
        putStrLn "Enter another edge? (y/n)"
        response <- getLine
        rest <- getUserGraph (head response)
        return ( [Edge src dest (read weight)] ++ rest )
    else
        return []


Return to “Coding”

Who is online

Users browsing this forum: No registered users and 10 guests