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