#! /usr/bin/env -S"GHCRTS=-N4" nix-shell #! nix-shell -p ghcid #! nix-shell -p "haskellPackages.ghcWithPackages (p: with p; [pretty-simple attoparsec arithmoi containers parallel semirings])" #! nix-shell -i "ghcid -c 'ghci' -T main" {-# OPTIONS_GHC -Wall -Wincomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-unused-top-binds -Wno-unused-imports #-} {-# OPTIONS_GHC -Wno-unused-matches -Wno-type-defaults #-} {-# OPTIONS_GHC -Wno-unused-local-binds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DataKinds #-} import Control.Applicative import Control.Monad import Control.Parallel.Strategies (parMap, parListChunk, rdeepseq) import Data.Attoparsec.Text (Parser) import Data.Euclidean (gcdExt) import Data.IntSet (IntSet) import Data.List (find,sortOn,sort) import Data.Maybe (fromMaybe,catMaybes) import Data.Monoid import Data.Text (Text) import Data.Vector (Vector) import Debug.Trace (trace,traceShow,traceShowId) import Math.NumberTheory.ArithmeticFunctions import Math.NumberTheory.Primes import Text.Pretty.Simple import qualified Data.Attoparsec.Text as A import qualified Data.IntSet as I import qualified Data.Text as T import qualified Data.Vector as V exampleData :: String exampleData = "939\n7,13,x,x,59,x,31,19" numOrXParser :: Parser (Maybe Int) numOrXParser = (Just <$> A.decimal) <|> ("x" *> pure Nothing) inputParser :: Parser (Int,[Int]) inputParser = do n <- A.decimal A.skipSpace xs <- numOrXParser `A.sepBy` "," pure (n,catMaybes $ xs) parseInput :: String -> Either String (Int,[Int]) parseInput = (A.parseOnly inputParser) . T.pack solvePart1 :: String -> Either String Int solvePart1 str = do (n,xs) <- parseInput str let (bus, time) = head $ sortOn (snd) $ map (\x -> (x,fromMaybe (-1) $ find (> n) [0,x..])) xs pure $ bus * (time - n) inputParser2 :: Parser (Int,[Maybe Int]) inputParser2 = do n <- A.decimal A.skipSpace xs <- numOrXParser `A.sepBy` "," pure (n,xs) parseInput2 :: String -> Either String (Int,[Maybe Int]) parseInput2 = (A.parseOnly inputParser2) . T.pack gcd' :: [Int] -> Int gcd' = head . (\xs -> if length xs > 1 then drop 1 xs else xs) . I.toDescList . (\x -> foldl I.intersection (I.unions x) x) . map divisorsSmall -- lcm on a list of Ints lcm' :: [Int] -> Int lcm' (x:xs) = go x xs where go x0 (y:ys) = go (lcm x0 y) (ys) go x0 [] = x0 lcm' [] = 1 -- lcm on a list of Ints lcm'' :: [Int] -> Int lcm'' xs = prodL xs `div` gcd' xs where prodL = getProduct . foldMap Product -- Too slow modList :: [(Int,Int)] -> [ [Int] ] modList = fmap f where f (n,m) = filter (\x -> (x + n) `mod` m == 0) [1..] findAllEq :: [[Int]] -> Maybe [Int] findAllEq = find (\xs -> notElem (head xs) xs) -- Can you feel how much fun I'm not having anymore? isT :: Int -> Int -> [(Int,Int)] -> Int isT tpx x xs = head $ catMaybes $ map go allTs where allTs = [tpx,2*tpx..] go :: Int -> Maybe Int go tpx0 = case and (parMap rdeepseq (go' tpx0) xs) of True -> Just (tpx0 - x) _ -> Nothing go' tpx0' (shift,fact) = -- trace ("tpx:"<>show tpx0'<>",shift:"<>show shift<>",x:"<>show x<>",fact:"<>show fact) $ (tpx0' - x + shift) `mod` fact == 0 solvePart2Naive :: String -> Either String Int solvePart2Naive str = do (_,xs) <- parseInput2 str let startAndIds = traceShowId $ catMaybes $ sequence <$> zip [0..] xs let sortedStartAndIds = reverse $ sortOn snd $ startAndIds -- pure $ sortedStartAndIds let (x,t) = head sortedStartAndIds pure $ isT t x sortedStartAndIds -- -------------------------------------------------------------------------- -- -- Here I sneak around a bit, and realize the problem is well defined -- -- (and solved!) already: it's called the Chinese Remainder Theorem -- -- https://en.wikipedia.org/wiki/Chinese_remainder_theorem -- -- -------------------------------------------------------------------------- -- -- Apllying the theorem allows to reduce a system of equation on x: -- -- -- -- x ≡ a1 (mod n1) -- -- · -- -- · -- -- · -- -- x ≡ ak (mod nk) -- -- -- -- to a single equation: -- -- -- -- x ≡ as (mod ns) -- -- -- -- It relates to the buses schedules in the following way: t is x, the bus -- -- number is the modulo factor (since a bus comes *every* ni) and subsequent -- -- additions to t (for other buses) is (-ai), so, for a but coming at -- -- t+ai, one would write x ≡ -ai (mod ni) -- -- -- -- I chose to encode ai and ni as a tuple (ai,ni), named startAndIds -- -- -- -- Basically, we're creating a “chinese” function: -- -- -- -- chinese :: (Int,Int) -> (Int,Int) -> (Int,Int) -- -- -- -- Then, given a list [(Int, Int)] we can fold over it to obtain the solution -- -- -- chinese :: (Integer,Integer) -> (Integer,Integer) -> Maybe (Integer,Integer) chinese (0,n1) (0,n2) = chinese (n1,n1) (n2,n2) chinese v (0,n2) = chinese v (n2,n2) chinese (0,n1) v = chinese (n1,n1) v chinese (a1,n1) (a2,n2) = do -- Computes a solution such that: n1×c1 + n2×c2 = g, for some c2 -- n1×c1 - g = - n2×c2, for some c2 -- 1/n2 (n1×c1 - g) = - c2, for some c2 (n2 is > 0) -- - 1/n2 (n1×c1 - g) = c2, for some c2 (n2 is > 0) -- n1 and n2 must be coprimes for this to work (g must be 1), fail otherwise (m1,m2) <- case gcdExt n1 n2 of (1,c1) -> Just ( c1, negate ((n1 * c1) - 1) `div` n2 ) _ -> Nothing let x = a1 * m2 * n2 + a2 * m1 * n1 let a12 = x `mod` (n1 * n2) pure $ (a12, n1 * n2) e2m :: Either e a -> Maybe a e2m (Right v) = Just v e2m _ = Nothing solvePart2Clever :: String -> Maybe (Integer,Integer) solvePart2Clever str = do (_,xs) <- e2m $ parseInput2 str let startAndIds = catMaybes $ sequence <$> zip [0..] (map (fmap fromIntegral) xs) let chineseEqs = traceShowId $ fmap (\(a,n) -> ((-a) `mod` n, n)) startAndIds foldM chinese (1,1) chineseEqs main :: IO () main = do putStrLn ":: Test" pPrint $ A.parseOnly inputParser $ T.pack exampleData pPrint $ take 3 ((\n -> [1,n..]) 59) putStrLn ":: Day 13 - Part 1" input <- readFile "day13/input" pPrint $ solvePart1 exampleData pPrint $ solvePart1 input putStrLn ":: Test 2" print $ (43+127) `mod` 8921 == ((43 `mod` 8921) + (127 `mod` 8921)) `mod` 8921 print $ (lcm' [100,23,98],getProduct $ foldMap Product [100,23,98]) print $ lcm' [7,13,59,31,19] print $ lcm'' [7,13,59,31,19] putStrLn "The lcm of a list of number is the first number that all of them " putStrLn "divide ie when are the different “gears” all in sync again, after " putStrLn "t=0 " print $ (div (lcm' [7,13,59,31,19])) <$> [7,13,59,31,19] print $ (div 1068781) <$> [7,13,59,31,19] print $ (mod (lcm' [7,13,59,31,19])) <$> [7,13,59,31,19] print $ (mod 1068781) <$> [7,13,59,31,19] putStrLn "::: 🎶 Musical Interlude 🎶" print $ (1068781 + 4) `div` 59 print $ (1068781 + 4) `mod` 59 print $ (1068781 + 6) `mod` 31 print $ (1068781 + 7) `mod` 19 print $ (1068781 + 1) `mod` 13 print $ (1068781 + 0) `mod` 7 print $ 100000000000000 `mod` 631 print $ 100000000000000 `div` 631 putStrLn ":: Day 13 - Part 2" print $ solvePart2Naive exampleData print $ solvePart2Naive "1\n17,x,13,19" print $ solvePart2Naive "1\n67,7,59,61" print $ solvePart2Naive "1\n67,x,7,59,61" print $ solvePart2Naive "1\n67,7,x,59,61" print $ solvePart2Naive "1\n1789,37,47,1889" putStrLn "" print $ solvePart2Clever exampleData print $ solvePart2Clever "1\n17,x,13,19" print $ solvePart2Clever "1\n67,7,59,61" print $ solvePart2Clever "1\n67,x,7,59,61" print $ solvePart2Clever "1\n67,7,x,59,61" print $ solvePart2Clever "1\n1789,37,47,1889" putStrLn "" -- Don't, it just takes forever. -- print $ solvePart2Naive input print $ solvePart2Clever input