{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeFamilies #-}
{-# LANGUAGE Trustworthy #-}
module Physics.Learn.StateSpace
( StateSpace(..)
, (.-^)
, Time
, DifferentialEquation
, InitialValueProblem
, EvolutionMethod
, SolutionMethod
, stepSolution
, eulerMethod
)
where
import Data.AdditiveGroup
( AdditiveGroup(..)
)
import Data.VectorSpace
( VectorSpace(..)
)
import Physics.Learn.Position
( Position
, shiftPosition
, displacement
)
import Physics.Learn.CarrotVec
( Vec
, (^*)
, (^-^)
)
infixl 6 .+^, .-^
infix 6 .-.
class (VectorSpace (Diff p), Fractional (Scalar (Diff p))) => StateSpace p where
type Diff p
(.-.) :: p -> p -> Diff p
(.+^) :: p -> Diff p -> p
type Time p = Scalar (Diff p)
(.-^) :: StateSpace p => p -> Diff p -> p
p .-^ v = p .+^ negateV v
instance StateSpace Double where
type Diff Double = Double
(.-.) = (-)
(.+^) = (+)
instance StateSpace Vec where
type Diff Vec = Vec
(.-.) = (^-^)
(.+^) = (^+^)
instance StateSpace Position where
type Diff Position = Vec
(.-.) = flip displacement
(.+^) = flip shiftPosition
instance (StateSpace p, StateSpace q, Time p ~ Time q) => StateSpace (p,q) where
type Diff (p,q) = (Diff p, Diff q)
(p,q) .-. (p',q') = (p .-. p', q .-. q')
(p,q) .+^ (u,v) = (p .+^ u, q .+^ v)
instance (StateSpace p, StateSpace q, StateSpace r, Time p ~ Time q
,Time q ~ Time r) => StateSpace (p,q,r) where
type Diff (p,q,r) = (Diff p, Diff q, Diff r)
(p,q,r) .-. (p',q',r') = (p .-. p', q .-. q', r .-. r')
(p,q,r) .+^ (u,v,w) = (p .+^ u, q .+^ v, r .+^ w)
inf :: a -> [a]
inf x = x : inf x
instance AdditiveGroup v => AdditiveGroup [v] where
zeroV = inf zeroV
(^+^) = zipWith (^+^)
negateV = map negateV
instance VectorSpace v => VectorSpace [v] where
type Scalar [v] = Scalar v
c *^ xs = [c *^ x | x <- xs]
instance StateSpace p => StateSpace [p] where
type Diff [p] = [Diff p]
(.-.) = zipWith (.-.)
(.+^) = zipWith (.+^)
type DifferentialEquation state = state -> Diff state
type InitialValueProblem state = (DifferentialEquation state, state)
type SolutionMethod state = InitialValueProblem state -> [state]
type EvolutionMethod state
= DifferentialEquation state
-> Time state
-> state
-> state
stepSolution :: EvolutionMethod state -> Time state -> SolutionMethod state
stepSolution ev dt (de, ic) = iterate (ev de dt) ic
eulerMethod :: StateSpace state => EvolutionMethod state
eulerMethod de dt st = st .+^ de st ^* dt