trying to get back on track...

adventofcode.cabal

@@ -2,7 +2,7 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 31e05860d959d56216fb654ea1de930cc755c6df1d83d10b43259637eed396c4
+-- hash: f9a4697d8f11ab3d8140e99316d613f42cd6e2550804b33ce3045f2fb81715a1
 
 name:                adventofcode
 version:             0.1.0.0
@@ -46,8 +46,8 @@ library
       Day14
       Day15
       Day16
-  other-modules:
       Day17
+  other-modules:
       Permutations
       Paths_adventofcode
   build-depends:

app/Main.hs

@@ -24,6 +24,7 @@ import qualified Day13
 import qualified Day14
 import qualified Day15
 import qualified Day16
+import qualified Day17
 
 showSol :: [Char] -> Doc -> IO ()
 showSol txt d = putText . toS . render $
@@ -53,6 +54,7 @@ solutions = Map.fromList [(["01"], day01)
                          ,(["14"], day14)
                          ,(["15"], day15)
                          ,(["16"], day16)
+                         ,(["17"], day17)
                          ]
 
 
@@ -184,7 +186,7 @@ day15 = do
   let sol1 = Day15.solution1 Day15.input
   showSol "Solution 1" (int sol1)
   let sol2 = Day15.solution2 Day15.input
-  showSol "Solution 1" (int sol2)
+  showSol "Solution 2" (int sol2)
 
 day16 :: IO ()
 day16 = do
@@ -192,5 +194,13 @@ 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))
+  -- sol2 <- Day16.solution2 16 input
+  -- showSol "Solution 2" (text (toS sol2))
+
+day17 :: IO ()
+day17 = do
+  putText "Day 17:"
+  sol1 <- Day17.solution1 2017 Day17.input
+  showSol "Solution 1" (int (fromMaybe 0 sol1))
+  let sol2 = Day17.solution2 50000000 Day17.input
+  showSol "Solution 2" (int sol2)

package.yaml

@@ -29,6 +29,7 @@ library:
   - Day14
   - Day15
   - Day16
+  - Day17
   dependencies:
   - base >=4.7 && <5
   - protolude

src/Day16.hs

@@ -1,8 +1,11 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NoImplicitPrelude     #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+
 {-| description:
+
 --- Day 16: Permutation Promenade ---
 
 You come upon a very unusual sight; a group of programs here appear to be
@@ -48,21 +51,19 @@ pe/b, swapping programs e and b: ceadb.
 
 In what order are the programs standing after their billion dances?
 
-
-
 |-}
 
 module Day16 where
 
-import Protolude hiding ((<|>),swap,rotate,(<>))
+import           Protolude         hiding (rotate, swap, (<>), (<|>))
 
-import Data.IORef
-import Data.Semigroup (Semigroup, (<>), stimes)
 import           Data.Array
-import Data.Array.MArray
 import           Data.Array.IO     (IOUArray)
-import Text.Parsec
+import           Data.Array.MArray
+import           Data.IORef
+import           Data.Semigroup    (Semigroup, stimes, (<>))
 import           Permutations
+import           Text.Parsec
 
 testInput :: [Command]
 testInput = readInput "s1,x3/4,pe/b"
@@ -191,22 +192,39 @@ solution2bruteforce len commands = do
 
 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 }
 
-solution2 :: Int -> [Command] -> [Char]
-solution2 len commands = do
+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
-      finalDance = stimes 1 firstDance
+      finalDance = stimes nbIter firstDance
       tmpArray = listArray (0,len-1) (elems (unPerm (cperm finalDance)))
   permute (iperm finalDance) tmpArray & elems
 
 instance Semigroup Dance where
   Dance r1 p1 <> Dance r2 p2 = Dance (r1 <> r2) (p1 <> p2)
