Parallel version of day 14

diff --git a/advent-of-code.cabal b/advent-of-code.cabal
index a5666f4c6d3e23f05412e2baddecb029a80db94c..5a2aa81521afe9aa62fec37e14c3e778b9ccec27 100644 (file)
--- a/advent-of-code.cabal
+++ b/advent-of-code.cabal
@@ -130,6 +130,16 @@ executable advent14
   hs-source-dirs:      src/advent14
   main-is:             advent14.hs
   default-language:    Haskell2010
+  build-depends:       base >= 4.7 && < 5
+                     , split
+                     , containers
+                     , parallel
+
+
+executable advent14serial
+  hs-source-dirs:      src/advent14
+  main-is:             advent14serial.hs
+  default-language:    Haskell2010
   build-depends:       base >= 4.7 && < 5
                      , split
                      , containers

diff --git a/src/advent14/advent14.hs b/src/advent14/advent14.hs
index 5ca281766e91e03b4f8d75644b8504f7bbf43ccc..d091ee1dde5287eb0d4b5bf822084577c5a9c764 100644 (file)
--- a/src/advent14/advent14.hs
+++ b/src/advent14/advent14.hs
@@ -4,7 +4,7 @@ import Text.Printf (printf)
 import Data.Bits (xor)
 import qualified Data.Map.Strict as M
 import qualified Data.Graph as G
-
+import Control.Parallel.Strategies (parMap, rpar)
 type CellMap = M.Map (Int, Int) Bool
 
 puzzleKey = "xlqgujun"
@@ -17,14 +17,16 @@ main = do
 
 part1 :: String -> Int
 part1 key = sum rowCounts
-    where binHashes = map binHash $ rowSpecs key
-          rowCounts = map countSetBits binHashes
+    where rowCounts = parMap rpar countSetBits $ binHashes key
 
 
 part2 :: String -> Int
 part2 key = length $ cellEdges cells
-    where binHashes = map binHash $ rowSpecs key
-          cells = presentCells binHashes
+    where cells = presentCells $ binHashes key
+
+binHashes :: String -> [String]
+binHashes key = parMap rpar binHash $ rowSpecs key
+
 
 binHash :: String -> String
 binHash = binify . knotHash
@@ -34,7 +36,7 @@ numKey (r, c) = 128 * r + c
 
 
 presentCells :: [String] -> CellMap
-presentCells binHashes = M.fromList [((r, c), True) | r <- [0..127], c <- [0..127], (binHashes!!r)!!c == '1']
+presentCells bhs = M.fromList [((r, c), True) | r <- [0..127], c <- [0..127], (bhs!!r)!!c == '1']
 
 adjacentCells :: CellMap -> (Int, Int) -> [(Int, Int)]
 adjacentCells cells (r, c) = filter (\k -> M.member k cells) possibles

diff --git a/src/advent14/advent14serial.hs b/src/advent14/advent14serial.hs
new file mode 100644 (file)
index 0000000..3e4ef20
--- /dev/null
+++ b/src/advent14/advent14serial.hs
@@ -0,0 +1,96 @@
+import Data.List.Split (chunksOf)
+import Data.Char (ord)
+import Text.Printf (printf)
+import Data.Bits (xor)
+import qualified Data.Map.Strict as M
+import qualified Data.Graph as G
+-- import Control.Parallel.Strategies (parMap, rpar)
+type CellMap = M.Map (Int, Int) Bool
+
+puzzleKey = "xlqgujun"
+
+main :: IO ()
+main = do
+  print $ part1 puzzleKey
+  print $ part2 puzzleKey
+
+
+part1 :: String -> Int
+part1 key = sum rowCounts
+    where rowCounts = map countSetBits $ binHashes key
+
+
+part2 :: String -> Int
+part2 key = length $ cellEdges cells
+    where cells = presentCells $ binHashes key
+
+binHashes :: String -> [String]
+binHashes key = map binHash $ rowSpecs key
+
+
+binHash :: String -> String
+binHash = binify . knotHash
+
+numKey :: (Int, Int) -> Int
+numKey (r, c) = 128 * r + c
+
+
+presentCells :: [String] -> CellMap
+presentCells bhs = M.fromList [((r, c), True) | r <- [0..127], c <- [0..127], (bhs!!r)!!c == '1']
+
+adjacentCells :: CellMap -> (Int, Int) -> [(Int, Int)]
+adjacentCells cells (r, c) = filter (\k -> M.member k cells) possibles
+  where possibles = [(r, c - 1), (r, c + 1), (r - 1, c), (r + 1, c)]
+
+
+cellEdges :: CellMap -> [G.SCC (Int, Int)]
+cellEdges cells = G.stronglyConnComp [(k, numKey k, map numKey $ adjacentCells cells k) | k <- M.keys cells]
+
+rowSpecs :: String -> [String]
+rowSpecs key = map (((key ++ "-") ++) . show) ([0..127] :: [Integer])
+
+countSetBits :: String -> Int
+countSetBits = length . filter (== '1')
+
+
+
+knotHash :: String -> [Int]
+knotHash input = densify tied
+    where (tied, _, _) = foldl step ([0..255], 0, 0) hashTerms
+          hashTerms = mkHashTerms input
+
+step :: ([Int], Int, Int) -> Int -> ([Int], Int, Int)
+step (original, start, skip) len = (replaced, start', skip + 1)
+    where replaced = tie original start len
+          start' = (start + len + skip) `mod` (length original)
+
+tie :: [a] -> Int -> Int -> [a]
+tie original start len = replace original replacement start
+    where replacement = reverse $ extract original start len
+
+extract :: [a] -> Int -> Int -> [a]
+extract items from len = take len $ drop from $ items ++ items
+
+replace :: [a] -> [a] -> Int -> [a]
+replace original replacement from = take (length original) (start ++ replacement ++ remainder)
+    where excess = drop (length original - from) replacement
+          stub = drop (length excess) original
+          start = take from (excess ++ stub)
+          remainder = drop (length $ start ++ replacement) original 
+
+
+mkHashTerms :: String -> [Int]
+mkHashTerms text = take (length chunk * 64) $ cycle chunk
+    where chunk = map ord text ++ [17, 31, 73, 47, 23]
+
+-- hexify :: [Int] -> String
+-- hexify = concatMap (printf "%02x")
+
+binify :: [Int] -> String
+binify = concatMap (printf "%08b")
+
+densify :: [Int] -> [Int]
+densify ns = codes
+    where chunks = chunksOf 16 ns
+          compress = foldl1 xor
+          codes = map compress chunks