git.iko.soy/project-m36
on bda2cfc help sign in
project-m36/ProjectM36/Tuple.hs
202 lines 10 kB history raw
1module ProjectM36.Tuple where
2import ProjectM36.Base
3import ProjectM36.Error
4import ProjectM36.Attribute
5import ProjectM36.Atom
7import qualified Data.Map as M
8import qualified Data.Set as S
9import qualified Data.Vector as V
10import Data.Either (rights)
11import Control.Monad
13emptyTuple :: RelationTuple
14emptyTuple = RelationTuple V.empty V.empty
16tupleSize :: RelationTuple -> Int
17tupleSize (RelationTuple tupAttrs _) = V.length tupAttrs
19tupleAttributeNameSet :: RelationTuple -> S.Set AttributeName
20tupleAttributeNameSet (RelationTuple tupAttrs _) = S.fromList $ V.toList $ V.map attributeName tupAttrs
22tupleAttributes :: RelationTuple -> Attributes
23tupleAttributes (RelationTuple tupAttrs _) = tupAttrs
25tupleAssocs :: RelationTuple -> [(AttributeName, Atom)]
26tupleAssocs (RelationTuple attrVec tupVec) = V.toList $ V.map (\(k,v) -> (attributeName k, v)) (V.zip attrVec tupVec)
28-- return atoms in some arbitrary but consistent key order
29tupleAtoms :: RelationTuple -> V.Vector Atom
30tupleAtoms (RelationTuple _ tupVec) = tupVec
32atomForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Atom
33atomForAttributeName attrName (RelationTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) tupAttrs of
34 Nothing -> Left $ NoSuchAttributeNamesError (S.singleton attrName)
35 Just index -> case tupVec V.!? index of
36 Nothing -> Left $ NoSuchAttributeNamesError (S.singleton attrName)
37 Just atom -> Right atom
39{- -- resolve naming clash with Attribute and Relation later
40atomTypeForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Atom
41atomTypeForAttributeName attrName tup = do
42 atom <- atomForAttributeName attrName tup
43 return $ atomTypeForAtom atom
44-}
46atomsForAttributeNames :: V.Vector AttributeName -> RelationTuple -> Either RelationalError (V.Vector Atom)
47atomsForAttributeNames attrNames tuple = do
48 vindices <- vectorIndicesForAttributeNames attrNames (tupleAttributes tuple)
49 return $ V.map (\index -> tupleAtoms tuple V.! index) vindices
51vectorIndicesForAttributeNames :: V.Vector AttributeName -> Attributes -> Either RelationalError (V.Vector Int)
52vectorIndicesForAttributeNames attrNameVec attrs = if not $ V.null unknownAttrNames then
53 Left $ NoSuchAttributeNamesError (S.fromList (V.toList unknownAttrNames))
54 else
55 Right $ V.map mapper attrNameVec
56 where
57 unknownAttrNames = V.filter ((flip V.notElem) (attributeNames attrs)) attrNameVec
58 mapper attrName = case V.elemIndex attrName (V.map attributeName attrs) of
59 Nothing -> undefined
60 Just index -> index
62relationForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Relation
63relationForAttributeName attrName tuple = do
64 aType <- atomTypeForAttributeName attrName (tupleAttributes tuple)
65 if not (isRelationAtomType aType) then
66 Left $ AttributeIsNotRelationValuedError attrName
67 else do
68 atomVal <- atomForAttributeName attrName tuple
69 relationForAtom atomVal
71--in case the oldattr does not exist in the tuple, then return the old tuple
72tupleRenameAttribute :: AttributeName -> AttributeName -> RelationTuple -> RelationTuple
73tupleRenameAttribute oldattr newattr (RelationTuple tupAttrs tupVec) = RelationTuple newAttrs tupVec
74 where
75 newAttrs = renameAttributes oldattr newattr tupAttrs
77mkRelationTuple :: Attributes -> V.Vector Atom -> RelationTuple
78mkRelationTuple attrs atoms = RelationTuple attrs atoms
80mkRelationTuples :: Attributes -> [V.Vector Atom] -> [RelationTuple]
81mkRelationTuples attrs atomsVec = map mapper atomsVec
82 where
83 mapper = mkRelationTuple attrs
85--return error if attribute names match but their types do not
86singleTupleSetJoin :: Attributes -> RelationTuple -> RelationTupleSet -> Either RelationalError [RelationTuple]
87singleTupleSetJoin joinAttrs tup tupSet = do
88 foldM tupleJoiner [] (asList tupSet)
89 where
90 tupleJoiner :: [RelationTuple] -> RelationTuple -> Either RelationalError [RelationTuple]
91 tupleJoiner accumulator tuple2 = case singleTupleJoin joinAttrs tup tuple2 of
92 Right Nothing -> Right accumulator
93 Right (Just relTuple) -> Right $ relTuple : accumulator
94 Left err -> Left err
96{-
97singleTupleSetJoin :: RelationTuple -> RelationTupleSet -> RelationTupleSet
98singleTupleSetJoin tup1 tupSet = HS.union
99 where
100 mapper tup2 = singleTupleJoin tup1 tup2
101-}
103-- if the keys share some keys and values, then merge the tuples
104-- if there are shared attributes, if they match, create a new tuple from the atoms of both tuples based on the attribute ordering argument
105singleTupleJoin :: Attributes -> RelationTuple -> RelationTuple -> Either RelationalError (Maybe RelationTuple)
106singleTupleJoin joinedAttrs tup1@(RelationTuple tupAttrs1 _) tup2@(RelationTuple tupAttrs2 _) = if
107 V.null keysIntersection || atomsForAttributeNames keysIntersection tup1 /= atomsForAttributeNames keysIntersection tup2
108 then
109 return $ Nothing
110 else
111 return $ Just $ RelationTuple joinedAttrs newVec
112 where
113 keysIntersection = V.map attributeName attrsIntersection
114 attrsIntersection = V.filter (flip V.elem $ tupAttrs1) tupAttrs2
115 newVec = V.map (findAtomForAttributeName . attributeName) joinedAttrs
116 --search both tuples for the attribute
117 findAtomForAttributeName attrName = head $ rights $ fmap (atomForAttributeName attrName) [tup1, tup2]
119--same consideration as Data.List.union- duplicates in v1 are not de-duped
120vectorUnion :: (Eq a) => V.Vector a -> V.Vector a -> V.Vector a
121vectorUnion v1 v2 = V.foldr folder v1 v2
122 where
123 folder e acc = if V.elem e v1 then
124 acc
125 else
126 V.snoc acc e
128--precondition- no overlap in attributes
129tupleExtend :: RelationTuple -> RelationTuple -> RelationTuple
130tupleExtend (RelationTuple tupAttrs1 tupVec1) (RelationTuple tupAttrs2 tupVec2) = RelationTuple newAttrs newVec
131 where
132 newAttrs = tupAttrs1 V.++ tupAttrs2
133 newVec = tupVec1 V.++ tupVec2
135tupleAtomExtend :: AttributeName -> Atom -> RelationTuple -> RelationTuple
136tupleAtomExtend newAttrName atom tupIn = tupleExtend tupIn newTup
137 where
138 newTup = RelationTuple (V.singleton $ Attribute newAttrName (atomTypeForAtom atom)) (V.singleton atom)
140{- sort the associative list to match the header sorting -}
141tupleSortedAssocs :: RelationTuple -> [(AttributeName, Atom)]
142tupleSortedAssocs (RelationTuple tupAttrs tupVec) = V.toList $ V.map (\(index,attr) -> (attributeName attr, tupVec V.! index)) $ V.indexed tupAttrs
144--this could be cheaper- it may not be wortwhile to update all the tuples for projection, but then the attribute management must be slightly different- perhaps the attributes should be a vector of association tuples [(name, index)]
145tupleProject :: S.Set AttributeName -> RelationTuple -> RelationTuple
146tupleProject projectAttrs (RelationTuple attrs tupVec) = RelationTuple newAttrs newTupVec
147 where
148 deleteIndices = V.findIndices (\attr -> S.notMember (attributeName attr) projectAttrs) attrs
149 indexDeleter = V.ifilter (\index _ -> V.notElem index deleteIndices)
150 newAttrs = indexDeleter attrs
151 newTupVec = indexDeleter tupVec
153--return the attributes and atoms which are equal in both vectors
154--semi-join
155tupleIntersection :: RelationTuple -> RelationTuple -> RelationTuple
156tupleIntersection tuple1 tuple2 = RelationTuple newAttrs newTupVec
157 where
158 attrs1 = tupleAttributes tuple1
159 attrs2 = tupleAttributes tuple2
160 matchingIndices = V.findIndices (\attr -> V.elem attr attrs2 &&
161 atomForAttributeName (attributeName attr) tuple1 ==
162 atomForAttributeName (attributeName attr) tuple2
163 ) attrs1
164 indexFilter = V.ifilter (\index _ -> V.elem index matchingIndices)
165 newAttrs = indexFilter attrs1
166 newTupVec = indexFilter (tupleAtoms tuple1)
168updateTuple :: (M.Map AttributeName Atom) -> RelationTuple -> RelationTuple
169updateTuple updateMap (RelationTuple attrs tupVec) = RelationTuple attrs newVec
170 where
171 updateKeysSet = M.keysSet updateMap
172 updateKeysIVec = V.filter (\(_,attr) -> S.member (attributeName attr) updateKeysSet) (V.indexed attrs)
173 newVec = V.update tupVec updateVec
174 updateVec = V.map (\(index, attr) -> (index, updateMap M.! (attributeName attr))) updateKeysIVec
176tupleToMap :: RelationTuple -> (M.Map AttributeName Atom)
177tupleToMap (RelationTuple attrs tupVec) = M.fromList assocList
178 where
179 assocList = V.toList $ V.map (\(index, attr) -> (attributeName attr, tupVec V.! index)) (V.indexed attrs)
181verifyTuple :: Attributes -> RelationTuple -> Either RelationalError RelationTuple
182verifyTuple attrs tuple = let attrsTypes = V.map atomType attrs
183 tupleTypes = V.map atomTypeForAtom (tupleAtoms tuple) in
184 if V.length attrs /= V.length tupleTypes then
185 Left $ TupleAttributeCountMismatchError 0
186 else if attrsTypes /= tupleTypes then
187 -- Left $ traceShow (show attrsTypes ++ "gonk" ++ show tupleTypes ++ "done") $ TupleAttributeTypeMismatchError (attributesDifference attrs (tupleAttributes tuple))
188 Left $ TupleAttributeTypeMismatchError (attributesDifference attrs (tupleAttributes tuple))
189 else
190 Right $ tuple
192--two tuples can be equal but the vectors of attributes could be out-of-order
193--reorder if necessary- this is useful during relMogrify so that all the relation's tuples have identical atom/attribute ordering
194reorderTuple :: Attributes -> RelationTuple -> RelationTuple
195reorderTuple attrs tupIn = if tupleAttributes tupIn == attrs then
196 tupIn
197 else do
198 RelationTuple attrs (V.map mapper attrs)
199 where
200 mapper attr = case atomForAttributeName (attributeName attr) tupIn of
201 Left _ -> undefined
202 Right atom -> atom