git.iko.soy/project-m36
on c3a4e2d help sign in
project-m36/src/lib/ProjectM36/AtomFunctions/Primitive.hs
99 lines 4.9 kB history raw
1module ProjectM36.AtomFunctions.Primitive where
2import ProjectM36.Base
3import ProjectM36.Relation (relFold, oneTuple)
4import ProjectM36.Tuple
5import ProjectM36.AtomFunctionError
6import ProjectM36.AtomFunction
7import qualified Data.HashSet as HS
8import qualified Data.Vector as V
9import Control.Monad
11primitiveAtomFunctions :: AtomFunctions
12primitiveAtomFunctions = HS.fromList [
13 --match on any relation type
14 AtomFunction { atomFuncName = "add",
15 atomFuncType = [IntegerAtomType, IntegerAtomType, IntegerAtomType],
16 atomFuncBody = body (\(IntegerAtom i1:IntegerAtom i2:_) -> pure (IntegerAtom (i1 + i2)))},
17 AtomFunction { atomFuncName = "id",
18 atomFuncType = [TypeVariableType "a", TypeVariableType "a"],
19 atomFuncBody = body (\(x:_) -> pure x)},
20 AtomFunction { atomFuncName = "sum",
21 atomFuncType = foldAtomFuncType IntegerAtomType IntegerAtomType,
22 atomFuncBody = body (\(RelationAtom rel:_) -> relationSum rel)},
23 AtomFunction { atomFuncName = "count",
24 atomFuncType = foldAtomFuncType (TypeVariableType "a") IntegerAtomType,
25 atomFuncBody = body (\(RelationAtom relIn:_) -> relationCount relIn)},
26 AtomFunction { atomFuncName = "max",
27 atomFuncType = foldAtomFuncType IntegerAtomType IntegerAtomType,
28 atomFuncBody = body (\(RelationAtom relIn:_) -> relationMax relIn)},
29 AtomFunction { atomFuncName = "min",
30 atomFuncType = foldAtomFuncType IntegerAtomType IntegerAtomType,
31 atomFuncBody = body (\(RelationAtom relIn:_) -> relationMin relIn)},
32 AtomFunction { atomFuncName = "lt",
33 atomFuncType = [IntegerAtomType, IntegerAtomType, BoolAtomType],
34 atomFuncBody = body $ integerAtomFuncLessThan False},
35 AtomFunction { atomFuncName = "lte",
36 atomFuncType = [IntegerAtomType, IntegerAtomType, BoolAtomType],
37 atomFuncBody = body $ integerAtomFuncLessThan True},
38 AtomFunction { atomFuncName = "gte",
39 atomFuncType = [IntegerAtomType, IntegerAtomType, BoolAtomType],
40 atomFuncBody = body $ integerAtomFuncLessThan False >=> boolAtomNot},
41 AtomFunction { atomFuncName = "gt",
42 atomFuncType = [IntegerAtomType, IntegerAtomType, BoolAtomType],
43 atomFuncBody = body $ integerAtomFuncLessThan True >=> boolAtomNot},
44 AtomFunction { atomFuncName = "not",
45 atomFuncType = [BoolAtomType, BoolAtomType],
46 atomFuncBody = body $ \(b:_) -> boolAtomNot b },
47 AtomFunction { atomFuncName = "int",
48 atomFuncType = [IntegerAtomType, IntAtomType],
49 atomFuncBody = body $ \(IntegerAtom v:_) -> if v < fromIntegral (maxBound :: Int) then
50 pure (IntAtom (fromIntegral v))
51 else
52 Left InvalidIntBoundError
53 }
55 ]
56 where
57 body = AtomFunctionBody Nothing
59integerAtomFuncLessThan :: Bool -> [Atom] -> Either AtomFunctionError Atom
60integerAtomFuncLessThan equality (IntegerAtom i1:IntegerAtom i2:_) = pure (BoolAtom (i1 `op` i2))
61 where
62 op = if equality then (<=) else (<)
63integerAtomFuncLessThan _ _= pure (BoolAtom False)
65boolAtomNot :: Atom -> Either AtomFunctionError Atom
66boolAtomNot (BoolAtom b) = pure (BoolAtom (not b))
67boolAtomNot _ = error "boolAtomNot called on non-Bool atom"
69--used by sum atom function
70relationSum :: Relation -> Either AtomFunctionError Atom
71relationSum relIn = pure (IntegerAtom (relFold (\tupIn acc -> acc + newVal tupIn) 0 relIn))
72 where
73 --extract Integer from Atom
74 newVal tupIn = castInteger (tupleAtoms tupIn V.! 0)
76relationCount :: Relation -> Either AtomFunctionError Atom
77relationCount relIn = pure (IntegerAtom (relFold (\_ acc -> acc + 1) (0::Integer) relIn))
79relationMax :: Relation -> Either AtomFunctionError Atom
80relationMax relIn = case oneTuple relIn of
81 Nothing -> Left AtomFunctionEmptyRelationError
82 Just oneTup -> pure (IntegerAtom (relFold (\tupIn acc -> max acc (newVal tupIn)) (newVal oneTup) relIn))
83 where
84 newVal tupIn = castInteger (tupleAtoms tupIn V.! 0)
86relationMin :: Relation -> Either AtomFunctionError Atom
87relationMin relIn = case oneTuple relIn of
88 Nothing -> Left AtomFunctionEmptyRelationError
89 Just oneTup -> pure (IntegerAtom (relFold (\tupIn acc -> min acc (newVal tupIn)) (newVal oneTup) relIn))
90 where
91 newVal tupIn = castInteger (tupleAtoms tupIn V.! 0)
93castInt :: Atom -> Int
94castInt (IntAtom i) = i
95castInt _ = error "attempted to cast non-IntAtom to Int"
97castInteger :: Atom -> Integer
98castInteger (IntegerAtom i) = i
99castInteger _ = error "attempted to cast non-IntegerAtom to Int"