Skip to content

Commit 7320112

Browse files
goblivendgoblivend
committed
feat(2024/Day24): part1 + start part2
1 parent b01170e commit 7320112

File tree

7 files changed

+598
-0
lines changed

7 files changed

+598
-0
lines changed

‎2024/Day24/Day24.hs

+175
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,175 @@
1+
module Main where
2+
3+
import Data.Bits
4+
import Data.List
5+
import Data.List.Split
6+
import Data.List.Unique
7+
import Data.Map (Map)
8+
import Data.Map qualified as M
9+
import Data.Matrix (Matrix, (!))
10+
import Data.Matrix qualified as Mat
11+
import Data.Set (Set)
12+
import Data.Set qualified as S
13+
import Data.Tuple.Extra
14+
import Debug.Trace
15+
import System.Environment
16+
import Text.Regex.TDFA ((=~))
17+
18+
-- TODO: Cleanup imports after day done
19+
20+
data BinOp = AND | OR | XOR deriving (Show, Eq)
21+
22+
data Operation = Operation {l :: String, r :: String, op :: BinOp} deriving (Show, Eq)
23+
24+
type Input = (Map String Bool, Map String Operation)
25+
26+
type Output = Int
27+
28+
parseInput :: String -> Input
29+
parseInput input = (defaultValues, opMap)
30+
where
31+
[defaultStr, opStr] = splitOn "\n\n" input
32+
33+
intToBool 0 = False
34+
intToBool _ = True
35+
36+
parseDefault = (\[key, n] -> (key, intToBool $ read n)) . splitOn ": "
37+
defaultValues = M.fromList . map parseDefault $ lines defaultStr
38+
parseOp [lKey, "AND", rKey, _, oKey] = (oKey, Operation lKey rKey AND)
39+
parseOp [lKey, "OR", rKey, _, oKey] = (oKey, Operation lKey rKey OR)
40+
parseOp [lKey, "XOR", rKey, _, oKey] = (oKey, Operation lKey rKey XOR)
41+
opMap = M.fromList . map (parseOp . splitOn " ") $ lines opStr
42+
43+
wiresToInt :: String -> Map String Bool -> Output
44+
wiresToInt prefix values = binToInt . map (\b -> if b then 1 else 0) . map snd . sortOn fst . filter (isPrefixOf prefix . fst) $ M.assocs values
45+
where
46+
binToInt = foldr (\c res -> res * 2 + c) 0
47+
48+
applyOp :: Map String Bool -> Operation -> Bool
49+
applyOp values (Operation lKey rKey AND) = (values M.! lKey) && (values M.! rKey)
50+
applyOp values (Operation lKey rKey OR) = (values M.! lKey) || (values M.! rKey)
51+
applyOp values (Operation lKey rKey XOR) = (values M.! lKey) `xor` (values M.! rKey)
52+
53+
applyOps :: Input -> Map String Bool
54+
applyOps (defaultValues, opMap) = foldl solve defaultValues opList
55+
where
56+
opList = filter (isPrefixOf "z") $ M.keys opMap
57+
58+
solve v key
59+
| key `M.member` v = v
60+
| otherwise = newValues
61+
where
62+
(Operation lKey rKey o) = opMap M.! key
63+
v' = solve v lKey
64+
v'' = solve v' rKey
65+
66+
res = applyOp v'' (opMap M.! key)
67+
newValues = M.insert key res v''
68+
69+
part1 :: Input -> Output
70+
part1 = wiresToInt "z" . applyOps
71+
72+
73+
intToWires :: Int -> Int -> [Bool]
74+
intToWires size val = reverse . snd $ foldl (\(v, r) _ -> (v `div` 2, (v `mod` 2 == 1) :r)) (val, []) $ replicate size 0
75+
76+
badOutputs :: [Bool] -> Map String Bool -> [String]
77+
badOutputs expected vals = map snd $ filter (\(e, s) -> e /= vals M.! s) $ zip expected zs
78+
where
79+
zs = sort . filter (isPrefixOf "z") $ M.keys vals
80+
81+
findInvalidGates :: Input -> Set String
82+
findInvalidGates (defaultV, opMap) = S.unions . map badKeys $ zip values $ tail values
83+
where
84+
values = [2^i | i<-[0..44]] ++ [2^i-1 | i<-[0..44]] ++ [0..512]
85+
xs = filter (isPrefixOf "x") $ M.keys defaultV
86+
ys = filter (isPrefixOf "y") $ M.keys defaultV
87+
xyLength = length xs
88+
valuesFrom x y = M.fromList $ (zip xs $ intToWires xyLength x) ++ (zip ys $ intToWires xyLength y)
89+
90+
binRes res = intToWires (xyLength + 1) res
91+
badKeys :: (Int, Int) -> Set String
92+
badKeys (v1, v2) = S.fromList . badOutputs (binRes $ v1+v2) $ applyOps (valuesFrom v1 v2, opMap)
93+
94+
-- part2 :: Input -> [(String, Set String)]
95+
-- part2 (defaultV, opMap) = intercalate "," . sort . head $ filter (\l -> (== res) . wiresToInt "z" $ applyOps (defaultV, swapThem opMap l)) $ keysToSwap -- (\e -> trace (show l) e).
96+
part2 (defaultV, opMap) = intercalate "," . sort . head $ filter (\l -> S.null . (\e -> trace (show (intercalate "," $l, e)) e) $ findInvalidGates (defaultV, swapThem opMap l)) $ keysToSwap --
97+
--map (\l -> )) keysToSwap
98+
99+
where
100+
defaultX = wiresToInt "x" defaultV
101+
defaultY = wiresToInt "y" defaultV
102+
res = defaultX + defaultY
103+
binRes = intToWires (length . filter (isPrefixOf "x") $ M.keys defaultV) res
104+
opKeys = M.keys opMap
105+
badKeys = (\e -> trace (show (length e, e)) e) . badOutputs binRes $ applyOps (defaultV, opMap)
106+
badDependencyMap = M.fromList $ map (id &&& (dependenciesOf opMap)) badKeys
107+
-- badDependencies = S.unions $ M.elems badDependencyMap
108+
keysToSwap = [["z06", "vwr", "tqm", "z11", "kfs", "z16", "gfv", "hcm"]] -- map ((++["z06", "vwr", "tqm", "z11", "kfs", "z16"]) . (\(a,b) -> [a,b])) $ zip (M.keys opMap) (tail $ M.keys opMap) -- $ (\l -> map(\(x, y) -> [x,y]). zip l $ tail l) $ S.toList $ dependenciesOf' opMap 5 "z36"
109+
-- filter (\(i, l) -> (all (\k -> not . S.null $ S.intersection (S.fromList l) (badDependencyMap M.! k)) badKeys)) .
110+
111+
dependsOn mp key curr
112+
| curr `M.notMember` mp = False
113+
| (key `elem`) $ filter (`M.member` mp) [curr, lKey, rKey] = True
114+
| otherwise = any (dependsOn mp key) [lKey, rKey]
115+
where
116+
(Operation lKey rKey _) = mp M.! curr
117+
118+
119+
120+
swapThem opMap [] = opMap
121+
swapThem opMap (k1:k2:l)
122+
| dependsOn opMap k1 k2 || dependsOn opMap k2 k1 = opMap
123+
| otherwise = swapThem newOpMap l
124+
where
125+
v1 = opMap M.! k1
126+
v2 = opMap M.! k2
127+
newOpMap = M.insert k1 v2 $ M.insert k2 v1 opMap
128+
129+
dependenciesOf :: Map String Operation -> String -> Set String
130+
dependenciesOf mp key
131+
| key `M.notMember` mp = S.empty
132+
| otherwise = S.insert key . S.unions $ map (dependenciesOf mp) [lKey, rKey]
133+
where
134+
(Operation lKey rKey _) = mp M.! key
135+
136+
dependenciesOf' :: Map String Operation -> Int -> String -> Set String
137+
dependenciesOf' mp d key
138+
| key `M.notMember` mp = S.empty
139+
| d == 0 = S.singleton key
140+
| otherwise = S.insert key . S.unions $ map (dependenciesOf' mp (d-1)) [lKey, rKey]
141+
where
142+
(Operation lKey rKey _) = mp M.! key
143+
144+
operations :: Map String Operation -> [String]
145+
operations ops = map (\e -> e ++ " = " ++ opeOf 5 e) . sort $ filter ("z" `isPrefixOf`) $ M.keys ops
146+
where
147+
opeOf 0 e = e
148+
opeOf d e
149+
| "x" `isPrefixOf` e = e
150+
| "y" `isPrefixOf` e = e
151+
| otherwise = "(" ++ opeOf (d-1) l ++ ")" ++ "[" ++ l ++ " " ++ (show op) ++ " " ++ r ++ "]" ++ "(" ++ opeOf (d-1) r ++ ")"
152+
where
153+
(Operation l r op) = ops M.! e
154+
155+
main :: IO ()
156+
main = do
157+
args <- getArgs
158+
content <- readFile (last args)
159+
let input = parseInput content
160+
161+
-- print input
162+
163+
-- print $intToWires 16 33
164+
print $ findInvalidGates input
165+
166+
-- print $ (== 50411513338638) $ part1 input
167+
-- print $part1 input
168+
print $ part2 input
169+
-- putStrLn $ unlines $ operations $ snd input
170+
171+
-- let mp = snd input
172+
-- let pairs l = zip l $ tail l
173+
-- print $ length $ pairs $ M.keys mp
174+
-- print $ dependenciesOf' mp 3 "z36"
175+
-- putStrLn $ unlines $ map show $ map (id &&& (dependenciesOf' mp 3)) . sort $ filter ("z" `isPrefixOf`) $ M.keys mp

‎2024/Day24/Makefile

+28
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,28 @@
1+
CONTAINER_NAME=haskell-aoc
2+
SRC=./Day24.hs
3+
TARGET=Day24
4+
all: $(TARGET)
5+
6+
$(TARGET): $(SRC)
7+
ghc -O3 $(SRC)
8+
9+
profile: $(SRC)
10+
11+
12+
clean:
13+
$(RM) ./Day24 ./Day24.o ./Day24.hi
14+
15+
setup: $(SRC)
16+
docker cp $(SRC) $(CONTAINER_NAME):/home/haskell/Main.hs
17+
docker cp input.txt $(CONTAINER_NAME):/home/haskell/input.txt
18+
docker cp shortinput.txt $(CONTAINER_NAME):/home/haskell/shortinput.txt
19+
20+
profiling: setup
21+
docker exec -it $(CONTAINER_NAME) cabal build --enable-profiling
22+
docker exec -it $(CONTAINER_NAME) ./profile input.txt
23+
24+
run: setup
25+
docker exec -it $(CONTAINER_NAME) cabal build
26+
docker exec -it $(CONTAINER_NAME) ./run input.txt
27+
28+
.PHONY: all $(TARGET) clean setup profiling run

0 commit comments

Comments
 (0)