From 098e1243c945207e48870a62ab589a551d183225 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Mon, 4 Oct 2021 14:15:18 +0100 Subject: [PATCH 01/10] Add observable probability --- package.yaml | 4 +- src/Engine/AtomicGames.hs | 2 +- src/Engine/BayesianGames.hs | 2 +- src/Engine/BayesianGamesNonState.hs | 2 +- src/Engine/OpticClass.hs | 2 +- src/Examples/Markov/NStageMarkov.hs | 2 +- src/Examples/Markov/RepeatedPD.hs | 2 +- src/Examples/Markov/RepeatedPDNonState.hs | 2 +- src/Examples/Markov/TwoStageMarkov.hs | 2 +- src/Examples/Staking/AndGateMarkov.hs | 26 ++-- .../Probability/Distribution/Observable.hs | 145 ++++++++++++++++++ stack.yaml | 2 - stack.yaml.lock | 6 +- 13 files changed, 174 insertions(+), 25 deletions(-) create mode 100644 src/Numeric/Probability/Distribution/Observable.hs diff --git a/package.yaml b/package.yaml index 2ffc22f..b719b31 100644 --- a/package.yaml +++ b/package.yaml @@ -56,7 +56,8 @@ dependencies: - haskeline - hashmap - hashable - - extra + - extra + - bytestring executables: open-games-exe: @@ -81,4 +82,3 @@ benchmarks: dependencies: - open-games-hs - criterion - diff --git a/src/Engine/AtomicGames.hs b/src/Engine/AtomicGames.hs index b67df62..97b5079 100644 --- a/src/Engine/AtomicGames.hs +++ b/src/Engine/AtomicGames.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ExtendedDefaultRules #-} module Engine.AtomicGames ( decision @@ -141,4 +142,3 @@ generateGame "pureDecision2" ["actionSpace","payoffFunction","playerName"] $ (Block ["observation"] [] [Line [[|observation|]] [] [|dependentDecision playerName (\y -> actionSpace)|] ["action"] [[|payoffFunction observation action returns|]]] [[|action|]] ["returns"]) - diff --git a/src/Engine/BayesianGames.hs b/src/Engine/BayesianGames.hs index 333fb97..5f1ad76 100644 --- a/src/Engine/BayesianGames.hs +++ b/src/Engine/BayesianGames.hs @@ -36,7 +36,7 @@ import Data.HashMap as HM hiding (null,map,mapMa import Data.List (maximumBy) import Data.Ord (comparing) import Data.Utils -import Numeric.Probability.Distribution hiding (map, lift, filter) +import Numeric.Probability.Distribution.Observable hiding (map, lift, filter) import Engine.OpenGames hiding (lift) import Engine.OpticClass diff --git a/src/Engine/BayesianGamesNonState.hs b/src/Engine/BayesianGamesNonState.hs index 4477b6c..ae41993 100644 --- a/src/Engine/BayesianGamesNonState.hs +++ b/src/Engine/BayesianGamesNonState.hs @@ -34,7 +34,7 @@ import Data.HashMap as HM hiding (null,map,mapMa import Data.List (maximumBy) import Data.Ord (comparing) import Data.Utils -import Numeric.Probability.Distribution hiding (map, lift, filter) +import Numeric.Probability.Distribution.Observable hiding (map, lift, filter) import Engine.OpenGames hiding (lift) import Engine.OpticClass diff --git a/src/Engine/OpticClass.hs b/src/Engine/OpticClass.hs index b4391e4..879285d 100644 --- a/src/Engine/OpticClass.hs +++ b/src/Engine/OpticClass.hs @@ -21,7 +21,7 @@ module Engine.OpticClass import Control.Monad.State hiding (state) import Data.HashMap as HM hiding (null,map,mapMaybe) -import Numeric.Probability.Distribution hiding (lift) +import Numeric.Probability.Distribution.Observable hiding (lift) class Optic o where lens :: (s -> a) -> (s -> b -> t) -> o s t a b diff --git a/src/Examples/Markov/NStageMarkov.hs b/src/Examples/Markov/NStageMarkov.hs index e1a3e50..7d40212 100644 --- a/src/Examples/Markov/NStageMarkov.hs +++ b/src/Examples/Markov/NStageMarkov.hs @@ -14,7 +14,7 @@ import Examples.SimultaneousMoves (ActionPD(..), Location(..)) import Control.Monad.State hiding (state,void) import qualified Control.Monad.State as ST -import Numeric.Probability.Distribution hiding (map, lift, filter) +import Numeric.Probability.Distribution.Observable hiding (map, lift, filter) diff --git a/src/Examples/Markov/RepeatedPD.hs b/src/Examples/Markov/RepeatedPD.hs index e4f737b..ef6d4e6 100644 --- a/src/Examples/Markov/RepeatedPD.hs +++ b/src/Examples/Markov/RepeatedPD.hs @@ -14,7 +14,7 @@ import Examples.SimultaneousMoves (ActionPD(..),prisonersDilemmaMatrix import Control.Monad.State hiding (state,void) import qualified Control.Monad.State as ST -import Numeric.Probability.Distribution hiding (map, lift, filter) +import Numeric.Probability.Distribution.Observable hiding (map, lift, filter) prisonersDilemma :: OpenGame StochasticStatefulOptic diff --git a/src/Examples/Markov/RepeatedPDNonState.hs b/src/Examples/Markov/RepeatedPDNonState.hs index 14bfabc..5dba440 100644 --- a/src/Examples/Markov/RepeatedPDNonState.hs +++ b/src/Examples/Markov/RepeatedPDNonState.hs @@ -24,7 +24,7 @@ import Engine.BayesianGamesNonState import Preprocessor.Preprocessor -import Numeric.Probability.Distribution hiding (map, lift, filter) +import Numeric.Probability.Distribution.Observable hiding (map, lift, filter) -- 1.0. Prisoner's dilemma data ActionPD = Cooperate | Defect diff --git a/src/Examples/Markov/TwoStageMarkov.hs b/src/Examples/Markov/TwoStageMarkov.hs index 4e8d617..5ecfc93 100644 --- a/src/Examples/Markov/TwoStageMarkov.hs +++ b/src/Examples/Markov/TwoStageMarkov.hs @@ -14,7 +14,7 @@ import Examples.SimultaneousMoves (ActionPD(..), Location(..)) import Control.Monad.State hiding (state,void) import qualified Control.Monad.State as ST -import Numeric.Probability.Distribution hiding (map, lift, filter) +import Numeric.Probability.Distribution.Observable hiding (map, lift, filter) diff --git a/src/Examples/Staking/AndGateMarkov.hs b/src/Examples/Staking/AndGateMarkov.hs index 1c070fb..ab50c31 100644 --- a/src/Examples/Staking/AndGateMarkov.hs +++ b/src/Examples/Staking/AndGateMarkov.hs @@ -8,10 +8,11 @@ module Examples.Staking.AndGateMarkov where import Engine.Engine +import Numeric.Probability.Distribution.Observable import Preprocessor.Preprocessor -import Control.Monad.State hiding (state,void) -import qualified Control.Monad.State as ST +import Control.Monad.State hiding (state,void) +import qualified Control.Monad.State as ST -------- -- Types andGateMarkovTestParams = AndGateMarkovParams { @@ -291,23 +292,28 @@ extractNextState2 (StochasticStatefulOptic v _) x = do pure a -- Random prior indpendent of previous moves -determineContinuationPayoffs parameters 1 strat action = pure () determineContinuationPayoffs parameters iterator strat action = do - extractContinuation executeStrat action - nextInput <- ST.lift $ andGateTestPrior - determineContinuationPayoffs parameters (pred iterator) strat nextInput - where executeStrat = play (andGateGame parameters) strat + ST.lift $ note "determineContinuationPayoffs" + go parameters iterator strat action + where + go parameters 1 strat action = ST.lift $ note "go[1]" + go parameters iterator strat action = do + ST.lift $ note ("go[" ++ show iterator ++ "]") + extractContinuation executeStrat action + ST.lift $ note "andGateTestPrior" + nextInput <- ST.lift $ andGateTestPrior + go parameters (pred iterator) strat nextInput + where + executeStrat = play (andGateGame parameters) strat -- Actual moves affect next moves determineContinuationPayoffs' parameters 1 strat action = pure () determineContinuationPayoffs' parameters iterator strat action = do extractContinuation executeStrat action nextInput <- ST.lift $ extractNextState executeStrat action - determineContinuationPayoffs parameters (pred iterator) strat nextInput + determineContinuationPayoffs' parameters (pred iterator) strat nextInput where executeStrat = play (andGateGame parameters) strat - - -- fix context used for the evaluation contextCont parameters iterator strat initialAction = StochasticStatefulContext (pure ((),initialAction)) (\_ action -> determineContinuationPayoffs parameters iterator strat action) diff --git a/src/Numeric/Probability/Distribution/Observable.hs b/src/Numeric/Probability/Distribution/Observable.hs new file mode 100644 index 0000000..5cceec7 --- /dev/null +++ b/src/Numeric/Probability/Distribution/Observable.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE EmptyDataDecls, ImplicitParams #-} + +-- | Observable distribution monad. + +module Numeric.Probability.Distribution.Observable + ( T + , decons + , fromFreqs + , certainly + , expected + , mapMaybe + , uniform + , observeT + , toT + , note + ) where + +import Control.Monad +import Control.Monad.Reader +import qualified Data.ByteString.Char8 as S8 +import qualified Data.List as List +import GHC.Stack +import qualified Numeric.Probability.Distribution as I +import System.IO.Unsafe + +data T p a where + FromFreqs :: Fractional p => CallStack -> [(a,p)] -> T p a + Certainly :: CallStack -> a -> T p a + MapMaybe :: Fractional prob => CallStack -> (a -> Maybe b) -> T prob a -> T prob b + Uniform :: Fractional prob => CallStack -> [a] -> T prob a + Bind :: T p x -> (x -> T p b) -> T p b + Note :: CallStack -> String -> T p () + +instance (Num prob, Ord prob, Show prob, Ord a, Show a) => Show (T prob a) where + show _ = "T" + +instance (Num prob) => Monad (T prob) where + return = pure + (>>=) = Bind + +instance Num prob => Applicative (T prob) where + pure = Certainly emptyCallStack + (<*>) = ap + +instance Num prob => Functor (T prob) where + fmap = liftM + +-------------------------------------------------------------------------------- +-- Interpetable + +fromFreqs :: (Fractional p, HasCallStack) => [(a,p)] -> T p a +fromFreqs = FromFreqs callStack + +certainly :: HasCallStack => a -> T p a +certainly = Certainly callStack + +mapMaybe :: + (Fractional prob, HasCallStack) => (a -> Maybe b) -> T prob a -> T prob b +mapMaybe = MapMaybe callStack + +uniform :: (Fractional prob, HasCallStack) => [a] -> T prob a +uniform = Uniform callStack + +note :: HasCallStack => String -> T prob () +note = Note callStack + +-------------------------------------------------------------------------------- +-- Exports; this is where the monad is "run" and where we can +-- reasonably print a trace. + +{-# NOINLINE decons #-} +decons :: (Num p, Fractional p) => T p a -> [(a,p)] +decons t = unsafePerformIO (observeT t) + +expected :: (Num a, Fractional a) => T a a -> a +expected = sum . List.map (\(x,p) -> x * p) . decons + +-------------------------------------------------------------------------------- +-- Reflection + +toT :: Num p => T p a -> I.T p a +toT = + \case + Uniform _ as -> I.uniform as + FromFreqs _ fs -> I.fromFreqs fs + Certainly _ a -> I.certainly a + MapMaybe _ f x -> I.mapMaybe f (toT x) + Bind m f -> toT m >>= toT . f + Note _ _ -> pure () + +-------------------------------------------------------------------------------- +-- Reflection with printing + +observeT :: (Num p, Fractional p) => T p a -> IO [(a,p)] +observeT = flip runReaderT 0 . go + where + go :: (Num p, Fractional p) => T p a -> ReaderT Int IO [(a, p)] + go = + \case + Bind m f -> do + {-output "Bind-LHS"-} + xps <- local (+ 2) (go m) + if null xps + then do + {-output "LHS was null"-} + pure [] + else do + {-output "Bind-RHS"-} + yqps <- + local + (+ 2) + (traverse + (\(_i, (x, p)) -> do + {-output ("RHS[" <> S8.pack (show i) <> "]")-} + yqs <- local (+ 2) (go (f x)) + pure (map (\(y, q) -> (y, q * p)) yqs)) + (zip [1 :: Int ..] xps)) + pure (concat yqps) + Uniform _c as -> do + output "Uniform" + pure (I.decons (I.uniform as)) + FromFreqs _c as -> do + output "FromFreqs" + pure (I.decons (I.fromFreqs as)) + Certainly _c as -> do + {-output "Certainly"-} + pure (I.decons (I.certainly as)) + MapMaybe _c f as -> do + {-output "MapMaybe"-} + as' <- go as + pure (I.decons (I.mapMaybe f (I.fromFreqs as'))) + Note _c no -> do + output ("Note: " <> S8.pack no) + pure [] + _smallCs c = + case getCallStack c of + [] -> "(no call stack)" + ((_, srcloc):_) -> prettySrcLoc srcloc + output s = do + i <- ask + lift (S8.putStrLn (S8.replicate i ' ' <> s)) diff --git a/stack.yaml b/stack.yaml index 3dbf66e..c158138 100644 --- a/stack.yaml +++ b/stack.yaml @@ -41,8 +41,6 @@ extra-deps: # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # -extra-deps: - - probability-0.2.6@sha256:6d85d961d85fd5d1a35b90fe77510f6fcc6a8f20e8ed503219c38378de9cb3cd,2857 # Override default flag values for local packages and extra-deps # flags: {} diff --git a/stack.yaml.lock b/stack.yaml.lock index f67b51e..c69c5fd 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,12 +5,12 @@ packages: - completed: - hackage: probability-0.2.6@sha256:6d85d961d85fd5d1a35b90fe77510f6fcc6a8f20e8ed503219c38378de9cb3cd,2857 + hackage: probability-0.2.7@sha256:3e9fe130af3bd75e791e1add902eb2caab170cc95373281c0a9626b01fc3b104,2869 pantry-tree: size: 2711 - sha256: 3ff942c55282f5e60db3f86ec1a0f69fd0134648838c23a990f1c72b8914602c + sha256: ee8953628fe301a29be9ef64ebd96f8c704969fec2b4e0b39243e6499911b767 original: - hackage: probability-0.2.6@sha256:6d85d961d85fd5d1a35b90fe77510f6fcc6a8f20e8ed503219c38378de9cb3cd,2857 + hackage: probability-0.2.7@sha256:3e9fe130af3bd75e791e1add902eb2caab170cc95373281c0a9626b01fc3b104,2869 snapshots: - completed: size: 533053 From f82f160a5c73d76d5fc3aaa41e4b669e1cdb560d Mon Sep 17 00:00:00 2001 From: Chris Done Date: Mon, 4 Oct 2021 14:15:18 +0100 Subject: [PATCH 02/10] Add observable probability --- package.yaml | 4 +- src/Engine/AtomicGames.hs | 2 +- src/Engine/BayesianGames.hs | 2 +- src/Engine/BayesianGamesNonState.hs | 2 +- src/Engine/OpticClass.hs | 2 +- src/Examples/Markov/NStageMarkov.hs | 2 +- src/Examples/Markov/RepeatedPD.hs | 2 +- src/Examples/Markov/RepeatedPDNonState.hs | 2 +- src/Examples/Markov/TwoStageMarkov.hs | 2 +- src/Examples/Staking/AndGateMarkov.hs | 19 ++- .../Probability/Distribution/Observable.hs | 145 ++++++++++++++++++ stack.yaml | 2 - stack.yaml.lock | 6 +- 13 files changed, 171 insertions(+), 21 deletions(-) create mode 100644 src/Numeric/Probability/Distribution/Observable.hs diff --git a/package.yaml b/package.yaml index 2ffc22f..b719b31 100644 --- a/package.yaml +++ b/package.yaml @@ -56,7 +56,8 @@ dependencies: - haskeline - hashmap - hashable - - extra + - extra + - bytestring executables: open-games-exe: @@ -81,4 +82,3 @@ benchmarks: dependencies: - open-games-hs - criterion - diff --git a/src/Engine/AtomicGames.hs b/src/Engine/AtomicGames.hs index b67df62..97b5079 100644 --- a/src/Engine/AtomicGames.hs +++ b/src/Engine/AtomicGames.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ExtendedDefaultRules #-} module Engine.AtomicGames ( decision @@ -141,4 +142,3 @@ generateGame "pureDecision2" ["actionSpace","payoffFunction","playerName"] $ (Block ["observation"] [] [Line [[|observation|]] [] [|dependentDecision playerName (\y -> actionSpace)|] ["action"] [[|payoffFunction observation action returns|]]] [[|action|]] ["returns"]) - diff --git a/src/Engine/BayesianGames.hs b/src/Engine/BayesianGames.hs index 333fb97..5f1ad76 100644 --- a/src/Engine/BayesianGames.hs +++ b/src/Engine/BayesianGames.hs @@ -36,7 +36,7 @@ import Data.HashMap as HM hiding (null,map,mapMa import Data.List (maximumBy) import Data.Ord (comparing) import Data.Utils -import Numeric.Probability.Distribution hiding (map, lift, filter) +import Numeric.Probability.Distribution.Observable hiding (map, lift, filter) import Engine.OpenGames hiding (lift) import Engine.OpticClass diff --git a/src/Engine/BayesianGamesNonState.hs b/src/Engine/BayesianGamesNonState.hs index 4477b6c..ae41993 100644 --- a/src/Engine/BayesianGamesNonState.hs +++ b/src/Engine/BayesianGamesNonState.hs @@ -34,7 +34,7 @@ import Data.HashMap as HM hiding (null,map,mapMa import Data.List (maximumBy) import Data.Ord (comparing) import Data.Utils -import Numeric.Probability.Distribution hiding (map, lift, filter) +import Numeric.Probability.Distribution.Observable hiding (map, lift, filter) import Engine.OpenGames hiding (lift) import Engine.OpticClass diff --git a/src/Engine/OpticClass.hs b/src/Engine/OpticClass.hs index b4391e4..879285d 100644 --- a/src/Engine/OpticClass.hs +++ b/src/Engine/OpticClass.hs @@ -21,7 +21,7 @@ module Engine.OpticClass import Control.Monad.State hiding (state) import Data.HashMap as HM hiding (null,map,mapMaybe) -import Numeric.Probability.Distribution hiding (lift) +import Numeric.Probability.Distribution.Observable hiding (lift) class Optic o where lens :: (s -> a) -> (s -> b -> t) -> o s t a b diff --git a/src/Examples/Markov/NStageMarkov.hs b/src/Examples/Markov/NStageMarkov.hs index e1a3e50..7d40212 100644 --- a/src/Examples/Markov/NStageMarkov.hs +++ b/src/Examples/Markov/NStageMarkov.hs @@ -14,7 +14,7 @@ import Examples.SimultaneousMoves (ActionPD(..), Location(..)) import Control.Monad.State hiding (state,void) import qualified Control.Monad.State as ST -import Numeric.Probability.Distribution hiding (map, lift, filter) +import Numeric.Probability.Distribution.Observable hiding (map, lift, filter) diff --git a/src/Examples/Markov/RepeatedPD.hs b/src/Examples/Markov/RepeatedPD.hs index d24d2d1..8608799 100644 --- a/src/Examples/Markov/RepeatedPD.hs +++ b/src/Examples/Markov/RepeatedPD.hs @@ -14,7 +14,7 @@ import Examples.SimultaneousMoves (ActionPD(..),prisonersDilemmaMatrix import Control.Monad.State hiding (state,void) import qualified Control.Monad.State as ST -import Numeric.Probability.Distribution hiding (map, lift, filter) +import Numeric.Probability.Distribution.Observable hiding (map, lift, filter) prisonersDilemma :: OpenGame StochasticStatefulOptic diff --git a/src/Examples/Markov/RepeatedPDNonState.hs b/src/Examples/Markov/RepeatedPDNonState.hs index 14bfabc..5dba440 100644 --- a/src/Examples/Markov/RepeatedPDNonState.hs +++ b/src/Examples/Markov/RepeatedPDNonState.hs @@ -24,7 +24,7 @@ import Engine.BayesianGamesNonState import Preprocessor.Preprocessor -import Numeric.Probability.Distribution hiding (map, lift, filter) +import Numeric.Probability.Distribution.Observable hiding (map, lift, filter) -- 1.0. Prisoner's dilemma data ActionPD = Cooperate | Defect diff --git a/src/Examples/Markov/TwoStageMarkov.hs b/src/Examples/Markov/TwoStageMarkov.hs index 4e8d617..5ecfc93 100644 --- a/src/Examples/Markov/TwoStageMarkov.hs +++ b/src/Examples/Markov/TwoStageMarkov.hs @@ -14,7 +14,7 @@ import Examples.SimultaneousMoves (ActionPD(..), Location(..)) import Control.Monad.State hiding (state,void) import qualified Control.Monad.State as ST -import Numeric.Probability.Distribution hiding (map, lift, filter) +import Numeric.Probability.Distribution.Observable hiding (map, lift, filter) diff --git a/src/Examples/Staking/AndGateMarkov.hs b/src/Examples/Staking/AndGateMarkov.hs index 544d40e..e259729 100644 --- a/src/Examples/Staking/AndGateMarkov.hs +++ b/src/Examples/Staking/AndGateMarkov.hs @@ -9,6 +9,7 @@ module Examples.Staking.AndGateMarkov where import Debug.Trace import Engine.Engine +import Numeric.Probability.Distribution.Observable import Preprocessor.Preprocessor import Control.Monad.State hiding (state,void) @@ -298,13 +299,19 @@ extractNextState2 (StochasticStatefulOptic v _) x = do pure a -- Random prior indpendent of previous moves -determineContinuationPayoffs parameters 1 strat action = pure () determineContinuationPayoffs parameters iterator strat action = do - trace ",,1" (pure ()) - extractContinuation executeStrat action - nextInput <- ST.lift $ andGateTestPrior - determineContinuationPayoffs parameters (pred iterator) strat nextInput - where executeStrat = play (andGateGame parameters) strat + ST.lift $ note "determineContinuationPayoffs" + go parameters iterator strat action + where + go parameters 1 strat action = ST.lift $ note "go[1]" + go parameters iterator strat action = do + ST.lift $ note ("go[" ++ show iterator ++ "]") + extractContinuation executeStrat action + ST.lift $ note "andGateTestPrior" + nextInput <- ST.lift $ andGateTestPrior + go parameters (pred iterator) strat nextInput + where + executeStrat = play (andGateGame parameters) strat -- Actual moves affect next moves determineContinuationPayoffs' parameters 1 strat action = pure () diff --git a/src/Numeric/Probability/Distribution/Observable.hs b/src/Numeric/Probability/Distribution/Observable.hs new file mode 100644 index 0000000..5cceec7 --- /dev/null +++ b/src/Numeric/Probability/Distribution/Observable.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE EmptyDataDecls, ImplicitParams #-} + +-- | Observable distribution monad. + +module Numeric.Probability.Distribution.Observable + ( T + , decons + , fromFreqs + , certainly + , expected + , mapMaybe + , uniform + , observeT + , toT + , note + ) where + +import Control.Monad +import Control.Monad.Reader +import qualified Data.ByteString.Char8 as S8 +import qualified Data.List as List +import GHC.Stack +import qualified Numeric.Probability.Distribution as I +import System.IO.Unsafe + +data T p a where + FromFreqs :: Fractional p => CallStack -> [(a,p)] -> T p a + Certainly :: CallStack -> a -> T p a + MapMaybe :: Fractional prob => CallStack -> (a -> Maybe b) -> T prob a -> T prob b + Uniform :: Fractional prob => CallStack -> [a] -> T prob a + Bind :: T p x -> (x -> T p b) -> T p b + Note :: CallStack -> String -> T p () + +instance (Num prob, Ord prob, Show prob, Ord a, Show a) => Show (T prob a) where + show _ = "T" + +instance (Num prob) => Monad (T prob) where + return = pure + (>>=) = Bind + +instance Num prob => Applicative (T prob) where + pure = Certainly emptyCallStack + (<*>) = ap + +instance Num prob => Functor (T prob) where + fmap = liftM + +-------------------------------------------------------------------------------- +-- Interpetable + +fromFreqs :: (Fractional p, HasCallStack) => [(a,p)] -> T p a +fromFreqs = FromFreqs callStack + +certainly :: HasCallStack => a -> T p a +certainly = Certainly callStack + +mapMaybe :: + (Fractional prob, HasCallStack) => (a -> Maybe b) -> T prob a -> T prob b +mapMaybe = MapMaybe callStack + +uniform :: (Fractional prob, HasCallStack) => [a] -> T prob a +uniform = Uniform callStack + +note :: HasCallStack => String -> T prob () +note = Note callStack + +-------------------------------------------------------------------------------- +-- Exports; this is where the monad is "run" and where we can +-- reasonably print a trace. + +{-# NOINLINE decons #-} +decons :: (Num p, Fractional p) => T p a -> [(a,p)] +decons t = unsafePerformIO (observeT t) + +expected :: (Num a, Fractional a) => T a a -> a +expected = sum . List.map (\(x,p) -> x * p) . decons + +-------------------------------------------------------------------------------- +-- Reflection + +toT :: Num p => T p a -> I.T p a +toT = + \case + Uniform _ as -> I.uniform as + FromFreqs _ fs -> I.fromFreqs fs + Certainly _ a -> I.certainly a + MapMaybe _ f x -> I.mapMaybe f (toT x) + Bind m f -> toT m >>= toT . f + Note _ _ -> pure () + +-------------------------------------------------------------------------------- +-- Reflection with printing + +observeT :: (Num p, Fractional p) => T p a -> IO [(a,p)] +observeT = flip runReaderT 0 . go + where + go :: (Num p, Fractional p) => T p a -> ReaderT Int IO [(a, p)] + go = + \case + Bind m f -> do + {-output "Bind-LHS"-} + xps <- local (+ 2) (go m) + if null xps + then do + {-output "LHS was null"-} + pure [] + else do + {-output "Bind-RHS"-} + yqps <- + local + (+ 2) + (traverse + (\(_i, (x, p)) -> do + {-output ("RHS[" <> S8.pack (show i) <> "]")-} + yqs <- local (+ 2) (go (f x)) + pure (map (\(y, q) -> (y, q * p)) yqs)) + (zip [1 :: Int ..] xps)) + pure (concat yqps) + Uniform _c as -> do + output "Uniform" + pure (I.decons (I.uniform as)) + FromFreqs _c as -> do + output "FromFreqs" + pure (I.decons (I.fromFreqs as)) + Certainly _c as -> do + {-output "Certainly"-} + pure (I.decons (I.certainly as)) + MapMaybe _c f as -> do + {-output "MapMaybe"-} + as' <- go as + pure (I.decons (I.mapMaybe f (I.fromFreqs as'))) + Note _c no -> do + output ("Note: " <> S8.pack no) + pure [] + _smallCs c = + case getCallStack c of + [] -> "(no call stack)" + ((_, srcloc):_) -> prettySrcLoc srcloc + output s = do + i <- ask + lift (S8.putStrLn (S8.replicate i ' ' <> s)) diff --git a/stack.yaml b/stack.yaml index 3dbf66e..c158138 100644 --- a/stack.yaml +++ b/stack.yaml @@ -41,8 +41,6 @@ extra-deps: # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # -extra-deps: - - probability-0.2.6@sha256:6d85d961d85fd5d1a35b90fe77510f6fcc6a8f20e8ed503219c38378de9cb3cd,2857 # Override default flag values for local packages and extra-deps # flags: {} diff --git a/stack.yaml.lock b/stack.yaml.lock index f67b51e..c69c5fd 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,12 +5,12 @@ packages: - completed: - hackage: probability-0.2.6@sha256:6d85d961d85fd5d1a35b90fe77510f6fcc6a8f20e8ed503219c38378de9cb3cd,2857 + hackage: probability-0.2.7@sha256:3e9fe130af3bd75e791e1add902eb2caab170cc95373281c0a9626b01fc3b104,2869 pantry-tree: size: 2711 - sha256: 3ff942c55282f5e60db3f86ec1a0f69fd0134648838c23a990f1c72b8914602c + sha256: ee8953628fe301a29be9ef64ebd96f8c704969fec2b4e0b39243e6499911b767 original: - hackage: probability-0.2.6@sha256:6d85d961d85fd5d1a35b90fe77510f6fcc6a8f20e8ed503219c38378de9cb3cd,2857 + hackage: probability-0.2.7@sha256:3e9fe130af3bd75e791e1add902eb2caab170cc95373281c0a9626b01fc3b104,2869 snapshots: - completed: size: 533053 From 01ab2d532f595d8c6ec7ad3b82b1531e28f476bd Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 5 Oct 2021 12:35:09 +0100 Subject: [PATCH 03/10] Suspiciously fast result --- src/Examples/Staking/AndGateMarkov.hs | 13 ++++++++++--- src/Numeric/Probability/Distribution/Observable.hs | 3 ++- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/src/Examples/Staking/AndGateMarkov.hs b/src/Examples/Staking/AndGateMarkov.hs index e259729..11f5859 100644 --- a/src/Examples/Staking/AndGateMarkov.hs +++ b/src/Examples/Staking/AndGateMarkov.hs @@ -32,7 +32,7 @@ andGateMarkovTestParams = AndGateMarkovParams { penalty = 0.5, minDeposit = 0.0, maxDeposit = 10.0, - incrementDeposit = 0.1, + incrementDeposit = 0.5, epsilon = 0.001, discountFactor = 0.5 } @@ -299,9 +299,9 @@ extractNextState2 (StochasticStatefulOptic v _) x = do pure a -- Random prior indpendent of previous moves -determineContinuationPayoffs parameters iterator strat action = do +determineContinuationPayoffs parameters0 iterator0 strat0 action0 = do ST.lift $ note "determineContinuationPayoffs" - go parameters iterator strat action + go parameters0 iterator0 strat0 action0 where go parameters 1 strat action = ST.lift $ note "go[1]" go parameters iterator strat action = do @@ -313,6 +313,13 @@ determineContinuationPayoffs parameters iterator strat action = do where executeStrat = play (andGateGame parameters) strat +determineContinuationPayoffs_ parameters 1 strat action = pure () +determineContinuationPayoffs_ parameters iterator strat action = do + extractContinuation executeStrat action + nextInput <- ST.lift $ andGateTestPrior + determineContinuationPayoffs parameters (pred iterator) strat nextInput + where executeStrat = play (andGateGame parameters) strat + -- Actual moves affect next moves determineContinuationPayoffs' parameters 1 strat action = pure () determineContinuationPayoffs' parameters iterator strat action = do diff --git a/src/Numeric/Probability/Distribution/Observable.hs b/src/Numeric/Probability/Distribution/Observable.hs index 5cceec7..9f85702 100644 --- a/src/Numeric/Probability/Distribution/Observable.hs +++ b/src/Numeric/Probability/Distribution/Observable.hs @@ -142,4 +142,5 @@ observeT = flip runReaderT 0 . go ((_, srcloc):_) -> prettySrcLoc srcloc output s = do i <- ask - lift (S8.putStrLn (S8.replicate i ' ' <> s)) + -- lift (S8.putStrLn (S8.replicate i ' ' <> s)) + pure () From f21c158a9d4d5a888009894688a54d56abf2f02e Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 5 Oct 2021 16:22:18 +0100 Subject: [PATCH 04/10] Correct impl. of note --- src/Numeric/Probability/Distribution/Observable.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Numeric/Probability/Distribution/Observable.hs b/src/Numeric/Probability/Distribution/Observable.hs index 9f85702..124f2c0 100644 --- a/src/Numeric/Probability/Distribution/Observable.hs +++ b/src/Numeric/Probability/Distribution/Observable.hs @@ -135,12 +135,12 @@ observeT = flip runReaderT 0 . go pure (I.decons (I.mapMaybe f (I.fromFreqs as'))) Note _c no -> do output ("Note: " <> S8.pack no) - pure [] + pure [((),1)] _smallCs c = case getCallStack c of [] -> "(no call stack)" ((_, srcloc):_) -> prettySrcLoc srcloc output s = do i <- ask - -- lift (S8.putStrLn (S8.replicate i ' ' <> s)) + lift (S8.putStrLn (S8.replicate i ' ' <> s)) pure () From b69d32acd2a6675d7a6e19b46ed0e6fd2936faff Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 5 Oct 2021 16:23:58 +0100 Subject: [PATCH 05/10] Drop indentation --- src/Numeric/Probability/Distribution/Observable.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Numeric/Probability/Distribution/Observable.hs b/src/Numeric/Probability/Distribution/Observable.hs index 124f2c0..f5dd46c 100644 --- a/src/Numeric/Probability/Distribution/Observable.hs +++ b/src/Numeric/Probability/Distribution/Observable.hs @@ -103,7 +103,7 @@ observeT = flip runReaderT 0 . go \case Bind m f -> do {-output "Bind-LHS"-} - xps <- local (+ 2) (go m) + xps <- {-local (+ 2) -}(go m) if null xps then do {-output "LHS was null"-} @@ -111,12 +111,13 @@ observeT = flip runReaderT 0 . go else do {-output "Bind-RHS"-} yqps <- - local - (+ 2) + -- local + -- (+ 2) (traverse (\(_i, (x, p)) -> do {-output ("RHS[" <> S8.pack (show i) <> "]")-} - yqs <- local (+ 2) (go (f x)) + yqs <- -- local (+ 2) + (go (f x)) pure (map (\(y, q) -> (y, q * p)) yqs)) (zip [1 :: Int ..] xps)) pure (concat yqps) From 17e18c34a6a03380446284edb9008880e81b3f98 Mon Sep 17 00:00:00 2001 From: Philipp Zahn Date: Wed, 6 Oct 2021 16:32:44 +0200 Subject: [PATCH 06/10] Changed state space --- src/Examples/Staking/AndGateMarkov.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Examples/Staking/AndGateMarkov.hs b/src/Examples/Staking/AndGateMarkov.hs index 001d456..ecab5b8 100644 --- a/src/Examples/Staking/AndGateMarkov.hs +++ b/src/Examples/Staking/AndGateMarkov.hs @@ -14,6 +14,7 @@ import Preprocessor.Preprocessor import Control.Monad.State hiding (state,void) import qualified Control.Monad.State as ST + -------- -- Types andGateMarkovTestParams = AndGateMarkovParams { @@ -27,7 +28,7 @@ andGateMarkovTestParams = AndGateMarkovParams { penalty = 0.5, minDeposit = 0.0, maxDeposit = 10.0, - incrementDeposit = 0.5, + incrementDeposit = 2, epsilon = 0.001, discountFactor = 0.5 } From 9f813b6d6bfe912f4dbd9b445f392abf71ab180e Mon Sep 17 00:00:00 2001 From: Philipp Zahn Date: Wed, 6 Oct 2021 17:15:26 +0200 Subject: [PATCH 07/10] Added AndGateMarkov to Main file --- app/Main.hs | 14 ++------------ package.yaml | 1 + 2 files changed, 3 insertions(+), 12 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 893345a..d814b50 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -4,17 +4,7 @@ import Examples.Decision import Examples.SimultaneousMoves import Examples.SequentialMoves +import Examples.Staking.AndGateMarkov main = do - putStrLn "Single decision -->" - isOptimalSingleDecisionVerbose (pureIdentity 4) - putStrLn "\n Single decision -->" - isOptimalSingleDecisionVerbose (pureIdentity 5) - putStrLn "\n Single decision with stochastic environment -->" - isOptimalSingleDecisionStoch peak - putStrLn "\n Prisoner's dilemma both cooperate -->" - isEquilibriumPrisonersDilemma strategTupleCooperate - putStrLn "\n Prisoner's dilemma both defect -->" - isEquilibriumPrisonersDilemma strategTupleDefect - putStrLn "\n Matching Pennies - mixed with equal prob -->" - isEquilibriumMatchingPennies strategyTupleMixed + testEq 2 diff --git a/package.yaml b/package.yaml index b719b31..52e1cf9 100644 --- a/package.yaml +++ b/package.yaml @@ -40,6 +40,7 @@ library: - Examples.Markov.RepeatedPD - Examples.Markov.RepeatedPDNonState - Examples.Markov.TwoStageMarkov + - Examples.Staking.AndGateMarkov dependencies: - base >=4.7 && <5 From 7ebc7d8199e7bf7036a80e7257cde934122cb35d Mon Sep 17 00:00:00 2001 From: Philipp Zahn Date: Wed, 6 Oct 2021 17:15:41 +0200 Subject: [PATCH 08/10] Corrected changes in Probability Observable --- src/Numeric/Probability/Distribution/Observable.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Numeric/Probability/Distribution/Observable.hs b/src/Numeric/Probability/Distribution/Observable.hs index f5dd46c..124f2c0 100644 --- a/src/Numeric/Probability/Distribution/Observable.hs +++ b/src/Numeric/Probability/Distribution/Observable.hs @@ -103,7 +103,7 @@ observeT = flip runReaderT 0 . go \case Bind m f -> do {-output "Bind-LHS"-} - xps <- {-local (+ 2) -}(go m) + xps <- local (+ 2) (go m) if null xps then do {-output "LHS was null"-} @@ -111,13 +111,12 @@ observeT = flip runReaderT 0 . go else do {-output "Bind-RHS"-} yqps <- - -- local - -- (+ 2) + local + (+ 2) (traverse (\(_i, (x, p)) -> do {-output ("RHS[" <> S8.pack (show i) <> "]")-} - yqs <- -- local (+ 2) - (go (f x)) + yqs <- local (+ 2) (go (f x)) pure (map (\(y, q) -> (y, q * p)) yqs)) (zip [1 :: Int ..] xps)) pure (concat yqps) From e8b222eb680b8370ce4919146935b856d362a71f Mon Sep 17 00:00:00 2001 From: Philipp Zahn Date: Wed, 6 Oct 2021 17:15:58 +0200 Subject: [PATCH 09/10] Explored iterations in PD --- src/Examples/Markov/RepeatedPD.hs | 43 ++++++++++++++++++++++++++----- 1 file changed, 37 insertions(+), 6 deletions(-) diff --git a/src/Examples/Markov/RepeatedPD.hs b/src/Examples/Markov/RepeatedPD.hs index 8608799..793363f 100644 --- a/src/Examples/Markov/RepeatedPD.hs +++ b/src/Examples/Markov/RepeatedPD.hs @@ -27,7 +27,7 @@ prisonersDilemma :: OpenGame () (ActionPD, ActionPD) () -discountFactor = 0.5 +discountFactor = 0.9 prisonersDilemma = [opengame| @@ -68,6 +68,15 @@ stageStrategy = Kleisli $ -- Stage strategy tuple strategyTuple = stageStrategy ::- stageStrategy ::- Nil +stageStrategy' :: Kleisli Stochastic (ActionPD, ActionPD) ActionPD +stageStrategy' = Kleisli $ + (\case + (Cooperate,Cooperate) -> uniformDist [Cooperate,Defect] + (_,_) -> uniformDist [Cooperate,Defect]) +-- Stage strategy tuple +strategyTuple' = stageStrategy ::- stageStrategy ::- Nil + + -- extract continuation extractContinuation :: StochasticStatefulOptic s () a () -> s -> StateT Vector Stochastic () @@ -85,22 +94,39 @@ executeStrat strat = play prisonersDilemma strat -- determine continuation for iterator, with the same repeated strategy -determineContinuationPayoffs :: Integer +determineContinuationPayoffs__ :: Integer -> List '[Kleisli Stochastic (ActionPD, ActionPD) ActionPD, Kleisli Stochastic (ActionPD, ActionPD) ActionPD] -> (ActionPD,ActionPD) -> StateT Vector Stochastic () -determineContinuationPayoffs 1 strat action = pure () -determineContinuationPayoffs iterator strat action = do +determineContinuationPayoffs__ 1 strat action = pure () +determineContinuationPayoffs__ iterator strat action = do extractContinuation executeStrat action nextInput <- ST.lift $ extractNextState executeStrat action - determineContinuationPayoffs (pred iterator) strat nextInput + determineContinuationPayoffs__ (pred iterator) strat nextInput where executeStrat = play prisonersDilemma strat +-- Random prior indpendent of previous moves +determineContinuationPayoffs iterator strat action = do + ST.lift $ note "determineContinuationPayoffs" + go iterator strat action + where + go 1 strat action = ST.lift $ note "go[1]" + go iterator strat action = do + ST.lift $ note ("go[" ++ show iterator ++ "]") + extractContinuation executeStrat action + ST.lift $ note "nextState" + nextInput <- ST.lift $ extractNextState executeStrat action + go (pred iterator) strat nextInput + where + executeStrat = play prisonersDilemma strat + + + -- fix context used for the evaluation -contextCont iterator strat initialAction = StochasticStatefulContext (pure ((),initialAction)) (\_ action -> trace ",,1" (determineContinuationPayoffs iterator strat action)) +contextCont iterator strat initialAction = StochasticStatefulContext (pure ((),initialAction)) (\_ action -> determineContinuationPayoffs iterator strat action) @@ -112,3 +138,8 @@ repeatedPDEq iterator strat initialAction = evaluate prisonersDilemma strat cont eqOutput iterator strat initialAction = generateIsEq $ repeatedPDEq iterator strat initialAction + + +testEq iterator = eqOutput iterator strategyTuple (Cooperate,Cooperate) + +testEq' iterator = eqOutput iterator strategyTuple' (Cooperate,Cooperate) From c0119b25f98e377cc2568304cf8e625e66d1c455 Mon Sep 17 00:00:00 2001 From: Philipp Zahn Date: Wed, 6 Oct 2021 17:45:27 +0200 Subject: [PATCH 10/10] Added Test Example and output --- src/Examples/Markov/Output.txt | 156 +++++++ src/Examples/Markov/TwoStageMarkovTest.hs | 498 ++++++++++++++++++++++ 2 files changed, 654 insertions(+) create mode 100644 src/Examples/Markov/Output.txt create mode 100644 src/Examples/Markov/TwoStageMarkovTest.hs diff --git a/src/Examples/Markov/Output.txt b/src/Examples/Markov/Output.txt new file mode 100644 index 0000000..45bfc30 --- /dev/null +++ b/src/Examples/Markov/Output.txt @@ -0,0 +1,156 @@ +TwoStageMarkovTest with 2 iterations + +Note: determineContinuationPayoffs + Note: go[2] + Note: nextState + Note: go[1] + Note: determineContinuationPayoffs + Note: go[2] + Note: nextState + Note: go[1] + Uniform + Note: determineContinuationPayoffs + Note: go[2] + Note: nextState + Note: go[1] + Note: determineContinuationPayoffs + Note: go[2] + Uniform + Note: nextState + Uniform + Note: go[1] + Note: go[1] + Note: nextState + Uniform + Note: go[1] + Note: go[1] +------------------------------------ +TwoStageMarkovTest with 3 iterations + +----Analytics begin---- Note: determineContinuationPayoffs + Note: go[3] + Note: nextState + Note: go[2] + Note: nextState + Note: go[1] + Note: determineContinuationPayoffs + Note: go[3] + Note: nextState + Note: go[2] + Note: nextState + Note: go[1] + Uniform + Note: determineContinuationPayoffs + Note: go[3] + Note: nextState + Note: go[2] + Note: nextState + Note: go[1] + Note: determineContinuationPayoffs + Note: go[3] + Uniform + Note: nextState + Uniform + Note: go[2] + Note: nextState + Note: go[1] + Note: go[2] + Uniform + Note: nextState + Uniform + Note: go[1] + Note: go[1] + Note: nextState + Uniform + Note: go[1] + Note: go[1] + Note: nextState + Uniform + Note: go[2] + Note: nextState + Note: go[1] + Note: go[2] + Uniform + Note: nextState + Uniform + Note: go[1] + Note: go[1] + Note: nextState + Uniform + Note: go[1] + Note: go[1] + +--------------------------- +TwoStageMarkovTest -- with deterministic transition and 2 iterations +----Analytics begin---- Note: determineContinuationPayoffs + Note: go[2] + Note: nextState + Note: go[1] + Note: determineContinuationPayoffs + Note: go[2] + Note: nextState + Note: go[1] + Note: determineContinuationPayoffs + Note: go[2] + Note: nextState + Note: go[1 + + +--------------------------- +TwoStageMarkovTest -- with deterministic transition and 3 iterations +----Analytics begin---- Note: determineContinuationPayoffs + Note: go[3] + Note: nextState + Note: go[2] + Note: nextState + Note: go[1] + Note: determineContinuationPayoffs + Note: go[3] + Note: nextState + Note: go[2] + Note: nextState + Note: go[1] + Note: determineContinuationPayoffs + Note: go[3] + Note: nextState + Note: go[2] + Note: nextState + Note: go[1] + + +---------------------------- +RepeatedPD with 2 iterations + +Note: determineContinuationPayoffs + Note: go[2] + Note: nextState + Note: go[1] + Note: determineContinuationPayoffs + Note: go[2] + Note: nextState + Note: go[1] + Note: determineContinuationPayoffs + Note: go[2] + Note: nextState + Note: go[1 +---------------------------- +RepeatedPD with 3 iterations + +----Analytics begin---- Note: determineContinuationPayoffs + Note: go[3] + Note: nextState + Note: go[2] + Note: nextState + Note: go[1] + Note: determineContinuationPayoffs + Note: go[3] + Note: nextState + Note: go[2] + Note: nextState + Note: go[1] + Note: determineContinuationPayoffs + Note: go[3] + Note: nextState + Note: go[2] + Note: nextState + Note: go[1] diff --git a/src/Examples/Markov/TwoStageMarkovTest.hs b/src/Examples/Markov/TwoStageMarkovTest.hs new file mode 100644 index 0000000..f8fe0fb --- /dev/null +++ b/src/Examples/Markov/TwoStageMarkovTest.hs @@ -0,0 +1,498 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} + +module Examples.Markov.TwoStageMarkovTest where + +import Data.Tuple.Extra (uncurry3) +import Engine.Engine +import Preprocessor.Preprocessor +import Examples.SimultaneousMoves (ActionPD(..), Location(..)) + +import Control.Monad.State hiding (state,void) +import qualified Control.Monad.State as ST + +import Numeric.Probability.Distribution.Observable hiding (map, lift, filter) + + + + +-------- +-- Types + +type EndState = Bool + +---------- +-- Payoffs + +-- | Payoff matrix for player i given i's action and j's action +prisonersDilemmaMatrix :: EndState -> ActionPD -> ActionPD -> Double +prisonersDilemmaMatrix True _ _ = 0 +prisonersDilemmaMatrix _ Cooperate Cooperate = 3 +prisonersDilemmaMatrix _ Cooperate Defect = 0 +prisonersDilemmaMatrix _ Defect Cooperate = 5 +prisonersDilemmaMatrix _ Defect Defect = 1 + + +-- | Payoff matrix meeting in NY +meetingInNYMatrix :: EndState -> Location -> Location -> Double +meetingInNYMatrix False _ _ = 0 +meetingInNYMatrix True x y = if x == y then 1 else 0 + +discountFactor = 1 + +-- | Fixed payoff for single decision end state +punishment True = - 10 +punishment False = 0 + +-- | Fixed payoff solely depending on state +payoffGame True = 0 +payoffGame False = 1 + + + +---------------------- +-- Auxiliary functions + +-- Once in endstate, we stay there +-- The transition happens with 0.5 probability if one of the actions is defect +transitionEndState :: EndState -> ActionPD -> ActionPD -> Stochastic EndState +transitionEndState True _ _ = playDeterministically True +transitionEndState False Defect _ = uniform [True,False] +transitionEndState False _ Defect = uniform [True,False] +transitionEndState False Cooperate Cooperate = playDeterministically False + +-- The transition happens deterministically if one of the player does not play _Cooperate_ and then we stay there +transitionEndStateDeterm :: EndState -> ActionPD -> ActionPD -> Stochastic EndState +transitionEndStateDeterm True _ _ = playDeterministically True +transitionEndStateDeterm False Cooperate Cooperate = playDeterministically False +transitionEndStateDeterm False _ _ = playDeterministically True + + + +------------- +-- Open games + +-- The baseline stage game: prisoner's dilemma +prisonersDilemma :: OpenGame + StochasticStatefulOptic + StochasticStatefulContext + ('[Kleisli Stochastic (ActionPD, ActionPD) ActionPD, + Kleisli Stochastic (ActionPD, ActionPD) ActionPD]) + ('[[DiagnosticInfoBayesian (ActionPD, ActionPD) ActionPD], + [DiagnosticInfoBayesian (ActionPD, ActionPD) ActionPD]]) + (ActionPD, ActionPD, EndState) + () + (ActionPD, ActionPD) + () +prisonersDilemma = [opengame| + + inputs : (dec1Old,dec2Old,endState) ; + feedback : ; + + :----------------------------: + inputs : (dec1Old,dec2Old) ; + feedback : ; + operation : dependentDecision "player1" (const [Cooperate,Defect]); + outputs : decisionPlayer1 ; + returns : prisonersDilemmaMatrix endState decisionPlayer1 decisionPlayer2 ; + + inputs : (dec1Old,dec2Old) ; + feedback : ; + operation : dependentDecision "player2" (const [Cooperate,Defect]); + outputs : decisionPlayer2 ; + returns : prisonersDilemmaMatrix endState decisionPlayer2 decisionPlayer1 ; + + + :----------------------------: + + outputs : (decisionPlayer1,decisionPlayer2) ; + returns : ; + |] + + +-- Start game with payoff only depending on current state +-- NOTE: an alternative implementation is possible; check _NStageMarkov_ +startGame :: OpenGame + StochasticStatefulOptic + StochasticStatefulContext + ('[Kleisli Stochastic (ActionPD, ActionPD) ActionPD, + Kleisli Stochastic (ActionPD, ActionPD) ActionPD]) + ('[[DiagnosticInfoBayesian (ActionPD, ActionPD) ActionPD], + [DiagnosticInfoBayesian (ActionPD, ActionPD) ActionPD]]) + (ActionPD, ActionPD, Bool) + () + (ActionPD, ActionPD) + () + +startGame = [opengame| + + inputs : (dec1Old,dec2Old,endState) ; + feedback : ; + + :----------------------------: + inputs : (dec1Old,dec2Old) ; + feedback : ; + operation : dependentDecision "player1" (const [Cooperate,Defect]); + outputs : decisionPlayer1 ; + returns : payoffGame endState ; + + inputs : (dec1Old,dec2Old) ; + feedback : ; + operation : dependentDecision "player2" (const [Cooperate,Defect]); + outputs : decisionPlayer2 ; + returns : payoffGame endState ; + + + :----------------------------: + + outputs : (decisionPlayer1,decisionPlayer2) ; + returns : ; + |] + + +-- absorbing state +-- only one action and therefore deterministic payoffGame +endState = [opengame| + + inputs : gameState ; + feedback : ; + + :----------------------------: + inputs : ; + feedback : ; + operation : dependentDecision "player1" (const [Defect,Defect]); + outputs : decisionPlayer1 ; + returns : punishment gameState; + + inputs : ; + feedback : ; + operation : dependentDecision "player2" (const [Defect,Defect]); + outputs : decisionPlayer2 ; + returns : punishment gameState ; + + + :----------------------------: + + outputs : ; + returns : ; + |] + + +-- define a proper stage game, here MeetingInNY, where we end up +endStateGame = [opengame| + + inputs : gameState ; + feedback : ; + + :----------------------------: + + inputs : ; + feedback : ; + operation : dependentDecision "player1" (const [EmpireState,GrandCentral]); + outputs : decisionPlayer1 ; + returns : meetingInNYMatrix gameState decisionPlayer1 decisionPlayer2 ; + + + inputs : ; + feedback : ; + operation : dependentDecision "player2" (const [EmpireState,GrandCentral]); + outputs : decisionPlayer2 ; + returns : meetingInNYMatrix gameState decisionPlayer2 decisionPlayer1 ; + + :----------------------------: + + outputs : ; + returns : ; + |] + +----------------- +-- Complete Games + +-- define the whole game, here with pathological endgame +-- payoffs only depend on state +completeGame = [opengame| + + inputs : (dec1Old,dec2Old,gameStateOld) ; + feedback : ; + + :----------------------------: + inputs : (dec1Old,dec2Old,gameStateOld); + feedback : ; + operation : startGame ; + outputs : (dec1New,dec2New) ; + returns : ; + + inputs : gameStateOld ; + feedback : ; + operation : endState ; + outputs : ; + returns : ; + + inputs : (gameStateOld,dec1New,dec2New) ; + feedback : ; + operation : liftStochasticForward $ uncurry3 transitionEndState; + outputs : gameStateNew; + returns : ; + + + + operation : discount "player1" (\x -> x * discountFactor) ; + + operation : discount "player2" (\x -> x * discountFactor) ; + + + :----------------------------: + + outputs : (dec1New,dec2New,gameStateNew) ; + returns : ; + |] + +-- define the whole game, here with pathological endgame +-- payoffs only depend on state +completeGameDeterm = [opengame| + + inputs : (dec1Old,dec2Old,gameStateOld) ; + feedback : ; + + :----------------------------: + inputs : (dec1Old,dec2Old,gameStateOld); + feedback : ; + operation : startGame ; + outputs : (dec1New,dec2New) ; + returns : ; + + inputs : gameStateOld ; + feedback : ; + operation : endState ; + outputs : ; + returns : ; + + inputs : (gameStateOld,dec1New,dec2New) ; + feedback : ; + operation : liftStochasticForward $ uncurry3 transitionEndStateDeterm; + outputs : gameStateNew; + returns : ; + + + + operation : discount "player1" (\x -> x * discountFactor) ; + + operation : discount "player2" (\x -> x * discountFactor) ; + + + :----------------------------: + + outputs : (dec1New,dec2New,gameStateNew) ; + returns : ; + |] + + + +-- with a proper subgame +-- define the whole game +completeGameMNY = [opengame| + + inputs : (dec1Old,dec2Old,gameStateOld) ; + feedback : ; + + :----------------------------: + inputs : (dec1Old,dec2Old,gameStateOld); + feedback : ; + operation : prisonersDilemma ; + outputs : (dec1New,dec2New) ; + returns : ; + + inputs : gameStateOld ; + feedback : ; + operation : endStateGame ; + outputs : ; + returns : ; + + inputs : (gameStateOld,dec1New,dec2New) ; + feedback : ; + operation : liftStochasticForward $ uncurry3 transitionEndState; + outputs : gameStateNew; + returns : ; + + + + operation : discount "player1" (\x -> x * discountFactor) ; + + operation : discount "player2" (\x -> x * discountFactor) ; + + + :----------------------------: + + outputs : (dec1New,dec2New,gameStateNew) ; + returns : ; + |] + + +------------- +-- Strategies + +-- Strategy for PD stage game +stageStrategy :: Kleisli Stochastic (ActionPD, ActionPD) ActionPD +stageStrategy = Kleisli $ + (\case + (Cooperate,Cooperate) -> playDeterministically Cooperate + (_,_) -> playDeterministically Defect) + +-- Strategy for game with state only dependent payoff +stageStrategyStateDep :: Kleisli Stochastic (ActionPD, ActionPD) ActionPD +stageStrategyStateDep = Kleisli $ const $ playDeterministically Cooperate + +-- Random strategy for single stage +stageStrategyRandom :: Kleisli Stochastic (ActionPD,ActionPD) ActionPD +stageStrategyRandom = Kleisli $ const $ uniform [Cooperate,Defect] + +-- Strategy for pathological end stage game +endStageStrategy :: Kleisli Stochastic () ActionPD +endStageStrategy = Kleisli $ const $ playDeterministically Defect + +-- Strategy for end stage game, meeting in NY +endStageStrategyMNY :: Kleisli Stochastic () Location +endStageStrategyMNY = Kleisli $ const $ playDeterministically EmpireState + +-- Strategy tuple for complete game +strategyTuple = stageStrategy ::- stageStrategy ::- endStageStrategy ::- endStageStrategy ::- Nil + +-- Strategy tuple for complete state-dependent payoff game +strategyTupleStateDep = stageStrategyStateDep ::- stageStrategyStateDep ::- endStageStrategy ::- endStageStrategy ::- Nil + +-- Strategy tuple for complete game with randomization in first stage +strategyTupleRandom = stageStrategyRandom ::- stageStrategyRandom ::- endStageStrategy ::- endStageStrategy ::- Nil + + +-- Strategy tuple for complete game with meeting in NY +strategyTupleMNY = stageStrategy ::- stageStrategy ::- endStageStrategyMNY ::- endStageStrategyMNY ::- Nil + + +----------------------- +-- Continuation payoffs + +-- Extract continuation +extractContinuation :: StochasticStatefulOptic s () a () -> s -> StateT Vector Stochastic () +extractContinuation (StochasticStatefulOptic v u) x = do + (z,a) <- ST.lift (v x) + u z () + +-- Extract next state (action) +extractNextState :: StochasticStatefulOptic s () (a,a,EndState) () -> s -> Stochastic (a,a,EndState) +extractNextState (StochasticStatefulOptic v _) x = do + (z,a) <- v x + pure a + + + +-- Determine continuation for iterator, with the same repeated strategy, using the pathological endgame +determineContinuationPayoffs :: Integer + -> List + '[Kleisli Stochastic (ActionPD, ActionPD) ActionPD, + Kleisli Stochastic (ActionPD, ActionPD) ActionPD, + Kleisli Stochastic () ActionPD, Kleisli Stochastic () ActionPD] + -> (ActionPD,ActionPD,EndState) + -> StateT Vector Stochastic () +determineContinuationPayoffs 1 strat action = pure () +determineContinuationPayoffs iterator strat action = do + ST.lift $ note "determineContinuationPayoffs" + go iterator strat action + where + go 1 strat action = ST.lift $ note "go[1]" + go iterator strat action = do + ST.lift $ note ("go[" ++ show iterator ++ "]") + extractContinuation executeStrat action + ST.lift $ note "nextState" + nextInput <- ST.lift $ extractNextState executeStrat action + go (pred iterator) strat nextInput + where + executeStrat = play completeGame strat + +-- Determine continuation for iterator, with the same repeated strategy, using the pathological endgame +determineContinuationPayoffsDeterm :: Integer + -> List + '[Kleisli Stochastic (ActionPD, ActionPD) ActionPD, + Kleisli Stochastic (ActionPD, ActionPD) ActionPD, + Kleisli Stochastic () ActionPD, Kleisli Stochastic () ActionPD] + -> (ActionPD,ActionPD,EndState) + -> StateT Vector Stochastic () +determineContinuationPayoffsDeterm 1 strat action = pure () +determineContinuationPayoffsDeterm iterator strat action = do + ST.lift $ note "determineContinuationPayoffs" + go iterator strat action + where + go 1 strat action = ST.lift $ note "go[1]" + go iterator strat action = do + ST.lift $ note ("go[" ++ show iterator ++ "]") + extractContinuation executeStrat action + ST.lift $ note "nextState" + nextInput <- ST.lift $ extractNextState executeStrat action + go (pred iterator) strat nextInput + where + executeStrat = play completeGame strat + + + + +-- Determine continuation for iterator, with the same repeated strategy, using the pathological endgame +determineContinuationPayoffsMNY 1 strat action = pure () +determineContinuationPayoffsMNY iterator strat action = do + ST.lift $ note "determineContinuationPayoffs" + go iterator strat action + where + go 1 strat action = ST.lift $ note "go[1]" + go iterator strat action = do + ST.lift $ note ("go[" ++ show iterator ++ "]") + extractContinuation executeStrat action + ST.lift $ note "nextState" + nextInput <- ST.lift $ extractNextState executeStrat action + go (pred iterator) strat nextInput + where + executeStrat = play completeGameMNY strat + + + +---------- +-- Context + +-- Context used for the evaluation of the pathological end state +contextCont iterator strat initialAction = StochasticStatefulContext (pure ((),initialAction)) (\_ action -> determineContinuationPayoffs iterator strat action) + +-- Context used for the evaluation of the pathological end state -- deterministic transition +contextContDeterm iterator strat initialAction = StochasticStatefulContext (pure ((),initialAction)) (\_ action -> determineContinuationPayoffsDeterm iterator strat action) + + + +-- Context used for the evaluation of the MNY end game +contextContMNY iterator strat initialAction = StochasticStatefulContext (pure ((),initialAction)) (\_ action -> determineContinuationPayoffsMNY iterator strat action) + + + +-------------- +-- Equilibrium + +-- Pathological end state +repeatedCompleteGameEq iterator strat initialAction = evaluate completeGame strat context + where context = contextCont iterator strat initialAction + +-- Pathological end state -- deterministic transition +repeatedCompleteGameEqDeterm iterator strat initialAction = evaluate completeGameDeterm strat context + where context = contextContDeterm iterator strat initialAction + + +-- Meeting in NY endgame +repeatedCompleteGameMNYEq iterator strat initialAction = evaluate completeGameMNY strat context + where context = contextContMNY iterator strat initialAction + +-- Show output pathological end game +eqOutput iterator = generateIsEq $ repeatedCompleteGameEq iterator strategyTuple (Cooperate,Cooperate,False) + +-- Show output pathological end game +eqOutputDeterm iterator = generateIsEq $ repeatedCompleteGameEqDeterm iterator strategyTuple (Cooperate,Cooperate,False) + + +-- Show output meeting in NY end game +eqOutputMYN iterator = generateIsEq $ repeatedCompleteGameMNYEq iterator strategyTupleMNY (Cooperate,Cooperate,False)