The shortest path in a graph

Generic path

import Data.Array
import Data.Array.ST
import Control.Monad
import Control.Monad.ST
import Data.Maybe
import Data.Functor
import Control.Monad.Trans.State

f <.> g = liftM f . g

whenJust  Nothing f = return ()
whenJust (Just x) f = f x

type Queue a = ([a], [a] -> [a])

toQueue :: [a] -> Queue a
toQueue xs = (xs, id)

split :: Queue a -> Maybe (a, Queue a)
split (  [], dxs) = case dxs [] of
  [] -> Nothing
  xs -> split $ toQueue xs
split (x:xs, dxs) = Just (x, (xs, dxs))

putList :: [a] -> Queue a -> Queue a
putList xs' (xs, dxs) = (xs, dxs . (xs' ++))

gpath :: (Eq a, Monad m)
      => (a -> [a])
      -> (a -> m Bool)
      -> (a -> a -> m ())
      -> (a -> m a)
      -> a
      -> a
      -> m [a]
gpath neighbs isVisited visitBy prev orig dest = do
  orig `visitBy` orig
  form $ toQueue [orig]
  found <- isVisited dest
  if found then extr [] dest else return [] where
    form qs = whenJust (split qs) $ \(x, qs') -> do
      xs' <- filterM (not <.> isVisited) $ neighbs x
      mapM_ (`visitBy` x) xs'
      when (dest `notElem` xs') $ form $ putList xs' qs'

    extr xs x | x == orig = return $ x:xs
    extr xs x = prev x >>= extr (x:xs)

degenerate :: Eq a => (a -> a -> [(a, [a])] -> [a]) -> a -> a -> [(a, [a])] -> [a]
degenerate go orig dest xs | orig == dest = [orig]
degenerate go orig dest xs = do
  mapM_ (\x -> maybeToList $ lookup x xs) [orig, dest]
  go orig dest xs

pathInt :: Int -> Int -> [(Int, [Int])] -> [Int]
pathInt = degenerate $ \orig dest xs -> runST $ do
	let mxs   = maximum $ xs >>= uncurry (:)
	    graph = accumArray (++) []  (1, mxs) xs :: Array Int [Int]
	visited  <- newArray            (1, mxs) 0  :: ST s (STUArray s Int Int)
	let neighbs   = (graph!)
	    elemAt    = readArray  visited
	    visitBy   = writeArray visited
	    isVisited = (/= 0) <.> elemAt
	gpath neighbs isVisited visitBy elemAt orig dest

path :: Eq a => a -> a -> [(a, [a])] -> [a]
path = degenerate $ \orig dest xs -> flip evalState [] $
  let neighbs   = \x -> fromMaybe [] $ lookup x xs
      getElem   = \x -> lookup x <$> get
      visitBy   = \x y -> modify ((x, y):)
      isVisited = isJust <.> getElem
  in gpath neighbs isVisited visitBy (fromJust <.> getElem) orig dest

graph = [ (1, [2, 3, 4])
        , (2, [1, 2, 4])
        , (3, [1, 4, 5])
        , (4, [1, 2, 3, 7])
        , (5, [3, 5, 6, 8])
        , (6, [5, 7, 8])
        , (7, [4, 6, 7])
        , (8, [5, 6])
        ]

graphStr = map (\(i, is) -> (show i, map show is)) $
  init graph ++ [(8, [5, 6, 9])] ++ zip [9..] (map (:[]) [10..])

main = do
  print $ pathInt 2 8 graph
  print $ length $ path "2" "5000" graphStr

Tying the knot

-- This is related to http://stackoverflow.com/questions/27369025/finding-the-quickest-way-with-the-least-changes-haskell/

import Data.Maybe

data Rose  a = Rose a [Rose a] deriving Show
data Graph a = Graph [(a, Rose a)]

lookupRose :: Eq a => a -> Graph a -> Rose a
lookupRose i (Graph rs) = fromJust $ lookup i rs

fromList :: Eq a => [(a, [a])] -> Graph a
fromList xs = graph where
	graph         = Graph $ map irose xs
	irose (i, is) = (i, Rose i $ map (\i -> lookupRose i graph) is)

shortest :: [a] -> [a] -> [a]
shortest xs ys = snd $ shortest' xs ys where
	shortest'    []     ys  = (True,  [])
	shortest'    xs     []  = (False, [])
	shortest' (x:xs) (y:ys) = case shortest' xs ys of
		~(b, zs) -> (b, (if b then x else y):zs)

path :: Eq a => a -> a -> Graph a -> [a]
path orig dest gr = path' (lookupRose orig gr) where
	path' (Rose p ps)
		| p == dest = [p]
		| otherwise = p : foldr1 shortest (map path' ps)

graph :: [(Int, [Int])]
graph = zip [0..]
	[ [2, 3]
	, [1, 3]
	, [0, 3, 4]
	, [0, 1, 2, 6]
	, [2, 5, 7]
	, [4, 5, 6, 7]
	, [3, 5, 6]
	, [4, 5]
	]

main = print $ path 1 7 $ fromList graph