fix day16 sol 2

adventofcode.cabal

@@ -2,7 +2,7 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: dd5686d02b76a5cdfd0af22f3af753c80816616396b5f3c7ad773a552f9d0647
+-- hash: 1e758d0525406b84a2b0161fe229f8b799eefbe00c43229a99d7360878eb5368
 
 name:                adventofcode
 version:             0.1.0.0
@@ -49,8 +49,8 @@ library
       Day17
       Day18
       Day19
-  other-modules:
       Day20
+  other-modules:
       DayXX
       Permutations
       Paths_adventofcode

app/Main.hs

@@ -27,7 +27,7 @@ import qualified Day16
 import qualified Day17
 import qualified Day18
 import qualified Day19
--- import qualified Day20
+import qualified Day20
 -- import qualified Day21
 -- import qualified Day22
 -- import qualified Day23
@@ -64,7 +64,7 @@ solutions = Map.fromList [(["01"], day01)
                          ,(["17"], day17)
                          ,(["18"], day18)
                          ,(["19"], day19)
-                         ,(["20"], dayXX)
+                         ,(["20"], day20)
                          ,(["21"], dayXX)
                          ,(["22"], dayXX)
                          ,(["23"], dayXX)
@@ -208,8 +208,8 @@ day16 = do
   input <- Day16.parseInput
   sol1 <- Day16.solution1 16 input
   showSol "Solution 1" (text (toS sol1))
-  -- sol2 <- Day16.solution2 16 input
-  -- showSol "Solution 2" (text (toS sol2))
+  let sol2 = Day16.solution2 16 1000000000 input
+  showSol "Solution 2" (text (toS sol2))
 
 day17 :: IO ()
 day17 = do
@@ -240,5 +240,14 @@ day19 = do
   let sol2 = Day19.solution2 input
   showSol "Solution 2" (int sol2)
 
+day20 :: IO ()
+day20 = do
+  putText "Day 20:"
+  input <- Day20.parseInput
+  let sol1 = Day20.solution1 input
+  showSol "Solution 1" (int sol1)
+  let sol2 = Day20.solution2 input
+  showSol "Solution 2" (int sol2)
+
 dayXX :: IO ()
 dayXX = putText "Not done yet"

package.yaml

@@ -32,7 +32,7 @@ library:
   - Day17
   - Day18
   - Day19
-  # - Day20
+  - Day20
   # - Day21
   # - Day22
   # - Day23

src/Day16.hs

@@ -194,20 +194,26 @@ data Dance = Dance { iperm :: Permutation Int
                    , cperm :: Permutation Char
                    } deriving (Eq, Show)
 
-applyCmd :: Command -> Dance -> Dance
-applyCmd (Spin n)       d@Dance{..} = d { iperm = rotate n iperm }
-applyCmd (Exchange i j) d@Dance{..} = d { iperm = swap i j iperm }
-applyCmd (Partner x y)  d@Dance{..} = d { cperm = swap x y cperm }
+applyCmd :: Permutation Int -> Permutation Char -> Dance -> Command -> Dance
+applyCmd p0 _ d@Dance{..} (Spin n)       = d { iperm = iperm <> rotate n p0 }
+applyCmd p0 _ d@Dance{..} (Exchange i j) = d { iperm = iperm <> swap i j p0 }
+applyCmd _ p0 d@Dance{..} (Partner x y)  = d { cperm = swap x y p0 <> cperm }
 
 solution2 :: Int -> Int -> [Command] -> [Char]
 solution2 len nbIter commands = do
   let letters = take len ['a'..'p']
       lastLetter = fromMaybe 'a' (head (reverse letters))
-      initDance = Dance (nullPerm (0,len-1)) (nullPerm ('a',lastLetter))
-      firstDance = foldl' (flip applyCmd) initDance commands
+      ip = nullPerm (0,len-1)
+      cp = nullPerm ('a',lastLetter)
+      initDance = Dance ip cp
+      firstDance = foldl' (applyCmd ip cp) initDance commands
       finalDance = stimes nbIter firstDance
-      tmpArray = listArray (0,len-1) (elems (unPerm (cperm finalDance)))
-  permute (iperm finalDance) tmpArray & elems
+      tmpArray = listArray ('a',lastLetter) letters
+  permute (cperm finalDance) tmpArray
+      & elems
+      & listArray (0,len-1)
+      & permute (iperm finalDance)
+      & elems
 
 instance Semigroup Dance where
   Dance r1 p1 <> Dance r2 p2 = Dance (r1 <> r2) (p1 <> p2)

src/Day20.hs

@@ -2,6 +2,8 @@
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types        #-}
+{-# LANGUAGE RankNTypes        #-}
 {-# LANGUAGE TypeApplications  #-}
 {-|
 
@@ -61,6 +63,7 @@ import           Control.Lens          hiding ((&))
 -- import           Data.Array
 import           Data.Generics.Product
 -- import qualified Data.Text             as T
+import qualified Data.Set              as Set
 import           GHC.Generics
 import           Text.Parsec           hiding (State)
 
@@ -114,7 +117,7 @@ parseInt = do
   str <- many1 digit
   let strint = case sgn of
                     Nothing -> str
-                    Just _ -> "-" <> str
+                    Just _  -> "-" <> str
   return $ fromMaybe 0 (reads strint & head & fmap fst)
 
 -- Solution 1
@@ -142,11 +145,65 @@ solution1 input =
 type Solution2 = Int
 
 solution2 :: Input -> Solution2
-solution2 grid =
-  let initState = undefined
-  in extractSol $ execState solve2 initState
+solution2 input =
+  let sorted = input
+               & zip ([0..] :: [Int])
+               & sortOn (\(_,p)->d (pos p))
+               & sortOn (\(_,p)->d (vit p))
+               & sortOn (\(_,p)->d (acc p))
+  in notCollided sorted & map fst & Set.fromList & Set.size
   where
-    extractSol :: AppState -> Solution2
-    extractSol = undefined
-    solve2 :: State AppState ()
-    solve2 = undefined
+    d = dist mempty
+    notCollided :: [(Int,Particle)] -> [(Int,Particle)]
+    notCollided sorted = do
+      (i,p1) <- sorted
+      (j,p2) <- sorted
+      guard (j > i)
+      guard (not (collide p1 p2))
+      return (i,p1)
+    collide :: Particle -> Particle -> Bool
+    collide p1 p2 = let trivialracines = [1..10]
+                    in checkRacines p1 p2 trivialracines
+    potentialRacines :: Particle -> Particle -> [Int]
+    potentialRacines p1 p2 =
+      let a = (acc p1 ^. field @"x") - (acc p2 ^. field @"x")
+          b = (vit p1 ^. field @"x") - (vit p2 ^. field @"x")
+          c = (pos p1 ^. field @"x") - (pos p2 ^. field @"x")
+      in
+        if a /= 0
+        then
+          let delta = b^2 - 4*a*c in
+          if delta >= 0
+          then [ (-b + isqrt delta) `div` (2*a)
+               , (-b - isqrt delta) `div` (2*a)
+               , 1+(-b - isqrt delta) `div` (2*a)
+               , 1+(-b + isqrt delta) `div` (2*a)
+               , 2+(-b - isqrt delta) `div` (2*a)
+               , 2+(-b + isqrt delta) `div` (2*a)
+               ] & filter (>0)
+          else []
+        else [-c `div` b | b /= 0]
+    isqrt :: Int -> Int
+    isqrt = fromIntegral . floor . sqrt . fromIntegral
+    pol :: Particle -> Particle -> Lens' Coord Int -> (Int -> Int)
+    pol p1 p2 l = \x -> a*(x*x) + (b*x) + c
+      where
+        a :: Int
+        a = (acc p1 ^. l) - (acc p2 ^. l)
+        b :: Int
+        b = (vit p1 ^. l) - (vit p2 ^. l)
+        c :: Int
+        c = (pos p1 ^. l) - (pos p2 ^. l)
+    checkRacines :: Particle -> Particle -> [Int] -> Bool
+    checkRacines _ _ [] = False
+    checkRacines p1 p2 (x:xs) =
+      traceShow (p1,p2,x
+                , pol p1 p2 (field @"x") x == 0
+                , pol p1 p2 (field @"y") x == 0
+                , pol p1 p2 (field @"z") x == 0)
+                (pol p1 p2 (field @"x") x == 0
+                 && pol p1 p2 (field @"y") x == 0
+                 && pol p1 p2 (field @"z") x == 0)
+      || checkRacines p1 p2 xs
+
+

src/Permutations.hs

@@ -6,14 +6,18 @@ import Protolude hiding (swap)
 import           Data.Array
 import           Data.Proxy
 import           Data.Semigroup
+import qualified Data.Set as Set
 import           GHC.TypeLits
 
+-- | properties
+-- a permutation is a bijection
 newtype Permutation i =
-  Permutation (Array i i)
+  Permutation { unPerm :: Array i i }
   deriving (Eq,Ord,Show)
 
-unPerm :: Permutation i -> Array i i
-unPerm (Permutation x) = x
+isBijection :: (Ix i) => Permutation i -> Bool
+isBijection p =
+  Set.fromList (elems (unPerm p)) == Set.fromList (indices (unPerm p))
 
 permute :: (Ix i,Enum i) => Permutation i -> Array i e -> Array i e
 permute (Permutation p) a =
@@ -48,24 +52,4 @@ rotate n (Permutation p) =
 
 instance (Ix i,Enum i) => Semigroup (Permutation i) where
   Permutation a1 <> Permutation a2 = Permutation $
-    array (bounds a2) [ (i, a2 ! j) | (i,j) <- assocs a1]
-
-{-
-
-0 1 2 === 0
-1 0 2 => p1
-0 2 1 => p2
-2 1 0 => p3
-1 2 0 => p4
-
-p1 <> p2 ===> 2 0 1
-p2 <> p1 ===> 1 2 0
-
--}
-
-testPermutation =
-  let p0 = nullPerm (0,2)
-      p1 = swap 0 1 p0
-      p2 = swap 1 2 p0
-      p3 = p1 <> p2
-  in p2 <> p1
+    array (bounds a1) [ (i, a1 ! j) | (i,j) <- assocs a2]

test/Spec.hs

@@ -48,6 +48,7 @@ main = defaultMain $
   , testDay13
   , testDay14
   , testDay15
+  , testDay16
   ]
 
 testDay01 =
@@ -285,9 +286,24 @@ testDay15 =
 
 testDay16 =
   testGroup "Day 16"
-  [ testGroup "Solution 1" []
-  , testGroup "Solution 2" []
+  [ testGroup "Solution 1"
+    [ testCase "Example" $ do
+        sol1 <- Day16.solution1 5 Day16.testInput
+        sol1 @?= "baedc"
+    ]
+  , testGroup "Solution 2"
+    [ testCase "Check equal to sol1 input of length 1" $ test2 1
+    , testCase "Check equal to sol1 input of length 1000" $ test2 1000
+    ]
   ]
+  where
+    test2 n = do
+      input <- fmap (take n) Day16.parseInput
+      sol1 <- Day16.solution1 16 input
+      let sol2 = Day16.solution2 16 1 input
+      sol1 @?= sol2
+
+
 
 testDay17 =
   testGroup "Day 17"