diff options
Diffstat (limited to 'src/PPL/Sampling.hs')
| -rw-r--r-- | src/PPL/Sampling.hs | 41 |
1 files changed, 14 insertions, 27 deletions
diff --git a/src/PPL/Sampling.hs b/src/PPL/Sampling.hs index 2d0c380..5ad346d 100644 --- a/src/PPL/Sampling.hs +++ b/src/PPL/Sampling.hs @@ -14,7 +14,6 @@ import Control.Exception (evaluate) import Control.Monad.IO.Class import Control.Monad.Trans.State import Data.Bifunctor -import qualified Data.HashMap.Strict as M import Data.Monoid import GHC.Exts.Heap import Numeric.Log @@ -27,12 +26,14 @@ import System.Random (StdGen, random, randoms) import qualified System.Random as R import Data.IORef import Control.Monad -import Debug.Trace +import qualified Data.Vector.Hashtables as H +import qualified Data.Vector as V mh :: (MonadIO m) => StdGen -> Double -> Meas a -> Stream (Of (a, Log Double)) m () mh g p m = do let (g0, g1) = R.split g - omega <- liftIO $ newIORef (mempty, g0) + hm <- liftIO $ H.initialize 0 + omega <- liftIO $ newIORef (hm, g0) let (x, w) = head $ samples m $ newTree omega step g1 omega x w where @@ -49,27 +50,13 @@ mh g p m = do yield (x'', w'') step g2 omega'' x'' w'' - mutate :: MonadIO m => StdGen -> IORef (M.HashMap [Int] Double, StdGen) -> m (IORef (M.HashMap [Int] Double, StdGen)) - mutate g omega = do - (m, g0) <- liftIO $ readIORef omega - {-let (r:q:_) = R.randoms g - ks = M.keys m - k = ks !! floor (r * join traceShow (fromIntegral (length ks))) - m' = M.insert k q m - liftIO $ newIORef $ (m',g0)-} - liftIO $ newIORef $ (,g0) $ flip evalState g $ mapM go m - - where - go x = do - g <- get - let (r, g1) = R.random g - (y, g2) = R.random g1 - if r < p - then do - put g2 - pure y - else do - put g1 - pure x - - + mutate :: MonadIO m => StdGen -> IORef (HashMap [Bool] Double, StdGen) -> m (IORef (HashMap [Bool] Double, StdGen)) + mutate g omega = liftIO $ do + (m, g0) <- readIORef omega + m' <- H.clone m + ks <- H.keys m + let (rs, qs) = splitAt (1 + floor (p * (n-1))) (R.randoms g) + n = fromIntegral (V.length ks) + zipWithM (\r q -> H.insert m' (ks V.! floor (r * n)) q) rs qs + newIORef (m',g0) + |