diff --git a/src/Day2508.hs b/src/Day2508.hs
new file mode 100644
index 0000000..8587102
--- /dev/null
+++ b/src/Day2508.hs
@@ -0,0 +1,64 @@
+{-
+
+< BENCHMARK RESULTS HERE >
+
+-}
+
+module Main where
+
+import Debug.Trace
+import Data.Maybe (isNothing, fromMaybe, isJust, fromJust)
+import Data.List (find, tails, delete, minimumBy, nub, sort, sortOn)
+import Data.List.Split (splitOn)
+
+import Data.Set qualified as Set
+import Data.Set (Set)
+
+pairs :: [a] -> [(a,a)]
+pairs l = [(x,y) | (x:ys) <- tails l, y <- ys]
+
+type Coord = (Int, Int, Int)
+type Pair = (Coord, Coord)
+
+dist :: Pair -> Int
+dist ((a,b,c), (d,e,f)) = (d-a)^2 + (e-b)^2 + (f-c)^2
+
+part1 :: String -> Int
+part1 str = go 1000 (sortOn dist $ pairs coords) $ map (\n -> Set.fromList [n]) coords
+  where
+  coords = map ((\[x,y,z] -> (read x, read y, read z)) . splitOn ",") $ lines str
+
+  go :: Int -> [Pair] -> [Set Coord] -> Int
+  go 0 pairs            graphs = product $ map Set.size $ take 3 $ sortOn ((*(-1)) . Set.size) graphs
+  go n ((start,end):xs) graphs | isJust theSame = go (n-1) xs graphs
+                               | otherwise      = go (n-1) xs graphs'
+    where
+    theSame = find (\s -> Set.member start s && Set.member end s) graphs
+    startSet = fromJust $ find (Set.member start) graphs
+    endSet   = fromJust $ find (Set.member end  ) graphs
+
+    graphs' = Set.union startSet endSet : (delete startSet (delete endSet graphs))
+
+part2 :: String -> Int
+part2 str = go (sortOn dist $ pairs coords) $ map (\n -> Set.fromList [n]) coords
+  where
+  coords = map ((\[x,y,z] -> (read x, read y, read z)) . splitOn ",") $ lines str
+
+  go :: [Pair] -> [Set Coord] -> Int
+  go ((start,end):xs) graphs | isJust theSame   = go xs graphs
+                             | otherwise        = if length graphs' == 1 then x1*x2 else go xs graphs'
+    where
+    (x1,_,_) = start
+    (x2,_,_) = end
+    theSame = find (\s -> Set.member start s && Set.member end s) graphs
+    startSet = fromJust $ find (Set.member start) graphs
+    endSet   = fromJust $ find (Set.member end  ) graphs
+
+    graphs' = Set.union startSet endSet : (delete startSet (delete endSet graphs))
+
+main :: IO ()
+main = do
+  str <- getContents
+
+  print $ part1 str
+  print $ part2 str