Skip to content

Commit

Permalink
Merge pull request #2435 from JacquesCarette/movArithBinOps
Browse files Browse the repository at this point in the history 
Move arithmetic binary operations out of BinOp
  • Loading branch information
@JacquesCarette
JacquesCarette authored May 12, 2021
2 parents 6f0de9d + 25fd2dd commit acf6d8d
Show file tree
Hide file tree
Showing 8 changed files with 231 additions and 208 deletions.
36 changes: 19 additions & 17 deletions code/drasil-code/Data/Drasil/ExternalLibraries/ODELibraries.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -591,28 +591,30 @@ modifiedODESyst sufx info = map replaceDepVar (odeSyst info)
where
replaceDepVar (C c) = if c == depVar info ^. uid
then C (c ++ "_" ++ sufx) else C c
replaceDepVar (AssocA a es) = AssocA a (map replaceDepVar es)
replaceDepVar (AssocB b es) = AssocB b (map replaceDepVar es)
replaceDepVar (Deriv dt e u) = Deriv dt (replaceDepVar e) u
replaceDepVar (FCall u es nes) = FCall u (map replaceDepVar es)
replaceDepVar (AssocA a es) = AssocA a (map replaceDepVar es)
replaceDepVar (AssocB b es) = AssocB b (map replaceDepVar es)
replaceDepVar (Deriv dt e u) = Deriv dt (replaceDepVar e) u
replaceDepVar (FCall u es nes) = FCall u (map replaceDepVar es)
(map (over _2 replaceDepVar) nes)
replaceDepVar (New u es nes) = New u (map replaceDepVar es)
replaceDepVar (New u es nes) = New u (map replaceDepVar es)
(map (over _2 replaceDepVar) nes)
replaceDepVar (Message au mu es nes) = Message au mu (map replaceDepVar es)
replaceDepVar (Message au mu es nes) = Message au mu (map replaceDepVar es)
(map (over _2 replaceDepVar) nes)
replaceDepVar (Case c cs) = Case c (map (over _1 replaceDepVar) cs)
replaceDepVar (Matrix es) = Matrix $ map (map replaceDepVar) es
replaceDepVar (UnaryOp u e) = UnaryOp u $ replaceDepVar e
replaceDepVar (UnaryOpB u e) = UnaryOpB u $ replaceDepVar e
replaceDepVar (UnaryOpVec u e) = UnaryOpVec u $ replaceDepVar e
replaceDepVar (BinaryOp b e1 e2) = BinaryOp b
replaceDepVar (Case c cs) = Case c (map (over _1 replaceDepVar) cs)
replaceDepVar (Matrix es) = Matrix $ map (map replaceDepVar) es
replaceDepVar (UnaryOp u e) = UnaryOp u $ replaceDepVar e
replaceDepVar (UnaryOpB u e) = UnaryOpB u $ replaceDepVar e
replaceDepVar (UnaryOpVec u e) = UnaryOpVec u $ replaceDepVar e
replaceDepVar (BinaryOp b e1 e2) = BinaryOp b
(replaceDepVar e1) (replaceDepVar e2)
replaceDepVar (BoolBinaryOp b e1 e2) = BoolBinaryOp b
replaceDepVar (ArithBinaryOp b e1 e2) = ArithBinaryOp b
(replaceDepVar e1) (replaceDepVar e2)
replaceDepVar (EqBinaryOp b e1 e2) = EqBinaryOp b
replaceDepVar (BoolBinaryOp b e1 e2) = BoolBinaryOp b
(replaceDepVar e1) (replaceDepVar e2)
replaceDepVar (OrdBinaryOp b e1 e2) = OrdBinaryOp b
replaceDepVar (EqBinaryOp b e1 e2) = EqBinaryOp b
(replaceDepVar e1) (replaceDepVar e2)
replaceDepVar (Operator ao dd e) = Operator ao dd $ replaceDepVar e
replaceDepVar (IsIn e s) = IsIn (replaceDepVar e) s
replaceDepVar (OrdBinaryOp b e1 e2) = OrdBinaryOp b
(replaceDepVar e1) (replaceDepVar e2)
replaceDepVar (Operator ao dd e) = Operator ao dd $ replaceDepVar e
replaceDepVar (IsIn e s) = IsIn (replaceDepVar e) s
replaceDepVar e = e
36 changes: 20 additions & 16 deletions code/drasil-code/Language/Drasil/Code/Imperative/Import.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,7 +9,7 @@ module Language.Drasil.Code.Imperative.Import (codeType, spaceCodeType,
import Language.Drasil hiding (Ref, int, log, ln, exp,
sin, cos, tan, csc, sec, cot, arcsin, arccos, arctan)
import Language.Drasil.Development (UFuncB(..), UFuncVec(..),
EqBinOp(..), BoolBinOp(..), OrdBinOp(..))
ArithBinOp(..), BoolBinOp(..), EqBinOp(..), OrdBinOp(..))
import Database.Drasil (symbResolve)
import Language.Drasil.Code.Imperative.Comments (getComment)
import Language.Drasil.Code.Imperative.ConceptMatch (conceptToGOOL)
Expand Down Expand Up @@ -313,20 +313,21 @@ convExpr (Field o f) = do
fld = quantvar (lookupC g f)
v <- mkVar (ccObjVar ob fld)
return $ valueOf v
convExpr (UnaryOp o u) = fmap (unop o) (convExpr u)
convExpr (UnaryOpB o u) = fmap (unopB o) (convExpr u)
convExpr (UnaryOp o u) = fmap (unop o) (convExpr u)
convExpr (UnaryOpB o u) = fmap (unopB o) (convExpr u)
convExpr (UnaryOpVec o u) = fmap (unopVec o) (convExpr u)
convExpr (BinaryOp Frac (Int a) (Int b)) = do -- hack to deal with integer division
convExpr (ArithBinaryOp Frac (Int a) (Int b)) = do -- hack to deal with integer division
sm <- spaceCodeType Rational
let getLiteral Double = litDouble (fromIntegral a) #/ litDouble (fromIntegral b)
getLiteral Float = litFloat (fromIntegral a) #/ litFloat (fromIntegral b)
getLiteral _ = error "convExpr: Rational space matched to invalid CodeType; should be Double or Float"
return $ getLiteral sm
convExpr (BinaryOp o a b) = liftM2 (bfunc o) (convExpr a) (convExpr b)
convExpr (BoolBinaryOp o a b) = liftM2 (boolBfunc o) (convExpr a) (convExpr b)
convExpr (EqBinaryOp o a b) = liftM2 (eqBfunc o) (convExpr a) (convExpr b)
convExpr (OrdBinaryOp o a b) = liftM2 (ordBfunc o) (convExpr a) (convExpr b)
convExpr (Case c l) = doit l -- FIXME this is sub-optimal
convExpr (BinaryOp o a b) = liftM2 (bfunc o) (convExpr a) (convExpr b)
convExpr (ArithBinaryOp o a b) = liftM2 (arithBfunc o) (convExpr a) (convExpr b)
convExpr (BoolBinaryOp o a b) = liftM2 (boolBfunc o) (convExpr a) (convExpr b)
convExpr (EqBinaryOp o a b) = liftM2 (eqBfunc o) (convExpr a) (convExpr b)
convExpr (OrdBinaryOp o a b) = liftM2 (ordBfunc o) (convExpr a) (convExpr b)
convExpr (Case c l) = doit l -- FIXME this is sub-optimal
where
doit [] = error "should never happen" -- TODO: change error message?
doit [(e,_)] = convExpr e -- should always be the else clause
Expand Down Expand Up @@ -410,26 +411,29 @@ unopVec :: (OOProg r) => UFuncVec -> (SValue r -> SValue r)
unopVec Dim = listSize
unopVec Norm = error "unop: Norm not implemented" -- TODO

