rhine-bayes 1.3 → 1.4
raw patch · 2 files changed
+22/−49 lines, 2 filesdep ~rhinedep ~rhine-glossPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: rhine, rhine-gloss
API changes (from Hackage documentation)
Files
- app/Main.hs +18/−45
- rhine-bayes.cabal +4/−4
app/Main.hs view
@@ -19,18 +19,12 @@ import Control.Monad (replicateM, void) import Data.Maybe (fromMaybe) import Data.Monoid (Product (Product, getProduct))-import GHC.Float (double2Float, float2Double)+import GHC.Float (double2Float) import Text.Printf (printf) -- transformers import Control.Monad.Trans.Class --- time-import Data.Time (addUTCTime, getCurrentTime)---- mmorph-import Control.Monad.Morph- -- log-domain import Numeric.Log hiding (sum) @@ -43,14 +37,14 @@ import Data.Automaton.Trans.Except -- rhine-import FRP.Rhine+import FRP.Rhine hiding (Result) -- rhine-gloss+import FRP.Rhine.Gloss.Common import FRP.Rhine.Gloss.IO -- rhine-bayes import FRP.Rhine.Bayes-import FRP.Rhine.Gloss.Common type Temperature = Double type Pos = (Double, Double)@@ -171,7 +165,7 @@ -- | The number of particles used in the filter. Change according to available computing power. nParticles :: Int-nParticles = 400+nParticles = 200 -- * Visualization @@ -269,15 +263,8 @@ -- ** 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- }+glossClockSingleRate :: GlossClockUTC SamplerIO GlossSimClockIO+glossClockSingleRate = glossClockUTC GlossSimClockIO -- *** Poor attempt at temperature inference: Particle collapse @@ -322,7 +309,7 @@ void $ sampleIO $ launchInGlossThread glossSettings $- reactimateCl glossClock mainClSFCollapse+ reactimateCl glossClockSingleRate mainClSFCollapse -- *** Infer temperature with a stochastic process @@ -353,30 +340,18 @@ void $ sampleIO $ launchInGlossThread glossSettings $- reactimateCl glossClock mainClSF+ reactimateCl glossClockSingleRate mainClSF -- ** Multi-rate: Simulation, inference, display at different rates --- | 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 cl =- RescaledClockS- { unscaledClockS = cl- , rescaleS = const $ do- now <- liftIO getCurrentTime- return (arr $ \(timePassed, event) -> (addUTCTime (realToFrac timePassed) now, event), now)- }- {- | The part of the program which simulates latent position and sensor, running 10 times a second. -}-modelRhine :: Rhine (GlossConcT IO) (LiftClock IO GlossConcT (Millisecond 100)) Temperature (Temperature, (Sensor, Pos))-modelRhine = hoistClSF sampleIOGloss (clId &&& genModelWithoutTemperature) @@ liftClock waitClock+modelRhine :: Rhine App (GlossConcTClock SamplerIO (Millisecond 100)) Temperature (Temperature, (Sensor, Pos))+modelRhine = (clId &&& genModelWithoutTemperature) @@ glossConcTClock waitClock -- | The user can change the temperature by pressing the up and down arrow keys.-userTemperature :: ClSF (GlossConcT IO) (GlossClockUTC GlossEventClockIO) () Temperature+userTemperature :: ClSF App (GlossClockUTC SamplerIO GlossEventClockIO) () Temperature userTemperature = tagS >>> arr (selector >>> fmap Product) >>> mappendS >>> arr (fmap getProduct >>> fromMaybe 1 >>> (* initialTemperature)) where selector (EventKey (SpecialKey KeyUp) Down _ _) = Just 1.2@@ -386,8 +361,8 @@ {- | 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. -}-inference :: Rhine (GlossConcT IO) (LiftClock IO GlossConcT Busy) (Temperature, (Sensor, Pos)) Result-inference = hoistClSF sampleIOGloss inferenceBehaviour @@ liftClock Busy+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 = proc (temperature, (measured, latent)) -> do@@ -403,8 +378,8 @@ } -- | Visualize the current 'Result' at a rate controlled by the @gloss@ backend, usually 30 FPS.-visualisationRhine :: Rhine (GlossConcT IO) (GlossClockUTC GlossSimClockIO) Result ()-visualisationRhine = hoistClSF sampleIOGloss visualisation @@ glossClockUTC GlossSimClockIO+visualisationRhine :: Rhine App (GlossClockUTC SamplerIO GlossSimClockIO) Result ()+visualisationRhine = visualisation @@ glossClockUTC GlossSimClockIO {- FOURMOLU_DISABLE -} -- | Compose all four asynchronous components to a single 'Rhine'.@@ -422,8 +397,9 @@ mainMultiRate :: IO () mainMultiRate = void $- launchInGlossThread glossSettings $- flow mainRhineMultiRate+ sampleIO $+ launchInGlossThread glossSettings $+ flow mainRhineMultiRate -- * Utilities @@ -434,6 +410,3 @@ score = lift . score instance (MonadMeasure m) => MonadMeasure (GlossConcT m)--sampleIOGloss :: App a -> GlossConcT IO a-sampleIOGloss = hoist sampleIO
rhine-bayes.cabal view
@@ -1,5 +1,5 @@ name: rhine-bayes-version: 1.3+version: 1.4 synopsis: monad-bayes backend for Rhine description: This package provides a backend to the @monad-bayes@ library,@@ -26,7 +26,7 @@ source-repository this type: git location: git@github.com:turion/rhine.git- tag: v1.3+ tag: v1.4 library exposed-modules: FRP.Rhine.Bayes@@ -37,7 +37,7 @@ log-domain >=0.12, mmorph ^>=1.2, monad-bayes ^>=1.3,- rhine ==1.3,+ rhine ==1.4, transformers >=0.5 hs-source-dirs: src@@ -72,7 +72,7 @@ monad-bayes, rhine, rhine-bayes,- rhine-gloss ==1.3,+ rhine-gloss ==1.4, time, transformers