better day16

adventofcode.cabal

@@ -2,22 +2,22 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 587471fb4a9e3e35e4a8caa85fa326f402b6840f011abfe42a46f3ea9b123026
+-- hash: 31e05860d959d56216fb654ea1de930cc755c6df1d83d10b43259637eed396c4
 
-name:           adventofcode
-version:        0.1.0.0
-synopsis:       Solutions for adventofcode
-description:    Please see the README on Github at <https://github.com/yogsototh/adventofcode#readme>
-category:       Web
-homepage:       https://github.com/yogsototh/adventofcode#readme
-bug-reports:    https://github.com/yogsototh/adventofcode/issues
-author:         Yann Esposito
-maintainer:     yann.esposito@gmail.com
-copyright:      Copyright: © 2017 Yann Esposito
-license:        BSD3
-license-file:   LICENSE
-build-type:     Simple
-cabal-version:  >= 1.10
+name:                adventofcode
+version:             0.1.0.0
+synopsis:            Solutions for adventofcode
+homepage:            https://github.com/yogsototh/adventofcode#readme
+bug-reports:         https://github.com/yogsototh/adventofcode/issues
+license:             BSD3
+license-file:        LICENSE
+author:              Yann Esposito
+maintainer:          yann.esposito@gmail.com
+copyright:           Copyright: © 2017 Yann Esposito
+category:            Web
+build-type:          Simple
+cabal-version:       >= 1.10
+description:         Please see the README on Github at <https://github.com/yogsototh/adventofcode#readme>
 
 extra-source-files:
     README.md
@@ -29,14 +29,6 @@ source-repository head
 library
   hs-source-dirs:
       src
-  build-depends:
-      array
-    , base >=4.7 && <5
-    , containers
-    , foldl
-    , parsec
-    , protolude
-    , text
   exposed-modules:
       Day01
       Day02
@@ -55,13 +47,24 @@ library
       Day15
       Day16
   other-modules:
+      Day17
+      Permutations
       Paths_adventofcode
+  build-depends:
+      array
+    , base >=4.7 && <5
+    , containers
+    , foldl
+    , parsec
+    , protolude
+    , text
+    , vector
   default-language: Haskell2010
 
 executable adventofcode-exe
-  main-is: Main.hs
   hs-source-dirs:
       app
+  main-is: Main.hs
   ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       adventofcode
@@ -75,10 +78,9 @@ executable adventofcode-exe
 
 test-suite adventofcode-test
   type: exitcode-stdio-1.0
-  main-is: Spec.hs
   hs-source-dirs:
       test
-  ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
+  main-is: Spec.hs
   build-depends:
       HUnit
     , adventofcode
@@ -88,4 +90,5 @@ test-suite adventofcode-test
     , tasty-hunit
   other-modules:
       Paths_adventofcode
+  ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
   default-language: Haskell2010

package.yaml

@@ -37,6 +37,7 @@ library:
   - text
   - array
   - parsec
+  - vector
 executables:
   adventofcode-exe:
     main: Main.hs

src/Day16.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
-
 {-| description:
 --- Day 16: Permutation Promenade ---
 
@@ -54,12 +54,15 @@ In what order are the programs standing after their billion dances?
 
 module Day16 where
 
-import Protolude hiding ((<|>),swap)
+import Protolude hiding ((<|>),swap,rotate,(<>))
 
 import Data.IORef
+import Data.Semigroup (Semigroup, (<>), stimes)
+import Data.Array
 import Data.Array.MArray
 import Data.Array.IO (IOUArray)
 import Text.Parsec
+import Permutations
 
 testInput :: [Command]
 testInput = readInput "s1,x3/4,pe/b"
@@ -151,24 +154,24 @@ applyCommand fastarr (Exchange rawi rawj) = do
       j = (rawj - cur) `mod` s
   li <- readArray (arr fastarr) i
   lj <- readArray (arr fastarr) j
-  swap i j (arr fastarr)
-  swap li lj (revarr fastarr)
+  faswap i j (arr fastarr)
+  faswap li lj (revarr fastarr)
 applyCommand fastarr (Partner l k) = do
   li <- readArray (revarr fastarr) l
   lj <- readArray (revarr fastarr) k
-  swap l k (revarr fastarr)
-  swap li lj (arr fastarr)
+  faswap l k (revarr fastarr)
+  faswap li lj (arr fastarr)
 
-swap :: (MArray a e m, Ix i) => i -> i -> a i e -> m ()
-swap i j arr = do
+faswap :: (MArray a e m, Ix i) => i -> i -> a i e -> m ()
+faswap i j arr = do
   tmpi <- readArray arr i
   tmpj <- readArray arr j
   writeArray arr i tmpj
   writeArray arr j tmpi
 
 -- | brute force, not the real way to do it
-solution2 :: Int -> [Command] -> IO [Char]
-solution2 len commands = do
+solution2bruteforce :: Int -> [Command] -> IO [Char]
+solution2bruteforce len commands = do
   let letters = take len ['a'..'p']
   array <- FastArr <$> newListArray (0,len-1) letters
            <*> newListArray ('a',fromMaybe 'a' (last letters)) [0..len-1]
@@ -185,3 +188,25 @@ solution2 len commands = do
   curs <- readIORef (cursor array)
   let shift = size array - curs
   return $ drop shift elems ++ take shift elems
+
+data Dance = Dance { iperm :: Permutation Int
+                   , cperm :: Permutation Char
+                   }
+
+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
+  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
+      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)

src/Permutations.hs

@@ -0,0 +1,41 @@
+module Permutations where
+
+import           Data.Array
+import           Data.Proxy
+import           Data.Semigroup
+import           GHC.TypeLits
+
+newtype Permutation i =
+  Permutation (Array i i)
+  deriving (Eq,Ord,Show)
+
+unPerm :: Permutation i -> Array i i
+unPerm (Permutation x) = x
+
+permute :: (Ix i,Enum i) => Permutation i -> Array i e -> Array i e
+permute (Permutation p) a =
+   array b [(i, a ! (p ! i)) | i <- [i0..iN] ]
+  where
+    b@(i0,iN) = bounds a
+
+testPerm :: Array Int Int
+testPerm = listArray (0,4) [3,2,4,1,0]
+
+testArray :: Array Int Char
+testArray = listArray (0,4) ['a'..]
+
+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)])
+
+rotate :: (Ix i) => Int -> Permutation i -> Permutation i
+rotate n (Permutation p) =
+  let is = indices p
+      es = elems p
+      newis = zip (drop n (cycle is)) es
+  in Permutation (p // newis)
+
+instance (Ix i,Enum i) => Semigroup (Permutation i) where
+  p1 <> Permutation a2 = Permutation $ permute p1 a2