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 Data.Functor
   9 import Control.Applicative
  10 import Control.Monad
  11 import Text.Parsers.Simple.ParserCombinators
  12 from Data.Set import :: Set
  13 import qualified Data.Set as DS
  14
  15 read :: *File -> [Char]
  16 read f
  17         # (ok, c, f) = freadc f
  18         | not ok = []
  19         = [c:read f]
  20
  21 Start w
  22         # (io, w) = stdio w
  23         # (Right (fields, myticket, nearby)) = parse parseInput (read io)
  24         # nearby = filter (not o isEmpty) nearby
  25         = (one fields nearby, two fields myticket nearby)
  26
  27 one fields = sum o flatten o map (filter \e->not $ isMember e $ flatten $ map snd fields)
  28
  29 valid fields = isEmpty o filter \e->not $ isMember e $ flatten $ map snd fields
  30
  31 foldr1 f [x:xs] = foldr f x xs
  32 foldr1 f [] = []
  33
  34 intersect` [] xs = xs
  35 intersect` xs [] = xs
  36 intersect` ys xs = intersect ys xs
  37
  38 // for every ticket, for every field, every option
  39 //two :: [([Char],[Int])] a [[Int]] -> [[[String]]]
  40 two fields myticket nearby = (\x->proc x x [] []) $ map (foldr1 intersect) $ transpose $ map (collectConstraints fields) $ filter (valid fields) nearby
  41 where
  42         //Per field show all options for the field
  43         collectConstraints :: [([Char], [Int])] [Int] -> [[String]]
  44         collectConstraints fields fs = map collectConstraint fs
  45         where
  46                 //For a field, return the possible fields
  47                 collectConstraint :: Int -> [String]
  48                 collectConstraint num = [toString f\\(f, rng)<-fields | isMember num rng]
  49
  50         proc :: [[String]] [[String]] [String] [[String]] -> [[String]]
  51         proc orig [[x:xs]:xxs] acc accum = proc orig (map (filter ((<>)x)) xxs) [x:acc] $ proc orig [xs:xxs] acc accum
  52         proc orig [[]:xxs] acc accum = proc orig xxs acc accum
  53         proc orig [] acc accum = if (valid orig (reverse acc)) [acc:accum] accum
  54         where
  55                 valid :: [[String]] [String] -> Bool
  56                 valid [x:xs] [y:ys]
  57                         | isMember y x = valid xs ys
  58                 valid [] [] = True
  59                 valid _ _ = False
  60
  61 parseInput :: Parser Char ([([Char], [Int])], [Int], [[Int]])
  62 parseInput = tuple3 <$> many pField
  63         <* pStr ['\nyour ticket:\n'] <*> pSepBy pInt pComma <* pToken '\n'
  64         <* pStr ['\nnearby tickets:\n'] <*> pSepBy (pSepBy pInt pComma) (pToken '\n')
  65 where
  66         pField :: Parser Char ([Char], [Int])
  67         pField = tuple <$> many (pSatisfy (\c->isAlpha c || c == ' ')) <* pStr [': '] <*> pRange <* pToken '\n'
  68         where
  69                 pRange :: Parser Char [Int]
  70                 pRange = flatten <$> pSepBy ((\x y->[x..y]) <$> pInt <* pToken '-' <*> pInt) (pStr [' or '])
  71
  72         pInt :: Parser Char Int
  73         pInt = toInt o toString <$> some pDigit
  74
  75         pStr :: ([Char] -> Parser Char [Char])
  76         pStr = sequence o map pToken