app/cses1625.hs

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