-- Maps a BinOp to the corresponding GOOL binary function
-- Maps a BinOp to it's corresponding GOOL binary function
bfunc :: (OOProg r) => BinOp -> (SValue r -> SValue r -> SValue r)
bfunc Cross = error "bfunc: Cross not implemented"
bfunc Pow = (#^)
bfunc Subt = (#-)
bfunc Dot = error "convExpr DotProduct"
bfunc Frac = (#/)
bfunc Index = listAccess

-- Maps a BoolBinOp to the corresponding GOOL binary function
-- Maps an ArithBinOp to it's corresponding GOOL binary function
arithBfunc :: (OOProg r) => ArithBinOp -> (SValue r -> SValue r -> SValue r)
arithBfunc Pow = (#^)
arithBfunc Subt = (#-)
arithBfunc Frac = (#/)

-- Maps a BoolBinOp to it's corresponding GOOL binary function
boolBfunc :: BoolBinOp -> (SValue r -> SValue r -> SValue r)
boolBfunc Impl = error "convExpr :=>"
boolBfunc Iff = error "convExpr :<=>"

-- Maps an EqBinOp to the corresponding GOOL binary function
-- Maps an EqBinOp to it's corresponding GOOL binary function
eqBfunc :: (OOProg r) => EqBinOp -> (SValue r -> SValue r -> SValue r)
eqBfunc Eq = (?==)
eqBfunc NEq = (?!=)

-- Maps an OrdBinOp to the corresponding GOOL binary function
-- Maps an OrdBinOp to it's corresponding GOOL binary function
ordBfunc :: (OOProg r) => OrdBinOp -> (SValue r -> SValue r -> SValue r)
ordBfunc Gt = (?>)
ordBfunc Lt = (?<)
Expand Down
4 changes: 2 additions & 2 deletions code/drasil-lang/Language/Drasil.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,7 @@
module Language.Drasil (
-- Expr
Expr(..), BinOp(..), UFunc(..), UFuncB, UFuncVec
, BoolBinOp, EqBinOp, OrdBinOp
, ArithBinOp, BoolBinOp, EqBinOp, OrdBinOp
, AssocArithOper(..), AssocBoolOper(..)
, DerivType(..), Completeness(..), Relation
, ($=), ($<), ($<=), ($>), ($>=), ($^), ($&&), ($||), ($=>), ($<=>), ($.)
Expand Down Expand Up @@ -184,7 +184,7 @@ module Language.Drasil (

import Prelude hiding (log, sin, cos, tan, sqrt, id, return, print, break, exp, product)
import Language.Drasil.Expr (Expr(..), BinOp(..), UFunc(..), UFuncB, UFuncVec,
BoolBinOp, EqBinOp, OrdBinOp,
ArithBinOp, BoolBinOp, EqBinOp, OrdBinOp,
AssocArithOper(..), AssocBoolOper(..),
DerivType(..), Completeness(..), Relation,
($=), ($<), ($<=), ($>), ($>=), ($^), ($&&), ($||), ($=>), ($<=>), ($.))
Expand Down
4 changes: 2 additions & 2 deletions code/drasil-lang/Language/Drasil/Development.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,7 @@ module Language.Drasil.Development (
NounPhrase(phraseNP,pluralNP)
-- Expr
, UFuncB(..), UFuncVec(..)
, BoolBinOp(..), EqBinOp(..), OrdBinOp(..)
, ArithBinOp(..), BoolBinOp(..), EqBinOp(..), OrdBinOp(..)
-- Expr.Extract
, dep, names, names', namesRI
-- Sentence.Extract
Expand All @@ -15,7 +15,7 @@ module Language.Drasil.Development (

import Language.Drasil.NounPhrase (NounPhrase(phraseNP,pluralNP))
import Language.Drasil.Expr (UFuncB(..), UFuncVec(..)
, BoolBinOp(..), EqBinOp(..), OrdBinOp(..))
, ArithBinOp(..), BoolBinOp(..), EqBinOp(..), OrdBinOp(..))
import Language.Drasil.Expr.Extract (dep, names', names, namesRI)
import Language.Drasil.Expr.Precedence (precA, precB, eprec)
import Language.Drasil.Sentence.Extract(sdep, lnames, lnames')
60 changes: 33 additions & 27 deletions code/drasil-lang/Language/Drasil/Expr.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -23,9 +23,11 @@ infixr 9 $||
-- TODO: Move the below to a separate file somehow. How to go about it?

-- | Binary functions
data BinOp = Frac | Pow | Subt | Index | Dot | Cross
data BinOp = Index | Dot | Cross
deriving Eq

data ArithBinOp = Frac | Pow | Subt

data EqBinOp = Eq | NEq

data BoolBinOp = Impl | Iff
Expand Down Expand Up @@ -79,19 +81,21 @@ data Expr where
-- | Access a field of an actor:
-- 1st UID is the actor,
-- 2nd UID is the field
Field :: UID -> UID -> Expr
Field :: UID -> UID -> Expr
-- | For multi-case expressions, each pair represents one case
Case :: Completeness -> [(Expr,Relation)] -> Expr
Matrix :: [[Expr]] -> Expr

-- | Unary functions/operations
UnaryOp :: UFunc -> Expr -> Expr
UnaryOpB :: UFuncB -> Expr -> Expr
UnaryOpVec :: UFuncVec -> Expr -> Expr

BinaryOp :: BinOp -> Expr -> Expr -> Expr
BoolBinaryOp :: BoolBinOp -> Expr -> Expr -> Expr
EqBinaryOp :: EqBinOp -> Expr -> Expr -> Expr
UnaryOp :: UFunc -> Expr -> Expr
UnaryOpB :: UFuncB -> Expr -> Expr
UnaryOpVec :: UFuncVec -> Expr -> Expr

-- | Binary functions/operations
BinaryOp :: BinOp -> Expr -> Expr -> Expr
ArithBinaryOp :: ArithBinOp -> Expr -> Expr -> Expr
BoolBinaryOp :: BoolBinOp -> Expr -> Expr -> Expr
EqBinaryOp :: EqBinOp -> Expr -> Expr -> Expr
OrdBinaryOp :: OrdBinOp -> Expr -> Expr -> Expr

-- | Operators are generalized arithmetic operators over a |DomainDesc|
Expand All @@ -104,29 +108,31 @@ data Expr where
RealI :: UID -> RealInterval Expr Expr -> Expr

($=), ($!=) :: Expr -> Expr -> Expr
($=) = EqBinaryOp Eq
($!=) = EqBinaryOp NEq
($=) = EqBinaryOp Eq
($!=) = EqBinaryOp NEq

($<), ($>), ($<=), ($>=) :: Expr -> Expr -> Expr
($<) = OrdBinaryOp Lt
($>) = OrdBinaryOp Gt
($<=) = OrdBinaryOp LEq
($>=) = OrdBinaryOp GEq
($<) = OrdBinaryOp Lt
($>) = OrdBinaryOp Gt
($<=) = OrdBinaryOp LEq
($>=) = OrdBinaryOp GEq

($.), ($-), ($/), ($^) :: Expr -> Expr -> Expr
($.) = BinaryOp Dot
($-) = BinaryOp Subt
($/) = BinaryOp Frac
($^) = BinaryOp Pow
($.) :: Expr -> Expr -> Expr
($.) = BinaryOp Dot

($&&), ($||) :: Expr -> Expr -> Expr
a $&& b = AssocB And [a,b]
a $|| b = AssocB Or [a,b]
($-), ($/), ($^) :: Expr -> Expr -> Expr
($-) = ArithBinaryOp Subt
($/) = ArithBinaryOp Frac
($^) = ArithBinaryOp Pow

($=>), ($<=>) :: Expr -> Expr -> Expr
($=>) = BoolBinaryOp Impl
($<=>) = BoolBinaryOp Iff

($&&), ($||) :: Expr -> Expr -> Expr
a $&& b = AssocB And [a,b]
a $|| b = AssocB Or [a,b]

type Variable = String

data DerivType = Part | Total
Expand All @@ -145,7 +151,7 @@ instance Num Expr where
a * (AssocA Mul l) = AssocA Mul (a : l)
a * b = AssocA Mul [a, b]

a - b = BinaryOp Subt a b
a - b = ArithBinaryOp Subt a b

fromInteger = Int
abs = UnaryOp Abs
Expand All @@ -169,6 +175,6 @@ instance Eq Expr where
_ == _ = False

instance Fractional Expr where
a / b = BinaryOp Frac a b
fromRational r = BinaryOp Frac (fromInteger $ numerator r)
(fromInteger $ denominator r)
a / b = ArithBinaryOp Frac a b
fromRational r = ArithBinaryOp Frac (fromInteger $ numerator r)
(fromInteger $ denominator r)
112 changes: 57 additions & 55 deletions code/drasil-lang/Language/Drasil/Expr/Extract.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,33 +7,34 @@ import Language.Drasil.Space (RealInterval(..))

-- | Generic traverse of all positions that could lead to names
names :: Expr -> [String]
names (AssocA _ l) = concatMap names l
names (AssocB _ l) = concatMap names l
names (Deriv _ a b) = b : names a
names (C c) = [c]
names Int{} = []
names Dbl{} = []
names Str{} = []
names Perc{} = []
names (FCall f x ns) = f : concatMap names x ++ map fst ns ++
concatMap (names . snd) ns
names (New c x ns) = c : concatMap names x ++ map fst ns ++
concatMap (names . snd) ns
names (Message a m x ns) = a : m : concatMap names x ++ map fst ns ++
concatMap (names . snd) ns
names (Field o f) = [o, f]
names (Case _ ls) = concatMap (names . fst) ls ++ concatMap (names . snd) ls
names (UnaryOp _ u) = names u
names (UnaryOpB _ u) = names u
names (UnaryOpVec _ u) = names u
names (BinaryOp _ a b) = names a ++ names b
names (BoolBinaryOp _ a b) = names a ++ names b
names (EqBinaryOp _ a b) = names a ++ names b
names (OrdBinaryOp _ a b) = names a ++ names b
names (Operator _ _ e) = names e
names (IsIn a _) = names a
names (Matrix a) = concatMap (concatMap names) a
names (RealI c b) = c : namesRI b
names (AssocA _ l) = concatMap names l
names (AssocB _ l) = concatMap names l
names (Deriv _ a b) = b : names a
names (C c) = [c]
names Int{} = []
names Dbl{} = []
names Str{} = []
names Perc{} = []
names (FCall f x ns) = f : concatMap names x ++ map fst ns ++
concatMap (names . snd) ns
names (New c x ns) = c : concatMap names x ++ map fst ns ++
concatMap (names . snd) ns
names (Message a m x ns) = a : m : concatMap names x ++ map fst ns ++
concatMap (names . snd) ns
names (Field o f) = [o, f]
names (Case _ ls) = concatMap (names . fst) ls ++ concatMap (names . snd) ls
names (UnaryOp _ u) = names u
names (UnaryOpB _ u) = names u
names (UnaryOpVec _ u) = names u
names (BinaryOp _ a b) = names a ++ names b
names (ArithBinaryOp _ a b) = names a ++ names b
names (BoolBinaryOp _ a b) = names a ++ names b
names (EqBinaryOp _ a b) = names a ++ names b
names (OrdBinaryOp _ a b) = names a ++ names b
names (Operator _ _ e) = names e
names (IsIn a _) = names a
names (Matrix a) = concatMap (concatMap names) a
names (RealI c b) = c : namesRI b

namesRI :: RealInterval Expr Expr -> [String]
namesRI (Bounded (_,il) (_,iu)) = names il ++ names iu
Expand All @@ -44,34 +45,35 @@ namesRI (UpFrom (_,il)) = names il
-- functions. FIXME : this should really be done via post-facto filtering, but
-- right now the information needed to do this is not available!
names' :: Expr -> [String]
names' (AssocA _ l) = concatMap names' l
names' (AssocB _ l) = concatMap names' l
names' (Deriv _ a b) = b : names' a
names' (C c) = [c]
names' Int{} = []
names' Dbl{} = []
names' Str{} = []
names' Perc{} = []
names' (FCall _ x ns) = concatMap names' x ++ map fst ns ++
concatMap (names .snd) ns
names' (New _ x ns) = concatMap names' x ++ map fst ns ++
concatMap (names .snd) ns
names' (Message a _ x ns) = a : concatMap names' x ++ map fst ns ++
concatMap (names .snd) ns
names' (Field o f) = [o, f]
names' (Case _ ls) = concatMap (names' . fst) ls ++
concatMap (names' . snd) ls
names' (UnaryOp _ u) = names' u
names' (UnaryOpB _ u) = names' u
names' (UnaryOpVec _ u) = names' u
names' (BinaryOp _ a b) = names' a ++ names' b
names' (BoolBinaryOp _ a b) = names' a ++ names' b
names' (EqBinaryOp _ a b) = names' a ++ names' b
names' (OrdBinaryOp _ a b) = names' a ++ names' b
names' (Operator _ _ e) = names' e
names' (IsIn a _) = names' a
names' (Matrix a) = concatMap (concatMap names') a
names' (RealI c b) = c : namesRI' b
names' (AssocA _ l) = concatMap names' l
names' (AssocB _ l) = concatMap names' l
names' (Deriv _ a b) = b : names' a
names' (C c) = [c]
names' Int{} = []
names' Dbl{} = []
names' Str{} = []
names' Perc{} = []
names' (FCall _ x ns) = concatMap names' x ++ map fst ns ++
concatMap (names .snd) ns
names' (New _ x ns) = concatMap names' x ++ map fst ns ++
concatMap (names .snd) ns
names' (Message a _ x ns) = a : concatMap names' x ++ map fst ns ++
concatMap (names .snd) ns
names' (Field o f) = [o, f]
names' (Case _ ls) = concatMap (names' . fst) ls ++
concatMap (names' . snd) ls
names' (UnaryOp _ u) = names' u
names' (UnaryOpB _ u) = names' u
names' (UnaryOpVec _ u) = names' u
names' (BinaryOp _ a b) = names' a ++ names' b
names' (ArithBinaryOp _ a b) = names' a ++ names' b
names' (BoolBinaryOp _ a b) = names' a ++ names' b
names' (EqBinaryOp _ a b) = names' a ++ names' b
names' (OrdBinaryOp _ a b) = names' a ++ names' b
names' (Operator _ _ e) = names' e
names' (IsIn a _) = names' a
names' (Matrix a) = concatMap (concatMap names') a
names' (RealI c b) = c : namesRI' b

namesRI' :: RealInterval Expr Expr -> [String]
namesRI' (Bounded il iu) = names' (snd il) ++ names' (snd iu)
Expand Down
Loading

0 comments on commit acf6d8d

Please sign in to comment.