git.iko.soy/project-m36
on bda2cfc help sign in
project-m36/ProjectM36/RelationalExpression.hs
533 lines 25 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module ProjectM36.RelationalExpression where
3import ProjectM36.Relation
4import ProjectM36.Tuple
5import ProjectM36.TupleSet
6import ProjectM36.Base
7import ProjectM36.Error
8import ProjectM36.Atom
9import ProjectM36.Key
10import ProjectM36.AtomFunction
11import ProjectM36.DataTypes.Interval
12import qualified ProjectM36.Attribute as A
13import qualified Data.Map as M
14import qualified Data.HashSet as HS
15import qualified Data.Set as S
16import Control.Monad.State hiding (join)
17import Data.Maybe
18import Data.Either
20--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
21evalRelationalExpr :: RelationalExpr -> DatabaseState (Either RelationalError Relation)
22evalRelationalExpr (RelationVariable name) = do
23 relvarTable <- liftM relationVariables get
24 return $ case M.lookup name relvarTable of
25 Just res -> Right res
26 Nothing -> Left $ RelVarNotDefinedError name
28evalRelationalExpr (Project attrNames expr) = do
29 rel <- evalRelationalExpr expr
30 case rel of
31 Right rel2 -> return $ project attrNames rel2
32 Left err -> return $ Left err
34evalRelationalExpr (Union exprA exprB) = do
35 relA <- evalRelationalExpr exprA
36 relB <- evalRelationalExpr exprB
37 case relA of
38 Left err -> return $ Left err
39 Right relA2 -> case relB of
40 Left err -> return $ Left err
41 Right relB2 -> return $ union relA2 relB2
43evalRelationalExpr (Join exprA exprB) = do
44 relA <- evalRelationalExpr exprA
45 relB <- evalRelationalExpr exprB
46 case relA of
47 Left err -> return $ Left err
48 Right relA2 -> case relB of
49 Left err -> return $ Left err
50 Right relB2 -> return $ join relA2 relB2
52evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) = do
53 case mkRelation attributeSet tupleSet of
54 Right rel -> return $ Right rel
55 Left err -> return $ Left err
57evalRelationalExpr (ExistingRelation rel) = return (Right rel)
59evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do
60 evald <- evalRelationalExpr relExpr
61 case evald of
62 Right rel -> return $ rename oldAttrName newAttrName rel
63 Left err -> return $ Left err
65evalRelationalExpr (Group oldAttrNameSet newAttrName relExpr) = do
66 evald <- evalRelationalExpr relExpr
67 case evald of
68 Right rel -> return $ group oldAttrNameSet newAttrName rel
69 Left err -> return $ Left err
71evalRelationalExpr (Ungroup attrName relExpr) = do
72 evald <- evalRelationalExpr relExpr
73 case evald of
74 Right rel -> return $ ungroup attrName rel
75 Left err -> return $ Left err
77evalRelationalExpr (Restrict predicateExpr relExpr) = do
78 evald <- evalRelationalExpr relExpr
79 context <- get
80 case evald of
81 Left err -> return $ Left err
82 Right rel -> case predicateRestrictionFilter context (attributes rel) predicateExpr of
83 Left err -> return $ Left err
84 Right filterfunc -> return $ restrict filterfunc rel
86evalRelationalExpr (Equals relExprA relExprB) = do
87 evaldA <- evalRelationalExpr relExprA
88 evaldB <- evalRelationalExpr relExprB
89 case evaldA of
90 Left err -> return $ Left err
91 Right relA -> case evaldB of
92 Left err -> return $ Left err
93 Right relB -> return $ Right $ if relA == relB then relationTrue else relationFalse
95--warning: copy-pasta from above- refactor
96evalRelationalExpr (NotEquals relExprA relExprB) = do
97 evaldA <- evalRelationalExpr relExprA
98 evaldB <- evalRelationalExpr relExprB
99 case evaldA of
100 Left err -> return $ Left err
101 Right relA -> case evaldB of
102 Left err -> return $ Left err
103 Right relB -> return $ Right $ if relA /= relB then relationTrue else relationFalse
105-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated
106evalRelationalExpr (Extend tupleExpression relExpr) = do
107 evald <- evalRelationalExpr relExpr
108 context <- get
109 case evald of
110 Left err -> return $ Left err
111 Right rel -> do
112 case tupleExpressionProcessor rel tupleExpression context of
113 Left err -> return $ Left err
114 Right (newAttrs, tupProc) -> return $ relMogrify tupProc newAttrs rel
116emptyDatabaseContext :: DatabaseContext
117emptyDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,
118 relationVariables = M.empty,
119 atomFunctions = HS.empty
120 }
122basicDatabaseContext :: DatabaseContext
123basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,
124 relationVariables = M.fromList [("true", relationTrue),
125 ("false", relationFalse)],
126 atomFunctions = basicAtomFunctions
127 }
129dateExamples :: DatabaseContext
130dateExamples = DatabaseContext { inclusionDependencies = dateIncDeps,
131 relationVariables = M.union (relationVariables basicDatabaseContext) dateRelVars,
132 atomFunctions = basicAtomFunctions}
133 where
134 dateRelVars = M.fromList [("S", suppliers),
135 ("P", products),
136 ("SP", supplierProducts)]
137 suppliers = suppliersRel
138 products = productsRel
139 supplierProducts = supplierProductsRel
140 dateIncDeps = M.fromList [("S_pkey", simplePKey ["S#"] "S"),
141 ("P_pkey", simplePKey ["P#"] "P"),
142 ("SP_pkey", simplePKey ["S#", "P#"] "SP")
143 ]
144 simplePKey attrNames relvarName = inclusionDependencyForKey (AttributeNames $ S.fromList attrNames) (RelationVariable relvarName)
146suppliersRel :: Relation
147suppliersRel = case mkRelationFromList attrs atomMatrix of
148 Left _ -> undefined
149 Right rel -> rel
150 where
151 attrs = A.attributesFromList [Attribute "S#" stringAtomType,
152 Attribute "SNAME" stringAtomType,
153 Attribute "STATUS" intAtomType,
154 Attribute "CITY" stringAtomType]
155 atomMatrix = [
156 [stringAtom "S1", stringAtom "Smith", intAtom 20, stringAtom "London"],
157 [stringAtom "S2", stringAtom "Jones", intAtom 10, stringAtom "Paris"],
158 [stringAtom "S3", stringAtom "Blake", intAtom 30, stringAtom "Paris"],
159 [stringAtom "S4", stringAtom "Clark", intAtom 20, stringAtom "London"],
160 [stringAtom "S5", stringAtom "Adams", intAtom 30, stringAtom "Athens"]]
162supplierProductsRel :: Relation
163supplierProductsRel = case mkRelationFromList attrs matrix of
164 Left _ -> undefined
165 Right rel -> rel
166 where
167 attrs = A.attributesFromList [Attribute "S#" stringAtomType,
168 Attribute "P#" stringAtomType,
169 Attribute "QTY" intAtomType]
170 matrix = [
171 [stringAtom "S1", stringAtom "P1", intAtom 300],
172 [stringAtom "S1", stringAtom "P2", intAtom 200],
173 [stringAtom "S1", stringAtom "P3", intAtom 400],
174 [stringAtom "S1", stringAtom "P4", intAtom 200],
175 [stringAtom "S1", stringAtom "P5", intAtom 100],
176 [stringAtom "S1", stringAtom "P6", intAtom 100],
177 [stringAtom "S2", stringAtom "P1", intAtom 300],
178 [stringAtom "S2", stringAtom "P2", intAtom 400],
179 [stringAtom "S3", stringAtom "P2", intAtom 200],
180 [stringAtom "S4", stringAtom "P2", intAtom 200],
181 [stringAtom "S4", stringAtom "P4", intAtom 300],
182 [stringAtom "S4", stringAtom "P5", intAtom 400]
183 ]
185productsRel :: Relation
186productsRel = case mkRelationFromList attrs matrix of
187 Left _ -> undefined
188 Right rel -> rel
189 where
190 attrs = A.attributesFromList [Attribute "P#" stringAtomType,
191 Attribute "PNAME" stringAtomType,
192 Attribute "COLOR" stringAtomType,
193 Attribute "WEIGHT" intAtomType,
194 Attribute "CITY" stringAtomType]
195 matrix = [
196 [stringAtom "P1", stringAtom "Nut", stringAtom "Red", intAtom 12, stringAtom "London"],
197 [stringAtom "P2", stringAtom "Bolt", stringAtom "Green", intAtom 17, stringAtom "Paris"],
198 [stringAtom "P3", stringAtom "Screw", stringAtom "Blue", intAtom 17, stringAtom "Oslo"],
199 [stringAtom "P4", stringAtom "Screw", stringAtom "Red", intAtom 14, stringAtom "London"],
200 [stringAtom "P5", stringAtom "Cam", stringAtom "Blue", intAtom 12, stringAtom "Paris"],
201 [stringAtom "P6", stringAtom "Cog", stringAtom "Red", intAtom 19, stringAtom "London"]
202 ]
204--helper function to process relation variable creation/assignment
205setRelVar :: RelVarName -> Relation -> DatabaseState (Maybe RelationalError)
206setRelVar relVarName rel = do
207 currentContext <- get
208 let newRelVars = M.insert relVarName rel $ relationVariables currentContext
209 let potentialContext = DatabaseContext (inclusionDependencies currentContext) newRelVars (atomFunctions currentContext)
210 case checkConstraints potentialContext of
211 Just err -> return $ Just err
212 Nothing -> do
213 put potentialContext
214 return Nothing
216-- it is not an error to delete a relvar which does not exist, just like it is not an error to insert a pre-existing tuple into a relation
217deleteRelVar :: RelVarName -> DatabaseState (Maybe RelationalError)
218deleteRelVar relVarName = do
219 currstate <- get
220 let newRelVars = M.delete relVarName (relationVariables currstate)
221 put $ DatabaseContext (inclusionDependencies currstate) newRelVars (atomFunctions currstate)
222 return Nothing
224evalContextExpr :: DatabaseExpr -> DatabaseState (Maybe RelationalError)
225evalContextExpr (Define relVarName attrs) = do
226 relvars <- liftM relationVariables get
227 case M.member relVarName relvars of
228 True -> return (Just (RelVarAlreadyDefinedError relVarName))
229 False -> setRelVar relVarName emptyRelation
230 where
231 emptyRelation = Relation attrs emptyTupleSet
233evalContextExpr (Undefine relVarName) = do
234 deleteRelVar relVarName
236evalContextExpr (Assign relVarName expr) = do
237 -- in the future, it would be nice to get types from the RelationalExpr instead of needing to evaluate it
238 relVarTable <- liftM relationVariables get
239 let existingRelVar = M.lookup relVarName relVarTable
240 value <- evalRelationalExpr expr
241 case value of
242 Left err -> return $ Just err
243 Right rel -> case existingRelVar of
244 Nothing -> setRelVar relVarName rel
245 Just existingRel -> let expectedAttributes = attributes existingRel
246 foundAttributes = attributes rel in
247 if A.attributesEqual expectedAttributes foundAttributes then
248 setRelVar relVarName rel
249 else
250 return $ Just (RelVarAssignmentTypeMismatchError expectedAttributes foundAttributes)
252evalContextExpr (Insert relVarName relExpr) = evalContextExpr $ Assign relVarName (Union relExpr (RelationVariable relVarName))
254--assign empty rel until restriction is implemented
255evalContextExpr (Delete relVarName predicate) = do
256 updatedRel <- evalRelationalExpr (Restrict (NotPredicate predicate) (RelationVariable relVarName))
257 case updatedRel of
258 Left err -> return $ Just err
259 Right rel -> setRelVar relVarName rel
261--union of restricted+updated portion and the unrestricted+unupdated portion
262evalContextExpr (Update relVarName attrAssignments restrictionPredicateExpr) = do
263 currstate <- get
264 let relVarTable = relationVariables currstate
265 case M.lookup relVarName relVarTable of
266 Nothing -> return $ Just (RelVarNotDefinedError relVarName)
267 Just rel -> case predicateRestrictionFilter currstate (attributes rel) restrictionPredicateExpr of
268 Left err -> return $ Just err
269 Right predicateFunc -> do
270 case makeUpdatedRel rel of
271 Left err -> return $ Just err
272 Right updatedRel -> setRelVar relVarName updatedRel
273 where
274 makeUpdatedRel relin = do
275 restrictedPortion <- restrict predicateFunc relin
276 unrestrictedPortion <- restrict (not . predicateFunc) relin
277 updatedPortion <- relMap (updateTuple attrAssignments) restrictedPortion
278 union updatedPortion unrestrictedPortion
280evalContextExpr (AddInclusionDependency newDepName newDep) = do
281 currContext <- get
282 let currDeps = inclusionDependencies currContext
283 newDeps = M.insert newDepName newDep currDeps
284 if M.member newDepName currDeps then
285 return $ Just (InclusionDependencyNameInUseError newDepName)
286 else do
287 let potentialContext = DatabaseContext newDeps (relationVariables currContext) (atomFunctions currContext)
288 case checkConstraints potentialContext of
289 Just err -> return $ Just err
290 Nothing -> do
291 put potentialContext
292 return Nothing
294evalContextExpr (RemoveInclusionDependency depName) = do
295 currContext <- get
296 let currDeps = inclusionDependencies currContext
297 newDeps = M.delete depName currDeps
298 if M.notMember depName currDeps then
299 return $ Just (InclusionDependencyNameNotInUseError depName)
300 else do
301 put $ DatabaseContext newDeps (relationVariables currContext) (atomFunctions currContext)
302 return Nothing
304evalContextExpr (MultipleExpr exprs) = do
305 --the multiple expressions must pass the same context around- not the old unmodified context
306 evald <- forM exprs evalContextExpr
307 --some lifting magic needed here
308 case catMaybes evald of
309 [] -> return $ Nothing
310 err:_ -> return $ Just err
312-- restrict relvar to get affected tuples, update tuples, delete restriction from relvar, relvar = relvar union updated tuples
313--evalRelVarExpr (Update relVarName updateMap) = do
315--run verification on all constraints
316checkConstraints :: DatabaseContext -> Maybe RelationalError
317checkConstraints context = case failures of
318 [] -> Nothing
319 l:_ -> Just l
320 where
321 failures = M.elems $ M.mapMaybeWithKey checkIncDep deps
322 deps = inclusionDependencies context
323 eval expr = runState (evalRelationalExpr expr) context
324 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = case evaldSub of
325 (Left err, _) -> Just err
326 (Right relSub, _) -> case evaldSuper of
327 (Left err, _) -> Just err
328 (Right relSuper, _) -> case union relSub relSuper of
329 Left err -> Just err
330 Right resultRel -> if resultRel == relSuper then
331 Nothing
332 else
333 Just $ InclusionDependencyCheckError depName
334 where
335 evaldSub = eval subsetExpr
336 evaldSuper = eval supersetExpr
338{-
339checkConstraint :: InclusionDependency -> DatabaseState (Maybe RelationalError)
340checkConstraint (InclusionDependency name subDep superDep) = do
341 evalSub <- evalRelationalExpr subDep
342 evalSuper <- evalRelationalExpr superDep
343 case evalSub of
344 Left err -> Just err
345 Right relSub
346 result <- liftM2 union evalSub evalSuper
347 return $ Nothing
348-}
350-- the type of a relational expression is equal to the relation attribute set returned from executing the relational expression; therefore, the type can be cheaply derived by evaluating a relational expression and ignoring and tuple processing
351-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation
353typeForRelationalExpr :: RelationalExpr -> DatabaseState (Either RelationalError Relation)
354typeForRelationalExpr expr = do
355 currstate <- get
356 --replace the relationVariables context element with a cloned set of relation devoid of tuples
357 put $ contextWithEmptyTupleSets currstate
358 evalRelationalExpr expr
360--returns a database context with all tuples removed
361--this is useful for type checking and optimization
362contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext
363contextWithEmptyTupleSets contextIn = DatabaseContext incDeps relVars funcs
364 where
365 incDeps = inclusionDependencies contextIn
366 relVars = M.map (\rel -> Relation (attributes rel) emptyTupleSet) (relationVariables contextIn)
367 funcs = atomFunctions contextIn
369{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}
370predicateRestrictionFilter :: DatabaseContext -> Attributes -> RestrictionPredicateExpr -> Either RelationalError (RelationTuple -> Bool)
371predicateRestrictionFilter context attrs (AndPredicate expr1 expr2) = do
372 expr1v <- predicateRestrictionFilter context attrs expr1
373 expr2v <- predicateRestrictionFilter context attrs expr2
374 return $ \x -> expr1v x && expr2v x
376predicateRestrictionFilter context attrs (OrPredicate expr1 expr2) = do
377 expr1v <- predicateRestrictionFilter context attrs expr1
378 expr2v <- predicateRestrictionFilter context attrs expr2
379 return $ \x -> expr1v x || expr2v x
381predicateRestrictionFilter _ _ TruePredicate = Right $ \_ -> True
383predicateRestrictionFilter context attrs (NotPredicate expr) = do
384 exprv <- predicateRestrictionFilter context attrs expr
385 return $ \x -> not (exprv x)
387predicateRestrictionFilter context _ (RelationalExprPredicate relExpr) = case runState (evalRelationalExpr relExpr) context of
388 (Left err, _) -> Left err
389 (Right rel, _) -> if rel == relationTrue then
390 Right $ \_ -> True
391 else if rel == relationFalse then
392 Right $ \_ -> False
393 else
394 Left $ PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'"
396predicateRestrictionFilter context attrs (AttributeEqualityPredicate attrName atomExpr) = do
397 attr <- A.attributeForName attrName attrs
398 atomExprType <- typeFromAtomExpr attrs context atomExpr
399 if atomExprType /= A.atomType attr then
400 Left $ TupleAttributeTypeMismatchError (A.attributesFromList [attr])
401 else
402 Right $ \tupleIn -> case atomForAttributeName attrName tupleIn of
403 Left _ -> False
404 Right atomIn ->
405 case evalAtomExpr tupleIn context atomExpr of
406 Left _ -> False
407 Right atomCmp -> atomCmp == atomIn
409-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance
410predicateRestrictionFilter context attrs (AtomExprPredicate atomExpr) = do
411 aType <- typeFromAtomExpr attrs context atomExpr
412 if aType /= boolAtomType then
413 Left $ AtomTypeMismatchError aType boolAtomType
414 else
415 Right (\tupleIn -> case evalAtomExpr tupleIn context atomExpr of
416 Left _ -> False
417 Right boolAtomValue -> boolAtomValue == Atom True)
419tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation
420tupleExprCheckNewAttrName attrName rel = if isRight $ attributeForName attrName rel then
421 Left $ AttributeNameInUseError attrName
422 else
423 Right rel
425tupleExpressionProcessor :: Relation -> TupleExpr -> DatabaseContext -> Either RelationalError (Attributes, RelationTuple -> RelationTuple)
426tupleExpressionProcessor relIn
427 (AttributeTupleExpr newAttrName atomExpr) context = do
428 _ <- tupleExprCheckNewAttrName newAttrName relIn
429 atomExprType <- typeFromAtomExpr (attributes relIn) context atomExpr
430 _ <- verifyAtomExprTypes relIn context atomExpr atomExprType
431 let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType]
432 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs
433 return $ (newAndOldAttrs, \tup -> case evalAtomExpr tup context atomExpr of
434 Left _ -> undefined -- ?!
435 Right atom -> tupleAtomExtend newAttrName atom tup)
437evalAtomExpr :: RelationTuple -> DatabaseContext -> AtomExpr -> Either RelationalError Atom
438evalAtomExpr tupIn _ (AttributeAtomExpr attrName) = atomForAttributeName attrName tupIn
439evalAtomExpr _ _ (NakedAtomExpr atom) = Right atom
440evalAtomExpr tupIn context (FunctionAtomExpr funcName arguments) = do
441 let functions = atomFunctions context
442 func <- atomFunctionForName funcName functions
443 argTypes <- mapM (typeFromAtomExpr (tupleAttributes tupIn) context) arguments
444 _ <- mapM (uncurry atomTypeVerify) $ init (zip (atomFuncType func) argTypes)
445 evaldArgs <- mapM (evalAtomExpr tupIn context) arguments
446 return $ (atomFunc func) evaldArgs
447evalAtomExpr _ context (RelationAtomExpr relExpr) = do
448 relAtom <- evalState (evalRelationalExpr relExpr) context
449 return $ Atom relAtom
451typeFromAtomExpr :: Attributes -> DatabaseContext -> AtomExpr -> Either RelationalError AtomType
452typeFromAtomExpr attrs _ (AttributeAtomExpr attrName) = A.atomTypeForAttributeName attrName attrs
453typeFromAtomExpr _ _ (NakedAtomExpr atom) = Right (atomTypeForAtom atom)
454typeFromAtomExpr _ context (FunctionAtomExpr funcName _) = do
455 let funcs = atomFunctions context
456 func <- atomFunctionForName funcName funcs
457 return $ last (atomFuncType func)
458typeFromAtomExpr _ context (RelationAtomExpr relExpr) = do
459 relType <- evalState (typeForRelationalExpr relExpr) context
460 return $ RelationAtomType (attributes relType)
462verifyAtomExprTypes :: Relation -> DatabaseContext -> AtomExpr -> AtomType -> Either RelationalError AtomType
463verifyAtomExprTypes relIn _ (AttributeAtomExpr attrName) expectedType = do
464 attrType <- A.atomTypeForAttributeName attrName (attributes relIn)
465 atomTypeVerify expectedType attrType
466verifyAtomExprTypes _ _ (NakedAtomExpr atom) expectedType = atomTypeVerify expectedType (atomTypeForAtom atom)
467verifyAtomExprTypes relIn context (FunctionAtomExpr funcName funcArgExprs) expectedType = do
468 let functions = atomFunctions context
469 func <- atomFunctionForName funcName functions
470 let expectedArgTypes = atomFuncType func
471 funcArgTypes <- mapM (\(atomExpr,expectedType2,argCount) -> case verifyAtomExprTypes relIn context atomExpr expectedType2 of
472 Left (AtomTypeMismatchError expSubType actSubType) -> Left $ AtomFunctionTypeError funcName argCount expSubType actSubType
473 Left err -> Left err
474 Right x -> Right x
475 ) $ zip3 funcArgExprs expectedArgTypes [1..]
476 if length funcArgTypes /= length expectedArgTypes - 1 then
477 Left $ AtomTypeCountError funcArgTypes expectedArgTypes
478 else do
479 atomTypeVerify expectedType (last expectedArgTypes)
480verifyAtomExprTypes _ context (RelationAtomExpr relationExpr) expectedType = do
481 case runState (typeForRelationalExpr relationExpr) context of
482 (Left err, _) -> Left err
483 (Right relType, _) -> atomTypeVerify expectedType (RelationAtomType (attributes relType))
486basicAtomFunctions :: AtomFunctions
487basicAtomFunctions = HS.fromList $ [
488 --match on any relation type
489 AtomFunction { atomFuncName = "add",
490 atomFuncType = [intAtomType, intAtomType, intAtomType],
491 atomFunc = (\(i1:i2:_) -> Atom $ ((unsafeCast i1)::Int) + unsafeCast i2)},
492 AtomFunction { atomFuncName = "id",
493 atomFuncType = [AnyAtomType, AnyAtomType],
494 atomFunc = (\(x:_) -> x)},
495 AtomFunction { atomFuncName = "sum",
496 atomFuncType = foldAtomFuncType intAtomType intAtomType,
497 atomFunc = (\(relAtom:_) -> relationSum $ unsafeCast relAtom)},
498 AtomFunction { atomFuncName = "count",
499 atomFuncType = foldAtomFuncType AnyAtomType intAtomType,
500 atomFunc = (\((relIn):_) -> relationCount (castRelation relIn))},
501 AtomFunction { atomFuncName = "max",
502 atomFuncType = foldAtomFuncType intAtomType intAtomType,
503 atomFunc = (\((relIn):_) -> relationMax (castRelation relIn))},
504 AtomFunction { atomFuncName = "min",
505 atomFuncType = foldAtomFuncType intAtomType intAtomType,
506 atomFunc = (\((relIn):_) -> relationMin (castRelation relIn))},
507 AtomFunction { atomFuncName = "lt",
508 atomFuncType = [intAtomType, intAtomType, boolAtomType],
509 atomFunc = intAtomFuncLessThan False},
510 AtomFunction { atomFuncName = "lte",
511 atomFuncType = [intAtomType, intAtomType, boolAtomType],
512 atomFunc = intAtomFuncLessThan True},
513 AtomFunction { atomFuncName = "gte",
514 atomFuncType = [intAtomType, intAtomType, boolAtomType],
515 atomFunc = boolAtomNot . (:[]) . intAtomFuncLessThan False},
516 AtomFunction { atomFuncName = "gt",
517 atomFuncType = [intAtomType, intAtomType, boolAtomType],
518 atomFunc = boolAtomNot . (:[]) . intAtomFuncLessThan True},
519 AtomFunction { atomFuncName = "not",
520 atomFuncType = [boolAtomType, boolAtomType],
521 atomFunc = boolAtomNot}
522 ] ++ intervalFunctions
524intAtomFuncLessThan :: Bool -> [Atom] -> Atom
525intAtomFuncLessThan equality (iatom1:iatom2:_) = (\i1 i2 -> Atom $ ((unsafeCast i1)::Int) `op` unsafeCast i2) iatom1 iatom2
526 where
527 op = if equality then (<=) else (<)
528intAtomFuncLessThan _ _= Atom False
530boolAtomNot :: [Atom] -> Atom
531boolAtomNot (bool:_) = Atom $ not (unsafeCast bool)
532boolAtomNot _ = Atom False