app/cses1625-array-count.hs

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