From 8ad7a27faf4d6516084addc5747223ab2cda78a8 Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Wed, 29 Nov 2023 14:45:17 +0000 Subject: [PATCH] Tackled problem 1625 --- app/cses1625-array-count.hs | 138 ++++++++++++++++++++++++++++++++++ app/cses1625-array.hs | 133 +++++++++++++++++++++++++++++++++ app/cses1625-mutable.hs | 138 ++++++++++++++++++++++++++++++++++ app/cses1625.hs | 141 +++++++++++++++++++++++++++++++++++ cses-programming-tasks.cabal | 22 +++++- data/cses1625.txt | 1 + 6 files changed, 572 insertions(+), 1 deletion(-) create mode 100644 app/cses1625-array-count.hs create mode 100644 app/cses1625-array.hs create mode 100644 app/cses1625-mutable.hs create mode 100644 app/cses1625.hs create mode 100644 data/cses1625.txt diff --git a/app/cses1625-array-count.hs b/app/cses1625-array-count.hs new file mode 100644 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 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 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 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 a1cde74..bc08e43 100644 --- 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 - \ 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 index 0000000..f954ea7 --- /dev/null +++ b/data/cses1625.txt @@ -0,0 +1 @@ +??????R??????U??????????????????????????LD????D? -- 2.34.1