Tackled problem 1625

diff --git a/app/cses1625-array-count.hs b/app/cses1625-array-count.hs
new file mode 100644 (file)
index 0000000..32989b3
--- /dev/null
+++ b/app/cses1625-array-count.hs
@@ -0,0 +1,138 @@
+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
+
+import Data.Ix
+-- import qualified Data.Set as S
+import qualified Data.Array.Unboxed as U
+import qualified Data.Array.IArray as A
+import Data.Array.IArray ((!), (//))
+import Control.Monad
+
+
+data Point = Point Int Int -- row, column
+  deriving (Show, Eq, Ord, Ix)
+
+-- type Grid = S.Set Point
+type Grid = U.UArray Point Bool
+
+gridBounds = (Point 1 1, Point 7 7)
+pathStart = Point 1 1
+pathEnd = Point 7 1
+fullPathLength = 48
+
+-- gridBounds = (Point 1 1, Point 2 2)
+-- pathStart = Point 1 1
+-- pathEnd = Point 2 1
+-- fullPathLength = 3
+
+-- gridBounds = (Point 1 1, Point 4 4)
+-- pathStart = Point 1 1
+-- pathEnd = Point 4 1
+-- fullPathLength = 15
+
+data Direction = U | R | D | L
+  deriving (Show, Eq, Ord, Enum, Bounded)
+
+data DirectionConstraint =  CU | CR | CD | CL | Unknown
+  deriving (Show, Eq, Ord, Enum, Bounded)
+
+data State = State { visited :: Grid
+                   , pos :: Point
+                   , trail :: [Direction]
+                   , constraints :: [DirectionConstraint]
+                   }
+  deriving (Show, Eq, Ord)
+
+initialState :: [DirectionConstraint] -> State
+initialState cs = 
+  State { visited = A.array gridBounds [(i, False) | i <- range gridBounds] // [(pathStart, True)]
+        , pos = pathStart
+        , constraints = cs
+        , trail = []
+        }
+
+
+main :: IO ()
+main = do
+  let cs = replicate fullPathLength Unknown
+  -- let cs = readConstraints "??????R??????U??????????????????????????LD????D?"
+  -- let cs = readConstraints "DRURRRRRDDDLUULDDDLDRRURDDLLLLLURULURRUULDLLDDDD"
+  -- line <- getLine
+  -- let cs = readConstraints line
+  -- let paths = allPaths cs
+  print $ allPathsCount cs
+  -- print paths
+  -- let n = read line
+  -- let nums = unfoldr collatzStep n
+  -- let outStr = intercalate " " $ map show nums
+  -- putStrLn outStr
+
+readConstraints :: String -> [DirectionConstraint]
+readConstraints = map readConstraint
+
+readConstraint :: Char -> DirectionConstraint
+readConstraint 'U' = CU
+readConstraint 'R' = CR
+readConstraint 'D' = CD
+readConstraint 'L' = CL
+readConstraint _ = Unknown
+
+delta :: Direction -> Point
+delta U = Point (-1) 0
+delta R = Point 0 1
+delta D = Point 1 0
+delta L = Point 0 (-1)
+
+(^+^) :: Point -> Point -> Point
+(Point r1 c1) ^+^ (Point r2 c2) = Point (r1 + r2) (c1 + c2)
+
+opposite :: Point -> Point -> Bool
+opposite (Point r1 c1) (Point r2 c2) 
+  | r1 == r2 && c1 /= c2 = True
+  | c1 == c2 && r1 /= r2 = True
+  | otherwise = False
+
+compatible :: Direction -> DirectionConstraint -> Bool
+compatible U CU = True
+compatible R CR = True
+compatible D CD = True
+compatible L CL = True
+compatible _ Unknown = True
+compatible _ _ = False
+
+
+isComplete :: State -> Bool
+isComplete (State {..}) =
+  pos == pathEnd && length trail == fullPathLength
+
+successors :: State -> [State]
+successors state@(State {..}) 
+  | pos == pathEnd = []
+  | isComplete state = []
+  | otherwise =
+      do dir <- [minBound..maxBound] 
+         let givenDirection = head constraints
+         guard $ compatible dir givenDirection
+         let nextPos = pos ^+^ (delta dir)
+         guard $ inRange gridBounds nextPos
+         guard $ not $ visited ! nextPos
+         let nextVisited = visited // [(nextPos, True)]
+         return $ State { visited = nextVisited
+                        , pos = nextPos
+                        , constraints = tail constraints
+                        , trail = dir : trail
+                        }
+
+allPathsCount :: [DirectionConstraint] -> Int
+allPathsCount constraints = dfs [initialState constraints] 0
+
+dfs :: [State] -> Int -> Int
+dfs [] completeds = completeds
+dfs (current:agenda) completeds
+  | isComplete current = dfs agenda (completeds + 1)
+  | oppositePair succs = dfs agenda completeds
+  | otherwise = dfs (succs ++ agenda) completeds
+  where
+    succs = successors current
+    oppositePair ss
+      | length ss /= 2 = False
+      | otherwise = opposite (pos $ ss !! 0) (pos $ ss !! 1)

diff --git a/app/cses1625-array.hs b/app/cses1625-array.hs
new file mode 100644 (file)
index 0000000..e55ea8f
--- /dev/null
+++ b/app/cses1625-array.hs
@@ -0,0 +1,133 @@
+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
+
+import Data.Ix
+import qualified Data.Array.Unboxed as U
+import qualified Data.Array.IArray as A
+import Data.Array.IArray ((!), (//))
+import Control.Monad
+
+
+data Point = Point Int Int -- row, column
+  deriving (Show, Eq, Ord, Ix)
+
+type Grid = U.UArray Point Bool
+
+gridBounds = (Point 1 1, Point 7 7)
+pathStart = Point 1 1
+pathEnd = Point 7 1
+fullPathLength = 48
+
+-- gridBounds = (Point 1 1, Point 2 2)
+-- pathStart = Point 1 1
+-- pathEnd = Point 2 1
+-- fullPathLength = 3
+
+-- gridBounds = (Point 1 1, Point 4 4)
+-- pathStart = Point 1 1
+-- pathEnd = Point 4 1
+-- fullPathLength = 15
+
+data Direction = U | R | D | L
+  deriving (Show, Eq, Ord, Enum, Bounded)
+
+data DirectionConstraint =  CU | CR | CD | CL | Unknown
+  deriving (Show, Eq, Ord, Enum, Bounded)
+
+data State = State { visited :: Grid
+                   , pos :: Point
+                   , trail :: [Direction]
+                   , constraints :: [DirectionConstraint]
+                   }
+  deriving (Show, Eq, Ord)
+
+initialState :: [DirectionConstraint] -> State
+initialState cs = 
+  State { visited = A.array gridBounds [(i, False) | i <- range gridBounds] // [(pathStart, True)]
+        , pos = pathStart
+        , constraints = cs
+        , trail = []
+        }
+
+
+main :: IO ()
+main = do
+  -- let cs = replicate fullPathLength Unknown
+  -- let cs = readConstraints "??????R??????U??????????????????????????LD????D?"
+  -- let cs = readConstraints "DRURRRRRDDDLUULDDDLDRRURDDLLLLLURULURRUULDLLDDDD"
+  line <- getLine
+  let cs = readConstraints line
+  let paths = allPaths cs
+  print $ length paths
+
+
+readConstraints :: String -> [DirectionConstraint]
+readConstraints = map readConstraint
+
+readConstraint :: Char -> DirectionConstraint
+readConstraint 'U' = CU
+readConstraint 'R' = CR
+readConstraint 'D' = CD
+readConstraint 'L' = CL
+readConstraint _ = Unknown
+
+delta :: Direction -> Point
+delta U = Point (-1) 0
+delta R = Point 0 1
+delta D = Point 1 0
+delta L = Point 0 (-1)
+
+(^+^) :: Point -> Point -> Point
+(Point r1 c1) ^+^ (Point r2 c2) = Point (r1 + r2) (c1 + c2)
+
+opposite :: Point -> Point -> Bool
+opposite (Point r1 c1) (Point r2 c2) 
+  | r1 == r2 && c1 /= c2 = True
+  | c1 == c2 && r1 /= r2 = True
+  | otherwise = False
+
+
+compatible :: Direction -> DirectionConstraint -> Bool
+compatible U CU = True
+compatible R CR = True
+compatible D CD = True
+compatible L CL = True
+compatible _ Unknown = True
+compatible _ _ = False
+
+
+isComplete :: State -> Bool
+isComplete (State {..}) =
+  pos == pathEnd && length trail == fullPathLength
+
+successors :: State -> [State]
+successors state@(State {..}) 
+  | pos == pathEnd = []
+  | isComplete state = []
+  | otherwise =
+      do dir <- [minBound..maxBound] 
+         let givenDirection = head constraints
+         guard $ compatible dir givenDirection
+         let nextPos = pos ^+^ (delta dir)
+         guard $ inRange gridBounds nextPos
+         guard $ not $ visited ! nextPos
+         let nextVisited = visited // [(nextPos, True)]
+         return $ State { visited = nextVisited
+                        , pos = nextPos
+                        , constraints = tail constraints
+                        , trail = dir : trail
+                        }
+
+allPaths :: [DirectionConstraint] -> [State]
+allPaths constraints = dfs [initialState constraints] []
+
+dfs :: [State] -> [State] -> [State]
+dfs [] completeds = completeds
+dfs (current:agenda) completeds
+  | isComplete current = dfs agenda (current : completeds)
+  | oppositePair succs = dfs agenda completeds
+  | otherwise = dfs (succs ++ agenda) completeds
+  where
+    succs = successors current
+    oppositePair ss
+      | length ss /= 2 = False
+      | otherwise = opposite (pos $ ss !! 0) (pos $ ss !! 1)

diff --git a/app/cses1625-mutable.hs b/app/cses1625-mutable.hs
new file mode 100644 (file)
index 0000000..4a53fc0
--- /dev/null
+++ b/app/cses1625-mutable.hs
@@ -0,0 +1,138 @@
+{-# LANGUAGE MultiWayIf #-}
+
+import Debug.Trace
+
+import Data.Ix
+import qualified Data.Array.ST as U
+import qualified Data.Array.MArray as A
+import Control.Monad
+import Control.Monad.ST
+import Data.STRef as S
+
+
+data Point = Point Int Int -- row, column
+  deriving (Show, Eq, Ord, Ix)
+
+type Grid s = U.STUArray s Point Bool
+
+gridBounds = (Point 1 1, Point 7 7)
+pathStart = Point 1 1
+pathEnd = Point 7 1
+fullPathLength = 48
+
+-- gridBounds = (Point 1 1, Point 2 2)
+-- pathStart = Point 1 1
+-- pathEnd = Point 2 1
+-- fullPathLength = 3
+
+-- gridBounds = (Point 1 1, Point 4 4)
+-- pathStart = Point 1 1
+-- pathEnd = Point 4 1
+-- fullPathLength = 15
+
+data Direction = U | R | D | L
+  deriving (Show, Eq, Ord, Enum, Bounded)
+
+data DirectionConstraint =  CU | CR | CD | CL | Unknown
+  deriving (Show, Eq, Ord, Enum, Bounded)
+
+
+main :: IO ()
+main = do
+  -- let cs = replicate fullPathLength Unknown
+  -- let cs = [CR, CD, CL]
+  -- let cs = readConstraints "??????R??????U??????????????????????????LD????D?"
+  -- let cs = readConstraints "DRURRRRRDDDLUULDDDLDRRURDDLLLLLURULURRUULDLLDDDD"
+  -- line <- getLine
+  let cs = readConstraints line
+  let paths = allPaths cs
+  print $ allPathsCount cs
+
+
+readConstraints :: String -> [DirectionConstraint]
+readConstraints = map readConstraint
+
+readConstraint :: Char -> DirectionConstraint
+readConstraint 'U' = CU
+readConstraint 'R' = CR
+readConstraint 'D' = CD
+readConstraint 'L' = CL
+readConstraint _ = Unknown
+
+delta :: Direction -> Point
+delta U = Point (-1) 0
+delta R = Point 0 1
+delta D = Point 1 0
+delta L = Point 0 (-1)
+
+(^+^) :: Point -> Point -> Point
+(Point r1 c1) ^+^ (Point r2 c2) = Point (r1 + r2) (c1 + c2)
+
+opposite :: Point -> Point -> Bool
+opposite (Point r1 c1) (Point r2 c2) 
+  | r1 == r2 && c1 /= c2 = True
+  | c1 == c2 && r1 /= r2 = True
+  | otherwise = False
+
+
+compatible :: DirectionConstraint -> Direction -> Bool
+compatible CU U = True
+compatible CR R = True
+compatible CD D = True
+compatible CL L = True
+compatible Unknown _ = True
+compatible _ _ = False
+
+directionsOf :: DirectionConstraint -> [Direction]
+directionsOf CU = [U]
+directionsOf CR = [R]
+directionsOf CD = [D]
+directionsOf CL = [L]
+directionsOf Unknown = [minBound..maxBound]
+
+
+allPathsCount :: [DirectionConstraint] -> Int
+allPathsCount constraints = runST $ do
+  visited <- U.newArray gridBounds False
+  count <- S.newSTRef 0
+  dfs constraints visited count pathStart
+  S.readSTRef count
+
+
+dfs :: [DirectionConstraint] -> Grid s -> S.STRef s Int -> Point -> ST s ()
+-- dfs cs _ _ pos | trace ("dfs " ++ (show cs ++ " " ++ (show pos))) False = undefined
+dfs [] visited count pos = do 
+  A.writeArray visited pos True
+  completed <- isComplete visited pos
+  when completed $ S.modifySTRef' count (+1)
+  A.writeArray visited pos False
+dfs (c:cs) visited count pos = do
+  A.writeArray visited pos True
+  completed <- isComplete visited pos
+  if | completed -> S.modifySTRef' count (+1)
+     | pos == pathEnd -> return ()
+     | otherwise -> do succs <- successors visited pos c
+                       mapM_ (dfs cs visited count) succs
+  A.writeArray visited pos False
+
+isComplete :: Grid s -> Point -> ST s Bool
+isComplete grid pos 
+  | pos == pathEnd = 
+      do  cells <- A.getElems grid
+          let allVisited = and cells
+          return allVisited
+  | otherwise = return False
+
+
+successors :: Grid s -> Point -> DirectionConstraint -> ST s [Point]
+successors grid pos constraint = do
+  let directions = {-# SCC "dir" #-} directionsOf constraint
+  let nextPoses0 = {-# SCC "pos0" #-} map ((^+^ pos) . delta) directions
+  let nextPoses1 = {-# SCC "inbouds" #-} filter (inRange gridBounds) nextPoses0
+  nextPoses2 <- {-# SCC "unvisited" #-} filterM ((liftM not) . (A.readArray grid)) nextPoses1
+  return $ {-# SCC "opps" #-} if length nextPoses2 == 2 then
+              let [p1, p2] = nextPoses2
+              in if opposite p1 p2 then [] else nextPoses2
+           else nextPoses2
+
+

diff --git a/app/cses1625.hs b/app/cses1625.hs
new file mode 100644 (file)
index 0000000..8aca3e8
--- /dev/null
+++ b/app/cses1625.hs
@@ -0,0 +1,141 @@
+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
+
+import Data.Ix
+import qualified Data.Set as S
+import Control.Monad
+
+
+data Point = Point Int Int -- row, column
+  deriving (Show, Eq, Ord, Ix)
+
+type Grid = S.Set Point
+
+gridBounds = (Point 1 1, Point 7 7)
+pathStart = Point 1 1
+pathEnd = Point 7 1
+fullPathLength = 48
+
+-- gridBounds = (Point 1 1, Point 2 2)
+-- pathStart = Point 1 1
+-- pathEnd = Point 2 1
+-- fullPathLength = 3
+
+-- gridBounds = (Point 1 1, Point 4 4)
+-- pathStart = Point 1 1
+-- pathEnd = Point 4 1
+-- fullPathLength = 15
+
+data Direction = U | R | D | L
+  deriving (Show, Eq, Ord, Enum, Bounded)
+
+data DirectionConstraint =  CU | CR | CD | CL | Unknown
+  deriving (Show, Eq, Ord, Enum, Bounded)
+
+data State = State { visited :: Grid
+                   , pos :: Point
+                   , trail :: [Direction]
+                   , constraints :: [DirectionConstraint]
+                   }
+  deriving (Show, Eq, Ord)
+
+initialState :: [DirectionConstraint] -> State
+initialState cs = 
+  State { visited = S.singleton pathStart
+        , pos = pathStart
+        , constraints = cs
+        , trail = []
+        }
+
+
+main :: IO ()
+main = do
+  -- let cs = replicate fullPathLength Unknown
+  let cs = readConstraints "??????R??????U??????????????????????????LD????D?"
+  -- let cs = readConstraints "DRURRRRRDDDLUULDDDLDRRURDDLLLLLURULURRUULDLLDDDD"
+  let paths = allPaths cs
+  print $ length paths
+  -- print paths
+  -- line <- getLine
+  -- let n = read line
+  -- let nums = unfoldr collatzStep n
+  -- let outStr = intercalate " " $ map show nums
+  -- putStrLn outStr
+
+readConstraints :: String -> [DirectionConstraint]
+readConstraints = map readConstraint
+
+readConstraint :: Char -> DirectionConstraint
+readConstraint 'U' = CU
+readConstraint 'R' = CR
+readConstraint 'D' = CD
+readConstraint 'L' = CL
+readConstraint _ = Unknown
+
+delta :: Direction -> Point
+delta U = Point (-1) 0
+delta R = Point 0 1
+delta D = Point 1 0
+delta L = Point 0 (-1)
+
+(^+^) :: Point -> Point -> Point
+(Point x1 y1) ^+^ (Point x2 y2) = Point (x1 + x2) (y1 + y2)
+
+opposite :: Direction -> Direction -> Bool
+opposite U D = True
+opposite D U = True
+opposite L R = True
+opposite R L = True
+opposite _ _ = False
+
+
+compatible :: Direction -> DirectionConstraint -> Bool
+compatible U CU = True
+compatible R CR = True
+compatible D CD = True
+compatible L CL = True
+compatible _ Unknown = True
+compatible _ _ = False
+
+
+isComplete :: State -> Bool
+isComplete (State {..}) =
+  pos == pathEnd && length trail == fullPathLength
+
+successors :: State -> [State]
+successors state@(State {..}) 
+  | pos == pathEnd = []
+  | isComplete state = []
+  | otherwise =
+      do dir <- [minBound..maxBound] 
+         let givenDirection = head constraints
+         guard $ compatible dir givenDirection
+         let nextPos = pos ^+^ (delta dir)
+         guard $ inRange gridBounds nextPos
+         {-# SCC "setNonMember" #-} guard $ S.notMember nextPos visited
+         let nextVisited = S.insert nextPos visited
+         return $ State { visited = nextVisited
+                        , pos = nextPos
+                        , constraints = tail constraints
+                        , trail = dir : trail
+                        }
+
+allPaths :: [DirectionConstraint] -> [State]
+allPaths constraints = dfs [initialState constraints] []
+
+-- bfs :: [State] -> [State] -> [State]
+-- bfs [] visited = visited
+-- bfs (current:agenda) visited
+--   | isComplete current = bfs agenda (current : visited)
+--   | otherwise =
+--       let succs = successors current
+--           newAgenda = agenda ++ succs
+--       in bfs newAgenda visited
+
+dfs :: [State] -> [State] -> [State]
+dfs [] visited = visited
+dfs (current:agenda) visited
+  | isComplete current = dfs agenda (current : visited)
+  | otherwise =
+      let succs = successors current
+          newAgenda = succs ++ agenda
+      in dfs newAgenda visited

diff --git a/cses-programming-tasks.cabal b/cses-programming-tasks.cabal
index a1cde74c0db9d7ddf9281cc6f2c46039dd05cf2a..bc08e43d5f2f65b726d46f1dad4818e96636ef34 100644 (file)
--- a/cses-programming-tasks.cabal
+++ b/cses-programming-tasks.cabal
@@ -163,4 +163,24 @@ executable cses1624
 executable cses2431
   import: build-directives
   main-is: cses2431.hs
 executable cses2431
   import: build-directives
   main-is: cses2431.hs

-  
\ No newline at end of file
+
+executable cses1625
+  import: build-directives
+  main-is: cses1625.hs
+  build-depends: containers
+
+executable cses1625a
+  import: build-directives
+  main-is: cses1625-array.hs
+  build-depends: containers, array
+
+executable cses1625ac
+  import: build-directives
+  main-is: cses1625-array-count.hs
+  build-depends: array
+
+executable cses1625m
+  import: build-directives
+  main-is: cses1625-mutable.hs
+  build-depends: array
+

diff --git a/data/cses1625.txt b/data/cses1625.txt
new file mode 100644 (file)
index 0000000..f954ea7
--- /dev/null
+++ b/data/cses1625.txt
@@ -0,0 +1 @@
+??????R??????U??????????????????????????LD????D?