{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Mcmc.Proposal
(
PName (..),
PDescription (..),
PWeight (..),
PDimension (..),
Proposal (..),
(@~),
ProposalSimple,
Tuner (tParam, tFunc),
Tune (..),
createProposal,
tune,
getOptimalRate,
proposalHeader,
proposalHLine,
summarizeProposal,
Order (..),
Cycle (ccProposals),
cycleFromList,
setOrder,
orderProposals,
tuneCycle,
autoTuneCycle,
summarizeCycle,
Acceptance (fromAcceptance),
emptyA,
pushA,
resetA,
transformKeysA,
acceptanceRate,
acceptanceRates,
)
where
import Control.DeepSeq
import Data.Aeson
import Data.Bifunctor
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Default
import qualified Data.Double.Conversion.ByteString as BC
import Data.Function
import Data.List
import qualified Data.Map.Strict as M
import Data.Maybe
import Lens.Micro
import Mcmc.Internal.ByteString
import Mcmc.Internal.Shuffle
import Numeric.Log hiding (sum)
import System.Random.MWC
newtype PName = PName {PName -> String
fromPName :: String}
deriving (Int -> PName -> ShowS
[PName] -> ShowS
PName -> String
(Int -> PName -> ShowS)
-> (PName -> String) -> ([PName] -> ShowS) -> Show PName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PName] -> ShowS
$cshowList :: [PName] -> ShowS
show :: PName -> String
$cshow :: PName -> String
showsPrec :: Int -> PName -> ShowS
$cshowsPrec :: Int -> PName -> ShowS
Show, PName -> PName -> Bool
(PName -> PName -> Bool) -> (PName -> PName -> Bool) -> Eq PName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PName -> PName -> Bool
$c/= :: PName -> PName -> Bool
== :: PName -> PName -> Bool
$c== :: PName -> PName -> Bool
Eq, Eq PName
Eq PName
-> (PName -> PName -> Ordering)
-> (PName -> PName -> Bool)
-> (PName -> PName -> Bool)
-> (PName -> PName -> Bool)
-> (PName -> PName -> Bool)
-> (PName -> PName -> PName)
-> (PName -> PName -> PName)
-> Ord PName
PName -> PName -> Bool
PName -> PName -> Ordering
PName -> PName -> PName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PName -> PName -> PName
$cmin :: PName -> PName -> PName
max :: PName -> PName -> PName
$cmax :: PName -> PName -> PName
>= :: PName -> PName -> Bool
$c>= :: PName -> PName -> Bool
> :: PName -> PName -> Bool
$c> :: PName -> PName -> Bool
<= :: PName -> PName -> Bool
$c<= :: PName -> PName -> Bool
< :: PName -> PName -> Bool
$c< :: PName -> PName -> Bool
compare :: PName -> PName -> Ordering
$ccompare :: PName -> PName -> Ordering
$cp1Ord :: Eq PName
Ord)
deriving (Semigroup PName
PName
Semigroup PName
-> PName
-> (PName -> PName -> PName)
-> ([PName] -> PName)
-> Monoid PName
[PName] -> PName
PName -> PName -> PName
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [PName] -> PName
$cmconcat :: [PName] -> PName
mappend :: PName -> PName -> PName
$cmappend :: PName -> PName -> PName
mempty :: PName
$cmempty :: PName
$cp1Monoid :: Semigroup PName
Monoid, b -> PName -> PName
NonEmpty PName -> PName
PName -> PName -> PName
(PName -> PName -> PName)
-> (NonEmpty PName -> PName)
-> (forall b. Integral b => b -> PName -> PName)
-> Semigroup PName
forall b. Integral b => b -> PName -> PName
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> PName -> PName
$cstimes :: forall b. Integral b => b -> PName -> PName
sconcat :: NonEmpty PName -> PName
$csconcat :: NonEmpty PName -> PName
<> :: PName -> PName -> PName
$c<> :: PName -> PName -> PName
Semigroup) via String
newtype PDescription = PDescription {PDescription -> String
fromPDescription :: String}
deriving (Int -> PDescription -> ShowS
[PDescription] -> ShowS
PDescription -> String
(Int -> PDescription -> ShowS)
-> (PDescription -> String)
-> ([PDescription] -> ShowS)
-> Show PDescription
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PDescription] -> ShowS
$cshowList :: [PDescription] -> ShowS
show :: PDescription -> String
$cshow :: PDescription -> String
showsPrec :: Int -> PDescription -> ShowS
$cshowsPrec :: Int -> PDescription -> ShowS
Show, PDescription -> PDescription -> Bool
(PDescription -> PDescription -> Bool)
-> (PDescription -> PDescription -> Bool) -> Eq PDescription
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PDescription -> PDescription -> Bool
$c/= :: PDescription -> PDescription -> Bool
== :: PDescription -> PDescription -> Bool
$c== :: PDescription -> PDescription -> Bool
Eq, Eq PDescription
Eq PDescription
-> (PDescription -> PDescription -> Ordering)
-> (PDescription -> PDescription -> Bool)
-> (PDescription -> PDescription -> Bool)
-> (PDescription -> PDescription -> Bool)
-> (PDescription -> PDescription -> Bool)
-> (PDescription -> PDescription -> PDescription)
-> (PDescription -> PDescription -> PDescription)
-> Ord PDescription
PDescription -> PDescription -> Bool
PDescription -> PDescription -> Ordering
PDescription -> PDescription -> PDescription
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PDescription -> PDescription -> PDescription
$cmin :: PDescription -> PDescription -> PDescription
max :: PDescription -> PDescription -> PDescription
$cmax :: PDescription -> PDescription -> PDescription
>= :: PDescription -> PDescription -> Bool
$c>= :: PDescription -> PDescription -> Bool
> :: PDescription -> PDescription -> Bool
$c> :: PDescription -> PDescription -> Bool
<= :: PDescription -> PDescription -> Bool
$c<= :: PDescription -> PDescription -> Bool
< :: PDescription -> PDescription -> Bool
$c< :: PDescription -> PDescription -> Bool
compare :: PDescription -> PDescription -> Ordering
$ccompare :: PDescription -> PDescription -> Ordering
$cp1Ord :: Eq PDescription
Ord)
newtype PWeight = PWeight {PWeight -> Int
fromPWeight :: Int}
deriving (Int -> PWeight -> ShowS
[PWeight] -> ShowS
PWeight -> String
(Int -> PWeight -> ShowS)
-> (PWeight -> String) -> ([PWeight] -> ShowS) -> Show PWeight
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PWeight] -> ShowS
$cshowList :: [PWeight] -> ShowS
show :: PWeight -> String
$cshow :: PWeight -> String
showsPrec :: Int -> PWeight -> ShowS
$cshowsPrec :: Int -> PWeight -> ShowS
Show, PWeight -> PWeight -> Bool
(PWeight -> PWeight -> Bool)
-> (PWeight -> PWeight -> Bool) -> Eq PWeight
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PWeight -> PWeight -> Bool
$c/= :: PWeight -> PWeight -> Bool
== :: PWeight -> PWeight -> Bool
$c== :: PWeight -> PWeight -> Bool
Eq, Eq PWeight
Eq PWeight
-> (PWeight -> PWeight -> Ordering)
-> (PWeight -> PWeight -> Bool)
-> (PWeight -> PWeight -> Bool)
-> (PWeight -> PWeight -> Bool)
-> (PWeight -> PWeight -> Bool)
-> (PWeight -> PWeight -> PWeight)
-> (PWeight -> PWeight -> PWeight)
-> Ord PWeight
PWeight -> PWeight -> Bool
PWeight -> PWeight -> Ordering
PWeight -> PWeight -> PWeight
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PWeight -> PWeight -> PWeight
$cmin :: PWeight -> PWeight -> PWeight
max :: PWeight -> PWeight -> PWeight
$cmax :: PWeight -> PWeight -> PWeight
>= :: PWeight -> PWeight -> Bool
$c>= :: PWeight -> PWeight -> Bool
> :: PWeight -> PWeight -> Bool
$c> :: PWeight -> PWeight -> Bool
<= :: PWeight -> PWeight -> Bool
$c<= :: PWeight -> PWeight -> Bool
< :: PWeight -> PWeight -> Bool
$c< :: PWeight -> PWeight -> Bool
compare :: PWeight -> PWeight -> Ordering
$ccompare :: PWeight -> PWeight -> Ordering
$cp1Ord :: Eq PWeight
Ord)
data PDimension = PDimension Int | PDimensionUnknown
data Proposal a = Proposal
{
Proposal a -> PName
pName :: PName,
Proposal a -> PDescription
pDescription :: PDescription,
Proposal a -> PDimension
pDimension :: PDimension,
Proposal a -> PWeight
pWeight :: PWeight,
Proposal a -> ProposalSimple a
pSimple :: ProposalSimple a,
Proposal a -> Maybe (Tuner a)
pTuner :: Maybe (Tuner a)
}
instance Eq (Proposal a) where
Proposal a
m == :: Proposal a -> Proposal a -> Bool
== Proposal a
n = Proposal a -> PName
forall a. Proposal a -> PName
pName Proposal a
m PName -> PName -> Bool
forall a. Eq a => a -> a -> Bool
== Proposal a -> PName
forall a. Proposal a -> PName
pName Proposal a
n Bool -> Bool -> Bool
&& Proposal a -> PDescription
forall a. Proposal a -> PDescription
pDescription Proposal a
m PDescription -> PDescription -> Bool
forall a. Eq a => a -> a -> Bool
== Proposal a -> PDescription
forall a. Proposal a -> PDescription
pDescription Proposal a
n
instance Ord (Proposal a) where
compare :: Proposal a -> Proposal a -> Ordering
compare = (PDescription, PName, PWeight)
-> (PDescription, PName, PWeight) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((PDescription, PName, PWeight)
-> (PDescription, PName, PWeight) -> Ordering)
-> (Proposal a -> (PDescription, PName, PWeight))
-> Proposal a
-> Proposal a
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (\Proposal a
p -> (Proposal a -> PDescription
forall a. Proposal a -> PDescription
pDescription Proposal a
p, Proposal a -> PName
forall a. Proposal a -> PName
pName Proposal a
p, Proposal a -> PWeight
forall a. Proposal a -> PWeight
pWeight Proposal a
p))
(@~) :: Lens' b a -> Proposal a -> Proposal b
@~ :: Lens' b a -> Proposal a -> Proposal b
(@~) Lens' b a
l (Proposal PName
n PDescription
r PDimension
d PWeight
w ProposalSimple a
s Maybe (Tuner a)
t) = PName
-> PDescription
-> PDimension
-> PWeight
-> ProposalSimple b
-> Maybe (Tuner b)
-> Proposal b
forall a.
PName
-> PDescription
-> PDimension
-> PWeight
-> ProposalSimple a
-> Maybe (Tuner a)
-> Proposal a
Proposal PName
n PDescription
r PDimension
d PWeight
w (Lens' b a -> ProposalSimple a -> ProposalSimple b
forall b a. Lens' b a -> ProposalSimple a -> ProposalSimple b
convertProposalSimple Lens' b a
l ProposalSimple a
s) (Lens' b a -> Tuner a -> Tuner b
forall b a. Lens' b a -> Tuner a -> Tuner b
convertTuner Lens' b a
l (Tuner a -> Tuner b) -> Maybe (Tuner a) -> Maybe (Tuner b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Tuner a)
t)
type ProposalSimple a = a -> GenIO -> IO (a, Log Double, Log Double)
convertProposalSimple :: Lens' b a -> ProposalSimple a -> ProposalSimple b
convertProposalSimple :: Lens' b a -> ProposalSimple a -> ProposalSimple b
convertProposalSimple Lens' b a
l ProposalSimple a
s = b -> Gen RealWorld -> IO (b, Log Double, Log Double)
ProposalSimple b
s'
where
s' :: b -> Gen RealWorld -> IO (b, Log Double, Log Double)
s' b
v Gen RealWorld
g = do
(a
x', Log Double
r, Log Double
j) <- ProposalSimple a
s (b
v b -> Getting a b a -> a
forall s a. s -> Getting a s a -> a
^. Getting a b a
Lens' b a
l) Gen RealWorld
Gen (PrimState IO)
g
(b, Log Double, Log Double) -> IO (b, Log Double, Log Double)
forall (m :: * -> *) a. Monad m => a -> m a
return (ASetter b b a a -> a -> b -> b
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter b b a a
Lens' b a
l a
x' b
v, Log Double
r, Log Double
j)
data Tuner a = Tuner
{ Tuner a -> Double
tParam :: Double,
Tuner a -> Double -> ProposalSimple a
tFunc :: Double -> ProposalSimple a
}
convertTuner :: Lens' b a -> Tuner a -> Tuner b
convertTuner :: Lens' b a -> Tuner a -> Tuner b
convertTuner Lens' b a
l (Tuner Double
p Double -> ProposalSimple a
f) = Double -> (Double -> ProposalSimple b) -> Tuner b
forall a. Double -> (Double -> ProposalSimple a) -> Tuner a
Tuner Double
p Double -> b -> Gen RealWorld -> IO (b, Log Double, Log Double)
Double -> ProposalSimple b
f'
where
f' :: Double -> ProposalSimple b
f' Double
x = Lens' b a -> ProposalSimple a -> ProposalSimple b
forall b a. Lens' b a -> ProposalSimple a -> ProposalSimple b
convertProposalSimple Lens' b a
l (ProposalSimple a -> ProposalSimple b)
-> ProposalSimple a -> ProposalSimple b
forall a b. (a -> b) -> a -> b
$ Double -> ProposalSimple a
f Double
x
data Tune = Tune | NoTune
deriving (Int -> Tune -> ShowS
[Tune] -> ShowS
Tune -> String
(Int -> Tune -> ShowS)
-> (Tune -> String) -> ([Tune] -> ShowS) -> Show Tune
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tune] -> ShowS
$cshowList :: [Tune] -> ShowS
show :: Tune -> String
$cshow :: Tune -> String
showsPrec :: Int -> Tune -> ShowS
$cshowsPrec :: Int -> Tune -> ShowS
Show, Tune -> Tune -> Bool
(Tune -> Tune -> Bool) -> (Tune -> Tune -> Bool) -> Eq Tune
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tune -> Tune -> Bool
$c/= :: Tune -> Tune -> Bool
== :: Tune -> Tune -> Bool
$c== :: Tune -> Tune -> Bool
Eq)
createProposal ::
PDescription ->
(Double -> ProposalSimple a) ->
PDimension ->
PName ->
PWeight ->
Tune ->
Proposal a
createProposal :: PDescription
-> (Double -> ProposalSimple a)
-> PDimension
-> PName
-> PWeight
-> Tune
-> Proposal a
createProposal PDescription
r Double -> ProposalSimple a
f PDimension
d PName
n PWeight
w Tune
Tune = PName
-> PDescription
-> PDimension
-> PWeight
-> ProposalSimple a
-> Maybe (Tuner a)
-> Proposal a
forall a.
PName
-> PDescription
-> PDimension
-> PWeight
-> ProposalSimple a
-> Maybe (Tuner a)
-> Proposal a
Proposal PName
n PDescription
r PDimension
d PWeight
w (Double -> ProposalSimple a
f Double
1.0) (Tuner a -> Maybe (Tuner a)
forall a. a -> Maybe a
Just (Tuner a -> Maybe (Tuner a)) -> Tuner a -> Maybe (Tuner a)
forall a b. (a -> b) -> a -> b
$ Double -> (Double -> ProposalSimple a) -> Tuner a
forall a. Double -> (Double -> ProposalSimple a) -> Tuner a
Tuner Double
1.0 Double -> ProposalSimple a
f)
createProposal PDescription
r Double -> ProposalSimple a
f PDimension
d PName
n PWeight
w Tune
NoTune = PName
-> PDescription
-> PDimension
-> PWeight
-> ProposalSimple a
-> Maybe (Tuner a)
-> Proposal a
forall a.
PName
-> PDescription
-> PDimension
-> PWeight
-> ProposalSimple a
-> Maybe (Tuner a)
-> Proposal a
Proposal PName
n PDescription
r PDimension
d PWeight
w (Double -> ProposalSimple a
f Double
1.0) Maybe (Tuner a)
forall a. Maybe a
Nothing
tuningParamMin :: Double
tuningParamMin :: Double
tuningParamMin = Double
1e-12
tune :: (Double -> Double) -> Proposal a -> Maybe (Proposal a)
tune :: (Double -> Double) -> Proposal a -> Maybe (Proposal a)
tune Double -> Double
f Proposal a
m = do
(Tuner Double
t Double -> ProposalSimple a
g) <- Proposal a -> Maybe (Tuner a)
forall a. Proposal a -> Maybe (Tuner a)
pTuner Proposal a
m
let t' :: Double
t' = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
tuningParamMin (Double -> Double
f Double
t)
Proposal a -> Maybe (Proposal a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Proposal a -> Maybe (Proposal a))
-> Proposal a -> Maybe (Proposal a)
forall a b. (a -> b) -> a -> b
$ Proposal a
m {pSimple :: ProposalSimple a
pSimple = Double -> ProposalSimple a
g Double
t', pTuner :: Maybe (Tuner a)
pTuner = Tuner a -> Maybe (Tuner a)
forall a. a -> Maybe a
Just (Tuner a -> Maybe (Tuner a)) -> Tuner a -> Maybe (Tuner a)
forall a b. (a -> b) -> a -> b
$ Double -> (Double -> ProposalSimple a) -> Tuner a
forall a. Double -> (Double -> ProposalSimple a) -> Tuner a
Tuner Double
t' Double -> ProposalSimple a
g}
getOptimalRate :: PDimension -> Double
getOptimalRate :: PDimension -> Double
getOptimalRate (PDimension Int
n)
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = String -> Double
forall a. HasCallStack => String -> a
error String
"getOptimalRate: Proposal dimension is zero or negative."
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Double
0.44
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 = Double
0.3885
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 = Double
0.337
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 = Double
0.2855
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
5 = Double
0.234
| Bool
otherwise = String -> Double
forall a. HasCallStack => String -> a
error String
"getOptimalRate: Proposal dimension is not an integer?"
getOptimalRate PDimension
PDimensionUnknown = Double
0.234
rateMin :: Double
rateMin :: Double
rateMin = Double
0.1
rateMax :: Double
rateMax :: Double
rateMax = Double
0.9
data Order
=
RandomO
|
SequentialO
|
RandomReversibleO
|
SequentialReversibleO
deriving (Order -> Order -> Bool
(Order -> Order -> Bool) -> (Order -> Order -> Bool) -> Eq Order
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Order -> Order -> Bool
$c/= :: Order -> Order -> Bool
== :: Order -> Order -> Bool
$c== :: Order -> Order -> Bool
Eq, Int -> Order -> ShowS
[Order] -> ShowS
Order -> String
(Int -> Order -> ShowS)
-> (Order -> String) -> ([Order] -> ShowS) -> Show Order
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Order] -> ShowS
$cshowList :: [Order] -> ShowS
show :: Order -> String
$cshow :: Order -> String
showsPrec :: Int -> Order -> ShowS
$cshowsPrec :: Int -> Order -> ShowS
Show)
instance Default Order where def :: Order
def = Order
RandomO
describeOrder :: Order -> BL.ByteString
describeOrder :: Order -> ByteString
describeOrder Order
RandomO = ByteString
"The proposals are executed in random order."
describeOrder Order
SequentialO = ByteString
"The proposals are executed sequentially."
describeOrder Order
RandomReversibleO =
ByteString -> [ByteString] -> ByteString
BL.intercalate
ByteString
"\n"
[ Order -> ByteString
describeOrder Order
RandomO,
ByteString
"A reversed copy of the shuffled proposals is appended to ensure reversibility."
]
describeOrder Order
SequentialReversibleO =
ByteString -> [ByteString] -> ByteString
BL.intercalate
ByteString
"\n"
[ Order -> ByteString
describeOrder Order
SequentialO,
ByteString
"A reversed copy of the sequential proposals is appended to ensure reversibility."
]
data Cycle a = Cycle
{ Cycle a -> [Proposal a]
ccProposals :: [Proposal a],
Cycle a -> Order
ccOrder :: Order
}
cycleFromList :: [Proposal a] -> Cycle a
cycleFromList :: [Proposal a] -> Cycle a
cycleFromList [] =
String -> Cycle a
forall a. HasCallStack => String -> a
error String
"cycleFromList: Received an empty list but cannot create an empty Cycle."
cycleFromList [Proposal a]
xs =
if [Proposal a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Proposal a] -> [Proposal a]
forall a. Eq a => [a] -> [a]
nub [Proposal a]
xs) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Proposal a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Proposal a]
xs
then [Proposal a] -> Order -> Cycle a
forall a. [Proposal a] -> Order -> Cycle a
Cycle [Proposal a]
xs Order
forall a. Default a => a
def
else String -> Cycle a
forall a. HasCallStack => String -> a
error String
"cycleFromList: Proposals are not unique."
setOrder :: Order -> Cycle a -> Cycle a
setOrder :: Order -> Cycle a -> Cycle a
setOrder Order
o Cycle a
c = Cycle a
c {ccOrder :: Order
ccOrder = Order
o}
orderProposals :: Cycle a -> GenIO -> IO [Proposal a]
orderProposals :: Cycle a -> Gen (PrimState IO) -> IO [Proposal a]
orderProposals (Cycle [Proposal a]
xs Order
o) Gen (PrimState IO)
g = case Order
o of
Order
RandomO -> [Proposal a] -> Gen (PrimState IO) -> IO [Proposal a]
forall a. [a] -> Gen (PrimState IO) -> IO [a]
shuffle [Proposal a]
ps Gen (PrimState IO)
g
Order
SequentialO -> [Proposal a] -> IO [Proposal a]
forall (m :: * -> *) a. Monad m => a -> m a
return [Proposal a]
ps
Order
RandomReversibleO -> do
[Proposal a]
psR <- [Proposal a] -> Gen (PrimState IO) -> IO [Proposal a]
forall a. [a] -> Gen (PrimState IO) -> IO [a]
shuffle [Proposal a]
ps Gen (PrimState IO)
g
[Proposal a] -> IO [Proposal a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Proposal a] -> IO [Proposal a])
-> [Proposal a] -> IO [Proposal a]
forall a b. (a -> b) -> a -> b
$ [Proposal a]
psR [Proposal a] -> [Proposal a] -> [Proposal a]
forall a. [a] -> [a] -> [a]
++ [Proposal a] -> [Proposal a]
forall a. [a] -> [a]
reverse [Proposal a]
psR
Order
SequentialReversibleO -> [Proposal a] -> IO [Proposal a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Proposal a] -> IO [Proposal a])
-> [Proposal a] -> IO [Proposal a]
forall a b. (a -> b) -> a -> b
$ [Proposal a]
ps [Proposal a] -> [Proposal a] -> [Proposal a]
forall a. [a] -> [a] -> [a]
++ [Proposal a] -> [Proposal a]
forall a. [a] -> [a]
reverse [Proposal a]
ps
where
!ps :: [Proposal a]
ps = [[Proposal a]] -> [Proposal a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Int -> Proposal a -> [Proposal a]
forall a. Int -> a -> [a]
replicate (PWeight -> Int
fromPWeight (PWeight -> Int) -> PWeight -> Int
forall a b. (a -> b) -> a -> b
$ Proposal a -> PWeight
forall a. Proposal a -> PWeight
pWeight Proposal a
p) Proposal a
p | Proposal a
p <- [Proposal a]
xs]
getNProposalsPerCycle :: Cycle a -> Int
getNProposalsPerCycle :: Cycle a -> Int
getNProposalsPerCycle (Cycle [Proposal a]
xs Order
o) = case Order
o of
Order
RandomO -> Int
once
Order
SequentialO -> Int
once
Order
RandomReversibleO -> Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
once
Order
SequentialReversibleO -> Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
once
where
once :: Int
once = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Proposal a -> Int) -> [Proposal a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (PWeight -> Int
fromPWeight (PWeight -> Int) -> (Proposal a -> PWeight) -> Proposal a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proposal a -> PWeight
forall a. Proposal a -> PWeight
pWeight) [Proposal a]
xs
tuneCycle :: M.Map (Proposal a) (Double -> Double) -> Cycle a -> Cycle a
tuneCycle :: Map (Proposal a) (Double -> Double) -> Cycle a -> Cycle a
tuneCycle Map (Proposal a) (Double -> Double)
m Cycle a
c =
if [Proposal a] -> [Proposal a]
forall a. Ord a => [a] -> [a]
sort (Map (Proposal a) (Double -> Double) -> [Proposal a]
forall k a. Map k a -> [k]
M.keys Map (Proposal a) (Double -> Double)
m) [Proposal a] -> [Proposal a] -> Bool
forall a. Eq a => a -> a -> Bool
== [Proposal a] -> [Proposal a]
forall a. Ord a => [a] -> [a]
sort [Proposal a]
ps
then Cycle a
c {ccProposals :: [Proposal a]
ccProposals = (Proposal a -> Proposal a) -> [Proposal a] -> [Proposal a]
forall a b. (a -> b) -> [a] -> [b]
map Proposal a -> Proposal a
tuneF [Proposal a]
ps}
else String -> Cycle a
forall a. HasCallStack => String -> a
error String
"tuneCycle: Propoals in map and cycle do not match."
where
ps :: [Proposal a]
ps = Cycle a -> [Proposal a]
forall a. Cycle a -> [Proposal a]
ccProposals Cycle a
c
tuneF :: Proposal a -> Proposal a
tuneF Proposal a
p = case Map (Proposal a) (Double -> Double)
m Map (Proposal a) (Double -> Double)
-> Proposal a -> Maybe (Double -> Double)
forall k a. Ord k => Map k a -> k -> Maybe a
M.!? Proposal a
p of
Maybe (Double -> Double)
Nothing -> Proposal a
p
Just Double -> Double
f -> Proposal a -> Maybe (Proposal a) -> Proposal a
forall a. a -> Maybe a -> a
fromMaybe Proposal a
p ((Double -> Double) -> Proposal a -> Maybe (Proposal a)
forall a. (Double -> Double) -> Proposal a -> Maybe (Proposal a)
tune Double -> Double
f Proposal a
p)
autoTuneCycle :: Acceptance (Proposal a) -> Cycle a -> Cycle a
autoTuneCycle :: Acceptance (Proposal a) -> Cycle a -> Cycle a
autoTuneCycle Acceptance (Proposal a)
a = Map (Proposal a) (Double -> Double) -> Cycle a -> Cycle a
forall a. Map (Proposal a) (Double -> Double) -> Cycle a -> Cycle a
tuneCycle ((Proposal a -> Double -> Double -> Double)
-> Map (Proposal a) Double -> Map (Proposal a) (Double -> Double)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey Proposal a -> Double -> Double -> Double
forall a. Proposal a -> Double -> Double -> Double
tuningF (Map (Proposal a) Double -> Map (Proposal a) (Double -> Double))
-> Map (Proposal a) Double -> Map (Proposal a) (Double -> Double)
forall a b. (a -> b) -> a -> b
$ Acceptance (Proposal a) -> Map (Proposal a) Double
forall k. Acceptance k -> Map k Double
acceptanceRates Acceptance (Proposal a)
a)
where
tuningF :: Proposal a -> Double -> Double -> Double
tuningF Proposal a
proposal Double
currentRate Double
currentTuningParam =
let optimalRate :: Double
optimalRate = PDimension -> Double
getOptimalRate (Proposal a -> PDimension
forall a. Proposal a -> PDimension
pDimension Proposal a
proposal)
in Double -> Double
forall a. Floating a => a -> a
exp (Double
currentRate Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
optimalRate) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
currentTuningParam
renderRow ::
BL.ByteString ->
BL.ByteString ->
BL.ByteString ->
BL.ByteString ->
BL.ByteString ->
BL.ByteString ->
BL.ByteString ->
BL.ByteString ->
BL.ByteString ->
BL.ByteString
renderRow :: ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
renderRow ByteString
name ByteString
ptype ByteString
weight ByteString
nAccept ByteString
nReject ByteString
acceptRate ByteString
optimalRate ByteString
tuneParam ByteString
manualAdjustment = ByteString
nm ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
pt ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
wt ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
na ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
nr ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
ra ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
ro ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
tp ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
mt
where
nm :: ByteString
nm = Int -> ByteString -> ByteString
alignLeft Int
30 ByteString
name
pt :: ByteString
pt = Int -> ByteString -> ByteString
alignLeft Int
50 ByteString
ptype
wt :: ByteString
wt = Int -> ByteString -> ByteString
alignRight Int
8 ByteString
weight
na :: ByteString
na = Int -> ByteString -> ByteString
alignRight Int
14 ByteString
nAccept
nr :: ByteString
nr = Int -> ByteString -> ByteString
alignRight Int
14 ByteString
nReject
ra :: ByteString
ra = Int -> ByteString -> ByteString
alignRight Int
14 ByteString
acceptRate
ro :: ByteString
ro = Int -> ByteString -> ByteString
alignRight Int
14 ByteString
optimalRate
tp :: ByteString
tp = Int -> ByteString -> ByteString
alignRight Int
20 ByteString
tuneParam
mt :: ByteString
mt = Int -> ByteString -> ByteString
alignRight Int
30 ByteString
manualAdjustment
proposalHeader :: BL.ByteString
=
ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
renderRow
ByteString
"Name"
ByteString
"Description"
ByteString
"Weight"
ByteString
"Accepted"
ByteString
"Rejected"
ByteString
"Rate"
ByteString
"Optimal rate"
ByteString
"Tuning parameter"
ByteString
"Consider manual adjustment"
proposalHLine :: BL.ByteString
proposalHLine :: ByteString
proposalHLine = Int64 -> Char -> ByteString
BL.replicate (ByteString -> Int64
BL.length ByteString
proposalHeader) Char
'-'
summarizeProposal ::
PName ->
PDescription ->
PWeight ->
Maybe Double ->
PDimension ->
Maybe (Int, Int, Double) ->
BL.ByteString
summarizeProposal :: PName
-> PDescription
-> PWeight
-> Maybe Double
-> PDimension
-> Maybe (Int, Int, Double)
-> ByteString
summarizeProposal PName
name PDescription
description PWeight
weight Maybe Double
tuningParam PDimension
dimension Maybe (Int, Int, Double)
r =
ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
renderRow
(String -> ByteString
BL.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ PName -> String
fromPName PName
name)
(String -> ByteString
BL.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ PDescription -> String
fromPDescription PDescription
description)
ByteString
weightStr
ByteString
nAccept
ByteString
nReject
ByteString
acceptRate
ByteString
optimalRate
ByteString
tuneParamStr
ByteString
manualAdjustmentStr
where
weightStr :: ByteString
weightStr = Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Builder
BB.intDec (Int -> Builder) -> Int -> Builder
forall a b. (a -> b) -> a -> b
$ PWeight -> Int
fromPWeight PWeight
weight
nAccept :: ByteString
nAccept = Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder
-> ((Int, Int, Double) -> Builder)
-> Maybe (Int, Int, Double)
-> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
"" (Int -> Builder
BB.intDec (Int -> Builder)
-> ((Int, Int, Double) -> Int) -> (Int, Int, Double) -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int, Double) -> Getting Int (Int, Int, Double) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (Int, Int, Double) Int
forall s t a b. Field1 s t a b => Lens s t a b
_1)) Maybe (Int, Int, Double)
r
nReject :: ByteString
nReject = Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder
-> ((Int, Int, Double) -> Builder)
-> Maybe (Int, Int, Double)
-> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
"" (Int -> Builder
BB.intDec (Int -> Builder)
-> ((Int, Int, Double) -> Int) -> (Int, Int, Double) -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int, Double) -> Getting Int (Int, Int, Double) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (Int, Int, Double) Int
forall s t a b. Field2 s t a b => Lens s t a b
_2)) Maybe (Int, Int, Double)
r
acceptRate :: ByteString
acceptRate = ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
-> ((Int, Int, Double) -> ByteString)
-> Maybe (Int, Int, Double)
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (Int -> Double -> ByteString
BC.toFixed Int
2 (Double -> ByteString)
-> ((Int, Int, Double) -> Double)
-> (Int, Int, Double)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int, Double)
-> Getting Double (Int, Int, Double) Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double (Int, Int, Double) Double
forall s t a b. Field3 s t a b => Lens s t a b
_3)) Maybe (Int, Int, Double)
r
optimalRate :: ByteString
optimalRate = ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Double -> ByteString
BC.toFixed Int
2 (Double -> ByteString) -> Double -> ByteString
forall a b. (a -> b) -> a -> b
$ PDimension -> Double
getOptimalRate PDimension
dimension
tuneParamStr :: ByteString
tuneParamStr = ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> (Double -> ByteString) -> Maybe Double -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (Int -> Double -> ByteString
BC.toFixed Int
3) Maybe Double
tuningParam
check :: Double -> p
check Double
v
| Double
v Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
rateMin = p
"rate too low"
| Double
v Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
rateMax = p
"rate too high"
| Bool
otherwise = p
""
manualAdjustmentStr :: ByteString
manualAdjustmentStr = ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
-> ((Int, Int, Double) -> ByteString)
-> Maybe (Int, Int, Double)
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (Double -> ByteString
forall p. IsString p => Double -> p
check (Double -> ByteString)
-> ((Int, Int, Double) -> Double)
-> (Int, Int, Double)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int, Double)
-> Getting Double (Int, Int, Double) Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double (Int, Int, Double) Double
forall s t a b. Field3 s t a b => Lens s t a b
_3)) Maybe (Int, Int, Double)
r
summarizeCycle :: Acceptance (Proposal a) -> Cycle a -> BL.ByteString
summarizeCycle :: Acceptance (Proposal a) -> Cycle a -> ByteString
summarizeCycle Acceptance (Proposal a)
a Cycle a
c =
ByteString -> [ByteString] -> ByteString
BL.intercalate ByteString
"\n" ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
[ ByteString
"Summary of proposal(s) in cycle.",
ByteString
nProposalsFullStr,
Order -> ByteString
describeOrder (Cycle a -> Order
forall a. Cycle a -> Order
ccOrder Cycle a
c),
ByteString
proposalHeader,
ByteString
proposalHLine
]
[ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ PName
-> PDescription
-> PWeight
-> Maybe Double
-> PDimension
-> Maybe (Int, Int, Double)
-> ByteString
summarizeProposal
(Proposal a -> PName
forall a. Proposal a -> PName
pName Proposal a
p)
(Proposal a -> PDescription
forall a. Proposal a -> PDescription
pDescription Proposal a
p)
(Proposal a -> PWeight
forall a. Proposal a -> PWeight
pWeight Proposal a
p)
(Tuner a -> Double
forall a. Tuner a -> Double
tParam (Tuner a -> Double) -> Maybe (Tuner a) -> Maybe Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proposal a -> Maybe (Tuner a)
forall a. Proposal a -> Maybe (Tuner a)
pTuner Proposal a
p)
(Proposal a -> PDimension
forall a. Proposal a -> PDimension
pDimension Proposal a
p)
(Proposal a -> Maybe (Int, Int, Double)
ar Proposal a
p)
| Proposal a
p <- [Proposal a]
ps
]
[ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
proposalHLine]
where
ps :: [Proposal a]
ps = Cycle a -> [Proposal a]
forall a. Cycle a -> [Proposal a]
ccProposals Cycle a
c
nProposals :: Int
nProposals = Cycle a -> Int
forall a. Cycle a -> Int
getNProposalsPerCycle Cycle a
c
nProposalsStr :: ByteString
nProposalsStr = Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Builder
BB.intDec Int
nProposals
nProposalsFullStr :: ByteString
nProposalsFullStr = case Int
nProposals of
Int
1 -> ByteString
nProposalsStr ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" proposal is performed per iteration."
Int
_ -> ByteString
nProposalsStr ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" proposals are performed per iterations."
ar :: Proposal a -> Maybe (Int, Int, Double)
ar Proposal a
m = Proposal a -> Acceptance (Proposal a) -> Maybe (Int, Int, Double)
forall k. Ord k => k -> Acceptance k -> Maybe (Int, Int, Double)
acceptanceRate Proposal a
m Acceptance (Proposal a)
a
newtype Acceptance k = Acceptance {Acceptance k -> Map k (Int, Int)
fromAcceptance :: M.Map k (Int, Int)}
deriving (Acceptance k -> Acceptance k -> Bool
(Acceptance k -> Acceptance k -> Bool)
-> (Acceptance k -> Acceptance k -> Bool) -> Eq (Acceptance k)
forall k. Eq k => Acceptance k -> Acceptance k -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Acceptance k -> Acceptance k -> Bool
$c/= :: forall k. Eq k => Acceptance k -> Acceptance k -> Bool
== :: Acceptance k -> Acceptance k -> Bool
$c== :: forall k. Eq k => Acceptance k -> Acceptance k -> Bool
Eq, ReadPrec [Acceptance k]
ReadPrec (Acceptance k)
Int -> ReadS (Acceptance k)
ReadS [Acceptance k]
(Int -> ReadS (Acceptance k))
-> ReadS [Acceptance k]
-> ReadPrec (Acceptance k)
-> ReadPrec [Acceptance k]
-> Read (Acceptance k)
forall k. (Ord k, Read k) => ReadPrec [Acceptance k]
forall k. (Ord k, Read k) => ReadPrec (Acceptance k)
forall k. (Ord k, Read k) => Int -> ReadS (Acceptance k)
forall k. (Ord k, Read k) => ReadS [Acceptance k]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Acceptance k]
$creadListPrec :: forall k. (Ord k, Read k) => ReadPrec [Acceptance k]
readPrec :: ReadPrec (Acceptance k)
$creadPrec :: forall k. (Ord k, Read k) => ReadPrec (Acceptance k)
readList :: ReadS [Acceptance k]
$creadList :: forall k. (Ord k, Read k) => ReadS [Acceptance k]
readsPrec :: Int -> ReadS (Acceptance k)
$creadsPrec :: forall k. (Ord k, Read k) => Int -> ReadS (Acceptance k)
Read, Int -> Acceptance k -> ShowS
[Acceptance k] -> ShowS
Acceptance k -> String
(Int -> Acceptance k -> ShowS)
-> (Acceptance k -> String)
-> ([Acceptance k] -> ShowS)
-> Show (Acceptance k)
forall k. Show k => Int -> Acceptance k -> ShowS
forall k. Show k => [Acceptance k] -> ShowS
forall k. Show k => Acceptance k -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Acceptance k] -> ShowS
$cshowList :: forall k. Show k => [Acceptance k] -> ShowS
show :: Acceptance k -> String
$cshow :: forall k. Show k => Acceptance k -> String
showsPrec :: Int -> Acceptance k -> ShowS
$cshowsPrec :: forall k. Show k => Int -> Acceptance k -> ShowS
Show)
instance ToJSONKey k => ToJSON (Acceptance k) where
toJSON :: Acceptance k -> Value
toJSON (Acceptance Map k (Int, Int)
m) = Map k (Int, Int) -> Value
forall a. ToJSON a => a -> Value
toJSON Map k (Int, Int)
m
toEncoding :: Acceptance k -> Encoding
toEncoding (Acceptance Map k (Int, Int)
m) = Map k (Int, Int) -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding Map k (Int, Int)
m
instance (Ord k, FromJSONKey k) => FromJSON (Acceptance k) where
parseJSON :: Value -> Parser (Acceptance k)
parseJSON Value
v = Map k (Int, Int) -> Acceptance k
forall k. Map k (Int, Int) -> Acceptance k
Acceptance (Map k (Int, Int) -> Acceptance k)
-> Parser (Map k (Int, Int)) -> Parser (Acceptance k)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (Map k (Int, Int))
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
emptyA :: Ord k => [k] -> Acceptance k
emptyA :: [k] -> Acceptance k
emptyA [k]
ks = Map k (Int, Int) -> Acceptance k
forall k. Map k (Int, Int) -> Acceptance k
Acceptance (Map k (Int, Int) -> Acceptance k)
-> Map k (Int, Int) -> Acceptance k
forall a b. (a -> b) -> a -> b
$ [(k, (Int, Int))] -> Map k (Int, Int)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(k
k, (Int
0, Int
0)) | k
k <- [k]
ks]
pushA :: Ord k => k -> Bool -> Acceptance k -> Acceptance k
pushA :: k -> Bool -> Acceptance k -> Acceptance k
pushA k
k Bool
True = Map k (Int, Int) -> Acceptance k
forall k. Map k (Int, Int) -> Acceptance k
Acceptance (Map k (Int, Int) -> Acceptance k)
-> (Acceptance k -> Map k (Int, Int))
-> Acceptance k
-> Acceptance k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int) -> (Int, Int))
-> k -> Map k (Int, Int) -> Map k (Int, Int)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
M.adjust ((Int, Int) -> (Int, Int)
forall a. NFData a => a -> a
force ((Int, Int) -> (Int, Int))
-> ((Int, Int) -> (Int, Int)) -> (Int, Int) -> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int) -> (Int, Int) -> (Int, Int)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Int -> Int
forall a. Enum a => a -> a
succ) k
k (Map k (Int, Int) -> Map k (Int, Int))
-> (Acceptance k -> Map k (Int, Int))
-> Acceptance k
-> Map k (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Acceptance k -> Map k (Int, Int)
forall k. Acceptance k -> Map k (Int, Int)
fromAcceptance
pushA k
k Bool
False = Map k (Int, Int) -> Acceptance k
forall k. Map k (Int, Int) -> Acceptance k
Acceptance (Map k (Int, Int) -> Acceptance k)
-> (Acceptance k -> Map k (Int, Int))
-> Acceptance k
-> Acceptance k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int) -> (Int, Int))
-> k -> Map k (Int, Int) -> Map k (Int, Int)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
M.adjust ((Int, Int) -> (Int, Int)
forall a. NFData a => a -> a
force ((Int, Int) -> (Int, Int))
-> ((Int, Int) -> (Int, Int)) -> (Int, Int) -> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int) -> (Int, Int) -> (Int, Int)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Int -> Int
forall a. Enum a => a -> a
succ) k
k (Map k (Int, Int) -> Map k (Int, Int))
-> (Acceptance k -> Map k (Int, Int))
-> Acceptance k
-> Map k (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Acceptance k -> Map k (Int, Int)
forall k. Acceptance k -> Map k (Int, Int)
fromAcceptance
{-# INLINEABLE pushA #-}
resetA :: Ord k => Acceptance k -> Acceptance k
resetA :: Acceptance k -> Acceptance k
resetA = [k] -> Acceptance k
forall k. Ord k => [k] -> Acceptance k
emptyA ([k] -> Acceptance k)
-> (Acceptance k -> [k]) -> Acceptance k -> Acceptance k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k (Int, Int) -> [k]
forall k a. Map k a -> [k]
M.keys (Map k (Int, Int) -> [k])
-> (Acceptance k -> Map k (Int, Int)) -> Acceptance k -> [k]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Acceptance k -> Map k (Int, Int)
forall k. Acceptance k -> Map k (Int, Int)
fromAcceptance
transformKeys :: (Ord k1, Ord k2) => [k1] -> [k2] -> M.Map k1 v -> M.Map k2 v
transformKeys :: [k1] -> [k2] -> Map k1 v -> Map k2 v
transformKeys [k1]
ks1 [k2]
ks2 Map k1 v
m = (Map k2 v -> (k1, k2) -> Map k2 v)
-> Map k2 v -> [(k1, k2)] -> Map k2 v
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map k2 v -> (k1, k2) -> Map k2 v
forall k. Ord k => Map k v -> (k1, k) -> Map k v
insrt Map k2 v
forall k a. Map k a
M.empty ([(k1, k2)] -> Map k2 v) -> [(k1, k2)] -> Map k2 v
forall a b. (a -> b) -> a -> b
$ [k1] -> [k2] -> [(k1, k2)]
forall a b. [a] -> [b] -> [(a, b)]
zip [k1]
ks1 [k2]
ks2
where
insrt :: Map k v -> (k1, k) -> Map k v
insrt Map k v
m' (k1
k1, k
k2) = k -> v -> Map k v -> Map k v
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
k2 (Map k1 v
m Map k1 v -> k1 -> v
forall k a. Ord k => Map k a -> k -> a
M.! k1
k1) Map k v
m'
transformKeysA :: (Ord k1, Ord k2) => [k1] -> [k2] -> Acceptance k1 -> Acceptance k2
transformKeysA :: [k1] -> [k2] -> Acceptance k1 -> Acceptance k2
transformKeysA [k1]
ks1 [k2]
ks2 = Map k2 (Int, Int) -> Acceptance k2
forall k. Map k (Int, Int) -> Acceptance k
Acceptance (Map k2 (Int, Int) -> Acceptance k2)
-> (Acceptance k1 -> Map k2 (Int, Int))
-> Acceptance k1
-> Acceptance k2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [k1] -> [k2] -> Map k1 (Int, Int) -> Map k2 (Int, Int)
forall k1 k2 v.
(Ord k1, Ord k2) =>
[k1] -> [k2] -> Map k1 v -> Map k2 v
transformKeys [k1]
ks1 [k2]
ks2 (Map k1 (Int, Int) -> Map k2 (Int, Int))
-> (Acceptance k1 -> Map k1 (Int, Int))
-> Acceptance k1
-> Map k2 (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Acceptance k1 -> Map k1 (Int, Int)
forall k. Acceptance k -> Map k (Int, Int)
fromAcceptance
acceptanceRate :: Ord k => k -> Acceptance k -> Maybe (Int, Int, Double)
acceptanceRate :: k -> Acceptance k -> Maybe (Int, Int, Double)
acceptanceRate k
k Acceptance k
a = case Acceptance k -> Map k (Int, Int)
forall k. Acceptance k -> Map k (Int, Int)
fromAcceptance Acceptance k
a Map k (Int, Int) -> k -> Maybe (Int, Int)
forall k a. Ord k => Map k a -> k -> Maybe a
M.!? k
k of
Just (Int
0, Int
0) -> Maybe (Int, Int, Double)
forall a. Maybe a
Nothing
Just (Int
as, Int
rs) -> (Int, Int, Double) -> Maybe (Int, Int, Double)
forall a. a -> Maybe a
Just (Int
as, Int
rs, Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
as Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
as Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rs))
Maybe (Int, Int)
Nothing -> String -> Maybe (Int, Int, Double)
forall a. HasCallStack => String -> a
error String
"acceptanceRate: Key not found in map."
acceptanceRates :: Acceptance k -> M.Map k Double
acceptanceRates :: Acceptance k -> Map k Double
acceptanceRates = ((Int, Int) -> Double) -> Map k (Int, Int) -> Map k Double
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (\(Int
as, Int
rs) -> Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
as Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
as Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rs)) (Map k (Int, Int) -> Map k Double)
-> (Acceptance k -> Map k (Int, Int))
-> Acceptance k
-> Map k Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Acceptance k -> Map k (Int, Int)
forall k. Acceptance k -> Map k (Int, Int)
fromAcceptance