16/one.icl

   1 module one
   2
   3 import StdEnv
   4 import Data.Tuple
   5 import Data.Either
   6 import Data.Func
   7 import Data.List
   8 import Text => qualified join
   9 import Data.Functor
  10 import Control.Applicative
  11 import Control.Monad
  12 import Text.Parsers.Simple.ParserCombinators
  13 from Data.Set import :: Set
  14 import qualified Data.Set as DS
  15
  16 read :: *File -> [Char]
  17 read f
  18         # (ok, c, f) = freadc f
  19         | not ok = []
  20         = [c:read f]
  21
  22 Start w
  23         # (io, w) = stdio w
  24         # (Right (fields, myticket, nearby)) = parse parseInput (read io)
  25         # nearby = filter (not o isEmpty) nearby
  26         = (one fields nearby, two fields myticket nearby)
  27
  28 one :: [([Char], [Int])] -> ([[Int]] -> Int)
  29 one fields = sum o flatten o map (filter \e->not $ isMember e $ flatten $ map snd fields)
  30
  31 valid fields = isEmpty o filter \e->not $ isMember e $ flatten $ map snd fields
  32
  33 // for every ticket, for every field, every option
  34 two :: [([Char], [Int])] [Int] [[Int]] -> Int
  35 two fields myticket nearby
  36         // Translate to numbers and multiply
  37         = prod $ zipWith (\i [s]->if (startsWith ['departure'] s) i 1) myticket
  38         // iteratively find all singletons and apply constraint
  39         $ proc []
  40         // Transpose and merge all fieldconstraints
  41         $ map (\[x:xs]->foldr intersect x xs) $ transpose
  42         // Remove all invalid fields
  43         $ map (collectConstraints fields)
  44         // Remove all invalid tickets
  45         $ filter (valid fields) nearby
  46 where
  47         collectConstraints :: [([Char], [Int])] [Int] -> [[[Char]]]
  48         collectConstraints fields fs = map collectConstraint fs
  49         where
  50                 collectConstraint :: Int -> [[Char]]
  51                 collectConstraint num = [f\\(f, rng)<-fields | isMember num rng]
  52
  53         proc :: [[[Char]]] [[[Char]]] -> [[[Char]]]
  54         proc had [[x]:todo] = proc [[x]:map (filter ((<>)x)) had] $ map (filter ((<>)x)) todo
  55         proc had [x:todo] = proc [x:had] todo
  56         proc had [] = if (any ((<>) 1 o length) had) (proc [] had) had
  57
  58 parseInput :: Parser Char ([([Char], [Int])], [Int], [[Int]])
  59 parseInput = tuple3 <$> many pField
  60         <* pStr ['\nyour ticket:\n'] <*> pSepBy pInt pComma <* pToken '\n'
  61         <* pStr ['\nnearby tickets:\n'] <*> pSepBy (pSepBy pInt pComma) (pToken '\n')
  62 where
  63         pField :: Parser Char ([Char], [Int])
  64         pField = tuple <$> many (pSatisfy (\c->isAlpha c || c == ' ')) <* pStr [': '] <*> pRange <* pToken '\n'
  65         where
  66                 pRange :: Parser Char [Int]
  67                 pRange = flatten <$> pSepBy ((\x y->[x..y]) <$> pInt <* pToken '-' <*> pInt) (pStr [' or '])
  68
  69         pInt :: Parser Char Int
  70         pInt = toInt o toString <$> some pDigit
  71
  72         pStr :: ([Char] -> Parser Char [Char])
  73         pStr = sequence o map pToken