module Simulation.Aivika.Dynamics.UVar
(UVar,
uvarQueue,
uvarChanged,
uvarChanged_,
newUVar,
readUVar,
writeUVar,
modifyUVar,
freezeUVar) where
import Control.Monad
import Data.Array
import Data.Array.IO.Safe
import Data.IORef
import Simulation.Aivika.Dynamics.Internal.Simulation
import Simulation.Aivika.Dynamics.Internal.Dynamics
import Simulation.Aivika.Dynamics.EventQueue
import Simulation.Aivika.Dynamics.Internal.Signal
import qualified Simulation.Aivika.UVector as UV
data UVar a =
UVar { uvarQueue :: EventQueue,
uvarRun :: Dynamics (),
uvarXS :: UV.UVector Double,
uvarYS :: UV.UVector a,
uvarChangedSource :: SignalSource a,
uvarUpdatedSource :: SignalSource a }
newUVar :: (MArray IOUArray a IO) => EventQueue -> a -> Simulation (UVar a)
newUVar q a =
Simulation $ \r ->
do xs <- UV.newVector
ys <- UV.newVector
UV.appendVector xs $ spcStartTime $ runSpecs r
UV.appendVector ys a
s <- invokeSimulation r newSignalSourceUnsafe
u <- invokeSimulation r $ newSignalSourceWithUpdate $ runQueue q
return UVar { uvarQueue = q,
uvarRun = runQueue q,
uvarXS = xs,
uvarYS = ys,
uvarChangedSource = s,
uvarUpdatedSource = u }
readUVar :: (MArray IOUArray a IO) => UVar a -> Dynamics a
readUVar v =
Dynamics $ \p ->
do invokeDynamics p $ uvarRun v
let xs = uvarXS v
ys = uvarYS v
t = pointTime p
count <- UV.vectorCount xs
let i = count 1
x <- UV.readVector xs i
if x <= t
then UV.readVector ys i
else do i <- UV.vectorBinarySearch xs t
if i >= 0
then UV.readVector ys i
else UV.readVector ys $ (i + 1) 1
writeUVar :: (MArray IOUArray a IO) => UVar a -> a -> Dynamics ()
writeUVar v a =
Dynamics $ \p ->
do let xs = uvarXS v
ys = uvarYS v
t = pointTime p
s = uvarChangedSource v
count <- UV.vectorCount xs
let i = count 1
x <- UV.readVector xs i
if t < x
then error "Cannot update the past data: writeUVar."
else if t == x
then UV.writeVector ys i $! a
else do UV.appendVector xs t
UV.appendVector ys $! a
invokeDynamics p $ triggerSignal s a
modifyUVar :: (MArray IOUArray a IO) => UVar a -> (a -> a) -> Dynamics ()
modifyUVar v f =
Dynamics $ \p ->
do invokeDynamics p $ uvarRun v
let xs = uvarXS v
ys = uvarYS v
t = pointTime p
s = uvarChangedSource v
count <- UV.vectorCount xs
let i = count 1
x <- UV.readVector xs i
if t < x
then error "Cannot update the past data: modifyUVar."
else if t == x
then do a <- UV.readVector ys i
let b = f a
UV.writeVector ys i $! b
invokeDynamics p $ triggerSignal s b
else do i <- UV.vectorBinarySearch xs t
if i >= 0
then do a <- UV.readVector ys i
let b = f a
UV.appendVector xs t
UV.appendVector ys $! b
invokeDynamics p $ triggerSignal s b
else do a <- UV.readVector ys $ (i + 1) 1
let b = f a
UV.appendVector xs t
UV.appendVector ys $! b
invokeDynamics p $ triggerSignal s b
freezeUVar :: (MArray IOUArray a IO) =>
UVar a -> Dynamics (Array Int Double, Array Int a)
freezeUVar v =
Dynamics $ \p ->
do invokeDynamics p $ uvarRun v
xs <- UV.freezeVector (uvarXS v)
ys <- UV.freezeVector (uvarYS v)
return (xs, ys)
uvarChanged :: UVar a -> Signal a
uvarChanged v = merge2Signals m1 m2
where m1 = publishSignal (uvarUpdatedSource v)
m2 = publishSignal (uvarChangedSource v)
uvarChanged_ :: UVar a -> Signal ()
uvarChanged_ v = mapSignal (const ()) $ uvarChanged v
invokeDynamics :: Point -> Dynamics a -> IO a
invokeDynamics p (Dynamics m) = m p
invokeSimulation :: Run -> Simulation a -> IO a
invokeSimulation r (Simulation m) = m r