Simplification
In path
, notice how the code gets more nested as you try each possible path (either from start to end, or end to start, or from end to root and root to start). You can use the Alternative instance for Maybe
to simplify this code:
let maybeStartEndPath = pathFromRoot childrenMap start end
maybeEndStartPath = pathFromRoot childrenMap end start
maybeRootPath = [...] -- see below
in
maybeStartEndPath
<|> fmap reverse maybeEndStartPath
<|> maybeRootPath
This code will try maybeStartEndPath
first. If it returns Nothing
, it will move on to the next option and so on.
For your final case (which I've named maybeRootPath
), you do the following check:
if isNothing rootPathToStart || isNothing rootPathToEnd
then Nothing
else connectedPath (fromJust rootPathToStart) (fromJust rootPathToEnd)
This is more consicely done with liftA2
from Control.Applicative
. liftA2
lifts a binary function into an applicative context:
λ :set -XTypeApplications
λ :t liftA2 @Maybe
liftA2 @Maybe :: (a -> b -> c) -> (Maybe a -> Maybe b -> Maybe c)
Then, if either argument is Nothing
, the function will return Nothing
without having to pattern match. So we can fill in maybeRootPath
above with
maybeRootPath = join $ liftA2 connectedPath rootPathToStart rootPathToEnd
where
rootPathToStart = pathFromRoot childrenMap root start
rootPathToEnd = pathFromRoot childrenMap root end
The join
is needed because connectedPath
returns a Maybe
already, and we've lifted it into Maybe
, which leaves us with a return value of Maybe (Maybe [a])
. join
flattens nested monads, bringing us back to Maybe [a]
Minor points
Your function applyToSecondElement
is second
from Control.Arrow
λ :t second @(->)
second @(->) :: (b -> c) -> (d, b) -> (d, c)
toSingleElementList
can also be written as (:[])
or return
So orbitMap
can be written
orbitMap = Map.fromListWith (++) . map (second (:[]))
To your credit, your naming made both of these functions clear anyway, but it's more recognizable if you use functions that already exist.
Algorithm
I was going to suggest keeping each edge bidirectional instead of one-directional, so that you can directly check for a path from start to end instead of checking 3 cases. After reviewing the code, I think your approach is better from a functional perspective because it eliminates the need for you to check for cycles and keep a set as you search the graph. Good work.
Revised Code
import Control.Applicative
import Control.Monad
import Control.Arrow
import System.IO
import Data.List.Split
import Data.List
import Data.Maybe
import Data.Hashable
import qualified Data.HashMap.Strict as Map
main :: IO ()
main = do
inputText <- readFile "Advent20191206_1_input.txt"
let orbitList = catMaybes $ (map orbit . lines) inputText
let orbits = orbitMap orbitList
let pathToSanta = fromJust $ path orbits "COM" "YOU" "SAN"
let requiredTransfers = length pathToSanta - 3
print requiredTransfers
type OrbitSpecification = (String,String)
type ChildrenMap a = Map.HashMap a [a]
children :: (Eq a, Hashable a) => ChildrenMap a -> a -> [a]
children childrenMap = fromMaybe [] . flip Map.lookup childrenMap
orbit :: String -> Maybe OrbitSpecification
orbit str =
case orbit_specification of
[x,y] -> Just (x, y)
_ -> Nothing
where orbit_specification = splitOn ")" str
orbitMap :: [OrbitSpecification] -> ChildrenMap String
orbitMap = Map.fromListWith (++) . map (second (:[]))
childrenAggregate :: (Eq a, Hashable a) => ([a] -> b) -> ChildrenMap a -> a -> b
childrenAggregate aggregatorFnc childrenMap = aggregatorFnc . children childrenMap
decendantAggregate :: (Eq a, Hashable a) => (b -> b -> b) -> (ChildrenMap a -> a -> b) -> ChildrenMap a -> a -> b
decendantAggregate resultFoldFnc nodeFnc childrenMap node =
foldl' resultFoldFnc nodeValue childResults
where
nodeValue = nodeFnc childrenMap node
childFnc = decendantAggregate resultFoldFnc nodeFnc childrenMap
childResults = map childFnc $ children childrenMap node
childrenCount :: (Eq a, Hashable a) => ChildrenMap a -> a -> Int
childrenCount = childrenAggregate length
decendantCount :: (Eq a, Hashable a) => ChildrenMap a -> a -> Int
decendantCount = decendantAggregate (+) childrenCount
totalDecendantCount :: (Eq a, Hashable a) => ChildrenMap a -> a -> Int
totalDecendantCount = decendantAggregate (+) decendantCount
pathFromRoot :: (Eq a, Hashable a) => ChildrenMap a -> a -> a -> Maybe [a]
pathFromRoot childrenMap root destination
| destination == root = Just [root]
| null childPaths = Nothing
| otherwise = Just $ root:(head childPaths)
where
rootChildren = children childrenMap root
pathFromNewRoot newRoot = pathFromRoot childrenMap newRoot destination
childPaths = mapMaybe pathFromNewRoot rootChildren
path :: (Eq a, Hashable a) => ChildrenMap a -> a -> a -> a -> Maybe [a]
path childrenMap root start end =
let maybeStartEndPath = pathFromRoot childrenMap start end
maybeEndStartPath = pathFromRoot childrenMap end start
maybeRootPath = join $ liftA2 connectedPath rootPathToStart rootPathToEnd
where
rootPathToStart = pathFromRoot childrenMap root start
rootPathToEnd = pathFromRoot childrenMap root end
in
maybeStartEndPath
<|> fmap reverse maybeEndStartPath
<|> maybeRootPath
connectedPath :: Eq a => [a] -> [a] -> Maybe [a]
connectedPath rootToStart rootToEnd =
case pathPieces of
Nothing -> Nothing
Just (middle, middleToStart, middleToEnd) ->
Just $ (reverse middleToStart) ++ [middle] ++ middleToEnd
where pathPieces = distinctPathPieces rootToStart rootToEnd
distinctPathPieces :: Eq a => [a] -> [a] -> Maybe (a, [a], [a])
distinctPathPieces [x] [y] = if x == y then Just (x, [], []) else Nothing
distinctPathPieces (x1:y1:z1) (x2:y2:z2)
| x1 /= x2 = Nothing
| y1 /= y2 = Just (x1, y1:z1, y2:z2)
| otherwise = distinctPathPieces (y1:z1) (y2:z2)
distinctPathPieces _ _ = Nothing