git.iko.soy/project-m36
on 52182bc help sign in
project-m36/src/lib/ProjectM36/Relation.hs
333 lines 17 kB history raw
1{-# LANGUAGE GADTs,ExistentialQuantification #-}
2module ProjectM36.Relation where
3import qualified Data.Set as S
4import qualified Data.HashSet as HS
5import Control.Monad
6import qualified Data.Vector as V
7import qualified Data.Map as M
8import ProjectM36.AtomType
9import ProjectM36.Base
10import ProjectM36.Tuple
11import qualified ProjectM36.Attribute as A
12import ProjectM36.TupleSet
13import ProjectM36.Error
14import ProjectM36.MiscUtils
15--import qualified Control.Parallel.Strategies as P
16import qualified ProjectM36.TypeConstructorDef as TCD
17import qualified ProjectM36.DataConstructorDef as DCD
18import qualified Data.Text as T
19import Data.Either (isRight)
20import System.Random.Shuffle
21import Control.Monad.Random
22import Data.List (sort)
24attributes :: Relation -> Attributes
25attributes (Relation attrs _ ) = attrs
27attributeNames :: Relation -> S.Set AttributeName
28attributeNames (Relation attrs _) = A.attributeNameSet attrs
30attributeForName :: AttributeName -> Relation -> Either RelationalError Attribute
31attributeForName attrName (Relation attrs _) = A.attributeForName attrName attrs
33attributesForNames :: S.Set AttributeName -> Relation -> Attributes
34attributesForNames attrNameSet (Relation attrs _) = A.attributesForNames attrNameSet attrs
36atomTypeForName :: AttributeName -> Relation -> Either RelationalError AtomType
37atomTypeForName attrName (Relation attrs _) = A.atomTypeForAttributeName attrName attrs
39mkRelationFromList :: Attributes -> [[Atom]] -> Either RelationalError Relation
40mkRelationFromList attrs atomMatrix =
41 Relation attrs <$> mkTupleSetFromList attrs atomMatrix
43emptyRelationWithAttrs :: Attributes -> Relation
44emptyRelationWithAttrs attrs = Relation attrs emptyTupleSet
46mkRelation :: Attributes -> RelationTupleSet -> Either RelationalError Relation
47mkRelation attrs tupleSet =
48 --check that all attributes are unique- this cannot be done when creating attributes because the check can become expensive
49 let duplicateAttrNames = dupes (sort (map A.attributeName (V.toList attrs))) in
50 if not (null duplicateAttrNames) then
51 Left (DuplicateAttributeNamesError (S.fromList duplicateAttrNames))
52 else
53 --check that all tuples have the same keys
54 --check that all tuples have keys (1-N) where N is the attribute count
55 case verifyTupleSet attrs tupleSet of
56 Left err -> Left err
57 Right verifiedTupleSet -> return $ Relation attrs verifiedTupleSet
59--less safe version of mkRelation skips verifyTupleSet
60--useful for infinite or thunked tuple sets
61--instead of returning a Left RelationalError, if a tuple does not match the relation's attributes, the tuple is simply removed
62--duplicate tuples are NOT filtered by this creation method
63mkRelationDeferVerify :: Attributes -> RelationTupleSet -> Either RelationalError Relation
64mkRelationDeferVerify attrs tupleSet = return $ Relation attrs (RelationTupleSet (filter tupleFilter (asList tupleSet)))
65 where
66 tupleFilter tuple = isRight (verifyTuple attrs tuple)
68--return a relation of the same type except without any tuples
69relationWithEmptyTupleSet :: Relation -> Relation
70relationWithEmptyTupleSet (Relation attrs _) = emptyRelationWithAttrs attrs
72mkRelationFromTuples :: Attributes -> [RelationTuple] -> Either RelationalError Relation
73mkRelationFromTuples attrs tupleSetList = do
74 tupSet <- mkTupleSet attrs tupleSetList
75 mkRelation attrs tupSet
77relationTrue :: Relation
78relationTrue = Relation A.emptyAttributes singletonTupleSet
80relationFalse :: Relation
81relationFalse = Relation A.emptyAttributes emptyTupleSet
83--if the relation contains one tuple, return it, otherwise Nothing
84singletonTuple :: Relation -> Maybe RelationTuple
85singletonTuple rel@(Relation _ tupleSet) = if cardinality rel == Finite 1 then
86 Just $ head $ asList tupleSet
87 else
88 Nothing
90-- this is still unncessarily expensive for (bigx union bigx) because each tuple is hashed and compared for equality (when the hashes match), but the major expense is attributesEqual, but we already know that all tuple attributes are equal (it's a precondition)
91union :: Relation -> Relation -> Either RelationalError Relation
92union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =
93 if not (A.attributesEqual attrs1 attrs2)
94 then Left $ AttributeNamesMismatchError (A.attributeNameSet (A.attributesDifference attrs1 attrs2))
95 else
96 Right $ Relation attrs1 newtuples
97 where
98 newtuples = RelationTupleSet $ HS.toList . HS.fromList $ asList tupSet1 ++ map (reorderTuple attrs1) (asList tupSet2)
100project :: S.Set AttributeName -> Relation -> Either RelationalError Relation
101project attrNames rel@(Relation _ tupSet) = do
102 newAttrs <- A.projectionAttributesForNames attrNames (attributes rel)
103 let newAttrNameSet = A.attributeNameSet newAttrs
104 newTupleList = map (tupleProject newAttrNameSet) (asList tupSet)
105 pure (Relation newAttrs (RelationTupleSet (HS.toList (HS.fromList newTupleList))))
107rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
108rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet)
109 | not attributeValid = Left $ AttributeNamesMismatchError (S.singleton oldAttrName)
110 | newAttributeInUse = Left $ AttributeNameInUseError newAttrName
111 | otherwise = mkRelation newAttrs newTupSet
112 where
113 newAttributeInUse = A.attributeNamesContained (S.singleton newAttrName) (attributeNames rel)
114 attributeValid = A.attributeNamesContained (S.singleton oldAttrName) (attributeNames rel)
115 newAttrs = A.renameAttributes oldAttrName newAttrName oldAttrs
116 newTupSet = RelationTupleSet $ map tupsetmapper (asList oldTupSet)
117 tupsetmapper = tupleRenameAttribute oldAttrName newAttrName
119--the algebra should return a relation of one attribute and one row with the arity
120arity :: Relation -> Int
121arity (Relation attrs _) = A.arity attrs
123degree :: Relation -> Int
124degree = arity
126cardinality :: Relation -> RelationCardinality --we need to detect infinite tuple sets- perhaps with a flag
127cardinality (Relation _ tupSet) = Finite (length (asList tupSet))
129--find tuples where the atoms in the relation which are NOT in the AttributeNameSet are equal
130-- create a relation for each tuple where the attributes NOT in the AttributeNameSet are equal
131--the attrname set attrs end up in the nested relation
133--algorithm:
134-- map projection of non-grouped attributes to restriction of matching grouped attribute tuples and then project on grouped attributes to construct the sub-relation
135{-
136group :: S.Set AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
137group groupAttrNames newAttrName rel@(Relation oldAttrs tupleSet) = do
138 nonGroupProjection <- project nonGroupAttrNames rel
139 relFold folder (Right (Relation newAttrs emptyTupleSet)) nonGroupProjection
140 where
141 newAttrs = M.union (attributesForNames nonGroupAttrNames rel) groupAttr
142 groupAttr = Attribute newAttrName RelationAtomType (invertedAttributeNames groupAttrNames (attributes rel))
143 nonGroupAttrNames = invertAttributeNames (attributes rel) groupAttrNames
144 --map the projection to add the additional new attribute
145 --create the new attribute (a new relation) by filtering and projecting the tupleSet
146 folder tupleFromProjection acc = case acc of
147 Left err -> Left err
148 Right acc -> union acc (Relation newAttrs (HS.singleton (tupleExtend tupleFromProjection (matchingRelTuple tupleFromProjection))))
149-}
151--algorithm: self-join with image relation
152group :: S.Set AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
153group groupAttrNames newAttrName rel = do
154 let nonGroupAttrNames = A.nonMatchingAttributeNameSet groupAttrNames (S.fromList (V.toList (A.attributeNames (attributes rel))))
155 nonGroupProjectionAttributes <- A.projectionAttributesForNames nonGroupAttrNames (attributes rel)
156 groupProjectionAttributes <- A.projectionAttributesForNames groupAttrNames (attributes rel)
157 let groupAttr = Attribute newAttrName (RelationAtomType groupProjectionAttributes)
158 matchingRelTuple tupIn = case imageRelationFor tupIn rel of
159 Right rel2 -> RelationTuple (V.singleton groupAttr) (V.singleton (RelationAtom rel2))
160 Left _ -> undefined
161 mogrifier tupIn = pure (tupleExtend tupIn (matchingRelTuple tupIn))
162 newAttrs = A.addAttribute groupAttr nonGroupProjectionAttributes
163 nonGroupProjection <- project nonGroupAttrNames rel
164 relMogrify mogrifier newAttrs nonGroupProjection
167--help restriction function
168--returns a subrelation of
169restrictEq :: RelationTuple -> Relation -> Either RelationalError Relation
170restrictEq tuple = restrict rfilter
171 where
172 rfilter :: RelationTuple -> Either RelationalError Bool
173 rfilter tupleIn = pure (tupleIntersection tuple tupleIn == tuple)
175-- unwrap relation-valued attribute
176-- return error if relval attrs and nongroup attrs overlap
177ungroup :: AttributeName -> Relation -> Either RelationalError Relation
178ungroup relvalAttrName rel = case attributesForRelval relvalAttrName rel of
179 Left err -> Left err
180 Right relvalAttrs -> relFold relFolder (Right $ Relation newAttrs emptyTupleSet) rel
181 where
182 newAttrs = A.addAttributes relvalAttrs nonGroupAttrs
183 nonGroupAttrs = A.deleteAttributeName relvalAttrName (attributes rel)
184 relFolder :: RelationTuple -> Either RelationalError Relation -> Either RelationalError Relation
185 relFolder tupleIn acc = case acc of
186 Left err -> Left err
187 Right accRel -> do
188 ungrouped <- tupleUngroup relvalAttrName newAttrs tupleIn
189 accRel `union` ungrouped
191--take an relval attribute name and a tuple and ungroup the relval
192tupleUngroup :: AttributeName -> Attributes -> RelationTuple -> Either RelationalError Relation
193tupleUngroup relvalAttrName newAttrs tuple = do
194 relvalRelation <- relationForAttributeName relvalAttrName tuple
195 relFold folder (Right $ Relation newAttrs emptyTupleSet) relvalRelation
196 where
197 nonGroupTupleProjection = tupleProject nonGroupAttrNames tuple
198 nonGroupAttrNames = A.attributeNameSet newAttrs
199 folder tupleIn acc = case acc of
200 Left err -> Left err
201 Right accRel -> union accRel $ Relation newAttrs (RelationTupleSet [tupleExtend nonGroupTupleProjection tupleIn])
203attributesForRelval :: AttributeName -> Relation -> Either RelationalError Attributes
204attributesForRelval relvalAttrName (Relation attrs _) = do
205 atomType <- A.atomTypeForAttributeName relvalAttrName attrs
206 case atomType of
207 (RelationAtomType relAttrs) -> Right relAttrs
208 _ -> Left $ AttributeIsNotRelationValuedError relvalAttrName
210type RestrictionFilter = RelationTuple -> Either RelationalError Bool
211restrict :: RestrictionFilter -> Relation -> Either RelationalError Relation
212restrict rfilter (Relation attrs tupset) = do
213 tuples <- filterM rfilter (asList tupset)
214 Right $ Relation attrs (RelationTupleSet tuples)
216--joins on columns with the same name- use rename to avoid this- base case: cartesian product
217--after changing from string atoms, there needs to be a type-checking step!
218--this is a "nested loop" scan as described by the postgresql documentation
219join :: Relation -> Relation -> Either RelationalError Relation
220join (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) = do
221 newAttrs <- A.joinAttributes attrs1 attrs2
222 let tupleSetJoiner accumulator tuple1 = do
223 joinedTupSet <- singleTupleSetJoin newAttrs tuple1 tupSet2
224 return $ joinedTupSet ++ accumulator
225 newTupSetList <- foldM tupleSetJoiner [] (asList tupSet1)
226 Relation newAttrs <$> mkTupleSet newAttrs newTupSetList
228-- | Difference takes two relations of the same type and returns a new relation which contains only tuples which appear in the first relation but not the second.
229difference :: Relation -> Relation -> Either RelationalError Relation
230difference relA relB =
231 if not (A.attributesEqual (attributes relA) (attributes relB))
232 then
233 Left $ AttributeNamesMismatchError (A.attributeNameSet (A.attributesDifference attrsA attrsB))
234 else
235 restrict rfilter relA
236 where
237 attrsA = attributes relA
238 attrsB = attributes relB
239 rfilter tupInA = relFold (\tupInB acc -> if acc == Right False then pure False else pure (tupInB /= tupInA)) (Right True) relB
241--a map should NOT change the structure of a relation, so attributes should be constant
242relMap :: (RelationTuple -> Either RelationalError RelationTuple) -> Relation -> Either RelationalError Relation
243relMap mapper (Relation attrs tupleSet) =
244 case forM (asList tupleSet) typeMapCheck of
245 Right remappedTupleSet -> mkRelation attrs (RelationTupleSet remappedTupleSet)
246 Left err -> Left err
247 where
248 typeMapCheck tupleIn = do
249 remappedTuple <- mapper tupleIn
250 if tupleAttributes remappedTuple == tupleAttributes tupleIn
251 then Right remappedTuple
252 else Left (TupleAttributeTypeMismatchError (A.attributesDifference (tupleAttributes tupleIn) attrs))
254relMogrify :: (RelationTuple -> Either RelationalError RelationTuple) -> Attributes -> Relation -> Either RelationalError Relation
255relMogrify mapper newAttributes (Relation _ tupSet) = do
256 newTuples <- mapM mapper (asList tupSet)
257 mkRelationFromTuples newAttributes newTuples
259relFold :: (RelationTuple -> a -> a) -> a -> Relation -> a
260relFold folder acc (Relation _ tupleSet) = foldr folder acc (asList tupleSet)
262-- | Generate a randomly-ordered list of tuples from the relation.
263toList :: Relation -> IO [RelationTuple]
264toList rel = do
265 gen <- newStdGen
266 let rel' = evalRand (randomizeTupleOrder rel) gen
267 pure (relFold (:) [] rel')
269--image relation as defined by CJ Date
270--given tupleA and relationB, return restricted relation where tuple attributes are not the attribues in tupleA but are attributes in relationB and match the tuple's value
272--check that matching attribute names have the same types
273imageRelationFor :: RelationTuple -> Relation -> Either RelationalError Relation
274imageRelationFor matchTuple rel = do
275 restricted <- restrictEq matchTuple rel --restrict across matching tuples
276 let projectionAttrNames = A.nonMatchingAttributeNameSet (attributeNames rel) (tupleAttributeNameSet matchTuple)
277 project projectionAttrNames restricted --project across attributes not in rel
279--returns a relation-valued attribute image relation for each tuple in rel1
280--algorithm:
281 {-
282imageRelationJoin :: Relation -> Relation -> Either RelationalError Relation
283imageRelationJoin rel1@(Relation attrNameSet1 tupSet1) rel2@(Relation attrNameSet2 tupSet2) = do
284 Right $ Relation undefined
285 where
286 matchingAttrs = matchingAttributeNameSet attrNameSet1 attrNameSet2
287 newAttrs = nonMatchingAttributeNameSet matchingAttrs $ S.union attrNameSet1 attrNameSet2
289 tupleSetJoiner tup1 acc = undefined
290-}
292-- | Return a Relation describing the types in the mapping.
293typesAsRelation :: TypeConstructorMapping -> Either RelationalError Relation
294typesAsRelation types = mkRelationFromTuples attrs tuples
295 where
296 attrs = A.attributesFromList [Attribute "TypeConstructor" TextAtomType,
297 Attribute "DataConstructors" dConsType]
298 subAttrs = A.attributesFromList [Attribute "DataConstructor" TextAtomType]
299 dConsType = RelationAtomType subAttrs
300 tuples = map mkTypeConsDescription types
302 mkTypeConsDescription (tCons, dConsList) = RelationTuple attrs (V.fromList [TextAtom (TCD.name tCons), mkDataConsRelation dConsList])
304 mkDataConsRelation dConsList = case mkRelationFromTuples subAttrs $ map (\dCons -> RelationTuple subAttrs (V.singleton $ TextAtom $ T.intercalate " " (DCD.name dCons:map (T.pack . show) (DCD.fields dCons)))) dConsList of
305 Left err -> error ("mkRelationFromTuples pooped " ++ show err)
306 Right rel -> RelationAtom rel
308-- | Return a Relation describing the relation variables.
309relationVariablesAsRelation :: M.Map RelVarName Relation -> Either RelationalError Relation
310relationVariablesAsRelation relVarMap = mkRelationFromList attrs tups
311 where
312 subrelAttrs = A.attributesFromList [Attribute "attribute" TextAtomType, Attribute "type" TextAtomType]
313 attrs = A.attributesFromList [Attribute "name" TextAtomType,
314 Attribute "attributes" (RelationAtomType subrelAttrs)]
315 tups = map relVarToAtomList (M.toList relVarMap)
316 relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributes rel)]
317 attributesToRel attrl = case mkRelationFromList subrelAttrs (map attrAtoms (V.toList attrl)) of
318 Left err -> error ("relationVariablesAsRelation pooped " ++ show err)
319 Right rel -> RelationAtom rel
320 attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))]
322-- | Randomly resort the tuples. This is useful for emphasizing that two relations are equal even when they are printed to the console in different orders.
323randomizeTupleOrder :: MonadRandom m => Relation -> m Relation
324randomizeTupleOrder (Relation attrs tupSet) =
325 Relation attrs . RelationTupleSet <$> shuffleM (asList tupSet)
327-- returns a tuple from the tupleset- this is useful for priming folds over the tuples
328oneTuple :: Relation -> Maybe RelationTuple
329oneTuple (Relation _ (RelationTupleSet [])) = Nothing
330oneTuple (Relation _ (RelationTupleSet (x:_))) = Just x
332tuplesList :: Relation -> [RelationTuple]
333tuplesList (Relation _ tupleSet) = asList tupleSet