AdventOfCode 2018 PureScript - Day 7

Main.purs

module Main where

import Prelude
import Effect (Effect)
import Effect.Console (logShow)
import Data.String.Yarn (fromChars, toChars)
import Data.List (List(..), concat, elem, fromFoldable, head, nub, sort, take, (:), (\\))
import Data.Traversable (sequence)
import Partial.Unsafe (unsafePartial)
import Data.Maybe (fromJust, fromMaybe)
import Text.Parsing.StringParser.CodeUnits (string, anyChar)
import Text.Parsing.StringParser (Parser, runParser, ParseError)
import Data.Either (Either)
import Control.MonadZero (guard)
import Control.Apply (lift2)
import Data.Tuple (Tuple(..), snd)
import Data.Char (toCharCode)

input :: List String
input = fromFoldable
  [ "Step S must be finished before step B can begin."
  , "Step B must be finished before step Y can begin."
  , "Step R must be finished before step E can begin."
  , "Step H must be finished before step M can begin."
  , "Step C must be finished before step F can begin."
  , "Step K must be finished before step A can begin."
  , "Step V must be finished before step W can begin."
  , "Step W must be finished before step L can begin."
  , "Step J must be finished before step L can begin."
  , "Step Q must be finished before step A can begin."
  , "Step U must be finished before step L can begin."
  , "Step Y must be finished before step M can begin."
  , "Step T must be finished before step F can begin."
  , "Step D must be finished before step A can begin."
  , "Step I must be finished before step M can begin."
  , "Step O must be finished before step P can begin."
  , "Step A must be finished before step L can begin."
  , "Step P must be finished before step N can begin."
  , "Step X must be finished before step Z can begin."
  , "Step G must be finished before step N can begin."
  , "Step M must be finished before step F can begin."
  , "Step N must be finished before step L can begin."
  , "Step F must be finished before step Z can begin."
  , "Step Z must be finished before step E can begin."
  , "Step E must be finished before step L can begin."
  , "Step O must be finished before step X can begin."
  , "Step B must be finished before step V can begin."
  , "Step H must be finished before step Q can begin."
  , "Step T must be finished before step M can begin."
  , "Step A must be finished before step G can begin."
  , "Step R must be finished before step H can begin."
  , "Step S must be finished before step C can begin."
  , "Step N must be finished before step Z can begin."
  , "Step Z must be finished before step L can begin."
  , "Step Q must be finished before step Z can begin."
  , "Step R must be finished before step G can begin."
  , "Step P must be finished before step Z can begin."
  , "Step U must be finished before step M can begin."
  , "Step W must be finished before step D can begin."
  , "Step F must be finished before step L can begin."
  , "Step D must be finished before step P can begin."
  , "Step I must be finished before step E can begin."
  , "Step M must be finished before step E can begin."
  , "Step H must be finished before step N can begin."
  , "Step F must be finished before step E can begin."
  , "Step D must be finished before step L can begin."
  , "Step C must be finished before step E can begin."
  , "Step H must be finished before step Z can begin."
  , "Step W must be finished before step Q can begin."
  , "Step X must be finished before step E can begin."
  , "Step G must be finished before step M can begin."
  , "Step X must be finished before step M can begin."
  , "Step Y must be finished before step P can begin."
  , "Step S must be finished before step I can begin."
  , "Step P must be finished before step X can begin."
  , "Step S must be finished before step T can begin."
  , "Step I must be finished before step N can begin."
  , "Step P must be finished before step L can begin."
  , "Step C must be finished before step X can begin."
  , "Step I must be finished before step G can begin."
  , "Step O must be finished before step F can begin."
  , "Step I must be finished before step X can begin."
  , "Step C must be finished before step Z can begin."
  , "Step B must be finished before step K can begin."
  , "Step T must be finished before step P can begin."
  , "Step Q must be finished before step X can begin."
  , "Step M must be finished before step N can begin."
  , "Step H must be finished before step O can begin."
  , "Step Q must be finished before step M can begin."
  , "Step U must be finished before step F can begin."
  , "Step Y must be finished before step O can begin."
  , "Step D must be finished before step O can begin."
  , "Step R must be finished before step T can begin."
  , "Step A must be finished before step E can begin."
  , "Step A must be finished before step M can begin."
  , "Step C must be finished before step N can begin."
  , "Step G must be finished before step E can begin."
  , "Step C must be finished before step Y can begin."
  , "Step A must be finished before step Z can begin."
  , "Step S must be finished before step X can begin."
  , "Step V must be finished before step Z can begin."
  , "Step Q must be finished before step I can begin."
  , "Step P must be finished before step E can begin."
  , "Step D must be finished before step F can begin."
  , "Step M must be finished before step Z can begin."
  , "Step U must be finished before step N can begin."
  , "Step Q must be finished before step L can begin."
  , "Step O must be finished before step Z can begin."
  , "Step N must be finished before step E can begin."
  , "Step S must be finished before step W can begin."
  , "Step S must be finished before step O can begin."
  , "Step U must be finished before step T can begin."
  , "Step A must be finished before step P can begin."
  , "Step J must be finished before step I can begin."
  , "Step A must be finished before step F can begin."
  , "Step U must be finished before step D can begin."
  , "Step W must be finished before step X can begin."
  , "Step O must be finished before step L can begin."
  , "Step J must be finished before step D can begin."
  , "Step R must be finished before step Z can begin."
  , "Step O must be finished before step N can begin."
  ]

