cleaned up a little
This commit is contained in:
		
							parent
							
								
									30c272f283
								
							
						
					
					
						commit
						170d7b09b8
					
				
							
								
								
									
										58
									
								
								day7.hs
									
									
									
									
									
								
							
							
						
						
									
										58
									
								
								day7.hs
									
									
									
									
									
								
							| 
						 | 
				
			
			@ -11,38 +11,55 @@ main :: IO ()
 | 
			
		|||
main = do
 | 
			
		||||
  raw <- readFile "day7.txt"
 | 
			
		||||
  let bags = validate $ map (parse lineP []) $ lines raw
 | 
			
		||||
      ansA = pred $ length $ filter (\x -> (snd x) == True)
 | 
			
		||||
                $ loeb $ map loebifyA bags
 | 
			
		||||
      ansB = pred $ unMaybe $ lookup "shiny gold"
 | 
			
		||||
                $ loeb $ map loebifyB bags
 | 
			
		||||
      ansA = solveA bags
 | 
			
		||||
      ansB = solveB bags
 | 
			
		||||
   in do
 | 
			
		||||
     putStrLn $ "day7a: " ++ (show ansA)
 | 
			
		||||
     putStrLn $ "day7b: " ++ (show ansB)
 | 
			
		||||
 | 
			
		||||
loeb :: Functor f => f (f a -> a) -> f a
 | 
			
		||||
loeb x = go where go = fmap ($ go) x
 | 
			
		||||
solveA :: [Bag] -> Int
 | 
			
		||||
solveA bs = pred
 | 
			
		||||
       $ length
 | 
			
		||||
       $ filter (== True)
 | 
			
		||||
       $ map snd
 | 
			
		||||
       $ loeb
 | 
			
		||||
       $ map loebifyA bs
 | 
			
		||||
 | 
			
		||||
loebifyA :: Bag -> ([(Label, Bool)] -> (Label, Bool))
 | 
			
		||||
solveB :: [Bag] -> Int
 | 
			
		||||
solveB bs = pred
 | 
			
		||||
       $ unsafeLookup "shiny gold"
 | 
			
		||||
       $ loeb
 | 
			
		||||
       $ map loebifyB bs
 | 
			
		||||
 | 
			
		||||
loeb :: Functor f => f (f a -> a) -> f a
 | 
			
		||||
loeb x = go
 | 
			
		||||
  where
 | 
			
		||||
    go = fmap ($ go) x
 | 
			
		||||
 | 
			
		||||
loebifyA :: Bag -> [(Label, Bool)] -> (Label, Bool)
 | 
			
		||||
loebifyA (Bag "shiny gold" _) = const ("shiny gold", True)
 | 
			
		||||
loebifyA (Bag l bs) =
 | 
			
		||||
  (\ls -> (l, or (unMaybes (map (\f -> f ls) (map lookupify bs)))))
 | 
			
		||||
  (\ls -> (l, or [f ls | f <- innerbags]))
 | 
			
		||||
  where
 | 
			
		||||
    lookupify (_,s) = lookup s
 | 
			
		||||
    lookupify = unsafeLookup . snd
 | 
			
		||||
    innerbags = map lookupify bs
 | 
			
		||||
 | 
			
		||||
loebifyB :: Bag -> ([(Label, Int)] -> (Label, Int))
 | 
			
		||||
loebifyB (Bag l []) = const (l, 1)
 | 
			
		||||
loebifyB (Bag l bs) =
 | 
			
		||||
  (\ls -> (l, sum (1:(map (\f -> f ls) (map lookupify bs)))))
 | 
			
		||||
  (\ls -> (l, sum $ 1 : [q*(f ls) | (f,q) <- innerbags]))
 | 
			
		||||
  where
 | 
			
		||||
    lookupify (q,s) = (\ms -> q * (unMaybe $ lookup s ms))
 | 
			
		||||
    lookupify = unsafeLookup . snd
 | 
			
		||||
    innerbags = zip (map lookupify bs)
 | 
			
		||||
                    (map fst bs)
 | 
			
		||||
 | 
			
		||||
unsafeLookup :: Eq a => a -> [(a,b)] -> b
 | 
			
		||||
unsafeLookup k = unMaybe . (lookup k)
 | 
			
		||||
 | 
			
		||||
unMaybe :: Maybe a -> a
 | 
			
		||||
unMaybe Nothing = error "invalid bag label"
 | 
			
		||||
unMaybe (Just v) = v
 | 
			
		||||
 | 
			
		||||
unMaybes :: [Maybe a] -> [a]
 | 
			
		||||
unMaybes = map unMaybe
 | 
			
		||||
 | 
			
		||||
validate :: [Either ParseError Bag] -> [Bag]
 | 
			
		||||
validate [] = []
 | 
			
		||||
validate ((Left _):_) = error "invalid input"
 | 
			
		||||
| 
						 | 
				
			
			@ -57,12 +74,15 @@ lineP = do
 | 
			
		|||
 | 
			
		||||
baglistP :: Parsec String () [(Quantity, Label)]
 | 
			
		||||
baglistP = do
 | 
			
		||||
  ((string "no other bags.") >> return []) <|>
 | 
			
		||||
    (endBy qlabelP $ oneOf [',', '.'] >> whitespaces)
 | 
			
		||||
  ((string "no other bags.") >> return [])
 | 
			
		||||
  <|> (endBy qlabelP
 | 
			
		||||
        $ oneOf [',', '.'] >> whitespaces)
 | 
			
		||||
 | 
			
		||||
initlabelP :: Parsec String () String
 | 
			
		||||
initlabelP = manyTill anyChar
 | 
			
		||||
  (try $ whitespaces >> (string "bags contain") >> whitespaces)
 | 
			
		||||
  (try $ whitespaces
 | 
			
		||||
      >> (string "bags contain")
 | 
			
		||||
      >> whitespaces)
 | 
			
		||||
 | 
			
		||||
whitespaces :: Parsec String () String
 | 
			
		||||
whitespaces = many $ char ' '
 | 
			
		||||
| 
						 | 
				
			
			@ -76,4 +96,6 @@ qlabelP = do
 | 
			
		|||
 | 
			
		||||
labelP :: Parsec String () String
 | 
			
		||||
labelP = manyTill anyChar
 | 
			
		||||
  (try $ whitespaces >> (string "bag") >> optional (char 's'))
 | 
			
		||||
  (try $ whitespaces
 | 
			
		||||
      >> (string "bag")
 | 
			
		||||
      >> optional (char 's'))
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in a new issue