@@ -0,0 +1,343 @@
1+-- this is an implementation of the Relation typeclass which creates a GADT DSL
2+{-# LANGUAGE GADTs,ExistentialQuantification #-}
3+module Relation where
4+import qualified Data.Map as M
5+import qualified Data.Serialize as SZ
6+import qualified Data.Set as S
7+import qualified Data.List as L
8+import qualified Data.HashSet as HS
9+import qualified Data.Hashable as Hash
10+import qualified Control.Monad.Error as Err
11+
12+import Debug.Trace
13+import RelationType
14+import RelationAtom
15+import RelationTuple
16+import RelationAttribute
17+import RelationTupleSet
18+
19+testTuple1 = mkRelationTuple (S.fromList ["hair"]) (M.fromList [("hair", StringAtom "brown")])
20+
21+attributes :: Relation -> Attributes
22+attributes (Relation attrs _ ) = attrs
23+
24+attributeNames :: Relation -> S.Set AttributeName
25+attributeNames (Relation attrs _) = M.keysSet attrs
26+
27+attributeForName :: AttributeName -> Relation -> Maybe Attribute
28+attributeForName attrName (Relation attrs _) = M.lookup attrName attrs
29+
30+attributesForNames :: S.Set AttributeName -> Relation -> Attributes
31+attributesForNames attrNameSet (Relation attrs _) = M.intersection attrs hollowMap
32+ where
33+ hollowMap = M.fromList $ zip (S.toList attrNameSet) (repeat (Attribute "" StringAtomType))
34+
35+attributeTypeForName :: AttributeName -> Relation -> Maybe AtomType
36+attributeTypeForName attrName rel = case attr of
37+ (Just (Attribute _ atomType)) -> Just atomType
38+ _ -> Nothing
39+ where
40+ attr = attributeForName attrName rel
41+
42+atomValueType :: Atom -> AtomType
43+atomValueType (StringAtom _) = StringAtomType
44+atomValueType (IntAtom _) = IntAtomType
45+atomValueType (RelationAtom rel) = RelationAtomType (attributes rel)
46+
47+
48+instance Err.Error RelationalError where
49+
50+mkRelation :: Attributes -> RelationTupleSet -> Either RelationalError Relation
51+mkRelation attrs tupleSet =
52+ --check that all tuples have the same keys
53+ --check that all tuples have keys (1-N) where N is the attribute count
54+ if differentTupleCounts
55+ then Left $ RelationalError 1 "Tuple attribute count mismatch"
56+ else if attrCountMismatch
57+ then Left $ RelationalError 1 "Attribute count mismatch"
58+ else
59+ Right $ Relation attrs tupleSet
60+ where
61+ attrCount = M.size attrs
62+ tupleCounts = HS.map tupleSize tupleSet
63+ attrCountMismatch = if HS.size tupleSet > 0
64+ then not $ HS.member attrCount tupleCounts
65+ else False --empty tuple set is always OK
66+ differentTupleCounts = HS.size tupleCounts > 1
67+
68+r1 = case mkRelation attributes tupleSet1 of
69+ Right x -> x
70+ Left x -> relationFalse
71+ where
72+ tupleSet1 = HS.fromList [tuple1,tuple2]
73+ tuple1 = mkRelationTuple (S.fromList ["hair"]) $ M.fromList [("hair", StringAtom "brown")]
74+ tuple2 = mkRelationTuple (S.fromList ["hair"]) $ M.fromList [("hair", StringAtom "blonde")]
75+ attributes = M.singleton "hair" (Attribute "hair" StringAtomType)
76+
77+testr1 = Relation attributes tupleSet
78+ where
79+ attributes = M.fromList [("hair", Attribute "hair" StringAtomType), ("name", Attribute "name" StringAtomType)]
80+ tupleSet = HS.fromList $ mkRelationTuples attributes [M.fromList [("name", StringAtom "spammo"),("hair", StringAtom "brown")]]
81+
82+testr2 = Relation attributes tupleSet
83+ where
84+ attributes = M.singleton "hair" (Attribute "hair" StringAtomType)
85+ tupleSet = HS.fromList $ mkRelationTuples attributes [M.fromList [("name", StringAtom "spammo")],M.fromList [("name", StringAtom "gonk")]]
86+
87+testcitiesr = Relation attributes tupleSet
88+ where
89+ attributes = M.singleton "name" (Attribute "name" StringAtomType)
90+ tupleSet = HS.fromList $ mkRelationTuples attributes [M.fromList [("name", StringAtom "Boston"), ("name", StringAtom "Cambridge")]]
91+
92+testrinr = Relation attributes tupleSet
93+ where
94+ attributes = M.fromList [("state", Attribute "state" StringAtomType), ("cities", Attribute "cities" StringAtomType)]
95+ tupleSet = HS.fromList $ mkRelationTuples attributes [M.fromList [("state", StringAtom "MA"), ("cities", RelationAtom testcitiesr)]]
96+
97+relationTrue = Relation M.empty $ HS.singleton (RelationTuple M.empty)
98+relationFalse = Relation M.empty emptyTupleSet
99+
100+madeTrue = mkRelation M.empty (HS.fromList [])
101+madeFalse = mkRelation M.empty emptyTupleSet
102+
103+union :: Relation -> Relation -> Either RelationalError Relation
104+union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =
105+ if not (attrs1 == attrs2)
106+ then Left $ RelationalError 1 ("Attribute mismatch " ++ show attrs1 ++ show attrs2)
107+ else
108+ Right $ Relation attrs1 newtuples
109+ where
110+ newtuples = HS.union tupSet1 tupSet2
111+
112+project :: S.Set AttributeName -> Relation -> Either RelationalError Relation
113+project projectionAttrNames rel@(Relation oldattrs rtuples) =
114+ if not $ attributeNamesContained projectionAttrNames (attributeNames rel)
115+ then Left $ RelationalError 1 "Attributes mismatch"
116+ else
117+ relFold folder (Right $ Relation newAttrs HS.empty) rel
118+ where
119+ newAttrs = attributesForNames projectionAttrNames rel
120+ folder :: RelationTuple -> Either RelationalError Relation -> Either RelationalError Relation
121+ folder tupleToProject acc = case acc of
122+ Left err -> Left err
123+ Right acc -> union acc (Relation newAttrs (HS.singleton (tupleProject projectionAttrNames tupleToProject)))
124+
125+tupleProject :: S.Set AttributeName -> RelationTuple -> RelationTuple
126+tupleProject projectAttrs tupleIn@(RelationTuple tupleInMap) = RelationTuple $ M.filterWithKey attrFilter tupleInMap
127+ where
128+ attrFilter key _ = S.member key projectAttrs
129+
130+--the expensive rename is why I wanted to use IntMap instead of attribute names in the tupleset
131+rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
132+rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet) =
133+ if not attributeValid
134+ then Left $ RelationalError 1 "No such attribute"
135+ else
136+ mkRelation newAttrs newTupSet
137+ where
138+ attributeValid = attributeNamesContained (S.singleton oldAttrName) (attributeNames rel)
139+ newAttrs = M.insert newAttrName (renameAttribute newAttrName (oldAttrs M.! oldAttrName)) oldAttrs
140+ newTupSet = HS.map tupsetmapper oldTupSet
141+ tupsetmapper tuple = tupleRenameAttribute oldAttrName newAttrName tuple
142+
143+--the algebra should return a relation of one attribute and one row with the arity
144+arity :: Relation -> Int
145+arity (Relation attrs _) = M.size attrs
146+
147+cardinality :: Relation -> RelationCardinality
148+cardinality (Relation _ tupSet) = Countable (HS.size tupSet)
149+
150+--find tuples where the atoms in the relation which are NOT in the AttributeNameSet are equal
151+-- create a relation for each tuple where the attributes NOT in the AttributeNameSet are equal
152+--the attrname set attrs end up in the nested relation
153+
154+--algorithm:
155+-- map projection of non-grouped attributes to restriction of matching grouped attribute tuples and then project on grouped attributes to construct the sub-relation
156+{-
157+group :: S.Set AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
158+group groupAttrNames newAttrName rel@(Relation oldAttrs tupleSet) = do
159+ nonGroupProjection <- project nonGroupAttrNames rel
160+ relFold folder (Right (Relation newAttrs emptyTupleSet)) nonGroupProjection
161+ where
162+ newAttrs = M.union (attributesForNames nonGroupAttrNames rel) groupAttr
163+ groupAttr = Attribute newAttrName RelationAtomType (attributesForNames nonGroupAttrNames rel)
164+ newAttrNameSet = S.insert newAttrName nonGroupAttrNames
165+ nonGroupAttrNames = S.difference groupAttrNames (attributeNames rel)
166+ --map the projection to add the additional new attribute
167+ --create the new attribute (a new relation) by filtering and projecting the tupleSet
168+ folder tupleFromProjection acc = case acc of
169+ Left err -> Left err
170+ Right acc -> union acc (Relation newAttrs (HS.singleton (tupleExtend tupleFromProjection (matchingRelTuple tupleFromProjection))))
171+-}
172+
173+--algorithm: self-join with image relation
174+group2 :: S.Set AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
175+group2 groupAttrNames newAttrName rel@(Relation attrs tupleSet) = do
176+ nonGroupProjection <- project nonGroupAttrNames rel
177+ relFold folder (Right $ Relation newAttrs emptyTupleSet) nonGroupProjection
178+ where
179+ newAttrs = M.insert newAttrName groupAttr (attributesForNames nonGroupAttrNames rel)
180+ groupAttr = Attribute newAttrName (RelationAtomType (attributesForNames nonGroupAttrNames rel))
181+ nonGroupAttrNames = nonMatchingAttributeNameSet groupAttrNames (attributeNames rel)
182+ newAttrNames = S.insert newAttrName nonGroupAttrNames
183+ folder tupleIn acc = case acc of
184+ Left err -> Left err
185+ Right acc -> union acc (Relation newAttrs (HS.singleton (tupleExtend tupleIn (matchingRelTuple tupleIn))))
186+ matchingRelTuple groupTuple = case imageRelationFor groupTuple rel of
187+ Right rel -> RelationTuple $ M.singleton newAttrName (RelationAtom rel)
188+ Left _ -> undefined
189+
190+--help restriction function
191+--returns a subrelation of
192+restrictEq :: RelationTuple -> Relation -> Either RelationalError Relation
193+restrictEq (RelationTuple tupMap) rel = restrict filter rel
194+ where
195+ filter :: RelationTuple -> Bool
196+ filter (RelationTuple tupMap2) = M.isSubmapOf tupMap tupMap2
197+
198+-- unwrap relation-valued attribute
199+-- return error if relval attrs and nongroup attrs overlap
200+ungroup :: AttributeName -> Relation -> Either RelationalError Relation
201+ungroup relvalAttrName rel = relFold relFolder (Right $ Relation newAttrs emptyTupleSet) rel
202+ where
203+ newAttrNames = M.keysSet newAttrs
204+ newAttrs = M.union (attributesForRelval relvalAttrName rel) nonGroupAttrs
205+ nonGroupAttrs = M.delete relvalAttrName (attributes rel)
206+ relFolder :: RelationTuple -> Either RelationalError Relation -> Either RelationalError Relation
207+ relFolder tupleIn acc = case (tupleUngroup relvalAttrName newAttrs tupleIn) of
208+ Right ungroupRelation -> case acc of
209+ Left err -> Left err
210+ Right accRel -> do
211+ ungrouped <- tupleUngroup relvalAttrName newAttrs tupleIn
212+ union accRel ungrouped
213+ Left err -> Left err
214+
215+--take an relval attribute name and a tuple and ungroup the relval
216+tupleUngroup :: AttributeName -> Attributes -> RelationTuple -> Either RelationalError Relation
217+tupleUngroup relvalAttrName newAttrs tuple@(RelationTuple tupMap) = case (tupMap M.! relvalAttrName) of
218+ (RelationAtom relvalRelation) -> relFold folder (Right $ Relation newAttrs emptyTupleSet) relvalRelation
219+ where
220+ newAttrNameSet = M.keysSet newAttrs
221+ nonGroupTupleProjection = tupleProject nonGroupAttrNames tuple
222+ nonGroupAttrNames = M.keysSet newAttrs
223+ folder tupleIn acc = case acc of
224+ Left err -> Left err
225+ Right accRel -> union accRel $ Relation newAttrs (HS.singleton (tupleExtend nonGroupTupleProjection tupleIn))
226+ relvalRelation = unsafeRelValFromAtom $ tupleAtomForAttribute tuple relvalAttrName
227+ where
228+ unsafeRelValFromAtom :: Atom -> Relation
229+ unsafeRelValFromAtom (RelationAtom rel) = rel
230+ _ -> Left $ RelationalError 1 "Attribute is not relation-valued."
231+
232+--this is a hack needed because the relation attributes are untyped so we must dig into the relval to get the attribute names
233+attributesForRelval :: AttributeName -> Relation -> Attributes
234+attributesForRelval relvalAttrName relIn@(Relation attrs tupleSet) = attributes relvalRelation
235+ where
236+ relvalRelationAttrs = attributes relvalRelation
237+ --this is only temporarily needed until the Relation stores the types of the columns as data- hack alert
238+ --find a tuple with attributes to steal to ungroup
239+ oneTuple :: RelationTupleSet -> RelationTuple
240+ oneTuple tupleSet = head $ HS.toList $ HS.filter (\tup@(RelationTuple tupMap) -> M.size tupMap > 0) tupleSet
241+ relvalRelation = unsafeRelValFromAtom $ tupleAtomForAttribute (oneTuple tupleSet) relvalAttrName
242+ where
243+ unsafeRelValFromAtom :: Atom -> Relation
244+ unsafeRelValFromAtom (RelationAtom rel) = rel
245+
246+restrict :: (RelationTuple -> Bool) -> Relation -> Either RelationalError Relation
247+restrict filter (Relation attrs tupset) = Right $ Relation attrs $ HS.filter filter tupset
248+
249+--joins on columns with the same name- use rename to avoid this- base case: cartesian product
250+--after changing from string atoms, there needs to be a type-checking step!
251+--this is a "nested loop" scan as described by the postgresql documentation
252+join :: Relation -> Relation -> Either RelationalError Relation
253+join (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) = Right $ Relation newAttrs newTupSet
254+ where
255+ newAttrs = M.union attrs1 attrs2
256+ newTupSet = HS.foldr tupleSetJoiner emptyTupleSet tupSet1
257+ tupleSetJoiner tuple1 accumulator = HS.union (singleTupleSetJoin tuple1 tupSet2) accumulator
258+
259+
260+--a map should NOT change the structure of a relation, so attributes should be constant relMap :: (RelationTuple -> RelationTuple) -> Attributes -> Relation -> Either RelationalError Relation
261+relMap mapper newAttributes (Relation attrs tupleSet) = Right $ Relation newAttributes (HS.map mapper tupleSet)
262+
263+relFold :: (RelationTuple -> a -> a) -> a -> Relation -> a
264+relFold folder acc (Relation attrs tupleSet) = HS.foldr folder acc tupleSet
265+
266+{- a specialized form of fold which always returns a Relation
267+relTuplesFold :: (RelationTuple -> RelationTupleSet -> RelationTupleSet) -> RelationTupleSet -> AttributeNameSet -> Relation -> Either RelationalError Relation
268+-}
269+
270+--image relation as defined by CJ Date
271+--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+
273+--check that matching attribute names have the same types
274+imageRelationFor :: RelationTuple -> Relation -> Either RelationalError Relation
275+imageRelationFor matchTuple rel@(Relation attrs _) = do
276+ restricted <- restrictEq matchTuple rel --restrict across matching tuples
277+ project (nonMatchingAttributeNameSet (attributeNames rel) (tupleAttributeNameSet matchTuple)) restricted --project across attributes not in rel
278+
279+imageRelationTest = imageRelationFor tup s
280+ where
281+ tup = mkRelationTuple (S.fromList ["SNAME", "CITY", "S#"]) (M.fromList [("SNAME", StringAtom "Smith"), ("S#", StringAtom "S1"), ("CITY", StringAtom "London")])
282+
283+--returns a relation-valued attribute image relation for each tuple in rel1
284+--algorithm:
285+ {-
286+imageRelationJoin :: Relation -> Relation -> Either RelationalError Relation
287+imageRelationJoin rel1@(Relation attrNameSet1 tupSet1) rel2@(Relation attrNameSet2 tupSet2) = do
288+ Right $ Relation undefined
289+ where
290+ matchingAttrs = matchingAttributeNameSet attrNameSet1 attrNameSet2
291+ newAttrs = nonMatchingAttributeNameSet matchingAttrs $ S.union attrNameSet1 attrNameSet2
292+
293+ tupleSetJoiner tup1 acc = undefined
294+-}
295+
296+{- C.J. Date's canonical example relvars -}
297+
298+relvarS = mkRelation attributes tupleSet
299+ where
300+ attributes = M.fromList [("S#", Attribute "S#" StringAtomType),
301+ ("SNAME", Attribute "SNAME" StringAtomType),
302+ ("STATUS", Attribute "STATUS" StringAtomType),
303+ ("CITY", Attribute "CITY" StringAtomType)]
304+ tupleSet = HS.fromList $ mkRelationTuples attributes [
305+ M.fromList [("S#", StringAtom "S1") , ("SNAME", StringAtom "Smith"), ("STATUS", IntAtom 20) , ("CITY", StringAtom "London")],
306+ M.fromList [("S#", StringAtom "S2"), ("SNAME", StringAtom "Jones"), ("STATUS", IntAtom 10), ("CITY", StringAtom "Paris")],
307+ M.fromList [("S#", StringAtom "S3"), ("SNAME", StringAtom "Blake"), ("STATUS", IntAtom 30), ("CITY", StringAtom "Paris")],
308+ M.fromList [("S#", StringAtom "S4"), ("SNAME", StringAtom "Clark"), ("STATUS", IntAtom 20), ("CITY", StringAtom "London")],
309+ M.fromList [("S#", StringAtom "S5"), ("SNAME", StringAtom "Adams"), ("STATUS", IntAtom 30), ("CITY", StringAtom "Athens")]]
310+
311+s = case relvarS of { Right r -> r }
312+
313+relvarP = mkRelation attributes tupleSet
314+ where
315+ attributes = M.fromList [("P#", Attribute "P#" StringAtomType),
316+ ("PNAME", Attribute "PNAME" StringAtomType),
317+ ("COLOR", Attribute "COLOR" StringAtomType),
318+ ("WEIGHT", Attribute "WEIGHT" StringAtomType),
319+ ("CITY", Attribute "CITY" StringAtomType)]
320+ tupleSet = HS.fromList $ mkRelationTuples attributes [
321+ M.fromList [("P#", StringAtom "P1"), ("PNAME", StringAtom "Nut"), ("COLOR", StringAtom "Red"), ("WEIGHT", IntAtom 12), ("CITY", StringAtom "London")]
322+ ]
323+p = case relvarP of { Right r -> r }
324+
325+relvarSP = mkRelation attributes tupleSet
326+ where
327+ attributes = M.fromList [("S#", Attribute "S#" StringAtomType),
328+ ("P#", Attribute "P#" StringAtomType),
329+ ("QTY", Attribute "QTY" StringAtomType)]
330+ tupleSet = HS.fromList $ mkRelationTuples attributes [
331+ M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P1"), ("QTY", IntAtom 300)]
332+ ]
333+
334+sp = case relvarSP of { Right r -> r }
335+
336+grouptest = case x of
337+ Right x -> x
338+ where
339+ x = group2 (S.fromList ["CITY", "SNAME", "S#"]) "X" s
340+
341+ungrouptest = case x of
342+ Right x -> x
343+ where x = ungroup "X" grouptest