diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -47,7 +47,17 @@ import FRP.Rhine.Bayes type Temperature = Double -type Pos = (Double, Double) +newtype Pos1d = Pos1d {getPos1 :: Double} + deriving stock (Show) + deriving newtype (Eq, Floating, Fractional, Num) + +instance VectorSpace Pos1d (Seconds Double) where + zeroVector = Pos1d 0 + Seconds s *^ Pos1d x = Pos1d $ s * x + (^+^) = (+) + dot (Pos1d x) (Pos1d y) = Seconds $ x * y + +type Pos = (Pos1d, Pos1d) type Sensor = Pos -- * Model @@ -56,14 +66,14 @@ -- | Harmonic oscillator with white noise prior1d :: - (Diff td ~ Double) => + (Diff td ~ Seconds Double) => -- | Starting position - Double -> + Pos1d -> -- | Starting velocity - Double -> - StochasticProcessF td Temperature Double + Pos1d -> + StochasticProcessF td Temperature Pos1d prior1d initialPosition initialVelocity = feedback 0 $ proc (temperature, position') -> do - impulse <- whiteNoiseVarying -< temperature + impulse <- arr Pos1d <<< whiteNoiseVarying -< temperature let acceleration = (-3) * position' + impulse -- Integral over roughly the last 10 seconds, dying off exponentially, as to model a small friction term velocity <- arr (+ initialVelocity) <<< decayIntegral 10 -< acceleration @@ -71,7 +81,7 @@ returnA -< (position, position) -- | 2D harmonic oscillator with noise -prior :: (MonadDistribution m, Diff td ~ Double) => BehaviourF m td Temperature Pos +prior :: (MonadDistribution m, Diff td ~ Seconds Double) => BehaviourF m td Temperature Pos prior = prior1d 10 0 &&& prior1d 0 10 -- ** Observation @@ -86,10 +96,10 @@ -- | A generative model of the sensor noise noise :: StochasticProcess td Pos -noise = whiteNoise sensorNoiseTemperature &&& whiteNoise sensorNoiseTemperature +noise = (Pos1d <$> whiteNoise sensorNoiseTemperature) &&& (Pos1d <$> whiteNoise sensorNoiseTemperature) -- | A generative model of the sensor position, given the noise -generativeModel :: (Diff td ~ Double) => StochasticProcessF td Pos Sensor +generativeModel :: (Diff td ~ Seconds Double) => StochasticProcessF td Pos Sensor generativeModel = proc latent -> do noiseNow <- noise -< () returnA -< latent ^+^ noiseNow @@ -98,7 +108,7 @@ as to be used in the inference later. -} sensorLikelihood :: Pos -> Sensor -> Log Double -sensorLikelihood (posX, posY) (sensorX, sensorY) = normalPdf posX sensorNoiseTemperature sensorX * normalPdf posY sensorNoiseTemperature sensorY +sensorLikelihood (posX, posY) (sensorX, sensorY) = normalPdf (getPos1 posX) sensorNoiseTemperature (getPos1 sensorX) * normalPdf (getPos1 posY) sensorNoiseTemperature (getPos1 sensorY) -- ** User behaviour @@ -107,7 +117,7 @@ initialTemperature = 7 -- | We assume the user changes the temperature randomly every 3 seconds. -temperatureProcess :: (MonadDistribution m, Diff td ~ Double) => BehaviourF m td () Temperature +temperatureProcess :: (MonadDistribution m, Diff td ~ Seconds Double) => BehaviourF m td () Temperature temperatureProcess = -- Draw events from a Poisson process with a rate of one event per 3 seconds poissonHomogeneous 3 @@ -127,7 +137,7 @@ {- | Generate a random position and sensor value, given a temperature. Used for simulating a situation upon which we will perform inference. -} -genModelWithoutTemperature :: (MonadDistribution m, Diff td ~ Double) => BehaviourF m td Temperature (Sensor, Pos) +genModelWithoutTemperature :: (MonadDistribution m, Diff td ~ Seconds Double) => BehaviourF m td Temperature (Sensor, Pos) genModelWithoutTemperature = proc temperature -> do latent <- prior -< temperature sensor <- generativeModel -< latent @@ -136,7 +146,7 @@ {- | Given sensor data, sample a latent position and a temperature, and weight them according to the likelihood of the observed sensor position. Used to infer position and temperature. -} -posteriorTemperatureProcess :: (MonadMeasure m, Diff td ~ Double) => BehaviourF m td Sensor (Temperature, Pos) +posteriorTemperatureProcess :: (MonadMeasure m, Diff td ~ Seconds Double) => BehaviourF m td Sensor (Temperature, Pos) posteriorTemperatureProcess = proc sensor -> do temperature <- temperatureProcess -< () latent <- prior -< temperature @@ -170,8 +180,8 @@ -- * Visualization -- | Internal utility because `gloss` operates on floats -double2FloatTuple :: (Double, Double) -> (Float, Float) -double2FloatTuple = double2Float *** double2Float +pos2FloatTuple :: Pos -> (Float, Float) +pos2FloatTuple = (double2Float . getPos1) *** (double2Float . getPos1) {- | The monad in which our program will run. 'SamplerIO' is for the probabilistic effects from @monad-bayes@, @@ -180,7 +190,7 @@ type App = GlossConcT SamplerIO -- | Draw the results of the simulation and inference -visualisation :: (Diff td ~ Double) => BehaviourF App td Result () +visualisation :: (Diff td ~ Seconds Double) => BehaviourF App td Result () visualisation = proc Result {temperature, measured, latent, particlesPosition, particlesTemperature} -> do constMCl clearIO -< () time <- sinceInitS -< () @@ -194,7 +204,7 @@ [0 ..] [ printf "Temperature: %.2f" temperature , printf "Particles: %i" $ length particlesPosition - , printf "Time: %.1f" time + , printf "Time: %.1f" $ getSeconds time ] return $ translate 0 ((-150) * n) $ text message , color red $ rectangleUpperSolid thermometerWidth $ double2Float temperature * thermometerScale @@ -222,7 +232,7 @@ drawBall :: BehaviourF App td (Pos, Double, Color) () drawBall = proc (position, width, theColor) -> do - arrMCl paintIO -< scale 20 20 $ uncurry translate (double2FloatTuple position) $ color theColor $ circleSolid $ double2Float width + arrMCl paintIO -< scale 20 20 $ uncurry translate (pos2FloatTuple position) $ color theColor $ circleSolid $ double2Float width drawParticle :: BehaviourF App td (Pos, Log Double) () drawParticle = proc (position, probability) -> do @@ -275,7 +285,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 :: (MonadMeasure m, Diff td ~ Seconds Double) => BehaviourF m td Sensor (Temperature, Pos) posteriorTemperatureCollapse = proc sensor -> do temperature <- performOnFirstSample (arr_ <$> temperaturePrior) -< () latent <- prior -< temperature @@ -285,7 +295,7 @@ {- | 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. -} -filteredCollapse :: (Diff td ~ Double) => BehaviourF App td Temperature Result +filteredCollapse :: (Diff td ~ Seconds Double) => BehaviourF App td Temperature Result filteredCollapse = proc temperature -> do (measured, latent) <- genModelWithoutTemperature -< temperature particlesAndTemperature <- runPopulationCl nParticles resampleSystematic posteriorTemperatureCollapse -< measured @@ -300,7 +310,7 @@ } -- | Run simulation, inference, and visualization synchronously -mainClSFCollapse :: (Diff td ~ Double) => BehaviourF App td () () +mainClSFCollapse :: (Diff td ~ Seconds Double) => BehaviourF App td () () mainClSFCollapse = proc () -> do output <- filteredCollapse -< initialTemperature visualisation -< output @@ -316,7 +326,7 @@ {- | 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 :: (Diff td ~ Seconds Double) => BehaviourF App td Temperature Result filtered = proc temperature -> do (measured, latent) <- genModelWithoutTemperature -< temperature positionsAndTemperatures <- runPopulationCl nParticles resampleSystematic posteriorTemperatureProcess -< measured @@ -331,7 +341,7 @@ } -- | Run simulation, inference, and visualization synchronously -mainClSF :: (Diff td ~ Double) => BehaviourF App td () () +mainClSF :: (Diff td ~ Seconds Double) => BehaviourF App td () () mainClSF = proc () -> do output <- filtered -< initialTemperature visualisation -< output @@ -364,7 +374,7 @@ inference :: Rhine App (GlossConcTClock SamplerIO (Millisecond 100)) (Temperature, (Sensor, Pos)) Result inference = inferenceBehaviour @@ glossConcTClock waitClock -inferenceBehaviour :: (MonadDistribution m, Diff td ~ Double, MonadIO m) => BehaviourF m td (Temperature, (Sensor, Pos)) Result +inferenceBehaviour :: (MonadDistribution m, Diff td ~ Seconds Double, MonadIO m) => BehaviourF m td (Temperature, (Sensor, Pos)) Result inferenceBehaviour = proc (temperature, (measured, latent)) -> do positionsAndTemperatures <- runPopulationCl nParticles resampleSystematic posteriorTemperatureProcess -< measured returnA diff --git a/rhine-bayes.cabal b/rhine-bayes.cabal --- a/rhine-bayes.cabal +++ b/rhine-bayes.cabal @@ -1,12 +1,13 @@ +cabal-version: 2.2 name: rhine-bayes -version: 1.6 +version: 1.7 synopsis: monad-bayes backend for Rhine description: 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 +license: BSD-3-Clause license-file: LICENSE author: Manuel Bärenz maintainer: programming@manuelbaerenz.de @@ -17,8 +18,6 @@ ChangeLog.md README.md -cabal-version: 2.0 - source-repository head type: git location: git@github.com:turion/rhine.git @@ -28,28 +27,26 @@ location: git@github.com:turion/rhine.git tag: v1.6 -library - exposed-modules: FRP.Rhine.Bayes - other-modules: Data.Automaton.Bayes +common opts build-depends: automaton, base >=4.16 && <4.22, log-domain >=0.12, mmorph ^>=1.2, monad-bayes ^>=1.3.0.5, - rhine ^>=1.6, - transformers >=0.5 + rhine ^>=1.7, + transformers >=0.5, - hs-source-dirs: src - default-language: Haskell2010 default-extensions: Arrows DataKinds DeriveFunctor + DerivingStrategies FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses + NamedFieldPuns RankNTypes ScopedTypeVariables TupleSections @@ -60,42 +57,27 @@ if flag(dev) ghc-options: -Werror + default-language: Haskell2010 +library + import: opts + exposed-modules: FRP.Rhine.Bayes + other-modules: Data.Automaton.Bayes + hs-source-dirs: src + executable rhine-bayes-gloss + import: opts main-is: Main.hs hs-source-dirs: app build-depends: - automaton, - base >=4.16 && <4.22, - log-domain, - mmorph, - monad-bayes, - rhine, rhine-bayes, - rhine-gloss ^>=1.6, + rhine-gloss ^>=1.7, time, - transformers - default-language: Haskell2010 - default-extensions: - Arrows - DataKinds - FlexibleContexts - NamedFieldPuns - RankNTypes - TupleSections - TypeApplications - TypeFamilies - TypeOperators - ghc-options: - -W -threaded -rtsopts -with-rtsopts=-N - - if flag(dev) - ghc-options: -Werror flag dev description: Enable warnings as errors. Active on ci. diff --git a/src/FRP/Rhine/Bayes.hs b/src/FRP/Rhine/Bayes.hs --- a/src/FRP/Rhine/Bayes.hs +++ b/src/FRP/Rhine/Bayes.hs @@ -29,10 +29,11 @@ Int -> -- | Resampler (see 'Control.Monad.Bayes.PopulationT' for some standard choices) (forall x m. (MonadDistribution m) => PopulationT m x -> PopulationT m x) -> - -- | A signal function modelling the stochastic process on which to perform inference. - -- @a@ represents observations upon which the model should condition, using e.g. 'score'. - -- It can also additionally contain hyperparameters. - -- @b@ is the type of estimated current state. + {- | A signal function modelling the stochastic process on which to perform inference. + @a@ represents observations upon which the model should condition, using e.g. 'score'. + It can also additionally contain hyperparameters. + @b@ is the type of estimated current state. + -} ClSF (PopulationT m) cl a b -> ClSF m cl a [(b, Log Double)] runPopulationCl nParticles resampler = AutomatonReader.readerS . AutomatonBayes.runPopulationS nParticles resampler . AutomatonReader.runReaderS