diff --git a/solutions/src/2023/23.hs b/solutions/src/2023/23.hs
index 2ab1800..689b59b 100644
--- a/solutions/src/2023/23.hs
+++ b/solutions/src/2023/23.hs
@@ -1,5 +1,4 @@
-{-# Language LambdaCase, ImportQualifiedPost #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# Language BangPatterns, ImportQualifiedPost #-}
 {-|
 Module      : Main
 Description : Day 23 solution
@@ -9,101 +8,92 @@ Maintainer  : emertens@gmail.com
 
 <https://adventofcode.com/2023/day/23>
 
-A brute-forced approach.
+A brute-forced approach. First extract the graph of
+intersections and then just enumerate all the possible
+paths between them that reach the exit.
 
 -}
 module Main (main) where
 
 import Advent (getInputArray, arrIx)
 import Advent.Coord (cardinal, coordRow, east, north, south, west, Coord(C))
-import Advent.Search (bfs, dfs)
 import Data.Array.Unboxed (bounds, UArray)
-import Data.List (sortBy)
 import Data.Map (Map)
 import Data.Map qualified as Map
-import Data.Ord (comparing)
-import Data.Set (Set)
-import Data.Set qualified as Set
 
 main :: IO ()
 main =
  do input <- getInputArray 2023 23
     let (_, C ymax _) = bounds input
-    let path = [length s | (C y _,s) <- dfs (step input) (C 0 1, Set.empty), y == ymax]
-    print (maximum path)
+    let input1 = buildPaths input part1
+    let input2 = buildPaths input part2
+    print (enum ymax (C 0 1) input1 0)
+    print (enum ymax (C 0 1) input2 0)
 
-    let input' = buildPaths input
-    let solvable here seen =
-          any (\x -> coordRow x == ymax) $
-          bfs (\c -> [next | (next, _) <- Map.findWithDefault [] c input'
-                            , Set.notMember next seen]) here
+enum :: Int -> Coord -> Map Coord [(Coord, Int)] -> Int -> Int
+enum !ymax !here edges !dist
+  | coordRow here == ymax = dist
+  | Just nexts <- Map.lookup here edges
+  = maximum [ enum ymax next edges' (dist + cost)
+            | let edges' = Map.delete here edges
+            , (next, cost) <- nexts
+            ]
+  | otherwise = 0
 
-    let search _ [] = []
-        search best ((C y _, dist, _):xs) | y == ymax = dist : search best xs
-        search best ((here, dist, seen):xs)
-          | Map.findWithDefault (-1) (here, seen) best < dist =
-          search (Map.insert (here,seen) dist best) (
-          [(next, dist+dist1, Set.insert here seen)
-            | (next, dist1) <- sortBy (flip (comparing snd))
-                 (Map.findWithDefault [] here input')
-            , Set.notMember next seen
-            , solvable here seen
-          ] ++ xs)
-          | otherwise = search best xs
-
-    print (maximum (search Map.empty [(C 0 1, 0, Set.empty)]))
-
-buildPaths :: UArray Coord Char -> Map Coord [(Coord, Int)]
-buildPaths input = go [C 0 1] Map.empty
+buildPaths ::
+  UArray Coord Char ->
+  (Char -> Coord -> Bool) ->
+  Map Coord [(Coord, Int)]
+buildPaths input isOpen = go [C 0 1] Map.empty
   where
-    isIntersection c =
-      2 < length [
-        c'
-        | c' <- cardinal c
-        , cell <- arrIx input c'
-        , isOpen cell
-      ] || coordRow c == ymax
+    isIntersection c there =
+      1 < length (exits c there) || coordRow c == ymax
     (_,C ymax _) = bounds input
 
+    exits here there =
+      [
+        next
+        | next <- cardinal here
+        , next /= there
+        , cell <- arrIx input next
+        , isOpen cell (next - here)
+      ]
+
     go [] acc = acc
     go (x:xs) acc
       | Map.member x acc = go xs acc
-      | otherwise = go (map fst ends ++ xs) (Map.insert x ends acc)
+      | otherwise = go (map fst nodes ++ xs) (Map.insert x nodes acc)
       where
-        ends =
-          map (\(p:path) -> (p, length path)) $
-          filter (isIntersection . head) $
-          bfs next [x]
-
-        next (c:_) | c /= x, isIntersection c = []
-        next xxs@(c:cs) =
-          [ c' : xxs
-            | c' <- cardinal c
-            , c' `notElem` cs
-            , cell <- arrIx input c'
-            , isOpen cell
+        nodes =
+          [ out
+            | c <- cardinal x
+            , cell <- arrIx input c
+            , isOpen cell (c - x)
+            , out <- walk c x 1
           ]
-        next [] = undefined
+        walk here there dist
+          | isIntersection here there = [(here, dist)]
+          | otherwise =
+            case exits here there of
+              [] -> []
+              next:_ -> walk next here (dist+1)
 
-step :: UArray Coord Char -> (Coord, Set Coord) -> [(Coord, Set Coord) ]
-step input (c, seen) =
-  [ (c', Set.insert c seen)
-     | c' <- cardinal c
-     , cell <- arrIx input c'
-     , case cell of
-         '.' -> True
-         '>' -> c' - c == east
-         'v' -> c' - c == south
-         '^' -> c' - c == north
-         '<' -> c' - c == west
-         _ -> False
-     , Set.notMember c' seen ]
+part1 :: Char -> Coord -> Bool
+part1 c dir =
+  case c of
+    '.' -> True
+    '>' -> dir == east
+    'v' -> dir == south
+    '^' -> dir == north
+    '<' -> dir == west
+    _   -> False
 
-isOpen :: Char -> Bool
-isOpen = \case
-  '.' -> True
-  '>' -> True
-  'v' -> True
-  '^' -> True
-  '<' -> True
-  _   -> False
+part2 :: Char -> Coord -> Bool
+part2 c _ =
+  case c of
+    '.' -> True
+    '>' -> True
+    'v' -> True
+    '^' -> True
+    '<' -> True
+    _   -> False