fix day16 sol 2
This commit is contained in:
parent
e11b690d75
commit
5408be6b5b
7 changed files with 121 additions and 49 deletions
|
@ -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
|
||||
|
|
17
app/Main.hs
17
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"
|
||||
|
|
|
@ -32,7 +32,7 @@ library:
|
|||
- Day17
|
||||
- Day18
|
||||
- Day19
|
||||
# - Day20
|
||||
- Day20
|
||||
# - Day21
|
||||
# - Day22
|
||||
# - Day23
|
||||
|
|
22
src/Day16.hs
22
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)
|
||||
|
|
73
src/Day20.hs
73
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
|
||||
|
||||
|
||||
|
|
|
@ -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]
|
||||
|
|
20
test/Spec.hs
20
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"
|
||||
|
|
Loading…
Reference in a new issue