app/cses1625-mutable.hs

   1 {-# LANGUAGE MultiWayIf #-}
   2
   3 import Debug.Trace
   4
   5 import Data.Ix
   6 import qualified Data.Array.ST as U
   7 import qualified Data.Array.MArray as A
   8 import Control.Monad
   9 import Control.Monad.ST
  10 import Data.STRef as S
  11
  12
  13 data Point = Point Int Int -- row, column
  14   deriving (Show, Eq, Ord, Ix)
  15
  16 type Grid s = U.STUArray s Point Bool
  17
  18 gridBounds = (Point 1 1, Point 7 7)
  19 pathStart = Point 1 1
  20 pathEnd = Point 7 1
  21 fullPathLength = 48
  22
  23 -- gridBounds = (Point 1 1, Point 2 2)
  24 -- pathStart = Point 1 1
  25 -- pathEnd = Point 2 1
  26 -- fullPathLength = 3
  27
  28 -- gridBounds = (Point 1 1, Point 4 4)
  29 -- pathStart = Point 1 1
  30 -- pathEnd = Point 4 1
  31 -- fullPathLength = 15
  32
  33 data Direction = U | R | D | L
  34   deriving (Show, Eq, Ord, Enum, Bounded)
  35
  36 data DirectionConstraint =  CU | CR | CD | CL | Unknown
  37   deriving (Show, Eq, Ord, Enum, Bounded)
  38
  39
  40 main :: IO ()
  41 main = do
  42   -- let cs = replicate fullPathLength Unknown
  43   -- let cs = [CR, CD, CL]
  44   -- let cs = readConstraints "??????R??????U??????????????????????????LD????D?"
  45   -- let cs = readConstraints "DRURRRRRDDDLUULDDDLDRRURDDLLLLLURULURRUULDLLDDDD"
  46   -- line <- getLine
  47   let cs = readConstraints line
  48   let paths = allPaths cs
  49   print $ allPathsCount cs
  50
  51
  52 readConstraints :: String -> [DirectionConstraint]
  53 readConstraints = map readConstraint
  54
  55 readConstraint :: Char -> DirectionConstraint
  56 readConstraint 'U' = CU
  57 readConstraint 'R' = CR
  58 readConstraint 'D' = CD
  59 readConstraint 'L' = CL
  60 readConstraint _ = Unknown
  61
  62 delta :: Direction -> Point
  63 delta U = Point (-1) 0
  64 delta R = Point 0 1
  65 delta D = Point 1 0
  66 delta L = Point 0 (-1)
  67
  68 (^+^) :: Point -> Point -> Point
  69 (Point r1 c1) ^+^ (Point r2 c2) = Point (r1 + r2) (c1 + c2)
  70
  71 opposite :: Point -> Point -> Bool
  72 opposite (Point r1 c1) (Point r2 c2)
  73   | r1 == r2 && c1 /= c2 = True
  74   | c1 == c2 && r1 /= r2 = True
  75   | otherwise = False
  76
  77
  78 compatible :: DirectionConstraint -> Direction -> Bool
  79 compatible CU U = True
  80 compatible CR R = True
  81 compatible CD D = True
  82 compatible CL L = True
  83 compatible Unknown _ = True
  84 compatible _ _ = False
  85
  86 directionsOf :: DirectionConstraint -> [Direction]
  87 directionsOf CU = [U]
  88 directionsOf CR = [R]
  89 directionsOf CD = [D]
  90 directionsOf CL = [L]
  91 directionsOf Unknown = [minBound..maxBound]
  92
  93
  94 allPathsCount :: [DirectionConstraint] -> Int
  95 allPathsCount constraints = runST $ do
  96   visited <- U.newArray gridBounds False
  97   count <- S.newSTRef 0
  98   dfs constraints visited count pathStart
  99   S.readSTRef count
 100
 101
 102 dfs :: [DirectionConstraint] -> Grid s -> S.STRef s Int -> Point -> ST s ()
 103 -- dfs cs _ _ pos | trace ("dfs " ++ (show cs ++ " " ++ (show pos))) False = undefined
 104 dfs [] visited count pos = do
 105   A.writeArray visited pos True
 106   completed <- isComplete visited pos
 107   when completed $ S.modifySTRef' count (+1)
 108   A.writeArray visited pos False
 109 dfs (c:cs) visited count pos = do
 110   A.writeArray visited pos True
 111   completed <- isComplete visited pos
 112   if | completed -> S.modifySTRef' count (+1)
 113      | pos == pathEnd -> return ()
 114      | otherwise -> do succs <- successors visited pos c
 115                        mapM_ (dfs cs visited count) succs
 116   A.writeArray visited pos False
 117
 118 isComplete :: Grid s -> Point -> ST s Bool
 119 isComplete grid pos
 120   | pos == pathEnd =
 121       do  cells <- A.getElems grid
 122           let allVisited = and cells
 123           return allVisited
 124   | otherwise = return False
 125
 126
 127 successors :: Grid s -> Point -> DirectionConstraint -> ST s [Point]
 128 successors grid pos constraint = do
 129   let directions = {-# SCC "dir" #-} directionsOf constraint
 130   let nextPoses0 = {-# SCC "pos0" #-} map ((^+^ pos) . delta) directions
 131   let nextPoses1 = {-# SCC "inbouds" #-} filter (inRange gridBounds) nextPoses0
 132   nextPoses2 <- {-# SCC "unvisited" #-} filterM ((liftM not) . (A.readArray grid)) nextPoses1
 133   return $ {-# SCC "opps" #-} if length nextPoses2 == 2 then
 134               let [p1, p2] = nextPoses2
 135               in if opposite p1 p2 then [] else nextPoses2
 136            else nextPoses2
 137
 138