diff options
| -rw-r--r-- | 5-2.hs | 93 |
1 files changed, 93 insertions, 0 deletions
@@ -0,0 +1,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 |