Day 13 (dirty)

day13/main.hs

@@ -1,6 +1,6 @@
 #! /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])"
+#! 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 #-}
@@ -11,23 +11,24 @@
 {-# 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,traceShowId)
+import Debug.Trace (trace,traceShow,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
-import Control.Parallel.Strategies (parMap, parListChunk, rdeepseq)
 
 exampleData :: String
 exampleData = "939\n7,13,x,x,59,x,31,19"
@@ -97,7 +98,7 @@ findAllEq = find (\xs -> notElem (head xs) xs)
 isT :: Int -> Int -> [(Int,Int)] -> Int
 isT tpx x xs = head $ catMaybes $ map go allTs
   where
-    allTs = [158478605388*tpx,158478605389*tpx..]
+    allTs = [tpx,2*tpx..]
     go :: Int -> Maybe Int
     go tpx0 = case and (parMap rdeepseq (go' tpx0) xs) of
       True -> Just (tpx0 - x)
@@ -106,15 +107,76 @@ isT tpx x xs = head $ catMaybes $ map go allTs
       -- trace ("tpx:"<>show tpx0'<>",shift:"<>show shift<>",x:"<>show x<>",fact:"<>show fact) $
       (tpx0' - x + shift) `mod` fact == 0
 
-solvePart2 :: String -> Either String Int
+solvePart2Naive :: String -> Either String Int
-solvePart2 str = do
+solvePart2Naive str = do
   (_,xs) <- parseInput2 str
-  let startAndIds = catMaybes $ sequence <$> zip [0..] xs
+  let startAndIds = traceShowId $ catMaybes $ sequence <$> zip [0..] xs
-  let sortedStartAndIds = traceShowId $ reverse $ sortOn snd $ startAndIds
+  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"
@@ -146,11 +208,20 @@ main = do
   print $ 100000000000000 `mod` 631
   print $ 100000000000000 `div` 631
   putStrLn ":: Day 13 - Part 2"
-  print $ solvePart2 "939\n3,5"
+  print $ solvePart2Naive exampleData
-  print $ solvePart2 exampleData
+  print $ solvePart2Naive "1\n17,x,13,19"
-  print $ solvePart2 "1\n17,x,13,19"
+  print $ solvePart2Naive "1\n67,7,59,61"
-  print $ solvePart2 "1\n67,7,59,61"
+  print $ solvePart2Naive "1\n67,x,7,59,61"
-  print $ solvePart2 "1\n67,x,7,59,61"
+  print $ solvePart2Naive "1\n67,7,x,59,61"
-  print $ solvePart2 "1\n67,7,x,59,61"
+  print $ solvePart2Naive "1\n1789,37,47,1889"
-  print $ solvePart2 "1\n1789,37,47,1889"
+  putStrLn ""
-  print $ solvePart2 input
+  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