Skip to main content
deleted 5 characters in body
Source Link

 
 

 
 
Source Link


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