rhine-bayes 1.0 → 1.1

raw patch · 5 files changed

+136/−46 lines, 5 filesdep ~dunaidep ~monad-bayesdep ~rhinePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: dunai, monad-bayes, rhine

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• app/Main.hs +116/−32
• rhine-bayes.cabal +7/−6
• src/Data/MonadicStreamFunction/Bayes.hs +3/−3
• src/FRP/Rhine/Bayes.hs +5/−5

@@ -1,5 +1,10 @@ # Revision history for rhine-gloss +## 1.1++* dunai-0.11 compatibility+* Extended example application by particle collapse+ ## 1.0  * Removed schedules. See the [page about changes in version 1](/version1.md).

@@ -39,6 +39,9 @@ import Control.Monad.Bayes.Population hiding (hoist) import Control.Monad.Bayes.Sampler.Strict +-- dunai+import Control.Monad.Trans.MSF.Except+ -- rhine import FRP.Rhine @@ -68,7 +71,7 @@ prior1d initialPosition initialVelocity = feedback 0 $ proc (temperature, position') -> do   impulse <- whiteNoiseVarying -< temperature   let acceleration = (-3) * position' + impulse-  -- Integral over roughly the last 100 seconds, dying off exponentially, as to model a small friction term+  -- Integral over roughly the last 10 seconds, dying off exponentially, as to model a small friction term   velocity <- arr (+ initialVelocity) <<< decayIntegral 10 -< acceleration   position <- integralFrom initialPosition -< velocity   returnA -< (position, position)@@ -151,10 +154,21 @@   { temperature :: Temperature   , measured :: Sensor   , latent :: Pos-  , particles :: [((Temperature, Pos), Log Double)]+  , particlesPosition :: [(Pos, Log Double)]+  , particlesTemperature :: [(Temperature, Log Double)]   }   deriving (Show) +-- | A 'Result' where nothing has been inferred yet+emptyResult =+  Result+    { temperature = initialTemperature+    , measured = zeroVector+    , latent = zeroVector+    , particlesPosition = []+    , particlesTemperature = []+    }+ -- | The number of particles used in the filter. Change according to available computing power. nParticles :: Int nParticles = 100@@ -172,8 +186,8 @@ type App = GlossConcT SamplerIO  -- | Draw the results of the simulation and inference-visualisation :: Diff td ~ Double => BehaviourF App td Result ()-visualisation = proc Result {temperature, measured, latent, particles} -> do+visualisation :: (Diff td ~ Double) => BehaviourF App td Result ()+visualisation = proc Result {temperature, measured, latent, particlesPosition, particlesTemperature} -> do   constMCl clearIO -< ()   time <- sinceInitS -< ()   arrMCl paintIO@@ -185,7 +199,7 @@                 zip                   [0 ..]                   [ printf "Temperature: %.2f" temperature-                  , printf "Particles: %i" $ length particles+                  , printf "Particles: %i" $ length particlesPosition                   , printf "Time: %.1f" time                   ]               return $ translate 0 ((-150) * n) $ text message@@ -193,7 +207,8 @@           ]   drawBall -< (measured, 0.3, red)   drawBall -< (latent, 0.3, green)-  drawParticles -< particles+  drawParticles -< particlesPosition+  drawParticlesTemperature -< particlesTemperature  -- ** Parameters for the temperature display @@ -215,19 +230,31 @@ drawBall = proc (position, width, theColor) -> do   arrMCl paintIO -< scale 20 20 $ uncurry translate (double2FloatTuple position) $ color theColor $ circleSolid $ double2Float width -drawParticle :: BehaviourF App td ((Temperature, Pos), Log Double) ()-drawParticle = proc ((temperature, position), probability) -> do+drawParticle :: BehaviourF App td (Pos, Log Double) ()+drawParticle = proc (position, probability) -> do   drawBall -< (position, 0.1, withAlpha (double2Float $ exp $ 0.2 * ln probability) white)++drawParticleTemperature :: BehaviourF App td (Temperature, Log Double) ()+drawParticleTemperature = proc (temperature, probability) -> do   arrMCl paintIO -< toThermometer $ translate 0 (double2Float temperature * thermometerScale) $ color (withAlpha (double2Float $ exp $ 0.2 * ln probability) white) $ rectangleSolid thermometerWidth 2 -drawParticles :: BehaviourF App td [((Temperature, Pos), Log Double)] ()-drawParticles = proc particles -> do-  case particles of+drawParticles :: BehaviourF App td [(Pos, Log Double)] ()+drawParticles = proc particlesPosition -> do+  case particlesPosition of     [] -> returnA -< ()     p : ps -> do       drawParticle -< p       drawParticles -< ps +-- FIXME abstract using a library+drawParticlesTemperature :: BehaviourF App td [(Temperature, Log Double)] ()+drawParticlesTemperature = proc particlesPosition -> do+  case particlesPosition of+    [] -> returnA -< ()+    p : ps -> do+      drawParticleTemperature -< p+      drawParticlesTemperature -< ps+ glossSettings :: GlossSettings glossSettings =   defaultSettings@@ -240,6 +267,7 @@ mains :: [(String, IO ())] mains =   [ ("single rate", mainSingleRate)+  , ("single rate, parameter collapse", mainSingleRateCollapse)   , ("multi rate, temperature process", mainMultiRate)   ] @@ -251,38 +279,86 @@  -- ** Single-rate : One simulation step = one inference step = one display step +-- | Rescale to the 'Double' time domain+type GlossClock = RescaledClock GlossSimClockIO Double++glossClock :: GlossClock+glossClock =+  RescaledClock+    { unscaledClock = GlossSimClockIO+    , rescale = float2Double+    }++-- *** Poor attempt at temperature inference: Particle collapse++-- | Choose an exponential distribution as prior for the temperature+temperaturePrior :: (MonadDistribution m) => m Temperature+temperaturePrior = gamma 1 7++{- | On startup, sample values from the temperature prior.+  Then keep sampling from the position prior and condition by the likelihood of the measured sensor position.+-}+posteriorTemperatureCollapse :: (MonadMeasure m, Diff td ~ Double) => BehaviourF m td Sensor (Temperature, Pos)+posteriorTemperatureCollapse = proc sensor -> do+  temperature <- performOnFirstSample (arr_ <$> temperaturePrior) -< ()+  latent <- prior -< temperature+  arrM score -< sensorLikelihood latent sensor+  returnA -< (temperature, latent)+ {- | Given an actual temperature, simulate a latent position and measured sensor position,    and based on the sensor data infer the latent position and the temperature. -}-filtered :: Diff td ~ Double => BehaviourF App td Temperature Result+filteredCollapse :: (Diff td ~ Double) => BehaviourF App td Temperature Result+filteredCollapse = proc temperature -> do+  (measured, latent) <- genModelWithoutTemperature -< temperature+  particlesAndTemperature <- runPopulationCl nParticles resampleSystematic posteriorTemperatureCollapse -< measured+  returnA+    -<+      Result+        { temperature+        , measured+        , latent+        , particlesPosition = first snd <$> particlesAndTemperature+        , particlesTemperature = first fst <$> particlesAndTemperature+        }++-- | Run simulation, inference, and visualization synchronously+mainClSFCollapse :: (Diff td ~ Double) => BehaviourF App td () ()+mainClSFCollapse = proc () -> do+  output <- filteredCollapse -< initialTemperature+  visualisation -< output++mainSingleRateCollapse =+  void $+    sampleIO $+      launchInGlossThread glossSettings $+        reactimateCl glossClock mainClSFCollapse++-- *** Infer temperature with a stochastic process++{- | Given an actual temperature, simulate a latent position and measured sensor position,+   and based on the sensor data infer the latent position and the temperature.+-}+filtered :: (Diff td ~ Double) => BehaviourF App td Temperature Result filtered = proc temperature -> do   (measured, latent) <- genModelWithoutTemperature -< temperature-  particles <- runPopulationCl nParticles resampleSystematic posteriorTemperatureProcess -< measured+  positionsAndTemperatures <- runPopulationCl nParticles resampleSystematic posteriorTemperatureProcess -< measured   returnA     -<       Result         { temperature         , measured         , latent-        , particles+        , particlesPosition = first snd <$> positionsAndTemperatures+        , particlesTemperature = first fst <$> positionsAndTemperatures         }  -- | Run simulation, inference, and visualization synchronously-mainClSF :: Diff td ~ Double => BehaviourF App td () ()+mainClSF :: (Diff td ~ Double) => BehaviourF App td () () mainClSF = proc () -> do   output <- filtered -< initialTemperature   visualisation -< output --- | Rescale to the 'Double' time domain-type GlossClock = RescaledClock GlossSimClockIO Double--glossClock :: GlossClock-glossClock =-  RescaledClock-    { unscaledClock = GlossSimClockIO-    , rescale = float2Double-    }- mainSingleRate =   void $     sampleIO $@@ -294,7 +370,7 @@ -- | Rescale the gloss clocks so they will be compatible with real 'UTCTime' (needed for compatibility with 'Millisecond') type GlossClockUTC cl = RescaledClockS (GlossConcT IO) cl UTCTime (Tag cl) -glossClockUTC :: Real (Time cl) => cl -> GlossClockUTC cl+glossClockUTC :: (Real (Time cl)) => cl -> GlossClockUTC cl glossClockUTC cl =   RescaledClockS     { unscaledClockS = cl@@ -325,8 +401,16 @@   where     inferenceBehaviour :: (MonadDistribution m, Diff td ~ Double, MonadIO m) => BehaviourF m td (Temperature, (Sensor, Pos)) Result     inferenceBehaviour = proc (temperature, (measured, latent)) -> do-      particles <- runPopulationCl nParticles resampleSystematic posteriorTemperatureProcess -< measured-      returnA -< Result {temperature, measured, latent, particles}+      positionsAndTemperatures <- runPopulationCl nParticles resampleSystematic posteriorTemperatureProcess -< measured+      returnA+        -<+          Result+            { temperature+            , measured+            , latent+            , particlesPosition = first snd <$> positionsAndTemperatures+            , particlesTemperature = first fst <$> positionsAndTemperatures+            }  -- | Visualize the current 'Result' at a rate controlled by the @gloss@ backend, usually 30 FPS. visualisationRhine :: Rhine (GlossConcT IO) (GlossClockUTC GlossSimClockIO) Result ()@@ -341,7 +425,7 @@         modelRhine         >-- keepLast (initialTemperature, (zeroVector, zeroVector)) -->           inference-            >-- keepLast Result {temperature = initialTemperature, measured = zeroVector, latent = zeroVector, particles = []} -->+            >-- keepLast emptyResult -->               visualisationRhine {- FOURMOLU_ENABLE -} @@ -353,13 +437,13 @@  -- * Utilities -instance MonadDistribution m => MonadDistribution (GlossConcT m) where+instance (MonadDistribution m) => MonadDistribution (GlossConcT m) where   random = lift random -instance MonadFactor m => MonadFactor (GlossConcT m) where+instance (MonadFactor m) => MonadFactor (GlossConcT m) where   score = lift . score -instance MonadMeasure m => MonadMeasure (GlossConcT m)+instance (MonadMeasure m) => MonadMeasure (GlossConcT m)  sampleIOGloss :: App a -> GlossConcT IO a sampleIOGloss = hoist sampleIO

@@ -1,8 +1,8 @@ name:                rhine-bayes-version:             1.0+version:             1.1 synopsis:            monad-bayes backend for Rhine description:-  This package provides a backend to the `monad-bayes` library,+  This package provides a backend to the @monad-bayes@ library,   enabling you to write stochastic processes as signal functions,   and performing online machine learning on them. license:             BSD3@@ -23,7 +23,7 @@ source-repository this   type:     git   location: git@github.com:turion/rhine.git-  tag:      v1.0+  tag:      v1.1  library   exposed-modules:@@ -32,10 +32,10 @@     Data.MonadicStreamFunction.Bayes   build-depends:       base         >= 4.11 && < 4.18                      , transformers >= 0.5-                     , rhine        == 1.0-                     , dunai        ^>= 0.9+                     , rhine        == 1.1+                     , dunai        ^>= 0.11                      , log-domain   >= 0.12-                     , monad-bayes  >= 1.1.0+                     , monad-bayes  ^>= 1.1   hs-source-dirs:      src   default-language:    Haskell2010   default-extensions:@@ -63,6 +63,7 @@                      , rhine                      , rhine-bayes                      , rhine-gloss+                     , dunai                      , monad-bayes                      , transformers                      , log-domain

@@ -20,7 +20,7 @@ -- | Run the Sequential Monte Carlo algorithm continuously on an 'MSF' runPopulationS ::   forall m a b.-  Monad m =>+  (Monad m) =>   -- | Number of particles   Int ->   -- | Resampler@@ -32,7 +32,7 @@  -- | Run the Sequential Monte Carlo algorithm continuously on a 'Population' of 'MSF's runPopulationsS ::-  Monad m =>+  (Monad m) =>   -- | Resampler   (forall x. Population m x -> Population m x) ->   Population m (MSF (Population m) a b) ->@@ -49,5 +49,5 @@             (swap . fmap fst &&& swap . fmap snd) . swap <$> bAndMSFs  -- FIXME see PR re-adding this to monad-bayes-normalize :: Monad m => Population m a -> Population m a+normalize :: (Monad m) => Population m a -> Population m a normalize = fromWeightedList . fmap (\particles -> second (/ (sum $ snd <$> particles)) <$> particles) . runPopulation

@@ -24,7 +24,7 @@ -- | Run the Sequential Monte Carlo algorithm continuously on a 'ClSF'. runPopulationCl ::   forall m cl a b.-  Monad m =>+  (Monad m) =>   -- | Number of particles   Int ->   -- | Resampler (see 'Control.Monad.Bayes.Population' for some standard choices)@@ -40,10 +40,10 @@ -- * Short standard library of stochastic processes  -- | A stochastic process is a behaviour that uses, as only effect, random sampling.-type StochasticProcess time a = forall m. MonadDistribution m => Behaviour m time a+type StochasticProcess time a = forall m. (MonadDistribution m) => Behaviour m time a  -- | Like 'StochasticProcess', but with a live input.-type StochasticProcessF time a b = forall m. MonadDistribution m => BehaviourF m time a b+type StochasticProcessF time a b = forall m. (MonadDistribution m) => BehaviourF m time a b  -- | White noise, that is, an independent normal distribution at every time step. whiteNoise :: Double -> StochasticProcess td Double@@ -110,7 +110,7 @@ poissonInhomogeneous ::   (MonadDistribution m, Real (Diff td), Fractional (Diff td)) =>   BehaviourF m td (Diff td) Int-poissonInhomogeneous = arrM $ \rate -> ReaderT $ \diffTime -> poisson $ realToFrac $ sinceLast diffTime / rate+poissonInhomogeneous = arrM $ \rate -> ReaderT $ \timeInfo -> poisson $ realToFrac $ sinceLast timeInfo / rate  -- | Like 'poissonInhomogeneous', but the rate is constant. poissonHomogeneous ::@@ -138,5 +138,5 @@   Throws a coin to a given probability at each tick.   The live input is the probability. -}-bernoulliInhomogeneous :: MonadDistribution m => BehaviourF m td Double Bool+bernoulliInhomogeneous :: (MonadDistribution m) => BehaviourF m td Double Bool bernoulliInhomogeneous = arrMCl bernoulli