Irrefutable patterns

a.hs

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
      (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

b.hs

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)

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

diff

$ diff a.hs b.hs
20,21c20
<       (True,  js) -> (True,  a:js)
<       (False, js) -> (False, b:js)
---
>       ~(i, js) -> (i, (if i then a else b):js)