1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
data Graph a = Graph { vertices :: [(Int,a)], edges :: [(Int,Int)] }
indices :: Graph a -> [Int]
indices (Graph vs _) = map fst vs
nextIdx :: Graph a -> Int
nextIdx (Graph [] _) = 0
nextIdx g = succ . maximum . indices $ g
getIdx :: Eq a => a -> Graph a -> Int
getIdx x = fst . head . filter ((== x) . snd) . vertices
addVertex :: Eq a => a -> Graph a -> (Int,Graph a)
addVertex x g = (idx,g')
where
isElem = x `elem` map snd (vertices g)
idx = if isElem then getIdx x g else nextIdx g
g' = if isElem then g else g { vertices = (idx,x) : vertices g }
addEdge :: Eq a => Graph a -> a -> a -> Graph a
addEdge g p q = g' { edges = (p',q') : edges g }
where
(p',g'') = addVertex p g
(q',g') = addVertex q g''
fromEdges :: [(Int,Int)] -> Graph Int
fromEdges = fr (Graph [] [])
where
fr :: Graph Int -> [(Int,Int)] -> Graph Int
fr g [] = g
fr g ((p,q):pqs) = fr (addEdge g p q) pqs
roots :: Graph a -> [(Int,a)]
roots (Graph vs es) = filter f vs
where
f (x,_) = notElem x . map snd $ es
removeIdx :: Int -> Graph a -> Graph a
removeIdx n (Graph vs es) = let vs' = filter ((/= n) . fst) vs
es' = filter f es
f (p,q) = p /= n && q /= n
in Graph vs' es'
removeIdxs :: Graph a -> [Int] -> Graph a
removeIdxs = foldr removeIdx
removeRoots :: Graph a -> Graph a
removeRoots g = removeIdxs g . map fst . roots $ g
toList :: Graph a -> [a]
toList = tl []
where
tl :: [a] -> Graph a -> [a]
tl xs (Graph [] _) = xs
tl xs g = tl (map snd (roots g) ++ xs) (removeRoots g)
pairs' :: [a] -> [(a,a)] -> [(a,a)]
pairs' [] ys = ys
pairs' (x:xs) ys = pairs' xs (ys ++ map (x,) xs)
pairs :: [a] -> [(a,a)]
pairs xs = pairs' xs []
filterRules :: Eq a => [a] -> [(a,a)] -> [(a,a)]
filterRules xs = filter (\ (p,q) -> p `elem` xs && q `elem` xs)
ordered :: Eq a => [(a,a)] -> [a] -> Bool
ordered ps xs = all (`elem` pairs xs) $ filterRules xs ps
parse :: String -> ([(Int,Int)], [[Int]])
parse s = (map pair ls, map list ks)
where
(ls,_:ks) = span (/= "") (lines s)
pair r = let (p,_:q) = span (/= '|') r in (read p, read q)
list r = read ("[" ++ r ++ "]") :: [Int]
incorrects :: String -> [[Int]]
incorrects s = let (ps,xss) = parse s in filter (not . ordered ps) xss
middle :: [a] -> a
middle xs = xs !! (length xs `div` 2)
order :: [(Int,Int)] -> [Int] -> [Int]
order rules xs = let rules' = filterRules xs rules
in toList . fromEdges $ rules'
main :: IO ()
main = do
s <- getContents
let rules = fst (parse s)
let xs = incorrects s
let result = sum . map (middle . order rules) $ xs
print result
|
