{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Language.Drasil.ModelExpr.Class where

import Prelude hiding (sqrt, log, sin, cos, tan, exp)

import Control.Lens ((^.))

import Language.Drasil.UID (HasUID(..))
import Language.Drasil.ModelExpr.Lang (ModelExpr(..), DerivType(..),
  SpaceBinOp(..), StatBinOp(..), AssocBoolOper(..), AssocArithOper(..))
import Language.Drasil.Space (DomainDesc(..), RTopology(..), Space)
import Language.Drasil.Symbol (Symbol, HasSymbol)

  
-- | Helper for creating new smart constructors for Associative Binary
--   operations that require at least 1 expression.
assocCreate :: AssocBoolOper -> [ModelExpr] -> ModelExpr
assocCreate :: AssocBoolOper -> [ModelExpr] -> ModelExpr
assocCreate abo :: AssocBoolOper
abo [] = [Char] -> ModelExpr
forall a. HasCallStack => [Char] -> a
error ([Char] -> ModelExpr) -> [Char] -> ModelExpr
forall a b. (a -> b) -> a -> b
$ "Need at least 1 expression to create " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AssocBoolOper -> [Char]
forall a. Show a => a -> [Char]
show AssocBoolOper
abo
assocCreate _ [x :: ModelExpr
x]  = ModelExpr
x
assocCreate b :: AssocBoolOper
b des :: [ModelExpr]
des  = AssocBoolOper -> [ModelExpr] -> ModelExpr
AssocB AssocBoolOper
b ([ModelExpr] -> ModelExpr) -> [ModelExpr] -> ModelExpr
forall a b. (a -> b) -> a -> b
$ AssocBoolOper -> [ModelExpr] -> [ModelExpr]
assocSanitize AssocBoolOper
b [ModelExpr]
des
  
-- | Helper for associative operations, removes embedded variants of the same kind
assocSanitize :: AssocBoolOper -> [ModelExpr] -> [ModelExpr]
assocSanitize :: AssocBoolOper -> [ModelExpr] -> [ModelExpr]
assocSanitize _ [] = []
assocSanitize b :: AssocBoolOper
b (it :: ModelExpr
it@(AssocB c :: AssocBoolOper
c des :: [ModelExpr]
des):r :: [ModelExpr]
r)
  | AssocBoolOper
b AssocBoolOper -> AssocBoolOper -> Bool
forall a. Eq a => a -> a -> Bool
== AssocBoolOper
c    = AssocBoolOper -> [ModelExpr] -> [ModelExpr]
assocSanitize AssocBoolOper
b [ModelExpr]
des [ModelExpr] -> [ModelExpr] -> [ModelExpr]
forall a. [a] -> [a] -> [a]
++ AssocBoolOper -> [ModelExpr] -> [ModelExpr]
assocSanitize AssocBoolOper
b [ModelExpr]
r
  | Bool
otherwise = ModelExpr
it ModelExpr -> [ModelExpr] -> [ModelExpr]
forall a. a -> [a] -> [a]
: AssocBoolOper -> [ModelExpr] -> [ModelExpr]
assocSanitize AssocBoolOper
b [ModelExpr]
r
assocSanitize b :: AssocBoolOper
b (de :: ModelExpr
de:des :: [ModelExpr]
des) = ModelExpr
de ModelExpr -> [ModelExpr] -> [ModelExpr]
forall a. a -> [a] -> [a]
: AssocBoolOper -> [ModelExpr] -> [ModelExpr]
assocSanitize AssocBoolOper
b [ModelExpr]
des

class ModelExprC r where
  -- This also wants a symbol constraint.
  -- | Gets the derivative of an 'ModelExpr' with respect to a 'Symbol'.
  deriv, pderiv :: (HasUID c, HasSymbol c) => r -> c -> r
  
  -- | Gets the nthderivative of an 'ModelExpr' with respect to a 'Symbol'.
  nthderiv, nthpderiv :: (HasUID c, HasSymbol c) => Integer -> r -> c -> r

  -- | One expression is "defined" by another.
  defines :: r -> r -> r
  
  -- | Space literals.
  space :: Space -> r

  -- | Check if a value belongs to a Space.
  isIn :: r -> Space -> r
  
  -- | Binary associative "Equivalence".
  equiv :: [r] -> r
  
  -- | Smart constructor for the summation, product, and integral functions over all Real numbers.
  intAll, sumAll, prodAll :: Symbol -> r -> r

instance ModelExprC ModelExpr where
  deriv :: ModelExpr -> c -> ModelExpr
deriv e :: ModelExpr
e c :: c
c  = Integer -> DerivType -> ModelExpr -> UID -> ModelExpr
Deriv 1 DerivType
Total ModelExpr
e (c
c c -> Getting UID c UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID c UID
forall c. HasUID c => Lens' c UID
uid)
  pderiv :: ModelExpr -> c -> ModelExpr
pderiv e :: ModelExpr
e c :: c
c = Integer -> DerivType -> ModelExpr -> UID -> ModelExpr
Deriv 1 DerivType
Part  ModelExpr
e (c
c c -> Getting UID c UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID c UID
forall c. HasUID c => Lens' c UID
uid)
  nthderiv :: Integer -> ModelExpr -> c -> ModelExpr
nthderiv n :: Integer
n e :: ModelExpr
e c :: c
c
    | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> 0     = Integer -> DerivType -> ModelExpr -> UID -> ModelExpr
Deriv Integer
n DerivType
Total ModelExpr
e (c
c c -> Getting UID c UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID c UID
forall c. HasUID c => Lens' c UID
uid)
    | Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 0    = Integer -> DerivType -> ModelExpr -> UID -> ModelExpr
Deriv 0 DerivType
Total ModelExpr
e (c
c c -> Getting UID c UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID c UID
forall c. HasUID c => Lens' c UID
uid)
    | Bool
otherwise = [Char] -> ModelExpr
forall a. HasCallStack => [Char] -> a
error "non-positive argument to derivative"

  nthpderiv :: Integer -> ModelExpr -> c -> ModelExpr
nthpderiv n :: Integer
n e :: ModelExpr
e c :: c
c
    | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> 0     = Integer -> DerivType -> ModelExpr -> UID -> ModelExpr
Deriv Integer
n DerivType
Part ModelExpr
e (c
c c -> Getting UID c UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID c UID
forall c. HasUID c => Lens' c UID
uid)
    | Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 0    = Integer -> DerivType -> ModelExpr -> UID -> ModelExpr
Deriv 0 DerivType
Total ModelExpr
e (c
c c -> Getting UID c UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID c UID
forall c. HasUID c => Lens' c UID
uid)
    | Bool
otherwise = [Char] -> ModelExpr
forall a. HasCallStack => [Char] -> a
error "non-positive argument to derivative"

  defines :: ModelExpr -> ModelExpr -> ModelExpr
defines = StatBinOp -> ModelExpr -> ModelExpr -> ModelExpr
StatBinaryOp StatBinOp
Defines

  space :: Space -> ModelExpr
space = Space -> ModelExpr
Spc

  isIn :: ModelExpr -> Space -> ModelExpr
isIn a :: ModelExpr
a s :: Space
s = SpaceBinOp -> ModelExpr -> ModelExpr -> ModelExpr
SpaceBinaryOp SpaceBinOp
IsIn ModelExpr
a (Space -> ModelExpr
Spc Space
s)

  equiv :: [ModelExpr] -> ModelExpr
equiv des :: [ModelExpr]
des
    | [ModelExpr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ModelExpr]
des Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 2 = AssocBoolOper -> [ModelExpr] -> ModelExpr
assocCreate AssocBoolOper
Equivalence [ModelExpr]
des
    | Bool
otherwise       = [Char] -> ModelExpr
forall a. HasCallStack => [Char] -> a
error ([Char] -> ModelExpr) -> [Char] -> ModelExpr
forall a b. (a -> b) -> a -> b
$ "Need at least 2 expressions to create " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AssocBoolOper -> [Char]
forall a. Show a => a -> [Char]
show AssocBoolOper
Equivalence
 
  -- TODO: All of the below only allow for Reals! Will be easier to fix while we add typing.
  -- | Integrate over some expression (∫).
  intAll :: Symbol -> ModelExpr -> ModelExpr
intAll v :: Symbol
v = AssocArithOper
-> DomainDesc 'Continuous ModelExpr ModelExpr
-> ModelExpr
-> ModelExpr
forall (t :: RTopology).
AssocArithOper
-> DomainDesc t ModelExpr ModelExpr -> ModelExpr -> ModelExpr
Operator AssocArithOper
AddRe (Symbol -> RTopology -> DomainDesc 'Continuous ModelExpr ModelExpr
forall a b. Symbol -> RTopology -> DomainDesc 'Continuous a b
AllDD Symbol
v RTopology
Continuous)
  -- | Sum over some expression (∑).
  sumAll :: Symbol -> ModelExpr -> ModelExpr
sumAll v :: Symbol
v = AssocArithOper
-> DomainDesc 'Continuous ModelExpr ModelExpr
-> ModelExpr
-> ModelExpr
forall (t :: RTopology).
AssocArithOper
-> DomainDesc t ModelExpr ModelExpr -> ModelExpr -> ModelExpr
Operator AssocArithOper
AddRe (Symbol -> RTopology -> DomainDesc 'Continuous ModelExpr ModelExpr
forall a b. Symbol -> RTopology -> DomainDesc 'Continuous a b
AllDD Symbol
v RTopology
Discrete)
  -- | Product over some expression (∏).
  prodAll :: Symbol -> ModelExpr -> ModelExpr
prodAll v :: Symbol
v = AssocArithOper
-> DomainDesc 'Continuous ModelExpr ModelExpr
-> ModelExpr
-> ModelExpr
forall (t :: RTopology).
AssocArithOper
-> DomainDesc t ModelExpr ModelExpr -> ModelExpr -> ModelExpr
Operator AssocArithOper
MulRe (Symbol -> RTopology -> DomainDesc 'Continuous ModelExpr ModelExpr
forall a b. Symbol -> RTopology -> DomainDesc 'Continuous a b
AllDD Symbol
v RTopology
Discrete)