From 89180000f8949c9bedb3638dce72da8d4c8d1601 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Wed, 4 Oct 2023 17:50:52 +0200 Subject: [PATCH 1/6] WIP --- rhine-bayes/app/Main.hs | 170 +++++++++++++++++++++++----------- rhine-bayes/rhine-bayes.cabal | 1 + 2 files changed, 115 insertions(+), 56 deletions(-) diff --git a/rhine-bayes/app/Main.hs b/rhine-bayes/app/Main.hs index cfd8faa8..312a9a97 100644 --- a/rhine-bayes/app/Main.hs +++ b/rhine-bayes/app/Main.hs @@ -13,10 +13,11 @@ In this example, you will find the following: * A more scalable, modular, interactive architecture, where all these three systems run on separate clocks, and the user can interactively change the temperature of the heat bath -} +{-# LANGUAGE LambdaCase #-} module Main where -- base -import Control.Monad (replicateM, void) +import Control.Monad (replicateM, void, guard) import Data.Maybe (fromMaybe) import Data.Monoid (Product (Product, getProduct)) import GHC.Float (double2Float, float2Double) @@ -51,6 +52,10 @@ import FRP.Rhine.Gloss.IO -- rhine-bayes import FRP.Rhine.Bayes import FRP.Rhine.Gloss.Common +import FRP.Rhine.Gloss (GlossEventClock) +import Control.Monad.Schedule.Class (MonadSchedule (..)) +import Unsafe.Coerce (unsafeCoerce) +import Control.Monad.Trans.Reader (ReaderT(ReaderT)) type Temperature = Double type Pos = (Double, Double) @@ -267,7 +272,7 @@ glossSettings = mains :: [(String, IO ())] mains = [ ("single rate", mainSingleRate) - , ("single rate, parameter collapse", mainSingleRateCollapse) + , ("multi rate, parameter collapse", mainMultiRateCollapse) , ("multi rate, temperature process", mainMultiRate) ] @@ -289,51 +294,6 @@ glossClock = , 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. --} -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, @@ -379,20 +339,109 @@ glossClockUTC cl = return (arr $ \(timePassed, event) -> (addUTCTime (realToFrac timePassed) now, event), now) } +type ModelClock = LiftClock IO GlossConcT (Millisecond 100) + +-- | The model is sampled at 100 FPS. +modelClock :: ModelClock +modelClock = liftClock waitClock + {- | The part of the program which simulates latent position and sensor, running 100 times a second. -} -modelRhine :: Rhine (GlossConcT IO) (LiftClock IO GlossConcT (Millisecond 100)) Temperature (Temperature, (Sensor, Pos)) -modelRhine = hoistClSF sampleIOGloss (clId &&& genModelWithoutTemperature) @@ liftClock waitClock +model :: ClSF (GlossConcT IO) ModelClock Temperature (Temperature, (Sensor, Pos)) +model = hoistClSF sampleIOGloss (clId &&& genModelWithoutTemperature) + +-- | The user can change the temperature by pressing the up and down arrow keys, +-- or press the "r" key. +data UserInput + = TemperatureFactor (Product Double) + | ResetKey + deriving Eq + +type UserClock = SelectClock (GlossClockUTC GlossEventClockIO) UserInput + +userClock :: UserClock +userClock = SelectClock + { mainClock = glossClockUTC GlossEventClockIO + , select = \case + EventKey (SpecialKey KeyUp) Down _ _ -> Just $ TemperatureFactor $ Product 1.2 + EventKey (SpecialKey KeyDown) Down _ _ -> Just $ TemperatureFactor $ Product $ 1 / 1.2 + EventKey (Char 'r') Down _ _ -> Just ResetKey + _ -> Nothing + } --- | The user can change the temperature by pressing the up and down arrow keys. -userTemperature :: ClSF (GlossConcT IO) (GlossClockUTC GlossEventClockIO) () Temperature -userTemperature = tagS >>> arr (selector >>> fmap Product) >>> mappendS >>> arr (fmap getProduct >>> fromMaybe 1 >>> (* initialTemperature)) +userTemperature :: ClSF (GlossConcT IO) UserClock () Temperature +userTemperature = tagS >>> arr selector >>> mappendS >>> arr (fmap getProduct >>> fromMaybe 1 >>> (* initialTemperature)) where - selector (EventKey (SpecialKey KeyUp) Down _ _) = Just 1.2 - selector (EventKey (SpecialKey KeyDown) Down _ _) = Just (1 / 1.2) + selector (TemperatureFactor factor) = Just factor selector _ = Nothing +-- *** 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 (Bool, Sensor) (Temperature, Pos) +posteriorTemperatureCollapse = proc (resetTemperature, sensor) -> do + temperature <- cache temperaturePrior -< resetTemperature + latent <- prior -< temperature + arrM score -< sensorLikelihood latent sensor + returnA -< (temperature, latent) + where + cache :: Monad m => m b -> BehaviourF m td Bool b + cache action = feedback Nothing $ proc (invalidateCache, bLast) -> do + let bCached = guard (not invalidateCache) >> bLast + bNew <- case bCached of + Nothing -> do + constMCl action -< () + Just b -> do + returnA -< b + returnA -< (bNew, Just bNew) + +{- | 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. +-} +inferenceCollapse :: Rhine (GlossConcT IO) (LiftClock IO GlossConcT Busy) (Bool, (Temperature, (Sensor, Pos))) Result +inferenceCollapse = hoistClSF sampleIOGloss inferenceBehaviour @@ liftClock Busy + where + inferenceBehaviour :: (MonadDistribution m, Diff td ~ Double, MonadIO m) => BehaviourF m td (Bool, (Temperature, (Sensor, Pos))) Result + inferenceBehaviour = proc (reset, (temperature, (measured, latent))) -> do + positionsAndTemperatures <- runPopulationCl nParticles resampleSystematic posteriorTemperatureCollapse -< (reset, measured) + returnA + -< + Result + { temperature + , measured + , latent + , particlesPosition = first snd <$> positionsAndTemperatures + , particlesTemperature = first fst <$> positionsAndTemperatures + } + +mainRhineMultiRateCollapse = + (tagS &&& userTemperature) + @@ userClock + >-- collect *-* keepLast initialTemperature --> + (clId *** model) @@ modelClock + >-- reset *-* keepLast (initialTemperature, (zeroVector, zeroVector)) --> + inferenceCollapse + >-- keepLast emptyResult --> + visualisationRhine + where + -- | Whether the user pressed the reset key + reset :: Monad m => ResamplingBuffer m cl1 cl2 [UserInput] Bool + reset = collect >>-^ arr (concat >>> filter (== ResetKey) >>> not . null) + +mainMultiRateCollapse = void $ + launchInGlossThread glossSettings $ + flow mainRhineMultiRateCollapse + +-- *** Multi rate with stochastic process + {- | This part performs the inference (and passes along temperature, sensor and position simulations). It runs as fast as possible, so this will potentially drain the CPU. -} @@ -420,9 +469,9 @@ visualisationRhine = hoistClSF sampleIOGloss visualisation @@ glossClockUTC Glos -- | Compose all four asynchronous components to a single 'Rhine'. mainRhineMultiRate = userTemperature - @@ glossClockUTC GlossEventClockIO + @@ userClock >-- keepLast initialTemperature --> - modelRhine + model @@ modelClock >-- keepLast (initialTemperature, (zeroVector, zeroVector)) --> inference >-- keepLast emptyResult --> @@ -447,3 +496,12 @@ instance (MonadMeasure m) => MonadMeasure (GlossConcT m) sampleIOGloss :: App a -> GlossConcT IO a sampleIOGloss = hoist sampleIO + +unsafeMkSampler :: ReaderT g m a -> Sampler g m a +unsafeMkSampler = unsafeCoerce + +runSampler :: Sampler g m a -> ReaderT g m a +runSampler = ReaderT . sampleWith + +instance (Monad m, MonadSchedule m) => MonadSchedule (Sampler g m) where + schedule = unsafeMkSampler . fmap (second (map unsafeMkSampler)) . schedule . fmap runSampler diff --git a/rhine-bayes/rhine-bayes.cabal b/rhine-bayes/rhine-bayes.cabal index 89c0a4af..14f1291e 100644 --- a/rhine-bayes/rhine-bayes.cabal +++ b/rhine-bayes/rhine-bayes.cabal @@ -69,6 +69,7 @@ executable rhine-bayes-gloss , log-domain , mmorph , time + , monad-schedule default-language: Haskell2010 default-extensions: Arrows From 0adbdb4f2bfc435ec86774c3b12c5a54b7604214 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Fri, 11 Aug 2023 14:48:35 +0200 Subject: [PATCH 2/6] DROP remove time and make window smaller --- rhine-bayes/app/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/rhine-bayes/app/Main.hs b/rhine-bayes/app/Main.hs index 312a9a97..3d56d184 100644 --- a/rhine-bayes/app/Main.hs +++ b/rhine-bayes/app/Main.hs @@ -205,7 +205,7 @@ visualisation = proc Result {temperature, measured, latent, particlesPosition, p [0 ..] [ printf "Temperature: %.2f" temperature , printf "Particles: %i" $ length particlesPosition - , printf "Time: %.1f" time + -- , printf "Time: %.1f" time ] return $ translate 0 ((-150) * n) $ text message , color red $ rectangleUpperSolid thermometerWidth $ double2Float temperature * thermometerScale @@ -263,7 +263,7 @@ drawParticlesTemperature = proc particlesPosition -> do glossSettings :: GlossSettings glossSettings = defaultSettings - { display = InWindow "rhine-bayes" (1024, 960) (10, 10) + { display = InWindow "rhine-bayes" (650, 780) (10, 10) } -- * Integration From d5a8cf97a92486797cc0172f40442c1d3e5ccd45 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Fri, 11 Aug 2023 15:55:30 +0200 Subject: [PATCH 3/6] Increase number of particles to 200 --- rhine-bayes/app/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/rhine-bayes/app/Main.hs b/rhine-bayes/app/Main.hs index 3d56d184..9b97d9fc 100644 --- a/rhine-bayes/app/Main.hs +++ b/rhine-bayes/app/Main.hs @@ -176,7 +176,7 @@ emptyResult = -- | The number of particles used in the filter. Change according to available computing power. nParticles :: Int -nParticles = 100 +nParticles = 200 -- * Visualization From bed71fb8859aa2b429d9f3a0557f2fa9fee8ad6e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Fri, 1 Sep 2023 16:22:10 +0200 Subject: [PATCH 4/6] CHERRY? document spring constant --- rhine-bayes/app/Main.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/rhine-bayes/app/Main.hs b/rhine-bayes/app/Main.hs index 9b97d9fc..93ec515c 100644 --- a/rhine-bayes/app/Main.hs +++ b/rhine-bayes/app/Main.hs @@ -75,7 +75,8 @@ prior1d :: StochasticProcessF td Temperature Double prior1d initialPosition initialVelocity = feedback 0 $ proc (temperature, position') -> do impulse <- whiteNoiseVarying -< temperature - let acceleration = (-3) * position' + impulse + let springConstant = 3 + acceleration = (- springConstant) * 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 position <- integralFrom initialPosition -< velocity From 61315a6ed0a4b07477ecb362a4c4306dcd2213ef Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Thu, 29 Aug 2024 10:56:12 +0200 Subject: [PATCH 5/6] Revert "Increase number of particles to 200" This reverts commit d5a8cf97a92486797cc0172f40442c1d3e5ccd45. --- rhine-bayes/app/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/rhine-bayes/app/Main.hs b/rhine-bayes/app/Main.hs index 93ec515c..6c5156e8 100644 --- a/rhine-bayes/app/Main.hs +++ b/rhine-bayes/app/Main.hs @@ -177,7 +177,7 @@ emptyResult = -- | The number of particles used in the filter. Change according to available computing power. nParticles :: Int -nParticles = 200 +nParticles = 100 -- * Visualization From 1e3c531dcf56081bc266217253af356b6a4deceb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Thu, 29 Aug 2024 10:56:20 +0200 Subject: [PATCH 6/6] Revert "DROP remove time and make window smaller" This reverts commit 0adbdb4f2bfc435ec86774c3b12c5a54b7604214. --- rhine-bayes/app/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/rhine-bayes/app/Main.hs b/rhine-bayes/app/Main.hs index 6c5156e8..2f071f82 100644 --- a/rhine-bayes/app/Main.hs +++ b/rhine-bayes/app/Main.hs @@ -206,7 +206,7 @@ visualisation = proc Result {temperature, measured, latent, particlesPosition, p [0 ..] [ printf "Temperature: %.2f" temperature , printf "Particles: %i" $ length particlesPosition - -- , printf "Time: %.1f" time + , printf "Time: %.1f" time ] return $ translate 0 ((-150) * n) $ text message , color red $ rectangleUpperSolid thermometerWidth $ double2Float temperature * thermometerScale @@ -264,7 +264,7 @@ drawParticlesTemperature = proc particlesPosition -> do glossSettings :: GlossSettings glossSettings = defaultSettings - { display = InWindow "rhine-bayes" (650, 780) (10, 10) + { display = InWindow "rhine-bayes" (1024, 960) (10, 10) } -- * Integration