The shortest path in a graph

GenericPath.hs

import Control.Monad
import Control.Monad.Trans.State
import Data.Maybe

(<.>) :: Monad m => (a -> b) -> (c -> m a) -> c -> m b
f <.> g = fmap f . g

whenJust :: Monad m => Maybe t -> (t -> m ()) -> m ()
whenJust  Nothing _ = 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]
  | otherwise = do
      mapM_ (\x -> maybeToList $ lookup x xs) [orig, dest]
      go orig dest xs

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

-------------------------------------------------------------------------------

type Pos = (Int,Int)

posGraph :: [(Pos,[Pos])]
posGraph = [ (a, [b, c, d])
          , (b, [a, b, d])
          , (c, [a, d, e])
          , (d, [a, b, c, g])
          , (e, [c, e, f, h])
          , (f, [e, g, h])
          , (g, [d, f, g])
          , (h, [e, f])
          ]
  where [a,b,c,d,e,f,g,h] =
          [ (1,1)
          , (2,2)
          , (3,3)
          , (4,4)
          , (5,5)
          , (6,6)
          , (7,7)
          , (8,8)
          ]

main :: IO ()
main = do
  print $ path (1,1) (8,8) posGraph
  print $ path (2,2) (8,8) posGraph

TyingTheKnot.hs

-- 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
newtype 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 (`lookupRose` graph) is)

shortest :: [a] -> [a] -> [a]
shortest xs ys = snd $ shortest' xs ys where
  shortest' :: [a] -> [a] -> (Bool, [a])
  shortest' []     _      = (True,  [])
  shortest'  _     []     = (False, [])
  shortest' (a:as) (b:bs) = case shortest' as bs of
      ~(i, js) -> (i, (if i then a else b):js)
      -- (True,  js) -> (True,  a:js)
      -- (False, js) -> (False, b:js)

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)

-------------------------------------------------------------------------------

type Pos = (Int,Int)

posGraph :: [(Pos,[Pos])]
posGraph = [ (a, [b, c, d])
          , (b, [a, b, d])
          , (c, [a, d, e])
          , (d, [a, b, c, g])
          , (e, [c, e, f, h])
          , (f, [e, g, h])
          , (g, [d, f, g])
          , (h, [e, f])
          ]
  where [a,b,c,d,e,f,g,h] =
          [ (1,1)
          , (2,2)
          , (3,3)
          , (4,4)
          , (5,5)
          , (6,6)
          , (7,7)
          , (8,8)
          ]

main :: IO ()
main = do
  print $ path (1,1) (8,8) $ fromList posGraph
  print $ path (2,2) (8,8) $ fromList posGraph