├── Setup.hs ├── examples ├── robot-door-1.png ├── robot-door-2.png ├── robot-door-3.png ├── door-particles.xcf ├── door-particles-2.xcf ├── family.hs ├── coins.hs ├── drug-test.hs ├── spam.hs └── Probability.hs ├── TODO ├── Data ├── Probability │ ├── Rational.hs │ └── Base.hs └── Probability.hs ├── README ├── Control └── Monad │ ├── Distribution │ ├── Rational.hs │ └── Base.hs │ ├── Distribution.hs │ ├── Perhaps.hs │ └── MonoidValue.hs ├── ProbabilityMonads.cabal ├── LICENSE └── .setup-config /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/robot-door-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/emk/haskell-probability-monads/HEAD/examples/robot-door-1.png -------------------------------------------------------------------------------- /examples/robot-door-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/emk/haskell-probability-monads/HEAD/examples/robot-door-2.png -------------------------------------------------------------------------------- /examples/robot-door-3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/emk/haskell-probability-monads/HEAD/examples/robot-door-3.png -------------------------------------------------------------------------------- /examples/door-particles.xcf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/emk/haskell-probability-monads/HEAD/examples/door-particles.xcf -------------------------------------------------------------------------------- /examples/door-particles-2.xcf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/emk/haskell-probability-monads/HEAD/examples/door-particles-2.xcf -------------------------------------------------------------------------------- /examples/family.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | 3 | -- See . 4 | 5 | import Control.Monad.Distribution 6 | 7 | data Child = Girl | Boy 8 | deriving (Show, Eq, Ord) 9 | 10 | child = uniform [Girl, Boy] 11 | 12 | family = do 13 | child1 <- child 14 | child2 <- child 15 | return [child1, child2] 16 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | / Stretch, go find Don, ask about MVT 2 | 3 | Document functions and modules 4 | Add examples for all important APIs 5 | 6 | , Add Show instances in all the obvious places 7 | Merge SMC monad from paper 8 | Add Dist helpers for Random and/or Enum instances? 9 | 10 | Add bogus Num instances just to get fromRational and fromInteger? 11 | Keep Rational in MonadRandom, Dist APIs? 12 | 13 | Install cabal-head from Darcs 14 | Look at cabal's *.cabal file parser 15 | Given a *.cabal file and the package tarball, generate a Portfile 16 | -------------------------------------------------------------------------------- /Data/Probability/Rational.hs: -------------------------------------------------------------------------------- 1 | module Data.Probability.Rational ( 2 | module Data.Probability.Base, 3 | Prob() 4 | ) where 5 | 6 | import Data.Monoid 7 | import Data.Probability.Base 8 | 9 | -- | An implementation of 'Data.Probability.Probability' using rational 10 | -- numbers. 11 | newtype Prob = Prob Rational 12 | deriving (Eq) 13 | 14 | instance Probability Prob where 15 | prob = Prob 16 | fromProb (Prob p) = p 17 | pnot (Prob p) = Prob (1-p) 18 | padd (Prob p1) (Prob p2) = Prob (p1 + p2) 19 | pmul (Prob p1) (Prob p2) = Prob (p1 * p2) 20 | 21 | instance Monoid Prob where 22 | mempty = prob 1 23 | mappend = pmul 24 | 25 | instance Show Prob where 26 | show (Prob p) = show p 27 | -------------------------------------------------------------------------------- /Data/Probability.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Copyright : 2007 Eric Kidd 3 | License : BSD3 4 | Stability : experimental 5 | 6 | This API is very limited, and only suited to use within the 7 | ProbabilityMonad library. If you're interested in redesigning this, your 8 | input would be appreciated. 9 | 10 | -} 11 | 12 | module Data.Probability ( 13 | module Data.Probability.Base, 14 | Prob() 15 | ) where 16 | 17 | import Data.Monoid 18 | import Data.Probability.Base 19 | 20 | -- | An implementation of 'Data.Probability.Probability' using 21 | -- double-precision floating-point numbers. 22 | newtype Prob = Prob Double 23 | deriving (Eq) 24 | 25 | instance Probability Prob where 26 | prob = Prob . fromRational 27 | fromProb (Prob p) = toRational p 28 | pnot (Prob p) = Prob (1-p) 29 | padd (Prob p1) (Prob p2) = Prob (p1 + p2) 30 | pmul (Prob p1) (Prob p2) = Prob (p1 * p2) 31 | 32 | instance Monoid Prob where 33 | mempty = prob 1 34 | mappend = pmul 35 | 36 | instance Show Prob where 37 | show (Prob p) = show p 38 | -------------------------------------------------------------------------------- /examples/coins.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | 3 | import Control.Monad 4 | import Control.Monad.Distribution.Rational 5 | -- or import Control.Monad.Distribution.Rational if you want exact answers 6 | import Data.List 7 | 8 | data Coin = Heads | Tails 9 | deriving (Eq, Ord, Show) 10 | 11 | toss = uniform [Heads, Tails] 12 | 13 | tosses n = sequence (replicate n toss) 14 | 15 | unorderedTosses n = liftM sort (tosses n) 16 | 17 | tossesWithAtLeastOneHead n = do 18 | result <- tosses n 19 | guard (Heads `elem` result) 20 | return result 21 | 22 | {- 23 | 24 | Using Control.Monad.Probability: 25 | 26 | *Main> ddist (unorderedTosses 2) 27 | [MV 0.25 [Heads,Heads],MV 0.5 [Heads,Tails],MV 0.25 [Tails,Tails]] 28 | 29 | Using Control.Monad.Probability.Rational: 30 | 31 | *Main> ddist (unorderedTosses 2) 32 | [MV 1%4 [Heads,Heads],MV 1%2 [Heads,Tails],MV 1%4 [Tails,Tails]] 33 | 34 | Using either: 35 | 36 | *Main> sampleIO (unorderedTosses 2) 10 37 | [[Heads,Heads],[Heads,Heads],[Heads,Heads],[Tails,Tails],[Heads,Heads],[Heads,Heads],[Heads,Tails],[Heads,Tails],[Tails,Tails],[Heads,Tails]] 38 | 39 | -} 40 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | This is a probability library inspired by Martin Erwig's and Steve 2 | Kollmansberger's "Probabilistic Functional Programming"[1], but with many 3 | additions and an underlying structure factored into monad transformers. 4 | 5 | You will need MaybeT and MonadRandom from HackageDB: 6 | 7 | http://hackage.haskell.org/packages/archive/pkg-list.html 8 | 9 | ...or from Darcs: 10 | 11 | http://code.haskell.org/maybet/ 12 | http://code.haskell.org/monadrandom/ 13 | 14 | To install, type: 15 | 16 | runhaskell Setup.hs configure 17 | runhaskell Setup.hs build 18 | runhaskell Setup.hs install 19 | 20 | To build documentation, make sure Haddock is installed, and type: 21 | 22 | runhaskell Setup.hs haddock 23 | 24 | This library is highly experimental, and the APIs may change without 25 | notice. 26 | 27 | The actual implementations of the probability monads currently appear in 28 | examples/Probability.hs. These will eventually be moved into the main 29 | library. 30 | 31 | For further information, please see my blog[2]. 32 | 33 | [1] http://web.engr.oregonstate.edu/~erwig/pfp/ 34 | [2] http://www.randomhacks.net/articles/tag/Probability 35 | -------------------------------------------------------------------------------- /Control/Monad/Distribution/Rational.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Copyright : 2007 Eric Kidd 3 | License : BSD3 4 | Stability : experimental 5 | 6 | An alternative version of @Control.Monad.Distribution@ based on exact 7 | rational numbers. 8 | 9 | -} 10 | 11 | module Control.Monad.Distribution.Rational ( 12 | module Control.Monad.Distribution.Base, 13 | DDist, ddist, BDDist, bddist 14 | ) where 15 | 16 | import Control.Monad.Distribution.Base 17 | import Control.Monad.Maybe 18 | import Control.Monad.MonoidValue 19 | import Data.Probability.Rational 20 | 21 | -- | A discrete, finite probability distribution implemented using 22 | -- double-precision floating-point numbers. 23 | type DDist = MVT Prob [] 24 | 25 | -- | Force a value to be interpreted as having type 'DDist'. 26 | ddist :: DDist a -> DDist a 27 | ddist d = d 28 | 29 | -- | A version of 'BDDist' with support for Bayes' theorem. 30 | type BDDist = MaybeT DDist 31 | 32 | -- | Force a value to be interpreted as having type 'BDDist', and apply 33 | -- Bayes' rule. Returns 'Nothing' if no possible combination of events 34 | -- will satisfy the guard conditions specified in 'BDDist'. 35 | bddist :: BDDist a -> Maybe (DDist a) 36 | bddist d = bayes d 37 | -------------------------------------------------------------------------------- /ProbabilityMonads.cabal: -------------------------------------------------------------------------------- 1 | Name: ProbabilityMonads 2 | Version: 0.1.0 3 | Synopsis: Probability distribution monads. 4 | Description: Tools for random sampling, explicit enumeration of possible 5 | outcomes, and applying Bayes' rule. Highly experimental, 6 | and subject to change. In particular, the 7 | Data.Probability API is rather poor and could stand an 8 | overhaul. 9 | License: BSD3 10 | License-file: LICENSE 11 | Category: Control 12 | Author: Eric Kidd 13 | Maintainer: Eric Kidd 14 | Stability: experimental 15 | Build-Depends: base, mtl, MaybeT, MonadRandom 16 | Exposed-modules: Data.Probability.Base, 17 | Data.Probability, 18 | Data.Probability.Rational, 19 | Control.Monad.MonoidValue, 20 | Control.Monad.Distribution.Base, 21 | Control.Monad.Distribution, 22 | Control.Monad.Distribution.Rational 23 | ghc-options: -Wall -fno-warn-orphans -O 24 | -------------------------------------------------------------------------------- /Data/Probability/Base.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Copyright : 2007 Eric Kidd 3 | License : BSD3 4 | Stability : experimental 5 | Portability : non-portable (newtype deriving) 6 | 7 | Support for probability values. 8 | -} 9 | 10 | module Data.Probability.Base ( 11 | Probability, 12 | prob, fromProb, 13 | pnot, padd, pmul 14 | ) where 15 | 16 | import Data.Monoid 17 | 18 | -- | The probability of an event occuring. We provide this as a type 19 | -- class, allowing users of this library to choose among various 20 | -- representations of probability. 21 | class (Eq p, Monoid p) => Probability p where 22 | -- TODO: Should 'prob' and 'fromProb' work with Rational or another type? 23 | -- They exist mostly to interface with 24 | -- 'Control.Monad.Distribution.weighted'. 25 | 26 | -- | Create a probability from a rational number between 0 and 1, inclusive. 27 | prob :: Rational -> p 28 | -- | Convert a probability to a rational number. 29 | fromProb :: p -> Rational 30 | 31 | -- | Given the probability of an event occuring, calculate the 32 | -- probability of the event /not/ occuring. 33 | pnot :: p -> p 34 | -- | Given the probabilities of two disjoint events, calculate the 35 | -- probability of either event occuring. 36 | padd :: p -> p -> p 37 | -- | Given the probabilities of two indepedent events, calculate the 38 | -- probability of both events occuring. 39 | pmul :: p -> p -> p 40 | -------------------------------------------------------------------------------- /Control/Monad/Distribution.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Copyright : 2007 Eric Kidd 3 | License : BSD3 4 | Stability : experimental 5 | 6 | This module is a wrapper around @Control.Monad.Distribution.Base@. It 7 | provides definitions of 'DDist', 'ddist', 'BDDist' and 'bddist' based on 8 | double-precion floating point numbers. 9 | 10 | For the main API, see @Control.Monad.Distribution.Base@. For alternative 11 | versions of 'DDist', etc., based on exact rational numbers, see 12 | @Control.Monad.Distribution.Rational@. 13 | 14 | -} 15 | 16 | module Control.Monad.Distribution ( 17 | module Control.Monad.Distribution.Base, 18 | DDist, ddist, BDDist, bddist 19 | ) where 20 | 21 | import Control.Monad.Distribution.Base 22 | import Control.Monad.Maybe 23 | import Control.Monad.MonoidValue 24 | import Data.Probability 25 | 26 | -- | A discrete, finite probability distribution implemented using rational 27 | -- numbers. 28 | type DDist = MVT Prob [] 29 | 30 | -- | Force a value to be interpreted as having type 'DDist'. 31 | ddist :: DDist a -> DDist a 32 | ddist d = d 33 | 34 | -- | A version of 'BDDist' with support for Bayes' theorem. 35 | type BDDist = MaybeT DDist 36 | 37 | -- | Force a value to be interpreted as having type 'BDDist', and apply 38 | -- Bayes' rule. Returns 'Nothing' if no possible combination of events 39 | -- will satisfy the guard conditions specified in 'BDDist'. 40 | bddist :: BDDist a -> Maybe (DDist a) 41 | bddist d = bayes d 42 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Probability library for Haskell. 2 | Copyright 2007 Eric Kidd. All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, 8 | this list of conditions and the following disclaimer. 9 | * Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | * The names of this library's contributors may not be used to endorse or 13 | promote products derived from this software without specific prior 14 | written permission. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 19 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE 20 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 21 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 22 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 23 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 24 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 25 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 26 | POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /examples/drug-test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | 3 | import Control.Monad.Distribution 4 | 5 | -- See . 6 | 7 | data HeroinStatus = User | Clean 8 | deriving (Show, Eq) 9 | 10 | data Test = Pos | Neg 11 | deriving (Show, Eq) 12 | 13 | percent p x1 x2 = 14 | weighted [(x1, p), (x2, 100-p)] 15 | 16 | percentUser p = percent p User Clean 17 | percentPos p = percent p Pos Neg 18 | 19 | drugTest1 = do 20 | heroinStatus <- percentUser 0.1 21 | testResult <- 22 | if heroinStatus == User 23 | then percentPos 99 24 | else percentPos 1 25 | return (heroinStatus, testResult) 26 | 27 | -- > exact drugTest1 28 | -- [Perhaps (User,Pos) 0.1%, 29 | -- Perhaps (User,Neg) 0.0%, 30 | -- Perhaps (Clean,Pos) 1.0%, 31 | -- Perhaps (Clean,Neg) 98.9%] 32 | 33 | drugTest2 = do 34 | (heroinStatus, testResult) <- drugTest1 35 | return (if testResult == Pos 36 | then Just heroinStatus 37 | else Nothing) 38 | 39 | -- > exact drugTest2 40 | -- [Perhaps (Just User) 0.1%, 41 | -- Perhaps Nothing 0.0%, 42 | -- Perhaps (Just Clean) 1.0%, 43 | -- Perhaps Nothing 98.9%] 44 | 45 | -- > exact (onlyJust drugTest2) 46 | -- [Perhaps User 9.0%,Perhaps Clean 91.0%] 47 | 48 | drugTest3 prior = do 49 | heroinStatus <- prior 50 | testResult <- 51 | if heroinStatus == User 52 | then percentPos 99 53 | else percentPos 1 54 | guard (testResult == Pos) 55 | return heroinStatus 56 | 57 | -- > bayes (drugTest3 (percentUser 0.1)) 58 | -- [Perhaps User 9.0%,Perhaps Clean 91.0%] 59 | -- > bayes (drugTest3 (percentUser 50)) 60 | -- [Perhaps User 99.0%,Perhaps Clean 1.0%] 61 | -------------------------------------------------------------------------------- /.setup-config: -------------------------------------------------------------------------------- 1 | LocalBuildInfo {prefix = "/usr/local", bindir = "$prefix/bin", libdir = "$prefix/lib", libsubdir = "$pkgid/$compiler", libexecdir = "$prefix/libexec", datadir = "$prefix/share", datasubdir = "$pkgid", compiler = Compiler {compilerFlavor = GHC, compilerVersion = Version {versionBranch = [6,6], versionTags = []}, compilerPath = "/opt/local/bin/ghc", compilerPkgTool = "/opt/local/bin/ghc-pkg"}, buildDir = "dist/build", packageDeps = [PackageIdentifier {pkgName = "base", pkgVersion = Version {versionBranch = [2,0], versionTags = []}},PackageIdentifier {pkgName = "mtl", pkgVersion = Version {versionBranch = [1,0], versionTags = []}},PackageIdentifier {pkgName = "MaybeT", pkgVersion = Version {versionBranch = [0,0], versionTags = []}},PackageIdentifier {pkgName = "MonadRandom", pkgVersion = Version {versionBranch = [0,0], versionTags = []}}], withPrograms = [("ar",Program {programName = "ar", programBinName = "ar", programArgs = [], programLocation = FoundOnSystem "/usr/bin/ar"}),("haddock",Program {programName = "haddock", programBinName = "haddock", programArgs = [], programLocation = FoundOnSystem "/opt/local/bin/haddock"}),("ld",Program {programName = "ld", programBinName = "ld", programArgs = [], programLocation = FoundOnSystem "/usr/bin/ld"}),("pfesetup",Program {programName = "pfesetup", programBinName = "pfesetup", programArgs = [], programLocation = EmptyLocation}),("ranlib",Program {programName = "ranlib", programBinName = "ranlib", programArgs = [], programLocation = FoundOnSystem "/usr/bin/ranlib"}),("runghc",Program {programName = "runghc", programBinName = "runghc", programArgs = [], programLocation = FoundOnSystem "/opt/local/bin/runghc"}),("runhugs",Program {programName = "runhugs", programBinName = "runhugs", programArgs = [], programLocation = EmptyLocation}),("tar",Program {programName = "tar", programBinName = "tar", programArgs = [], programLocation = FoundOnSystem "/sw/bin/tar"})], userConf = False, withHappy = Nothing, withAlex = Nothing, withHsc2hs = Just "/opt/local/bin/hsc2hs", withC2hs = Nothing, withCpphs = Nothing, withGreencard = Nothing, withVanillaLib = True, withProfLib = False, withProfExe = False, withOptimization = True, withGHCiLib = True, splitObjs = False, haddockUsePackages = True} -------------------------------------------------------------------------------- /Control/Monad/Perhaps.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Copyright : 2007 Eric Kidd 3 | License : BSD3 4 | Stability : experimental 5 | 6 | Generalization of 'Maybe' to work with probability values between 0 and 1. 7 | 8 | -} 9 | 10 | module Control.Monad.Perhaps ( 11 | -- * Perhaps 12 | Perhaps(..), never, always, possible, impossible, perhaps, 13 | -- * PerhapsT 14 | PerhapsT(..) 15 | ) where 16 | 17 | import Data.Prob 18 | import Control.Monad 19 | import Control.Monad.Trans 20 | 21 | data Perhaps a = Perhaps { perhapsValue :: a, perhapsProb :: Prob } 22 | 23 | instance Show a => Show (Perhaps a) where 24 | show (Perhaps _ 0) = "never" 25 | show (Perhaps x p) = "Perhaps " ++ show x ++ " " ++ show p 26 | 27 | never :: Perhaps a 28 | never = Perhaps undefined 0 29 | 30 | always :: a -> Perhaps a 31 | always x = Perhaps x 1 32 | 33 | impossible :: Perhaps a -> Bool 34 | impossible p = perhapsProb p == 0 35 | 36 | possible :: Perhaps a -> Bool 37 | possible = not . impossible 38 | 39 | perhaps :: b -> (a -> b) -> Perhaps a -> b 40 | perhaps defaultValue f ph | impossible ph = defaultValue 41 | | otherwise = f (perhapsValue ph) 42 | 43 | instance Functor Perhaps where 44 | fmap f (Perhaps x p) = Perhaps (f x) p 45 | 46 | instance Monad Perhaps where 47 | return x = Perhaps x 1 48 | -- Note that if (*) were non-strict in its first argument, we wouldn't need 49 | -- to handle 'never' separately. 50 | ph >>= f | impossible ph = never 51 | | otherwise = Perhaps x (p1 * p2) 52 | where (Perhaps (Perhaps x p1) p2) = fmap f ph 53 | 54 | newtype PerhapsT m a = PerhapsT { runPerhapsT :: m (Perhaps a) } 55 | 56 | instance MonadTrans PerhapsT where 57 | -- TODO: Assigns every event a probability of 1. Obviously, this doesn't 58 | -- always make sense to call. 59 | lift x = PerhapsT (liftM return x) 60 | 61 | instance Functor m => Functor (PerhapsT m) where 62 | fmap f = PerhapsT . fmap (fmap f) . runPerhapsT 63 | 64 | instance Monad m => Monad (PerhapsT m) where 65 | return = lift . return 66 | m >>= f = PerhapsT bound 67 | where bound = do 68 | ph <- runPerhapsT m 69 | case ph of 70 | (Perhaps x1 p1) | p1 == 0 -> return never 71 | | otherwise -> do 72 | (Perhaps x2 p2) <- runPerhapsT (f x1) 73 | return (Perhaps x2 (p1 * p2)) 74 | -------------------------------------------------------------------------------- /Control/Monad/MonoidValue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-} 2 | 3 | {- | 4 | Copyright : 2007 Eric Kidd 5 | License : BSD3 6 | Stability : experimental 7 | Portability : non-portable (multi-parameter type classes, undecidable instances) 8 | 9 | This module provides stripped-down versions of 10 | 'Control.Monad.Writer.Writer' and 'Control.Monad.Writer.WriterT', minus the 11 | operations 'Control.Monad.Writer.tell', 'Control.Monad.Writer.listen' and 12 | 'Control.Monad.Writer.pass'. It a useful building block for monads 13 | representing probability distributions or quantum states, where the extra 14 | functions provided by 'Control.Monad.Writer.Class.MonadWriter' are 15 | irrelevant or inappropriate. 16 | 17 | The 'MV' monad and the 'MVT' monad transformer were proposed by Dan Piponi 18 | as a way of representing M-sets in Haskell. An /M-set/ is a set with a 19 | monoid action (by analogy to the more common G-sets found in group theory). 20 | Here, 'MV' represents an element in a /free M-set/. This is essentially a 21 | (monoid,value) pair. 22 | 23 | [Computation type:] Computations with an associated monoid action. 24 | 25 | [Binding strategy:] The @return@ function lifts a value into the monad by 26 | pairing it with @mempty@. The @bind@ function uses @mappend@ to implement 27 | the monoid action. 28 | 29 | [Useful for:] Building probability distribution monads. 30 | 31 | -} 32 | 33 | module Control.Monad.MonoidValue ( 34 | module Data.Monoid, 35 | MV(MV), mvMonoid, mvValue, MVT(MVT), runMVT 36 | ) where 37 | 38 | import Control.Monad.Trans 39 | import Data.Monoid 40 | 41 | -- | A value annotated with a monoid. Represents an element in a free 42 | -- M-set. 43 | data (Monoid w) => MV w a = 44 | MV { mvMonoid :: w, mvValue :: a } 45 | 46 | instance (Monoid w, Show w, Show a) => Show (MV w a) where 47 | show (MV w a) = "MV " ++ show w ++ " " ++ show a 48 | 49 | -- We build our functor and monad instances from 'mapMV' and 'joinMV' for 50 | -- simplicity. 51 | mapMV :: (Monoid w) => (a -> b) -> MV w a -> MV w b 52 | mapMV f (MV w v) = MV w (f v) 53 | 54 | joinMV :: (Monoid w) => MV w (MV w a) -> MV w a 55 | joinMV (MV w1 (MV w2 v)) = MV (w1 `mappend` w2) v 56 | 57 | instance (Monoid w) => Functor (MV w) where 58 | fmap = mapMV 59 | 60 | instance (Monoid w) => Monad (MV w) where 61 | return v = MV mempty v 62 | mv >>= f = joinMV (mapMV f mv) 63 | 64 | -- | Transforms a monad @m@ to associate a monoid value with the 65 | -- computation. 66 | newtype (Monoid w, Monad m) => MVT w m a = 67 | MVT { runMVT :: m (MV w a) } 68 | 69 | instance (Monoid w) => MonadTrans (MVT w) where 70 | lift mv = MVT (do v <- mv 71 | return (MV mempty v)) 72 | 73 | instance (Monoid w, Monad m) => Functor (MVT w m) where 74 | fmap f ma = MVT mapped 75 | where mapped = do 76 | (MV w v) <- runMVT ma 77 | return (MV w (f v)) 78 | 79 | instance (Monoid w, Monad m) => Monad (MVT w m) where 80 | return = lift . return 81 | ma >>= f = MVT bound 82 | where bound = do 83 | (MV w1 v1) <- runMVT ma 84 | (MV w2 v2) <- runMVT (f v1) 85 | return (MV (w1 `mappend` w2) v2) 86 | 87 | -------------------------------------------------------------------------------- /examples/spam.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Distribution 2 | import Control.Monad.MonoidValue 3 | import Data.List 4 | import qualified Data.Map as M 5 | import Data.Maybe 6 | import Data.Probability 7 | 8 | -- Spam Filtering 9 | -- 10 | -- Inspired by and 11 | -- . 12 | 13 | -- Each message is spam (junk mail) or "ham" (good mail). 14 | data MsgType = Spam | Ham 15 | deriving (Show, Eq, Enum, Bounded) 16 | 17 | hasWord :: String -> BDDist MsgType -> 18 | BDDist MsgType 19 | hasWord word prior = do 20 | msgType <- prior 21 | wordPresent <- wordPresentIn msgType word 22 | guard wordPresent 23 | return msgType 24 | 25 | -- > bayes msgTypePrior 26 | -- [Perhaps Spam 64.2%,Perhaps Ham 35.8%] 27 | 28 | -- > bayes (hasWord "free" msgTypePrior) 29 | -- [Perhaps Spam 90.5%,Perhaps Ham 9.5%] 30 | 31 | wordPresentIn msgType word = 32 | boolDist (prob (n/total)) 33 | where wordCounts = findWordCounts word 34 | n = entryFor msgType wordCounts 35 | total = entryFor msgType msgCounts 36 | 37 | boolDist :: Prob -> BDDist Bool 38 | boolDist p = 39 | weighted [(True, p'), (False, 1-p')] 40 | where p' = fromProb p 41 | 42 | msgCounts = [102, 57] 43 | 44 | wordCountTable = 45 | M.fromList [("free", [57, 6]), 46 | -- Lots of words... 47 | ("bayes", [1, 10]), 48 | ("monad", [0, 22])] 49 | 50 | entryFor :: Enum a => a -> [b] -> b 51 | entryFor x ys = ys !! fromEnum x 52 | 53 | findWordCounts word = 54 | M.findWithDefault [0,0] word wordCountTable 55 | 56 | msgTypePrior :: Dist d => d MsgType 57 | msgTypePrior = 58 | weighted (zipWith (,) [Spam,Ham] msgCounts) 59 | 60 | -- > bayes (hasWord "bayes" msgTypePrior) 61 | -- [Perhaps Spam 9.1%,Perhaps Ham 90.9%] 62 | 63 | hasWords [] prior = prior 64 | hasWords (w:ws) prior = do 65 | hasWord w (hasWords ws prior) 66 | 67 | -- > bayes (hasWords ["free","bayes"] msgTypePrior) 68 | -- [Perhaps Spam 34.7%,Perhaps Ham 65.3%] 69 | 70 | uniformAll :: (Dist d,Enum a,Bounded a) => d a 71 | uniformAll = uniform allValues 72 | 73 | allValues :: (Enum a,Bounded a) => [a] 74 | allValues = enumFromTo minBound maxBound 75 | 76 | -- > bayes (uniformAll :: BDDist MsgType) 77 | -- [Perhaps Spam 50.0%,Perhaps Ham 50.0%] 78 | 79 | characteristic f = f uniformAll 80 | 81 | -- > bayes (characteristic (hasWord "free")) 82 | -- [Perhaps Spam 84.1%,Perhaps Ham 15.9%] 83 | 84 | score f = 85 | distance (characteristic f) uniformAll 86 | 87 | distance :: (Eq a, Enum a, Bounded a) => 88 | BDDist a -> BDDist a -> Double 89 | distance dist1 dist2 = 90 | sum (map (^2) (zipWith (-) ps1 ps2)) 91 | where ps1 = vectorFromDist dist1 92 | ps2 = vectorFromDist dist2 93 | 94 | vectorFromDist dist = 95 | map (fromRational . fromProb) (probsFromDist dist) 96 | 97 | probsFromDist dist = 98 | map (\x -> (sumProbs . matching x) (listFromMaybeDist (bayes dist))) 99 | allValues 100 | where matching x = filter ((==x) . mvValue) 101 | sumProbs = sum . map mvMonoid 102 | 103 | listFromMaybeDist Nothing = [] 104 | listFromMaybeDist (Just dist) = runMVT dist 105 | 106 | adjustMinimums xs = map (/ total) adjusted 107 | where adjusted = map (max 0.01) xs 108 | total = sum adjusted 109 | 110 | adjustedProbsFromDist dist = 111 | adjustMinimums (probsFromDist dist) 112 | 113 | classifierProbs f = 114 | adjustedProbsFromDist (characteristic f) 115 | 116 | --applyProbs :: (Enum a) => [Prob] -> BDDist a -> BDDist a 117 | applyProbs probs prior = do 118 | msgType <- prior 119 | applyProb (entryFor msgType probs) 120 | return msgType 121 | 122 | -- Will need LaTeX PNG to explain. 123 | applyProb :: Prob -> BDDist () 124 | applyProb p = do 125 | b <- boolDist p 126 | guard b 127 | 128 | -- > bayes (hasWord "free" msgTypePrior) 129 | -- [Perhaps Spam 90.5%,Perhaps Ham 9.5%] 130 | -- > let probs = classifierProbs (hasWord "free") 131 | -- > bayes (applyProbs probs msgTypePrior) 132 | -- [Perhaps Spam 90.5%,Perhaps Ham 9.5%] 133 | 134 | data Classifier = Classifier Double [Prob] 135 | deriving Show 136 | 137 | classifier f = Classifier (score f) (classifierProbs f) 138 | 139 | applyClassifier (Classifier _ probs) = 140 | applyProbs probs 141 | 142 | instance Eq Classifier where 143 | (Classifier s1 _) == (Classifier s2 _) = 144 | s1 == s2 145 | 146 | instance Ord Classifier where 147 | compare (Classifier s1 _) 148 | (Classifier s2 _) = 149 | compare s2 s1 150 | 151 | -- > classifier (hasWord "free") 152 | -- Classifier 0.23 [84.1%,15.9%] 153 | 154 | classifiers :: M.Map String Classifier 155 | classifiers = 156 | M.mapWithKey toClassifier wordCountTable 157 | where toClassifier w _ = 158 | classifier (hasWord w) 159 | 160 | findClassifier :: String -> Maybe Classifier 161 | findClassifier w = M.lookup w classifiers 162 | 163 | findClassifiers n ws = 164 | take n (sort classifiers) 165 | where classifiers = 166 | catMaybes (map findClassifier ws) 167 | 168 | hasTokens ws prior = 169 | foldr applyClassifier 170 | prior 171 | (findClassifiers 15 ws) 172 | 173 | -- > bayes (hasTokens ["bayes", "free"] 174 | -- msgTypePrior) 175 | -- [Perhaps Spam 34.7%,Perhaps Ham 65.3%] 176 | -------------------------------------------------------------------------------- /examples/Probability.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | 3 | -- Standard modules. 4 | import Control.Monad 5 | import Control.Monad.Trans 6 | import Data.List 7 | import qualified Data.Map as M 8 | import Data.Maybe 9 | import System.Random 10 | 11 | -- Modules provided by this library. 12 | import Control.Monad.Dist 13 | import Control.Monad.Maybe 14 | import Control.Monad.Perhaps 15 | import Data.Prob 16 | 17 | -- ======================================================================== 18 | -- Spam Filtering 19 | -- 20 | -- Inspired by and 21 | -- . 22 | 23 | -- Each message is spam (junk mail) or "ham" (good mail). 24 | data MsgType = Spam | Ham 25 | deriving (Show, Eq, Enum, Bounded) 26 | 27 | hasWord :: String -> FDist' MsgType -> 28 | FDist' MsgType 29 | hasWord word prior = do 30 | msgType <- prior 31 | wordPresent <- wordPresentIn msgType word 32 | condition wordPresent 33 | return msgType 34 | 35 | -- > bayes msgTypePrior 36 | -- [Perhaps Spam 64.2%,Perhaps Ham 35.8%] 37 | 38 | -- > bayes (hasWord "free" msgTypePrior) 39 | -- [Perhaps Spam 90.5%,Perhaps Ham 9.5%] 40 | 41 | wordPresentIn msgType word = 42 | boolDist (Prob (n/total)) 43 | where wordCounts = findWordCounts word 44 | n = entryFor msgType wordCounts 45 | total = entryFor msgType msgCounts 46 | 47 | boolDist :: Prob -> FDist' Bool 48 | boolDist (Prob p) = 49 | weighted [(True, p), (False, 1-p)] 50 | 51 | msgCounts = [102, 57] 52 | 53 | wordCountTable = 54 | M.fromList [("free", [57, 6]), 55 | -- Lots of words... 56 | ("bayes", [1, 10]), 57 | ("monad", [0, 22])] 58 | 59 | entryFor :: Enum a => a -> [b] -> b 60 | entryFor x ys = ys !! fromEnum x 61 | 62 | findWordCounts word = 63 | M.findWithDefault [0,0] word wordCountTable 64 | 65 | msgTypePrior :: Dist d => d MsgType 66 | msgTypePrior = 67 | weighted (zipWith (,) [Spam,Ham] msgCounts) 68 | 69 | -- > bayes (hasWord "bayes" msgTypePrior) 70 | -- [Perhaps Spam 9.1%,Perhaps Ham 90.9%] 71 | 72 | hasWords [] prior = prior 73 | hasWords (w:ws) prior = do 74 | hasWord w (hasWords ws prior) 75 | 76 | -- > bayes (hasWords ["free","bayes"] msgTypePrior) 77 | -- [Perhaps Spam 34.7%,Perhaps Ham 65.3%] 78 | 79 | uniformAll :: (Dist d,Enum a,Bounded a) => d a 80 | uniformAll = uniform allValues 81 | 82 | allValues :: (Enum a,Bounded a) => [a] 83 | allValues = enumFromTo minBound maxBound 84 | 85 | -- > bayes (uniformAll :: FDist' MsgType) 86 | -- [Perhaps Spam 50.0%,Perhaps Ham 50.0%] 87 | 88 | characteristic f = f uniformAll 89 | 90 | -- > bayes (characteristic (hasWord "free")) 91 | -- [Perhaps Spam 84.1%,Perhaps Ham 15.9%] 92 | 93 | score f = 94 | distance (characteristic f) uniformAll 95 | 96 | distance :: (Eq a, Enum a, Bounded a) => 97 | FDist' a -> FDist' a -> Double 98 | distance dist1 dist2 = 99 | sum (map (^2) (zipWith (-) ps1 ps2)) 100 | where ps1 = vectorFromDist dist1 101 | ps2 = vectorFromDist dist2 102 | 103 | vectorFromDist dist = 104 | map doubleFromProb (probsFromDist dist) 105 | 106 | probsFromDist dist = 107 | map (\x -> (sumProbs . matching x) (bayes dist)) 108 | allValues 109 | where matching x = filter ((==x) . perhapsValue) 110 | sumProbs = sum . map perhapsProb 111 | 112 | adjustMinimums xs = map (/ total) adjusted 113 | where adjusted = map (max 0.01) xs 114 | total = sum adjusted 115 | 116 | adjustedProbsFromDist dist = 117 | adjustMinimums (probsFromDist dist) 118 | 119 | classifierProbs f = 120 | adjustedProbsFromDist (characteristic f) 121 | 122 | --applyProbs :: (Enum a) => [Prob] -> FDist' a -> FDist' a 123 | applyProbs probs prior = do 124 | msgType <- prior 125 | applyProb (entryFor msgType probs) 126 | return msgType 127 | 128 | -- Will need LaTeX PNG to explain. 129 | applyProb :: Prob -> FDist' () 130 | applyProb p = do 131 | b <- boolDist p 132 | condition b 133 | 134 | -- > bayes (hasWord "free" msgTypePrior) 135 | -- [Perhaps Spam 90.5%,Perhaps Ham 9.5%] 136 | -- > let probs = classifierProbs (hasWord "free") 137 | -- > bayes (applyProbs probs msgTypePrior) 138 | -- [Perhaps Spam 90.5%,Perhaps Ham 9.5%] 139 | 140 | data Classifier = Classifier Double [Prob] 141 | deriving Show 142 | 143 | classifier f = Classifier (score f) (classifierProbs f) 144 | 145 | applyClassifier (Classifier _ probs) = 146 | applyProbs probs 147 | 148 | instance Eq Classifier where 149 | (Classifier s1 _) == (Classifier s2 _) = 150 | s1 == s2 151 | 152 | instance Ord Classifier where 153 | compare (Classifier s1 _) 154 | (Classifier s2 _) = 155 | compare s2 s1 156 | 157 | -- > classifier (hasWord "free") 158 | -- Classifier 0.23 [84.1%,15.9%] 159 | 160 | classifiers :: M.Map String Classifier 161 | classifiers = 162 | M.mapWithKey toClassifier wordCountTable 163 | where toClassifier w _ = 164 | classifier (hasWord w) 165 | 166 | findClassifier :: String -> Maybe Classifier 167 | findClassifier w = M.lookup w classifiers 168 | 169 | findClassifiers n ws = 170 | take n (sort classifiers) 171 | where classifiers = 172 | catMaybes (map findClassifier ws) 173 | 174 | hasTokens ws prior = 175 | foldr applyClassifier 176 | prior 177 | (findClassifiers 15 ws) 178 | 179 | -- > bayes (hasTokens ["bayes", "free"] 180 | -- msgTypePrior) 181 | -- [Perhaps Spam 34.7%,Perhaps Ham 65.3%] 182 | 183 | 184 | -- ======================================================================== 185 | -- Robot localization 186 | -- 187 | -- Example based on "Bayesian Filters for Location Estimation", Fox et al., 188 | -- 2005. Available online at: 189 | -- 190 | -- http://seattle.intel-research.net/people/jhightower/pubs/fox2003bayesian/fox2003bayesian.pdf 191 | 192 | -- The hallway extends from 0 to 299, and 193 | -- it contains three doors. 194 | doorAtPosition :: Int -> Bool 195 | doorAtPosition pos 196 | -- Doors 1, 2 and 3. 197 | | 26 <= pos && pos < 58 = True 198 | | 82 <= pos && pos < 114 = True 199 | | 192 <= pos && pos < 224 = True 200 | | otherwise = False 201 | 202 | localizeRobot :: WPS Int 203 | localizeRobot = do 204 | -- Pick a random starting location 205 | -- to use as a hypothesis. 206 | pos1 <- uniform [0..299] 207 | -- We know we're at a door. Hypotheses 208 | -- which agree with this fact get a 209 | -- weight of 1, others get 0. 210 | if doorAtPosition pos1 211 | then weight 1 212 | else weight 0 213 | 214 | -- Drive forward a bit. 215 | let pos2 = pos1 + 28 216 | -- We know we're not at a door. 217 | if not (doorAtPosition pos2) 218 | then weight 1 219 | else weight 0 220 | 221 | -- Drive forward some more. 222 | let pos3 = pos2 + 28 223 | if doorAtPosition pos3 224 | then weight 1 225 | else weight 0 226 | -- Our final hypothesis. 227 | return pos3 228 | 229 | -- > runRand (runWPS localizeRobot 10) 230 | -- [Perhaps 106 100.0%, 231 | -- never,never,never,never,never, 232 | -- Perhaps 93 100.0%, 233 | -- never,never,never] 234 | 235 | -- > runWPS' localizeRobot 10 236 | -- [97,109,93] 237 | 238 | 239 | -- ======================================================================== 240 | -- Random sampling 241 | -- 242 | -- Heavily inspired by Sungwoo Park and colleagues' $\lambda_{\bigcirc}$ 243 | -- caculus . 244 | -- 245 | -- See . 246 | 247 | histogram :: Ord a => [a] -> [Int] 248 | histogram = map length . group . sort 249 | 250 | 251 | -- ======================================================================== 252 | -- Particle System 253 | 254 | newtype PS a = PS { runPS :: Int -> Rand [a] } 255 | 256 | liftRand :: Rand a -> PS a 257 | liftRand r = PS (sample r) 258 | 259 | instance Functor PS where 260 | fmap f ps = PS mapped 261 | where mapped n = 262 | liftM (map f) (runPS ps n) 263 | 264 | instance Monad PS where 265 | return = liftRand . return 266 | ps >>= f = joinPS (fmap f ps) 267 | 268 | joinPS :: PS (PS a) -> PS a 269 | joinPS psps = PS (joinPS' psps) 270 | 271 | joinPS' :: PS (PS a) -> Int -> Rand [a] 272 | joinPS' psps n = do 273 | pss <- (runPS psps n) 274 | xs <- sequence (map sample1 pss) 275 | return (concat xs) -- TODO: Can we base on Rand's join? 276 | where sample1 ps = runPS ps 1 277 | 278 | instance Dist PS where 279 | weighted = liftRand . weighted 280 | 281 | type WPS = PerhapsT PS 282 | 283 | instance Dist (PerhapsT PS) where 284 | weighted = PerhapsT . weighted . map liftWeighted 285 | where liftWeighted (x,w) = (Perhaps x 1,w) 286 | 287 | weight :: Prob -> WPS () 288 | weight p = PerhapsT (return (Perhaps () p)) 289 | 290 | runWPS wps n = runPS (runPerhapsT wps) n 291 | 292 | runWPS' wps n = (runRand . liftM catPossible) (runWPS wps n) 293 | 294 | catPossible (ph:phs) | impossible ph = 295 | catPossible phs 296 | catPossible (Perhaps x p:phs) = 297 | x:(catPossible phs) 298 | catPossible [] = [] 299 | -------------------------------------------------------------------------------- /Control/Monad/Distribution/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-} 2 | 3 | {- | 4 | Copyright : 2007 Eric Kidd 5 | License : BSD3 6 | Stability : experimental 7 | 8 | Common interface for probability distribution monads. Heavily inspired by 9 | Martin Erwig's and Steve Kollmansberger's /Probabilistic Functional 10 | Programming/, which can be found at 11 | . 12 | 13 | For background, see Michele Giry, /A Categorical Approach to Probability 14 | Theory/. 15 | 16 | -} 17 | 18 | module Control.Monad.Distribution.Base ( 19 | -- * Common interface 20 | -- $Interface 21 | Dist, weighted, uniform, 22 | -- * Bayes' rule 23 | -- $Bayes 24 | MonadPlus, mzero, mplus, guard, -- Re-exported from Control.Monad. 25 | -- * Random sampling functions 26 | -- $Rand 27 | module Control.Monad.Random, 28 | sample, sampleIO, 29 | BRand, sampleBayes, sampleBayesIO, 30 | -- * Discrete, finite distributions 31 | -- $DDist 32 | bayes 33 | ) where 34 | 35 | import Control.Monad 36 | import Control.Monad.Maybe 37 | import Control.Monad.MonoidValue 38 | import Control.Monad.Random 39 | import Control.Monad.Trans 40 | import Data.List 41 | import Data.Maybe 42 | import Data.Probability 43 | 44 | {- $Interface 45 | 46 | Common interfaces to probability monads. For example, if we assume that a 47 | family has two children, each a boy or a girl, we can build a probability 48 | distribution representing all such families. 49 | 50 | >{-# LANGUAGE NoMonomorphismRestriction #-} 51 | > 52 | >import Control.Monad.Distribution 53 | > 54 | >data Child = Girl | Boy 55 | > deriving (Show, Eq, Ord) 56 | > 57 | >child = uniform [Girl, Boy] 58 | > 59 | >family = do 60 | > child1 <- child 61 | > child2 <- child 62 | > return [child1, child2] 63 | 64 | The use of @NoMonomorphismRestriction@ is optional. It eliminates the need 65 | for type declarations on @child@ and @family@: 66 | 67 | >child :: (Dist d) => d Child 68 | >child = uniform [Girl, Boy] 69 | > 70 | >family :: (Dist d) => d [Child] 71 | >family = ... 72 | 73 | Unfortunately, using @NoMonomorphismRestriction@ may hide potential 74 | performance issues. In either of the above examples, Haskell compilers may 75 | recompute @child@ from scratch each time it is called, because the actual 76 | type of the distribution @d@ is unknown. Normally, Haskell requires an 77 | explicit type declaration in this case, in hope that you will notice the 78 | potential performance issue. By enabling @NoMonomorphismRestriction@, you 79 | indicate that you intended the code to work this way, and don't wish to use 80 | type declarations on every definition. 81 | 82 | -} 83 | 84 | -- | Represents a probability distribution. 85 | class (Functor d, Monad d) => Dist d where 86 | -- | Creates a new distribution from a weighted list of values. The 87 | -- individual weights must be non-negative, and they must sum to a 88 | -- positive number. 89 | weighted :: [(a, Rational)] -> d a 90 | -- TODO: What order do we want weighted's arguments in? 91 | 92 | -- | Creates a new distribution from a list of values, weighting it evenly. 93 | uniform :: Dist d => [a] -> d a 94 | uniform = weighted . map (\x -> (x, 1)) 95 | 96 | {- $Bayes 97 | 98 | Using 'Control.Monad.guard', it's possible to calculate conditional 99 | probabilities using Bayes' rule. In the example below, we choose to 100 | @Control.Monad.Distribution.Rational@, which calculates probabilities using 101 | exact rational numbers. This is useful for small, interactive programs 102 | where you want answers like 1/3 and 2/3 instead of 0.3333333 and 0.6666666. 103 | 104 | >{-# LANGUAGE NoMonomorphismRestriction #-} 105 | > 106 | >import Control.Monad 107 | >import Control.Monad.Distribution.Rational 108 | >import Data.List 109 | > 110 | >data Coin = Heads | Tails 111 | > deriving (Eq, Ord, Show) 112 | > 113 | >toss = uniform [Heads, Tails] 114 | > 115 | >tosses n = sequence (replicate n toss) 116 | > 117 | >tossesWithAtLeastOneHead n = do 118 | > result <- tosses n 119 | > guard (Heads `elem` result) 120 | > return result 121 | 122 | In this example, we use 'Control.Monad.guard' to discard possible outcomes 123 | where no coin comes up heads. 124 | 125 | -} 126 | 127 | 128 | -- | A distribution which supports 'Dist' and 'Control.Monad.MonadPlus' 129 | -- supports Bayes' rule. Use 'Control.Monad.guard' to calculate a 130 | -- conditional probability. 131 | class (Dist d, MonadPlus d) => BayesDist d 132 | -- TODO: Do we want to add an associated type here, pointing to the 133 | -- underlying distribution type? 134 | 135 | -- Applying MaybeT to a distribution gives you another distribution, but 136 | -- with support for Bayes' rule. 137 | instance (Dist d) => Dist (MaybeT d) where 138 | weighted wvs = lift (weighted wvs) 139 | 140 | {- $Rand 141 | 142 | Support for probability distributions represented by sampling functions. 143 | This API is heavily inspired by Sungwoo Park and colleagues' 144 | $\lambda_{\bigcirc}$ caculus . 145 | 146 | Two sampling-function monads are available: 'Control.Monad.Random.Rand' and 147 | 'BRand'. The former provides ordinary sampling functions, and the latter 148 | supports Bayesian reasoning. 149 | 150 | It's possible run code in the 'Control.Monad.Random.Rand' monad using 151 | either 'sample' or 'sampleIO'. 152 | 153 | >sampleIO family 3 154 | >-- [[Boy,Girl],[Boy,Girl],[Girl,Girl]] 155 | 156 | If the probability distribution uses 'Control.Monad.guard', you can run it 157 | using 'sampleBayesIO'. Note that one of the outcomes below was discarded, 158 | leaving 3 outcomes instead of the expected 4: 159 | 160 | >sampleBayesIO (tossesWithAtLeastOneHead 2) 4 161 | >-- [[Tails,Heads],[Heads,Heads],[Tails,Heads]] 162 | 163 | -} 164 | 165 | -- Make all the standard instances of MonadRandom into probability 166 | -- distributions. 167 | instance (RandomGen g) => Dist (Rand g) where 168 | weighted = fromList 169 | instance (Monad m, RandomGen g) => Dist (RandT g m) where 170 | weighted = fromList 171 | 172 | -- | Take @n@ samples from the distribution @r@. 173 | sample :: (MonadRandom m) => m a -> Int -> m [a] 174 | sample d n = sequence (replicate n d) 175 | 176 | -- | Take @n@ samples from the distribution @r@ using the IO monad. 177 | sampleIO :: Rand StdGen a -> Int -> IO [a] 178 | sampleIO d n = evalRandIO (sample d n) 179 | 180 | -- | A random distribution where some samples may be discarded. 181 | type BRand g = MaybeT (Rand g) 182 | 183 | instance (RandomGen g) => BayesDist (MaybeT (Rand g)) 184 | instance (RandomGen g, Monad m) => BayesDist (MaybeT (RandT g m)) 185 | 186 | instance (RandomGen g) => MonadPlus (MaybeT (Rand g)) where 187 | mzero = randMZero 188 | mplus = randMPlus 189 | 190 | instance (RandomGen g, Monad m) => MonadPlus (MaybeT (RandT g m)) where 191 | mzero = randMZero 192 | mplus = randMPlus 193 | 194 | randMZero :: (MonadRandom m) => (MaybeT m a) 195 | randMZero = MaybeT (return Nothing) 196 | 197 | -- TODO: I'm not sure this is particularly sensible or useful. 198 | randMPlus :: (MonadRandom m) => (MaybeT m a) -> (MaybeT m a) -> (MaybeT m a) 199 | randMPlus d1 d2 = MaybeT choose 200 | where choose = do 201 | x1 <- runMaybeT d1 202 | case x1 of 203 | Nothing -> runMaybeT d2 204 | Just _ -> return x1 205 | 206 | 207 | -- | Take @n@ samples from the distribution @r@, and eliminate any samples 208 | -- which fail a 'Control.Monad.guard' condition. 209 | sampleBayes :: (MonadRandom m) => MaybeT m a -> Int -> m [a] 210 | sampleBayes d n = liftM catMaybes (sample (runMaybeT d) n) 211 | 212 | -- | Take @n@ samples from the distribution @r@ using the IO monad, and 213 | -- eliminate any samples which fail a 'Control.Monad.guard' condition. 214 | sampleBayesIO :: BRand StdGen a -> Int -> IO [a] 215 | sampleBayesIO d n = evalRandIO (sampleBayes d n) 216 | 217 | {- $DDist 218 | 219 | Using the 'Control.Monad.Distribution.DDist' and 220 | 'Control.Monad.Distribution.BDDist' monads, you can compute exact 221 | distributions. For example: 222 | 223 | >ddist family 224 | >-- [MV 0.25 [Girl,Girl], 225 | >-- MV 0.25 [Girl,Boy], 226 | >-- MV 0.25 [Boy,Girl], 227 | >-- MV 0.25 [Boy,Boy]] 228 | 229 | If the probability distribution uses 'Control.Monad.guard', you can run it 230 | using 'Control.Monad.Distribution.bddist'. 231 | 232 | >bddist (tossesWithAtLeastOneHead 2) 233 | >-- Just [MV 1%3 [Heads,Heads], 234 | >-- MV 1%3 [Heads,Tails], 235 | >-- MV 1%3 [Tails,Heads]] 236 | 237 | Note that we see rational numbers in this second example, because we used 238 | @Control.Monad.Distribution.Rational@ above. 239 | 240 | -} 241 | 242 | instance (Probability p) => Dist (MVT p []) where 243 | weighted wvs = MVT (map toMV wvs) 244 | where toMV (v, w) = MV (prob (w / total)) v 245 | total = sum (map snd wvs) 246 | 247 | instance (Show a, Ord a, Show p, Probability p) => Show (MVT p [] a) where 248 | show = show . simplify . runMVT 249 | 250 | simplify :: (Probability p, Ord a) => [MV p a] -> [MV p a] 251 | simplify = map (foldr1 merge) . groupEvents . sortEvents 252 | where sortEvents = sortBy (liftOp compare) 253 | groupEvents = groupBy (liftOp (==)) 254 | liftOp op (MV _ v1) (MV _ v2) = op v1 v2 255 | merge (MV w1 v1) (MV w2 _) = MV (w1 `padd` w2) v1 256 | 257 | instance (Probability p) => BayesDist (MaybeT (MVT p [])) 258 | 259 | instance (Probability p) => MonadPlus (MaybeT (MVT p [])) where 260 | mzero = MaybeT (return Nothing) 261 | -- TODO: I'm not sure this is particularly sensible or useful. 262 | d1 `mplus` d2 263 | | isNothing (bayes d1) = d2 264 | | otherwise = d1 265 | 266 | catMaybes' :: (Monoid w) => [MV w (Maybe a)] -> [MV w a] 267 | catMaybes' = map (liftM fromJust) . filter (isJust . mvValue) 268 | 269 | -- | Apply Bayes' rule, discarding impossible outcomes and normalizing the 270 | -- probabilities that remain. 271 | -- 272 | -- TODO: It's entirely possible that this method should be moved to a type 273 | -- class. 274 | bayes :: (Probability p) => 275 | MaybeT (MVT p []) a -> Maybe ((MVT p []) a) 276 | bayes bfd 277 | | total == prob 0 = Nothing 278 | | otherwise = Just (weighted (map unpack events)) 279 | where 280 | events = catMaybes' (runMVT (runMaybeT bfd)) 281 | total = foldl' padd (prob 0) (map mvMonoid events) 282 | unpack (MV p v) = (v, fromProb p) 283 | --------------------------------------------------------------------------------