Created
March 5, 2011 23:37
-
-
Save jagbolanos/856828 to your computer and use it in GitHub Desktop.
Some DFS based graph algorithms in Haskell
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
--Proposed solutions to problems 87,88 and 89 of "99 Haskell Problems" | |
--Not optimal but they work | |
--If you know haskell and want to solve some problems there are some missing at: | |
--http://www.haskell.org/haskellwiki/99_questions/80_to_89 | |
import Data.List | |
type Node = Int | |
type Edge = (Node,Node) | |
type Graph = ([Node],[Edge]) | |
depthfirst :: Graph -> Node -> [Node] | |
depthfirst (v,e) n | |
| [x|x<-v,x==n] == [] = [] | |
| otherwise = dfrecursive (v,e) [n] | |
dfrecursive :: Graph -> [Node] -> [Node] | |
dfrecursive ([],_) _ = [] | |
dfrecursive (_,_) [] = [] | |
dfrecursive (v,e) (top:stack) | |
| [x|x<-v,x==top] == [] = dfrecursive (newv, e) stack | |
| otherwise = top : dfrecursive (newv, e) (adjacent ++ stack) | |
where | |
adjacent = [x | (x,y)<-e,y==top] ++ [x | (y,x)<-e,y==top] | |
newv = [x|x<-v,x/=top] | |
connectedcomponents :: Graph -> [[Node]] | |
connectedcomponents ([],_) = [] | |
connectedcomponents (top:v,e) | |
| remaining == [] = [connected] | |
| otherwise = connected : connectedcomponents (remaining, e) | |
where | |
connected = depthfirst (top:v,e) top | |
remaining = (top:v) \\ connected | |
dfsbipartite :: Graph -> [(Node, Int)] -> [Node] -> [Node] -> Bool | |
dfsbipartite ([],_) _ _ _ = True | |
dfsbipartite (_,_) [] _ _ = True | |
dfsbipartite (v,e) ((nv, 0):stack) odd even | |
| [x|x<-v,x==nv] == [] = dfsbipartite (v, e) stack odd even | |
| [] == intersect adjacent even = dfsbipartite (newv, e) ([(x,1)|x<-adjacent] ++ stack) odd (nv : even) | |
| otherwise = False | |
where | |
adjacent = [x | (x,y)<-e,y==nv] ++ [x | (y,x)<-e,y==nv] | |
newv = [x|x<-v,x/=nv] | |
dfsbipartite (v,e) ((nv, 1):stack) odd even | |
| [x|x<-v,x==nv] == [] = dfsbipartite (v, e) stack odd even | |
| [] == intersect adjacent odd = dfsbipartite (newv, e) ([(x,0)|x<-adjacent] ++ stack) (nv : odd) even | |
| otherwise = False | |
where | |
adjacent = [x | (x,y)<-e,y==nv] ++ [x | (y,x)<-e,y==nv] | |
newv = [x|x<-v,x/=nv] | |
bipartite :: Graph -> Bool | |
bipartite ([],_) = True | |
bipartite (top:v,e) = dfsbipartite (top:v, e) [(top,0)] [] [] |
You can also instrument your code, to see the intermediate data structures using the Hackage package hood.
{-# LANGUAGE NoMonomorphismRestriction #-}
-- Fold Behaviour Observed
module Folding where
-- See Hood on Hackage
import Observe
import Data.List
n = 10::Int
fr = foldr (observe "Add" (+)) 0 [1..n]
fl = foldl (observe "Add" (+)) 0 [1..n]
frr = foldr (observe "Add" (+)) 0 (reverse [1..n])
flr = foldl (observe "Add" (+)) 0 (reverse [1..n])
fro = printO fr
flo = printO fl
frro = printO frr
flro = printO flr
fl' = foldl' (observe "Add" (+)) 0 [1..n]
flr' = foldl' (observe "Add" (+)) 0 (reverse [1..n])
flo' = printO fl'
flro' = printO flr'
By the way, I always tend to think of appending as O(n^2) but pre-pending short lists is O(n) in the length of the short list. It's always post-pending that is O(n^2). And; if it's postage-pending then it's even slower. :)
As Randy Pausch would have said, "That was pretty good but I know you can do better." :)
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
You can put your code into a timing harness, for example:
module Main where
import Data.Time.Clock (diffUTCTime, getCurrentTime)
import System.Environment (getArgs)
import System.Exit (exitFailure)
-- Module/Program to be timed.
import TheSmallestFreeNumber
main = do
a <- timed "minfreeAA" (minfreeAA testlist)
b <- timed "minfreeMD" (minfreeMD testlist)
c <- timed "minfreeDC" (minfreeDC testlist)
-- From "Real World Haskell" Chapter 26
timed :: String -> a -> IO a
timed desc act = do
start <- getCurrentTime
end <- act
seq
getCurrentTimeputStrLn $ show (diffUTCTime end start) ++ " to " ++ desc
return act