+
+test n = do
+  input <- fmap (take n) parseInput
+  sol1 <- solution1 16 input
+  let sol2 = solution2 16 1 input
+  print (head (reverse input))
+  print sol1
+  print sol2
+  return $ sol1 == sol2
+
+test2 commands = do
+  sol1 <- solution1 3 commands
+  let sol2 = solution2 3 1 commands
+  print (head (reverse commands))
+  print sol1
+  print sol2
+  return $ sol1 == sol2

src/Day17.hs

@@ -0,0 +1,161 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE Strict            #-}
+{-| description:
+
+--- Day 17: Spinlock ---
+
+Suddenly, whirling in the distance, you notice what looks like a massive,
+pixelated hurricane: a deadly spinlock. This spinlock isn't just consuming
+computing power, but memory, too; vast, digital mountains are being ripped from
+the ground and consumed by the vortex.
+
+If you don't move quickly, fixing that printer will be the least of your
+problems.
+
+This spinlock's algorithm is simple but efficient, quickly consuming everything
+in its path. It starts with a circular buffer containing only the value 0, which
+it marks as the current position. It then steps forward through the circular
+buffer some number of steps (your puzzle input) before inserting the first new
+value, 1, after the value it stopped on. The inserted value becomes the current
+position. Then, it steps forward from there the same number of steps, and
+wherever it stops, inserts after it the second new value, 2, and uses that as
+the new current position again.
+
+It repeats this process of stepping forward, inserting a new value, and using
+the location of the inserted value as the new current position a total of 2017
+times, inserting 2017 as its final operation, and ending with a total of 2018
+values (including 0) in the circular buffer.
+
+For example, if the spinlock were to step 3 times per insert, the circular
+buffer would begin to evolve like this (using parentheses to mark the current
+position after each iteration of the algorithm):
+
+- (0), the initial state before any insertions.
+- 0 (1): the spinlock steps forward three times (0, 0, 0), and then inserts the
+  first value, 1, after it. 1 becomes the current position.
+- 0 (2) 1: the spinlock steps forward three times (0, 1, 0), and then inserts
+  the second value, 2, after it. 2 becomes the current position.
+- 0 2 (3) 1: the spinlock steps forward three times (1, 0, 2), and then inserts
+  the third value, 3, after it. 3 becomes the current position.
+
+And so on:
+
+- 0  2 (4) 3  1
+- 0 (5) 2  4  3  1
+- 0  5  2  4  3 (6) 1
+- 0  5 (7) 2  4  3  6  1
+- 0  5  7  2  4  3 (8) 6  1
+- 0 (9) 5  7  2  4  3  8  6  1
+
+Eventually, after 2017 insertions, the section of the circular buffer near the
+last insertion looks like this:
+
+1512  1134  151 (2017) 638  1513  851
+
+Perhaps, if you can identify the value that will ultimately be after the last
+value written (2017), you can short-circuit the spinlock. In this example, that
+would be 638.
+
+What is the value after 2017 in your completed circular buffer?
+
+
+--- Part Two ---
+
+The spinlock does not short-circuit. Instead, it gets more angry. At least, you
+assume that's what happened; it's spinning significantly faster than it was a
+moment ago.
+
+You have good news and bad news.
+
+The good news is that you have improved calculations for how to stop the
+spinlock. They indicate that you actually need to identify the value after 0 in
+the current state of the circular buffer.
+
+The bad news is that while you were determining this, the spinlock has just
+finished inserting its fifty millionth value (50000000).
+
+What is the value after 0 the moment 50000000 is inserted?
+
+|-}
+
+module Day17 where
+
+import           Protolude
+
+import qualified Data.Text as T
+
+input :: Int
+input = 303
+testInput :: Int
+testInput = 3
+
+data Buffer = Buffer { elems :: [Int]
+                     , pos   :: Int
+                     } deriving (Show)
+
+nextPreStep :: Int -> Buffer -> Buffer
+nextPreStep nbSteps b@Buffer{..} =
+  b { pos = (pos + nbSteps) `rem` length elems }
+
+showBuffer :: Buffer -> Text
+showBuffer Buffer{..} =
+  zip  [0..] elems
+  & map (\(i,v) -> if i == pos
+                     then "(" <> show v <> ") "
+                     else show v <> " ")
+  & T.concat
+
+nextStep :: Int -> Int -> Buffer -> Buffer
+nextStep nbSteps roundNumber b =
+  b
+  & nextPreStep nbSteps
+  & addElem roundNumber
+  -- & \x -> trace (showBuffer x) (addElem roundNumber x)
+
+addElem :: Int -> Buffer -> Buffer
+addElem roundNumber b@Buffer {..} =
+  b { elems = newelems
+    , pos = pos + 1 `rem` length newelems
+    }
+  where
+    newelems = take (pos + 1) elems
+               ++ [roundNumber]
+               ++ drop (pos + 1) elems
+
+solution1 :: Int -> Int -> IO (Maybe Int)
+solution1 nbOcc nbSteps = go initState 0
+  where
+    initState = Buffer [0] 0
+    go st n
+      | n == nbOcc = st & elems & elemAt (1 + (pos st)) & return
+      | otherwise = do
+            -- print st
+            -- putText $ "> " <> showBuffer st
+            go (nextStep nbSteps (n+1) st) (n+1)
+    elemAt :: Int -> [a] -> Maybe a
+    elemAt 0 (x:xs) = Just x
+    elemAt n (_:xs) = elemAt (n-1) xs
+    elemAt _ _      = Nothing
+
+data Buf2 = Buf2 { position :: Int
+                 , size :: Int
+                 , lastSol :: Int
+                 }
+
+solution2 :: Int -> Int -> Int
+solution2 nbOcc nbSteps = go initState 1
+  where
+    initState = Buf2 0 1 0
+    go st@Buf2{..} n
+      | n == nbOcc = lastSol
+      | (position + nbSteps) `rem` size == 0 =
+          traceShow n $ go (st { position = 1
+                               , lastSol = n
+                               , size = size + 1
+                               })
+                           (n+1)
+      | otherwise = go (st { position = (1 + position + nbSteps) `rem` size
+                           , size = size + 1 })
+                       (n+1)

