module RSAGL.Animation.AnimationExtras
(rotationA,
animateA,
rotateA,
pointAtCameraA,
inverseSquareLaw,
quadraticTrap,
drag,
concatForces,
constrainForce,
singleParticle,
particleSystem,
PV,
PVA,
ForceFunction)
where
import RSAGL.Math.Vector
import RSAGL.FRP
import RSAGL.Math.AbstractVector
import Control.Arrow
import Control.Arrow.Operations
import RSAGL.Scene.CoordinateSystems
import RSAGL.Math.Affine
import RSAGL.Math.Angle
import RSAGL.Scene.Scene
import RSAGL.Modeling.Model
import RSAGL.Scene.WrappedAffine
import Control.Monad
import RSAGL.Math.Types
import Debug.Trace
rotationA :: Vector3D -> Rate Angle -> FRP e m ignored AffineTransformation
rotationA v a = proc _ ->
do t <- absoluteTime -< ()
returnA -< rotate v (a `over` t)
animateA :: (CoordinateSystemClass s,StateOf m ~ s) => FRP e m j AffineTransformation -> FRP e m j p -> FRP e m j p
animateA affineA action = proc i ->
do at <- affineA -< i
transformA action -< (affineOf at,i)
rotateA :: (CoordinateSystemClass s,StateOf m ~ s) => Vector3D -> Rate Angle -> FRP e m j p -> FRP e m j p
rotateA v a = animateA (rotationA v a)
pointAtCameraA :: (Arrow a,ArrowState s a,CoordinateSystemClass s,ScenicAccumulator s m,ModelType model) => a (SceneLayer,m model) ()
pointAtCameraA = proc (slayer,the_model) ->
do cs <- arr getCoordinateSystem <<< fetch -< ()
accumulateSceneA -< (slayer,cameraRelativeSceneObject $ \c ->
liftM ((rotateToFrom (vectorToFrom (migrateToFrom root_coordinate_system cs $ camera_position c) $ origin_point_3d)
(Vector3D 0 1 0)) . wrapAffine) (liftM toIntermediateModel the_model))
type PV = (Point3D,Rate Vector3D)
type PVA = (Point3D,Rate Vector3D,Acceleration Vector3D)
type ForceFunction = Time -> Point3D -> Rate Vector3D -> Acceleration Vector3D
inverseSquareLaw :: RSdouble -> Point3D -> ForceFunction
inverseSquareLaw g attractor _ p _ =
if l > 0
then perSecond $ perSecond $ vectorScaleTo (g * recip l) v
else zero
where l = vectorLengthSquared v
v = vectorToFrom attractor p
quadraticTrap :: RSdouble -> Point3D -> ForceFunction
quadraticTrap g attractor _ p _ = perSecond $ perSecond $ vectorScaleTo (g * vectorLengthSquared v) v
where v = vectorToFrom attractor p
drag :: RSdouble -> ForceFunction
drag x _ _ v' = perSecond $ perSecond $ vectorScaleTo (negate $ x * vectorLengthSquared v) v
where v = v' `over` fromSeconds 1
concatForces :: [ForceFunction] -> ForceFunction
concatForces ffs t p v = abstractSum $ map (\f -> f t p v) ffs
constrainForce :: (Time -> Point3D -> Rate Vector3D -> Bool) -> ForceFunction -> ForceFunction
constrainForce predicate f t p v = if predicate t p v
then f t p v
else zero
singleParticle :: (CoordinateSystemClass s,StateOf m ~ s) =>
Frequency -> PV -> FRP e m ForceFunction PVA
singleParticle f pv = proc force_function ->
do (p,v) <- integralRK4' f (flip translate) pv -< force_function
a <- derivative -< v
returnA -< (p,v,a)
particleSystem :: (CoordinateSystemClass s,StateOf m ~ s) =>
Frequency -> [PV] -> FRP e m ([PV] -> ForceFunction) [PVA]
particleSystem f particles = proc force_function ->
do (ps',vs') <- integralRK4' f (zipWith $ flip translate) (second pack $ unzip particles) -<
\t ps vs -> packa $ zipWith (force_function (zip ps (unpack vs)) t) ps (unpack vs)
as' <- derivative -< vs'
returnA -< zip3 ps' (unpack vs') (unpacka as')