ルート探索

ルート探索(1) - バリケンのRuby日記 - RubyistをHaskellで書いてみました。最近こればっかりな気もしますが。
やっぱり再帰ものは書きやすいです。バリケンさんのコードをそのまま移植できました。副作用のないバージョンも2つ書いてみましたので、参考まで。

module Main (main) where

import Data.Maybe (fromJust)

routeMap :: [(String, [String])]
routeMap = 
  [("A", ["B", "D"]),
   ("B", ["A", "C"]),
   ("C", ["A", "D"]),
   ("D", ["B", "C"])]

-- 関数の中で出力する場合。
routeComb1 :: String -> String -> [(String, [String])] -> IO ()
routeComb1 = comb []
  where
    comb trace start goal rtmap =
      mapM_ f $ fromJust $ lookup start rtmap
      where
        trace' = start : trace
    
        f node
          | elem node trace = return ()
          | node == goal    = print $ reverse $ node : trace'
          | otherwise       = comb trace' node goal rtmap

-- リストを返す場合。
routeComb2 :: String -> String -> [(String, [String])] -> [[String]]
routeComb2 = comb []
  where
    comb trace start goal rtmap =
      concatMap f $ fromJust $ lookup start rtmap
      where
        trace' = start : trace
    
        f node
          | elem node trace = []
          | node == goal    = [reverse $ node : trace']
          | otherwise       = comb trace' node goal rtmap

-- リストを返す場合(accumulaterを使う場合)。
routeComb3 :: String -> String -> [(String, [String])] -> [[String]]
routeComb3 = comb [] []
  where
    comb acc trace start goal rtmap =
      concatMap f $ fromJust $ lookup start rtmap
      where
        trace' = start : trace
    
        f node
          | elem node trace = acc
          | node == goal    = (reverse $ node : trace') : acc
          | otherwise       = comb acc trace' node goal rtmap

main :: IO ()
main = do
  putStrLn "routeComb1:"
  routeComb1 "B" "D" routeMap

  putStrLn "routeComb2:"
  mapM_ print $ routeComb2 "B" "D" routeMap

  putStrLn "routeComb3:"
  mapM_ print $ routeComb3 "B" "D" routeMap

実行例:

$ ./rt.exe
routeComb1:
["B","A","D"]
["B","C","A","D"]
["B","C","D"]
routeComb2:
["B","A","D"]
["B","C","A","D"]
["B","C","D"]
routeComb3:
["B","A","D"]
["B","C","A","D"]
["B","C","D"]