app/cses1625-array.hs

   1 {-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
   2
   3 import Data.Ix
   4 import qualified Data.Array.Unboxed as U
   5 import qualified Data.Array.IArray as A
   6 import Data.Array.IArray ((!), (//))
   7 import Control.Monad
   8
   9
  10 data Point = Point Int Int -- row, column
  11   deriving (Show, Eq, Ord, Ix)
  12
  13 type Grid = U.UArray Point Bool
  14
  15 gridBounds = (Point 1 1, Point 7 7)
  16 pathStart = Point 1 1
  17 pathEnd = Point 7 1
  18 fullPathLength = 48
  19
  20 -- gridBounds = (Point 1 1, Point 2 2)
  21 -- pathStart = Point 1 1
  22 -- pathEnd = Point 2 1
  23 -- fullPathLength = 3
  24
  25 -- gridBounds = (Point 1 1, Point 4 4)
  26 -- pathStart = Point 1 1
  27 -- pathEnd = Point 4 1
  28 -- fullPathLength = 15
  29
  30 data Direction = U | R | D | L
  31   deriving (Show, Eq, Ord, Enum, Bounded)
  32
  33 data DirectionConstraint =  CU | CR | CD | CL | Unknown
  34   deriving (Show, Eq, Ord, Enum, Bounded)
  35
  36 data State = State { visited :: Grid
  37                    , pos :: Point
  38                    , trail :: [Direction]
  39                    , constraints :: [DirectionConstraint]
  40                    }
  41   deriving (Show, Eq, Ord)
  42
  43 initialState :: [DirectionConstraint] -> State
  44 initialState cs =
  45   State { visited = A.array gridBounds [(i, False) | i <- range gridBounds] // [(pathStart, True)]
  46         , pos = pathStart
  47         , constraints = cs
  48         , trail = []
  49         }
  50
  51
  52 main :: IO ()
  53 main = do
  54   -- let cs = replicate fullPathLength Unknown
  55   -- let cs = readConstraints "??????R??????U??????????????????????????LD????D?"
  56   -- let cs = readConstraints "DRURRRRRDDDLUULDDDLDRRURDDLLLLLURULURRUULDLLDDDD"
  57   line <- getLine
  58   let cs = readConstraints line
  59   let paths = allPaths cs
  60   print $ length paths
  61
  62
  63 readConstraints :: String -> [DirectionConstraint]
  64 readConstraints = map readConstraint
  65
  66 readConstraint :: Char -> DirectionConstraint
  67 readConstraint 'U' = CU
  68 readConstraint 'R' = CR
  69 readConstraint 'D' = CD
  70 readConstraint 'L' = CL
  71 readConstraint _ = Unknown
  72
  73 delta :: Direction -> Point
  74 delta U = Point (-1) 0
  75 delta R = Point 0 1
  76 delta D = Point 1 0
  77 delta L = Point 0 (-1)
  78
  79 (^+^) :: Point -> Point -> Point
  80 (Point r1 c1) ^+^ (Point r2 c2) = Point (r1 + r2) (c1 + c2)
  81
  82 opposite :: Point -> Point -> Bool
  83 opposite (Point r1 c1) (Point r2 c2)
  84   | r1 == r2 && c1 /= c2 = True
  85   | c1 == c2 && r1 /= r2 = True
  86   | otherwise = False
  87
  88
  89 compatible :: Direction -> DirectionConstraint -> Bool
  90 compatible U CU = True
  91 compatible R CR = True
  92 compatible D CD = True
  93 compatible L CL = True
  94 compatible _ Unknown = True
  95 compatible _ _ = False
  96
  97
  98 isComplete :: State -> Bool
  99 isComplete (State {..}) =
 100   pos == pathEnd && length trail == fullPathLength
 101
 102 successors :: State -> [State]
 103 successors state@(State {..})
 104   | pos == pathEnd = []
 105   | isComplete state = []
 106   | otherwise =
 107       do dir <- [minBound..maxBound]
 108          let givenDirection = head constraints
 109          guard $ compatible dir givenDirection
 110          let nextPos = pos ^+^ (delta dir)
 111          guard $ inRange gridBounds nextPos
 112          guard $ not $ visited ! nextPos
 113          let nextVisited = visited // [(nextPos, True)]
 114          return $ State { visited = nextVisited
 115                         , pos = nextPos
 116                         , constraints = tail constraints
 117                         , trail = dir : trail
 118                         }
 119
 120 allPaths :: [DirectionConstraint] -> [State]
 121 allPaths constraints = dfs [initialState constraints] []
 122
 123 dfs :: [State] -> [State] -> [State]
 124 dfs [] completeds = completeds
 125 dfs (current:agenda) completeds
 126   | isComplete current = dfs agenda (current : completeds)
 127   | oppositePair succs = dfs agenda completeds
 128   | otherwise = dfs (succs ++ agenda) completeds
 129   where
 130     succs = successors current
 131     oppositePair ss
 132       | length ss /= 2 = False
 133       | otherwise = opposite (pos $ ss !! 0) (pos $ ss !! 1)