import Data.List

-- BEGIN DATA STRUCTURES --

--IMPORTANT: Attribute lists are assumed to be duplicate free

-- Attribute defintion
data Attribute = Attribute Char deriving (Show,Eq, Ord)

-- A MVD (or the more special case of an FD)
data MVD = FD [Attribute] [Attribute] | MVD [Attribute] [Attribute] deriving (Show,Eq)

-- A relation
data Relation = Relation [Attribute] [MVD]  deriving (Show,Eq)

--Remove old MVD (if elem), add new
replaceMvd :: Relation -> MVD -> MVD -> Relation
replaceMvd (Relation attrs mvds) old new = (Relation attrs newMvds)
  where newMvds = (filter (\x -> x /= old) mvds)++[new]

--Find out if a prticular FD is also a MVD
isFD :: MVD -> Bool
isFD (FD _ _) = True
isFD (MVD _ _) = False

-- END DATA STRUCTURES --

-- BEGIN COMPUTING CLOSURES --

-- Compute the closure (This is formulated as a fixpoint operation)
closure :: [Attribute] -> Relation -> [Attribute]
closure a r | sort (nub a) == sort nextRun = a
        | otherwise = closure nextRun r
  where nextRun = closureRun a r --No need to nub here, already done by the resultFunction

-- Do the next run of the closure algorithm (used to find out if we have a fixpoint)
closureRun :: [Attribute] -> Relation -> [Attribute]
closureRun a (Relation _ []) = a
closureRun a (Relation as (mvd:mvds)) = closureRun (result a mvd) (Relation as mvds)

-- Get transitive attributes wrt to particular MVD (FD actually, MVDs are just handeled
-- here for the sake of simplicity)
result :: [Attribute] -> MVD -> [Attribute]
result x (MVD _ _) = x
result x (FD ls rs) | null (ls \\ x) = x `union` rs --If everything from ls is also in x we can merge
            | otherwise = x

-- END COMPUTING CLOSURES --

-- BEGIN LEFT REDUTION --

leftReduce :: Relation -> Relation
leftReduce (Relation attrs mvds) = leftReduceFDs (Relation attrs mvds) mvds

-- Left reduce all given MVDs, the second attribute is a list of mvds that are still to do
leftReduceFDs :: Relation -> [MVD] -> Relation
leftReduceFDs r [] = r
leftReduceFDs r ((MVD _ _):mvds) = leftReduceFDs r mvds
leftReduceFDs orgR ((FD ls rs):mvds) = leftReduceFDs (replaceMvd orgR orgFD (remLOneMVD orgR orgFD ls)) mvds
  where orgFD = (FD ls rs)

--Removes all superfluos attributes on the left of one MVD
remLOneMVD :: Relation -> MVD -> [Attribute] -> MVD
remLOneMVD _ (MVD ls rs) _ = (MVD ls rs) -- MVDs need not be reduced
remLOneMVD r (FD ls rs) [] = (FD ls rs)  -- base case
remLOneMVD r (FD ls rs) (todo:todos) | isSuperfluosOnLeft r (FD ls rs) todo = remLOneMVD r (FD (delete todo ls) rs) todos --If current attribute is superfluos, remove it and recurse
                     | otherwise = remLOneMVD r (FD ls rs) todos

-- Checks if a given attribute is superfluos in a given FD
isSuperfluosOnLeft :: Relation -> MVD -> Attribute -> Bool
isSuperfluosOnLeft _ (MVD _ _) _ = False
isSuperfluosOnLeft (Relation as mvds) (FD ls rs) a = a `elem` (closure attrsWithoutA (Relation as mvds))
  where attrsWithoutA = delete a ls)
-- END LEFT REDUCTION --

-- BEGIN RIGHT REDUTION --

rightReduce :: Relation -> Relation
rightReduce (Relation attrs mvds) = rightReduceFDs (Relation attrs mvds) mvds

-- right reduce all given MVDs, the second attribute is a list of mvds that are still to do
rightReduceFDs :: Relation -> [MVD] -> Relation
rightReduceFDs r [] = r
rightReduceFDs r ((MVD _ _):mvds) = rightReduceFDs r mvds
rightReduceFDs orgR ((FD ls rs):mvds) =  rightReduceFDs (replaceMvd orgR orgFD (remROneMVD orgR orgFD rs)) mvds
  where orgFD = (FD ls rs)

--Removes all superfluos attributes on the right of one MVD
remROneMVD :: Relation -> MVD -> [Attribute] -> MVD
remROneMVD _ (MVD ls rs) _ = (MVD ls rs) -- MVDs need not be reduced
remROneMVD r (FD ls rs) [] = (FD ls rs)  -- base case
remROneMVD r (FD ls rs) (todo:todos) | isSuperfluosOnRight r (FD ls rs) todo = remROneMVD r (FD  ls (delete todo rs)) todos --If current attribute i superfluos
                     | otherwise = remROneMVD r (FD ls rs) todos

-- Checks if a given attribute is superfluos in a given FD
isSuperfluosOnRight :: Relation -> MVD -> Attribute -> Bool
isSuperfluosOnRight _ (MVD _ _) _ = False
isSuperfluosOnRight (Relation as mvds) (FD ls rs) a = a `elem` closure ls (replaceMvd (Relation as mvds) (FD ls rs) (FD ls rsWithoutA))
  where rsWithoutA = delete a rs
-- END RIGHT REDUCTION --

-- BEGIN CANONICAL COVER --
canonicalCover :: Relation -> Relation
canonicalCover r = mergeDuplicates $ remEmptyFD $ rightReduce $ leftReduce r

-- Remove FDs of the form X -> {}
remEmptyFD :: Relation -> Relation
remEmptyFD (Relation atts mvds) = (Relation atts (filter helper mvds))
  where helper (FD rs []) = False
    helper _ = True

-- Merge duplicate FDs of the form A->X A->Y into A -> X u Y
mergeDuplicates :: Relation -> Relation
mergeDuplicates (Relation as mvds) = (Relation as ((addAllToProperMVD (leftSides justFDs) justFDs)++justMVDs))
  where justFDs = filter isFD mvds
    justMVDs = filter (not.isFD) mvds

-- add all right sides of the given FDs to the proper FD in mvd (obtained e.g. from leftSides)
addAllToProperMVD :: [MVD] -> [MVD] ->[MVD]
addAllToProperMVD mvds (todo:todos) = addAllToProperMVD (addToProperMVD mvds todo) todos
addAllToProperMVD mvds [] = mvds

--add right side of a given FD to the correct FD in the list (e.g. obtained from leftSides)
addToProperMVD :: [MVD] -> MVD -> [MVD]
addToProperMVD ((FD ls rs):mvds) (FD ls' rs') | sort ls == sort ls' = (FD ls (nub rs++rs')):mvds
                          | otherwise = (FD ls rs):(addToProperMVD mvds (FD ls' rs'))

--Create FDs of the form A -> {} for each individual A
leftSides :: [MVD] ->  [MVD]
leftSides mvds = map (\ls -> FD ls []) (nub $ map (\(FD ls rs) -> sort ls) mvds)
-- END CANONICAL COVER --