src/advent14/advent14.hs

   1 import Data.List.Split (chunksOf)
   2 import Data.Char (ord)
   3 import Text.Printf (printf)
   4 import Data.Bits (xor)
   5 import qualified Data.Set as S
   6 import qualified Data.Graph as G
   7 import Control.Parallel.Strategies (parMap, rpar)
   8
   9 type CellSet = S.Set (Int, Int)
  10
  11 puzzleKey = "xlqgujun"
  12
  13 main :: IO ()
  14 main = do
  15   print $ part1 puzzleKey
  16   print $ part2 puzzleKey
  17
  18
  19 part1 :: String -> Int
  20 part1 key = sum rowCounts
  21     where rowCounts = parMap rpar countSetBits $ binHashes key
  22
  23
  24 part2 :: String -> Int
  25 part2 key = length $ cellEdges cells
  26     where cells = presentCells $ binHashes key
  27
  28 binHashes :: String -> [String]
  29 binHashes key = parMap rpar binHash $ rowSpecs key
  30
  31
  32 binHash :: String -> String
  33 binHash = binify . knotHash
  34
  35 numKey :: (Int, Int) -> Int
  36 numKey (r, c) = 128 * r + c
  37
  38
  39 presentCells :: [String] -> CellSet
  40 presentCells bhs = S.fromList [(r, c) | r <- [0..127], c <- [0..127], (bhs!!r)!!c == '1']
  41
  42 adjacentCells :: CellSet -> (Int, Int) -> [(Int, Int)]
  43 adjacentCells cells (r, c) = filter (\k -> S.member k cells) possibles
  44   where possibles = [(r, c - 1), (r, c + 1), (r - 1, c), (r + 1, c)]
  45
  46
  47 cellEdges :: CellSet -> [G.SCC (Int, Int)]
  48 cellEdges cells = G.stronglyConnComp [(k, numKey k, map numKey $ adjacentCells cells k) | k <- S.elems cells]
  49
  50 rowSpecs :: String -> [String]
  51 rowSpecs key = map (((key ++ "-") ++) . show) ([0..127] :: [Integer])
  52
  53 countSetBits :: String -> Int
  54 countSetBits = length . filter (== '1')
  55
  56
  57
  58 knotHash :: String -> [Int]
  59 knotHash input = densify tied
  60     where (tied, _, _) = foldl step ([0..255], 0, 0) hashTerms
  61           hashTerms = mkHashTerms input
  62
  63 step :: ([Int], Int, Int) -> Int -> ([Int], Int, Int)
  64 step (original, start, skip) len = (replaced, start', skip + 1)
  65     where replaced = tie original start len
  66           start' = (start + len + skip) `mod` (length original)
  67
  68 tie :: [a] -> Int -> Int -> [a]
  69 tie original start len = replace original replacement start
  70     where replacement = reverse $ extract original start len
  71
  72 extract :: [a] -> Int -> Int -> [a]
  73 extract items from len = take len $ drop from $ items ++ items
  74
  75 replace :: [a] -> [a] -> Int -> [a]
  76 replace original replacement from = take (length original) (start ++ replacement ++ remainder)
  77     where excess = drop (length original - from) replacement
  78           stub = drop (length excess) original
  79           start = take from (excess ++ stub)
  80           remainder = drop (length $ start ++ replacement) original
  81
  82
  83 mkHashTerms :: String -> [Int]
  84 mkHashTerms text = take (length chunk * 64) $ cycle chunk
  85     where chunk = map ord text ++ [17, 31, 73, 47, 23]
  86
  87 -- hexify :: [Int] -> String
  88 -- hexify = concatMap (printf "%02x")
  89
  90 binify :: [Int] -> String
  91 binify = concatMap (printf "%08b")
  92
  93 densify :: [Int] -> [Int]
  94 densify ns = codes
  95     where chunks = chunksOf 16 ns
  96           compress = foldl1 xor
  97           codes = map compress chunks