src/Permutations.hs

@@ -1,5 +1,8 @@
+{-# LANGUAGE NoImplicitPrelude #-}
 module Permutations where
 
+import Protolude hiding (swap)
+
 import           Data.Array
 import           Data.Proxy
 import           Data.Semigroup
@@ -18,6 +21,12 @@ permute (Permutation p) a =
   where
     b@(i0,iN) = bounds a
 
+revpermute :: (Ix i,Enum i) => Permutation i -> Permutation i
+revpermute (Permutation p) =
+  Permutation $ p // [(j,i) | (i,j) <- assocs p]
+
+
+
 testPerm :: Array Int Int
 testPerm = listArray (0,4) [3,2,4,1,0]
 
@@ -28,7 +37,7 @@ nullPerm :: (Ix i,Enum i) => (i,i) -> Permutation i
 nullPerm bnds@(start,end) = Permutation $ listArray bnds [start..end]
 
 swap :: (Ix i) => i -> i -> Permutation i -> Permutation i
-swap x y (Permutation p) = Permutation (p // [(x,p ! y), (y,p ! x)])
+swap x y (Permutation p) = Permutation (p // [(x,y), (y,x)])
 
 rotate :: (Ix i) => Int -> Permutation i -> Permutation i
 rotate n (Permutation p) =
@@ -38,4 +47,5 @@ rotate n (Permutation p) =
   in Permutation (p // newis)
 
 instance (Ix i,Enum i) => Semigroup (Permutation i) where
-  p1 <> Permutation a2 = Permutation $ permute p1 a2
+  Permutation a1 <> Permutation a2 = Permutation $
+    array (bounds a2) [ (i, a2 ! j) | (i,j) <- assocs a1]