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])"
#! 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 Data.Attoparsec.Text (Parser)
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,traceShowId)
import Math.NumberTheory.ArithmeticFunctions
import Math.NumberTheory.Primes
--import Math.NumberTheory.Moduli.Class
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 = [158478605388*tpx,158478605389*tpx..]
    go :: Int -> Maybe Int
    go tpx0 = case and (map (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

solvePart2 :: String -> Either String Int
solvePart2 str = do
  (_,xs) <- parseInput2 str
  let startAndIds = catMaybes $ sequence <$> zip [0..] xs
  let sortedStartAndIds = traceShowId $ reverse $ sortOn snd $ startAndIds
  -- pure $ sortedStartAndIds
  let (x,t) = head sortedStartAndIds
  pure $ isT t x sortedStartAndIds

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 $ solvePart2 "939\n3,5"
  -- print $ solvePart2 exampleData
  -- print $ solvePart2 "1\n17,x,13,19"
  -- print $ solvePart2 "1\n67,7,59,61"
  -- print $ solvePart2 "1\n67,x,7,59,61"
  -- print $ solvePart2 "1\n67,7,x,59,61"
  -- print $ solvePart2 "1\n1789,37,47,1889"
  print $ solvePart2 input