adventofcode-2020/day13/main.hs

#! /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