fork download
copy 
  1. {-# OPTIONS_GHC -Wall #-}
  2. import Control.Monad (guard)
  3. import Control.Applicative ((<$>))
  4. import Data.Array (Array, listArray, assocs, (!), elems, (//))
  5.  
  6. data Direction = E | W | S | N deriving (Show, Eq)
  7. type Pos = (Int,Int) -- (y,x)
  8. type Tile = Char
  9. data MapData = MapData {mapData :: Array Pos Tile, height :: Int, width :: Int}
  10.  
  11. strToMapData :: Int -> Int -> String -> MapData
  12. strToMapData h w input = MapData (listArray ((0,0), (h,w)) $ filter (/='\n') input) h w
  13.  
  14. printMapData :: MapData -> IO ()
  15. printMapData (MapData m _ w) = do
  16.   printMapData' w $ elems m
  17.   where
  18.     printMapData' :: Int -> String -> IO ()
  19.     printMapData' _ "" = return ()
  20.     printMapData' w' s = do
  21.       putStrLn $ take w' s
  22.       printMapData' w' $ drop w' s
  23.  
  24. startPos :: MapData -> Pos
  25. startPos = posOf 'S'
  26.   where
  27.     posOf :: Tile -> MapData -> Pos
  28.     posOf tile (MapData ar _ _) = fst $ head $ filter (\(_,t) -> t == tile) $ assocs ar
  29.  
  30. -- | 指定した位置から移動した次の位置のリストを返す (壁'*'には移動できない)
  31. nextPoss :: MapData -> Pos -> [Pos]
  32. nextPoss (MapData m h w) p = do
  33.   (y',x') <- (move p) <$> [E,W,S,N]
  34.   guard $ (y' >= 0) && (y' < h) && (x' >= 0) && (x' < w)
  35.   guard $ (m ! (y',x')) /= '*'
  36.   return (y',x')
  37.  
  38. -- | １マス移動する
  39. move :: Pos -> Direction -> Pos
  40. move (y,x) E = (y,x+1)
  41. move (y,x) W = (y,x-1)
  42. move (y,x) S = (y+1,x)
  43. move (y,x) N = (y-1,x)
  44.  
  45. -- | ゴールに到達する経路をすべて返す (ただし一度通ったところは通らない)
  46. searchRoute :: MapData -> [Pos] -> Pos -> [[Pos]]
  47. searchRoute m tracks currentP = do
  48.   if ((mapData m) ! currentP) == 'G'
  49.      then return tracks
  50.      else if currentP `elem` tracks
  51.             then []
  52.             else do
  53.               nextP <- nextPoss m currentP
  54.               searchRoute m (currentP:tracks) nextP
  55.  
  56. -- | ゴールへの最短経路を返す
  57. shortestRoute :: MapData -> Maybe [Pos]
  58. shortestRoute mData =
  59.   let routes = searchRoute mData [] $ startPos mData
  60.       minLen = minimum $ map length routes
  61.       minRoutes = filter (\r -> length r == minLen) routes
  62.   in if length minRoutes == 0 then Nothing else Just $ head minRoutes
  63.  
  64. -- | マップに経路を重ねる
  65. mergeRoute :: MapData -> [Pos] -> MapData
  66. mergeRoute (MapData m h w) route = MapData (m // init (map (\p -> (p,'$')) $ route)) (h+1) (w+1)
  67.  
  68. main :: IO ()
  69. main = do
  70.   c <- getContents
  71.   let h = length $ lines c
  72.       w = length $ head $ lines c
  73.       mData = strToMapData (h-1) (w-1) c
  74.   case shortestRoute mData of
  75.     Just route -> printMapData $ mergeRoute mData $ route
  76.     Nothing -> error "There is no route."
  77.  
Success #stdin #stdout 0.16s 6300KB
comments (?)
stdin
copy 
***************
*S* *  * *  * *
* * *         *
* *   **   *  *
* *   **  *   *
* *   *   *** *
*    *G    *  *
***************
stdout
copy 
***************
*S* *  * *  * *
*$* *$$$$     *
*$*  $**$  *  *
*$*  $**$ *   *
*$* $$*$$ *** *
*$$$$*G$   *  *
***************
https://ideone.com/XOspWl
language:
Haskell (ghc 8.4.4)
created:
10 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!