Permalink
Browse files

Implements dust vortexes and ascendants in terms of multi-particle ph…

…ysical systems. Still needs work.
  • Loading branch information...
1 parent 5238c38 commit 29906f0565eabfa568a92f04d38eb2c2e11d18c9 @clanehin committed Feb 15, 2011
@@ -71,30 +71,61 @@ androsynthAvatar = genericCreatureAvatar $ proc () ->
glower :: (FRPModel m, FRPModes m ~ RoguestarModes,
ThreadIDOf m ~ Maybe Integer) =>
- LibraryModel -> Point3D -> FRP e m () ()
-glower library_model p_init = proc () ->
+ LibraryModel -> FRP e m (Point3D, Rate Vector3D, Acceleration Vector3D) ()
+glower library_model = proc (p,_,_) ->
do local_origin <- exportToA root_coordinate_system -< origin_point_3d
- transformA (accelerationModel fps120 (p_init,zero)
- (proc () ->
- do a <- derivative <<< derivative <<< exportToA root_coordinate_system -< origin_point_3d
- returnA -< concatForces [quadraticTrap 10 p_init,
- drag 1.0,
- \_ _ _ -> scalarMultiply (-1) a,
- \_ p _ -> perSecond $ perSecond $ vectorNormalize $
- vectorToFrom p_init p `crossProduct` (Vector3D 0 1 0)])
- (proc (_,()) -> libraryPointAtCamera -< (scene_layer_local,library_model))) -<
- (translateToFrom local_origin origin_point_3d $ root_coordinate_system,())
+ transformA libraryPointAtCamera -<
+ (translateToFrom p origin_point_3d $ -- use absolute positioning
+ translateToFrom local_origin origin_point_3d $
+ root_coordinate_system,
+ (scene_layer_local,library_model))
+ returnA -< ()
+
+starting_particles :: [(Point3D,Rate Vector3D)]
+starting_particles = [
+ (Point3D 0 0.8 0.8,zero),
+ (Point3D 0 0.15 (-0.15),zero),
+ (Point3D 0.21 0.21 0,zero),
+ (Point3D (-0.26) 0.26 0,zero),
+ (Point3D 0 0.3 0.3,zero),
+ (Point3D 0 0.33 (-0.33),zero),
+ (Point3D 0.35 0.35 0,zero),
+ (Point3D (-0.36) 0.36 0,zero)]
particleAvatar :: (FRPModel m) => LibraryModel -> (Maybe RGB) -> CreatureAvatar e m
particleAvatar library_model m_color = genericCreatureAvatar $ proc () ->
- do glower library_model (Point3D 0 0.8 0.8) -< ()
- glower library_model (Point3D 0 0.15 (-0.15)) -< ()
- glower library_model (Point3D 0.21 0.21 0) -< ()
- glower library_model (Point3D (-0.26) 0.26 0) -< ()
- glower library_model (Point3D 0 0.3 0.3) -< ()
- glower library_model (Point3D 0 0.33 (-0.33)) -< ()
- glower library_model (Point3D 0.35 0.35 0) -< ()
- glower library_model (Point3D (-0.36) 0.36 0) -< ()
+ do a <- inertia root_coordinate_system origin_point_3d -< ()
+ particles <- particleSystem fps120 starting_particles -<
+ \particles ->
+ concatForces
+ -- Bind the entire system to the origin of the local coordinate system.
+ [quadraticTrap 10 origin_point_3d,
+ -- Damp down runaway behavior.
+ drag 1.0,
+ -- apply inertia.
+ \_ _ _ -> a,
+ -- Repulse points that get too close.
+ concatForces $ map (\cloud_point ->
+ constrainForce (\_ p _ -> distanceBetween p cloud_point > 0.001)
+ (scalarMultiply (-1) $ inverseSquareLaw 0.5 cloud_point))
+ (map fst particles),
+ -- Attract points that wonder too far away.
+ concatForces $ map (quadraticTrap 10 . fst) particles,
+ -- Swirl points around the y axis.
+ \_ p _ -> perSecond $ perSecond $ vectorNormalize $
+ vectorToFrom origin_point_3d p `crossProduct` (Vector3D 0 1 0),
+ -- Bounce off the ground.
+ constrainForce (\ _ (Point3D _ y _) _ -> y <= 0) $
+ \_ (Point3D _ y _) _ -> perSecond $ perSecond $ Vector3D 0 (-100*y) 0
+ ]
+ glower library_model -< particles !! 0
+ glower library_model -< particles !! 1
+ glower library_model -< particles !! 2
+ glower library_model -< particles !! 3
+ glower library_model -< particles !! 4
+ glower library_model -< particles !! 5
+ glower library_model -< particles !! 6
+ glower library_model -< particles !! 7
accumulateSceneA -< (scene_layer_local,
lightSource $
case m_color of
@@ -105,8 +136,8 @@ particleAvatar library_model m_color = genericCreatureAvatar $ proc () ->
Nothing -> NoLight)
t <- threadTime -< ()
wield_point <- exportCoordinateSystem -< translate (rotateY (fromRotations $ t `cyclical'` (fromSeconds 3)) $ Vector3D 0.25 0.5 0)
- returnA -< CreatureThreadOutput {
- cto_wield_point = wield_point }
+ returnA -< (CreatureThreadOutput {
+ cto_wield_point = wield_point })
ascendantAvatar :: (FRPModel m) => CreatureAvatar e m
ascendantAvatar = particleAvatar (SimpleModel AscendantGlow) $ Just light_blue
View
@@ -32,13 +32,18 @@ number_of_frames :: Integer
number_of_frames = 6000
--number_of_frames = 60
+plotMoon :: (FRPModel m) => FRP e (SimpleSwitch k () (SceneAccumulator IO) i o m) (IO BakedModel) (CSN Point3D)
+plotMoon = proc baked_model ->
+ do accumulateSceneA -< (std_scene_layer_infinite+2,sceneObject baked_model)
+ exportA -< origin_point_3d
+
moon_orbital_animation :: (FRPModel m) => FRP e (SimpleSwitch k () (SceneAccumulator IO) i o m) (IO BakedModel) (CSN Point3D)
-moon_orbital_animation =
- accelerationModel (perSecond 60)
- (Point3D (-6) 0 0,perSecond $ Vector3D 0.0 0.14 0.18)
- (arr $ const $ inverseSquareLaw 1.0 origin_point_3d)
- (proc (_,im) -> do rotateA (Vector3D 0 1 0) (perSecond $ fromDegrees 20) accumulateSceneA -< (std_scene_layer_infinite+2,sceneObject im)
- exportA -< origin_point_3d)
+moon_orbital_animation = proc baked_model ->
+ do let force = inverseSquareLaw 1.0 origin_point_3d
+ (p,_,_) <- singleParticle (perSecond 60)
+ (Point3D (-6) 0 0,perSecond $ Vector3D 0.0 0.14 0.18) -< force
+ transformA (rotateA (Vector3D 0 1 0) (perSecond $ fromDegrees 20) plotMoon) -<
+ (Affine $ translate $ vectorToFrom p origin_point_3d, baked_model)
walking_orb_animation :: (FRPModel m) =>
BakedModel ->
@@ -56,7 +56,7 @@ accumulateNumerical frequency accumF initial_value = proc i ->
integralRK4 :: (AbstractVector v) => Frequency -> (p -> v -> p) -> p -> FRP e m (Time -> p -> Rate v) p
integralRK4 f addPV = accumulateNumerical f (\diffF p abs_t delta_t -> integrateRK4 addPV diffF p (abs_t `sub` delta_t) abs_t)
-integralRK4' :: (AbstractVector v) => Frequency -> (p -> v -> p) -> (p,Rate v) ->
+integralRK4' :: (AbstractVector v) => Frequency -> (p -> v -> p) -> (p,Rate v) ->
FRP e m (Time -> p -> Rate v -> Acceleration v) (p,Rate v)
integralRK4' f addPV = accumulateNumerical f (\diffF p abs_t delta_t -> integrateRK4' addPV diffF p (abs_t `sub` delta_t) abs_t)
@@ -379,12 +379,12 @@ frpFix thread = FRP $ \frp_init -> FactoryArrow $
return $ Kleisli $ \i -> lift $
do s <- getProgramState frp_init
absolute_time <- liftM frpstate_absolute_time $ getFRPState frp_init
- liftM fst $ mfix $ \(_,x) ->
- do result <- unsafeRunFRPProgram absolute_time ((i,x),s) nested_frp_init
+ liftM fst $ mfix $ \ox ->
+ do result <- unsafeRunFRPProgram absolute_time ((i,snd ox),s) nested_frp_init
case result of
- Just ((o,x'),s') ->
+ Just (ox',s') ->
do putProgramState frp_init s'
- return (o,x')
+ return ox'
Nothing ->
do error "frpFix: unexpected non-singualr result."
@@ -21,6 +21,10 @@ module RSAGL.FRP.Time
day,
month,
year,
+ pack,
+ unpack,
+ packa,
+ unpacka,
fromSeconds,
toSeconds,
getTime,
@@ -114,9 +118,21 @@ toSeconds :: Time -> RSdouble
toSeconds (Time t) = fromInteger t / time_resolution
getTime :: IO Time
-getTime =
+getTime =
do (TOD secs picos) <- getClockTime
return $ Time $ secs * time_resolution + (picos * time_resolution) `div` 1000000000000
+
+pack :: [Rate a] -> Rate [a]
+pack = Rate . map (\(Rate a) -> a)
+
+unpack :: Rate [a] -> [Rate a]
+unpack (Rate as) = map perSecond as
+
+unpacka :: Acceleration [a] -> [Acceleration a]
+unpacka (Rate (Rate as)) = map (Rate . Rate) as
+
+packa :: [Acceleration a] -> Acceleration [a]
+packa = Rate . Rate . map (\(Rate (Rate a)) -> a)
\end{code}
\subsection{Modulo Division for Time}
@@ -139,6 +139,17 @@ instance (AbstractMagnitude a,AbstractMagnitude b) => AbstractMagnitude (a,b) wh
instance (AbstractVector a,AbstractVector b) => AbstractVector (a,b)
+-- Functions
+
+instance (AbstractAdd a a') => AbstractAdd ((->) x a) ((->) x a') where
+ add a b = \x -> a x `add` b x
+
+instance (AbstractSubtract a a') => AbstractSubtract ((->) x a) ((->) x a') where
+ sub a b = \x -> a x `sub` b x
+
+instance (AbstractScale a) => AbstractScale ((->) x a) where
+ scalarMultiply d f = scalarMultiply d . f
+
-- RSfloat
instance AbstractAdd RSfloat RSfloat where
@@ -179,12 +190,23 @@ instance AbstractZero RSdouble where
-- Lists
+instance (AbstractZero a) => AbstractZero [a] where
+ zero = repeat zero
+
+instance (AbstractAdd a b) => AbstractAdd [a] [b] where
+ add = zipWith add
+
+instance (AbstractSubtract a b) => AbstractSubtract [a] [b] where
+ sub = zipWith sub
+
instance (AbstractScale a) => AbstractScale [a] where
scalarMultiply d = map (scalarMultiply d)
instance (AbstractMagnitude a) => AbstractMagnitude [a] where
magnitude = sqrt . sum . map ((^2) . magnitude)
+instance (AbstractVector a) => AbstractVector [a] where
+
-- Generic functions.
-- | Force a vector to the specified magnitude.
@@ -294,5 +294,5 @@ orthos :: Vector3D -> (Vector3D,Vector3D)
orthos v@(Vector3D x y z) | abs y >= abs x && abs z >= abs x = fixOrtho2 v (Vector3D (abs x + abs y + abs z) y z)
orthos v@(Vector3D x y z) | abs x >= abs y && abs z >= abs y = fixOrtho2 v (Vector3D x (abs x + abs y + abs z) z)
orthos v@(Vector3D x y z) | abs x >= abs z && abs y >= abs z = fixOrtho2 v (Vector3D x y (abs x + abs y + abs z))
-orthos _ = error "orthos: NaN"
+orthos v = error $ "orthos: (" ++ show v ++ ")"
\end{code}
@@ -10,7 +10,8 @@ module RSAGL.Animation.AnimationExtras
drag,
concatForces,
constrainForce,
- accelerationModel)
+ singleParticle,
+ particleSystem)
where
import RSAGL.Math.Vector
@@ -26,6 +27,7 @@ import RSAGL.Modeling.Model
import RSAGL.Scene.WrappedAffine
import Control.Monad
import RSAGL.Math.Types
+import Debug.Trace
-- | Answers a continuous rotation.
rotationA :: Vector3D -> Rate Angle -> FRP e m ignored AffineTransformation
@@ -63,8 +65,12 @@ type ForceFunction = Time -> Point3D -> Rate Vector3D -> Acceleration Vector3D
-- | An energy-conserving force function describing gravitational attraction.
-- Accepts the intensity and singularity of the vector field.
inverseSquareLaw :: RSdouble -> Point3D -> ForceFunction
-inverseSquareLaw g attractor _ p _ = perSecond $ perSecond $ vectorScaleTo (g * (recip $ vectorLengthSquared v)) v
- where v = vectorToFrom attractor p
+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
-- | An energy-conserving force function that increases in
-- intensity with distance.
@@ -89,11 +95,19 @@ constrainForce predicate f t p v = if predicate t p v
else zero
-- | Apply a varying force function to a particle.
-accelerationModel :: (CoordinateSystemClass s,StateOf m ~ s) =>
- Frequency -> PV -> FRP e m j ForceFunction ->
- FRP e m (PVA,j) p -> FRP e m j p
-accelerationModel f pv forceA actionA = proc j ->
- do (p,v) <- integralRK4' f (flip translate) pv <<< forceA -< j
+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
- transformA actionA -< (affineOf $ translate (vectorToFrom p origin_point_3d),((p,v,a),j))
+ returnA -< (p,v,a)
+
+-- | Apply a varying force function to a system of particles.
+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')
@@ -1,14 +1,15 @@
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeFamilies, Arrows #-}
module RSAGL.Animation.KinematicSensors
- (odometer)
+ (odometer,
+ inertia)
where
import Control.Arrow
import RSAGL.Math.Vector
import RSAGL.FRP
import RSAGL.Scene.CoordinateSystems
-import RSAGL.Math.Types
+import RSAGL.Math
-- | Measures the distance traveled, by the origin of the local coordinate
-- system, as measured in a remote coordinate system, in terms
@@ -25,3 +26,9 @@ odometer cs measurement_vector_ =
integral 0
where measurement_vector = vectorNormalize measurement_vector_
+-- | Measures the (presumed) acceleration due to inertia of a point
+-- in the local coordinate system, relative to a (presumably) inertial frame a reference.
+inertia :: (CoordinateSystemClass s,StateOf m ~ s) =>
+ CoordinateSystem -> Point3D -> FRP e m () (Acceleration Vector3D)
+inertia cs p = proc () -> arr (scalarMultiply (-1)) <<< derivative <<< derivative <<< exportToA cs -< p
+

0 comments on commit 29906f0

Please sign in to comment.