basic functions to work with graphs in haskell

graphs_example.hs

-- see videos https://www.youtube.com/watch?v=UM0sggwLXk4&t=974s
-- https://www.youtube.com/watch?v=RS7eIkETdIQ
-- https://www.youtube.com/watch?v=UM0sggwLXk4&t=974s

import Control.Monad
import Data.List
import Data.Maybe
data Uedge a = Ue (a,a) deriving Show

(<->) a b = Ue (a,b)

instance Eq a => Eq (Uedge a) where
  (==) (Ue (a,b)) (Ue (a1,b1)) = (a == a1 &&  b==b1 ) || (a==b1 && b==a1)

data Graph a = G [Uedge a] deriving Show

g = G [Ue ('a','b'), Ue ('b','c') , Ue ('x','a'),Ue ('b','z'),Ue ('z','c'),Ue ('a','w'),Ue ('c','w')]

vertices :: Eq a => Graph a -> [a]
vertices (G l) = nub.join $ [ [a,b] | (Ue (a,b)) <- l]

op_adj :: Eq a => Uedge a -> a -> Maybe a
op_adj (Ue (a,b)) x | a == x = Just b
                    | b == x = Just a
                    | otherwise = Nothing


adj :: Eq a => Graph a -> a -> [a]
adj (G l) a = catMaybes [op_adj e a | e <- l]

is_adj :: Eq a => Graph a -> a -> a -> Bool
is_adj (G l) a b = elem (Ue (a,b)) l

isWalk :: Eq a => Graph a -> [a] -> Bool
isWalk _ ([]) = True
isWalk _ ([a]) = True
isWalk g (x:y:xs) = (is_adj g x y) && (isWalk g (y:xs))

connect_nearest_ue :: [a] -> [Uedge a]
connect_nearest_ue [] = []
connect_nearest_ue [a] = []
connect_nearest_ue (x:y:xs) = (Ue (x,y)):(connect_nearest_ue $ y:xs)

isTrail :: Eq a => Graph a -> [a] -> Bool
isTrail g l = (isWalk g l) && ( (length alle) == (length.nub $ alle) ) where alle = connect_nearest_ue l

isPath :: Eq a => Graph a -> [a] -> Bool
isPath g l = (isWalk g l) && ( (length l) == (length.nub $ l) )

open :: Eq a => Graph a -> [a] -> Bool
open _ [] = True
open _ [a] = True
open g l = (head l /= last l) && ((l \\ (vertices g) ) == [])


close :: Eq a => Graph a -> [a] -> Bool
close g l = not $ open g l

paths :: Eq a => Graph a -> [a] -> a -> a -> [[a]]
paths g v a b | a == b = [[a]]
              | a /= b = (b:) <$> (foldl (++) [] ((paths g (v++[b]) a) <$> ((adj g b) \\ v)))

step_ :: Eq a => Graph a -> ([a], [a]) -> ([a], [a])
-- step g a = step_ g ([],[a])
--step_ _ (v,[]) = (v,[])
--step_ g (v,(h:q)) = (v++[h], q++ (((adj g h) \\ v) \\ q) )
--bfs g a = fst $ fromJust $ find (\(_,q)->null q) $ iterate (step_ g) ([],[a])

step_ _ (v,[]) = (v,[])
step_ g (v,(h:q)) = (v++[h], (((adj g h) \\ v) \\ q) ++ q )
dfs g a = fst $ fromJust $ find (\(_,q)->null q) $ iterate (step_ g) ([],[a])

bfs :: Eq a => Graph a -> [a] -> [a] -> [a]
bfs _ _ [] = []
bfs g v (h:qs) = h : (bfs g (h:v) (qs++(((adj g h) \\) v \\ qs)))

--dfs :: Eq a => Graph a -> [a] -> [a] -> [a]
--dfs _ _ [] = []
--dfs g v (h:qs) = h : (dfs g (h:v) ((((adj g h) \\) v \\ qs)++qs))

bfsl g v = bfs_l g [] (if (elem v $ vertices g) then [(v,0)] else [])
bfs_l :: Eq a => Graph a -> [(a,Int)] -> [(a,Int)] -> [(a,Int)]
bfs_l _ _ [] = []
bfs_l g v ((h,l):qs) = (h,l) : (bfs_l g v1 (qs++a))
                                where
                                  v1 = (h,l):v
                                  a = add_l (((adj g h) \\ au v) \\ au qs) (l+1)
                                  au l = [fst e | e <- l]
                                  add_l vs l = [ (v,l) | v <- vs ]

s_paths :: Eq a => Graph a -> a -> a -> Maybe [[a]]
s_paths g a b = do
                lookup a bfs
                lb <- lookup b bfs
                return $ ps a (b,lb)
                where
                  ps a (b,lb) | a == b = [[a]]
                              | a /=b = (b:) <$> (foldl (++) [] ((ps a) <$> (adj_ b lb)))
                  bfs = (bfsl g a)
                  adj_ b lb = catMaybes [find ((==) (v, lb-1)) bfs | v <- adj g b]

video - https://www.youtube.com/watch?v=RS7eIkETdIQ
https://www.youtube.com/watch?v=sw1qGlEcL1g&t=1s
https://www.youtube.com/watch?v=UM0sggwLXk4&t=974s