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