git.iko.soy/project-m36
on d64cdeb help sign in
project-m36/src/lib/ProjectM36/Relation.hs
329 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 = do
41 tupSet <- mkTupleSetFromList attrs atomMatrix
42 return $ Relation attrs tupSet
44emptyRelationWithAttrs :: Attributes -> Relation
45emptyRelationWithAttrs attrs = Relation attrs emptyTupleSet
47mkRelation :: Attributes -> RelationTupleSet -> Either RelationalError Relation
48mkRelation attrs tupleSet =
49 --check that all attributes are unique- this cannot be done when creating attributes because the check can become expensive
50 let duplicateAttrNames = dupes (sort (map A.attributeName (V.toList attrs))) in
51 if not (null duplicateAttrNames) then
52 Left (DuplicateAttributeNamesError (S.fromList duplicateAttrNames))
53 else
54 --check that all tuples have the same keys
55 --check that all tuples have keys (1-N) where N is the attribute count
56 case verifyTupleSet attrs tupleSet of
57 Left err -> Left err
58 Right verifiedTupleSet -> return $ Relation attrs verifiedTupleSet
60--less safe version of mkRelation skips verifyTupleSet
61--useful for infinite or thunked tuple sets
62--instead of returning a Left RelationalError, if a tuple does not match the relation's attributes, the tuple is simply removed
63--duplicate tuples are NOT filtered by this creation method
64mkRelationDeferVerify :: Attributes -> RelationTupleSet -> Either RelationalError Relation
65mkRelationDeferVerify attrs tupleSet = return $ Relation attrs (RelationTupleSet (filter tupleFilter (asList tupleSet)))
66 where
67 tupleFilter tuple = isRight (verifyTuple attrs tuple)
69mkRelationFromTuples :: Attributes -> [RelationTuple] -> Either RelationalError Relation
70mkRelationFromTuples attrs tupleSetList = do
71 tupSet <- mkTupleSet attrs tupleSetList
72 mkRelation attrs tupSet
74relationTrue :: Relation
75relationTrue = Relation A.emptyAttributes singletonTupleSet
77relationFalse :: Relation
78relationFalse = Relation A.emptyAttributes emptyTupleSet
80--if the relation contains one tuple, return it, otherwise Nothing
81singletonTuple :: Relation -> Maybe RelationTuple
82singletonTuple rel@(Relation _ tupleSet) = if cardinality rel == Finite 1 then
83 Just $ head $ asList tupleSet
84 else
85 Nothing
87-- 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)
88union :: Relation -> Relation -> Either RelationalError Relation
89union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =
90 if not (A.attributesEqual attrs1 attrs2)
91 then Left $ AttributeNamesMismatchError (A.attributeNameSet (A.attributesDifference attrs1 attrs2))
92 else
93 Right $ Relation attrs1 newtuples
94 where
95 newtuples = RelationTupleSet $ HS.toList . HS.fromList $ asList tupSet1 ++ map (reorderTuple attrs1) (asList tupSet2)
97project :: S.Set AttributeName -> Relation -> Either RelationalError Relation
98project attrNames rel@(Relation _ tupSet) = do
99 newAttrs <- A.projectionAttributesForNames attrNames (attributes rel)
100 let newAttrNameSet = A.attributeNameSet newAttrs
101 newTupleList = map (tupleProject newAttrNameSet) (asList tupSet)
102 pure (Relation newAttrs (RelationTupleSet (HS.toList (HS.fromList newTupleList))))
104rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
105rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet)
106 | not attributeValid = Left $ AttributeNamesMismatchError (S.singleton oldAttrName)
107 | newAttributeInUse = Left $ AttributeNameInUseError newAttrName
108 | otherwise = mkRelation newAttrs newTupSet
109 where
110 newAttributeInUse = A.attributeNamesContained (S.singleton newAttrName) (attributeNames rel)
111 attributeValid = A.attributeNamesContained (S.singleton oldAttrName) (attributeNames rel)
112 newAttrs = A.renameAttributes oldAttrName newAttrName oldAttrs
113 newTupSet = RelationTupleSet $ map tupsetmapper (asList oldTupSet)
114 tupsetmapper = tupleRenameAttribute oldAttrName newAttrName
116--the algebra should return a relation of one attribute and one row with the arity
117arity :: Relation -> Int
118arity (Relation attrs _) = A.arity attrs
120degree :: Relation -> Int
121degree = arity
123cardinality :: Relation -> RelationCardinality --we need to detect infinite tuple sets- perhaps with a flag
124cardinality (Relation _ tupSet) = Finite (length (asList tupSet))
126--find tuples where the atoms in the relation which are NOT in the AttributeNameSet are equal
127-- create a relation for each tuple where the attributes NOT in the AttributeNameSet are equal
128--the attrname set attrs end up in the nested relation
130--algorithm:
131-- map projection of non-grouped attributes to restriction of matching grouped attribute tuples and then project on grouped attributes to construct the sub-relation
132{-
133group :: S.Set AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
134group groupAttrNames newAttrName rel@(Relation oldAttrs tupleSet) = do
135 nonGroupProjection <- project nonGroupAttrNames rel
136 relFold folder (Right (Relation newAttrs emptyTupleSet)) nonGroupProjection
137 where
138 newAttrs = M.union (attributesForNames nonGroupAttrNames rel) groupAttr
139 groupAttr = Attribute newAttrName RelationAtomType (invertedAttributeNames groupAttrNames (attributes rel))
140 nonGroupAttrNames = invertAttributeNames (attributes rel) groupAttrNames
141 --map the projection to add the additional new attribute
142 --create the new attribute (a new relation) by filtering and projecting the tupleSet
143 folder tupleFromProjection acc = case acc of
144 Left err -> Left err
145 Right acc -> union acc (Relation newAttrs (HS.singleton (tupleExtend tupleFromProjection (matchingRelTuple tupleFromProjection))))
146-}
148--algorithm: self-join with image relation
149group :: S.Set AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
150group groupAttrNames newAttrName rel = do
151 let nonGroupAttrNames = A.nonMatchingAttributeNameSet groupAttrNames (S.fromList (V.toList (A.attributeNames (attributes rel))))
152 nonGroupProjectionAttributes <- A.projectionAttributesForNames nonGroupAttrNames (attributes rel)
153 groupProjectionAttributes <- A.projectionAttributesForNames groupAttrNames (attributes rel)
154 let groupAttr = Attribute newAttrName (RelationAtomType groupProjectionAttributes)
155 matchingRelTuple tupIn = case imageRelationFor tupIn rel of
156 Right rel2 -> RelationTuple (V.singleton groupAttr) (V.singleton (RelationAtom rel2))
157 Left _ -> undefined
158 mogrifier tupIn = pure (tupleExtend tupIn (matchingRelTuple tupIn))
159 newAttrs = A.addAttribute groupAttr nonGroupProjectionAttributes
160 nonGroupProjection <- project nonGroupAttrNames rel
161 relMogrify mogrifier newAttrs nonGroupProjection
164--help restriction function
165--returns a subrelation of
166restrictEq :: RelationTuple -> Relation -> Either RelationalError Relation
167restrictEq tuple = restrict rfilter
168 where
169 rfilter :: RelationTuple -> Either RelationalError Bool
170 rfilter tupleIn = pure (tupleIntersection tuple tupleIn == tuple)
172-- unwrap relation-valued attribute
173-- return error if relval attrs and nongroup attrs overlap
174ungroup :: AttributeName -> Relation -> Either RelationalError Relation
175ungroup relvalAttrName rel = case attributesForRelval relvalAttrName rel of
176 Left err -> Left err
177 Right relvalAttrs -> relFold relFolder (Right $ Relation newAttrs emptyTupleSet) rel
178 where
179 newAttrs = A.addAttributes relvalAttrs nonGroupAttrs
180 nonGroupAttrs = A.deleteAttributeName relvalAttrName (attributes rel)
181 relFolder :: RelationTuple -> Either RelationalError Relation -> Either RelationalError Relation
182 relFolder tupleIn acc = case acc of
183 Left err -> Left err
184 Right accRel -> do
185 ungrouped <- tupleUngroup relvalAttrName newAttrs tupleIn
186 accRel `union` ungrouped
188--take an relval attribute name and a tuple and ungroup the relval
189tupleUngroup :: AttributeName -> Attributes -> RelationTuple -> Either RelationalError Relation
190tupleUngroup relvalAttrName newAttrs tuple = do
191 relvalRelation <- relationForAttributeName relvalAttrName tuple
192 relFold folder (Right $ Relation newAttrs emptyTupleSet) relvalRelation
193 where
194 nonGroupTupleProjection = tupleProject nonGroupAttrNames tuple
195 nonGroupAttrNames = A.attributeNameSet newAttrs
196 folder tupleIn acc = case acc of
197 Left err -> Left err
198 Right accRel -> union accRel $ Relation newAttrs (RelationTupleSet [tupleExtend nonGroupTupleProjection tupleIn])
200attributesForRelval :: AttributeName -> Relation -> Either RelationalError Attributes
201attributesForRelval relvalAttrName (Relation attrs _) = do
202 atomType <- A.atomTypeForAttributeName relvalAttrName attrs
203 case atomType of
204 (RelationAtomType relAttrs) -> Right relAttrs
205 _ -> Left $ AttributeIsNotRelationValuedError relvalAttrName
207type RestrictionFilter = RelationTuple -> Either RelationalError Bool
208restrict :: RestrictionFilter -> Relation -> Either RelationalError Relation
209restrict rfilter (Relation attrs tupset) = do
210 tuples <- filterM rfilter (asList tupset)
211 Right $ Relation attrs (RelationTupleSet tuples)
213--joins on columns with the same name- use rename to avoid this- base case: cartesian product
214--after changing from string atoms, there needs to be a type-checking step!
215--this is a "nested loop" scan as described by the postgresql documentation
216join :: Relation -> Relation -> Either RelationalError Relation
217join (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) = do
218 newAttrs <- A.joinAttributes attrs1 attrs2
219 let tupleSetJoiner accumulator tuple1 = do
220 joinedTupSet <- singleTupleSetJoin newAttrs tuple1 tupSet2
221 return $ joinedTupSet ++ accumulator
222 newTupSetList <- foldM tupleSetJoiner [] (asList tupSet1)
223 newTupSet <- mkTupleSet newAttrs newTupSetList
224 return $ Relation newAttrs newTupSet
226-- | 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.
227difference :: Relation -> Relation -> Either RelationalError Relation
228difference relA relB =
229 if not (A.attributesEqual (attributes relA) (attributes relB))
230 then
231 Left $ AttributeNamesMismatchError (A.attributeNameSet (A.attributesDifference attrsA attrsB))
232 else
233 restrict rfilter relA
234 where
235 attrsA = attributes relA
236 attrsB = attributes relB
237 rfilter tupInA = relFold (\tupInB acc -> if acc == Right False then pure False else pure (tupInB /= tupInA)) (Right True) relB
239--a map should NOT change the structure of a relation, so attributes should be constant
240relMap :: (RelationTuple -> Either RelationalError RelationTuple) -> Relation -> Either RelationalError Relation
241relMap mapper (Relation attrs tupleSet) =
242 case forM (asList tupleSet) typeMapCheck of
243 Right remappedTupleSet -> mkRelation attrs (RelationTupleSet remappedTupleSet)
244 Left err -> Left err
245 where
246 typeMapCheck tupleIn = do
247 remappedTuple <- mapper tupleIn
248 if tupleAttributes remappedTuple == tupleAttributes tupleIn
249 then Right remappedTuple
250 else Left (TupleAttributeTypeMismatchError (A.attributesDifference (tupleAttributes tupleIn) attrs))
252relMogrify :: (RelationTuple -> Either RelationalError RelationTuple) -> Attributes -> Relation -> Either RelationalError Relation
253relMogrify mapper newAttributes (Relation _ tupSet) = do
254 newTuples <- mapM mapper (asList tupSet)
255 mkRelationFromTuples newAttributes newTuples
257relFold :: (RelationTuple -> a -> a) -> a -> Relation -> a
258relFold folder acc (Relation _ tupleSet) = foldr folder acc (asList tupleSet)
260-- | Generate a randomly-ordered list of tuples from the relation.
261toList :: Relation -> IO [RelationTuple]
262toList rel = do
263 gen <- newStdGen
264 let rel' = evalRand (randomizeTupleOrder rel) gen
265 pure (relFold (:) [] rel')
267--image relation as defined by CJ Date
268--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
270--check that matching attribute names have the same types
271imageRelationFor :: RelationTuple -> Relation -> Either RelationalError Relation
272imageRelationFor matchTuple rel = do
273 restricted <- restrictEq matchTuple rel --restrict across matching tuples
274 let projectionAttrNames = A.nonMatchingAttributeNameSet (attributeNames rel) (tupleAttributeNameSet matchTuple)
275 project projectionAttrNames restricted --project across attributes not in rel
277--returns a relation-valued attribute image relation for each tuple in rel1
278--algorithm:
279 {-
280imageRelationJoin :: Relation -> Relation -> Either RelationalError Relation
281imageRelationJoin rel1@(Relation attrNameSet1 tupSet1) rel2@(Relation attrNameSet2 tupSet2) = do
282 Right $ Relation undefined
283 where
284 matchingAttrs = matchingAttributeNameSet attrNameSet1 attrNameSet2
285 newAttrs = nonMatchingAttributeNameSet matchingAttrs $ S.union attrNameSet1 attrNameSet2
287 tupleSetJoiner tup1 acc = undefined
288-}
290-- | Return a Relation describing the types in the mapping.
291typesAsRelation :: TypeConstructorMapping -> Either RelationalError Relation
292typesAsRelation types = mkRelationFromTuples attrs tuples
293 where
294 attrs = A.attributesFromList [Attribute "TypeConstructor" TextAtomType,
295 Attribute "DataConstructors" dConsType]
296 subAttrs = A.attributesFromList [Attribute "DataConstructor" TextAtomType]
297 dConsType = RelationAtomType subAttrs
298 tuples = map mkTypeConsDescription types
300 mkTypeConsDescription (tCons, dConsList) = RelationTuple attrs (V.fromList [TextAtom (TCD.name tCons), mkDataConsRelation dConsList])
302 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
303 Left err -> error ("mkRelationFromTuples pooped " ++ show err)
304 Right rel -> RelationAtom rel
306-- | Return a Relation describing the relation variables.
307relationVariablesAsRelation :: M.Map RelVarName Relation -> Either RelationalError Relation
308relationVariablesAsRelation relVarMap = mkRelationFromList attrs tups
309 where
310 subrelAttrs = A.attributesFromList [Attribute "attribute" TextAtomType, Attribute "type" TextAtomType]
311 attrs = A.attributesFromList [Attribute "name" TextAtomType,
312 Attribute "attributes" (RelationAtomType subrelAttrs)]
313 tups = map relVarToAtomList (M.toList relVarMap)
314 relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributes rel)]
315 attributesToRel attrl = case mkRelationFromList subrelAttrs (map attrAtoms (V.toList attrl)) of
316 Left err -> error ("relationVariablesAsRelation pooped " ++ show err)
317 Right rel -> RelationAtom rel
318 attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))]
320-- | 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.
321randomizeTupleOrder :: MonadRandom m => Relation -> m Relation
322randomizeTupleOrder (Relation attrs tupSet) = do
323 newTupSet <- shuffleM (asList tupSet)
324 pure (Relation attrs (RelationTupleSet newTupSet))
326-- returns a tuple from the tupleset- this is useful for priming folds over the tuples
327oneTuple :: Relation -> Maybe RelationTuple
328oneTuple (Relation _ (RelationTupleSet [])) = Nothing
329oneTuple (Relation _ (RelationTupleSet (x:_))) = Just x