diff --git a/advent-of-code-2023.cabal b/advent-of-code-2023.cabal
index 1fdf1de..2277b87 100644
--- a/advent-of-code-2023.cabal
+++ b/advent-of-code-2023.cabal
@@ -159,3 +159,11 @@ executable day22
     build-depends:      base ^>=4.15.1.0, containers, MissingH
     hs-source-dirs:     day22
     default-language:   Haskell2010
+
+executable day23
+    main-is:            Main.hs
+    other-modules:      Commons Part1 Part2
+    build-depends:      base ^>=4.15.1.0, array, containers
+    hs-source-dirs:     day23
+    default-language:   Haskell2010
+    default-extensions: LambdaCase
diff --git a/day23/Commons.hs b/day23/Commons.hs
new file mode 100644
index 0000000..f8d10de
--- /dev/null
+++ b/day23/Commons.hs
@@ -0,0 +1,32 @@
+module Commons where
+
+import GHC.IO.Handle (isEOF)
+import Data.Array (Array, listArray, (!), Ix (inRange), bounds)
+
+
+data Direction = North | South | West | East deriving (Eq, Ord, Show)
+data Tile = Empty | Rock | Slope { direction :: Direction } deriving (Eq, Show)
+type Trails = Array (Int, Int) Tile
+
+
+parseLine :: String -> [Tile]
+parseLine = map (\case
+                  '.' -> Empty
+                  '#' -> Rock
+                  '>' -> Slope {direction = East}
+                  'v' -> Slope {direction = South}
+                  '<' -> Slope {direction = West}
+                  '^' -> Slope {direction = North})
+
+parseTrails :: IO [[Tile]]
+parseTrails = do done <- isEOF
+                 if done
+                    then return []
+                    else do line <- getLine
+                            let trailsLine = parseLine line
+                            trails <- parseTrails
+                            return (trailsLine: trails)
+
+parse :: IO Trails
+parse = do trails <- parseTrails
+           return $ listArray ((1, 1), (length trails, length $ head trails)) $ concat trails
diff --git a/day23/Main.hs b/day23/Main.hs
new file mode 100644
index 0000000..07e9ce6
--- /dev/null
+++ b/day23/Main.hs
@@ -0,0 +1,13 @@
+module Main where
+
+import Commons
+import qualified Part1
+import qualified Part2
+
+
+main = do trailsMap <- parse
+          let part1Res = Part1.getAllTrails trailsMap
+          print $ maximum $ map length part1Res
+          let compactPaths = Part2.getCompactPaths trailsMap part1Res
+          let part2Res = Part2.getAllTrails trailsMap compactPaths
+          print $ maximum $ map (foldl (\ s t -> s + snd t) 0) part2Res
diff --git a/day23/Part1.hs b/day23/Part1.hs
new file mode 100644
index 0000000..b39f267
--- /dev/null
+++ b/day23/Part1.hs
@@ -0,0 +1,31 @@
+module Part1 where
+
+import Commons
+import Data.Array (Ix (inRange), bounds, (!))
+
+
+cleanNext :: Trails -> [(Int, Int)] -> [((Int, Int), Direction)] -> [((Int, Int), Direction)]
+cleanNext tr hist [] = []
+cleanNext tr hist ((ch, dh): t) =
+  if inRange (bounds tr) ch && (tr ! ch == Slope dh || tr ! ch == Empty) && notElem ch hist
+  then (ch, dh): cleanNext tr hist t else cleanNext tr hist t
+
+getNext :: Trails -> [(Int, Int)] -> Direction -> [((Int, Int), Direction)]
+getNext tr ((y, x): t) North = cleanNext tr t [((y - 1, x), North), ((y, x - 1), West), ((y, x + 1), East)]
+getNext tr ((y, x): t) East = cleanNext tr t [((y - 1, x), North), ((y, x + 1), East), ((y + 1, x), South)]
+getNext tr ((y, x): t) South = cleanNext tr t [((y + 1, x), South), ((y, x - 1), West), ((y, x + 1), East)]
+getNext tr ((y, x): t) West = cleanNext tr t [((y - 1, x), North), ((y, x - 1), West), ((y + 1, x), South)]
+
+getNextTrails' :: Trails -> (Int, Int) -> (Int, Int) -> [(Int, Int)] -> [((Int, Int), Direction)] -> [[(Int, Int)]]
+getNextTrails' _ _ _ _ [] = []
+getNextTrails' tr f s hist ((ch, dh): t)
+  | ch == f   = hist: getNextTrails' tr f ch hist t
+  | otherwise = getNextTrails tr f ch (ch: hist) dh ++ getNextTrails' tr f ch hist t
+
+getNextTrails :: Trails -> (Int, Int) -> (Int, Int) -> [(Int, Int)] -> Direction -> [[(Int, Int)]]
+getNextTrails tr f s hist d = let next = getNext tr hist d
+                              in getNextTrails' tr f s hist next
+
+getAllTrails :: Trails -> [[(Int, Int)]]
+getAllTrails tr = let ((yMin, xMin), (yMax, xMax)) = bounds tr
+                  in getNextTrails tr (yMax, xMax - 1) (yMin, xMin + 1) [(yMin, xMin + 1)] South
diff --git a/day23/Part2.hs b/day23/Part2.hs
new file mode 100644
index 0000000..53c7102
--- /dev/null
+++ b/day23/Part2.hs
@@ -0,0 +1,68 @@
+module Part2 where
+
+import Commons
+import Data.Array (Ix (inRange), bounds, (!))
+import qualified Data.Map as M
+
+
+type CompactPaths = M.Map ((Int, Int), Direction) ((Int, Int), Direction, Int)
+
+
+invertDirection :: Direction -> Direction
+invertDirection North = South
+invertDirection East = West
+invertDirection South = North
+invertDirection West = East
+
+findCompactPaths :: Trails -> [(Int, Int)] -> (Int, Int) -> Direction -> Int -> CompactPaths
+findCompactPaths _ [(yF, xF)] (y, x) d n =
+  let iD = invertDirection d
+  in M.insert ((yF, xF), South) ((y, x), d, n + 1) $ M.singleton ((y, x), iD) ((yF, xF), North, n + 1)
+findCompactPaths tr ((yF, xF): t) (y, x) d n
+  | let t = tr ! (yF, xF) in t /= Empty && t /= Rock =
+      let Slope nD = tr ! (yF, xF)
+          iD = invertDirection d
+          iND = invertDirection nD
+      in if n <= 2 then findCompactPaths tr t (yF, xF) nD 1
+         else M.union (M.insert ((yF, xF), nD) ((y, x), d, n + 1) $ M.singleton ((y, x), iD) ((yF, xF), iND, n + 1))
+                      $ findCompactPaths tr t (yF, xF) nD 1
+  | otherwise = findCompactPaths tr t (y, x) d (n + 1)
+
+getCompactPaths :: Trails -> [[(Int, Int)]] -> CompactPaths
+getCompactPaths _ [] = M.empty
+getCompactPaths tr (h: t) = let (y, x) = head h
+                            in M.union (getCompactPaths tr t) $ findCompactPaths tr h (y + 1, x) North 0
+
+
+cleanNext :: Trails -> CompactPaths -> [(Int, Int)] -> [((Int, Int), Direction)] -> [((Int, Int), Direction, Int)]
+cleanNext _ _ _ [] = []
+cleanNext tr cp hist ((ch, dh): t) =
+  if inRange (bounds tr) ch && (tr ! ch /= Rock) && notElem ch hist
+  then let actualNext = M.lookup (ch, dh) cp
+       in case actualNext of
+               Just v -> v: cleanNext tr cp hist t
+               _      -> (ch, dh, 1): cleanNext tr cp hist t
+  else cleanNext tr cp hist t
+
+getNext :: Trails -> CompactPaths -> [(Int, Int)] -> Direction -> [((Int, Int), Direction, Int)]
+getNext tr cp ((y, x): t) North = cleanNext tr cp t [((y - 1, x), North), ((y, x - 1), West), ((y, x + 1), East)]
+getNext tr cp ((y, x): t) East = cleanNext tr cp t [((y - 1, x), North), ((y, x + 1), East), ((y + 1, x), South)]
+getNext tr cp ((y, x): t) South = cleanNext tr cp t [((y + 1, x), South), ((y, x - 1), West), ((y, x + 1), East)]
+getNext tr cp ((y, x): t) West = cleanNext tr cp t [((y - 1, x), North), ((y, x - 1), West), ((y + 1, x), South)]
+
+getNextTrails' :: Trails -> CompactPaths -> (Int, Int) -> (Int, Int) -> [((Int, Int), Int)] ->
+                  [((Int, Int), Direction, Int)] -> [[((Int, Int), Int)]]
+getNextTrails' _ _ _ _ _ [] = []
+getNextTrails' tr cp f s hist ((ch, dh, nh): t)
+  | ch == f   = ((ch, nh): hist): getNextTrails' tr cp f ch hist t
+  | otherwise = getNextTrails tr cp f ch ((ch, nh): hist) dh ++ getNextTrails' tr cp f ch hist t
+
+getNextTrails :: Trails -> CompactPaths -> (Int, Int) -> (Int, Int) -> [((Int, Int), Int)] -> Direction ->
+                 [[((Int, Int), Int)]]
+getNextTrails tr cp f s hist d = let histWithoutDist = map fst hist
+                                     next = getNext tr cp histWithoutDist d
+                                 in getNextTrails' tr cp f s hist next
+
+getAllTrails :: Trails -> CompactPaths -> [[((Int, Int), Int)]]
+getAllTrails tr cp = let ((yMin, xMin), (yMax, xMax)) = bounds tr
+                     in getNextTrails tr cp (yMax, xMax - 1) (yMin - 1, xMin + 1) [((yMin - 1, xMin + 1), 0)] South