{-# LANGUAGE DeriveGeneric, PatternGuards, PatternSynonyms,
    MultiParamTypeClasses, FlexibleContexts, DeriveDataTypeable,
    GeneralizedNewtypeDeriving #-}

{-|
Module      : Math.MFSolve
Description : Equation solver and calculator à la metafont
Copyright   : (c) Kristof Bastiaensen, 2015
License     : BSD-3
Maintainer  : kristof@resonata.be
Stability   : unstable
Portability : ghc

This module implements an equation solver that solves and evaluates
expressions on the fly.  It is based on Prof. D.E.Knuth's
/metafont/.  The goal of mfsolve is to make the solver useful in an
interactive program, by enhancing the bidirectionality of the solver.
Like metafont, it can solve linear equations, and evaluate nonlinear
expressions.  In addition to metafont, it also solves for angles, and
makes the solution independend of the order of the equations.

The `Expr` datatype allows for calculations with constants and unknown
variables.  The `Dependencies` datatype contains all dependencies and known equations.

=== Examples:

Let's define some variables.  The `SimpleVar` type is a simple wrapper
around `String` to provide nice output, since the Show instance for
`String` outputs quotation marks.

> let [x, y, t, a] = map (makeVariable . SimpleVar) ["x", "y", "t", "a"]

Solve linear equations:

> showVars $ flip execSolver noDeps $ do
>   2*x + y === 5
>   x - y   === 1

> x = 2.0
> y = 1.0

Solve for angle (pi/4):

> showVars $ flip execSolver noDeps $ sin(t) === 1/sqrt(2)

> t = 0.7853981633974484

Solve for angle (pi/3) and amplitude:

> showVars $ flip execSolver noDeps $ do
>   a*sin(x) === sqrt 3
>   a*cos(x) === 1

> x = 1.0471975511965979
> a = 2.0

Allow nonlinear expression with unknown variables:

> showVars $ flip execSolver noDeps $ do
>   sin(sqrt(x)) === y
>   x === 2

>x = 2.0
>y = 0.9877659459927355

Find the angle and amplitude when using a rotation matrix:

> showVars $ flip execSolver noDeps $ do
>   a*cos t*x - a*sin t*y === 30
>   a*sin t*x + a*cos t*y === 40
>   x === 10
>   y === 10

> x = 10.0
> y = 10.0
> t = 0.14189705460416402
> a = 3.5355339059327373

-}

module Math.MFSolve
       (-- * Expressions
        SimpleExpr(..), Expr, LinExpr(..), UnaryOp(..), BinaryOp(..),
        SimpleVar(..),
        makeVariable,
        makeConstant, evalExpr, fromSimple, toSimple, evalSimple, hasVar,
        mapSimple, mapExpr,
        -- * Dependencies
        Dependencies, DepError(..), 
        noDeps, addEquation, eliminate,
        getKnown, knownVars, varDefined, nonlinearEqs, dependendVars,
        -- * Monadic Interface
        (===), (=&=), dependencies, getValue, getKnownM,
        varDefinedM, eliminateM, ignore,
        -- * MFSolver monad
        MFSolver, 
        runSolver, evalSolver, execSolver, unsafeSolve, showVars,
        -- * MFSolverT monad transformer
        MFSolverT, 
        runSolverT, evalSolverT, execSolverT, unsafeSolveT)
where
import qualified Data.HashMap.Strict as M
import qualified Data.HashSet as H
import GHC.Generics
import Control.Monad.Except
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.Identity
import Control.Monad.Cont
import Control.Exception
import Data.Typeable
import Control.Applicative hiding (Const)
import Data.Hashable
import Data.Maybe
import Data.List
import Data.Function(on)

data BinaryOp =
  -- | Addition
  Add |
  -- | Multiplication
  Mul
  deriving BinaryOp -> BinaryOp -> Bool
(BinaryOp -> BinaryOp -> Bool)
-> (BinaryOp -> BinaryOp -> Bool) -> Eq BinaryOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BinaryOp -> BinaryOp -> Bool
$c/= :: BinaryOp -> BinaryOp -> Bool
== :: BinaryOp -> BinaryOp -> Bool
$c== :: BinaryOp -> BinaryOp -> Bool
Eq

data UnaryOp =
  -- | sine
  Sin |
  -- | cosine
  Cos |
  -- | absolute value
  Abs |
  -- | reciprocal (1/x)
  Recip |
  -- | sign
  Signum |
  -- | natural exponential (e^x)
  Exp |
  -- | natural logarithm (log x)
  Log |
  -- | hyperbolic cosine
  Cosh |
  -- | inverse hyperbolic tangent
  Atanh |
  -- | tangent
  Tan |
  -- | hyperbolic tangent
  Tanh |
  -- | hyperbolic sine
  Sinh |
  -- | inverse sine
  Asin |
  -- | inverse cosine
  Acos |
  -- | inverse hyperbolic sine
  Asinh |
  -- | inverse hyperbolic cosine
  Acosh |
  -- | inverse tangent
  Atan
  deriving (UnaryOp -> UnaryOp -> Bool
(UnaryOp -> UnaryOp -> Bool)
-> (UnaryOp -> UnaryOp -> Bool) -> Eq UnaryOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnaryOp -> UnaryOp -> Bool
$c/= :: UnaryOp -> UnaryOp -> Bool
== :: UnaryOp -> UnaryOp -> Bool
$c== :: UnaryOp -> UnaryOp -> Bool
Eq, (forall x. UnaryOp -> Rep UnaryOp x)
-> (forall x. Rep UnaryOp x -> UnaryOp) -> Generic UnaryOp
forall x. Rep UnaryOp x -> UnaryOp
forall x. UnaryOp -> Rep UnaryOp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UnaryOp x -> UnaryOp
$cfrom :: forall x. UnaryOp -> Rep UnaryOp x
Generic)

-- | A simplified datatype representing an expression.  This can be
-- used to inspect the structure of a `Expr`, which is hidden.
data SimpleExpr v n =
  SEBin BinaryOp (SimpleExpr v n) (SimpleExpr v n) |
  SEUn UnaryOp (SimpleExpr v n) |
  Var v |
  Const n

newtype SimpleVar = SimpleVar String
                  deriving (SimpleVar -> SimpleVar -> Bool
(SimpleVar -> SimpleVar -> Bool)
-> (SimpleVar -> SimpleVar -> Bool) -> Eq SimpleVar
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SimpleVar -> SimpleVar -> Bool
$c/= :: SimpleVar -> SimpleVar -> Bool
== :: SimpleVar -> SimpleVar -> Bool
$c== :: SimpleVar -> SimpleVar -> Bool
Eq, Eq SimpleVar
Eq SimpleVar
-> (SimpleVar -> SimpleVar -> Ordering)
-> (SimpleVar -> SimpleVar -> Bool)
-> (SimpleVar -> SimpleVar -> Bool)
-> (SimpleVar -> SimpleVar -> Bool)
-> (SimpleVar -> SimpleVar -> Bool)
-> (SimpleVar -> SimpleVar -> SimpleVar)
-> (SimpleVar -> SimpleVar -> SimpleVar)
-> Ord SimpleVar
SimpleVar -> SimpleVar -> Bool
SimpleVar -> SimpleVar -> Ordering
SimpleVar -> SimpleVar -> SimpleVar
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SimpleVar -> SimpleVar -> SimpleVar
$cmin :: SimpleVar -> SimpleVar -> SimpleVar
max :: SimpleVar -> SimpleVar -> SimpleVar
$cmax :: SimpleVar -> SimpleVar -> SimpleVar
>= :: SimpleVar -> SimpleVar -> Bool
$c>= :: SimpleVar -> SimpleVar -> Bool
> :: SimpleVar -> SimpleVar -> Bool
$c> :: SimpleVar -> SimpleVar -> Bool
<= :: SimpleVar -> SimpleVar -> Bool
$c<= :: SimpleVar -> SimpleVar -> Bool
< :: SimpleVar -> SimpleVar -> Bool
$c< :: SimpleVar -> SimpleVar -> Bool
compare :: SimpleVar -> SimpleVar -> Ordering
$ccompare :: SimpleVar -> SimpleVar -> Ordering
$cp1Ord :: Eq SimpleVar
Ord, (forall x. SimpleVar -> Rep SimpleVar x)
-> (forall x. Rep SimpleVar x -> SimpleVar) -> Generic SimpleVar
forall x. Rep SimpleVar x -> SimpleVar
forall x. SimpleVar -> Rep SimpleVar x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SimpleVar x -> SimpleVar
$cfrom :: forall x. SimpleVar -> Rep SimpleVar x
Generic, Typeable)

-- | A mathematical expression of several variables. Several Numeric
-- instances (`Num`, `Floating` and `Fractional`) are provided, so
-- doing calculations over `Expr` is more convenient.
data Expr v n = Expr (LinExpr v n) [TrigTerm v n] [NonLinExpr v n]
                deriving (Expr v n -> Expr v n -> Bool
(Expr v n -> Expr v n -> Bool)
-> (Expr v n -> Expr v n -> Bool) -> Eq (Expr v n)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall v n. (Eq n, Eq v) => Expr v n -> Expr v n -> Bool
/= :: Expr v n -> Expr v n -> Bool
$c/= :: forall v n. (Eq n, Eq v) => Expr v n -> Expr v n -> Bool
== :: Expr v n -> Expr v n -> Bool
$c== :: forall v n. (Eq n, Eq v) => Expr v n -> Expr v n -> Bool
Eq, (forall x. Expr v n -> Rep (Expr v n) x)
-> (forall x. Rep (Expr v n) x -> Expr v n) -> Generic (Expr v n)
forall x. Rep (Expr v n) x -> Expr v n
forall x. Expr v n -> Rep (Expr v n) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall v n x. Rep (Expr v n) x -> Expr v n
forall v n x. Expr v n -> Rep (Expr v n) x
$cto :: forall v n x. Rep (Expr v n) x -> Expr v n
$cfrom :: forall v n x. Expr v n -> Rep (Expr v n) x
Generic)

-- | A linear expression of several variables.
-- For example: @2*a + 3*b + 2@ would be represented as
-- @LinExpr 2 [(a, 2), (b, 3)]@.
data LinExpr v n = LinExpr n [(v, n)]
                 deriving ((forall x. LinExpr v n -> Rep (LinExpr v n) x)
-> (forall x. Rep (LinExpr v n) x -> LinExpr v n)
-> Generic (LinExpr v n)
forall x. Rep (LinExpr v n) x -> LinExpr v n
forall x. LinExpr v n -> Rep (LinExpr v n) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall v n x. Rep (LinExpr v n) x -> LinExpr v n
forall v n x. LinExpr v n -> Rep (LinExpr v n) x
$cto :: forall v n x. Rep (LinExpr v n) x -> LinExpr v n
$cfrom :: forall v n x. LinExpr v n -> Rep (LinExpr v n) x
Generic, LinExpr v n -> LinExpr v n -> Bool
(LinExpr v n -> LinExpr v n -> Bool)
-> (LinExpr v n -> LinExpr v n -> Bool) -> Eq (LinExpr v n)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall v n. (Eq n, Eq v) => LinExpr v n -> LinExpr v n -> Bool
/= :: LinExpr v n -> LinExpr v n -> Bool
$c/= :: forall v n. (Eq n, Eq v) => LinExpr v n -> LinExpr v n -> Bool
== :: LinExpr v n -> LinExpr v n -> Bool
$c== :: forall v n. (Eq n, Eq v) => LinExpr v n -> LinExpr v n -> Bool
Eq, Int -> LinExpr v n -> ShowS
[LinExpr v n] -> ShowS
LinExpr v n -> String
(Int -> LinExpr v n -> ShowS)
-> (LinExpr v n -> String)
-> ([LinExpr v n] -> ShowS)
-> Show (LinExpr v n)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall v n. (Show n, Show v) => Int -> LinExpr v n -> ShowS
forall v n. (Show n, Show v) => [LinExpr v n] -> ShowS
forall v n. (Show n, Show v) => LinExpr v n -> String
showList :: [LinExpr v n] -> ShowS
$cshowList :: forall v n. (Show n, Show v) => [LinExpr v n] -> ShowS
show :: LinExpr v n -> String
$cshow :: forall v n. (Show n, Show v) => LinExpr v n -> String
showsPrec :: Int -> LinExpr v n -> ShowS
$cshowsPrec :: forall v n. (Show n, Show v) => Int -> LinExpr v n -> ShowS
Show)
type Period v n = [(v, n)]
type Phase n = n
type Amplitude v n = LinExpr v n

-- A sum of sinewaves with the same period (a linear sum of several
-- variables), but possibly different (constant) phase.  For example
-- @(2*a+b) sin (x+y) + 2*b*sin(x+y+pi)@ would be represented by:
-- @TrigTerm [(x,1),(y,1)] [(0, LinExpr 0 [(a, 2), (b, 1)]),
-- (pi, LinExpr 0 [(b, 2)])@
type TrigTerm v n = (Period v n, [(Phase n, Amplitude v n)])

-- Any other term
data NonLinExpr v n = 
  UnaryApp UnaryOp (Expr v n) |
  MulExp (Expr v n) (Expr v n) |
  SinExp (Expr v n)
  deriving (NonLinExpr v n -> NonLinExpr v n -> Bool
(NonLinExpr v n -> NonLinExpr v n -> Bool)
-> (NonLinExpr v n -> NonLinExpr v n -> Bool)
-> Eq (NonLinExpr v n)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall v n.
(Eq v, Eq n) =>
NonLinExpr v n -> NonLinExpr v n -> Bool
/= :: NonLinExpr v n -> NonLinExpr v n -> Bool
$c/= :: forall v n.
(Eq v, Eq n) =>
NonLinExpr v n -> NonLinExpr v n -> Bool
== :: NonLinExpr v n -> NonLinExpr v n -> Bool
$c== :: forall v n.
(Eq v, Eq n) =>
NonLinExpr v n -> NonLinExpr v n -> Bool
Eq, (forall x. NonLinExpr v n -> Rep (NonLinExpr v n) x)
-> (forall x. Rep (NonLinExpr v n) x -> NonLinExpr v n)
-> Generic (NonLinExpr v n)
forall x. Rep (NonLinExpr v n) x -> NonLinExpr v n
forall x. NonLinExpr v n -> Rep (NonLinExpr v n) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall v n x. Rep (NonLinExpr v n) x -> NonLinExpr v n
forall v n x. NonLinExpr v n -> Rep (NonLinExpr v n) x
$cto :: forall v n x. Rep (NonLinExpr v n) x -> NonLinExpr v n
$cfrom :: forall v n x. NonLinExpr v n -> Rep (NonLinExpr v n) x
Generic)

-- | An angular function of the form @c + n*sin(theta + alpha)@
-- where @theta@, and @n@ are linear terms, @alpha@ and @c@ are constants.
type LinearMap v n = M.HashMap v (LinExpr v n)
type TrigEq v n = (Period v n, Amplitude v n, Phase n, n)
type TrigEq2 v n = M.HashMap (Period v n)
                   (M.HashMap v (Expr v n))

pattern $bLinearE :: LinExpr v n -> Expr v n
$mLinearE :: forall r v n. Expr v n -> (LinExpr v n -> r) -> (Void# -> r) -> r
LinearE l = Expr l [] []
pattern $bConstE :: n -> Expr v n
$mConstE :: forall r v n. Expr v n -> (n -> r) -> (Void# -> r) -> r
ConstE c = Expr (LinExpr c []) [] []
pattern $bLConst :: n -> LinExpr v n
$mLConst :: forall r v n. LinExpr v n -> (n -> r) -> (Void# -> r) -> r
LConst c = LinExpr c []

instance (Hashable v, Hashable n) => Hashable (LinExpr v n)
instance (Hashable v, Hashable n) => Hashable (NonLinExpr v n)
instance Hashable UnaryOp
instance (Hashable v, Hashable n) => Hashable (Expr v n)
instance Hashable SimpleVar

-- | A simple String wrapper, which will print formulas more cleanly.
instance Show SimpleVar where
  show :: SimpleVar -> String
show (SimpleVar String
s) = String
s

-- | This hidden datatype represents a system of equations.  It
-- contains linear dependencies on variables as well as nonlinear
-- equations. The following terminology is used from /metafont/:
-- 
--   * /known variable/: A variable who's dependency is just a number.
--   
--   * /dependend variable/: A variable which depends linearly on other variables.
--
--   * /independend variable/: any other variable.
--
-- A /dependend/ variable can only depend on other /independend/
-- variables.  Nonlinear equations will be simplified by substituting
-- and evaluating known variables, or by reducing some trigonometric
-- equations to linear equations.
data Dependencies v n = Dependencies
                        (M.HashMap v (H.HashSet v))
                        (LinearMap v n)
                        [TrigEq v n]
                        (TrigEq2 v n)
                        [Expr v n]
                        
-- | An error type for '===', '=&=' and 'addEquation':
data DepError v n =
  -- | The variable is not defined.
  UndefinedVar v |
  -- | The variable is defined but dependend an other variables.
  UnknownVar v n |
  -- | The equation was reduced to the
  -- impossible equation `a == 0` for nonzero a, which means the
  -- equation is inconsistent with previous equations.
  InconsistentEq n (Expr v n) |
  -- | The equation was reduced to the redundant equation `0 == 0`,
  -- which means it doesn't add any information.
  RedundantEq (Expr v n)
  deriving Typeable

instance (Ord n, Num n, Show v, Show n, Typeable v, Typeable n)
       => Exception (DepError v n)

instance (Ord n, Num n, Eq n, Show v, Show n) => Show (Expr v n) where
  show :: Expr v n -> String
show Expr v n
e = SimpleExpr v n -> String
forall a. Show a => a -> String
show (Expr v n -> SimpleExpr v n
forall n v. (Num n, Eq n) => Expr v n -> SimpleExpr v n
toSimple Expr v n
e)

-- | A monad transformer for solving equations.  Basicly just a state
-- and exception monad transformer over `Dependencies` and `DepError`.
newtype MFSolverT v n m a =
  MFSolverT (StateT (Dependencies v n) (ExceptT (DepError v n) m) a)
  deriving (a -> MFSolverT v n m b -> MFSolverT v n m a
(a -> b) -> MFSolverT v n m a -> MFSolverT v n m b
(forall a b. (a -> b) -> MFSolverT v n m a -> MFSolverT v n m b)
-> (forall a b. a -> MFSolverT v n m b -> MFSolverT v n m a)
-> Functor (MFSolverT v n m)
forall a b. a -> MFSolverT v n m b -> MFSolverT v n m a
forall a b. (a -> b) -> MFSolverT v n m a -> MFSolverT v n m b
forall v n (m :: * -> *) a b.
Functor m =>
a -> MFSolverT v n m b -> MFSolverT v n m a
forall v n (m :: * -> *) a b.
Functor m =>
(a -> b) -> MFSolverT v n m a -> MFSolverT v n m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> MFSolverT v n m b -> MFSolverT v n m a
$c<$ :: forall v n (m :: * -> *) a b.
Functor m =>
a -> MFSolverT v n m b -> MFSolverT v n m a
fmap :: (a -> b) -> MFSolverT v n m a -> MFSolverT v n m b
$cfmap :: forall v n (m :: * -> *) a b.
Functor m =>
(a -> b) -> MFSolverT v n m a -> MFSolverT v n m b
Functor, Functor (MFSolverT v n m)
a -> MFSolverT v n m a
Functor (MFSolverT v n m)
-> (forall a. a -> MFSolverT v n m a)
-> (forall a b.
    MFSolverT v n m (a -> b) -> MFSolverT v n m a -> MFSolverT v n m b)
-> (forall a b c.
    (a -> b -> c)
    -> MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m c)
-> (forall a b.
    MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m b)
-> (forall a b.
    MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m a)
-> Applicative (MFSolverT v n m)
MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m b
MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m a
MFSolverT v n m (a -> b) -> MFSolverT v n m a -> MFSolverT v n m b
(a -> b -> c)
-> MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m c
forall a. a -> MFSolverT v n m a
forall a b.
MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m a
forall a b.
MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m b
forall a b.
MFSolverT v n m (a -> b) -> MFSolverT v n m a -> MFSolverT v n m b
forall a b c.
(a -> b -> c)
-> MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m c
forall v n (m :: * -> *). Monad m => Functor (MFSolverT v n m)
forall v n (m :: * -> *) a. Monad m => a -> MFSolverT v n m a
forall v n (m :: * -> *) a b.
Monad m =>
MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m a
forall v n (m :: * -> *) a b.
Monad m =>
MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m b
forall v n (m :: * -> *) a b.
Monad m =>
MFSolverT v n m (a -> b) -> MFSolverT v n m a -> MFSolverT v n m b
forall v n (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m a
$c<* :: forall v n (m :: * -> *) a b.
Monad m =>
MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m a
*> :: MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m b
$c*> :: forall v n (m :: * -> *) a b.
Monad m =>
MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m b
liftA2 :: (a -> b -> c)
-> MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m c
$cliftA2 :: forall v n (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m c
<*> :: MFSolverT v n m (a -> b) -> MFSolverT v n m a -> MFSolverT v n m b
$c<*> :: forall v n (m :: * -> *) a b.
Monad m =>
MFSolverT v n m (a -> b) -> MFSolverT v n m a -> MFSolverT v n m b
pure :: a -> MFSolverT v n m a
$cpure :: forall v n (m :: * -> *) a. Monad m => a -> MFSolverT v n m a
$cp1Applicative :: forall v n (m :: * -> *). Monad m => Functor (MFSolverT v n m)
Applicative, Applicative (MFSolverT v n m)
a -> MFSolverT v n m a
Applicative (MFSolverT v n m)
-> (forall a b.
    MFSolverT v n m a -> (a -> MFSolverT v n m b) -> MFSolverT v n m b)
-> (forall a b.
    MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m b)
-> (forall a. a -> MFSolverT v n m a)
-> Monad (MFSolverT v n m)
MFSolverT v n m a -> (a -> MFSolverT v n m b) -> MFSolverT v n m b
MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m b
forall a. a -> MFSolverT v n m a
forall a b.
MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m b
forall a b.
MFSolverT v n m a -> (a -> MFSolverT v n m b) -> MFSolverT v n m b
forall v n (m :: * -> *). Monad m => Applicative (MFSolverT v n m)
forall v n (m :: * -> *) a. Monad m => a -> MFSolverT v n m a
forall v n (m :: * -> *) a b.
Monad m =>
MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m b
forall v n (m :: * -> *) a b.
Monad m =>
MFSolverT v n m a -> (a -> MFSolverT v n m b) -> MFSolverT v n m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> MFSolverT v n m a
$creturn :: forall v n (m :: * -> *) a. Monad m => a -> MFSolverT v n m a
>> :: MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m b
$c>> :: forall v n (m :: * -> *) a b.
Monad m =>
MFSolverT v n m a -> MFSolverT v n m b -> MFSolverT v n m b
>>= :: MFSolverT v n m a -> (a -> MFSolverT v n m b) -> MFSolverT v n m b
$c>>= :: forall v n (m :: * -> *) a b.
Monad m =>
MFSolverT v n m a -> (a -> MFSolverT v n m b) -> MFSolverT v n m b
$cp1Monad :: forall v n (m :: * -> *). Monad m => Applicative (MFSolverT v n m)
Monad, Monad (MFSolverT v n m)
Monad (MFSolverT v n m)
-> (forall a. IO a -> MFSolverT v n m a)
-> MonadIO (MFSolverT v n m)
IO a -> MFSolverT v n m a
forall a. IO a -> MFSolverT v n m a
forall v n (m :: * -> *). MonadIO m => Monad (MFSolverT v n m)
forall v n (m :: * -> *) a. MonadIO m => IO a -> MFSolverT v n m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> MFSolverT v n m a
$cliftIO :: forall v n (m :: * -> *) a. MonadIO m => IO a -> MFSolverT v n m a
$cp1MonadIO :: forall v n (m :: * -> *). MonadIO m => Monad (MFSolverT v n m)
MonadIO, MonadState (Dependencies v n),
             MonadError (DepError v n), MonadReader s, MonadWriter s,
             Monad (MFSolverT v n m)
Monad (MFSolverT v n m)
-> (forall a b.
    ((a -> MFSolverT v n m b) -> MFSolverT v n m a)
    -> MFSolverT v n m a)
-> MonadCont (MFSolverT v n m)
((a -> MFSolverT v n m b) -> MFSolverT v n m a)
-> MFSolverT v n m a
forall a b.
((a -> MFSolverT v n m b) -> MFSolverT v n m a)
-> MFSolverT v n m a
forall v n (m :: * -> *). MonadCont m => Monad (MFSolverT v n m)
forall v n (m :: * -> *) a b.
MonadCont m =>
((a -> MFSolverT v n m b) -> MFSolverT v n m a)
-> MFSolverT v n m a
forall (m :: * -> *).
Monad m -> (forall a b. ((a -> m b) -> m a) -> m a) -> MonadCont m
callCC :: ((a -> MFSolverT v n m b) -> MFSolverT v n m a)
-> MFSolverT v n m a
$ccallCC :: forall v n (m :: * -> *) a b.
MonadCont m =>
((a -> MFSolverT v n m b) -> MFSolverT v n m a)
-> MFSolverT v n m a
$cp1MonadCont :: forall v n (m :: * -> *). MonadCont m => Monad (MFSolverT v n m)
MonadCont)

instance MonadTrans (MFSolverT v n) where
  lift :: m a -> MFSolverT v n m a
lift = StateT (Dependencies v n) (ExceptT (DepError v n) m) a
-> MFSolverT v n m a
forall v n (m :: * -> *) a.
StateT (Dependencies v n) (ExceptT (DepError v n) m) a
-> MFSolverT v n m a
MFSolverT (StateT (Dependencies v n) (ExceptT (DepError v n) m) a
 -> MFSolverT v n m a)
-> (m a -> StateT (Dependencies v n) (ExceptT (DepError v n) m) a)
-> m a
-> MFSolverT v n m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT (DepError v n) m a
-> StateT (Dependencies v n) (ExceptT (DepError v n) m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift(ExceptT (DepError v n) m a
 -> StateT (Dependencies v n) (ExceptT (DepError v n) m) a)
-> (m a -> ExceptT (DepError v n) m a)
-> m a
-> StateT (Dependencies v n) (ExceptT (DepError v n) m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ExceptT (DepError v n) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

runSolverT :: MFSolverT v n m a -> Dependencies v n
           -> m (Either (DepError v n) (a, Dependencies v n))
runSolverT :: MFSolverT v n m a
-> Dependencies v n
-> m (Either (DepError v n) (a, Dependencies v n))
runSolverT (MFSolverT StateT (Dependencies v n) (ExceptT (DepError v n) m) a
s) = ExceptT (DepError v n) m (a, Dependencies v n)
-> m (Either (DepError v n) (a, Dependencies v n))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (DepError v n) m (a, Dependencies v n)
 -> m (Either (DepError v n) (a, Dependencies v n)))
-> (Dependencies v n
    -> ExceptT (DepError v n) m (a, Dependencies v n))
-> Dependencies v n
-> m (Either (DepError v n) (a, Dependencies v n))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT (Dependencies v n) (ExceptT (DepError v n) m) a
-> Dependencies v n
-> ExceptT (DepError v n) m (a, Dependencies v n)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT (Dependencies v n) (ExceptT (DepError v n) m) a
s 

-- | A monad for solving equations.  Basicly just a state and
-- exception monad over `Dependencies` and `DepError`.
type MFSolver v n a = MFSolverT v n Identity a

withParens :: (Show t1, Show t, Ord t1, Num t1, Eq t1) => SimpleExpr t t1
           -> [BinaryOp] -> String
withParens :: SimpleExpr t t1 -> [BinaryOp] -> String
withParens e :: SimpleExpr t t1
e@(SEBin BinaryOp
op SimpleExpr t t1
_ SimpleExpr t t1
_) [BinaryOp]
ops
  | BinaryOp
op BinaryOp -> [BinaryOp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BinaryOp]
ops = String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SimpleExpr t t1 -> String
forall a. Show a => a -> String
show SimpleExpr t t1
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
withParens SimpleExpr t t1
e [BinaryOp]
_ = SimpleExpr t t1 -> String
forall a. Show a => a -> String
show SimpleExpr t t1
e

instance (Show v, Ord n, Show n, Num n, Eq n) => Show (SimpleExpr v n) where
  show :: SimpleExpr v n -> String
show (Var v
v) = v -> String
forall a. Show a => a -> String
show v
v
  show (Const n
n) = n -> String
forall a. Show a => a -> String
show n
n
  show (SEBin BinaryOp
Add SimpleExpr v n
e1 (SEBin BinaryOp
Mul (Const n
e2) SimpleExpr v n
e3))
    | n
e2 n -> n -> Bool
forall a. Ord a => a -> a -> Bool
< n
0 =
      SimpleExpr v n -> String
forall a. Show a => a -> String
show SimpleExpr v n
e1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" - " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SimpleExpr v n -> String
forall a. Show a => a -> String
show (BinaryOp -> SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n
forall v n.
BinaryOp -> SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n
SEBin BinaryOp
Mul (n -> SimpleExpr v n
forall v n. n -> SimpleExpr v n
Const (n -> n
forall a. Num a => a -> a
negate n
e2)) SimpleExpr v n
e3)
  show (SEBin BinaryOp
Add SimpleExpr v n
e1 SimpleExpr v n
e2) =
    SimpleExpr v n -> String
forall a. Show a => a -> String
show SimpleExpr v n
e1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" + " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SimpleExpr v n -> String
forall a. Show a => a -> String
show SimpleExpr v n
e2
  show (SEBin BinaryOp
Mul (Const n
1) SimpleExpr v n
e) = SimpleExpr v n -> String
forall a. Show a => a -> String
show SimpleExpr v n
e
  show (SEBin BinaryOp
Mul SimpleExpr v n
e (Const n
1)) = SimpleExpr v n -> String
forall a. Show a => a -> String
show SimpleExpr v n
e
  show (SEBin BinaryOp
Mul SimpleExpr v n
e1 (SEUn UnaryOp
Recip SimpleExpr v n
e2)) =
    SimpleExpr v n -> [BinaryOp] -> String
forall t1 t.
(Show t1, Show t, Ord t1, Num t1, Eq t1) =>
SimpleExpr t t1 -> [BinaryOp] -> String
withParens SimpleExpr v n
e1 [BinaryOp
Add] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SimpleExpr v n -> [BinaryOp] -> String
forall t1 t.
(Show t1, Show t, Ord t1, Num t1, Eq t1) =>
SimpleExpr t t1 -> [BinaryOp] -> String
withParens SimpleExpr v n
e2 [BinaryOp
Add, BinaryOp
Mul]
  show (SEBin BinaryOp
Mul SimpleExpr v n
e1 SimpleExpr v n
e2) =
    SimpleExpr v n -> [BinaryOp] -> String
forall t1 t.
(Show t1, Show t, Ord t1, Num t1, Eq t1) =>
SimpleExpr t t1 -> [BinaryOp] -> String
withParens SimpleExpr v n
e1 [BinaryOp
Add] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"*" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SimpleExpr v n -> [BinaryOp] -> String
forall t1 t.
(Show t1, Show t, Ord t1, Num t1, Eq t1) =>
SimpleExpr t t1 -> [BinaryOp] -> String
withParens SimpleExpr v n
e2 [BinaryOp
Add]
  show (SEUn UnaryOp
Exp (SEBin BinaryOp
Mul (SEUn UnaryOp
Log SimpleExpr v n
e1) SimpleExpr v n
e2)) =
    SimpleExpr v n -> [BinaryOp] -> String
forall t1 t.
(Show t1, Show t, Ord t1, Num t1, Eq t1) =>
SimpleExpr t t1 -> [BinaryOp] -> String
withParens SimpleExpr v n
e1 [BinaryOp
Add, BinaryOp
Mul] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"**" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SimpleExpr v n -> [BinaryOp] -> String
forall t1 t.
(Show t1, Show t, Ord t1, Num t1, Eq t1) =>
SimpleExpr t t1 -> [BinaryOp] -> String
withParens SimpleExpr v n
e2 [BinaryOp
Add, BinaryOp
Mul]
  show (SEUn UnaryOp
op SimpleExpr v n
e) = UnaryOp -> String
forall a. Show a => a -> String
show UnaryOp
op String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SimpleExpr v n -> String
forall a. Show a => a -> String
show SimpleExpr v n
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

instance Show BinaryOp where
  show :: BinaryOp -> String
show BinaryOp
Add = String
"+"
  show BinaryOp
Mul = String
"*"

instance Show UnaryOp where
  show :: UnaryOp -> String
show UnaryOp
Sin = String
"sin"
  show UnaryOp
Abs = String
"abs"
  show UnaryOp
Recip = String
"1/"
  show UnaryOp
Signum = String
"sign"
  show UnaryOp
Exp = String
"exp"
  show UnaryOp
Log = String
"log"
  show UnaryOp
Cos = String
"cos"
  show UnaryOp
Cosh = String
"cosh"
  show UnaryOp
Atanh = String
"atanh"
  show UnaryOp
Tan = String
"tan"
  show UnaryOp
Tanh = String
"tanh"
  show UnaryOp
Sinh = String
"sinh"
  show UnaryOp
Asin = String
"asin"
  show UnaryOp
Acos = String
"acos"
  show UnaryOp
Asinh = String
"asinh"
  show UnaryOp
Acosh = String
"acosh"
  show UnaryOp
Atan = String
"atan"

instance (Floating n, Ord n, Ord v) => Num (Expr v n) where
  + :: Expr v n -> Expr v n -> Expr v n
(+) = Expr v n -> Expr v n -> Expr v n
forall n v.
(Ord n, Ord v, Floating n) =>
Expr v n -> Expr v n -> Expr v n
addExpr
  * :: Expr v n -> Expr v n -> Expr v n
(*) = Expr v n -> Expr v n -> Expr v n
forall n v.
(Ord n, Ord v, Floating n) =>
Expr v n -> Expr v n -> Expr v n
mulExpr
  negate :: Expr v n -> Expr v n
negate = Expr v n -> Expr v n -> Expr v n
forall n v.
(Ord n, Ord v, Floating n) =>
Expr v n -> Expr v n -> Expr v n
mulExpr (n -> Expr v n
forall v n. n -> Expr v n
ConstE (-n
1))
  abs :: Expr v n -> Expr v n
abs = UnaryOp -> Expr v n -> Expr v n
forall n v. Floating n => UnaryOp -> Expr v n -> Expr v n
unExpr UnaryOp
Abs
  signum :: Expr v n -> Expr v n
signum = UnaryOp -> Expr v n -> Expr v n
forall n v. Floating n => UnaryOp -> Expr v n -> Expr v n
unExpr UnaryOp
Signum
  fromInteger :: Integer -> Expr v n
fromInteger = n -> Expr v n
forall v n. n -> Expr v n
ConstE (n -> Expr v n) -> (Integer -> n) -> Integer -> Expr v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> n
forall a. Num a => Integer -> a
fromInteger

instance (Floating n, Ord n, Ord v) => Fractional (Expr v n) where
  recip :: Expr v n -> Expr v n
recip = UnaryOp -> Expr v n -> Expr v n
forall n v. Floating n => UnaryOp -> Expr v n -> Expr v n
unExpr UnaryOp
Recip
  fromRational :: Rational -> Expr v n
fromRational = n -> Expr v n
forall v n. n -> Expr v n
ConstE (n -> Expr v n) -> (Rational -> n) -> Rational -> Expr v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> n
forall a. Fractional a => Rational -> a
fromRational

instance (Floating n, Ord n, Ord v) => Floating (Expr v n) where
  pi :: Expr v n
pi = n -> Expr v n
forall v n. n -> Expr v n
ConstE n
forall a. Floating a => a
pi
  exp :: Expr v n -> Expr v n
exp = UnaryOp -> Expr v n -> Expr v n
forall n v. Floating n => UnaryOp -> Expr v n -> Expr v n
unExpr UnaryOp
Exp
  log :: Expr v n -> Expr v n
log = UnaryOp -> Expr v n -> Expr v n
forall n v. Floating n => UnaryOp -> Expr v n -> Expr v n
unExpr UnaryOp
Log
  sin :: Expr v n -> Expr v n
sin = Expr v n -> Expr v n
forall n v. Floating n => Expr v n -> Expr v n
sinExpr
  cos :: Expr v n -> Expr v n
cos Expr v n
a = Expr v n -> Expr v n
forall n v. Floating n => Expr v n -> Expr v n
sinExpr (Expr v n
a Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
+ n -> Expr v n
forall v n. n -> Expr v n
ConstE (n
forall a. Floating a => a
pin -> n -> n
forall a. Fractional a => a -> a -> a
/n
2))
  cosh :: Expr v n -> Expr v n
cosh = UnaryOp -> Expr v n -> Expr v n
forall n v. Floating n => UnaryOp -> Expr v n -> Expr v n
unExpr UnaryOp
Cosh
  atanh :: Expr v n -> Expr v n
atanh = UnaryOp -> Expr v n -> Expr v n
forall n v. Floating n => UnaryOp -> Expr v n -> Expr v n
unExpr UnaryOp
Atanh
  tan :: Expr v n -> Expr v n
tan = UnaryOp -> Expr v n -> Expr v n
forall n v. Floating n => UnaryOp -> Expr v n -> Expr v n
unExpr UnaryOp
Tan
  tanh :: Expr v n -> Expr v n
tanh = UnaryOp -> Expr v n -> Expr v n
forall n v. Floating n => UnaryOp -> Expr v n -> Expr v n
unExpr UnaryOp
Tanh
  sinh :: Expr v n -> Expr v n
sinh = UnaryOp -> Expr v n -> Expr v n
forall n v. Floating n => UnaryOp -> Expr v n -> Expr v n
unExpr UnaryOp
Sinh
  asin :: Expr v n -> Expr v n
asin = UnaryOp -> Expr v n -> Expr v n
forall n v. Floating n => UnaryOp -> Expr v n -> Expr v n
unExpr UnaryOp
Asin
  acos :: Expr v n -> Expr v n
acos = UnaryOp -> Expr v n -> Expr v n
forall n v. Floating n => UnaryOp -> Expr v n -> Expr v n
unExpr UnaryOp
Acos
  asinh :: Expr v n -> Expr v n
asinh = UnaryOp -> Expr v n -> Expr v n
forall n v. Floating n => UnaryOp -> Expr v n -> Expr v n
unExpr UnaryOp
Asinh
  acosh :: Expr v n -> Expr v n
acosh = UnaryOp -> Expr v n -> Expr v n
forall n v. Floating n => UnaryOp -> Expr v n -> Expr v n
unExpr UnaryOp
Acosh
  atan :: Expr v n -> Expr v n
atan = UnaryOp -> Expr v n -> Expr v n
forall n v. Floating n => UnaryOp -> Expr v n -> Expr v n
unExpr UnaryOp
Atan

instance (Show n, Floating n, Ord n, Ord v, Show v)
    => Show (Dependencies v n) where
  show :: Dependencies v n -> String
show dep :: Dependencies v n
dep@(Dependencies HashMap v (HashSet v)
_ LinearMap v n
lin [TrigEq v n]
_ TrigEq2 v n
_ [Expr v n]
_) = 
    [String] -> String
unlines (((v, LinExpr v n) -> String) -> [(v, LinExpr v n)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (v, LinExpr v n) -> String
forall n a v.
(Ord n, Num n, Show a, Show v, Show n) =>
(a, LinExpr v n) -> String
showLin (LinearMap v n -> [(v, LinExpr v n)]
forall k v. HashMap k v -> [(k, v)]
M.toList LinearMap v n
lin) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
             (Expr v n -> String) -> [Expr v n] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Expr v n -> String
forall a. Show a => a -> String
showNl (Dependencies v n -> [Expr v n]
forall n v.
(Ord n, Ord v, Floating n) =>
Dependencies v n -> [Expr v n]
nonlinearEqs Dependencies v n
dep))
    where showLin :: (a, LinExpr v n) -> String
showLin (a
v, LinExpr v n
e) = a -> String
forall a. Show a => a -> String
show a
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr v n -> String
forall a. Show a => a -> String
show (LinExpr v n -> Expr v n
forall v n. LinExpr v n -> Expr v n
LinearE LinExpr v n
e)
          showNl :: a -> String
showNl a
e = a -> String
forall a. Show a => a -> String
show a
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" = 0"

instance (Num n, Ord n, Show n, Show v) => Show (DepError v n) where
  show :: DepError v n -> String
show (InconsistentEq n
a Expr v n
e) =
    String
"Inconsistent equations, off by " String -> ShowS
forall a. [a] -> [a] -> [a]
++ n -> String
forall a. Show a => a -> String
show n
a String -> ShowS
forall a. [a] -> [a] -> [a]
++
    String
".  original expression: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr v n -> String
forall a. Show a => a -> String
show Expr v n
e
  show (RedundantEq Expr v n
e) =
    String
"Redundant Equation: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr v n -> String
forall a. Show a => a -> String
show Expr v n
e
  show (UndefinedVar v
v) =
    ShowS
forall a. HasCallStack => String -> a
error (String
"Variable is undefined: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ v -> String
forall a. Show a => a -> String
show v
v)
  show (UnknownVar v
v n
n) =
    ShowS
forall a. HasCallStack => String -> a
error (String
"Value of variable not known: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ v -> String
forall a. Show a => a -> String
show v
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ n -> String
forall a. Show a => a -> String
show n
n)

addSimple :: (Num t1, Eq t1) => SimpleExpr t t1 -> SimpleExpr t t1 -> SimpleExpr t t1
addSimple :: SimpleExpr t t1 -> SimpleExpr t t1 -> SimpleExpr t t1
addSimple (Const t1
0) SimpleExpr t t1
e = SimpleExpr t t1
e
addSimple SimpleExpr t t1
e (Const t1
0) = SimpleExpr t t1
e
addSimple SimpleExpr t t1
e1 SimpleExpr t t1
e2 = BinaryOp -> SimpleExpr t t1 -> SimpleExpr t t1 -> SimpleExpr t t1
forall v n.
BinaryOp -> SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n
SEBin BinaryOp
Add SimpleExpr t t1
e1 SimpleExpr t t1
e2

seHasVar :: Eq v => v -> SimpleExpr v t -> Bool
seHasVar :: v -> SimpleExpr v t -> Bool
seHasVar v
v1 (Var v
v2) = v
v1 v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v2
seHasVar v
_ (Const t
_) = Bool
False
seHasVar v
v (SEBin BinaryOp
_ SimpleExpr v t
e1 SimpleExpr v t
e2) =
  v -> SimpleExpr v t -> Bool
forall v t. Eq v => v -> SimpleExpr v t -> Bool
seHasVar v
v SimpleExpr v t
e1 Bool -> Bool -> Bool
||
  v -> SimpleExpr v t -> Bool
forall v t. Eq v => v -> SimpleExpr v t -> Bool
seHasVar v
v SimpleExpr v t
e2
seHasVar v
v (SEUn UnaryOp
_ SimpleExpr v t
e) = v -> SimpleExpr v t -> Bool
forall v t. Eq v => v -> SimpleExpr v t -> Bool
seHasVar v
v SimpleExpr v t
e

-- | The expression contains the given variable.
hasVar :: (Num t, Eq v, Eq t) => v -> Expr v t -> Bool
hasVar :: v -> Expr v t -> Bool
hasVar v
v = v -> SimpleExpr v t -> Bool
forall v t. Eq v => v -> SimpleExpr v t -> Bool
seHasVar v
v (SimpleExpr v t -> Bool)
-> (Expr v t -> SimpleExpr v t) -> Expr v t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr v t -> SimpleExpr v t
forall n v. (Num n, Eq n) => Expr v n -> SimpleExpr v n
toSimple

linToSimple :: (Num n, Eq n) => LinExpr v n -> SimpleExpr v n
linToSimple :: LinExpr v n -> SimpleExpr v n
linToSimple (LinExpr n
v [(v, n)]
t) =
  n -> SimpleExpr v n
forall v n. n -> SimpleExpr v n
Const n
v SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n
forall t1 t.
(Num t1, Eq t1) =>
SimpleExpr t t1 -> SimpleExpr t t1 -> SimpleExpr t t1
`addSimple`
  ((v, n) -> SimpleExpr v n -> SimpleExpr v n)
-> SimpleExpr v n -> [(v, n)] -> SimpleExpr v n
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n
forall t1 t.
(Num t1, Eq t1) =>
SimpleExpr t t1 -> SimpleExpr t t1 -> SimpleExpr t t1
addSimple(SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n)
-> ((v, n) -> SimpleExpr v n)
-> (v, n)
-> SimpleExpr v n
-> SimpleExpr v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(v, n) -> SimpleExpr v n
forall n v. (Eq n, Num n) => (v, n) -> SimpleExpr v n
mul) (n -> SimpleExpr v n
forall v n. n -> SimpleExpr v n
Const n
0) [(v, n)]
t
  where
    mul :: (v, n) -> SimpleExpr v n
mul (v
v2, n
1) = v -> SimpleExpr v n
forall v n. v -> SimpleExpr v n
Var v
v2
    mul (v
v2, n
c) = BinaryOp -> SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n
forall v n.
BinaryOp -> SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n
SEBin BinaryOp
Mul (n -> SimpleExpr v n
forall v n. n -> SimpleExpr v n
Const n
c) (v -> SimpleExpr v n
forall v n. v -> SimpleExpr v n
Var v
v2)

   
trigToSimple :: (Num n, Eq n) => TrigTerm v n -> SimpleExpr v n
trigToSimple :: TrigTerm v n -> SimpleExpr v n
trigToSimple (Period v n
theta, [(n, Amplitude v n)]
t) =
  ((n, Amplitude v n) -> SimpleExpr v n -> SimpleExpr v n)
-> SimpleExpr v n -> [(n, Amplitude v n)] -> SimpleExpr v n
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n
forall t1 t.
(Num t1, Eq t1) =>
SimpleExpr t t1 -> SimpleExpr t t1 -> SimpleExpr t t1
addSimple(SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n)
-> ((n, Amplitude v n) -> SimpleExpr v n)
-> (n, Amplitude v n)
-> SimpleExpr v n
-> SimpleExpr v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(n, Amplitude v n) -> SimpleExpr v n
makeSin) (n -> SimpleExpr v n
forall v n. n -> SimpleExpr v n
Const n
0) [(n, Amplitude v n)]
t
  where
    makeSin :: (n, Amplitude v n) -> SimpleExpr v n
makeSin (n
alpha, Amplitude v n
n) =
      BinaryOp -> SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n
forall v n.
BinaryOp -> SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n
SEBin BinaryOp
Mul (Amplitude v n -> SimpleExpr v n
forall n v. (Num n, Eq n) => LinExpr v n -> SimpleExpr v n
linToSimple Amplitude v n
n)
      (UnaryOp -> SimpleExpr v n -> SimpleExpr v n
forall v n. UnaryOp -> SimpleExpr v n -> SimpleExpr v n
SEUn UnaryOp
Sin SimpleExpr v n
angle) where
        angle :: SimpleExpr v n
angle = Amplitude v n -> SimpleExpr v n
forall n v. (Num n, Eq n) => LinExpr v n -> SimpleExpr v n
linToSimple (n -> Period v n -> Amplitude v n
forall v n. n -> [(v, n)] -> LinExpr v n
LinExpr n
alpha Period v n
theta)

nonlinToSimple :: (Num n, Eq n) => NonLinExpr v n -> SimpleExpr v n
nonlinToSimple :: NonLinExpr v n -> SimpleExpr v n
nonlinToSimple (UnaryApp UnaryOp
o Expr v n
e) =
  UnaryOp -> SimpleExpr v n -> SimpleExpr v n
forall v n. UnaryOp -> SimpleExpr v n -> SimpleExpr v n
SEUn UnaryOp
o (Expr v n -> SimpleExpr v n
forall n v. (Num n, Eq n) => Expr v n -> SimpleExpr v n
toSimple Expr v n
e)
nonlinToSimple (MulExp Expr v n
e1 Expr v n
e2) =
  BinaryOp -> SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n
forall v n.
BinaryOp -> SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n
SEBin BinaryOp
Mul (Expr v n -> SimpleExpr v n
forall n v. (Num n, Eq n) => Expr v n -> SimpleExpr v n
toSimple Expr v n
e1) (Expr v n -> SimpleExpr v n
forall n v. (Num n, Eq n) => Expr v n -> SimpleExpr v n
toSimple Expr v n
e2)
nonlinToSimple (SinExp Expr v n
e) =
  UnaryOp -> SimpleExpr v n -> SimpleExpr v n
forall v n. UnaryOp -> SimpleExpr v n -> SimpleExpr v n
SEUn UnaryOp
Sin (Expr v n -> SimpleExpr v n
forall n v. (Num n, Eq n) => Expr v n -> SimpleExpr v n
toSimple Expr v n
e)

-- | Convert an `Expr` to a `SimpleExpr`.
toSimple :: (Num n, Eq n) => Expr v n -> SimpleExpr v n
toSimple :: Expr v n -> SimpleExpr v n
toSimple (Expr LinExpr v n
lin [TrigTerm v n]
trig [NonLinExpr v n]
nonlin) =
  LinExpr v n -> SimpleExpr v n
forall n v. (Num n, Eq n) => LinExpr v n -> SimpleExpr v n
linToSimple LinExpr v n
lin SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n
forall t1 t.
(Num t1, Eq t1) =>
SimpleExpr t t1 -> SimpleExpr t t1 -> SimpleExpr t t1
`addSimple`
  (TrigTerm v n -> SimpleExpr v n -> SimpleExpr v n)
-> SimpleExpr v n -> [TrigTerm v n] -> SimpleExpr v n
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n
forall t1 t.
(Num t1, Eq t1) =>
SimpleExpr t t1 -> SimpleExpr t t1 -> SimpleExpr t t1
addSimple(SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n)
-> (TrigTerm v n -> SimpleExpr v n)
-> TrigTerm v n
-> SimpleExpr v n
-> SimpleExpr v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
.TrigTerm v n -> SimpleExpr v n
forall n v. (Num n, Eq n) => TrigTerm v n -> SimpleExpr v n
trigToSimple)
  (n -> SimpleExpr v n
forall v n. n -> SimpleExpr v n
Const n
0) [TrigTerm v n]
trig SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n
forall t1 t.
(Num t1, Eq t1) =>
SimpleExpr t t1 -> SimpleExpr t t1 -> SimpleExpr t t1
`addSimple`
  (NonLinExpr v n -> SimpleExpr v n -> SimpleExpr v n)
-> SimpleExpr v n -> [NonLinExpr v n] -> SimpleExpr v n
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n
forall t1 t.
(Num t1, Eq t1) =>
SimpleExpr t t1 -> SimpleExpr t t1 -> SimpleExpr t t1
addSimple(SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n)
-> (NonLinExpr v n -> SimpleExpr v n)
-> NonLinExpr v n
-> SimpleExpr v n
-> SimpleExpr v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
.NonLinExpr v n -> SimpleExpr v n
forall n v. (Num n, Eq n) => NonLinExpr v n -> SimpleExpr v n
nonlinToSimple)
  (n -> SimpleExpr v n
forall v n. n -> SimpleExpr v n
Const n
0) [NonLinExpr v n]
nonlin

evalBin :: (Floating n) => BinaryOp -> n -> n -> n
evalBin :: BinaryOp -> n -> n -> n
evalBin BinaryOp
Add = n -> n -> n
forall a. Num a => a -> a -> a
(+)
evalBin BinaryOp
Mul = n -> n -> n
forall a. Num a => a -> a -> a
(*)

evalUn :: (Floating n) => UnaryOp -> n -> n
evalUn :: UnaryOp -> n -> n
evalUn UnaryOp
Sin = n -> n
forall a. Floating a => a -> a
sin
evalUn UnaryOp
Abs = n -> n
forall a. Num a => a -> a
abs
evalUn UnaryOp
Recip = n -> n
forall a. Fractional a => a -> a
recip
evalUn UnaryOp
Signum = n -> n
forall a. Num a => a -> a
signum
evalUn UnaryOp
Exp = n -> n
forall a. Floating a => a -> a
exp
evalUn UnaryOp
Log = n -> n
forall a. Floating a => a -> a
log
evalUn UnaryOp
Cos = n -> n
forall a. Floating a => a -> a
cos
evalUn UnaryOp
Cosh = n -> n
forall a. Floating a => a -> a
cosh
evalUn UnaryOp
Atanh = n -> n
forall a. Floating a => a -> a
atanh
evalUn UnaryOp
Tan = n -> n
forall a. Floating a => a -> a
tan
evalUn UnaryOp
Tanh = n -> n
forall a. Floating a => a -> a
tanh
evalUn UnaryOp
Sinh = n -> n
forall a. Floating a => a -> a
sinh
evalUn UnaryOp
Asin = n -> n
forall a. Floating a => a -> a
asin
evalUn UnaryOp
Acos = n -> n
forall a. Floating a => a -> a
acos
evalUn UnaryOp
Asinh = n -> n
forall a. Floating a => a -> a
asinh
evalUn UnaryOp
Acosh = n -> n
forall a. Floating a => a -> a
acosh
evalUn UnaryOp
Atan = n -> n
forall a. Floating a => a -> a
atan

-- | evaluate a simple expression using the given substitution.
evalSimple :: Floating m => (n -> m) -> (v -> m) -> SimpleExpr v n -> m
evalSimple :: (n -> m) -> (v -> m) -> SimpleExpr v n -> m
evalSimple n -> m
_ v -> m
s (Var v
v) = v -> m
s v
v
evalSimple n -> m
g v -> m
_ (Const n
c) = n -> m
g n
c
evalSimple n -> m
g v -> m
s (SEBin BinaryOp
f SimpleExpr v n
e1 SimpleExpr v n
e2) =
  BinaryOp -> m -> m -> m
forall n. Floating n => BinaryOp -> n -> n -> n
evalBin BinaryOp
f ((n -> m) -> (v -> m) -> SimpleExpr v n -> m
forall m n v.
Floating m =>
(n -> m) -> (v -> m) -> SimpleExpr v n -> m
evalSimple n -> m
g v -> m
s SimpleExpr v n
e1) ((n -> m) -> (v -> m) -> SimpleExpr v n -> m
forall m n v.
Floating m =>
(n -> m) -> (v -> m) -> SimpleExpr v n -> m
evalSimple n -> m
g v -> m
s SimpleExpr v n
e2)
evalSimple n -> m
g v -> m
s (SEUn UnaryOp
f SimpleExpr v n
e) =
  UnaryOp -> m -> m
forall n. Floating n => UnaryOp -> n -> n
evalUn UnaryOp
f ((n -> m) -> (v -> m) -> SimpleExpr v n -> m
forall m n v.
Floating m =>
(n -> m) -> (v -> m) -> SimpleExpr v n -> m
evalSimple n -> m
g v -> m
s SimpleExpr v n
e)

-- | map a simple expression using the given substitution.
mapSimple :: (Floating m, Floating n) => (n -> m) -> (v -> u) -> SimpleExpr v n
          -> SimpleExpr u m
mapSimple :: (n -> m) -> (v -> u) -> SimpleExpr v n -> SimpleExpr u m
mapSimple n -> m
_ v -> u
g (Var v
v) = u -> SimpleExpr u m
forall v n. v -> SimpleExpr v n
Var (v -> u
g v
v)
mapSimple n -> m
f v -> u
_ (Const n
c) = m -> SimpleExpr u m
forall v n. n -> SimpleExpr v n
Const (n -> m
f n
c)
mapSimple n -> m
f v -> u
g (SEBin BinaryOp
h SimpleExpr v n
e1 SimpleExpr v n
e2) =
  BinaryOp -> SimpleExpr u m -> SimpleExpr u m -> SimpleExpr u m
forall v n.
BinaryOp -> SimpleExpr v n -> SimpleExpr v n -> SimpleExpr v n
SEBin BinaryOp
h ((n -> m) -> (v -> u) -> SimpleExpr v n -> SimpleExpr u m
forall m n v u.
(Floating m, Floating n) =>
(n -> m) -> (v -> u) -> SimpleExpr v n -> SimpleExpr u m
mapSimple n -> m
f v -> u
g SimpleExpr v n
e1) ((n -> m) -> (v -> u) -> SimpleExpr v n -> SimpleExpr u m
forall m n v u.
(Floating m, Floating n) =>
(n -> m) -> (v -> u) -> SimpleExpr v n -> SimpleExpr u m
mapSimple n -> m
f v -> u
g SimpleExpr v n
e2)
mapSimple n -> m
f v -> u
g (SEUn UnaryOp
h SimpleExpr v n
e) =
  UnaryOp -> SimpleExpr u m -> SimpleExpr u m
forall v n. UnaryOp -> SimpleExpr v n -> SimpleExpr v n
SEUn UnaryOp
h ((n -> m) -> (v -> u) -> SimpleExpr v n -> SimpleExpr u m
forall m n v u.
(Floating m, Floating n) =>
(n -> m) -> (v -> u) -> SimpleExpr v n -> SimpleExpr u m
mapSimple n -> m
f v -> u
g SimpleExpr v n
e)

-- | map an expression using the given substitution.
mapExpr :: (Floating m, Floating n, Ord u, Ord v, Eq n, Ord m) =>
           (n -> m) -> (v -> u) -> Expr v n -> Expr u m
mapExpr :: (n -> m) -> (v -> u) -> Expr v n -> Expr u m
mapExpr n -> m
f v -> u
g = SimpleExpr u m -> Expr u m
forall n v.
(Floating n, Ord n, Ord v) =>
SimpleExpr v n -> Expr v n
fromSimple (SimpleExpr u m -> Expr u m)
-> (Expr v n -> SimpleExpr u m) -> Expr v n -> Expr u m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> m) -> (v -> u) -> SimpleExpr v n -> SimpleExpr u m
forall m n v u.
(Floating m, Floating n) =>
(n -> m) -> (v -> u) -> SimpleExpr v n -> SimpleExpr u m
mapSimple n -> m
f v -> u
g (SimpleExpr v n -> SimpleExpr u m)
-> (Expr v n -> SimpleExpr v n) -> Expr v n -> SimpleExpr u m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr v n -> SimpleExpr v n
forall n v. (Num n, Eq n) => Expr v n -> SimpleExpr v n
toSimple

-- | Make a expression from a simple expression.
fromSimple :: (Floating n, Ord n, Ord v) => SimpleExpr v n -> Expr v n
fromSimple :: SimpleExpr v n -> Expr v n
fromSimple = (n -> Expr v n) -> (v -> Expr v n) -> SimpleExpr v n -> Expr v n
forall m n v.
Floating m =>
(n -> m) -> (v -> m) -> SimpleExpr v n -> m
evalSimple n -> Expr v n
forall n v. n -> Expr v n
makeConstant v -> Expr v n
forall n v. Num n => v -> Expr v n
makeVariable

-- | Evaluate the expression given a variable substitution.
evalExpr :: (Floating n) => (v -> n) -> SimpleExpr v n -> n
evalExpr :: (v -> n) -> SimpleExpr v n -> n
evalExpr = (n -> n) -> (v -> n) -> SimpleExpr v n -> n
forall m n v.
Floating m =>
(n -> m) -> (v -> m) -> SimpleExpr v n -> m
evalSimple n -> n
forall a. a -> a
id

zeroTerm :: (Num n) => LinExpr v n
zeroTerm :: LinExpr v n
zeroTerm = n -> LinExpr v n
forall v n. n -> LinExpr v n
LConst n
0

zeroExpr :: (Num n) => Expr v n
zeroExpr :: Expr v n
zeroExpr = n -> Expr v n
forall n v. n -> Expr v n
makeConstant n
0

-- | Create an expression from a constant
makeConstant :: n -> Expr v n
makeConstant :: n -> Expr v n
makeConstant = n -> Expr v n
forall v n. n -> Expr v n
ConstE

-- | Create an expression from a variable
makeVariable :: Num n => v -> Expr v n
makeVariable :: v -> Expr v n
makeVariable v
v = LinExpr v n -> Expr v n
forall v n. LinExpr v n -> Expr v n
LinearE (LinExpr v n -> Expr v n) -> LinExpr v n -> Expr v n
forall a b. (a -> b) -> a -> b
$ n -> [(v, n)] -> LinExpr v n
forall v n. n -> [(v, n)] -> LinExpr v n
LinExpr n
0 [(v
v, n
1)]

trigExpr :: (Num n) => [TrigTerm v n] -> Expr v n
trigExpr :: [TrigTerm v n] -> Expr v n
trigExpr [TrigTerm v n]
t = LinExpr v n -> [TrigTerm v n] -> [NonLinExpr v n] -> Expr v n
forall v n.
LinExpr v n -> [TrigTerm v n] -> [NonLinExpr v n] -> Expr v n
Expr LinExpr v n
forall n v. Num n => LinExpr v n
zeroTerm [TrigTerm v n]
t []

nonlinExpr :: Num n => [NonLinExpr v n] -> Expr v n
nonlinExpr :: [NonLinExpr v n] -> Expr v n
nonlinExpr = LinExpr v n -> [TrigTerm v n] -> [NonLinExpr v n] -> Expr v n
forall v n.
LinExpr v n -> [TrigTerm v n] -> [NonLinExpr v n] -> Expr v n
Expr LinExpr v n
forall n v. Num n => LinExpr v n
zeroTerm []

isConst :: LinExpr v n -> Bool
isConst :: LinExpr v n -> Bool
isConst (LConst n
_) = Bool
True
isConst LinExpr v n
_ = Bool
False

linVars :: LinExpr v n -> [v]
linVars :: LinExpr v n -> [v]
linVars (LinExpr n
_ [(v, n)]
v) = ((v, n) -> v) -> [(v, n)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (v, n) -> v
forall a b. (a, b) -> a
fst [(v, n)]
v

addLin :: (Ord v, Num n, Eq n) => LinExpr v n -> LinExpr v n -> LinExpr v n
addLin :: LinExpr v n -> LinExpr v n -> LinExpr v n
addLin (LinExpr n
c1 [(v, n)]
terms1) (LinExpr n
c2 [(v, n)]
terms2) =
  n -> [(v, n)] -> LinExpr v n
forall v n. n -> [(v, n)] -> LinExpr v n
LinExpr (n
c1n -> n -> n
forall a. Num a => a -> a -> a
+n
c2) [(v, n)]
terms3 where
    terms3 :: [(v, n)]
terms3 = ((v, n) -> Bool) -> [(v, n)] -> [(v, n)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((n -> n -> Bool
forall a. Eq a => a -> a -> Bool
/= n
0) (n -> Bool) -> ((v, n) -> n) -> (v, n) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v, n) -> n
forall a b. (a, b) -> b
snd) ([(v, n)] -> [(v, n)]) -> [(v, n)] -> [(v, n)]
forall a b. (a -> b) -> a -> b
$
             [(v, n)] -> [(v, n)] -> (n -> n -> n) -> [(v, n)]
forall k v.
Ord k =>
[(k, v)] -> [(k, v)] -> (v -> v -> v) -> [(k, v)]
merge [(v, n)]
terms1 [(v, n)]
terms2 n -> n -> n
forall a. Num a => a -> a -> a
(+)

addExpr :: (Ord n, Ord v, Floating n) => Expr v n -> Expr v n -> Expr v n
addExpr :: Expr v n -> Expr v n -> Expr v n
addExpr (Expr LinExpr v n
lt1 [TrigTerm v n]
trig1 [NonLinExpr v n]
nl1) (Expr LinExpr v n
lt2 [TrigTerm v n]
trig2 [NonLinExpr v n]
nl2) =
  LinExpr v n -> [TrigTerm v n] -> [NonLinExpr v n] -> Expr v n
forall v n.
LinExpr v n -> [TrigTerm v n] -> [NonLinExpr v n] -> Expr v n
Expr (LinExpr v n -> LinExpr v n -> LinExpr v n
forall v n.
(Ord v, Num n, Eq n) =>
LinExpr v n -> LinExpr v n -> LinExpr v n
addLin LinExpr v n
lt1 LinExpr v n
lt2) [TrigTerm v n]
trig3 ([NonLinExpr v n]
nl1[NonLinExpr v n] -> [NonLinExpr v n] -> [NonLinExpr v n]
forall a. [a] -> [a] -> [a]
++[NonLinExpr v n]
nl2)
  where
    trig3 :: [TrigTerm v n]
trig3 = [TrigTerm v n]
-> [TrigTerm v n]
-> ([(n, LinExpr v n)] -> [(n, LinExpr v n)] -> [(n, LinExpr v n)])
-> [TrigTerm v n]
forall k v.
Ord k =>
[(k, v)] -> [(k, v)] -> (v -> v -> v) -> [(k, v)]
merge [TrigTerm v n]
trig1 [TrigTerm v n]
trig2 [(n, LinExpr v n)] -> [(n, LinExpr v n)] -> [(n, LinExpr v n)]
forall a t.
(Ord a, Ord t, Floating a) =>
[(a, LinExpr t a)] -> [(a, LinExpr t a)] -> [(a, LinExpr t a)]
addTrigTerms

-- merge two association lists, by combining equal keys with
-- the given function, and keeping keys sorted.
merge :: Ord k => [(k, v)] -> [(k, v)] -> (v -> v -> v) -> [(k, v)]
merge :: [(k, v)] -> [(k, v)] -> (v -> v -> v) -> [(k, v)]
merge [] [(k, v)]
l v -> v -> v
_ = [(k, v)]
l
merge [(k, v)]
l [] v -> v -> v
_ = [(k, v)]
l
merge (a :: (k, v)
a@(k
k,v
v):[(k, v)]
as) (b :: (k, v)
b@(k
k2,v
v2):[(k, v)]
bs) v -> v -> v
f = case k -> k -> Ordering
forall a. Ord a => a -> a -> Ordering
compare k
k k
k2 of
  Ordering
LT -> (k, v)
a(k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
: [(k, v)] -> [(k, v)] -> (v -> v -> v) -> [(k, v)]
forall k v.
Ord k =>
[(k, v)] -> [(k, v)] -> (v -> v -> v) -> [(k, v)]
merge [(k, v)]
as ((k, v)
b(k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
:[(k, v)]
bs) v -> v -> v
f
  Ordering
EQ -> (k
k, v -> v -> v
f v
v v
v2)(k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
: [(k, v)] -> [(k, v)] -> (v -> v -> v) -> [(k, v)]
forall k v.
Ord k =>
[(k, v)] -> [(k, v)] -> (v -> v -> v) -> [(k, v)]
merge [(k, v)]
as [(k, v)]
bs v -> v -> v
f
  Ordering
GT -> (k, v)
b(k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
: [(k, v)] -> [(k, v)] -> (v -> v -> v) -> [(k, v)]
forall k v.
Ord k =>
[(k, v)] -> [(k, v)] -> (v -> v -> v) -> [(k, v)]
merge ((k, v)
a(k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
:[(k, v)]
as) [(k, v)]
bs v -> v -> v
f

-- add trigonometric terms with the same period
addTrigTerms :: (Ord a, Ord t, Floating a)
             => [(a, LinExpr t a)] -> [(a, LinExpr t a)]
             -> [(a, LinExpr t a)]
addTrigTerms :: [(a, LinExpr t a)] -> [(a, LinExpr t a)] -> [(a, LinExpr t a)]
addTrigTerms [] [(a, LinExpr t a)]
p = [(a, LinExpr t a)]
p
addTrigTerms [(a, LinExpr t a)]
terms [(a, LinExpr t a)]
terms2 =
  ((a, LinExpr t a) -> [(a, LinExpr t a)] -> [(a, LinExpr t a)])
-> [(a, LinExpr t a)] -> [(a, LinExpr t a)] -> [(a, LinExpr t a)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a, LinExpr t a) -> [(a, LinExpr t a)] -> [(a, LinExpr t a)]
forall a v.
(Ord a, Ord v, Floating a) =>
(a, LinExpr v a) -> [(a, LinExpr v a)] -> [(a, LinExpr v a)]
mergeTerms [(a, LinExpr t a)]
terms [(a, LinExpr t a)]
terms2
  where
    mergeTerms :: (a, LinExpr v a) -> [(a, LinExpr v a)] -> [(a, LinExpr v a)]
mergeTerms (a
alpha, LinExpr v a
n) ((a
beta, LinExpr v a
m):[(a, LinExpr v a)]
rest) =
      case a -> LinExpr v a -> a -> LinExpr v a -> Maybe (a, LinExpr v a)
forall a t.
(Ord a, Ord t, Floating a) =>
a -> LinExpr t a -> a -> LinExpr t a -> Maybe (a, LinExpr t a)
addTrigTerm a
alpha LinExpr v a
n a
beta LinExpr v a
m of
       Just (a
_, LConst a
0) -> [(a, LinExpr v a)]
rest
       Just (a
gamma, LinExpr v a
o) ->
         (a, LinExpr v a) -> [(a, LinExpr v a)] -> [(a, LinExpr v a)]
mergeTerms (a
gamma, LinExpr v a
o) [(a, LinExpr v a)]
rest
       Maybe (a, LinExpr v a)
Nothing ->
         (a
beta, LinExpr v a
m) (a, LinExpr v a) -> [(a, LinExpr v a)] -> [(a, LinExpr v a)]
forall a. a -> [a] -> [a]
: (a, LinExpr v a) -> [(a, LinExpr v a)] -> [(a, LinExpr v a)]
mergeTerms (a
alpha, LinExpr v a
n) [(a, LinExpr v a)]
rest
    mergeTerms (a, LinExpr v a)
a [] = [(a, LinExpr v a)
a]

addTrigTerm :: (Ord a, Ord t, Floating a)
            => a -> LinExpr t a -> a -> LinExpr t a -> Maybe (a, LinExpr t a)
addTrigTerm :: a -> LinExpr t a -> a -> LinExpr t a -> Maybe (a, LinExpr t a)
addTrigTerm a
alpha LinExpr t a
n a
beta LinExpr t a
m
  | a
alpha a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
beta =
    (a, LinExpr t a) -> Maybe (a, LinExpr t a)
forall a. a -> Maybe a
Just (a
alpha, LinExpr t a -> LinExpr t a -> LinExpr t a
forall v n.
(Ord v, Num n, Eq n) =>
LinExpr v n -> LinExpr v n -> LinExpr v n
addLin LinExpr t a
n LinExpr t a
m)
  | Just a
r <- LinExpr t a -> LinExpr t a -> Maybe a
forall a t.
(Ord a, Fractional a, Eq t) =>
LinExpr t a -> LinExpr t a -> Maybe a
termIsMultiple LinExpr t a
n LinExpr t a
m =
      let gamma :: a
gamma = a -> a
forall a. Floating a => a -> a
atan (a
dividenta -> a -> a
forall a. Fractional a => a -> a -> a
/a
divisor) a -> a -> a
forall a. Num a => a -> a -> a
+
                  (if a
divisor a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 then a
forall a. Floating a => a
pi else a
0)
          divident :: a
divident = a
ra -> a -> a
forall a. Num a => a -> a -> a
*a -> a
forall a. Floating a => a -> a
sin a
alpha a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a
forall a. Floating a => a -> a
sin a
beta
          divisor :: a
divisor = a
ra -> a -> a
forall a. Num a => a -> a -> a
*a -> a
forall a. Floating a => a -> a
cos a
alpha a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a
forall a. Floating a => a -> a
cos a
beta
          o :: a
o = a -> a
forall a. Floating a => a -> a
sqrt(a
dividenta -> a -> a
forall a. Num a => a -> a -> a
*a
divident a -> a -> a
forall a. Num a => a -> a -> a
+ a
divisora -> a -> a
forall a. Num a => a -> a -> a
*a
divisor)
      in (a, LinExpr t a) -> Maybe (a, LinExpr t a)
forall a. a -> Maybe a
Just (a
gamma, a -> LinExpr t a -> LinExpr t a
forall n v. Num n => n -> LinExpr v n -> LinExpr v n
mulLinExpr a
o LinExpr t a
m)
  | Bool
otherwise = Maybe (a, LinExpr t a)
forall a. Maybe a
Nothing

-- compare if the linear term is a multiple of the other, within roundoff                
termIsMultiple :: (Ord a, Fractional a, Eq t)
               => LinExpr t a -> LinExpr t a -> Maybe a
termIsMultiple :: LinExpr t a -> LinExpr t a -> Maybe a
termIsMultiple (LinExpr a
_ [(t, a)]
_) (LinExpr a
0 []) = Maybe a
forall a. Maybe a
Nothing
termIsMultiple (LinExpr a
0 []) (LinExpr a
_ [(t, a)]
_) = Maybe a
forall a. Maybe a
Nothing
termIsMultiple (LinExpr a
0 r1 :: [(t, a)]
r1@((t
_, a
d1):[(t, a)]
_)) (LinExpr a
0 r2 :: [(t, a)]
r2@((t
_, a
d2):[(t, a)]
_))
  | [(t, a)] -> [(t, a)] -> ((t, a) -> (t, a) -> Bool) -> Bool
forall a b. [a] -> [b] -> (a -> b -> Bool) -> Bool
compareBy [(t, a)]
r1 [(t, a)]
r2 (a -> (t, a) -> (t, a) -> Bool
forall a1 a.
(Ord a1, Fractional a1, Eq a) =>
a1 -> (a, a1) -> (a, a1) -> Bool
compareTerm (a
d1a -> a -> a
forall a. Fractional a => a -> a -> a
/a
d2)) =
      a -> Maybe a
forall a. a -> Maybe a
Just (a
d1a -> a -> a
forall a. Fractional a => a -> a -> a
/a
d2)
termIsMultiple (LinExpr a
c1 [(t, a)]
r1) (LinExpr a
c2 [(t, a)]
r2)
  | [(t, a)] -> [(t, a)] -> ((t, a) -> (t, a) -> Bool) -> Bool
forall a b. [a] -> [b] -> (a -> b -> Bool) -> Bool
compareBy [(t, a)]
r1 [(t, a)]
r2 (a -> (t, a) -> (t, a) -> Bool
forall a1 a.
(Ord a1, Fractional a1, Eq a) =>
a1 -> (a, a1) -> (a, a1) -> Bool
compareTerm (a
c1a -> a -> a
forall a. Fractional a => a -> a -> a
/a
c2)) =
      a -> Maybe a
forall a. a -> Maybe a
Just (a
c1a -> a -> a
forall a. Fractional a => a -> a -> a
/a
c2)
  | Bool
otherwise = Maybe a
forall a. Maybe a
Nothing

compareTerm :: (Ord a1, Fractional a1, Eq a) => a1 -> (a, a1) -> (a, a1) -> Bool
compareTerm :: a1 -> (a, a1) -> (a, a1) -> Bool
compareTerm a1
ratio (a
v3,a1
c3) (a
v4, a1
c4) = 
  a
v3 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v4 Bool -> Bool -> Bool
&& (a1 -> a1
forall a. Num a => a -> a
abs(a1
c3 a1 -> a1 -> a1
forall a. Num a => a -> a -> a
- (a1
c4 a1 -> a1 -> a1
forall a. Num a => a -> a -> a
* a1
ratio)) a1 -> a1 -> Bool
forall a. Ord a => a -> a -> Bool
<= a1 -> a1
forall a. Num a => a -> a
abs a1
c3a1 -> a1 -> a1
forall a. Num a => a -> a -> a
*a1
2e-50)

compareBy :: [a] -> [b] -> (a -> b -> Bool) -> Bool
compareBy :: [a] -> [b] -> (a -> b -> Bool) -> Bool
compareBy [] [] a -> b -> Bool
_ = Bool
True
compareBy (a
e:[a]
l) (b
e2:[b]
l2) a -> b -> Bool
f =
  a -> b -> Bool
f a
e b
e2 Bool -> Bool -> Bool
&& [a] -> [b] -> (a -> b -> Bool) -> Bool
forall a b. [a] -> [b] -> (a -> b -> Bool) -> Bool
compareBy [a]
l [b]
l2 a -> b -> Bool
f
compareBy [a]
_ [b]
_ a -> b -> Bool
_ = Bool
False
        
-- multiply a linear term by a constant.
mulLinExpr :: Num n => n -> LinExpr v n -> LinExpr v n
mulLinExpr :: n -> LinExpr v n -> LinExpr v n
mulLinExpr n
x (LinExpr n
e [(v, n)]
terms) =
  n -> [(v, n)] -> LinExpr v n
forall v n. n -> [(v, n)] -> LinExpr v n
LinExpr (n
en -> n -> n
forall a. Num a => a -> a -> a
*n
x) ([(v, n)] -> LinExpr v n) -> [(v, n)] -> LinExpr v n
forall a b. (a -> b) -> a -> b
$ ((v, n) -> (v, n)) -> [(v, n)] -> [(v, n)]
forall a b. (a -> b) -> [a] -> [b]
map ((n -> n) -> (v, n) -> (v, n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (n -> n -> n
forall a. Num a => a -> a -> a
*n
x)) [(v, n)]
terms

-- multiply all sines with the constant
-- constant multiplier
mulConstTrig :: (Ord n, Num n) => n -> TrigTerm v n -> TrigTerm v n
mulConstTrig :: n -> TrigTerm v n -> TrigTerm v n
mulConstTrig n
c (Period v n
theta, [(n, Amplitude v n)]
terms) =  (Period v n
theta, [(n, Amplitude v n)]
tt) where
  tt :: [(n, Amplitude v n)]
tt = ((n, Amplitude v n) -> (n, Amplitude v n))
-> [(n, Amplitude v n)] -> [(n, Amplitude v n)]
forall a b. (a -> b) -> [a] -> [b]
map ((Amplitude v n -> Amplitude v n)
-> (n, Amplitude v n) -> (n, Amplitude v n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (n -> Amplitude v n -> Amplitude v n
forall n v. Num n => n -> LinExpr v n -> LinExpr v n
mulLinExpr n
c)) [(n, Amplitude v n)]
terms

mulLinTrig :: (Ord n, Ord v, Floating n)
           => LinExpr v n -> TrigTerm v n -> Expr v n
mulLinTrig :: LinExpr v n -> TrigTerm v n -> Expr v n
mulLinTrig LinExpr v n
lt (Period v n
theta, [(n, LinExpr v n)]
terms) =
  -- linear multiplier
  ((n, LinExpr v n) -> Expr v n -> Expr v n)
-> Expr v n -> [(n, LinExpr v n)] -> Expr v n
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
(+)(Expr v n -> Expr v n -> Expr v n)
-> ((n, LinExpr v n) -> Expr v n)
-> (n, LinExpr v n)
-> Expr v n
-> Expr v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(n, LinExpr v n) -> Expr v n
mul1) Expr v n
0 [(n, LinExpr v n)]
terms
  where
    -- constant amplitude
    mul1 :: (n, LinExpr v n) -> Expr v n
mul1 (n
alpha, LinExpr n
c []) =
      [TrigTerm v n] -> Expr v n
forall n v. Num n => [TrigTerm v n] -> Expr v n
trigExpr [(Period v n
theta, [(n
alpha, n -> LinExpr v n -> LinExpr v n
forall n v. Num n => n -> LinExpr v n -> LinExpr v n
mulLinExpr n
c LinExpr v n
lt)])]
    -- linear amplitude
    mul1 (n, LinExpr v n)
t =
      [NonLinExpr v n] -> Expr v n
forall n v. Num n => [NonLinExpr v n] -> Expr v n
nonlinExpr [Expr v n -> Expr v n -> NonLinExpr v n
forall v n. Expr v n -> Expr v n -> NonLinExpr v n
MulExp ([TrigTerm v n] -> Expr v n
forall n v. Num n => [TrigTerm v n] -> Expr v n
trigExpr [(Period v n
theta, [(n, LinExpr v n)
t])])
                  (LinExpr v n -> [TrigTerm v n] -> [NonLinExpr v n] -> Expr v n
forall v n.
LinExpr v n -> [TrigTerm v n] -> [NonLinExpr v n] -> Expr v n
Expr LinExpr v n
lt [] [])]

-- constant * (linear + trig)
mulExpr :: (Ord a, Ord t, Floating a) => Expr t a -> Expr t a -> Expr t a
mulExpr :: Expr t a -> Expr t a -> Expr t a
mulExpr (ConstE a
c) (Expr LinExpr t a
lt2 [TrigTerm t a]
trig []) =
  LinExpr t a -> [TrigTerm t a] -> [NonLinExpr t a] -> Expr t a
forall v n.
LinExpr v n -> [TrigTerm v n] -> [NonLinExpr v n] -> Expr v n
Expr (a -> LinExpr t a -> LinExpr t a
forall n v. Num n => n -> LinExpr v n -> LinExpr v n
mulLinExpr a
c LinExpr t a
lt2)
  ((TrigTerm t a -> TrigTerm t a) -> [TrigTerm t a] -> [TrigTerm t a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> TrigTerm t a -> TrigTerm t a
forall n v. (Ord n, Num n) => n -> TrigTerm v n -> TrigTerm v n
mulConstTrig a
c) [TrigTerm t a]
trig) []

mulExpr (Expr LinExpr t a
lt2 [TrigTerm t a]
trig []) (ConstE a
c) =
  LinExpr t a -> [TrigTerm t a] -> [NonLinExpr t a] -> Expr t a
forall v n.
LinExpr v n -> [TrigTerm v n] -> [NonLinExpr v n] -> Expr v n
Expr (a -> LinExpr t a -> LinExpr t a
forall n v. Num n => n -> LinExpr v n -> LinExpr v n
mulLinExpr a
c LinExpr t a
lt2)
  ((TrigTerm t a -> TrigTerm t a) -> [TrigTerm t a] -> [TrigTerm t a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> TrigTerm t a -> TrigTerm t a
forall n v. (Ord n, Num n) => n -> TrigTerm v n -> TrigTerm v n
mulConstTrig a
c) [TrigTerm t a]
trig) []

-- linear * (constant + trig)
mulExpr (LinearE LinExpr t a
lt) (Expr (LConst a
c) [TrigTerm t a]
trig []) =
  LinExpr t a -> Expr t a
forall v n. LinExpr v n -> Expr v n
LinearE (a -> LinExpr t a -> LinExpr t a
forall n v. Num n => n -> LinExpr v n -> LinExpr v n
mulLinExpr a
c LinExpr t a
lt) Expr t a -> Expr t a -> Expr t a
forall a. Num a => a -> a -> a
+
  (TrigTerm t a -> Expr t a -> Expr t a)
-> Expr t a -> [TrigTerm t a] -> Expr t a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Expr t a -> Expr t a -> Expr t a
forall a. Num a => a -> a -> a
(+)(Expr t a -> Expr t a -> Expr t a)
-> (TrigTerm t a -> Expr t a)
-> TrigTerm t a
-> Expr t a
-> Expr t a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.LinExpr t a -> TrigTerm t a -> Expr t a
forall n v.
(Ord n, Ord v, Floating n) =>
LinExpr v n -> TrigTerm v n -> Expr v n
mulLinTrig LinExpr t a
lt) Expr t a
0 [TrigTerm t a]
trig

mulExpr (Expr (LConst a
c) [TrigTerm t a]
trig []) (LinearE LinExpr t a
lt) =
  LinExpr t a -> Expr t a
forall v n. LinExpr v n -> Expr v n
LinearE (a -> LinExpr t a -> LinExpr t a
forall n v. Num n => n -> LinExpr v n -> LinExpr v n
mulLinExpr a
c LinExpr t a
lt) Expr t a -> Expr t a -> Expr t a
forall a. Num a => a -> a -> a
+
  (TrigTerm t a -> Expr t a -> Expr t a)
-> Expr t a -> [TrigTerm t a] -> Expr t a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Expr t a -> Expr t a -> Expr t a
forall a. Num a => a -> a -> a
(+)(Expr t a -> Expr t a -> Expr t a)
-> (TrigTerm t a -> Expr t a)
-> TrigTerm t a
-> Expr t a
-> Expr t a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.LinExpr t a -> TrigTerm t a -> Expr t a
forall n v.
(Ord n, Ord v, Floating n) =>
LinExpr v n -> TrigTerm v n -> Expr v n
mulLinTrig LinExpr t a
lt) Expr t a
0 [TrigTerm t a]
trig

-- anything else
mulExpr Expr t a
e1 Expr t a
e2 = [NonLinExpr t a] -> Expr t a
forall n v. Num n => [NonLinExpr v n] -> Expr v n
nonlinExpr [Expr t a -> Expr t a -> NonLinExpr t a
forall v n. Expr v n -> Expr v n -> NonLinExpr v n
MulExp Expr t a
e1 Expr t a
e2]
      
sinExpr :: Floating n => Expr v n -> Expr v n
sinExpr :: Expr v n -> Expr v n
sinExpr (Expr (LinExpr n
c [(v, n)]
t) [] [])
  | [(v, n)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(v, n)]
t = n -> Expr v n
forall v n. n -> Expr v n
ConstE (n -> n
forall a. Floating a => a -> a
sin n
c)
  | Bool
otherwise = [TrigTerm v n] -> Expr v n
forall n v. Num n => [TrigTerm v n] -> Expr v n
trigExpr [([(v, n)]
t, [(n
c, n -> [(v, n)] -> LinExpr v n
forall v n. n -> [(v, n)] -> LinExpr v n
LinExpr n
1 [])])]
sinExpr Expr v n
e = [NonLinExpr v n] -> Expr v n
forall n v. Num n => [NonLinExpr v n] -> Expr v n
nonlinExpr [Expr v n -> NonLinExpr v n
forall v n. Expr v n -> NonLinExpr v n
SinExp Expr v n
e]

unExpr :: Floating n => UnaryOp -> Expr v n -> Expr v n
unExpr :: UnaryOp -> Expr v n -> Expr v n
unExpr UnaryOp
f (ConstE n
c) = n -> Expr v n
forall v n. n -> Expr v n
ConstE (UnaryOp -> n -> n
forall n. Floating n => UnaryOp -> n -> n
evalUn UnaryOp
f n
c)
unExpr UnaryOp
f Expr v n
e = [NonLinExpr v n] -> Expr v n
forall n v. Num n => [NonLinExpr v n] -> Expr v n
nonlinExpr [UnaryOp -> Expr v n -> NonLinExpr v n
forall v n. UnaryOp -> Expr v n -> NonLinExpr v n
UnaryApp UnaryOp
f Expr v n
e]

substVarLin :: (Ord v, Num n, Eq n)
            => (v -> Maybe (LinExpr v n)) -> LinExpr v n -> LinExpr v n
substVarLin :: (v -> Maybe (LinExpr v n)) -> LinExpr v n -> LinExpr v n
substVarLin v -> Maybe (LinExpr v n)
s (LinExpr n
a [(v, n)]
terms) =
  let substOne :: (v, n) -> LinExpr v n
substOne (v
v, n
c) =
        case v -> Maybe (LinExpr v n)
s v
v of
         Maybe (LinExpr v n)
Nothing -> n -> [(v, n)] -> LinExpr v n
forall v n. n -> [(v, n)] -> LinExpr v n
LinExpr n
0 [(v
v, n
c)]
         Just LinExpr v n
expr -> n -> LinExpr v n -> LinExpr v n
forall n v. Num n => n -> LinExpr v n -> LinExpr v n
mulLinExpr n
c LinExpr v n
expr
  in ((v, n) -> LinExpr v n -> LinExpr v n)
-> LinExpr v n -> [(v, n)] -> LinExpr v n
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (LinExpr v n -> LinExpr v n -> LinExpr v n
forall v n.
(Ord v, Num n, Eq n) =>
LinExpr v n -> LinExpr v n -> LinExpr v n
addLin(LinExpr v n -> LinExpr v n -> LinExpr v n)
-> ((v, n) -> LinExpr v n) -> (v, n) -> LinExpr v n -> LinExpr v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(v, n) -> LinExpr v n
substOne) (n -> [(v, n)] -> LinExpr v n
forall v n. n -> [(v, n)] -> LinExpr v n
LinExpr n
a []) [(v, n)]
terms

substVarNonLin :: (Ord n, Ord v, Floating n)
               => (v -> Maybe (LinExpr v n)) -> NonLinExpr v n -> Expr v n
substVarNonLin :: (v -> Maybe (LinExpr v n)) -> NonLinExpr v n -> Expr v n
substVarNonLin v -> Maybe (LinExpr v n)
s (UnaryApp UnaryOp
f Expr v n
e1) =
  UnaryOp -> Expr v n -> Expr v n
forall n v. Floating n => UnaryOp -> Expr v n -> Expr v n
unExpr UnaryOp
f ((v -> Maybe (LinExpr v n)) -> Expr v n -> Expr v n
forall n v.
(Ord n, Ord v, Floating n) =>
(v -> Maybe (LinExpr v n)) -> Expr v n -> Expr v n
subst v -> Maybe (LinExpr v n)
s Expr v n
e1)
substVarNonLin v -> Maybe (LinExpr v n)
s (MulExp Expr v n
e1 Expr v n
e2) =
  (v -> Maybe (LinExpr v n)) -> Expr v n -> Expr v n
forall n v.
(Ord n, Ord v, Floating n) =>
(v -> Maybe (LinExpr v n)) -> Expr v n -> Expr v n
subst v -> Maybe (LinExpr v n)
s Expr v n
e1 Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
* (v -> Maybe (LinExpr v n)) -> Expr v n -> Expr v n
forall n v.
(Ord n, Ord v, Floating n) =>
(v -> Maybe (LinExpr v n)) -> Expr v n -> Expr v n
subst v -> Maybe (LinExpr v n)
s Expr v n
e2
substVarNonLin v -> Maybe (LinExpr v n)
s (SinExp Expr v n
e1) =
  Expr v n -> Expr v n
forall a. Floating a => a -> a
sin ((v -> Maybe (LinExpr v n)) -> Expr v n -> Expr v n
forall n v.
(Ord n, Ord v, Floating n) =>
(v -> Maybe (LinExpr v n)) -> Expr v n -> Expr v n
subst v -> Maybe (LinExpr v n)
s Expr v n
e1)

substVarTrig :: (Ord v, Ord n, Floating n)
             => (v -> Maybe (LinExpr v n)) -> ([(v, n)], [(n, LinExpr v n)]) -> Expr v n
substVarTrig :: (v -> Maybe (LinExpr v n))
-> ([(v, n)], [(n, LinExpr v n)]) -> Expr v n
substVarTrig v -> Maybe (LinExpr v n)
s ([(v, n)]
period, [(n, LinExpr v n)]
terms) =
  let period2 :: Expr v n
period2 = LinExpr v n -> Expr v n
forall v n. LinExpr v n -> Expr v n
LinearE (LinExpr v n -> Expr v n) -> LinExpr v n -> Expr v n
forall a b. (a -> b) -> a -> b
$ (v -> Maybe (LinExpr v n)) -> LinExpr v n -> LinExpr v n
forall v n.
(Ord v, Num n, Eq n) =>
(v -> Maybe (LinExpr v n)) -> LinExpr v n -> LinExpr v n
substVarLin v -> Maybe (LinExpr v n)
s (n -> [(v, n)] -> LinExpr v n
forall v n. n -> [(v, n)] -> LinExpr v n
LinExpr n
0 [(v, n)]
period)
      terms2 :: [(n, Expr v n)]
terms2 = ((n, LinExpr v n) -> (n, Expr v n))
-> [(n, LinExpr v n)] -> [(n, Expr v n)]
forall a b. (a -> b) -> [a] -> [b]
map ((LinExpr v n -> Expr v n) -> (n, LinExpr v n) -> (n, Expr v n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LinExpr v n -> Expr v n) -> (n, LinExpr v n) -> (n, Expr v n))
-> (LinExpr v n -> Expr v n) -> (n, LinExpr v n) -> (n, Expr v n)
forall a b. (a -> b) -> a -> b
$ LinExpr v n -> Expr v n
forall v n. LinExpr v n -> Expr v n
LinearE (LinExpr v n -> Expr v n)
-> (LinExpr v n -> LinExpr v n) -> LinExpr v n -> Expr v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v -> Maybe (LinExpr v n)) -> LinExpr v n -> LinExpr v n
forall v n.
(Ord v, Num n, Eq n) =>
(v -> Maybe (LinExpr v n)) -> LinExpr v n -> LinExpr v n
substVarLin v -> Maybe (LinExpr v n)
s) [(n, LinExpr v n)]
terms
  in ((n, Expr v n) -> Expr v n -> Expr v n)
-> Expr v n -> [(n, Expr v n)] -> Expr v n
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(n
p,Expr v n
a) -> (Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
+ (Expr v n
a Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
* Expr v n -> Expr v n
forall a. Floating a => a -> a
sin (n -> Expr v n
forall v n. n -> Expr v n
ConstE n
p Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
+ Expr v n
period2))))
     Expr v n
0 [(n, Expr v n)]
terms2

subst :: (Ord n, Ord v, Floating n)
      => (v -> Maybe (LinExpr v n)) -> Expr v n -> Expr v n
subst :: (v -> Maybe (LinExpr v n)) -> Expr v n -> Expr v n
subst v -> Maybe (LinExpr v n)
s (Expr LinExpr v n
lt [TrigTerm v n]
trig [NonLinExpr v n]
nl) =
  LinExpr v n -> Expr v n
forall v n. LinExpr v n -> Expr v n
LinearE ((v -> Maybe (LinExpr v n)) -> LinExpr v n -> LinExpr v n
forall v n.
(Ord v, Num n, Eq n) =>
(v -> Maybe (LinExpr v n)) -> LinExpr v n -> LinExpr v n
substVarLin v -> Maybe (LinExpr v n)
s LinExpr v n
lt) Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
+
  (TrigTerm v n -> Expr v n -> Expr v n)
-> Expr v n -> [TrigTerm v n] -> Expr v n
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
(+)(Expr v n -> Expr v n -> Expr v n)
-> (TrigTerm v n -> Expr v n)
-> TrigTerm v n
-> Expr v n
-> Expr v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(v -> Maybe (LinExpr v n)) -> TrigTerm v n -> Expr v n
forall v n.
(Ord v, Ord n, Floating n) =>
(v -> Maybe (LinExpr v n))
-> ([(v, n)], [(n, LinExpr v n)]) -> Expr v n
substVarTrig v -> Maybe (LinExpr v n)
s) Expr v n
0 [TrigTerm v n]
trig Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
+
  (NonLinExpr v n -> Expr v n -> Expr v n)
-> Expr v n -> [NonLinExpr v n] -> Expr v n
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
(+)(Expr v n -> Expr v n -> Expr v n)
-> (NonLinExpr v n -> Expr v n)
-> NonLinExpr v n
-> Expr v n
-> Expr v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(v -> Maybe (LinExpr v n)) -> NonLinExpr v n -> Expr v n
forall n v.
(Ord n, Ord v, Floating n) =>
(v -> Maybe (LinExpr v n)) -> NonLinExpr v n -> Expr v n
substVarNonLin v -> Maybe (LinExpr v n)
s) Expr v n
0 [NonLinExpr v n]
nl

-- | An empty system of equations.
noDeps :: Dependencies v n
noDeps :: Dependencies v n
noDeps = HashMap v (HashSet v)
-> LinearMap v n
-> [TrigEq v n]
-> TrigEq2 v n
-> [Expr v n]
-> Dependencies v n
forall v n.
HashMap v (HashSet v)
-> LinearMap v n
-> [TrigEq v n]
-> TrigEq2 v n
-> [Expr v n]
-> Dependencies v n
Dependencies HashMap v (HashSet v)
forall k v. HashMap k v
M.empty LinearMap v n
forall k v. HashMap k v
M.empty [] TrigEq2 v n
forall k v. HashMap k v
M.empty []

simpleSubst :: Eq a => a -> b -> a -> Maybe b
simpleSubst :: a -> b -> a -> Maybe b
simpleSubst a
x b
y a
z
  | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
z = b -> Maybe b
forall a. a -> Maybe a
Just b
y
  | Bool
otherwise = Maybe b
forall a. Maybe a
Nothing

trigToExpr :: (Ord n, Ord v, Floating n) => TrigEq v n -> Expr v n
trigToExpr :: TrigEq v n -> Expr v n
trigToExpr (Period v n
p, Amplitude v n
a, n
ph, n
c) =
  Amplitude v n -> Expr v n
forall v n. LinExpr v n -> Expr v n
LinearE Amplitude v n
a Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
* Expr v n -> Expr v n
forall a. Floating a => a -> a
sin(Amplitude v n -> Expr v n
forall v n. LinExpr v n -> Expr v n
LinearE (Amplitude v n -> Expr v n) -> Amplitude v n -> Expr v n
forall a b. (a -> b) -> a -> b
$ n -> Period v n -> Amplitude v n
forall v n. n -> [(v, n)] -> LinExpr v n
LinExpr n
ph Period v n
p) Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
+
  n -> Expr v n
forall v n. n -> Expr v n
ConstE n
c

trig2ToExpr :: (Ord v, Floating n, Ord n) => M.HashMap v (Expr v n) -> [Expr v n]
trig2ToExpr :: HashMap v (Expr v n) -> [Expr v n]
trig2ToExpr =
  ((v, Expr v n) -> Expr v n) -> [(v, Expr v n)] -> [Expr v n]
forall a b. (a -> b) -> [a] -> [b]
map (\(v
v,Expr v n
e)-> v -> Expr v n
forall n v. Num n => v -> Expr v n
makeVariable v
vExpr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
-Expr v n
e)
  ([(v, Expr v n)] -> [Expr v n])
-> (HashMap v (Expr v n) -> [(v, Expr v n)])
-> HashMap v (Expr v n)
-> [Expr v n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap v (Expr v n) -> [(v, Expr v n)]
forall k v. HashMap k v -> [(k, v)]
M.toList

addEqs :: (Hashable v, Hashable n, RealFrac (Phase n), Ord v, Floating n)
       => Dependencies v n -> [Expr v n]
       -> Either (DepError v n) (Dependencies v n)
addEqs :: Dependencies v n
-> [Expr v n] -> Either (DepError v n) (Dependencies v n)
addEqs = (Dependencies v n
 -> Expr v n -> Either (DepError v n) (Dependencies v n))
-> Dependencies v n
-> [Expr v n]
-> Either (DepError v n) (Dependencies v n)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Dependencies v n
-> Expr v n -> Either (DepError v n) (Dependencies v n)
forall n v.
(Hashable n, Hashable v, RealFrac n, Ord v, Floating n) =>
Dependencies v n
-> Expr v n -> Either (DepError v n) (Dependencies v n)
addEquation

-- | @addEquation d e@: Add the equation @e = 0@ to the system d.
addEquation :: (Hashable n, Hashable v, RealFrac (Phase n), Ord v,
          Floating n) =>
         Dependencies v n
         -> Expr v n -> Either (DepError v n) (Dependencies v n)
addEquation :: Dependencies v n
-> Expr v n -> Either (DepError v n) (Dependencies v n)
addEquation deps :: Dependencies v n
deps@(Dependencies HashMap v (HashSet v)
_ LinearMap v n
lin [TrigEq v n]
_ TrigEq2 v n
_ [Expr v n]
_) Expr v n
expr =
  Dependencies v n
-> Expr v n -> Expr v n -> Either (DepError v n) (Dependencies v n)
forall v n.
(Hashable v, Hashable n, RealFrac n, Ord v, Floating n) =>
Dependencies v n
-> Expr v n -> Expr v n -> Either (DepError v n) (Dependencies v n)
addEq0 Dependencies v n
deps Expr v n
expr (Expr v n -> Either (DepError v n) (Dependencies v n))
-> Expr v n -> Either (DepError v n) (Dependencies v n)
forall a b. (a -> b) -> a -> b
$
  -- substitute known and dependend variables
  (v -> Maybe (LinExpr v n)) -> Expr v n -> Expr v n
forall n v.
(Ord n, Ord v, Floating n) =>
(v -> Maybe (LinExpr v n)) -> Expr v n -> Expr v n
subst ((v -> LinearMap v n -> Maybe (LinExpr v n))
-> LinearMap v n -> v -> Maybe (LinExpr v n)
forall a b c. (a -> b -> c) -> b -> a -> c
flip v -> LinearMap v n -> Maybe (LinExpr v n)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup LinearMap v n
lin) Expr v n
expr
  
-- the following alternative would continue after a redundant error.
-- However a redundant expression is supposed to be an error in metafont.
-- 
-- addEqs dep [] = Right dep
-- addEqs dep (e:r) =
--   case addEq0 dep e of
--    Left (InconsistentEq c) ->
--      Left $ InconsistentEq c
--    Left RedundantEq ->
--      addEqs dep r
--    Right newdep ->
--      case addEqs newdep r of
--       Left (InconsistentEq c) ->
--         Left $ InconsistentEq c
--       Left RedundantEq -> Right newdep
--       Right newerdep -> Right newerdep

-- This one is by Cale Gibbard: 

select :: [a] -> [(a, [a])]
select :: [a] -> [(a, [a])]
select [] = []
select (a
x:[a]
xs) =
  (a
x,[a]
xs) (a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
: [(a
y,a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys) | (a
y,[a]
ys) <- [a] -> [(a, [a])]
forall a. [a] -> [(a, [a])]
select [a]
xs]

-- substitute v for lt in all linear equations
-- if insertp is true, then add v = tl to equations
substDep :: (Hashable v, Ord v, Num n, Eq n) =>
             M.HashMap v (H.HashSet v) -> M.HashMap v (LinExpr v n)
             -> v -> LinExpr v n -> Bool 
             -> (M.HashMap v (H.HashSet v), LinearMap v n)
substDep :: HashMap v (HashSet v)
-> HashMap v (LinExpr v n)
-> v
-> LinExpr v n
-> Bool
-> (HashMap v (HashSet v), HashMap v (LinExpr v n))
substDep HashMap v (HashSet v)
vdep HashMap v (LinExpr v n)
lin v
v LinExpr v n
lt Bool
insertp =
       -- variables that depend on v
  let depVars :: HashSet v
depVars = HashSet v -> Maybe (HashSet v) -> HashSet v
forall a. a -> Maybe a -> a
fromMaybe HashSet v
forall a. HashSet a
H.empty (v -> HashMap v (HashSet v) -> Maybe (HashSet v)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup v
v HashMap v (HashSet v)
vdep)
      -- substitute v in all dependend variables and (optionally) add
      -- v as dependend variable
      lin' :: HashMap v (LinExpr v n)
lin' = (if Bool
insertp then v
-> LinExpr v n
-> HashMap v (LinExpr v n)
-> HashMap v (LinExpr v n)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert v
v LinExpr v n
lt
              else HashMap v (LinExpr v n) -> HashMap v (LinExpr v n)
forall a. a -> a
id) (HashMap v (LinExpr v n) -> HashMap v (LinExpr v n))
-> HashMap v (LinExpr v n) -> HashMap v (LinExpr v n)
forall a b. (a -> b) -> a -> b
$
             (HashMap v (LinExpr v n) -> v -> HashMap v (LinExpr v n))
-> HashMap v (LinExpr v n) -> HashSet v -> HashMap v (LinExpr v n)
forall a b. (a -> b -> a) -> a -> HashSet b -> a
H.foldl' ((v -> HashMap v (LinExpr v n) -> HashMap v (LinExpr v n))
-> HashMap v (LinExpr v n) -> v -> HashMap v (LinExpr v n)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((v -> HashMap v (LinExpr v n) -> HashMap v (LinExpr v n))
 -> HashMap v (LinExpr v n) -> v -> HashMap v (LinExpr v n))
-> (v -> HashMap v (LinExpr v n) -> HashMap v (LinExpr v n))
-> HashMap v (LinExpr v n)
-> v
-> HashMap v (LinExpr v n)
forall a b. (a -> b) -> a -> b
$ (LinExpr v n -> LinExpr v n)
-> v -> HashMap v (LinExpr v n) -> HashMap v (LinExpr v n)
forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
M.adjust ((LinExpr v n -> LinExpr v n)
 -> v -> HashMap v (LinExpr v n) -> HashMap v (LinExpr v n))
-> (LinExpr v n -> LinExpr v n)
-> v
-> HashMap v (LinExpr v n)
-> HashMap v (LinExpr v n)
forall a b. (a -> b) -> a -> b
$
                       (v -> Maybe (LinExpr v n)) -> LinExpr v n -> LinExpr v n
forall v n.
(Ord v, Num n, Eq n) =>
(v -> Maybe (LinExpr v n)) -> LinExpr v n -> LinExpr v n
substVarLin ((v -> Maybe (LinExpr v n)) -> LinExpr v n -> LinExpr v n)
-> (v -> Maybe (LinExpr v n)) -> LinExpr v n -> LinExpr v n
forall a b. (a -> b) -> a -> b
$
                       v -> LinExpr v n -> v -> Maybe (LinExpr v n)
forall a b. Eq a => a -> b -> a -> Maybe b
simpleSubst v
v LinExpr v n
lt)
             HashMap v (LinExpr v n)
lin HashSet v
depVars
      -- add dependency link from independend variables to the
      -- substituted equations and (optionally) v, and remove v (since
      -- it has become dependend, so no variable can depend on it).
      depVars2 :: HashSet v
depVars2 | Bool
insertp = v -> HashSet v -> HashSet v
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
H.insert v
v HashSet v
depVars
               | Bool
otherwise = HashSet v
depVars
      -- exclude dependend variable v if k has been canceled
      tryUnion :: v -> HashSet v -> HashSet v -> HashSet v
tryUnion v
k HashSet v
m1 HashSet v
m2 =
        let xs :: HashSet v
xs = HashSet v -> HashSet v -> HashSet v
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
H.intersection HashSet v
m1 HashSet v
m2
            hasvar :: v -> Bool
hasvar v
v2 = case v -> HashMap v (LinExpr v n) -> Maybe (LinExpr v n)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup v
v2 HashMap v (LinExpr v n)
lin' of
              Maybe (LinExpr v n)
Nothing -> Bool
False
              Just (LinExpr n
_ [(v, n)]
vs) ->
                ((v, n) -> Bool) -> [(v, n)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((v -> v -> Bool
forall a. Eq a => a -> a -> Bool
==v
k)(v -> Bool) -> ((v, n) -> v) -> (v, n) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(v, n) -> v
forall a b. (a, b) -> a
fst) [(v, n)]
vs
        in (v -> Bool) -> HashSet v -> HashSet v
forall a. (a -> Bool) -> HashSet a -> HashSet a
H.filter v -> Bool
hasvar HashSet v
xs
           HashSet v -> HashSet v -> HashSet v
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`H.union` HashSet v -> HashSet v -> HashSet v
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
H.difference HashSet v
m1 HashSet v
xs
           HashSet v -> HashSet v -> HashSet v
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`H.union` HashSet v -> HashSet v -> HashSet v
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
H.difference HashSet v
m2 HashSet v
xs
      vdep' :: HashMap v (HashSet v)
vdep' = (HashMap v (HashSet v) -> v -> HashMap v (HashSet v))
-> HashMap v (HashSet v) -> HashSet v -> HashMap v (HashSet v)
forall a b. (a -> b -> a) -> a -> HashSet b -> a
H.foldl'
              (\HashMap v (HashSet v)
mp v
k -> (HashSet v -> HashSet v -> HashSet v)
-> v -> HashSet v -> HashMap v (HashSet v) -> HashMap v (HashSet v)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
M.insertWith (v -> HashSet v -> HashSet v -> HashSet v
tryUnion v
k) v
k HashSet v
depVars2 HashMap v (HashSet v)
mp)
              (v -> HashMap v (HashSet v) -> HashMap v (HashSet v)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
M.delete v
v HashMap v (HashSet v)
vdep)
              ([v] -> HashSet v
forall a. (Eq a, Hashable a) => [a] -> HashSet a
H.fromList ([v] -> HashSet v) -> [v] -> HashSet v
forall a b. (a -> b) -> a -> b
$ LinExpr v n -> [v]
forall v n. LinExpr v n -> [v]
linVars LinExpr v n
lt)
  in (HashMap v (HashSet v)
vdep', HashMap v (LinExpr v n)
lin')

addEq0 :: (Hashable v, Hashable n, RealFrac (Phase n), Ord v, Floating n)
       => Dependencies v n -> Expr v n -> Expr v n
       -> Either (DepError v n) (Dependencies v n)
-- adding a constant equation
addEq0 :: Dependencies v n
-> Expr v n -> Expr v n -> Either (DepError v n) (Dependencies v n)
addEq0 Dependencies v n
_ Expr v n
e (ConstE n
c) =
  DepError v n -> Either (DepError v n) (Dependencies v n)
forall a b. a -> Either a b
Left (DepError v n -> Either (DepError v n) (Dependencies v n))
-> DepError v n -> Either (DepError v n) (Dependencies v n)
forall a b. (a -> b) -> a -> b
$ if n -> n
forall a. Num a => a -> a
abs n
c n -> n -> Bool
forall a. Ord a => a -> a -> Bool
< n
eps
         then Expr v n -> DepError v n
forall v n. Expr v n -> DepError v n
RedundantEq Expr v n
e
         else n -> Expr v n -> DepError v n
forall v n. n -> Expr v n -> DepError v n
InconsistentEq n
c Expr v n
e
  where eps :: n
eps = n
0.0001

-- adding a linear equation
addEq0 (Dependencies HashMap v (HashSet v)
vdep LinearMap v n
lin [TrigEq v n]
trig TrigEq2 v n
trig2 [Expr v n]
nonlin) Expr v n
_ (Expr LinExpr v n
lt [] []) =
  let (v
v, n
_, LinExpr v n
lt2) = LinExpr v n -> (v, n, LinExpr v n)
forall b v.
(Ord b, Fractional b, Eq v) =>
LinExpr v b -> (v, b, LinExpr v b)
splitMax LinExpr v n
lt
      (HashMap v (HashSet v)
vdep', LinearMap v n
lin') = HashMap v (HashSet v)
-> LinearMap v n
-> v
-> LinExpr v n
-> Bool
-> (HashMap v (HashSet v), LinearMap v n)
forall v n.
(Hashable v, Ord v, Num n, Eq n) =>
HashMap v (HashSet v)
-> HashMap v (LinExpr v n)
-> v
-> LinExpr v n
-> Bool
-> (HashMap v (HashSet v), HashMap v (LinExpr v n))
substDep HashMap v (HashSet v)
vdep LinearMap v n
lin v
v LinExpr v n
lt2 Bool
True
      
      -- Add nonlinear equations again to the system.
      trig' :: [Expr v n]
trig' = (TrigEq v n -> Expr v n) -> [TrigEq v n] -> [Expr v n]
forall a b. (a -> b) -> [a] -> [b]
map TrigEq v n -> Expr v n
forall n v. (Ord n, Ord v, Floating n) => TrigEq v n -> Expr v n
trigToExpr [TrigEq v n]
trig
      trig2' :: [Expr v n]
trig2' = (HashMap v (Expr v n) -> [Expr v n])
-> [HashMap v (Expr v n)] -> [Expr v n]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HashMap v (Expr v n) -> [Expr v n]
forall v n.
(Ord v, Floating n, Ord n) =>
HashMap v (Expr v n) -> [Expr v n]
trig2ToExpr ([HashMap v (Expr v n)] -> [Expr v n])
-> [HashMap v (Expr v n)] -> [Expr v n]
forall a b. (a -> b) -> a -> b
$ TrigEq2 v n -> [HashMap v (Expr v n)]
forall k v. HashMap k v -> [v]
M.elems TrigEq2 v n
trig2
  in Dependencies v n
-> [Expr v n] -> Either (DepError v n) (Dependencies v n)
forall v n.
(Hashable v, Hashable n, RealFrac n, Ord v, Floating n) =>
Dependencies v n
-> [Expr v n] -> Either (DepError v n) (Dependencies v n)
addEqs (HashMap v (HashSet v)
-> LinearMap v n
-> [TrigEq v n]
-> TrigEq2 v n
-> [Expr v n]
-> Dependencies v n
forall v n.
HashMap v (HashSet v)
-> LinearMap v n
-> [TrigEq v n]
-> TrigEq2 v n
-> [Expr v n]
-> Dependencies v n
Dependencies HashMap v (HashSet v)
vdep' LinearMap v n
lin' [] TrigEq2 v n
forall k v. HashMap k v
M.empty []) ([Expr v n]
trig'[Expr v n] -> [Expr v n] -> [Expr v n]
forall a. [a] -> [a] -> [a]
++[Expr v n]
trig2'[Expr v n] -> [Expr v n] -> [Expr v n]
forall a. [a] -> [a] -> [a]
++[Expr v n]
nonlin)

-- adding a sine equation
addEq0 deps :: Dependencies v n
deps@(Dependencies HashMap v (HashSet v)
vdep LinearMap v n
lin [TrigEq v n]
trig TrigEq2 v n
trig2 [Expr v n]
nl) Expr v n
orig
  (Expr (LinExpr n
c [(v, n)]
lt) [([(v, n)]
theta, [(n
alpha, LConst n
n)])] []) =
  if [(v, n)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(v, n)]
lt then
    -- reduce a sine to linear equation
    Dependencies v n
-> Expr v n -> Expr v n -> Either (DepError v n) (Dependencies v n)
forall v n.
(Hashable v, Hashable n, RealFrac n, Ord v, Floating n) =>
Dependencies v n
-> Expr v n -> Expr v n -> Either (DepError v n) (Dependencies v n)
addEq0 Dependencies v n
deps Expr v n
orig (LinExpr v n -> Expr v n
forall v n. LinExpr v n -> Expr v n
LinearE (LinExpr v n -> Expr v n) -> LinExpr v n -> Expr v n
forall a b. (a -> b) -> a -> b
$ n -> [(v, n)] -> LinExpr v n
forall v n. n -> [(v, n)] -> LinExpr v n
LinExpr (n
alpha n -> n -> n
forall a. Num a => a -> a -> a
- n -> n
forall a. Floating a => a -> a
asin (-n
cn -> n -> n
forall a. Fractional a => a -> a -> a
/n
n)) [(v, n)]
theta)
  else
    -- add a variable dependency on the sine equation
    case [(v, n)] -> TrigEq2 v n -> Maybe (HashMap v (Expr v n))
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup [(v, n)]
theta TrigEq2 v n
trig2 of
     -- no sine with same period
     Maybe (HashMap v (Expr v n))
Nothing -> LinExpr v n -> n -> n -> Either (DepError v n) (Dependencies v n)
forall a. LinExpr v n -> n -> n -> Either a (Dependencies v n)
addSin (n -> [(v, n)] -> LinExpr v n
forall v n. n -> [(v, n)] -> LinExpr v n
LinExpr n
c [(v, n)]
lt) n
alpha n
n
     Just HashMap v (Expr v n)
map2 ->
       case ((v, n) -> Expr v n -> Expr v n)
-> Expr v n -> [(v, n)] -> Expr v n
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
(+)(Expr v n -> Expr v n -> Expr v n)
-> ((v, n) -> Expr v n) -> (v, n) -> Expr v n -> Expr v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(v, n) -> Expr v n
doSubst)
            (n -> Expr v n
forall v n. n -> Expr v n
ConstE n
c Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
+
             n -> Expr v n
forall v n. n -> Expr v n
ConstE n
n Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
*
             Expr v n -> Expr v n
forall a. Floating a => a -> a
sin (LinExpr v n -> Expr v n
forall v n. LinExpr v n -> Expr v n
LinearE (LinExpr v n -> Expr v n) -> LinExpr v n -> Expr v n
forall a b. (a -> b) -> a -> b
$ n -> [(v, n)] -> LinExpr v n
forall v n. n -> [(v, n)] -> LinExpr v n
LinExpr n
alpha [(v, n)]
theta))
            [(v, n)]
lt of
        Expr LinExpr v n
lt2 [([(v, n)]
_, [(n
alpha2, LConst n
n2)])] []
          | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ LinExpr v n -> Bool
forall v n. LinExpr v n -> Bool
isConst LinExpr v n
lt2
          -> LinExpr v n -> n -> n -> Either (DepError v n) (Dependencies v n)
forall a. LinExpr v n -> n -> n -> Either a (Dependencies v n)
addSin LinExpr v n
lt2 n
alpha2 n
n2
        Expr v n
e2 -> Dependencies v n
-> Expr v n -> Expr v n -> Either (DepError v n) (Dependencies v n)
forall v n.
(Hashable v, Hashable n, RealFrac n, Ord v, Floating n) =>
Dependencies v n
-> Expr v n -> Expr v n -> Either (DepError v n) (Dependencies v n)
addEq0 Dependencies v n
deps Expr v n
orig Expr v n
e2
       where
         doSubst :: (v, n) -> Expr v n
doSubst (v
v,n
c2) = case v -> HashMap v (Expr v n) -> Maybe (Expr v n)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup v
v HashMap v (Expr v n)
map2 of
           Maybe (Expr v n)
Nothing -> v -> Expr v n
forall n v. Num n => v -> Expr v n
makeVariable v
v Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
* n -> Expr v n
forall v n. n -> Expr v n
ConstE n
c2
           Just Expr v n
e2 -> Expr v n
e2 Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
* n -> Expr v n
forall v n. n -> Expr v n
ConstE n
c2
  where
    addSin :: LinExpr v n -> n -> n -> Either a (Dependencies v n)
addSin LinExpr v n
l' n
a' n
n' =
      let (v
v, n
c', LinExpr v n
r) = LinExpr v n -> (v, n, LinExpr v n)
forall b v.
(Ord b, Fractional b, Eq v) =>
LinExpr v b -> (v, b, LinExpr v b)
splitMax LinExpr v n
l'
          trig2' :: TrigEq2 v n
trig2' = (HashMap v (Expr v n)
 -> HashMap v (Expr v n) -> HashMap v (Expr v n))
-> [(v, n)] -> HashMap v (Expr v n) -> TrigEq2 v n -> TrigEq2 v n
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
M.insertWith HashMap v (Expr v n)
-> HashMap v (Expr v n) -> HashMap v (Expr v n)
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
M.union [(v, n)]
theta
                   (v -> Expr v n -> HashMap v (Expr v n)
forall k v. Hashable k => k -> v -> HashMap k v
M.singleton v
v (Expr v n -> HashMap v (Expr v n))
-> Expr v n -> HashMap v (Expr v n)
forall a b. (a -> b) -> a -> b
$
                    LinExpr v n -> [TrigTerm v n] -> [NonLinExpr v n] -> Expr v n
forall v n.
LinExpr v n -> [TrigTerm v n] -> [NonLinExpr v n] -> Expr v n
Expr LinExpr v n
r [([(v, n)]
theta, [(n
a', n -> [(v, n)] -> LinExpr v n
forall v n. n -> [(v, n)] -> LinExpr v n
LinExpr (n
n'n -> n -> n
forall a. Fractional a => a -> a -> a
/n -> n
forall a. Num a => a -> a
negate n
c') [])])] [])
                   TrigEq2 v n
trig2
      in Dependencies v n -> Either a (Dependencies v n)
forall a b. b -> Either a b
Right (Dependencies v n -> Either a (Dependencies v n))
-> Dependencies v n -> Either a (Dependencies v n)
forall a b. (a -> b) -> a -> b
$ HashMap v (HashSet v)
-> LinearMap v n
-> [TrigEq v n]
-> TrigEq2 v n
-> [Expr v n]
-> Dependencies v n
forall v n.
HashMap v (HashSet v)
-> LinearMap v n
-> [TrigEq v n]
-> TrigEq2 v n
-> [Expr v n]
-> Dependencies v n
Dependencies  HashMap v (HashSet v)
vdep LinearMap v n
lin [TrigEq v n]
trig TrigEq2 v n
trig2' [Expr v n]
nl

--  adding the first sine equation
addEq0 (Dependencies HashMap v (HashSet v)
d LinearMap v n
lin [] TrigEq2 v n
trig2 [Expr v n]
nl) Expr v n
_
  (Expr (LConst n
c) [([(v, n)]
theta, [(n
alpha, LinExpr v n
n)])] []) =
  Dependencies v n -> Either (DepError v n) (Dependencies v n)
forall a b. b -> Either a b
Right (Dependencies v n -> Either (DepError v n) (Dependencies v n))
-> Dependencies v n -> Either (DepError v n) (Dependencies v n)
forall a b. (a -> b) -> a -> b
$ HashMap v (HashSet v)
-> LinearMap v n
-> [TrigEq v n]
-> TrigEq2 v n
-> [Expr v n]
-> Dependencies v n
forall v n.
HashMap v (HashSet v)
-> LinearMap v n
-> [TrigEq v n]
-> TrigEq2 v n
-> [Expr v n]
-> Dependencies v n
Dependencies HashMap v (HashSet v)
d LinearMap v n
lin [([(v, n)]
theta, LinExpr v n
n, n
alpha, n
c)] TrigEq2 v n
trig2 [Expr v n]
nl

-- try reducing this equation with another sine equation
addEq0 (Dependencies HashMap v (HashSet v)
deps LinearMap v n
lin [TrigEq v n]
trig TrigEq2 v n
trig2 [Expr v n]
nl) Expr v n
_
  (Expr (LConst n
x) [([(v, n)]
theta, [(n
a, LinExpr v n
n)])] []) =
  case ((TrigEq v n, [TrigEq v n]) -> Maybe ((n, n), [TrigEq v n]))
-> [(TrigEq v n, [TrigEq v n])] -> [((n, n), [TrigEq v n])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TrigEq v n, [TrigEq v n]) -> Maybe ((n, n), [TrigEq v n])
forall b. (TrigEq v n, b) -> Maybe ((n, n), b)
similarTrig ([(TrigEq v n, [TrigEq v n])] -> [((n, n), [TrigEq v n])])
-> [(TrigEq v n, [TrigEq v n])] -> [((n, n), [TrigEq v n])]
forall a b. (a -> b) -> a -> b
$ [TrigEq v n] -> [(TrigEq v n, [TrigEq v n])]
forall a. [a] -> [(a, [a])]
select [TrigEq v n]
trig of
   -- no matching equation found
   [] -> Dependencies v n -> Either (DepError v n) (Dependencies v n)
forall a b. b -> Either a b
Right (Dependencies v n -> Either (DepError v n) (Dependencies v n))
-> Dependencies v n -> Either (DepError v n) (Dependencies v n)
forall a b. (a -> b) -> a -> b
$ HashMap v (HashSet v)
-> LinearMap v n
-> [TrigEq v n]
-> TrigEq2 v n
-> [Expr v n]
-> Dependencies v n
forall v n.
HashMap v (HashSet v)
-> LinearMap v n
-> [TrigEq v n]
-> TrigEq2 v n
-> [Expr v n]
-> Dependencies v n
Dependencies HashMap v (HashSet v)
deps LinearMap v n
lin (([(v, n)]
theta, LinExpr v n
n, n
a, n
x)TrigEq v n -> [TrigEq v n] -> [TrigEq v n]
forall a. a -> [a] -> [a]
:[TrigEq v n]
trig) TrigEq2 v n
trig2 [Expr v n]
nl
   -- solve for angle and amplitude, and add resulting linear
   -- equations
   [((n, n), [TrigEq v n])]
l -> Dependencies v n
-> [Expr v n] -> Either (DepError v n) (Dependencies v n)
forall v n.
(Hashable v, Hashable n, RealFrac n, Ord v, Floating n) =>
Dependencies v n
-> [Expr v n] -> Either (DepError v n) (Dependencies v n)
addEqs (HashMap v (HashSet v)
-> LinearMap v n
-> [TrigEq v n]
-> TrigEq2 v n
-> [Expr v n]
-> Dependencies v n
forall v n.
HashMap v (HashSet v)
-> LinearMap v n
-> [TrigEq v n]
-> TrigEq2 v n
-> [Expr v n]
-> Dependencies v n
Dependencies HashMap v (HashSet v)
deps LinearMap v n
lin [TrigEq v n]
rest TrigEq2 v n
trig2 [Expr v n]
nl) [Expr v n
lin1, Expr v n
lin2]
     where
       ((n
b,n
y), [TrigEq v n]
rest) = (((n, n), [TrigEq v n]) -> ((n, n), [TrigEq v n]) -> Ordering)
-> [((n, n), [TrigEq v n])] -> ((n, n), [TrigEq v n])
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy ((n, n) -> (n, n) -> Ordering
forall b b. (n, b) -> (n, b) -> Ordering
maxTrig ((n, n) -> (n, n) -> Ordering)
-> (((n, n), [TrigEq v n]) -> (n, n))
-> ((n, n), [TrigEq v n])
-> ((n, n), [TrigEq v n])
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ((n, n), [TrigEq v n]) -> (n, n)
forall a b. (a, b) -> a
fst) [((n, n), [TrigEq v n])]
l
       maxTrig :: (n, b) -> (n, b) -> Ordering
maxTrig (n
t1,b
_) (n
t2,b
_) = 
         n -> n -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((n
t1n -> n -> n
forall a. Num a => a -> a -> a
-n
a)n -> n -> n
forall a. RealFrac a => a -> a -> a
`dmod`n
forall a. Floating a => a
pi) ((n
t2n -> n -> n
forall a. Num a => a -> a -> a
-n
a)n -> n -> n
forall a. RealFrac a => a -> a -> a
`dmod`n
forall a. Floating a => a
pi)
       d :: n
d      = n -> n
forall a. Floating a => a -> a
sin(n
an -> n -> n
forall a. Num a => a -> a -> a
-n
b)
       e :: n
e      = n
yn -> n -> n
forall a. Num a => a -> a -> a
*n -> n
forall a. Floating a => a -> a
cos(n
an -> n -> n
forall a. Num a => a -> a -> a
-n
b)n -> n -> n
forall a. Num a => a -> a -> a
-n
x
       theta2 :: n
theta2 = n -> n
forall a. Floating a => a -> a
atan (-n
yn -> n -> n
forall a. Num a => a -> a -> a
*n
dn -> n -> n
forall a. Fractional a => a -> a -> a
/n
e)n -> n -> n
forall a. Num a => a -> a -> a
-n
b n -> n -> n
forall a. Num a => a -> a -> a
+
                (if (n
dn -> n -> n
forall a. Num a => a -> a -> a
*n
e) n -> n -> Bool
forall a. Ord a => a -> a -> Bool
< n
0 then n
forall a. Floating a => a
pi else n
0)
       n2 :: n
n2     = n -> n
forall a. Floating a => a -> a
sqrt(n
yn -> n -> n
forall a. Num a => a -> a -> a
*n
y n -> n -> n
forall a. Num a => a -> a -> a
+ n
en -> n -> n
forall a. Num a => a -> a -> a
*n
en -> n -> n
forall a. Fractional a => a -> a -> a
/(n
dn -> n -> n
forall a. Num a => a -> a -> a
*n
d))
       lin1 :: Expr v n
lin1   = LinExpr v n -> Expr v n
forall v n. LinExpr v n -> Expr v n
LinearE (LinExpr v n -> Expr v n) -> LinExpr v n -> Expr v n
forall a b. (a -> b) -> a -> b
$ n -> [(v, n)] -> LinExpr v n
forall v n. n -> [(v, n)] -> LinExpr v n
LinExpr (-n
theta2) [(v, n)]
theta
       lin2 :: Expr v n
lin2   = LinExpr v n -> Expr v n
forall v n. LinExpr v n -> Expr v n
LinearE LinExpr v n
n Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
- n -> Expr v n
forall v n. n -> Expr v n
ConstE n
n2
  where
    similarTrig :: (TrigEq v n, b) -> Maybe ((n, n), b)
similarTrig (([(v, n)]
t,LinExpr v n
m,n
b,n
y),b
rest)
      | Just n
r <- LinExpr v n -> LinExpr v n -> Maybe n
forall a t.
(Ord a, Fractional a, Eq t) =>
LinExpr t a -> LinExpr t a -> Maybe a
termIsMultiple LinExpr v n
m LinExpr v n
n,
        [(v, n)]
t [(v, n)] -> [(v, n)] -> Bool
forall a. Eq a => a -> a -> Bool
== [(v, n)]
theta Bool -> Bool -> Bool
&&
        (n
bn -> n -> n
forall a. Num a => a -> a -> a
-n
a) n -> n -> n
forall a. RealFrac a => a -> a -> a
`dmod` n
forall a. Floating a => a
pi n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
forall a. Floating a => a
pin -> n -> n
forall a. Fractional a => a -> a -> a
/n
8 =
          ((n, n), b) -> Maybe ((n, n), b)
forall a. a -> Maybe a
Just ((n
b,n
yn -> n -> n
forall a. Fractional a => a -> a -> a
/n
r),b
rest)
      | Bool
otherwise = Maybe ((n, n), b)
forall a. Maybe a
Nothing

-- just add any other equation to the list of nonlinear equations
addEq0 (Dependencies HashMap v (HashSet v)
d LinearMap v n
lin [TrigEq v n]
trig TrigEq2 v n
trig2 [Expr v n]
nonlin) Expr v n
_ Expr v n
e =
  Dependencies v n -> Either (DepError v n) (Dependencies v n)
forall a b. b -> Either a b
Right (Dependencies v n -> Either (DepError v n) (Dependencies v n))
-> Dependencies v n -> Either (DepError v n) (Dependencies v n)
forall a b. (a -> b) -> a -> b
$ HashMap v (HashSet v)
-> LinearMap v n
-> [TrigEq v n]
-> TrigEq2 v n
-> [Expr v n]
-> Dependencies v n
forall v n.
HashMap v (HashSet v)
-> LinearMap v n
-> [TrigEq v n]
-> TrigEq2 v n
-> [Expr v n]
-> Dependencies v n
Dependencies HashMap v (HashSet v)
d LinearMap v n
lin [TrigEq v n]
trig TrigEq2 v n
trig2 (Expr v n
eExpr v n -> [Expr v n] -> [Expr v n]
forall a. a -> [a] -> [a]
:[Expr v n]
nonlin)

deleteDep :: (Hashable k, Hashable b, Eq k, Eq b) =>
             M.HashMap b (H.HashSet k)
          -> M.HashMap k (LinExpr b n) -> k
          -> Maybe (M.HashMap b (H.HashSet k), M.HashMap k (LinExpr b n),
                    LinExpr b n)
deleteDep :: HashMap b (HashSet k)
-> HashMap k (LinExpr b n)
-> k
-> Maybe
     (HashMap b (HashSet k), HashMap k (LinExpr b n), LinExpr b n)
deleteDep HashMap b (HashSet k)
vdep HashMap k (LinExpr b n)
lin k
v =
  case k -> HashMap k (LinExpr b n) -> Maybe (LinExpr b n)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup k
v HashMap k (LinExpr b n)
lin of
   Maybe (LinExpr b n)
Nothing -> Maybe (HashMap b (HashSet k), HashMap k (LinExpr b n), LinExpr b n)
forall a. Maybe a
Nothing
   Just LinExpr b n
lt -> (HashMap b (HashSet k), HashMap k (LinExpr b n), LinExpr b n)
-> Maybe
     (HashMap b (HashSet k), HashMap k (LinExpr b n), LinExpr b n)
forall a. a -> Maybe a
Just (HashMap b (HashSet k)
vdep', HashMap k (LinExpr b n)
lin', LinExpr b n
lt)
     where
       -- delete equation of v
       lin' :: HashMap k (LinExpr b n)
lin' = k -> HashMap k (LinExpr b n) -> HashMap k (LinExpr b n)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
M.delete k
v HashMap k (LinExpr b n)
lin
       -- delete v from dependencies
       vdep' :: HashMap b (HashSet k)
vdep' = (HashMap b (HashSet k) -> b -> HashMap b (HashSet k))
-> HashMap b (HashSet k) -> HashSet b -> HashMap b (HashSet k)
forall a b. (a -> b -> a) -> a -> HashSet b -> a
H.foldl'
               ((b -> HashMap b (HashSet k) -> HashMap b (HashSet k))
-> HashMap b (HashSet k) -> b -> HashMap b (HashSet k)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((b -> HashMap b (HashSet k) -> HashMap b (HashSet k))
 -> HashMap b (HashSet k) -> b -> HashMap b (HashSet k))
-> (b -> HashMap b (HashSet k) -> HashMap b (HashSet k))
-> HashMap b (HashSet k)
-> b
-> HashMap b (HashSet k)
forall a b. (a -> b) -> a -> b
$ (HashSet k -> HashSet k)
-> b -> HashMap b (HashSet k) -> HashMap b (HashSet k)
forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
M.adjust ((HashSet k -> HashSet k)
 -> b -> HashMap b (HashSet k) -> HashMap b (HashSet k))
-> (HashSet k -> HashSet k)
-> b
-> HashMap b (HashSet k)
-> HashMap b (HashSet k)
forall a b. (a -> b) -> a -> b
$ k -> HashSet k -> HashSet k
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
H.delete k
v)
               HashMap b (HashSet k)
vdep ([b] -> HashSet b
forall a. (Eq a, Hashable a) => [a] -> HashSet a
H.fromList ([b] -> HashSet b) -> [b] -> HashSet b
forall a b. (a -> b) -> a -> b
$ LinExpr b n -> [b]
forall v n. LinExpr v n -> [v]
linVars LinExpr b n
lt)

-- | Eliminate an variable from the equations.  Returns the eliminated
-- equations.  Before elimination it performs substitution to minimize
-- the number of eliminated equations.
-- 
--__Important__: this function is
-- still experimental and mostly untested.
eliminate :: (Hashable n, Show n, Hashable v, RealFrac (Phase n), Ord v, Show v,
              Floating n)
          => Dependencies v n -> v -> (Dependencies v n, [Expr v n])
eliminate :: Dependencies v n -> v -> (Dependencies v n, [Expr v n])
eliminate (Dependencies HashMap v (HashSet v)
vdep LinearMap v n
lin [TrigEq v n]
trig TrigEq2 v n
trig2 [Expr v n]
nonlin) v
v
  | Just (HashMap v (HashSet v)
vdep', LinearMap v n
lin', LinExpr v n
lt) <- HashMap v (HashSet v)
-> LinearMap v n
-> v
-> Maybe (HashMap v (HashSet v), LinearMap v n, LinExpr v n)
forall k b n.
(Hashable k, Hashable b, Eq k, Eq b) =>
HashMap b (HashSet k)
-> HashMap k (LinExpr b n)
-> k
-> Maybe
     (HashMap b (HashSet k), HashMap k (LinExpr b n), LinExpr b n)
deleteDep HashMap v (HashSet v)
vdep LinearMap v n
lin v
v =
    -- v is dependend, so doesn't appear in other equations
    (HashMap v (HashSet v)
-> LinearMap v n
-> [TrigEq v n]
-> TrigEq2 v n
-> [Expr v n]
-> Dependencies v n
forall v n.
HashMap v (HashSet v)
-> LinearMap v n
-> [TrigEq v n]
-> TrigEq2 v n
-> [Expr v n]
-> Dependencies v n
Dependencies HashMap v (HashSet v)
vdep' LinearMap v n
lin' [TrigEq v n]
trig TrigEq2 v n
trig2 [Expr v n]
nonlin,
     [LinExpr v n -> Expr v n
forall v n. LinExpr v n -> Expr v n
LinearE LinExpr v n
lt Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
- v -> Expr v n
forall n v. Num n => v -> Expr v n
makeVariable v
v])
  | Just HashSet v
vars <- v -> HashMap v (HashSet v) -> Maybe (HashSet v)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup v
v HashMap v (HashSet v)
vdep,
    (v
v2:[v]
_) <- HashSet v -> [v]
forall a. HashSet a -> [a]
H.toList HashSet v
vars =
      -- v is independend, and appears in a linear equation
      case HashMap v (HashSet v)
-> LinearMap v n
-> v
-> Maybe (HashMap v (HashSet v), LinearMap v n, LinExpr v n)
forall k b n.
(Hashable k, Hashable b, Eq k, Eq b) =>
HashMap b (HashSet k)
-> HashMap k (LinExpr b n)
-> k
-> Maybe
     (HashMap b (HashSet k), HashMap k (LinExpr b n), LinExpr b n)
deleteDep HashMap v (HashSet v)
vdep LinearMap v n
lin v
v2 of
       Maybe (HashMap v (HashSet v), LinearMap v n, LinExpr v n)
Nothing ->
         String -> (Dependencies v n, [Expr v n])
forall a. HasCallStack => String -> a
error (String -> (Dependencies v n, [Expr v n]))
-> String -> (Dependencies v n, [Expr v n])
forall a b. (a -> b) -> a -> b
$ String
"Internal error: found empty dependency on " String -> ShowS
forall a. [a] -> [a] -> [a]
++ v -> String
forall a. Show a => a -> String
show v
v2
       Just (HashMap v (HashSet v)
vdep', LinearMap v n
lin', LinExpr v n
lt) ->
         -- rearrange the deleted equation in terms of v
         let lt2 :: LinExpr v n
lt2 = (n, LinExpr v n) -> LinExpr v n
forall a b. (a, b) -> b
snd ((n, LinExpr v n) -> LinExpr v n)
-> (n, LinExpr v n) -> LinExpr v n
forall a b. (a -> b) -> a -> b
$ v -> LinExpr v n -> v -> (n, LinExpr v n)
forall v n.
(Show v, Ord v, Fractional n, Eq n) =>
v -> LinExpr v n -> v -> (n, LinExpr v n)
reArrange v
v2 LinExpr v n
lt v
v
             -- substitute v in all equations
             (HashMap v (HashSet v)
vdep'', LinearMap v n
lin'') = HashMap v (HashSet v)
-> LinearMap v n
-> v
-> LinExpr v n
-> Bool
-> (HashMap v (HashSet v), LinearMap v n)
forall v n.
(Hashable v, Ord v, Num n, Eq n) =>
HashMap v (HashSet v)
-> HashMap v (LinExpr v n)
-> v
-> LinExpr v n
-> Bool
-> (HashMap v (HashSet v), HashMap v (LinExpr v n))
substDep HashMap v (HashSet v)
vdep' LinearMap v n
lin' v
v LinExpr v n
lt2 Bool
False
             trig' :: [Expr v n]
trig' = (TrigEq v n -> Expr v n) -> [TrigEq v n] -> [Expr v n]
forall a b. (a -> b) -> [a] -> [b]
map TrigEq v n -> Expr v n
forall n v. (Ord n, Ord v, Floating n) => TrigEq v n -> Expr v n
trigToExpr [TrigEq v n]
trig
             trig2' :: [Expr v n]
trig2' = (HashMap v (Expr v n) -> [Expr v n])
-> [HashMap v (Expr v n)] -> [Expr v n]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HashMap v (Expr v n) -> [Expr v n]
forall v n.
(Ord v, Floating n, Ord n) =>
HashMap v (Expr v n) -> [Expr v n]
trig2ToExpr ([HashMap v (Expr v n)] -> [Expr v n])
-> [HashMap v (Expr v n)] -> [Expr v n]
forall a b. (a -> b) -> a -> b
$ TrigEq2 v n -> [HashMap v (Expr v n)]
forall k v. HashMap k v -> [v]
M.elems TrigEq2 v n
trig2
             deps :: Dependencies v n
deps = HashMap v (HashSet v)
-> LinearMap v n
-> [TrigEq v n]
-> TrigEq2 v n
-> [Expr v n]
-> Dependencies v n
forall v n.
HashMap v (HashSet v)
-> LinearMap v n
-> [TrigEq v n]
-> TrigEq2 v n
-> [Expr v n]
-> Dependencies v n
Dependencies HashMap v (HashSet v)
vdep'' LinearMap v n
lin'' [] TrigEq2 v n
forall k v. HashMap k v
M.empty []
             e :: [Expr v n]
e = [LinExpr v n -> Expr v n
forall v n. LinExpr v n -> Expr v n
LinearE LinExpr v n
lt2 Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
- v -> Expr v n
forall n v. Num n => v -> Expr v n
makeVariable v
v]
          -- use addEq0 since substitution is unnecessary
         in case (Dependencies v n
 -> Expr v n -> Either (DepError v n) (Dependencies v n))
-> Dependencies v n
-> [Expr v n]
-> Either (DepError v n) (Dependencies v n)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Dependencies v n
 -> Expr v n
 -> Expr v n
 -> Either (DepError v n) (Dependencies v n))
-> Expr v n
-> Dependencies v n
-> Expr v n
-> Either (DepError v n) (Dependencies v n)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Dependencies v n
-> Expr v n -> Expr v n -> Either (DepError v n) (Dependencies v n)
forall v n.
(Hashable v, Hashable n, RealFrac n, Ord v, Floating n) =>
Dependencies v n
-> Expr v n -> Expr v n -> Either (DepError v n) (Dependencies v n)
addEq0 Expr v n
forall n v. Num n => Expr v n
zeroExpr)
                 Dependencies v n
deps ([Expr v n] -> Either (DepError v n) (Dependencies v n))
-> [Expr v n] -> Either (DepError v n) (Dependencies v n)
forall a b. (a -> b) -> a -> b
$
                 (Expr v n -> Expr v n) -> [Expr v n] -> [Expr v n]
forall a b. (a -> b) -> [a] -> [b]
map ((v -> Maybe (LinExpr v n)) -> Expr v n -> Expr v n
forall n v.
(Ord n, Ord v, Floating n) =>
(v -> Maybe (LinExpr v n)) -> Expr v n -> Expr v n
subst ((v -> Maybe (LinExpr v n)) -> Expr v n -> Expr v n)
-> (v -> Maybe (LinExpr v n)) -> Expr v n -> Expr v n
forall a b. (a -> b) -> a -> b
$ v -> LinExpr v n -> v -> Maybe (LinExpr v n)
forall a b. Eq a => a -> b -> a -> Maybe b
simpleSubst v
v LinExpr v n
lt2)
                 ([Expr v n]
trig'[Expr v n] -> [Expr v n] -> [Expr v n]
forall a. [a] -> [a] -> [a]
++[Expr v n]
trig2'[Expr v n] -> [Expr v n] -> [Expr v n]
forall a. [a] -> [a] -> [a]
++[Expr v n]
nonlin) of
             Left DepError v n
_ -> (Dependencies v n
deps, [Expr v n]
e) --shouldn't happen
             Right Dependencies v n
d -> (Dependencies v n
d, [Expr v n]
e)
  | Bool
otherwise =
      let ([Expr v n]
l, TrigEq2 v n
trig2') =
            ([(v, n)]
 -> HashMap v (Expr v n)
 -> ([Expr v n], TrigEq2 v n)
 -> ([Expr v n], TrigEq2 v n))
-> ([Expr v n], TrigEq2 v n)
-> TrigEq2 v n
-> ([Expr v n], TrigEq2 v n)
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
M.foldrWithKey [(v, n)]
-> HashMap v (Expr v n)
-> ([Expr v n], TrigEq2 v n)
-> ([Expr v n], TrigEq2 v n)
forall n.
(Floating n, Ord n, Hashable n) =>
[(v, n)]
-> HashMap v (Expr v n)
-> ([Expr v n], HashMap [(v, n)] (HashMap v (Expr v n)))
-> ([Expr v n], HashMap [(v, n)] (HashMap v (Expr v n)))
trigFold
            ([], TrigEq2 v n
forall k v. HashMap k v
M.empty) TrigEq2 v n
trig2
          trigFold :: [(v, n)]
-> HashMap v (Expr v n)
-> ([Expr v n], HashMap [(v, n)] (HashMap v (Expr v n)))
-> ([Expr v n], HashMap [(v, n)] (HashMap v (Expr v n)))
trigFold [(v, n)]
p HashMap v (Expr v n)
t ([Expr v n]
l2, HashMap [(v, n)] (HashMap v (Expr v n))
m2) =
            let ([Expr v n]
l3, HashMap v (Expr v n)
m1) = [(v, n)]
-> HashMap v (Expr v n) -> v -> ([Expr v n], HashMap v (Expr v n))
forall v n.
(Show v, Ord v, Hashable v, Floating n, Ord n) =>
Period v n
-> HashMap v (Expr v n) -> v -> ([Expr v n], HashMap v (Expr v n))
elimTrig [(v, n)]
p HashMap v (Expr v n)
t v
v
                mp :: HashMap [(v, n)] (HashMap v (Expr v n))
mp | HashMap v (Expr v n) -> Bool
forall k v. HashMap k v -> Bool
M.null HashMap v (Expr v n)
m1 = HashMap [(v, n)] (HashMap v (Expr v n))
m2
                   | Bool
otherwise = [(v, n)]
-> HashMap v (Expr v n)
-> HashMap [(v, n)] (HashMap v (Expr v n))
-> HashMap [(v, n)] (HashMap v (Expr v n))
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert [(v, n)]
p HashMap v (Expr v n)
m1 HashMap [(v, n)] (HashMap v (Expr v n))
m2
            in ([Expr v n]
l3[Expr v n] -> [Expr v n] -> [Expr v n]
forall a. [a] -> [a] -> [a]
++[Expr v n]
l2, HashMap [(v, n)] (HashMap v (Expr v n))
mp)
            
          ([Expr v n]
nlWith, [Expr v n]
nlWithout) =
            (Expr v n -> Bool) -> [Expr v n] -> ([Expr v n], [Expr v n])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (v -> Expr v n -> Bool
forall t v. (Num t, Eq v, Eq t) => v -> Expr v t -> Bool
hasVar v
v) ([Expr v n] -> ([Expr v n], [Expr v n]))
-> [Expr v n] -> ([Expr v n], [Expr v n])
forall a b. (a -> b) -> a -> b
$
            (TrigEq v n -> Expr v n) -> [TrigEq v n] -> [Expr v n]
forall a b. (a -> b) -> [a] -> [b]
map TrigEq v n -> Expr v n
forall n v. (Ord n, Ord v, Floating n) => TrigEq v n -> Expr v n
trigToExpr [TrigEq v n]
trig [Expr v n] -> [Expr v n] -> [Expr v n]
forall a. [a] -> [a] -> [a]
++ [Expr v n]
nonlin
          deps :: Dependencies v n
deps = HashMap v (HashSet v)
-> LinearMap v n
-> [TrigEq v n]
-> TrigEq2 v n
-> [Expr v n]
-> Dependencies v n
forall v n.
HashMap v (HashSet v)
-> LinearMap v n
-> [TrigEq v n]
-> TrigEq2 v n
-> [Expr v n]
-> Dependencies v n
Dependencies HashMap v (HashSet v)
vdep LinearMap v n
lin [] TrigEq2 v n
trig2' []
      in case (Dependencies v n
 -> Expr v n -> Either (DepError v n) (Dependencies v n))
-> Dependencies v n
-> [Expr v n]
-> Either (DepError v n) (Dependencies v n)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Dependencies v n
 -> Expr v n
 -> Expr v n
 -> Either (DepError v n) (Dependencies v n))
-> Expr v n
-> Dependencies v n
-> Expr v n
-> Either (DepError v n) (Dependencies v n)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Dependencies v n
-> Expr v n -> Expr v n -> Either (DepError v n) (Dependencies v n)
forall v n.
(Hashable v, Hashable n, RealFrac n, Ord v, Floating n) =>
Dependencies v n
-> Expr v n -> Expr v n -> Either (DepError v n) (Dependencies v n)
addEq0 Expr v n
forall n v. Num n => Expr v n
zeroExpr) Dependencies v n
deps
              [Expr v n]
nlWithout of
             Left DepError v n
_ -> (Dependencies v n
deps, [Expr v n]
nlWith[Expr v n] -> [Expr v n] -> [Expr v n]
forall a. [a] -> [a] -> [a]
++[Expr v n]
l) --shouldn't happen
             Right Dependencies v n
d -> (Dependencies v n
d, [Expr v n]
nlWith[Expr v n] -> [Expr v n] -> [Expr v n]
forall a. [a] -> [a] -> [a]
++[Expr v n]
l)

-- v2 = c2*v + b + c
reArrange :: (Show v, Ord v, Fractional n, Eq n) =>
             v -> LinExpr v n -> v -> (n, LinExpr v n)
reArrange :: v -> LinExpr v n -> v -> (n, LinExpr v n)
reArrange v
v2 (LinExpr n
c [(v, n)]
vars) v
v =
  case (((v, n), [(v, n)]) -> Bool)
-> [((v, n), [(v, n)])] -> Maybe ((v, n), [(v, n)])
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((v -> v -> Bool
forall a. Eq a => a -> a -> Bool
==v
v)(v -> Bool)
-> (((v, n), [(v, n)]) -> v) -> ((v, n), [(v, n)]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(v, n) -> v
forall a b. (a, b) -> a
fst((v, n) -> v)
-> (((v, n), [(v, n)]) -> (v, n)) -> ((v, n), [(v, n)]) -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((v, n), [(v, n)]) -> (v, n)
forall a b. (a, b) -> a
fst) ([((v, n), [(v, n)])] -> Maybe ((v, n), [(v, n)]))
-> [((v, n), [(v, n)])] -> Maybe ((v, n), [(v, n)])
forall a b. (a -> b) -> a -> b
$ [(v, n)] -> [((v, n), [(v, n)])]
forall a. [a] -> [(a, [a])]
select [(v, n)]
vars of
   Maybe ((v, n), [(v, n)])
Nothing ->
     String -> (n, LinExpr v n)
forall a. HasCallStack => String -> a
error (String -> (n, LinExpr v n)) -> String -> (n, LinExpr v n)
forall a b. (a -> b) -> a -> b
$ String
"Internal error: variable " String -> ShowS
forall a. [a] -> [a] -> [a]
++ v -> String
forall a. Show a => a -> String
show v
v String -> ShowS
forall a. [a] -> [a] -> [a]
++
     String
" not in linear expression "
   Just ((v
_,n
c2), [(v, n)]
r) ->
     (n
c2,
      n -> [(v, n)] -> LinExpr v n
forall v n. n -> [(v, n)] -> LinExpr v n
LinExpr (n
cn -> n -> n
forall a. Fractional a => a -> a -> a
/n -> n
forall a. Num a => a -> a
negate n
c2) [(v, n)]
r
      LinExpr v n -> LinExpr v n -> LinExpr v n
forall v n.
(Ord v, Num n, Eq n) =>
LinExpr v n -> LinExpr v n -> LinExpr v n
`addLin` n -> [(v, n)] -> LinExpr v n
forall v n. n -> [(v, n)] -> LinExpr v n
LinExpr n
0 [(v
v2, n
1n -> n -> n
forall a. Fractional a => a -> a -> a
/n
c2)])

reArrangeTrig :: (Show v, Ord t1, Ord v, Floating t1)
              => v -> Expr v t1 -> v -> Expr v t1
reArrangeTrig :: v -> Expr v t1 -> v -> Expr v t1
reArrangeTrig v
v2 (Expr LinExpr v t1
lt [TrigTerm v t1]
trig [NonLinExpr v t1]
_) v
v =
  let (t1
c2, LinExpr v t1
lt2) = v -> LinExpr v t1 -> v -> (t1, LinExpr v t1)
forall v n.
(Show v, Ord v, Fractional n, Eq n) =>
v -> LinExpr v n -> v -> (n, LinExpr v n)
reArrange v
v2 LinExpr v t1
lt v
v
  in LinExpr v t1 -> Expr v t1
forall v n. LinExpr v n -> Expr v n
LinearE LinExpr v t1
lt2 Expr v t1 -> Expr v t1 -> Expr v t1
forall a. Num a => a -> a -> a
- [TrigTerm v t1] -> Expr v t1
forall n v. Num n => [TrigTerm v n] -> Expr v n
trigExpr [TrigTerm v t1]
trig Expr v t1 -> Expr v t1 -> Expr v t1
forall a. Fractional a => a -> a -> a
/ t1 -> Expr v t1
forall v n. n -> Expr v n
ConstE t1
c2
  
elimTrig :: (Show v, Ord v, Hashable v, Floating n, Ord n) =>
            Period v n -> M.HashMap v (Expr v n) -> v
         -> ([Expr v n], M.HashMap v (Expr v n))
elimTrig :: Period v n
-> HashMap v (Expr v n) -> v -> ([Expr v n], HashMap v (Expr v n))
elimTrig Period v n
p HashMap v (Expr v n)
m v
v
  -- period contains the variable, remove all eqs
  | ((v, n) -> Bool) -> Period v n -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((v -> v -> Bool
forall a. Eq a => a -> a -> Bool
==v
v)(v -> Bool) -> ((v, n) -> v) -> (v, n) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(v, n) -> v
forall a b. (a, b) -> a
fst) Period v n
p =
      (HashMap v (Expr v n) -> [Expr v n]
forall v n.
(Ord v, Floating n, Ord n) =>
HashMap v (Expr v n) -> [Expr v n]
trig2ToExpr HashMap v (Expr v n)
m, HashMap v (Expr v n)
forall k v. HashMap k v
M.empty)
  -- the variable is dependend in:
  -- v = e (== sin(p+const) + linear)
  -- remove the eq
  | Just Expr v n
e <- v -> HashMap v (Expr v n) -> Maybe (Expr v n)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup v
v HashMap v (Expr v n)
m =
      ([v -> Expr v n
forall n v. Num n => v -> Expr v n
makeVariable v
v Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
- Expr v n
e],
       v -> HashMap v (Expr v n) -> HashMap v (Expr v n)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
M.delete v
v HashMap v (Expr v n)
m)
  -- the variable is independent in:
  -- v2 = e (== sin(p+const) + const*v + linear)
  -- rearrange, and substitute
  | Just (v
v2, Expr v n
e) <-
    ((v, Expr v n) -> Bool) -> [(v, Expr v n)] -> Maybe (v, Expr v n)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (v -> Expr v n -> Bool
forall t v. (Num t, Eq v, Eq t) => v -> Expr v t -> Bool
hasVar v
v(Expr v n -> Bool)
-> ((v, Expr v n) -> Expr v n) -> (v, Expr v n) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(v, Expr v n) -> Expr v n
forall a b. (a, b) -> b
snd) ([(v, Expr v n)] -> Maybe (v, Expr v n))
-> [(v, Expr v n)] -> Maybe (v, Expr v n)
forall a b. (a -> b) -> a -> b
$ HashMap v (Expr v n) -> [(v, Expr v n)]
forall k v. HashMap k v -> [(k, v)]
M.toList HashMap v (Expr v n)
m =
      let e2 :: Expr v n
e2 = v -> Expr v n -> v -> Expr v n
forall v t1.
(Show v, Ord t1, Ord v, Floating t1) =>
v -> Expr v t1 -> v -> Expr v t1
reArrangeTrig v
v2 Expr v n
e v
v
          substOne :: (v, n) -> Expr v n
substOne (v
v3, n
c)
            | v
v v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v3 = Expr v n
e2 Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
* n -> Expr v n
forall v n. n -> Expr v n
ConstE n
c
            | Bool
otherwise = v -> Expr v n
forall n v. Num n => v -> Expr v n
makeVariable v
v3 Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
* n -> Expr v n
forall v n. n -> Expr v n
ConstE n
c
          doSubst :: Expr v n -> Expr v n
doSubst (Expr (LinExpr n
c Period v n
lt) [TrigTerm v n]
trig [NonLinExpr v n]
_) =
            ((v, n) -> Expr v n -> Expr v n)
-> Expr v n -> Period v n -> Expr v n
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
(+)(Expr v n -> Expr v n -> Expr v n)
-> ((v, n) -> Expr v n) -> (v, n) -> Expr v n -> Expr v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(v, n) -> Expr v n
substOne) 
            (n -> Expr v n
forall v n. n -> Expr v n
ConstE n
c Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
+ [TrigTerm v n] -> Expr v n
forall n v. Num n => [TrigTerm v n] -> Expr v n
trigExpr [TrigTerm v n]
trig) Period v n
lt
      in ([v -> Expr v n
forall n v. Num n => v -> Expr v n
makeVariable v
v Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
- Expr v n
e],
          (Expr v n -> Expr v n)
-> HashMap v (Expr v n) -> HashMap v (Expr v n)
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
M.map Expr v n -> Expr v n
doSubst (HashMap v (Expr v n) -> HashMap v (Expr v n))
-> HashMap v (Expr v n) -> HashMap v (Expr v n)
forall a b. (a -> b) -> a -> b
$ v -> HashMap v (Expr v n) -> HashMap v (Expr v n)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
M.delete v
v2 HashMap v (Expr v n)
m)
  -- variable not found
  | Bool
otherwise =
    ([], HashMap v (Expr v n)
m)

dmod :: RealFrac a => a -> a -> a
dmod :: a -> a -> a
dmod a
a a
b = a -> a
forall a. Num a => a -> a
abs((a
aa -> a -> a
forall a. Fractional a => a -> a -> a
/a
b) a -> a -> a
forall a. Num a => a -> a -> a
- Integer -> a
forall a. Num a => Integer -> a
fromInteger (a -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (a
aa -> a -> a
forall a. Fractional a => a -> a -> a
/a
b)) a -> a -> a
forall a. Num a => a -> a -> a
* a
b)

-- put the variable with the maximum coefficient on the lhs of the
-- equation
splitMax :: (Ord b, Fractional b, Eq v) => LinExpr v b -> (v, b, LinExpr v b)
splitMax :: LinExpr v b -> (v, b, LinExpr v b)
splitMax (LinExpr b
c [(v, b)]
t) =
  let ((v
v,b
c2),[(v, b)]
r) = (((v, b), [(v, b)]) -> ((v, b), [(v, b)]) -> Ordering)
-> [((v, b), [(v, b)])] -> ((v, b), [(v, b)])
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (b -> b -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (b -> b -> Ordering)
-> (((v, b), [(v, b)]) -> b)
-> ((v, b), [(v, b)])
-> ((v, b), [(v, b)])
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (b -> b
forall a. Num a => a -> a
abs(b -> b) -> (((v, b), [(v, b)]) -> b) -> ((v, b), [(v, b)]) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(v, b) -> b
forall a b. (a, b) -> b
snd((v, b) -> b)
-> (((v, b), [(v, b)]) -> (v, b)) -> ((v, b), [(v, b)]) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((v, b), [(v, b)]) -> (v, b)
forall a b. (a, b) -> a
fst)) ([((v, b), [(v, b)])] -> ((v, b), [(v, b)]))
-> [((v, b), [(v, b)])] -> ((v, b), [(v, b)])
forall a b. (a -> b) -> a -> b
$
                   [(v, b)] -> [((v, b), [(v, b)])]
forall a. [a] -> [(a, [a])]
select [(v, b)]
t
  in (v
v, b
c2,
      b -> [(v, b)] -> LinExpr v b
forall v n. n -> [(v, n)] -> LinExpr v n
LinExpr (-b
cb -> b -> b
forall a. Fractional a => a -> a -> a
/b
c2) ([(v, b)] -> LinExpr v b) -> [(v, b)] -> LinExpr v b
forall a b. (a -> b) -> a -> b
$
      ((v, b) -> (v, b)) -> [(v, b)] -> [(v, b)]
forall a b. (a -> b) -> [a] -> [b]
map ((b -> b) -> (v, b) -> (v, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> b
forall a. Num a => a -> a
negate(b -> b) -> (b -> b) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(b -> b -> b
forall a. Fractional a => a -> a -> a
/b
c2))) [(v, b)]
r)
      
-- | Return True if the variable is known or dependend.
varDefined :: (Eq v, Hashable v) => v -> Dependencies v n -> Bool
varDefined :: v -> Dependencies v n -> Bool
varDefined v
v (Dependencies HashMap v (HashSet v)
_ LinearMap v n
dep [TrigEq v n]
_ TrigEq2 v n
_ [Expr v n]
_) =
  case v -> LinearMap v n -> Maybe (LinExpr v n)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup v
v LinearMap v n
dep of
    Maybe (LinExpr v n)
Nothing -> Bool
False
    Maybe (LinExpr v n)
_ -> Bool
True

-- | Return all dependend variables with their dependencies.
dependendVars :: (Eq n) => Dependencies v n -> [(v, LinExpr v n)]
dependendVars :: Dependencies v n -> [(v, LinExpr v n)]
dependendVars (Dependencies HashMap v (HashSet v)
_ LinearMap v n
lin [TrigEq v n]
_ TrigEq2 v n
_ [Expr v n]
_) =
  ((v, LinExpr v n) -> Bool)
-> [(v, LinExpr v n)] -> [(v, LinExpr v n)]
forall a. (a -> Bool) -> [a] -> [a]
filter (LinExpr v n -> Bool
forall v n. LinExpr v n -> Bool
notConst(LinExpr v n -> Bool)
-> ((v, LinExpr v n) -> LinExpr v n) -> (v, LinExpr v n) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(v, LinExpr v n) -> LinExpr v n
forall a b. (a, b) -> b
snd) (LinearMap v n -> [(v, LinExpr v n)]
forall k v. HashMap k v -> [(k, v)]
M.toList LinearMap v n
lin)
  where
    notConst :: LinExpr v n -> Bool
notConst (LinExpr n
_ []) = Bool
False
    notConst LinExpr v n
_ = Bool
True
  

-- | Return all known variables.
knownVars :: Dependencies v n -> [(v, n)]
knownVars :: Dependencies v n -> [(v, n)]
knownVars (Dependencies HashMap v (HashSet v)
_ LinearMap v n
lin [TrigEq v n]
_ TrigEq2 v n
_ [Expr v n]
_) =
  ((v, LinExpr v n) -> Maybe (v, n))
-> [(v, LinExpr v n)] -> [(v, n)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (v, LinExpr v n) -> Maybe (v, n)
forall a v b. (a, LinExpr v b) -> Maybe (a, b)
knownVar ([(v, LinExpr v n)] -> [(v, n)]) -> [(v, LinExpr v n)] -> [(v, n)]
forall a b. (a -> b) -> a -> b
$ LinearMap v n -> [(v, LinExpr v n)]
forall k v. HashMap k v -> [(k, v)]
M.toList LinearMap v n
lin
  where
    knownVar :: (a, LinExpr v b) -> Maybe (a, b)
knownVar (a
v, LinExpr b
n []) = (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
v, b
n)
    knownVar (a, LinExpr v b)
_ = Maybe (a, b)
forall a. Maybe a
Nothing

-- -- | Return all independend variables.
-- freeVars :: (Eq v, Hashable v) => Dependencies n v -> [v]
-- freeVars (Dependencies dep) =
--   HS.toList $ M.foldl' addVars HS.empty dep
--   where addVars s (LinExpr _ a) =
--           HS.union s $ HS.fromList $ map fst a

-- | Return the value of the variable, or a list of variables
-- it depends on.  Only linear dependencies are shown.
getKnown :: (Eq v, Hashable v) => v -> Dependencies v n -> Either [v] n
getKnown :: v -> Dependencies v n -> Either [v] n
getKnown v
var (Dependencies HashMap v (HashSet v)
_ LinearMap v n
lin [TrigEq v n]
_ TrigEq2 v n
_ [Expr v n]
_) =
  case v -> LinearMap v n -> Maybe (LinExpr v n)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup v
var LinearMap v n
lin of
    Maybe (LinExpr v n)
Nothing -> [v] -> Either [v] n
forall a b. a -> Either a b
Left  []
    Just (LinExpr n
a []) ->
      n -> Either [v] n
forall a b. b -> Either a b
Right n
a
    Just (LinExpr n
_ [(v, n)]
v) ->
      [v] -> Either [v] n
forall a b. a -> Either a b
Left ([v] -> Either [v] n) -> [v] -> Either [v] n
forall a b. (a -> b) -> a -> b
$ ((v, n) -> v) -> [(v, n)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (v, n) -> v
forall a b. (a, b) -> a
fst [(v, n)]
v

-- | Return all nonlinear equations @e_i@, where @e_i = 0@.
nonlinearEqs :: (Ord n, Ord v, Floating n) => Dependencies v n -> [Expr v n]
nonlinearEqs :: Dependencies v n -> [Expr v n]
nonlinearEqs  (Dependencies HashMap v (HashSet v)
_ LinearMap v n
_ [TrigEq v n]
trig TrigEq2 v n
trig2 [Expr v n]
nl) =
  (TrigEq v n -> Expr v n) -> [TrigEq v n] -> [Expr v n]
forall a b. (a -> b) -> [a] -> [b]
map TrigEq v n -> Expr v n
forall n v. (Ord n, Ord v, Floating n) => TrigEq v n -> Expr v n
trigToExpr [TrigEq v n]
trig [Expr v n] -> [Expr v n] -> [Expr v n]
forall a. [a] -> [a] -> [a]
++
  ((v, Expr v n) -> Expr v n) -> [(v, Expr v n)] -> [Expr v n]
forall a b. (a -> b) -> [a] -> [b]
map (\(v
v, Expr v n
e) -> v -> Expr v n
forall n v. Num n => v -> Expr v n
makeVariable v
v Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
- Expr v n
e) 
  ((HashMap v (Expr v n) -> [(v, Expr v n)])
-> [HashMap v (Expr v n)] -> [(v, Expr v n)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HashMap v (Expr v n) -> [(v, Expr v n)]
forall k v. HashMap k v -> [(k, v)]
M.toList (TrigEq2 v n -> [HashMap v (Expr v n)]
forall k v. HashMap k v -> [v]
M.elems TrigEq2 v n
trig2)) [Expr v n] -> [Expr v n] -> [Expr v n]
forall a. [a] -> [a] -> [a]
++
  [Expr v n]
nl
  
-- | Show all variables and equations.  Useful in combination with `execSolver`.
showVars :: (Show n, Show v, Ord n, Ord v, Floating n)
         => Either (DepError v n) (Dependencies v n) -> IO ()
showVars :: Either (DepError v n) (Dependencies v n) -> IO ()
showVars (Left DepError v n
e) = DepError v n -> IO ()
forall a. Show a => a -> IO ()
print DepError v n
e
showVars (Right Dependencies v n
dep) = Dependencies v n -> IO ()
forall a. Show a => a -> IO ()
print Dependencies v n
dep

-- | Get the dependencies from a state monad.  Specialized version of `get`.
dependencies :: (MonadState (Dependencies v n) m) => m (Dependencies v n)
dependencies :: m (Dependencies v n)
dependencies = m (Dependencies v n)
forall s (m :: * -> *). MonadState s m => m s
get

-- | Return the value of the variable or throw an error.
getValue :: (MonadState (Dependencies v n) m,
             MonadError (DepError v n) m,
             Eq v, Hashable v) =>
            v -> m n
getValue :: v -> m n
getValue v
v = do
  Either [v] n
v2 <- v -> m (Either [v] n)
forall v n (m :: * -> *).
(MonadState (Dependencies v n) m, Hashable v, Eq v) =>
v -> m (Either [v] n)
getKnownM v
v
  case Either [v] n
v2 of
   Right n
e -> n -> m n
forall (m :: * -> *) a. Monad m => a -> m a
return n
e
   Left [v]
_ -> DepError v n -> m n
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DepError v n -> m n) -> DepError v n -> m n
forall a b. (a -> b) -> a -> b
$ v -> DepError v n
forall v n. v -> DepError v n
UndefinedVar v
v

-- | Monadic version of `varDefined`.
varDefinedM :: (MonadState (Dependencies v n) m, Hashable v, Eq v) =>
               v -> m Bool
varDefinedM :: v -> m Bool
varDefinedM v
v = v -> Dependencies v n -> Bool
forall v n. (Eq v, Hashable v) => v -> Dependencies v n -> Bool
varDefined v
v (Dependencies v n -> Bool) -> m (Dependencies v n) -> m Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` m (Dependencies v n)
forall v n (m :: * -> *).
MonadState (Dependencies v n) m =>
m (Dependencies v n)
dependencies

-- | Monadic version of `getKnown`.
getKnownM :: (MonadState (Dependencies v n) m, Hashable v, Eq v) =>
             v -> m (Either [v] n)
getKnownM :: v -> m (Either [v] n)
getKnownM v
v = v -> Dependencies v n -> Either [v] n
forall v n.
(Eq v, Hashable v) =>
v -> Dependencies v n -> Either [v] n
getKnown v
v (Dependencies v n -> Either [v] n)
-> m (Dependencies v n) -> m (Either [v] n)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` m (Dependencies v n)
forall v n (m :: * -> *).
MonadState (Dependencies v n) m =>
m (Dependencies v n)
dependencies

-- | Monadic version of `eliminate`.
eliminateM :: (MonadState (Dependencies v n) m, Hashable n, Hashable v,
               Show n, Show v, RealFrac n, Ord v, Floating n) =>
              v -> m [Expr v n]
eliminateM :: v -> m [Expr v n]
eliminateM v
v = do
  Dependencies v n
dep <- m (Dependencies v n)
forall v n (m :: * -> *).
MonadState (Dependencies v n) m =>
m (Dependencies v n)
dependencies
  let (Dependencies v n
dep2, [Expr v n]
e) = Dependencies v n -> v -> (Dependencies v n, [Expr v n])
forall n v.
(Hashable n, Show n, Hashable v, RealFrac n, Ord v, Show v,
 Floating n) =>
Dependencies v n -> v -> (Dependencies v n, [Expr v n])
eliminate Dependencies v n
dep v
v
  Dependencies v n -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Dependencies v n
dep2
  [Expr v n] -> m [Expr v n]
forall (m :: * -> *) a. Monad m => a -> m a
return [Expr v n]
e

infixr 1 === , =&=

-- | Make the expressions on both sides equal
(===) :: (MonadState (Dependencies v n) m,
          MonadError (DepError v n) m,
          Eq v, Hashable v, Hashable n,
          RealFrac n, Floating n, Ord v) =>
         Expr v n -> Expr v n -> m ()
=== :: Expr v n -> Expr v n -> m ()
(===) Expr v n
lhs Expr v n
rhs = do
  Dependencies v n
deps <- m (Dependencies v n)
forall v n (m :: * -> *).
MonadState (Dependencies v n) m =>
m (Dependencies v n)
dependencies
  case Dependencies v n
-> Expr v n -> Either (DepError v n) (Dependencies v n)
forall n v.
(Hashable n, Hashable v, RealFrac n, Ord v, Floating n) =>
Dependencies v n
-> Expr v n -> Either (DepError v n) (Dependencies v n)
addEquation Dependencies v n
deps (Expr v n
lhs Expr v n -> Expr v n -> Expr v n
forall a. Num a => a -> a -> a
- Expr v n
rhs) of
   Left DepError v n
e -> DepError v n -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DepError v n
e
   Right Dependencies v n
dep -> Dependencies v n -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Dependencies v n
dep

-- | Make the pairs of expressions on both sides equal. No error is
-- signaled if the equation for one of the sides is `Redundant` for
-- example in (x, 0) == (y, 0).
(=&=) :: (MonadState (Dependencies v n) m,
          MonadError (DepError v n) m,
          Eq v, Hashable v, Hashable n,
          RealFrac n, Floating n, Ord v) =>
         (Expr v n, Expr v n) -> (Expr v n, Expr v n) -> m ()
=&= :: (Expr v n, Expr v n) -> (Expr v n, Expr v n) -> m ()
(=&=) (Expr v n
a, Expr v n
b) (Expr v n
c, Expr v n
d) =
  do m () -> (DepError v n -> m ()) -> m ()
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (Expr v n
a Expr v n -> Expr v n -> m ()
forall v n (m :: * -> *).
(MonadState (Dependencies v n) m, MonadError (DepError v n) m,
 Eq v, Hashable v, Hashable n, RealFrac n, Floating n, Ord v) =>
Expr v n -> Expr v n -> m ()
=== Expr v n
c) ((DepError v n -> m ()) -> m ()) -> (DepError v n -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \DepError v n
e ->
       case DepError v n
e of
        RedundantEq Expr v n
_ ->
          Expr v n
b Expr v n -> Expr v n -> m ()
forall v n (m :: * -> *).
(MonadState (Dependencies v n) m, MonadError (DepError v n) m,
 Eq v, Hashable v, Hashable n, RealFrac n, Floating n, Ord v) =>
Expr v n -> Expr v n -> m ()
=== Expr v n
d
        DepError v n
_ -> DepError v n -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DepError v n
e
     m () -> m ()
forall v n (m :: * -> *).
MonadError (DepError v n) m =>
m () -> m ()
ignore (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Expr v n
b Expr v n -> Expr v n -> m ()
forall v n (m :: * -> *).
(MonadState (Dependencies v n) m, MonadError (DepError v n) m,
 Eq v, Hashable v, Hashable n, RealFrac n, Floating n, Ord v) =>
Expr v n -> Expr v n -> m ()
=== Expr v n
d

-- | Succeed even when trowing a `RedundantEq` error.
ignore :: MonadError (DepError v n) m => m () -> m ()
ignore :: m () -> m ()
ignore m ()
m =
  m () -> (DepError v n -> m ()) -> m ()
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError m ()
m ((DepError v n -> m ()) -> m ()) -> (DepError v n -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \DepError v n
e ->
  case DepError v n
e of
   RedundantEq Expr v n
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
   DepError v n
_ -> DepError v n -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DepError v n
e

-- | run the solver.
runSolver :: MFSolver v n a -> Dependencies v n -> Either (DepError v n) (a, Dependencies v n)
runSolver :: MFSolver v n a
-> Dependencies v n -> Either (DepError v n) (a, Dependencies v n)
runSolver MFSolver v n a
s = Identity (Either (DepError v n) (a, Dependencies v n))
-> Either (DepError v n) (a, Dependencies v n)
forall a. Identity a -> a
runIdentity (Identity (Either (DepError v n) (a, Dependencies v n))
 -> Either (DepError v n) (a, Dependencies v n))
-> (Dependencies v n
    -> Identity (Either (DepError v n) (a, Dependencies v n)))
-> Dependencies v n
-> Either (DepError v n) (a, Dependencies v n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MFSolver v n a
-> Dependencies v n
-> Identity (Either (DepError v n) (a, Dependencies v n))
forall v n (m :: * -> *) a.
MFSolverT v n m a
-> Dependencies v n
-> m (Either (DepError v n) (a, Dependencies v n))
runSolverT MFSolver v n a
s
           
-- | Return the result of solving the equations, or throw the error as an exception.  Monadic version.
unsafeSolveT :: (Num n, Ord n, Show n, Show v, Typeable n, Typeable v, Monad m) =>
                Dependencies v n -> MFSolverT v n m a -> m a
unsafeSolveT :: Dependencies v n -> MFSolverT v n m a -> m a
unsafeSolveT Dependencies v n
dep MFSolverT v n m a
s = do
  Either (DepError v n) (a, Dependencies v n)
res <- MFSolverT v n m a
-> Dependencies v n
-> m (Either (DepError v n) (a, Dependencies v n))
forall v n (m :: * -> *) a.
MFSolverT v n m a
-> Dependencies v n
-> m (Either (DepError v n) (a, Dependencies v n))
runSolverT MFSolverT v n m a
s Dependencies v n
dep
  case Either (DepError v n) (a, Dependencies v n)
res of
   Right (a
v, Dependencies v n
_) -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
   Left DepError v n
e -> DepError v n -> m a
forall a e. Exception e => e -> a
throw DepError v n
e

-- | Return the result of solving the equations or an error.  Monadic version.
evalSolverT :: Functor f =>
               MFSolverT v n f b
            -> Dependencies v n -> f (Either (DepError v n) b)
evalSolverT :: MFSolverT v n f b
-> Dependencies v n -> f (Either (DepError v n) b)
evalSolverT MFSolverT v n f b
s Dependencies v n
dep =
  ((b, Dependencies v n) -> b)
-> Either (DepError v n) (b, Dependencies v n)
-> Either (DepError v n) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, Dependencies v n) -> b
forall a b. (a, b) -> a
fst (Either (DepError v n) (b, Dependencies v n)
 -> Either (DepError v n) b)
-> f (Either (DepError v n) (b, Dependencies v n))
-> f (Either (DepError v n) b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MFSolverT v n f b
-> Dependencies v n
-> f (Either (DepError v n) (b, Dependencies v n))
forall v n (m :: * -> *) a.
MFSolverT v n m a
-> Dependencies v n
-> m (Either (DepError v n) (a, Dependencies v n))
runSolverT MFSolverT v n f b
s Dependencies v n
dep 

-- | Run the solver and return the dependencies or an error.  Monadic version.
execSolverT :: Functor m =>
               MFSolverT v n m a
            -> Dependencies v n -> m (Either (DepError v n) (Dependencies v n))
execSolverT :: MFSolverT v n m a
-> Dependencies v n -> m (Either (DepError v n) (Dependencies v n))
execSolverT MFSolverT v n m a
s Dependencies v n
dep =
  ((a, Dependencies v n) -> Dependencies v n)
-> Either (DepError v n) (a, Dependencies v n)
-> Either (DepError v n) (Dependencies v n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, Dependencies v n) -> Dependencies v n
forall a b. (a, b) -> b
snd (Either (DepError v n) (a, Dependencies v n)
 -> Either (DepError v n) (Dependencies v n))
-> m (Either (DepError v n) (a, Dependencies v n))
-> m (Either (DepError v n) (Dependencies v n))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MFSolverT v n m a
-> Dependencies v n
-> m (Either (DepError v n) (a, Dependencies v n))
forall v n (m :: * -> *) a.
MFSolverT v n m a
-> Dependencies v n
-> m (Either (DepError v n) (a, Dependencies v n))
runSolverT MFSolverT v n m a
s Dependencies v n
dep

-- | Return the result of solving the equations, or throw the error as an exception.
unsafeSolve :: (Typeable n, Typeable v, Show n, Show v, Ord n, Num n) =>
               Dependencies v n -> MFSolver v n a -> a
unsafeSolve :: Dependencies v n -> MFSolver v n a -> a
unsafeSolve Dependencies v n
dep = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a)
-> (MFSolver v n a -> Identity a) -> MFSolver v n a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies v n -> MFSolver v n a -> Identity a
forall n v (m :: * -> *) a.
(Num n, Ord n, Show n, Show v, Typeable n, Typeable v, Monad m) =>
Dependencies v n -> MFSolverT v n m a -> m a
unsafeSolveT Dependencies v n
dep

-- | Return the result of solving the equations or an error.
evalSolver :: MFSolver v n a
           -> Dependencies v n -> Either (DepError v n) a
evalSolver :: MFSolver v n a -> Dependencies v n -> Either (DepError v n) a
evalSolver MFSolver v n a
s = Identity (Either (DepError v n) a) -> Either (DepError v n) a
forall a. Identity a -> a
runIdentity (Identity (Either (DepError v n) a) -> Either (DepError v n) a)
-> (Dependencies v n -> Identity (Either (DepError v n) a))
-> Dependencies v n
-> Either (DepError v n) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MFSolver v n a
-> Dependencies v n -> Identity (Either (DepError v n) a)
forall (f :: * -> *) v n b.
Functor f =>
MFSolverT v n f b
-> Dependencies v n -> f (Either (DepError v n) b)
evalSolverT MFSolver v n a
s

-- | Run the solver and return the dependencies or an error.
execSolver :: MFSolver v n a
           -> Dependencies v n -> Either (DepError v n) (Dependencies v n)
execSolver :: MFSolver v n a
-> Dependencies v n -> Either (DepError v n) (Dependencies v n)
execSolver MFSolver v n a
s = Identity (Either (DepError v n) (Dependencies v n))
-> Either (DepError v n) (Dependencies v n)
forall a. Identity a -> a
runIdentity (Identity (Either (DepError v n) (Dependencies v n))
 -> Either (DepError v n) (Dependencies v n))
-> (Dependencies v n
    -> Identity (Either (DepError v n) (Dependencies v n)))
-> Dependencies v n
-> Either (DepError v n) (Dependencies v n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MFSolver v n a
-> Dependencies v n
-> Identity (Either (DepError v n) (Dependencies v n))
forall (m :: * -> *) v n a.
Functor m =>
MFSolverT v n m a
-> Dependencies v n -> m (Either (DepError v n) (Dependencies v n))
execSolverT MFSolver v n a
s