Skip to content

Commit 3c50000

Browse files
mnvrmnvr
committed
Split into solution and vis
1 parent 67a9a00 commit 3c50000

File tree

2 files changed

+149
-16
lines changed

2 files changed

+149
-16
lines changed

‎10.hs

Lines changed: 145 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,145 @@
1+
import Data.Bifunctor (first, second)
2+
import Data.Map qualified as M
3+
import Data.Maybe (catMaybes, fromJust)
4+
import Control.Arrow ((&&&))
5+
6+
main :: IO ()
7+
main = interact $ (++ "\n") . show . (p1 &&& p2) . parse
8+
9+
type Node = (Int, Int)
10+
11+
data Parsed = Parsed {
12+
start :: Node,
13+
nm :: M.Map Node (Node, Node),
14+
dm :: M.Map Node Int,
15+
ny :: Int,
16+
nx :: Int
17+
}
18+
19+
parse :: String -> Parsed
20+
parse = mkParsed . chunks . lines
21+
where
22+
mkParsed ck@((h, _, _):_) = let (s, nb) = ensureStart (neighbours ck)
23+
in Parsed { start = s, nm = nb, dm = mkDistanceMap s nb,
24+
ny = length ck, nx = length h }
25+
chunks ls = let g = ground ls in zip3 (g : ls) ls (drop 1 ls ++ [g])
26+
ground (h:_) = length h `replicate` '.'
27+
enum = zip [0..]
28+
neighbours ck = foldl f (Nothing, M.empty) (enum ck) where
29+
f m (y, (p, c, n)) = foldl g m (enum c) where
30+
g :: (Maybe Node, M.Map Node (Node, Node)) -> (Int, Char) -> (Maybe Node, M.Map Node (Node, Node))
31+
g r (x, '.') = r
32+
g (_, m) (x, 'S') = let k = (y, x) in
33+
(Just k, case neighboursOfStart (p, c, n) 'S' k of
34+
(Just n1, Just n2) -> M.insert k (n1, n2) m)
35+
g (s, m) (x, i ) = let k = (y, x) in
36+
case neighbour (p, c, n) i k of
37+
(Just n1, Just n2) -> (s, M.insert k (n1, n2) m)
38+
_ -> (s, m)
39+
neighbour :: (String, String, String) -> Char -> (Int, Int) -> (Maybe (Int, Int), Maybe (Int, Int))
40+
neighbour (p, c, n) '|' k = (north p k, south n k)
41+
neighbour (p, c, n) '-' k = (west c k, east c k)
42+
neighbour (p, c, n) 'L' k = (north p k, east c k)
43+
neighbour (p, c, n) 'J' k = (north p k, west c k)
44+
neighbour (p, c, n) '7' k = (south n k, west c k)
45+
neighbour (p, c, n) 'F' k = (south n k, east c k)
46+
north p (y, x) = if p !! x `notElem` "|F7S" then Nothing else Just (y - 1, x)
47+
south n (y, x) = if n !! x `notElem` "|LJS" then Nothing else Just (y + 1, x)
48+
west c (y, x) = if x == 0 || c !! (x - 1) `notElem` "-LFS" then Nothing
49+
else Just (y, x - 1)
50+
east c (y, x) = if x + 1 == length c || c !! (x + 1) `notElem` "-J7S" then Nothing
51+
else Just (y, x + 1)
52+
neighboursOfStart :: (String, String, String) -> Char -> (Int, Int) -> (Maybe (Int, Int), Maybe (Int, Int))
53+
neighboursOfStart (p, c, n) _ (y, x) = case catMaybes [
54+
if p !! x `elem` "|F7" then Just (y - 1, x) else Nothing,
55+
if n !! x `elem` "|LJ" then Just (y + 1, x) else Nothing,
56+
if x > 0 && c !! (x - 1) `elem` "-LF" then Just (y, x - 1) else Nothing,
57+
if x + 1 < length c && c !! (x + 1) `elem` "-J7" then Just (y, x + 1) else Nothing
58+
] of
59+
[a, b] -> (Just a, Just b)
60+
ensureStart (Just s, m) = (s, m)
61+
ensureStart _ = error "input does not contain a start node"
62+
63+
mkDistanceMap :: Node -> M.Map Node (Node, Node) -> M.Map Node Int
64+
mkDistanceMap start neighbours = relax (dm0 start) [start]
65+
where
66+
dm0 s = M.singleton start 0
67+
relax :: M.Map Node Int -> [Node] -> M.Map Node Int
68+
relax dm [] = dm
69+
relax dm (key:q) = case (M.lookup key dm, M.lookup key neighbours) of
70+
(Just dist, Just (n1, n2)) ->
71+
let (dm', q') = relaxNeighbour n1 dm q dist in
72+
(let (dm'', q'') = relaxNeighbour n2 dm' q' dist in relax dm'' q'')
73+
relaxNeighbour nn dm q dist = case M.lookup nn dm of
74+
Nothing -> (M.insert nn (dist + 1) dm, q ++ [nn])
75+
Just d -> if dist + 1 < d then (M.insert nn (dist + 1) dm, q ++ [nn]) else (dm, q)
76+
77+
p1 :: Parsed -> Int
78+
p1 Parsed { dm } = maximum $ M.elems dm
79+
80+
data Grid = Grid { gm :: M.Map Node Char, gny :: Int, gnx :: Int }
81+
82+
mkGrid :: [String] -> Int -> Int -> Grid
83+
mkGrid ls ny nx = Grid { gm = mkGridMap ls, gny = ny, gnx = nx }
84+
85+
p2 :: Parsed -> Int
86+
p2 = countEmpty . gm . collapse . flood . expand
87+
where countEmpty = length . M.elems . M.filter (== '?')
88+
89+
mkGridMap :: [String] -> M.Map Node Char
90+
mkGridMap = foldl f M.empty . enum
91+
where
92+
f m (y, row) = foldl (g y) m (enum row)
93+
g y m (x, c) = M.insert (y, x) c m
94+
enum = zip [0..]
95+
96+
expand :: Parsed -> Grid
97+
expand Parsed { nm, dm, ny, nx } =
98+
Grid { gm = mkGridMap expandLines, gny = eny, gnx = enx }
99+
where
100+
keys = M.keys dm
101+
eny = 3 * (ny + 2)
102+
enx = 3 * (nx + 2)
103+
expandLines = addBoundaryLines $ concatMap (addBoundary . expandRow) [0..ny-1]
104+
expandRow y =
105+
foldr (\(c1, c2, c3) ([l1, l2, l3]) -> [c1 ++ l1, c2 ++ l2, c3 ++ l3])
106+
[[], [], []] (expandRow' y)
107+
expandRow' y = map (\x -> expandCell (y, x)) [0..nx-1]
108+
expandCell key | key `elem` keys = expandCell' key (M.lookup key nm)
109+
| otherwise = ("???", "???", "???")
110+
expandCell' key@(y, x) (Just (n1, n2))
111+
| n1 == (y, x - 1) && n2 == (y, x + 1) = ("???", "---", "???")
112+
| n1 == (y - 1, x) && n2 == (y, x - 1) = ("?|?", "-J?", "???")
113+
| n1 == (y + 1, x) && n2 == (y, x - 1) = ("???", "-7?", "?|?")
114+
| n1 == (y + 1, x) && n2 == (y, x + 1) = ("???", "?F-", "?|?")
115+
| n1 == (y - 1, x) && n2 == (y, x + 1) = ("?|?", "?L-", "???")
116+
| n1 == (y - 1, x) && n2 == (y + 1, x) = ("?|?", "?|?", "?|?")
117+
boundaryLine = enx `replicate` '#'
118+
addBoundary = map (\s -> "###" ++ s ++ "###")
119+
addBoundaryLines ls = let bs = 3 `replicate` boundaryLine in bs ++ ls ++ bs
120+
121+
flood :: Grid -> Grid
122+
flood Grid { gm, gny, gnx } = Grid { gm = go gm, gny = gny, gnx = gnx }
123+
where
124+
go gm = case step gm of
125+
(0, gm') -> gm'
126+
(_, gm') -> go gm'
127+
step m = M.mapAccumWithKey f 0 m
128+
where
129+
f changed key '?' | any (=='#') (nbr key) = (changed + 1, '#')
130+
f changed key ch = (changed, ch)
131+
nbr (y,x) = catMaybes $ map (`M.lookup` m) [
132+
(y, x - 1), (y - 1, x), (y, x + 1), (y + 1, x)]
133+
134+
collapse :: Grid -> Grid
135+
collapse Grid { gm, gny, gnx } = Grid { gm = cm, gny = cny, gnx = cnx }
136+
where
137+
cny = (gny `div` 3) - 2
138+
cnx = (gnx `div` 3) - 2
139+
cm = M.foldrWithKey f M.empty gm
140+
f key@(y, x) ch m
141+
| isNotBoundary key && y `mod` 3 == 0 && x `mod` 3 == 0 =
142+
M.insert ((y - 3) `div` 3, (x - 3) `div` 3) (g key gm) m
143+
| otherwise = m
144+
isNotBoundary (y, x) = y > 2 && y < gny - 3 && x > 2 && x < gnx - 3
145+
g (y, x) m = fromJust $ M.lookup (y+1, x+1) m

‎10.wip.hs renamed to ‎10.vis.hs

Lines changed: 4 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,9 @@
11
import Data.Bifunctor (first, second)
22
import Data.Map qualified as M
33
import Data.Maybe (catMaybes, fromJust)
4-
import Control.Arrow ((&&&))
54

65
main :: IO ()
7-
-- main = interact $ (++ "\n") . fst . p2v . parse
8-
main = interact $ (++ "\n") . show . (p1 &&& p2) . parse
6+
main = interact $ (++ "\n") . p2v . parse
97

108
type Node = (Int, Int)
119

@@ -59,12 +57,6 @@ parse = mkParsed . chunks . lines
5957
ensureStart (Just s, m) = (s, m)
6058
ensureStart _ = error "input does not contain a start node"
6159

62-
p1 :: Parsed -> Int
63-
p1 Parsed { start, nm } = p1' (start, nm)
64-
65-
p1' :: (Node, M.Map Node (Node, Node)) -> Int
66-
p1' = maximum . M.elems . mkDistanceMap
67-
6860
mkDistanceMap :: (Node, M.Map Node (Node, Node)) -> (M.Map Node Int)
6961
mkDistanceMap (start, neighbours) = relax (dm0 start) [start]
7062
where
@@ -87,20 +79,16 @@ instance Show Grid where
8779
mkGrid :: [String] -> Int -> Int -> Grid
8880
mkGrid ls ny nx = Grid { gm = mkGridMap ls, gny = ny, gnx = nx }
8981

90-
p2 :: Parsed -> Int
91-
p2 = snd . p2v
92-
93-
p2v :: Parsed -> (String, Int)
82+
p2v :: Parsed -> String
9483
p2v pr@Parsed { start, nm, ny, nx } =
95-
(show og ++ show eg ++ unlines log ++ show fg ++ show cg ++ resultL (gm cg),
96-
countEmpty (gm cg))
84+
show og ++ show eg ++ unlines log ++ show fg ++ show cg ++ result (gm cg)
9785
where
9886
dm = mkDistanceMap (start, nm)
9987
og = reconstruct pr dm
10088
eg = expand pr dm
10189
(log, fg) = flood eg
10290
cg = collapse fg
103-
resultL m = "inside " ++ show (countEmpty m)
91+
result m = "inside " ++ show (countEmpty m)
10492
countEmpty = length . M.elems . M.filter (== inside)
10593

10694
mkGridMap :: [String] -> M.Map Node Char

0 commit comments

Comments
 (0)