parseInput :: List String -> Either ParseError (List (Tuple Char Char))
parseInput =
  sequence <<< map (runParser stepParser)

stepParser :: Parser (Tuple Char Char)
stepParser = do
  _ <- string "Step "
  c1 <- anyChar
  _ <- string " must be finished before step "
  c2 <- anyChar
  _ <- string " can begin."
  pure $ Tuple c1 c2

solution1 :: List (Tuple Char Char) -> String
solution1 edges = fromChars $ topSort nodes edges
  where
    nodes = nub $ concat $ do
      Tuple x y <- edges
      pure $ x : y : Nil

topSort :: List Char -> List (Tuple Char Char) -> List Char
topSort Nil   edges = Nil
topSort nodes edges = candidate : topSort newNodes edges
  where newNodes  = nodes \\ candidate : Nil
        candidate = unsafePartial fromJust $ head $ nextTasks edges nodes

nextTasks :: List (Tuple Char Char) -> List Char -> List Char
nextTasks edges nodes =
  sort $ (nodes \\ pointedTo)
  where
    pointedTo = do
      Tuple from to <- edges
      guard $ from `elem` nodes
      pure to

durationOf :: Char -> Int
durationOf = normalize <<< toCharCode
  where normalize i = i - 64 + 60

solution2 :: List (Tuple Char Char) -> String -> Int
solution2 edges nodes = totalDuration edges (toChars nodes) Nil

totalDuration :: List (Tuple Char Char) -> List Char -> List (Tuple Int Char) -> Int
totalDuration edges Nil   Nil  = 0
totalDuration edges nodes works = duration + totalDuration edges newNodes newWork
  where work@(Tuple duration label) = headOr (Tuple 0 '.') $ sort $ works
        newNodes = nodes \\ (label : Nil)
        newWork = take elves $ newWork1 <> newWork2
        newWork1 = map (\(Tuple d l) -> Tuple (d - duration) l) (works \\ (work : Nil))
        newWork2 = map (\c -> Tuple (durationOf c) c) $ (nextTasks edges newNodes \\ map snd works)
        elves = 5

headOr :: Tuple Int Char -> List (Tuple Int Char) -> Tuple Int Char
headOr default xs = fromMaybe default $ head xs

main :: Effect Unit
main = do
  logShow $ enodeOrder
  logShow $ lift2 solution2 einput enodeOrder
  where einput     = parseInput input
        enodeOrder = map solution1 einput