db.hs

{-# Language OverloadedStrings #-}

import qualified Data.Set as S
import qualified Data.Map as M
import Data.List (sort, foldl', find)
import Data.Function(on)
import Control.Applicative (liftA2)
import Data.Monoid ((<>))
import Control.Arrow ((&&&))

main = do
    printSuperkeys $ superkeys $ M.fromList
        [ "ABC" ~> "D"
        , "AC" ~> "F"
        , "BC" ~> "E"
        , "A" ~> "C"
        ]
    putStrLn "-----"
    printDeps $ simplify $ M.fromList
        [ "OY" ~> "HP"
        , "CY" ~> "OP"
        , "HOYV" ~> "B"
        ]
  where
    printSuperkeys keys = mapM_ (putStrLn . S.toList) (sort keys)
    printDeps deps = mapM_ (uncurry printSingle) (M.toAscList deps)
    printSingle k v = putStrLn $ S.toList k <> " -> " <> S.toList v
    (~>) = (,) `on` S.fromList

simplify :: Ord a => M.Map (S.Set a) (S.Set a) -> M.Map (S.Set a) (S.Set a)
simplify = removeTrivial . reduceRight . reduceLeft
 where
    removeTrivial = M.filterWithKey (not .: redundant)
    redundant a b = a == b -- trivial dependency
            || S.null b -- empty rhs

    reduceLeft fd = M.fromListWith S.union $ map (uncurry reduceSingle &&& snd) $  M.toList fd
      where
        reduceSingle lhs rhs = foldl' (step rhs) lhs (S.toList lhs)
        step rhs lhs x = if pred lhs rhs x then x `S.delete` lhs else lhs
        pred lhs rhs x = rhs `S.isSubsetOf` closure fd (S.delete x lhs)

    reduceRight fd = M.mapWithKey reduceSingle fd
      where
        reduceSingle lhs rhs = foldl' (step lhs) rhs (S.toList rhs)
        step lhs rhs x = if pred lhs rhs x then S.delete x rhs else rhs
        pred lhs rhs x = rhs `S.isSubsetOf` closure (M.delete lhs fd) (lhs `S.union` S.delete x rhs)

superkeys :: Ord a => M.Map (S.Set a) (S.Set a) -> [S.Set a]
superkeys dep = filter ((== fullSet) . closure dep) $ powerset (S.toList fullSet)
  where fullSet = M.foldMapWithKey (<>) dep

closure :: Ord a => M.Map (S.Set a) (S.Set a) -> S.Set a -> S.Set a
closure ls = fixpoint step
  where
    step s = foldl' apply s (M.toList ls)
    apply cur (lhs, rhs)
      | lhs `S.isSubsetOf` cur = cur `S.union` rhs
      | otherwise = cur

fixpoint :: Eq a => (a -> a) -> a -> a
fixpoint = fst . head . dropWhile (uncurry (/=)) . (zip <*> tail) .: iterate
infixl 8 .:
(.:) :: (b -> c) -> (a1 -> a -> b) -> a1 -> a -> c
(.:) = (.).(.)

powerset :: Ord a => [a] -> [S.Set a]
powerset = map S.fromList . pow
  where
    pow [] = [[]]
    pow (x:xs) = [(x:), id] <*> pow xs