{-# LANGUAGE CPP
           , GADTs
           , KindSignatures
           , TypeOperators
           , TypeFamilies
           , EmptyCase
           , DataKinds
           , PolyKinds
           , ExistentialQuantification
           , FlexibleContexts
           , OverloadedStrings
           #-}

{-# OPTIONS_GHC -Wall -fwarn-tabs #-}

module Language.Hakaru.Sample where

import           Numeric.SpecFunctions            (logFactorial)
import qualified Data.Number.LogFloat             as LF
import qualified Math.Combinatorics.Exact.Binomial as EB
-- import qualified Numeric.Integration.TanhSinh     as TS
import qualified System.Random.MWC                as MWC
import qualified System.Random.MWC.CondensedTable as MWC
import qualified System.Random.MWC.Distributions  as MWCD

import qualified Data.Vector                      as V
import           Data.STRef
import           Data.Sequence (Seq)
import qualified Data.Foldable                    as F
import qualified Data.List.NonEmpty               as L
import           Data.List.NonEmpty               (NonEmpty(..))
import           Data.Maybe                       (fromMaybe)

#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative   (Applicative(..), (<$>))
#endif
import           Control.Monad
import           Control.Monad.ST
import           Control.Monad.Identity
import           Control.Monad.Trans.Maybe
import           Control.Monad.State.Strict
import qualified Data.IntMap                      as IM

import Data.Number.Nat     (fromNat)
import Data.Number.Natural (fromNatural, fromNonNegativeRational, Natural, unsafeNatural)
import Language.Hakaru.Types.DataKind
import Language.Hakaru.Types.Coercion
import Language.Hakaru.Types.Sing
import Language.Hakaru.Types.HClasses
import Language.Hakaru.Syntax.IClasses
import Language.Hakaru.Syntax.TypeOf
import Language.Hakaru.Syntax.Value
import Language.Hakaru.Syntax.Reducer
import Language.Hakaru.Syntax.Datum
import Language.Hakaru.Syntax.DatumCase
import Language.Hakaru.Syntax.AST
import Language.Hakaru.Syntax.ABT

data EAssoc =
    forall a. EAssoc {-# UNPACK #-} !(Variable a) !(Value a)

newtype Env = Env (IM.IntMap EAssoc)

emptyEnv :: Env
emptyEnv :: Env
emptyEnv = IntMap EAssoc -> Env
Env IntMap EAssoc
forall a. IntMap a
IM.empty

updateEnv :: EAssoc -> Env -> Env
updateEnv :: EAssoc -> Env -> Env
updateEnv v :: EAssoc
v@(EAssoc Variable a
x Value a
_) (Env IntMap EAssoc
xs) =
    IntMap EAssoc -> Env
Env (IntMap EAssoc -> Env) -> IntMap EAssoc -> Env
forall a b. (a -> b) -> a -> b
$ Key -> EAssoc -> IntMap EAssoc -> IntMap EAssoc
forall a. Key -> a -> IntMap a -> IntMap a
IM.insert (Nat -> Key
fromNat (Nat -> Key) -> Nat -> Key
forall a b. (a -> b) -> a -> b
$ Variable a -> Nat
forall k (a :: k). Variable a -> Nat
varID Variable a
x) EAssoc
v IntMap EAssoc
xs

updateEnvs
    :: List1 Variable xs
    -> List1 Value xs
    -> Env
    -> Env
updateEnvs :: List1 Variable xs -> List1 Value xs -> Env -> Env
updateEnvs List1 Variable xs
Nil1         List1 Value xs
Nil1         Env
env = Env
env
updateEnvs (Cons1 Variable x
x List1 Variable xs
xs) (Cons1 Value x
y List1 Value xs
ys) Env
env =
    List1 Variable xs -> List1 Value xs -> Env -> Env
forall (xs :: [Hakaru]).
List1 Variable xs -> List1 Value xs -> Env -> Env
updateEnvs List1 Variable xs
xs List1 Value xs
List1 Value xs
ys (EAssoc -> Env -> Env
updateEnv (Variable x -> Value x -> EAssoc
forall (a :: Hakaru). Variable a -> Value a -> EAssoc
EAssoc Variable x
x Value x
Value x
y) Env
env)

lookupVar :: Variable a -> Env -> Maybe (Value a)
lookupVar :: Variable a -> Env -> Maybe (Value a)
lookupVar Variable a
x (Env IntMap EAssoc
env) = do
    EAssoc Variable a
x' Value a
e' <- Key -> IntMap EAssoc -> Maybe EAssoc
forall a. Key -> IntMap a -> Maybe a
IM.lookup (Nat -> Key
fromNat (Nat -> Key) -> Nat -> Key
forall a b. (a -> b) -> a -> b
$ Variable a -> Nat
forall k (a :: k). Variable a -> Nat
varID Variable a
x) IntMap EAssoc
env
    TypeEq a a
Refl         <- Variable a -> Variable a -> Maybe (TypeEq a a)
forall k (a :: k) (b :: k).
(Show1 Sing, JmEq1 Sing) =>
Variable a -> Variable b -> Maybe (TypeEq a b)
varEq Variable a
x Variable a
x'
    Value a -> Maybe (Value a)
forall (m :: * -> *) a. Monad m => a -> m a
return Value a
e'

---------------------------------------------------------------

-- Makes use of Atkinson's algorithm as described in:
-- Monte Carlo Statistical Methods pg. 55
--
-- Further discussion at:
-- http://www.johndcook.com/blog/2010/06/14/generating-poisson-random-values/
poisson_rng :: Double -> MWC.GenIO -> IO Int
poisson_rng :: Double -> GenIO -> IO Key
poisson_rng Double
lambda GenIO
g' = GenIO -> IO Key
make_poisson GenIO
g'
    where
    smu :: Double
smu   = Double -> Double
forall a. Floating a => a -> a
sqrt Double
lambda
    b :: Double
b     = Double
0.931 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
2.53Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
smu
    a :: Double
a     = -Double
0.059 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.02483Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
b
    vr :: Double
vr    = Double
0.9277 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
3.6224Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/(Double
b Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
2)
    arep :: Double
arep  = Double
1.1239 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
1.1368Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/(Double
b Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
3.4)
    lnlam :: Double
lnlam = Double -> Double
forall a. Floating a => a -> a
log Double
lambda

    make_poisson :: MWC.GenIO -> IO Int
    make_poisson :: GenIO -> IO Key
make_poisson GenIO
g = do
        Double
u <- (Double, Double) -> GenIO -> IO Double
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
(a, a) -> Gen (PrimState m) -> m a
MWC.uniformR (-Double
0.5,Double
0.5) GenIO
g
        Double
v <- (Double, Double) -> GenIO -> IO Double
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
(a, a) -> Gen (PrimState m) -> m a
MWC.uniformR (Double
0,Double
1) GenIO
g
        let us :: Double
us = Double
0.5 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double
forall a. Num a => a -> a
abs Double
u
            k :: Key
k = Double -> Key
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Key) -> Double -> Key
forall a b. (a -> b) -> a -> b
$ (Double
2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
a Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
us Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
b)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
u Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
lambda Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.43
        case () of
            () | Double
us Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0.07 Bool -> Bool -> Bool
&& Double
v Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
vr -> Key -> IO Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
k
            () | Key
k Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
< Key
0                 -> GenIO -> IO Key
make_poisson GenIO
g
            () | Double
us Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0.013 Bool -> Bool -> Bool
&& Double
v Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
us -> GenIO -> IO Key
make_poisson GenIO
g
            () | Double -> Double -> Key -> Bool
accept_region Double
us Double
v Key
k  -> Key -> IO Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
k
            ()
_                          -> GenIO -> IO Key
make_poisson GenIO
g

    accept_region :: Double -> Double -> Int -> Bool
    accept_region :: Double -> Double -> Key -> Bool
accept_region Double
us Double
v Key
k =
        Double -> Double
forall a. Floating a => a -> a
log (Double
v Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
arep Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
aDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/(Double
usDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
us)Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
b))
        Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<=
        -Double
lambda Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Key -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
k Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
lnlam Double -> Double -> Double
forall a. Num a => a -> a -> a
- Key -> Double
forall a. Integral a => a -> Double
logFactorial Key
k


normalize :: [Value 'HProb] -> (LF.LogFloat, Double, [Double])
normalize :: [Value 'HProb] -> (LogFloat, Double, [Double])
normalize []          = (LogFloat
0, Double
0, [])
normalize [(VProb LogFloat
x)] = (LogFloat
x, Double
1, [Double
1])
normalize [Value 'HProb]
xs          = (LogFloat
m, Double
y, [Double]
ys)
    where
    xs' :: [LogFloat]
xs' = (Value 'HProb -> LogFloat) -> [Value 'HProb] -> [LogFloat]
forall a b. (a -> b) -> [a] -> [b]
map (\(VProb LogFloat
x) -> LogFloat
x) [Value 'HProb]
xs
    m :: LogFloat
m   = [LogFloat] -> LogFloat
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [LogFloat]
xs'
    ys :: [Double]
ys  = [ LogFloat -> Double
LF.fromLogFloat (LogFloat
xLogFloat -> LogFloat -> LogFloat
forall a. Fractional a => a -> a -> a
/LogFloat
m) | LogFloat
x <- [LogFloat]
xs' ]
    y :: Double
y   = [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double]
ys


normalizeVector
    :: Value ('HArray 'HProb) -> (LF.LogFloat, Double, V.Vector Double)
normalizeVector :: Value ('HArray 'HProb) -> (LogFloat, Double, Vector Double)
normalizeVector (VArray Vector (Value a)
xs) =
    let xs' :: Vector LogFloat
xs' = (Value a -> LogFloat) -> Vector (Value a) -> Vector LogFloat
forall a b. (a -> b) -> Vector a -> Vector b
V.map (\(VProb LogFloat
x) -> LogFloat
x) Vector (Value a)
xs in
    case Vector (Value a) -> Key
forall a. Vector a -> Key
V.length Vector (Value a)
xs of
    Key
0 -> (LogFloat
0, Double
0, Vector Double
forall a. Vector a
V.empty)
    Key
1 -> (Vector LogFloat -> LogFloat
forall a. Vector a -> a
V.unsafeHead Vector LogFloat
xs', Double
1, Double -> Vector Double
forall a. a -> Vector a
V.singleton Double
1)
    Key
_ ->
        let m :: LogFloat
m   = Vector LogFloat -> LogFloat
forall a. Ord a => Vector a -> a
V.maximum Vector LogFloat
xs'
            ys :: Vector Double
ys  = (LogFloat -> Double) -> Vector LogFloat -> Vector Double
forall a b. (a -> b) -> Vector a -> Vector b
V.map (\LogFloat
x -> LogFloat -> Double
LF.fromLogFloat (LogFloat
xLogFloat -> LogFloat -> LogFloat
forall a. Fractional a => a -> a -> a
/LogFloat
m)) Vector LogFloat
xs'
            y :: Double
y   = Vector Double -> Double
forall a. Num a => Vector a -> a
V.sum Vector Double
ys
        in (LogFloat
m, Double
y, Vector Double
ys)

---------------------------------------------------------------

runEvaluate
    :: (ABT Term abt)
    => abt '[] a
    -> Value a
runEvaluate :: abt '[] a -> Value a
runEvaluate abt '[] a
prog = abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] a
prog Env
emptyEnv

evaluate
    :: (ABT Term abt)
    => abt '[] a
    -> Env
    -> Value a
evaluate :: abt '[] a -> Env -> Value a
evaluate abt '[] a
e Env
env = abt '[] a
-> (Variable a -> Value a) -> (Term abt a -> Value a) -> Value a
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (a :: k) r.
ABT syn abt =>
abt '[] a -> (Variable a -> r) -> (syn abt a -> r) -> r
caseVarSyn abt '[] a
e (Env -> Variable a -> Value a
forall (a :: Hakaru). Env -> Variable a -> Value a
evaluateVar Env
env) ((Term abt a -> Env -> Value a) -> Env -> Term abt a -> Value a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Term abt a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Term abt a -> Env -> Value a
evaluateTerm Env
env)

evaluateVar :: Env -> Variable a -> Value a
evaluateVar :: Env -> Variable a -> Value a
evaluateVar Env
env Variable a
v =
    case Variable a -> Env -> Maybe (Value a)
forall (a :: Hakaru). Variable a -> Env -> Maybe (Value a)
lookupVar Variable a
v Env
env of
    Maybe (Value a)
Nothing -> [Char] -> Value a
forall a. HasCallStack => [Char] -> a
error [Char]
"variable not found!"
    Just Value a
a  -> Value a
a

evaluateTerm
    :: (ABT Term abt)
    => Term abt a
    -> Env
    -> Value a
evaluateTerm :: Term abt a -> Env -> Value a
evaluateTerm Term abt a
t Env
env =
    case Term abt a
t of
    SCon args a
o :$          SArgs abt args
es -> SCon args a -> SArgs abt args -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *)
       (args :: [([Hakaru], Hakaru)]) (a :: Hakaru).
ABT Term abt =>
SCon args a -> SArgs abt args -> Env -> Value a
evaluateSCon    SCon args a
o SArgs abt args
es    Env
env
    NaryOp_  NaryOp a
o    Seq (abt '[] a)
es -> NaryOp a -> Seq (abt '[] a) -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
NaryOp a -> Seq (abt '[] a) -> Env -> Value a
evaluateNaryOp  NaryOp a
o Seq (abt '[] a)
es    Env
env
    Literal_ Literal a
v       -> Literal a -> Value a
forall (a :: Hakaru). Literal a -> Value a
evaluateLiteral Literal a
v
    Empty_   Sing ('HArray a)
_       -> Value a
forall (a :: Hakaru). Value ('HArray a)
evaluateEmpty
    Array_   abt '[] 'HNat
n    abt '[ 'HNat] a
es -> abt '[] 'HNat -> abt '[ 'HNat] a -> Env -> Value ('HArray a)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] 'HNat -> abt '[ 'HNat] a -> Env -> Value ('HArray a)
evaluateArray   abt '[] 'HNat
n abt '[ 'HNat] a
es    Env
env
    ArrayLiteral_ [abt '[] a]
es -> Vector (Value a) -> Value ('HArray a)
forall (a :: Hakaru). Vector (Value a) -> Value ('HArray a)
VArray (Vector (Value a) -> Value ('HArray a))
-> ([Value a] -> Vector (Value a))
-> [Value a]
-> Value ('HArray a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value a] -> Vector (Value a)
forall a. [a] -> Vector a
V.fromList ([Value a] -> Value ('HArray a)) -> [Value a] -> Value ('HArray a)
forall a b. (a -> b) -> a -> b
$ (abt '[] a -> Value a) -> [abt '[] a] -> [Value a]
forall a b. (a -> b) -> [a] -> [b]
map ((abt '[] a -> Env -> Value a) -> Env -> abt '[] a -> Value a
forall a b c. (a -> b -> c) -> b -> a -> c
flip abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate Env
env) [abt '[] a]
es
    Bucket abt '[] 'HNat
b abt '[] 'HNat
e    Reducer abt '[] a
rs -> abt '[] 'HNat
-> abt '[] 'HNat -> Reducer abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] 'HNat
-> abt '[] 'HNat -> Reducer abt '[] a -> Env -> Value a
evaluateBucket  abt '[] 'HNat
b abt '[] 'HNat
e  Reducer abt '[] a
rs Env
env
    Datum_   Datum (abt '[]) (HData' t)
d       -> Datum (abt '[]) (HData' t) -> Env -> Value (HData' t)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: HakaruCon).
ABT Term abt =>
Datum (abt '[]) (HData' a) -> Env -> Value (HData' a)
evaluateDatum   Datum (abt '[]) (HData' t)
d       Env
env
    Case_    abt '[] a
o    [Branch a abt a]
es -> abt '[] a -> [Branch a abt a] -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
       (b :: Hakaru).
ABT Term abt =>
abt '[] a -> [Branch a abt b] -> Env -> Value b
evaluateCase    abt '[] a
o [Branch a abt a]
es    Env
env
    Superpose_    NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
es -> NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
-> Env -> Value ('HMeasure a)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
-> Env -> Value ('HMeasure a)
evaluateSuperpose NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
es    Env
env
    Reject_  Sing ('HMeasure a)
_       -> (Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb)))
-> Value ('HMeasure a)
forall (b :: Hakaru).
(Value 'HProb -> GenIO -> IO (Maybe (Value b, Value 'HProb)))
-> Value ('HMeasure b)
VMeasure ((Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb)))
 -> Value ('HMeasure a))
-> (Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb)))
-> Value ('HMeasure a)
forall a b. (a -> b) -> a -> b
$ \Value 'HProb
_ GenIO
_ -> Maybe (Value a, Value 'HProb) -> IO (Maybe (Value a, Value 'HProb))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Value a, Value 'HProb)
forall a. Maybe a
Nothing

evaluateSCon
    :: (ABT Term abt)
    => SCon args a
    -> SArgs abt args
    -> Env
    -> Value a
evaluateSCon :: SCon args a -> SArgs abt args -> Env -> Value a
evaluateSCon SCon args a
Lam_ (abt vars a
e1 :* SArgs abt args
End) Env
env =
    abt '[a] a
-> (Variable a -> abt '[] a -> Value (a ':-> a))
-> Value (a ':-> a)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind abt vars a
abt '[a] a
e1 ((Variable a -> abt '[] a -> Value (a ':-> a)) -> Value (a ':-> a))
-> (Variable a -> abt '[] a -> Value (a ':-> a))
-> Value (a ':-> a)
forall a b. (a -> b) -> a -> b
$ \Variable a
x abt '[] a
e1' ->
        (Value a -> Value a) -> Value (a ':-> a)
forall (a :: Hakaru) (b :: Hakaru).
(Value a -> Value b) -> Value (a ':-> b)
VLam ((Value a -> Value a) -> Value (a ':-> a))
-> (Value a -> Value a) -> Value (a ':-> a)
forall a b. (a -> b) -> a -> b
$ \Value a
v -> abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] a
e1' (EAssoc -> Env -> Env
updateEnv (Variable a -> Value a -> EAssoc
forall (a :: Hakaru). Variable a -> Value a -> EAssoc
EAssoc Variable a
x Value a
v) Env
env)
evaluateSCon SCon args a
App_ (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) Env
env =
    case abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env of
    VLam Value a -> Value b
f -> Value a -> Value b
f (abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e2 Env
env)
evaluateSCon SCon args a
Let_ (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) Env
env =
    let v :: Value a
v = abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env
    in abt '[a] a -> (Variable a -> abt '[] a -> Value a) -> Value a
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind abt vars a
abt '[a] a
e2 ((Variable a -> abt '[] a -> Value a) -> Value a)
-> (Variable a -> abt '[] a -> Value a) -> Value a
forall a b. (a -> b) -> a -> b
$ \Variable a
x abt '[] a
e2' ->
        abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] a
e2' (EAssoc -> Env -> Env
updateEnv (Variable a -> Value a -> EAssoc
forall (a :: Hakaru). Variable a -> Value a -> EAssoc
EAssoc Variable a
x Value a
v) Env
env)
evaluateSCon (CoerceTo_   Coercion a a
c) (abt vars a
e1 :* SArgs abt args
End) Env
env =
    Coercion a a -> Value a -> Value a
forall (f :: Hakaru -> *) (a :: Hakaru) (b :: Hakaru).
Coerce f =>
Coercion a b -> f a -> f b
coerceTo Coercion a a
c (Value a -> Value a) -> Value a -> Value a
forall a b. (a -> b) -> a -> b
$ abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env
evaluateSCon (UnsafeFrom_ Coercion a b
c) (abt vars a
e1 :* SArgs abt args
End) Env
env =
    Coercion a b -> Value b -> Value a
forall (f :: Hakaru -> *) (a :: Hakaru) (b :: Hakaru).
Coerce f =>
Coercion a b -> f b -> f a
coerceFrom Coercion a b
c (Value b -> Value a) -> Value b -> Value a
forall a b. (a -> b) -> a -> b
$ abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env
evaluateSCon (PrimOp_ PrimOp typs a
o)     SArgs abt args
es Env
env = PrimOp typs a -> SArgs abt args -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (typs :: [Hakaru])
       (args :: [([Hakaru], Hakaru)]) (a :: Hakaru).
(ABT Term abt, typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SArgs abt args -> Env -> Value a
evaluatePrimOp    PrimOp typs a
o SArgs abt args
es Env
env
evaluateSCon (ArrayOp_ ArrayOp typs a
o)    SArgs abt args
es Env
env = ArrayOp typs a -> SArgs abt args -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (typs :: [Hakaru])
       (args :: [([Hakaru], Hakaru)]) (a :: Hakaru).
(ABT Term abt, typs ~ UnLCs args, args ~ LCs typs) =>
ArrayOp typs a -> SArgs abt args -> Env -> Value a
evaluateArrayOp   ArrayOp typs a
o SArgs abt args
es Env
env
evaluateSCon (MeasureOp_  MeasureOp typs a
m) SArgs abt args
es Env
env = MeasureOp typs a -> SArgs abt args -> Env -> Value ('HMeasure a)
forall (abt :: [Hakaru] -> Hakaru -> *) (typs :: [Hakaru])
       (args :: [([Hakaru], Hakaru)]) (a :: Hakaru).
(ABT Term abt, typs ~ UnLCs args, args ~ LCs typs) =>
MeasureOp typs a -> SArgs abt args -> Env -> Value ('HMeasure a)
evaluateMeasureOp MeasureOp typs a
m SArgs abt args
es Env
env
evaluateSCon SCon args a
Dirac           (abt vars a
e1 :* SArgs abt args
End) Env
env =
    (Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb)))
-> Value ('HMeasure a)
forall (b :: Hakaru).
(Value 'HProb -> GenIO -> IO (Maybe (Value b, Value 'HProb)))
-> Value ('HMeasure b)
VMeasure ((Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb)))
 -> Value ('HMeasure a))
-> (Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb)))
-> Value ('HMeasure a)
forall a b. (a -> b) -> a -> b
$ \Value 'HProb
p GenIO
_ -> Maybe (Value a, Value 'HProb) -> IO (Maybe (Value a, Value 'HProb))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Value a, Value 'HProb)
 -> IO (Maybe (Value a, Value 'HProb)))
-> Maybe (Value a, Value 'HProb)
-> IO (Maybe (Value a, Value 'HProb))
forall a b. (a -> b) -> a -> b
$ (Value a, Value 'HProb) -> Maybe (Value a, Value 'HProb)
forall a. a -> Maybe a
Just (abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env, Value 'HProb
p)
evaluateSCon SCon args a
MBind (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) Env
env =
    case abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env of
    VMeasure Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb))
m1 -> (Value 'HProb -> GenIO -> IO (Maybe (Value b, Value 'HProb)))
-> Value ('HMeasure b)
forall (b :: Hakaru).
(Value 'HProb -> GenIO -> IO (Maybe (Value b, Value 'HProb)))
-> Value ('HMeasure b)
VMeasure ((Value 'HProb -> GenIO -> IO (Maybe (Value b, Value 'HProb)))
 -> Value ('HMeasure b))
-> (Value 'HProb -> GenIO -> IO (Maybe (Value b, Value 'HProb)))
-> Value ('HMeasure b)
forall a b. (a -> b) -> a -> b
$ \ Value 'HProb
p GenIO
g -> do
        Maybe (Value a, Value 'HProb)
x <- Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb))
m1 Value 'HProb
p GenIO
g
        case Maybe (Value a, Value 'HProb)
x of
            Maybe (Value a, Value 'HProb)
Nothing -> Maybe (Value b, Value 'HProb) -> IO (Maybe (Value b, Value 'HProb))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Value b, Value 'HProb)
forall a. Maybe a
Nothing
            Just (Value a
a, Value 'HProb
p') ->
                abt '[a] a
-> (Variable a -> abt '[] a -> IO (Maybe (Value b, Value 'HProb)))
-> IO (Maybe (Value b, Value 'HProb))
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind abt vars a
abt '[a] a
e2 ((Variable a -> abt '[] a -> IO (Maybe (Value b, Value 'HProb)))
 -> IO (Maybe (Value b, Value 'HProb)))
-> (Variable a -> abt '[] a -> IO (Maybe (Value b, Value 'HProb)))
-> IO (Maybe (Value b, Value 'HProb))
forall a b. (a -> b) -> a -> b
$ \Variable a
x' abt '[] a
e2' ->
                    case abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] a
e2' (EAssoc -> Env -> Env
updateEnv (Variable a -> Value a -> EAssoc
forall (a :: Hakaru). Variable a -> Value a -> EAssoc
EAssoc Variable a
x' Value a
a) Env
env) of
                    VMeasure Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb))
y -> Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb))
y Value 'HProb
p' GenIO
g

evaluateSCon SCon args a
Plate (abt vars a
n :* abt vars a
e2 :* SArgs abt args
End) Env
env =
    case abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
n Env
env of
    VNat Natural
n' -> abt '[ 'HNat] a
-> (Variable 'HNat -> abt '[] a -> Value ('HMeasure ('HArray a)))
-> Value ('HMeasure ('HArray a))
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind abt vars a
abt '[ 'HNat] a
e2 ((Variable 'HNat -> abt '[] a -> Value ('HMeasure ('HArray a)))
 -> Value ('HMeasure ('HArray a)))
-> (Variable 'HNat -> abt '[] a -> Value ('HMeasure ('HArray a)))
-> Value ('HMeasure ('HArray a))
forall a b. (a -> b) -> a -> b
$ \Variable 'HNat
x abt '[] a
e' ->
        (Value 'HProb
 -> GenIO -> IO (Maybe (Value ('HArray a), Value 'HProb)))
-> Value ('HMeasure ('HArray a))
forall (b :: Hakaru).
(Value 'HProb -> GenIO -> IO (Maybe (Value b, Value 'HProb)))
-> Value ('HMeasure b)
VMeasure ((Value 'HProb
  -> GenIO -> IO (Maybe (Value ('HArray a), Value 'HProb)))
 -> Value ('HMeasure ('HArray a)))
-> (Value 'HProb
    -> GenIO -> IO (Maybe (Value ('HArray a), Value 'HProb)))
-> Value ('HMeasure ('HArray a))
forall a b. (a -> b) -> a -> b
$ \(VProb LogFloat
p) GenIO
g -> MaybeT IO (Value ('HArray a), Value 'HProb)
-> IO (Maybe (Value ('HArray a), Value 'HProb))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO (Value ('HArray a), Value 'HProb)
 -> IO (Maybe (Value ('HArray a), Value 'HProb)))
-> MaybeT IO (Value ('HArray a), Value 'HProb)
-> IO (Maybe (Value ('HArray a), Value 'HProb))
forall a b. (a -> b) -> a -> b
$ do
            (Vector (Value a)
v', Vector (Value 'HProb)
ps) <- (Vector (Value a, Value 'HProb)
 -> (Vector (Value a), Vector (Value 'HProb)))
-> MaybeT IO (Vector (Value a, Value 'HProb))
-> MaybeT IO (Vector (Value a), Vector (Value 'HProb))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vector (Value a, Value 'HProb)
-> (Vector (Value a), Vector (Value 'HProb))
forall a b. Vector (a, b) -> (Vector a, Vector b)
V.unzip (MaybeT IO (Vector (Value a, Value 'HProb))
 -> MaybeT IO (Vector (Value a), Vector (Value 'HProb)))
-> (Vector (Value ('HMeasure a))
    -> MaybeT IO (Vector (Value a, Value 'HProb)))
-> Vector (Value ('HMeasure a))
-> MaybeT IO (Vector (Value a), Vector (Value 'HProb))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value ('HMeasure a) -> MaybeT IO (Value a, Value 'HProb))
-> Vector (Value ('HMeasure a))
-> MaybeT IO (Vector (Value a, Value 'HProb))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
V.mapM (GenIO -> Value ('HMeasure a) -> MaybeT IO (Value a, Value 'HProb)
forall (a :: Hakaru).
GenIO -> Value ('HMeasure a) -> MaybeT IO (Value a, Value 'HProb)
performMaybe GenIO
g) (Vector (Value ('HMeasure a))
 -> MaybeT IO (Vector (Value a), Vector (Value 'HProb)))
-> Vector (Value ('HMeasure a))
-> MaybeT IO (Vector (Value a), Vector (Value 'HProb))
forall a b. (a -> b) -> a -> b
$
                Key -> (Key -> Value a) -> Vector (Value a)
forall a. Key -> (Key -> a) -> Vector a
V.generate (Integer -> Key
forall a. Num a => Integer -> a
fromInteger (Integer -> Key) -> Integer -> Key
forall a b. (a -> b) -> a -> b
$ Natural -> Integer
fromNatural Natural
n') ((Key -> Value a) -> Vector (Value a))
-> (Key -> Value a) -> Vector (Value a)
forall a b. (a -> b) -> a -> b
$ \Key
v ->
                    abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] a
e' (Env -> Value a) -> Env -> Value a
forall a b. (a -> b) -> a -> b
$
                    EAssoc -> Env -> Env
updateEnv (Variable 'HNat -> Value 'HNat -> EAssoc
forall (a :: Hakaru). Variable a -> Value a -> EAssoc
EAssoc Variable 'HNat
x (Value 'HNat -> EAssoc)
-> (Natural -> Value 'HNat) -> Natural -> EAssoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Value 'HNat
VNat (Natural -> EAssoc) -> Natural -> EAssoc
forall a b. (a -> b) -> a -> b
$ Key -> Natural
intToNatural Key
v) Env
env
            (Value ('HArray a), Value 'HProb)
-> MaybeT IO (Value ('HArray a), Value 'HProb)
forall (m :: * -> *) a. Monad m => a -> m a
return
                ( Vector (Value a) -> Value ('HArray a)
forall (a :: Hakaru). Vector (Value a) -> Value ('HArray a)
VArray Vector (Value a)
v'
                , LogFloat -> Value 'HProb
VProb (LogFloat -> Value 'HProb) -> LogFloat -> Value 'HProb
forall a b. (a -> b) -> a -> b
$ LogFloat
p LogFloat -> LogFloat -> LogFloat
forall a. Num a => a -> a -> a
* Vector LogFloat -> LogFloat
forall a. Num a => Vector a -> a
V.product ((Value 'HProb -> LogFloat)
-> Vector (Value 'HProb) -> Vector LogFloat
forall a b. (a -> b) -> Vector a -> Vector b
V.map (\(VProb LogFloat
y) -> LogFloat
y) Vector (Value 'HProb)
ps)
                )
    where
    performMaybe
        :: MWC.GenIO
        -> Value ('HMeasure a)
        -> MaybeT IO (Value a, Value 'HProb)
    performMaybe :: GenIO -> Value ('HMeasure a) -> MaybeT IO (Value a, Value 'HProb)
performMaybe GenIO
g (VMeasure Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb))
m) = IO (Maybe (Value a, Value 'HProb))
-> MaybeT IO (Value a, Value 'HProb)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe (Value a, Value 'HProb))
 -> MaybeT IO (Value a, Value 'HProb))
-> IO (Maybe (Value a, Value 'HProb))
-> MaybeT IO (Value a, Value 'HProb)
forall a b. (a -> b) -> a -> b
$ Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb))
m (LogFloat -> Value 'HProb
VProb LogFloat
1) GenIO
g

evaluateSCon SCon args a
Chain (abt vars a
n :* abt vars a
s :* abt vars a
e :* SArgs abt args
End) Env
env =
    case (abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
n Env
env, abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
s Env
env) of
    (VNat Natural
n', Value a
start) ->
        abt '[s] a
-> (Variable s
    -> abt '[] a -> Value ('HMeasure (HPair ('HArray a) s)))
-> Value ('HMeasure (HPair ('HArray a) s))
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind abt vars a
abt '[s] a
e ((Variable s
  -> abt '[] a -> Value ('HMeasure (HPair ('HArray a) s)))
 -> Value ('HMeasure (HPair ('HArray a) s)))
-> (Variable s
    -> abt '[] a -> Value ('HMeasure (HPair ('HArray a) s)))
-> Value ('HMeasure (HPair ('HArray a) s))
forall a b. (a -> b) -> a -> b
$ \Variable s
x abt '[] a
e' ->
            let s' :: Value (s ':-> a)
s' = (Value s -> Value a) -> Value (s ':-> a)
forall (a :: Hakaru) (b :: Hakaru).
(Value a -> Value b) -> Value (a ':-> b)
VLam ((Value s -> Value a) -> Value (s ':-> a))
-> (Value s -> Value a) -> Value (s ':-> a)
forall a b. (a -> b) -> a -> b
$ \Value s
v -> abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] a
e' (EAssoc -> Env -> Env
updateEnv (Variable s -> Value s -> EAssoc
forall (a :: Hakaru). Variable a -> Value a -> EAssoc
EAssoc Variable s
x Value s
v) Env
env) in
            (Value 'HProb
 -> GenIO -> IO (Maybe (Value (HPair ('HArray a) s), Value 'HProb)))
-> Value ('HMeasure (HPair ('HArray a) s))
forall (b :: Hakaru).
(Value 'HProb -> GenIO -> IO (Maybe (Value b, Value 'HProb)))
-> Value ('HMeasure b)
VMeasure (\(VProb LogFloat
p) GenIO
g -> MaybeT IO (Value (HPair ('HArray a) s), Value 'HProb)
-> IO (Maybe (Value (HPair ('HArray a) s), Value 'HProb))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO (Value (HPair ('HArray a) s), Value 'HProb)
 -> IO (Maybe (Value (HPair ('HArray a) s), Value 'HProb)))
-> MaybeT IO (Value (HPair ('HArray a) s), Value 'HProb)
-> IO (Maybe (Value (HPair ('HArray a) s), Value 'HProb))
forall a b. (a -> b) -> a -> b
$ do
                ([(Value a, Value 'HProb)]
evaluates, Value s
sout) <- StateT (Value s) (MaybeT IO) [(Value a, Value 'HProb)]
-> Value s -> MaybeT IO ([(Value a, Value 'HProb)], Value s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Key
-> StateT (Value s) (MaybeT IO) (Value a, Value 'HProb)
-> StateT (Value s) (MaybeT IO) [(Value a, Value 'HProb)]
forall (m :: * -> *) a. Applicative m => Key -> m a -> m [a]
replicateM (Natural -> Key
unsafeInt Natural
n') (StateT (Value s) (MaybeT IO) (Value a, Value 'HProb)
 -> StateT (Value s) (MaybeT IO) [(Value a, Value 'HProb)])
-> StateT (Value s) (MaybeT IO) (Value a, Value 'HProb)
-> StateT (Value s) (MaybeT IO) [(Value a, Value 'HProb)]
forall a b. (a -> b) -> a -> b
$ GenIO
-> Value (s ':-> 'HMeasure (HPair a s))
-> StateT (Value s) (MaybeT IO) (Value a, Value 'HProb)
forall (s :: Hakaru) (a :: Hakaru).
GenIO
-> Value (s ':-> 'HMeasure (HPair a s))
-> StateT (Value s) (MaybeT IO) (Value a, Value 'HProb)
convert GenIO
g Value (s ':-> a)
Value (s ':-> 'HMeasure (HPair a s))
s') Value s
Value a
start
                let ([Value a]
v', [Value 'HProb]
ps) = [(Value a, Value 'HProb)] -> ([Value a], [Value 'HProb])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Value a, Value 'HProb)]
evaluates
                    bodyType :: Sing ('HMeasure (HPair a b)) -> Sing ('HArray a)
                    bodyType :: Sing ('HMeasure (HPair a b)) -> Sing ('HArray a)
bodyType = Sing a -> Sing ('HArray a)
forall (a :: Hakaru). Sing a -> Sing ('HArray a)
SArray (Sing a -> Sing ('HArray a))
-> (Sing ('HMeasure (HPair a b)) -> Sing a)
-> Sing ('HMeasure (HPair a b))
-> Sing ('HArray a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sing a, Sing b) -> Sing a
forall a b. (a, b) -> a
fst ((Sing a, Sing b) -> Sing a)
-> (Sing ('HMeasure (HPair a b)) -> (Sing a, Sing b))
-> Sing ('HMeasure (HPair a b))
-> Sing a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing (HPair a b) -> (Sing a, Sing b)
forall (a :: Hakaru) (b :: Hakaru).
Sing (HPair a b) -> (Sing a, Sing b)
sUnPair (Sing (HPair a b) -> (Sing a, Sing b))
-> (Sing ('HMeasure (HPair a b)) -> Sing (HPair a b))
-> Sing ('HMeasure (HPair a b))
-> (Sing a, Sing b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sing ('HMeasure (HPair a b)) -> Sing (HPair a b)
forall (a :: Hakaru). Sing ('HMeasure a) -> Sing a
sUnMeasure
                (Value (HPair ('HArray a) s), Value 'HProb)
-> MaybeT IO (Value (HPair ('HArray a) s), Value 'HProb)
forall (m :: * -> *) a. Monad m => a -> m a
return
                    ( Datum Value (HData' (('TyCon "Pair" ':@ 'HArray a) ':@ a))
-> Value (HData' (('TyCon "Pair" ':@ 'HArray a) ':@ a))
forall (t :: HakaruCon). Datum Value (HData' t) -> Value (HData' t)
VDatum (Datum Value (HData' (('TyCon "Pair" ':@ 'HArray a) ':@ a))
 -> Value (HData' (('TyCon "Pair" ':@ 'HArray a) ':@ a)))
-> Datum Value (HData' (('TyCon "Pair" ':@ 'HArray a) ':@ a))
-> Value (HData' (('TyCon "Pair" ':@ 'HArray a) ':@ a))
forall a b. (a -> b) -> a -> b
$ Sing ('HArray a)
-> Sing a
-> Value ('HArray a)
-> Value a
-> Datum Value (HPair ('HArray a) a)
forall (a :: Hakaru) (b :: Hakaru) (ast :: Hakaru -> *).
Sing a -> Sing b -> ast a -> ast b -> Datum ast (HPair a b)
dPair_ (Sing ('HMeasure (HPair a s)) -> Sing ('HArray a)
forall (a :: Hakaru) (b :: Hakaru).
Sing ('HMeasure (HPair a b)) -> Sing ('HArray a)
bodyType (Sing ('HMeasure (HPair a s)) -> Sing ('HArray a))
-> Sing ('HMeasure (HPair a s)) -> Sing ('HArray a)
forall a b. (a -> b) -> a -> b
$ abt '[s] a -> (Variable s -> abt '[] a -> Sing a) -> Sing a
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind abt vars a
abt '[s] a
e ((abt '[] a -> Sing a) -> Variable s -> abt '[] a -> Sing a
forall a b. a -> b -> a
const abt '[] a -> Sing a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Sing a
typeOf)) (abt '[] a -> Sing a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Sing a
typeOf abt vars a
abt '[] a
s)
                        (Vector (Value a) -> Value ('HArray a)
forall (a :: Hakaru). Vector (Value a) -> Value ('HArray a)
VArray (Vector (Value a) -> Value ('HArray a))
-> ([Value a] -> Vector (Value a))
-> [Value a]
-> Value ('HArray a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value a] -> Vector (Value a)
forall a. [a] -> Vector a
V.fromList ([Value a] -> Value ('HArray a)) -> [Value a] -> Value ('HArray a)
forall a b. (a -> b) -> a -> b
$ [Value a]
v') Value s
Value a
sout
                    , LogFloat -> Value 'HProb
VProb (LogFloat -> Value 'HProb) -> LogFloat -> Value 'HProb
forall a b. (a -> b) -> a -> b
$ LogFloat
p LogFloat -> LogFloat -> LogFloat
forall a. Num a => a -> a -> a
* [LogFloat] -> LogFloat
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ((Value 'HProb -> LogFloat) -> [Value 'HProb] -> [LogFloat]
forall a b. (a -> b) -> [a] -> [b]
map (\(VProb LogFloat
y) -> LogFloat
y) [Value 'HProb]
ps)
                    ))
    where
    convert
        :: MWC.GenIO
        -> Value (s ':-> 'HMeasure (HPair a s))
        -> StateT (Value s) (MaybeT IO) (Value a, Value 'HProb)
    convert :: GenIO
-> Value (s ':-> 'HMeasure (HPair a s))
-> StateT (Value s) (MaybeT IO) (Value a, Value 'HProb)
convert GenIO
g (VLam Value a -> Value b
f) = (Value a -> MaybeT IO ((Value a, Value 'HProb), Value a))
-> StateT (Value a) (MaybeT IO) (Value a, Value 'HProb)
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((Value a -> MaybeT IO ((Value a, Value 'HProb), Value a))
 -> StateT (Value a) (MaybeT IO) (Value a, Value 'HProb))
-> (Value a -> MaybeT IO ((Value a, Value 'HProb), Value a))
-> StateT (Value a) (MaybeT IO) (Value a, Value 'HProb)
forall a b. (a -> b) -> a -> b
$ \Value a
s' ->
        case Value a -> Value b
f Value a
s' of
        VMeasure Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb))
f' -> do
            (Value a
as'', Value 'HProb
p') <- IO (Maybe (Value a, Value 'HProb))
-> MaybeT IO (Value a, Value 'HProb)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb))
f' (LogFloat -> Value 'HProb
VProb LogFloat
1) GenIO
g)
            let (Value a
a, Value a
s'') = Value (HPair a a) -> (Value a, Value a)
forall (a :: Hakaru) (b :: Hakaru).
Value (HPair a b) -> (Value a, Value b)
unPair Value a
Value (HPair a a)
as''
            ((Value a, Value 'HProb), Value a)
-> MaybeT IO ((Value a, Value 'HProb), Value a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Value a
a, Value 'HProb
p'), Value a
s'')

    unPair :: Value (HPair a b) -> (Value a, Value b)
    unPair :: Value (HPair a b) -> (Value a, Value b)
unPair (VDatum (Datum Text
"pair" Sing (HData' t)
_typ
        (Inl (Et (Konst Value b
a)
            (Et (Konst Value b
b) DatumStruct xs Value (HData' t)
Done))))) = (Value a
Value b
a, Value b
Value b
b)
    unPair Value (HPair a b)
x = case Value (HPair a b)
x of {}

evaluateSCon (Summate HDiscrete a
hd HSemiring a
hs) (abt vars a
e1 :* abt vars a
e2 :* abt vars a
e3 :* SArgs abt args
End) Env
env =
    case (abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env, abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e2 Env
env) of
    (Value a
lo, Value a
hi) ->
        abt '[a] a -> (Variable a -> abt '[] a -> Value a) -> Value a
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind abt vars a
abt '[a] a
e3 ((Variable a -> abt '[] a -> Value a) -> Value a)
-> (Variable a -> abt '[] a -> Value a) -> Value a
forall a b. (a -> b) -> a -> b
$ \Variable a
x abt '[] a
e3' ->
            (Value a -> Value a -> Value a) -> Value a -> [Value a] -> Value a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Value a
t Value a
i ->
                   NaryOp a -> Value a -> Value a -> Value a
forall (a :: Hakaru). NaryOp a -> Value a -> Value a -> Value a
evalOp (HSemiring a -> NaryOp a
forall (a :: Hakaru). HSemiring a -> NaryOp a
Sum  HSemiring a
hs) Value a
t (Value a -> Value a) -> Value a -> Value a
forall a b. (a -> b) -> a -> b
$
                     abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] a
e3' (EAssoc -> Env -> Env
updateEnv (Variable a -> Value a -> EAssoc
forall (a :: Hakaru). Variable a -> Value a -> EAssoc
EAssoc Variable a
x Value a
i) Env
env))
                  (NaryOp a -> Value a
forall (a :: Hakaru). NaryOp a -> Value a
identityElement (NaryOp a -> Value a) -> NaryOp a -> Value a
forall a b. (a -> b) -> a -> b
$ HSemiring a -> NaryOp a
forall (a :: Hakaru). HSemiring a -> NaryOp a
Sum HSemiring a
hs)
                  (HDiscrete a -> Value a -> Value a -> [Value a]
forall (a :: Hakaru).
HDiscrete a -> Value a -> Value a -> [Value a]
enumFromUntilValue HDiscrete a
hd Value a
Value a
lo Value a
Value a
hi)

evaluateSCon (Product HDiscrete a
hd HSemiring a
hs) (abt vars a
e1 :* abt vars a
e2 :* abt vars a
e3 :* SArgs abt args
End) Env
env =
    case (abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env, abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e2 Env
env) of
    (Value a
lo, Value a
hi) ->
        abt '[a] a -> (Variable a -> abt '[] a -> Value a) -> Value a
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind abt vars a
abt '[a] a
e3 ((Variable a -> abt '[] a -> Value a) -> Value a)
-> (Variable a -> abt '[] a -> Value a) -> Value a
forall a b. (a -> b) -> a -> b
$ \Variable a
x abt '[] a
e3' ->
            (Value a -> Value a -> Value a) -> Value a -> [Value a] -> Value a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Value a
t Value a
i ->
                   NaryOp a -> Value a -> Value a -> Value a
forall (a :: Hakaru). NaryOp a -> Value a -> Value a -> Value a
evalOp (HSemiring a -> NaryOp a
forall (a :: Hakaru). HSemiring a -> NaryOp a
Prod HSemiring a
hs) Value a
t (Value a -> Value a) -> Value a -> Value a
forall a b. (a -> b) -> a -> b
$
                     abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] a
e3' (EAssoc -> Env -> Env
updateEnv (Variable a -> Value a -> EAssoc
forall (a :: Hakaru). Variable a -> Value a -> EAssoc
EAssoc Variable a
x Value a
i) Env
env))
                  (NaryOp a -> Value a
forall (a :: Hakaru). NaryOp a -> Value a
identityElement (NaryOp a -> Value a) -> NaryOp a -> Value a
forall a b. (a -> b) -> a -> b
$ HSemiring a -> NaryOp a
forall (a :: Hakaru). HSemiring a -> NaryOp a
Prod HSemiring a
hs)
                  (HDiscrete a -> Value a -> Value a -> [Value a]
forall (a :: Hakaru).
HDiscrete a -> Value a -> Value a -> [Value a]
enumFromUntilValue HDiscrete a
hd Value a
Value a
lo Value a
Value a
hi)

evaluateSCon SCon args a
s SArgs abt args
_ Env
_ = [Char] -> Value a
forall a. HasCallStack => [Char] -> a
error ([Char] -> Value a) -> [Char] -> Value a
forall a b. (a -> b) -> a -> b
$ [Char]
"TODO: evaluateSCon{" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SCon args a -> [Char]
forall a. Show a => a -> [Char]
show SCon args a
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"}"

evaluatePrimOp
    ::  ( ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
    => PrimOp typs a
    -> SArgs abt args
    -> Env
    -> Value a
evaluatePrimOp :: PrimOp typs a -> SArgs abt args -> Env -> Value a
evaluatePrimOp PrimOp typs a
Not (abt vars a
e1 :* SArgs abt args
End) Env
env = 
    case abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env of        
      VDatum Datum Value (HData' t)
a -> if Datum Value (HData' t)
Datum Value ('HData ('TyCon "Bool") '[ '[], '[]])
a Datum Value ('HData ('TyCon "Bool") '[ '[], '[]])
-> Datum Value ('HData ('TyCon "Bool") '[ '[], '[]]) -> Bool
forall a. Eq a => a -> a -> Bool
== Datum Value ('HData ('TyCon "Bool") '[ '[], '[]])
forall (ast :: Hakaru -> *).
Datum ast ('HData ('TyCon "Bool") '[ '[], '[]])
dTrue
                  then Datum Value (HData' ('TyCon "Bool"))
-> Value (HData' ('TyCon "Bool"))
forall (t :: HakaruCon). Datum Value (HData' t) -> Value (HData' t)
VDatum Datum Value (HData' ('TyCon "Bool"))
forall (ast :: Hakaru -> *).
Datum ast ('HData ('TyCon "Bool") '[ '[], '[]])
dFalse
                  else Datum Value (HData' ('TyCon "Bool"))
-> Value (HData' ('TyCon "Bool"))
forall (t :: HakaruCon). Datum Value (HData' t) -> Value (HData' t)
VDatum Datum Value (HData' ('TyCon "Bool"))
forall (ast :: Hakaru -> *).
Datum ast ('HData ('TyCon "Bool") '[ '[], '[]])
dTrue

evaluatePrimOp PrimOp typs a
Pi  SArgs abt args
End         Env
_   = LogFloat -> Value 'HProb
VProb (LogFloat -> Value 'HProb)
-> (Double -> LogFloat) -> Double -> Value 'HProb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> LogFloat
LF.logFloat (Double -> Value 'HProb) -> Double -> Value 'HProb
forall a b. (a -> b) -> a -> b
$ Double
forall a. Floating a => a
pi
evaluatePrimOp PrimOp typs a
Cos (abt vars a
e1 :* SArgs abt args
End) Env
env =
    case abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env of
      VReal Double
v1 -> Double -> Value 'HReal
VReal (Double -> Value 'HReal)
-> (Double -> Double) -> Double -> Value 'HReal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double
forall a. Floating a => a -> a
cos (Double -> Value 'HReal) -> Double -> Value 'HReal
forall a b. (a -> b) -> a -> b
$ Double
v1

evaluatePrimOp PrimOp typs a
Sin (abt vars a
e1 :* SArgs abt args
End) Env
env =
    case abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env of
      VReal Double
v1 -> Double -> Value 'HReal
VReal (Double -> Value 'HReal)
-> (Double -> Double) -> Double -> Value 'HReal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double
forall a. Floating a => a -> a
sin (Double -> Value 'HReal) -> Double -> Value 'HReal
forall a b. (a -> b) -> a -> b
$ Double
v1

evaluatePrimOp PrimOp typs a
Tan (abt vars a
e1 :* SArgs abt args
End) Env
env =
    case abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env of
      VReal Double
v1 -> Double -> Value 'HReal
VReal (Double -> Value 'HReal)
-> (Double -> Double) -> Double -> Value 'HReal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double
forall a. Floating a => a -> a
tan (Double -> Value 'HReal) -> Double -> Value 'HReal
forall a b. (a -> b) -> a -> b
$ Double
v1

evaluatePrimOp PrimOp typs a
RealPow (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) Env
env =
    case (abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env, abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e2 Env
env) of
      (VProb LogFloat
v1, VReal Double
v2) -> LogFloat -> Value 'HProb
VProb (LogFloat -> Value 'HProb) -> LogFloat -> Value 'HProb
forall a b. (a -> b) -> a -> b
$ LogFloat -> Double -> LogFloat
LF.pow LogFloat
v1 Double
v2

evaluatePrimOp PrimOp typs a
Choose (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) Env
env =
    case (abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env, abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e2 Env
env) of
      (VNat Natural
v1, VNat Natural
v2) -> Natural -> Value 'HNat
VNat (Natural -> Value 'HNat) -> Natural -> Value 'HNat
forall a b. (a -> b) -> a -> b
$ Natural -> Natural -> Natural
forall a. Integral a => a -> a -> a
EB.choose Natural
v1 Natural
v2
      
evaluatePrimOp PrimOp typs a
Exp (abt vars a
e1 :* SArgs abt args
End) Env
env =
    case abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env of
      VReal Double
v1 -> LogFloat -> Value 'HProb
VProb (LogFloat -> Value 'HProb)
-> (Double -> LogFloat) -> Double -> Value 'HProb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> LogFloat
LF.logToLogFloat (Double -> Value 'HProb) -> Double -> Value 'HProb
forall a b. (a -> b) -> a -> b
$ Double
v1

evaluatePrimOp PrimOp typs a
Log (abt vars a
e1 :* SArgs abt args
End) Env
env =
    case abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env of
      VProb LogFloat
v1 -> Double -> Value 'HReal
VReal (Double -> Value 'HReal)
-> (LogFloat -> Double) -> LogFloat -> Value 'HReal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogFloat -> Double
LF.logFromLogFloat (LogFloat -> Value 'HReal) -> LogFloat -> Value 'HReal
forall a b. (a -> b) -> a -> b
$ LogFloat
v1

evaluatePrimOp (Infinity HIntegrable a
h) SArgs abt args
End Env
_ =
    case HIntegrable a
h of
      HIntegrable a
HIntegrable_Nat  -> [Char] -> Value a
forall a. HasCallStack => [Char] -> a
error [Char]
"Can not evaluate infinity for natural numbers"
      HIntegrable a
HIntegrable_Prob -> LogFloat -> Value 'HProb
VProb (LogFloat -> Value 'HProb) -> LogFloat -> Value 'HProb
forall a b. (a -> b) -> a -> b
$ Double -> LogFloat
LF.logFloat Double
forall a. Transfinite a => a
LF.infinity

evaluatePrimOp (Equal HEq a
_) (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) Env
env = (Datum Value ('HData ('TyCon "Bool") '[ '[], '[]]) -> Value a
forall (t :: HakaruCon). Datum Value (HData' t) -> Value (HData' t)
VDatum (Datum Value ('HData ('TyCon "Bool") '[ '[], '[]]) -> Value a)
-> (Bool -> Datum Value ('HData ('TyCon "Bool") '[ '[], '[]]))
-> Bool
-> Value a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Datum Value ('HData ('TyCon "Bool") '[ '[], '[]])
forall (ast :: Hakaru -> *).
Bool -> Datum ast ('HData ('TyCon "Bool") '[ '[], '[]])
dBool) (Bool -> Value a) -> Bool -> Value a
forall a b. (a -> b) -> a -> b
$ abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env Value a -> Value a -> Bool
forall a. Eq a => a -> a -> Bool
== abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e2 Env
env

evaluatePrimOp (Less HOrd a
_) (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) Env
env =
    case (abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env, abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e2 Env
env) of
    (VNat  Natural
v1, VNat  Natural
v2) -> Datum Value (HData' ('TyCon "Bool"))
-> Value (HData' ('TyCon "Bool"))
forall (t :: HakaruCon). Datum Value (HData' t) -> Value (HData' t)
VDatum (Datum Value (HData' ('TyCon "Bool"))
 -> Value (HData' ('TyCon "Bool")))
-> Datum Value (HData' ('TyCon "Bool"))
-> Value (HData' ('TyCon "Bool"))
forall a b. (a -> b) -> a -> b
$ if Natural
v1 Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< Natural
v2 then Datum Value (HData' ('TyCon "Bool"))
forall (ast :: Hakaru -> *).
Datum ast ('HData ('TyCon "Bool") '[ '[], '[]])
dTrue else Datum Value (HData' ('TyCon "Bool"))
forall (ast :: Hakaru -> *).
Datum ast ('HData ('TyCon "Bool") '[ '[], '[]])
dFalse
    (VInt  Integer
v1, VInt  Integer
v2) -> Datum Value (HData' ('TyCon "Bool"))
-> Value (HData' ('TyCon "Bool"))
forall (t :: HakaruCon). Datum Value (HData' t) -> Value (HData' t)
VDatum (Datum Value (HData' ('TyCon "Bool"))
 -> Value (HData' ('TyCon "Bool")))
-> Datum Value (HData' ('TyCon "Bool"))
-> Value (HData' ('TyCon "Bool"))
forall a b. (a -> b) -> a -> b
$ if Integer
v1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
v2 then Datum Value (HData' ('TyCon "Bool"))
forall (ast :: Hakaru -> *).
Datum ast ('HData ('TyCon "Bool") '[ '[], '[]])
dTrue else Datum Value (HData' ('TyCon "Bool"))
forall (ast :: Hakaru -> *).
Datum ast ('HData ('TyCon "Bool") '[ '[], '[]])
dFalse
    (VProb LogFloat
v1, VProb LogFloat
v2) -> Datum Value (HData' ('TyCon "Bool"))
-> Value (HData' ('TyCon "Bool"))
forall (t :: HakaruCon). Datum Value (HData' t) -> Value (HData' t)
VDatum (Datum Value (HData' ('TyCon "Bool"))
 -> Value (HData' ('TyCon "Bool")))
-> Datum Value (HData' ('TyCon "Bool"))
-> Value (HData' ('TyCon "Bool"))
forall a b. (a -> b) -> a -> b
$ if LogFloat
v1 LogFloat -> LogFloat -> Bool
forall a. Ord a => a -> a -> Bool
< LogFloat
v2 then Datum Value (HData' ('TyCon "Bool"))
forall (ast :: Hakaru -> *).
Datum ast ('HData ('TyCon "Bool") '[ '[], '[]])
dTrue else Datum Value (HData' ('TyCon "Bool"))
forall (ast :: Hakaru -> *).
Datum ast ('HData ('TyCon "Bool") '[ '[], '[]])
dFalse
    (VReal Double
v1, VReal Double
v2) -> Datum Value (HData' ('TyCon "Bool"))
-> Value (HData' ('TyCon "Bool"))
forall (t :: HakaruCon). Datum Value (HData' t) -> Value (HData' t)
VDatum (Datum Value (HData' ('TyCon "Bool"))
 -> Value (HData' ('TyCon "Bool")))
-> Datum Value (HData' ('TyCon "Bool"))
-> Value (HData' ('TyCon "Bool"))
forall a b. (a -> b) -> a -> b
$ if Double
v1 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
v2 then Datum Value (HData' ('TyCon "Bool"))
forall (ast :: Hakaru -> *).
Datum ast ('HData ('TyCon "Bool") '[ '[], '[]])
dTrue else Datum Value (HData' ('TyCon "Bool"))
forall (ast :: Hakaru -> *).
Datum ast ('HData ('TyCon "Bool") '[ '[], '[]])
dFalse
    (Value a, Value a)
_                    -> [Char] -> Value a
forall a. HasCallStack => [Char] -> a
error [Char]
"TODO: evaluatePrimOp{Less}"
evaluatePrimOp (NatPow HSemiring a
_) (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) Env
env = 
    case abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e2 Env
env of
    VNat  Natural
v2 ->
        let v2' :: Integer
v2' = Natural -> Integer
fromNatural Natural
v2 in
        case abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env of
          VNat  Natural
v1 -> Natural -> Value 'HNat
VNat  (Natural
v1 Natural -> Integer -> Natural
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
v2')
          VInt  Integer
v1 -> Integer -> Value 'HInt
VInt  (Integer
v1 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
v2')
          VProb LogFloat
v1 -> LogFloat -> Value 'HProb
VProb (LogFloat
v1 LogFloat -> Integer -> LogFloat
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
v2')
          VReal Double
v1 -> Double -> Value 'HReal
VReal (Double
v1 Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
v2')
          Value a
_        -> [Char] -> Value a
forall a. HasCallStack => [Char] -> a
error [Char]
"NatPow should always return some kind of number"
evaluatePrimOp (Negate HRing a
_) (abt vars a
e1 :* SArgs abt args
End) Env
env = 
    case abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env of
    VInt  Integer
v -> Integer -> Value 'HInt
VInt  (Integer -> Integer
forall a. Num a => a -> a
negate Integer
v)
    VReal Double
v -> Double -> Value 'HReal
VReal (Double -> Double
forall a. Num a => a -> a
negate Double
v)
    Value a
v       -> case Value a
v of {}
evaluatePrimOp (Abs   HRing a
_) (abt vars a
e1 :* SArgs abt args
End) Env
env =
    case abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env of
    VInt  Integer
v -> Natural -> Value 'HNat
VNat  (Natural -> Value 'HNat)
-> (Integer -> Natural) -> Integer -> Value 'HNat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Natural
unsafeNatural   (Integer -> Value 'HNat) -> Integer -> Value 'HNat
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Num a => a -> a
abs Integer
v
    VReal Double
v -> LogFloat -> Value 'HProb
VProb (LogFloat -> Value 'HProb)
-> (Double -> LogFloat) -> Double -> Value 'HProb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> LogFloat
LF.logFloat (Double -> Value 'HProb) -> Double -> Value 'HProb
forall a b. (a -> b) -> a -> b
$ Double -> Double
forall a. Num a => a -> a
abs Double
v
    Value a
v       -> case Value a
v of {}
evaluatePrimOp (Recip HFractional a
_) (abt vars a
e1 :* SArgs abt args
End) Env
env = 
    case abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env of
    VProb LogFloat
v -> LogFloat -> Value 'HProb
VProb (LogFloat -> LogFloat
forall a. Fractional a => a -> a
recip LogFloat
v)
    VReal Double
v -> Double -> Value 'HReal
VReal (Double -> Double
forall a. Fractional a => a -> a
recip Double
v)
    Value a
v       -> case Value a
v of {}
evaluatePrimOp (NatRoot HRadical a
_) (abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) Env
env =
    case (abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env, abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e2 Env
env) of
    (VProb LogFloat
v1, VNat Natural
v2) -> LogFloat -> Value 'HProb
VProb (LogFloat -> Value 'HProb) -> LogFloat -> Value 'HProb
forall a b. (a -> b) -> a -> b
$ LogFloat -> Double -> LogFloat
LF.pow LogFloat
v1 (Double -> Double
forall a. Fractional a => a -> a
recip (Double -> Double) -> (Natural -> Double) -> Natural -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Double) -> Natural -> Double
forall a b. (a -> b) -> a -> b
$ Natural
v2)
    (Value a, Value a)
v                   -> case (Value a, Value a)
v of {}    

evaluatePrimOp (PrimOp typs a
Floor) (abt vars a
e1 :* SArgs abt args
End) Env
env =
    case (abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env) of
    VProb LogFloat
v1 -> Natural -> Value 'HNat
VNat (Double -> Natural
forall a b. (RealFrac a, Integral b) => a -> b
floor (LogFloat -> Double
LF.fromLogFloat LogFloat
v1))

evaluatePrimOp PrimOp typs a
prim SArgs abt args
_ Env
_ =
    [Char] -> Value a
forall a. HasCallStack => [Char] -> a
error ([Char]
"TODO: evaluatePrimOp{" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PrimOp typs a -> [Char]
forall a. Show a => a -> [Char]
show PrimOp typs a
prim [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"}")

evaluateArrayOp
    :: ( ABT Term abt
       , typs ~ UnLCs args
       , args ~ LCs typs)
    => ArrayOp typs a
    -> SArgs abt args
    -> Env
    -> Value a
evaluateArrayOp :: ArrayOp typs a -> SArgs abt args -> Env -> Value a
evaluateArrayOp (Index Sing a
_) = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) Env
env ->
    case (abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env, abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e2 Env
env) of
    (VArray Vector (Value a)
v, VNat Natural
n) -> Vector (Value a)
v Vector (Value a) -> Key -> Value a
forall a. Vector a -> Key -> a
V.! Natural -> Key
unsafeInt Natural
n

evaluateArrayOp (Size Sing a
_) = \(abt vars a
e1 :* SArgs abt args
End) Env
env ->
    case abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env of
    VArray Vector (Value a)
v -> Natural -> Value 'HNat
VNat (Natural -> Value 'HNat) -> (Key -> Natural) -> Key -> Value 'HNat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Natural
intToNatural (Key -> Value 'HNat) -> Key -> Value 'HNat
forall a b. (a -> b) -> a -> b
$ Vector (Value a) -> Key
forall a. Vector a -> Key
V.length Vector (Value a)
v

evaluateArrayOp (Reduce Sing a
_) = \(abt vars a
e1 :* abt vars a
e2 :* abt vars a
e3 :* SArgs abt args
End) Env
env ->
    case ( abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env
         , abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e2 Env
env
         , abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e3 Env
env) of
    (Value a
f, Value a
a, VArray Vector (Value a)
v) -> (Value a -> Value a -> Value a)
-> Value a -> Vector (Value a) -> Value a
forall a b. (a -> b -> a) -> a -> Vector b -> a
V.foldl' (Value (a ':-> (a ':-> a)) -> Value a -> Value a -> Value a
forall (a :: Hakaru) (b :: Hakaru) (c :: Hakaru).
Value (a ':-> (b ':-> c)) -> Value a -> Value b -> Value c
lam2 Value a
Value (a ':-> (a ':-> a))
f) Value a
a Vector (Value a)
v

evaluateMeasureOp
    :: ( ABT Term abt
       , typs ~ UnLCs args
       , args ~ LCs typs)
    => MeasureOp typs a
    -> SArgs abt args
    -> Env
    -> Value ('HMeasure a)

evaluateMeasureOp :: MeasureOp typs a -> SArgs abt args -> Env -> Value ('HMeasure a)
evaluateMeasureOp MeasureOp typs a
Lebesgue = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) Env
env ->
  case (abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env, abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e2 Env
env) of
    (VReal Double
v1, VReal Double
v2) | Double
v1 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
v2 ->
      (Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb)))
-> Value ('HMeasure a)
forall (b :: Hakaru).
(Value 'HProb -> GenIO -> IO (Maybe (Value b, Value 'HProb)))
-> Value ('HMeasure b)
VMeasure ((Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb)))
 -> Value ('HMeasure a))
-> (Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb)))
-> Value ('HMeasure a)
forall a b. (a -> b) -> a -> b
$ \(VProb LogFloat
p) GenIO
g ->
        case (Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
v1, Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
v2) of
          (Bool
False, Bool
False) -> do
            Double
x <- (Double, Double) -> GenIO -> IO Double
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
(a, a) -> Gen (PrimState m) -> m a
MWC.uniformR (Double
v1, Double
v2) GenIO
g
            Maybe (Value 'HReal, Value 'HProb)
-> IO (Maybe (Value 'HReal, Value 'HProb))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Value 'HReal, Value 'HProb)
 -> IO (Maybe (Value 'HReal, Value 'HProb)))
-> Maybe (Value 'HReal, Value 'HProb)
-> IO (Maybe (Value 'HReal, Value 'HProb))
forall a b. (a -> b) -> a -> b
$ (Value 'HReal, Value 'HProb) -> Maybe (Value 'HReal, Value 'HProb)
forall a. a -> Maybe a
Just (Double -> Value 'HReal
VReal (Double -> Value 'HReal) -> Double -> Value 'HReal
forall a b. (a -> b) -> a -> b
$ Double
x,
                           LogFloat -> Value 'HProb
VProb (LogFloat -> Value 'HProb) -> LogFloat -> Value 'HProb
forall a b. (a -> b) -> a -> b
$ LogFloat
p LogFloat -> LogFloat -> LogFloat
forall a. Num a => a -> a -> a
* Double -> LogFloat
LF.logFloat (Double
v2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
v1))
          (Bool
False, Bool
True) -> do
            Double
u <- GenIO -> IO Double
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
Gen (PrimState m) -> m a
MWC.uniform GenIO
g
            let l :: Double
l = Double -> Double
forall a. Floating a => a -> a
log Double
u
            let n :: Double
n = -Double
l
            Maybe (Value 'HReal, Value 'HProb)
-> IO (Maybe (Value 'HReal, Value 'HProb))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Value 'HReal, Value 'HProb)
 -> IO (Maybe (Value 'HReal, Value 'HProb)))
-> Maybe (Value 'HReal, Value 'HProb)
-> IO (Maybe (Value 'HReal, Value 'HProb))
forall a b. (a -> b) -> a -> b
$ (Value 'HReal, Value 'HProb) -> Maybe (Value 'HReal, Value 'HProb)
forall a. a -> Maybe a
Just (Double -> Value 'HReal
VReal (Double -> Value 'HReal) -> Double -> Value 'HReal
forall a b. (a -> b) -> a -> b
$ Double
v1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
n,
                           LogFloat -> Value 'HProb
VProb (LogFloat -> Value 'HProb) -> LogFloat -> Value 'HProb
forall a b. (a -> b) -> a -> b
$ LogFloat
p LogFloat -> LogFloat -> LogFloat
forall a. Num a => a -> a -> a
* Double -> LogFloat
LF.logToLogFloat Double
n)
          (Bool
True, Bool
False) -> do
            Double
u <- GenIO -> IO Double
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
Gen (PrimState m) -> m a
MWC.uniform GenIO
g
            let l :: Double
l = Double -> Double
forall a. Floating a => a -> a
log Double
u
            let n :: Double
n = -Double
l
            Maybe (Value 'HReal, Value 'HProb)
-> IO (Maybe (Value 'HReal, Value 'HProb))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Value 'HReal, Value 'HProb)
 -> IO (Maybe (Value 'HReal, Value 'HProb)))
-> Maybe (Value 'HReal, Value 'HProb)
-> IO (Maybe (Value 'HReal, Value 'HProb))
forall a b. (a -> b) -> a -> b
$ (Value 'HReal, Value 'HProb) -> Maybe (Value 'HReal, Value 'HProb)
forall a. a -> Maybe a
Just (Double -> Value 'HReal
VReal (Double -> Value 'HReal) -> Double -> Value 'HReal
forall a b. (a -> b) -> a -> b
$ Double
v2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
n,
                           LogFloat -> Value 'HProb
VProb (LogFloat -> Value 'HProb) -> LogFloat -> Value 'HProb
forall a b. (a -> b) -> a -> b
$ LogFloat
p LogFloat -> LogFloat -> LogFloat
forall a. Num a => a -> a -> a
* Double -> LogFloat
LF.logToLogFloat Double
n)
          (Bool
True, Bool
True) -> do
            (Double
u,Bool
b) <- GenIO -> IO (Double, Bool)
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
Gen (PrimState m) -> m a
MWC.uniform GenIO
g
            let l :: Double
l = Double -> Double
forall a. Floating a => a -> a
log Double
u
            let n :: Double
n = -Double
l
            Maybe (Value 'HReal, Value 'HProb)
-> IO (Maybe (Value 'HReal, Value 'HProb))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Value 'HReal, Value 'HProb)
 -> IO (Maybe (Value 'HReal, Value 'HProb)))
-> Maybe (Value 'HReal, Value 'HProb)
-> IO (Maybe (Value 'HReal, Value 'HProb))
forall a b. (a -> b) -> a -> b
$ (Value 'HReal, Value 'HProb) -> Maybe (Value 'HReal, Value 'HProb)
forall a. a -> Maybe a
Just (Double -> Value 'HReal
VReal (Double -> Value 'HReal) -> Double -> Value 'HReal
forall a b. (a -> b) -> a -> b
$ if Bool
b then Double
n else Double
l,
                           LogFloat -> Value 'HProb
VProb (LogFloat -> Value 'HProb) -> LogFloat -> Value 'HProb
forall a b. (a -> b) -> a -> b
$ LogFloat
p LogFloat -> LogFloat -> LogFloat
forall a. Num a => a -> a -> a
* LogFloat
2 LogFloat -> LogFloat -> LogFloat
forall a. Num a => a -> a -> a
* Double -> LogFloat
LF.logToLogFloat Double
n)
    (VReal Double
_, VReal Double
_) -> [Char] -> Value ('HMeasure a)
forall a. HasCallStack => [Char] -> a
error [Char]
"Lebesgue with length 0 or flipped endpoints"

evaluateMeasureOp MeasureOp typs a
Counting = \SArgs abt args
End Env
_ ->
    (Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb)))
-> Value ('HMeasure a)
forall (b :: Hakaru).
(Value 'HProb -> GenIO -> IO (Maybe (Value b, Value 'HProb)))
-> Value ('HMeasure b)
VMeasure ((Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb)))
 -> Value ('HMeasure a))
-> (Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb)))
-> Value ('HMeasure a)
forall a b. (a -> b) -> a -> b
$ \(VProb LogFloat
p) GenIO
g -> do
        let success :: LogFloat
success = Double -> LogFloat
LF.logToLogFloat (-Double
3 :: Double)
        let pow :: LogFloat -> a -> LogFloat
pow LogFloat
x a
y = Double -> LogFloat
LF.logToLogFloat (LogFloat -> Double
LF.logFromLogFloat LogFloat
x Double -> Double -> Double
forall a. Num a => a -> a -> a
*
                                       (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
y :: Double))
        Key
u' <- Double -> GenIO -> IO Key
forall (m :: * -> *).
PrimMonad m =>
Double -> Gen (PrimState m) -> m Key
MWCD.geometric0 (LogFloat -> Double
LF.fromLogFloat LogFloat
success) GenIO
g
        let u :: Integer
u = Key -> Integer
forall a. Integral a => a -> Integer
toInteger Key
u'
        Bool
b <- GenIO -> IO Bool
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
Gen (PrimState m) -> m a
MWC.uniform GenIO
g
        Maybe (Value 'HInt, Value 'HProb)
-> IO (Maybe (Value 'HInt, Value 'HProb))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Value 'HInt, Value 'HProb)
 -> IO (Maybe (Value 'HInt, Value 'HProb)))
-> Maybe (Value 'HInt, Value 'HProb)
-> IO (Maybe (Value 'HInt, Value 'HProb))
forall a b. (a -> b) -> a -> b
$ (Value 'HInt, Value 'HProb) -> Maybe (Value 'HInt, Value 'HProb)
forall a. a -> Maybe a
Just
            ( Integer -> Value 'HInt
VInt  (Integer -> Value 'HInt) -> Integer -> Value 'HInt
forall a b. (a -> b) -> a -> b
$ if Bool
b then -Integer
1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
u else Integer
u
            , LogFloat -> Value 'HProb
VProb (LogFloat -> Value 'HProb) -> LogFloat -> Value 'HProb
forall a b. (a -> b) -> a -> b
$ LogFloat
p LogFloat -> LogFloat -> LogFloat
forall a. Num a => a -> a -> a
* LogFloat
2 LogFloat -> LogFloat -> LogFloat
forall a. Fractional a => a -> a -> a
/ LogFloat -> Integer -> LogFloat
forall a. Integral a => LogFloat -> a -> LogFloat
pow (LogFloat
1LogFloat -> LogFloat -> LogFloat
forall a. Num a => a -> a -> a
-LogFloat
success) Integer
u LogFloat -> LogFloat -> LogFloat
forall a. Fractional a => a -> a -> a
/ LogFloat
success)

evaluateMeasureOp MeasureOp typs a
Categorical = \(abt vars a
e1 :* SArgs abt args
End) Env
env ->
    (Value 'HProb -> GenIO -> IO (Maybe (Value 'HNat, Value 'HProb)))
-> Value ('HMeasure 'HNat)
forall (b :: Hakaru).
(Value 'HProb -> GenIO -> IO (Maybe (Value b, Value 'HProb)))
-> Value ('HMeasure b)
VMeasure ((Value 'HProb -> GenIO -> IO (Maybe (Value 'HNat, Value 'HProb)))
 -> Value ('HMeasure 'HNat))
-> (Value 'HProb
    -> GenIO -> IO (Maybe (Value 'HNat, Value 'HProb)))
-> Value ('HMeasure 'HNat)
forall a b. (a -> b) -> a -> b
$ \Value 'HProb
p GenIO
g -> do
        let (LogFloat
_,Double
y,Vector Double
ys) = Value ('HArray 'HProb) -> (LogFloat, Double, Vector Double)
normalizeVector (abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env)
        if Bool -> Bool
not (Double
y Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> (Double
0::Double)) -- TODO: why not use @y <= 0@ ??
        then [Char] -> IO (Maybe (Value 'HNat, Value 'HProb))
forall a. HasCallStack => [Char] -> a
error [Char]
"Categorical needs positive weights"
        else do
            Double
u <- (Double, Double) -> GenIO -> IO Double
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
(a, a) -> Gen (PrimState m) -> m a
MWC.uniformR (Double
0, Double
y) GenIO
g
            Maybe (Value 'HNat, Value 'HProb)
-> IO (Maybe (Value 'HNat, Value 'HProb))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Value 'HNat, Value 'HProb)
 -> IO (Maybe (Value 'HNat, Value 'HProb)))
-> Maybe (Value 'HNat, Value 'HProb)
-> IO (Maybe (Value 'HNat, Value 'HProb))
forall a b. (a -> b) -> a -> b
$ (Value 'HNat, Value 'HProb) -> Maybe (Value 'HNat, Value 'HProb)
forall a. a -> Maybe a
Just
                ( Natural -> Value 'HNat
VNat
                (Natural -> Value 'HNat)
-> (Vector Double -> Natural) -> Vector Double -> Value 'HNat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Natural
intToNatural
                (Key -> Natural)
-> (Vector Double -> Key) -> Vector Double -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Maybe Key -> Key
forall a. a -> Maybe a -> a
fromMaybe Key
0
                (Maybe Key -> Key)
-> (Vector Double -> Maybe Key) -> Vector Double -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Bool) -> Vector Double -> Maybe Key
forall a. (a -> Bool) -> Vector a -> Maybe Key
V.findIndex (Double
u Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<=) 
                (Vector Double -> Maybe Key)
-> (Vector Double -> Vector Double) -> Vector Double -> Maybe Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double) -> Vector Double -> Vector Double
forall a. (a -> a -> a) -> Vector a -> Vector a
V.scanl1' Double -> Double -> Double
forall a. Num a => a -> a -> a
(+)
                (Vector Double -> Value 'HNat) -> Vector Double -> Value 'HNat
forall a b. (a -> b) -> a -> b
$ Vector Double
ys
                , Value 'HProb
p)

evaluateMeasureOp MeasureOp typs a
Uniform = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) Env
env ->
    case (abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env, abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e2 Env
env) of
    (VReal Double
v1, VReal Double
v2) -> (Value 'HProb -> GenIO -> IO (Maybe (Value 'HReal, Value 'HProb)))
-> Value ('HMeasure 'HReal)
forall (b :: Hakaru).
(Value 'HProb -> GenIO -> IO (Maybe (Value b, Value 'HProb)))
-> Value ('HMeasure b)
VMeasure ((Value 'HProb -> GenIO -> IO (Maybe (Value 'HReal, Value 'HProb)))
 -> Value ('HMeasure 'HReal))
-> (Value 'HProb
    -> GenIO -> IO (Maybe (Value 'HReal, Value 'HProb)))
-> Value ('HMeasure 'HReal)
forall a b. (a -> b) -> a -> b
$ \Value 'HProb
p GenIO
g -> do
        Double
x <- (Double, Double) -> GenIO -> IO Double
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
(a, a) -> Gen (PrimState m) -> m a
MWC.uniformR (Double
v1, Double
v2) GenIO
g
        Maybe (Value 'HReal, Value 'HProb)
-> IO (Maybe (Value 'HReal, Value 'HProb))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Value 'HReal, Value 'HProb)
 -> IO (Maybe (Value 'HReal, Value 'HProb)))
-> Maybe (Value 'HReal, Value 'HProb)
-> IO (Maybe (Value 'HReal, Value 'HProb))
forall a b. (a -> b) -> a -> b
$ (Value 'HReal, Value 'HProb) -> Maybe (Value 'HReal, Value 'HProb)
forall a. a -> Maybe a
Just (Double -> Value 'HReal
VReal Double
x, Value 'HProb
p)

evaluateMeasureOp MeasureOp typs a
Normal = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) Env
env ->
    case (abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env, abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e2 Env
env) of 
    (VReal Double
v1, VProb LogFloat
v2) -> (Value 'HProb -> GenIO -> IO (Maybe (Value 'HReal, Value 'HProb)))
-> Value ('HMeasure 'HReal)
forall (b :: Hakaru).
(Value 'HProb -> GenIO -> IO (Maybe (Value b, Value 'HProb)))
-> Value ('HMeasure b)
VMeasure ((Value 'HProb -> GenIO -> IO (Maybe (Value 'HReal, Value 'HProb)))
 -> Value ('HMeasure 'HReal))
-> (Value 'HProb
    -> GenIO -> IO (Maybe (Value 'HReal, Value 'HProb)))
-> Value ('HMeasure 'HReal)
forall a b. (a -> b) -> a -> b
$ \ Value 'HProb
p GenIO
g -> do
        Double
x <- Double -> Double -> GenIO -> IO Double
forall (m :: * -> *).
PrimMonad m =>
Double -> Double -> Gen (PrimState m) -> m Double
MWCD.normal Double
v1 (LogFloat -> Double
LF.fromLogFloat LogFloat
v2) GenIO
g
        Maybe (Value 'HReal, Value 'HProb)
-> IO (Maybe (Value 'HReal, Value 'HProb))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Value 'HReal, Value 'HProb)
 -> IO (Maybe (Value 'HReal, Value 'HProb)))
-> Maybe (Value 'HReal, Value 'HProb)
-> IO (Maybe (Value 'HReal, Value 'HProb))
forall a b. (a -> b) -> a -> b
$ (Value 'HReal, Value 'HProb) -> Maybe (Value 'HReal, Value 'HProb)
forall a. a -> Maybe a
Just (Double -> Value 'HReal
VReal Double
x, Value 'HProb
p)

evaluateMeasureOp MeasureOp typs a
Poisson = \(abt vars a
e1 :* SArgs abt args
End) Env
env ->
    case abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env of
    VProb LogFloat
v1 -> (Value 'HProb -> GenIO -> IO (Maybe (Value 'HNat, Value 'HProb)))
-> Value ('HMeasure 'HNat)
forall (b :: Hakaru).
(Value 'HProb -> GenIO -> IO (Maybe (Value b, Value 'HProb)))
-> Value ('HMeasure b)
VMeasure ((Value 'HProb -> GenIO -> IO (Maybe (Value 'HNat, Value 'HProb)))
 -> Value ('HMeasure 'HNat))
-> (Value 'HProb
    -> GenIO -> IO (Maybe (Value 'HNat, Value 'HProb)))
-> Value ('HMeasure 'HNat)
forall a b. (a -> b) -> a -> b
$ \ Value 'HProb
p GenIO
g -> do
        Key
x <- CondensedTable Vector Key -> GenIO -> IO Key
forall (m :: * -> *) (v :: * -> *) a.
(PrimMonad m, Vector v a) =>
CondensedTable v a -> Gen (PrimState m) -> m a
MWC.genFromTable (Double -> CondensedTable Vector Key
MWC.tablePoisson (LogFloat -> Double
LF.fromLogFloat LogFloat
v1)) GenIO
g
        Maybe (Value 'HNat, Value 'HProb)
-> IO (Maybe (Value 'HNat, Value 'HProb))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Value 'HNat, Value 'HProb)
 -> IO (Maybe (Value 'HNat, Value 'HProb)))
-> Maybe (Value 'HNat, Value 'HProb)
-> IO (Maybe (Value 'HNat, Value 'HProb))
forall a b. (a -> b) -> a -> b
$ (Value 'HNat, Value 'HProb) -> Maybe (Value 'HNat, Value 'HProb)
forall a. a -> Maybe a
Just (Natural -> Value 'HNat
VNat (Natural -> Value 'HNat) -> Natural -> Value 'HNat
forall a b. (a -> b) -> a -> b
$ Key -> Natural
intToNatural Key
x, Value 'HProb
p)

evaluateMeasureOp MeasureOp typs a
Gamma = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) Env
env ->
    case (abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env, abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e2 Env
env) of 
    (VProb LogFloat
v1, VProb LogFloat
v2) -> (Value 'HProb -> GenIO -> IO (Maybe (Value 'HProb, Value 'HProb)))
-> Value ('HMeasure 'HProb)
forall (b :: Hakaru).
(Value 'HProb -> GenIO -> IO (Maybe (Value b, Value 'HProb)))
-> Value ('HMeasure b)
VMeasure ((Value 'HProb -> GenIO -> IO (Maybe (Value 'HProb, Value 'HProb)))
 -> Value ('HMeasure 'HProb))
-> (Value 'HProb
    -> GenIO -> IO (Maybe (Value 'HProb, Value 'HProb)))
-> Value ('HMeasure 'HProb)
forall a b. (a -> b) -> a -> b
$ \ Value 'HProb
p GenIO
g -> do
        Double
x <- Double -> Double -> GenIO -> IO Double
forall (m :: * -> *).
PrimMonad m =>
Double -> Double -> Gen (PrimState m) -> m Double
MWCD.gamma (LogFloat -> Double
LF.fromLogFloat LogFloat
v1) (LogFloat -> Double
LF.fromLogFloat LogFloat
v2) GenIO
g
        Maybe (Value 'HProb, Value 'HProb)
-> IO (Maybe (Value 'HProb, Value 'HProb))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Value 'HProb, Value 'HProb)
 -> IO (Maybe (Value 'HProb, Value 'HProb)))
-> Maybe (Value 'HProb, Value 'HProb)
-> IO (Maybe (Value 'HProb, Value 'HProb))
forall a b. (a -> b) -> a -> b
$ (Value 'HProb, Value 'HProb) -> Maybe (Value 'HProb, Value 'HProb)
forall a. a -> Maybe a
Just (LogFloat -> Value 'HProb
VProb (LogFloat -> Value 'HProb) -> LogFloat -> Value 'HProb
forall a b. (a -> b) -> a -> b
$ Double -> LogFloat
LF.logFloat Double
x, Value 'HProb
p)

evaluateMeasureOp MeasureOp typs a
Beta = \(abt vars a
e1 :* abt vars a
e2 :* SArgs abt args
End) Env
env ->
    case (abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e1 Env
env, abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt vars a
abt '[] a
e2 Env
env) of 
    (VProb LogFloat
v1, VProb LogFloat
v2) -> (Value 'HProb -> GenIO -> IO (Maybe (Value 'HProb, Value 'HProb)))
-> Value ('HMeasure 'HProb)
forall (b :: Hakaru).
(Value 'HProb -> GenIO -> IO (Maybe (Value b, Value 'HProb)))
-> Value ('HMeasure b)
VMeasure ((Value 'HProb -> GenIO -> IO (Maybe (Value 'HProb, Value 'HProb)))
 -> Value ('HMeasure 'HProb))
-> (Value 'HProb
    -> GenIO -> IO (Maybe (Value 'HProb, Value 'HProb)))
-> Value ('HMeasure 'HProb)
forall a b. (a -> b) -> a -> b
$ \ Value 'HProb
p GenIO
g -> do
        Double
x <- Double -> Double -> GenIO -> IO Double
forall (m :: * -> *).
PrimMonad m =>
Double -> Double -> Gen (PrimState m) -> m Double
MWCD.beta (LogFloat -> Double
LF.fromLogFloat LogFloat
v1) (LogFloat -> Double
LF.fromLogFloat LogFloat
v2) GenIO
g
        Maybe (Value 'HProb, Value 'HProb)
-> IO (Maybe (Value 'HProb, Value 'HProb))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Value 'HProb, Value 'HProb)
 -> IO (Maybe (Value 'HProb, Value 'HProb)))
-> Maybe (Value 'HProb, Value 'HProb)
-> IO (Maybe (Value 'HProb, Value 'HProb))
forall a b. (a -> b) -> a -> b
$ (Value 'HProb, Value 'HProb) -> Maybe (Value 'HProb, Value 'HProb)
forall a. a -> Maybe a
Just (LogFloat -> Value 'HProb
VProb (LogFloat -> Value 'HProb) -> LogFloat -> Value 'HProb
forall a b. (a -> b) -> a -> b
$ Double -> LogFloat
LF.logFloat Double
x, Value 'HProb
p)

evaluateNaryOp
    :: (ABT Term abt)
    => NaryOp a -> Seq (abt '[] a) -> Env -> Value a
evaluateNaryOp :: NaryOp a -> Seq (abt '[] a) -> Env -> Value a
evaluateNaryOp NaryOp a
s Seq (abt '[] a)
es =
    (Value a -> Value a -> Value a)
-> Value a -> Seq (Value a) -> Value a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr (NaryOp a -> Value a -> Value a -> Value a
forall (a :: Hakaru). NaryOp a -> Value a -> Value a -> Value a
evalOp NaryOp a
s) (NaryOp a -> Value a
forall (a :: Hakaru). NaryOp a -> Value a
identityElement NaryOp a
s) (Seq (Value a) -> Value a)
-> (Env -> Seq (Value a)) -> Env -> Value a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq (abt '[] a) -> Env -> Seq (Value a)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Seq (abt '[] a) -> Env -> Seq (Value a)
mapEvaluate Seq (abt '[] a)
es

identityElement :: NaryOp a -> Value a
identityElement :: NaryOp a -> Value a
identityElement NaryOp a
And                   = Datum Value (HData' ('TyCon "Bool"))
-> Value (HData' ('TyCon "Bool"))
forall (t :: HakaruCon). Datum Value (HData' t) -> Value (HData' t)
VDatum Datum Value (HData' ('TyCon "Bool"))
forall (ast :: Hakaru -> *).
Datum ast ('HData ('TyCon "Bool") '[ '[], '[]])
dTrue
identityElement (Sum HSemiring a
HSemiring_Nat)   = Natural -> Value 'HNat
VNat  Natural
0
identityElement (Sum HSemiring a
HSemiring_Int)   = Integer -> Value 'HInt
VInt  Integer
0
identityElement (Sum HSemiring a
HSemiring_Prob)  = LogFloat -> Value 'HProb
VProb LogFloat
0
identityElement (Sum HSemiring a
HSemiring_Real)  = Double -> Value 'HReal
VReal Double
0
identityElement (Prod HSemiring a
HSemiring_Nat)  = Natural -> Value 'HNat
VNat  Natural
1
identityElement (Prod HSemiring a
HSemiring_Int)  = Integer -> Value 'HInt
VInt  Integer
1
identityElement (Prod HSemiring a
HSemiring_Prob) = LogFloat -> Value 'HProb
VProb LogFloat
1
identityElement (Prod HSemiring a
HSemiring_Real) = Double -> Value 'HReal
VReal Double
1
identityElement (Max  HOrd a
HOrd_Prob)      = LogFloat -> Value 'HProb
VProb LogFloat
0
identityElement (Max  HOrd a
HOrd_Real)      = Double -> Value 'HReal
VReal Double
forall a. Transfinite a => a
LF.negativeInfinity
identityElement (Min  HOrd a
HOrd_Prob)      = LogFloat -> Value 'HProb
VProb (Double -> LogFloat
LF.logFloat Double
forall a. Transfinite a => a
LF.infinity)
identityElement (Min  HOrd a
HOrd_Real)      = Double -> Value 'HReal
VReal Double
forall a. Transfinite a => a
LF.infinity
identityElement NaryOp a
_                     = [Char] -> Value a
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing identity elements?"


evalOp
    :: NaryOp a -> Value a -> Value a -> Value a
evalOp :: NaryOp a -> Value a -> Value a -> Value a
evalOp NaryOp a
And (VDatum Datum Value (HData' t)
a) (VDatum Datum Value (HData' t)
b)        
    | Datum Value (HData' t)
Datum Value ('HData ('TyCon "Bool") '[ '[], '[]])
a Datum Value ('HData ('TyCon "Bool") '[ '[], '[]])
-> Datum Value ('HData ('TyCon "Bool") '[ '[], '[]]) -> Bool
forall a. Eq a => a -> a -> Bool
== Datum Value ('HData ('TyCon "Bool") '[ '[], '[]])
forall (ast :: Hakaru -> *).
Datum ast ('HData ('TyCon "Bool") '[ '[], '[]])
dTrue Bool -> Bool -> Bool
&& Datum Value (HData' t)
Datum Value ('HData ('TyCon "Bool") '[ '[], '[]])
b Datum Value ('HData ('TyCon "Bool") '[ '[], '[]])
-> Datum Value ('HData ('TyCon "Bool") '[ '[], '[]]) -> Bool
forall a. Eq a => a -> a -> Bool
== Datum Value ('HData ('TyCon "Bool") '[ '[], '[]])
forall (ast :: Hakaru -> *).
Datum ast ('HData ('TyCon "Bool") '[ '[], '[]])
dTrue = Datum Value (HData' ('TyCon "Bool"))
-> Value (HData' ('TyCon "Bool"))
forall (t :: HakaruCon). Datum Value (HData' t) -> Value (HData' t)
VDatum Datum Value (HData' ('TyCon "Bool"))
forall (ast :: Hakaru -> *).
Datum ast ('HData ('TyCon "Bool") '[ '[], '[]])
dTrue
    | Bool
otherwise = Datum Value (HData' ('TyCon "Bool"))
-> Value (HData' ('TyCon "Bool"))
forall (t :: HakaruCon). Datum Value (HData' t) -> Value (HData' t)
VDatum Datum Value (HData' ('TyCon "Bool"))
forall (ast :: Hakaru -> *).
Datum ast ('HData ('TyCon "Bool") '[ '[], '[]])
dFalse
evalOp (Sum  HSemiring a
HSemiring_Nat)  (VNat  Natural
a) (VNat  Natural
b) = Natural -> Value 'HNat
VNat  (Natural
a Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
b)
evalOp (Sum  HSemiring a
HSemiring_Int)  (VInt  Integer
a) (VInt  Integer
b) = Integer -> Value 'HInt
VInt  (Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
b)
evalOp (Sum  HSemiring a
HSemiring_Prob) (VProb LogFloat
a) (VProb LogFloat
b) = LogFloat -> Value 'HProb
VProb (LogFloat
a LogFloat -> LogFloat -> LogFloat
forall a. Num a => a -> a -> a
+ LogFloat
b)
evalOp (Sum  HSemiring a
HSemiring_Real) (VReal Double
a) (VReal Double
b) = Double -> Value 'HReal
VReal (Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
b)
evalOp (Prod HSemiring a
HSemiring_Nat)  (VNat  Natural
a) (VNat  Natural
b) = Natural -> Value 'HNat
VNat  (Natural
a Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
b)
evalOp (Prod HSemiring a
HSemiring_Int)  (VInt  Integer
a) (VInt  Integer
b) = Integer -> Value 'HInt
VInt  (Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
b)  
evalOp (Prod HSemiring a
HSemiring_Prob) (VProb LogFloat
a) (VProb LogFloat
b) = LogFloat -> Value 'HProb
VProb (LogFloat
a LogFloat -> LogFloat -> LogFloat
forall a. Num a => a -> a -> a
* LogFloat
b)  
evalOp (Prod HSemiring a
HSemiring_Real) (VReal Double
a) (VReal Double
b) = Double -> Value 'HReal
VReal (Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
b)
evalOp (Max  HOrd a
HOrd_Prob)      (VProb LogFloat
a) (VProb LogFloat
b) = LogFloat -> Value 'HProb
VProb (LogFloat -> LogFloat -> LogFloat
forall a. Ord a => a -> a -> a
max LogFloat
a LogFloat
b)
evalOp (Max  HOrd a
HOrd_Real)      (VReal Double
a) (VReal Double
b) = Double -> Value 'HReal
VReal (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
a Double
b)
evalOp (Min  HOrd a
HOrd_Prob)      (VProb LogFloat
a) (VProb LogFloat
b) = LogFloat -> Value 'HProb
VProb (LogFloat -> LogFloat -> LogFloat
forall a. Ord a => a -> a -> a
min LogFloat
a LogFloat
b) 
evalOp (Min  HOrd a
HOrd_Real)      (VReal Double
a) (VReal Double
b) = Double -> Value 'HReal
VReal (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
a Double
b) 

evalOp NaryOp a
op                    Value a
_          Value a
_        =
    [Char] -> Value a
forall a. HasCallStack => [Char] -> a
error ([Char]
"TODO: evalOp{" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NaryOp a -> [Char]
forall a. Show a => a -> [Char]
show NaryOp a
op [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"}")

mapEvaluate
    :: (ABT Term abt)
    => Seq (abt '[] a) -> Env -> Seq (Value a)
mapEvaluate :: Seq (abt '[] a) -> Env -> Seq (Value a)
mapEvaluate Seq (abt '[] a)
es Env
env = (abt '[] a -> Value a) -> Seq (abt '[] a) -> Seq (Value a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((abt '[] a -> Env -> Value a) -> Env -> abt '[] a -> Value a
forall a b c. (a -> b -> c) -> b -> a -> c
flip abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate Env
env) Seq (abt '[] a)
es


evaluateLiteral :: Literal a -> Value a
evaluateLiteral :: Literal a -> Value a
evaluateLiteral (LNat  Natural
n) = Natural -> Value 'HNat
VNat  (Natural -> Value 'HNat)
-> (Integer -> Natural) -> Integer -> Value 'HNat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Natural
forall a. Num a => Integer -> a
fromInteger (Integer -> Value 'HNat) -> Integer -> Value 'HNat
forall a b. (a -> b) -> a -> b
$ Natural -> Integer
fromNatural Natural
n -- TODO: catch overflow errors
evaluateLiteral (LInt  Integer
n) = Integer -> Value 'HInt
VInt  (Integer -> Value 'HInt) -> Integer -> Value 'HInt
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
n -- TODO: catch overflow errors
evaluateLiteral (LProb NonNegativeRational
n) = LogFloat -> Value 'HProb
VProb (LogFloat -> Value 'HProb)
-> (Rational -> LogFloat) -> Rational -> Value 'HProb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> LogFloat
forall a. Fractional a => Rational -> a
fromRational (Rational -> Value 'HProb) -> Rational -> Value 'HProb
forall a b. (a -> b) -> a -> b
$ NonNegativeRational -> Rational
fromNonNegativeRational NonNegativeRational
n
evaluateLiteral (LReal Rational
n) = Double -> Value 'HReal
VReal (Double -> Value 'HReal) -> Double -> Value 'HReal
forall a b. (a -> b) -> a -> b
$ Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
n

evaluateEmpty :: Value ('HArray a)
evaluateEmpty :: Value ('HArray a)
evaluateEmpty = Vector (Value a) -> Value ('HArray a)
forall (a :: Hakaru). Vector (Value a) -> Value ('HArray a)
VArray Vector (Value a)
forall a. Vector a
V.empty

evaluateArray
    :: (ABT Term abt)
    => (abt '[] 'HNat)
    -> (abt '[ 'HNat ] a)
    -> Env
    -> Value ('HArray a)
evaluateArray :: abt '[] 'HNat -> abt '[ 'HNat] a -> Env -> Value ('HArray a)
evaluateArray abt '[] 'HNat
n abt '[ 'HNat] a
e Env
env =
    case abt '[] 'HNat -> Env -> Value 'HNat
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] 'HNat
n Env
env of
    VNat Natural
n' -> abt '[ 'HNat] a
-> (Variable 'HNat -> abt '[] a -> Value ('HArray a))
-> Value ('HArray a)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind abt '[ 'HNat] a
e ((Variable 'HNat -> abt '[] a -> Value ('HArray a))
 -> Value ('HArray a))
-> (Variable 'HNat -> abt '[] a -> Value ('HArray a))
-> Value ('HArray a)
forall a b. (a -> b) -> a -> b
$ \Variable 'HNat
x abt '[] a
e' ->
        Vector (Value a) -> Value ('HArray a)
forall (a :: Hakaru). Vector (Value a) -> Value ('HArray a)
VArray (Vector (Value a) -> Value ('HArray a))
-> Vector (Value a) -> Value ('HArray a)
forall a b. (a -> b) -> a -> b
$ Key -> (Key -> Value a) -> Vector (Value a)
forall a. Key -> (Key -> a) -> Vector a
V.generate (Natural -> Key
unsafeInt Natural
n') ((Key -> Value a) -> Vector (Value a))
-> (Key -> Value a) -> Vector (Value a)
forall a b. (a -> b) -> a -> b
$ \Key
v ->
            let v' :: Value 'HNat
v' = Natural -> Value 'HNat
VNat (Natural -> Value 'HNat) -> Natural -> Value 'HNat
forall a b. (a -> b) -> a -> b
$ Key -> Natural
intToNatural Key
v in
            abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] a
e' (EAssoc -> Env -> Env
updateEnv (Variable 'HNat -> Value 'HNat -> EAssoc
forall (a :: Hakaru). Variable a -> Value a -> EAssoc
EAssoc Variable 'HNat
x Value 'HNat
v') Env
env)

evaluateBucket
    :: (ABT Term abt)
    => abt '[] 'HNat
    -> abt '[] 'HNat
    -> Reducer abt '[] a
    -> Env
    -> Value a
evaluateBucket :: abt '[] 'HNat
-> abt '[] 'HNat -> Reducer abt '[] a -> Env -> Value a
evaluateBucket abt '[] 'HNat
b abt '[] 'HNat
e Reducer abt '[] a
rs Env
env =
    case (abt '[] 'HNat -> Env -> Value 'HNat
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] 'HNat
b Env
env, abt '[] 'HNat -> Env -> Value 'HNat
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] 'HNat
e Env
env) of
      (VNat Natural
b', VNat Natural
e') -> (forall s. ST s (Value a)) -> Value a
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Value a)) -> Value a)
-> (forall s. ST s (Value a)) -> Value a
forall a b. (a -> b) -> a -> b
$ do
          VReducer s a
s' <- List1 Value '[] -> Reducer abt '[] a -> Env -> ST s (VReducer s a)
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru) s.
ABT Term abt =>
List1 Value xs -> Reducer abt xs a -> Env -> ST s (VReducer s a)
init List1 Value '[]
forall k (a :: k -> *). List1 a '[]
Nil1 Reducer abt '[] a
rs Env
env
          (Natural -> ST s ()) -> [Natural] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Natural
i -> Value 'HNat
-> List1 Value '[]
-> Reducer abt '[] a
-> VReducer s a
-> Env
-> ST s ()
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru) s.
ABT Term abt =>
Value 'HNat
-> List1 Value xs
-> Reducer abt xs a
-> VReducer s a
-> Env
-> ST s ()
accum (Natural -> Value 'HNat
VNat Natural
i) List1 Value '[]
forall k (a :: k -> *). List1 a '[]
Nil1 Reducer abt '[] a
rs VReducer s a
s' Env
env) [Natural
b' .. Natural
e' Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1]
          VReducer s a -> ST s (Value a)
forall s (a :: Hakaru). VReducer s a -> ST s (Value a)
done VReducer s a
s'
    where init :: (ABT Term abt)
               => List1 Value xs
               -> Reducer abt xs a
               -> Env
               -> ST s (VReducer s a)
          init :: List1 Value xs -> Reducer abt xs a -> Env -> ST s (VReducer s a)
init List1 Value xs
ix (Red_Fanout Reducer abt xs a
r1 Reducer abt xs b
r2)    Env
env  =
              Sing a
-> Sing b -> VReducer s a -> VReducer s b -> VReducer s (HPair a b)
forall (a :: Hakaru) (b :: Hakaru) s.
Sing a
-> Sing b -> VReducer s a -> VReducer s b -> VReducer s (HPair a b)
VRed_Pair (Reducer abt xs a -> Sing a
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
Reducer abt xs a -> Sing a
type_ Reducer abt xs a
r1) (Reducer abt xs b -> Sing b
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
Reducer abt xs a -> Sing a
type_ Reducer abt xs b
r2) (VReducer s a -> VReducer s b -> VReducer s (HPair a b))
-> ST s (VReducer s a)
-> ST s (VReducer s b -> VReducer s (HPair a b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> List1 Value xs -> Reducer abt xs a -> Env -> ST s (VReducer s a)
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru) s.
ABT Term abt =>
List1 Value xs -> Reducer abt xs a -> Env -> ST s (VReducer s a)
init List1 Value xs
ix Reducer abt xs a
r1 Env
env ST s (VReducer s b -> VReducer s (HPair a b))
-> ST s (VReducer s b) -> ST s (VReducer s (HPair a b))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> List1 Value xs -> Reducer abt xs b -> Env -> ST s (VReducer s b)
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru) s.
ABT Term abt =>
List1 Value xs -> Reducer abt xs a -> Env -> ST s (VReducer s a)
init List1 Value xs
ix Reducer abt xs b
r2 Env
env
          init List1 Value xs
ix (Red_Index  abt xs 'HNat
n  abt ('HNat : xs) 'HNat
_  Reducer abt ('HNat : xs) a
mr) Env
env' =
              let (List1 Variable xs
vars, abt '[] 'HNat
n') = abt xs 'HNat -> (List1 Variable xs, abt '[] 'HNat)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (xs :: [k]) (a :: k).
ABT syn abt =>
abt xs a -> (List1 Variable xs, abt '[] a)
caseBinds abt xs 'HNat
n in
              case abt '[] 'HNat -> Env -> Value 'HNat
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] 'HNat
n' (List1 Variable xs -> List1 Value xs -> Env -> Env
forall (xs :: [Hakaru]).
List1 Variable xs -> List1 Value xs -> Env -> Env
updateEnvs List1 Variable xs
vars List1 Value xs
ix Env
env') of
                VNat Natural
n'' -> Vector (VReducer s a) -> VReducer s ('HArray a)
forall s (a :: Hakaru).
Vector (VReducer s a) -> VReducer s ('HArray a)
VRed_Array (Vector (VReducer s a) -> VReducer s ('HArray a))
-> ST s (Vector (VReducer s a)) -> ST s (VReducer s ('HArray a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> (Key -> ST s (VReducer s a)) -> ST s (Vector (VReducer s a))
forall (m :: * -> *) a.
Monad m =>
Key -> (Key -> m a) -> m (Vector a)
V.generateM (Natural -> Key
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n'')
                            (\Key
bb -> List1 Value ('HNat : xs)
-> Reducer abt ('HNat : xs) a -> Env -> ST s (VReducer s a)
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru) s.
ABT Term abt =>
List1 Value xs -> Reducer abt xs a -> Env -> ST s (VReducer s a)
init (Value 'HNat -> List1 Value xs -> List1 Value ('HNat : xs)
forall a (a :: a -> *) (x :: a) (xs :: [a]).
a x -> List1 a xs -> List1 a (x : xs)
Cons1 (Key -> Value 'HNat
vnat Key
bb) List1 Value xs
ix) Reducer abt ('HNat : xs) a
mr Env
env')
          init List1 Value xs
ix (Red_Split abt ('HNat : xs) ('HData ('TyCon "Bool") '[ '[], '[]])
_ Reducer abt xs a
r1 Reducer abt xs b
r2)   Env
env' =
              Sing a
-> Sing b -> VReducer s a -> VReducer s b -> VReducer s (HPair a b)
forall (a :: Hakaru) (b :: Hakaru) s.
Sing a
-> Sing b -> VReducer s a -> VReducer s b -> VReducer s (HPair a b)
VRed_Pair (Reducer abt xs a -> Sing a
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
Reducer abt xs a -> Sing a
type_ Reducer abt xs a
r1) (Reducer abt xs b -> Sing b
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
Reducer abt xs a -> Sing a
type_ Reducer abt xs b
r2) (VReducer s a -> VReducer s b -> VReducer s (HPair a b))
-> ST s (VReducer s a)
-> ST s (VReducer s b -> VReducer s (HPair a b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> List1 Value xs -> Reducer abt xs a -> Env -> ST s (VReducer s a)
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru) s.
ABT Term abt =>
List1 Value xs -> Reducer abt xs a -> Env -> ST s (VReducer s a)
init List1 Value xs
ix Reducer abt xs a
r1 Env
env ST s (VReducer s b -> VReducer s (HPair a b))
-> ST s (VReducer s b) -> ST s (VReducer s (HPair a b))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> List1 Value xs -> Reducer abt xs b -> Env -> ST s (VReducer s b)
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru) s.
ABT Term abt =>
List1 Value xs -> Reducer abt xs a -> Env -> ST s (VReducer s a)
init List1 Value xs
ix Reducer abt xs b
r2 Env
env'
          init List1 Value xs
_  Reducer abt xs a
Red_Nop               Env
_    = VReducer s HUnit -> ST s (VReducer s HUnit)
forall (m :: * -> *) a. Monad m => a -> m a
return VReducer s HUnit
forall s. VReducer s HUnit
VRed_Unit
          init List1 Value xs
_  (Red_Add HSemiring a
h abt ('HNat : xs) a
_) Env
_ = STRef s (Value a) -> VReducer s a
forall s (a :: Hakaru). STRef s (Value a) -> VReducer s a
VRed_Num (STRef s (Value a) -> VReducer s a)
-> ST s (STRef s (Value a)) -> ST s (VReducer s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value a -> ST s (STRef s (Value a))
forall a s. a -> ST s (STRef s a)
newSTRef (NaryOp a -> Value a
forall (a :: Hakaru). NaryOp a -> Value a
identityElement (HSemiring a -> NaryOp a
forall (a :: Hakaru). HSemiring a -> NaryOp a
Sum HSemiring a
h))

          type_ :: Reducer abt xs a -> Sing a
type_ = Reducer abt xs a -> Sing a
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru).
Reducer abt xs a -> Sing a
typeOfReducer

          vnat :: Int -> Value 'HNat
          vnat :: Key -> Value 'HNat
vnat  = Natural -> Value 'HNat
VNat (Natural -> Value 'HNat) -> (Key -> Natural) -> Key -> Value 'HNat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral

          accum :: (ABT Term abt)
                => Value 'HNat
                -> List1 Value xs
                -> Reducer abt xs a
                -> VReducer s a
                -> Env
                -> ST s ()
          accum :: Value 'HNat
-> List1 Value xs
-> Reducer abt xs a
-> VReducer s a
-> Env
-> ST s ()
accum Value 'HNat
n List1 Value xs
ix (Red_Fanout Reducer abt xs a
r1 Reducer abt xs b
r2)   (VRed_Pair Sing a
_ Sing b
_ VReducer s a
v1 VReducer s b
v2) Env
env' =
              Value 'HNat
-> List1 Value xs
-> Reducer abt xs a
-> VReducer s a
-> Env
-> ST s ()
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru) s.
ABT Term abt =>
Value 'HNat
-> List1 Value xs
-> Reducer abt xs a
-> VReducer s a
-> Env
-> ST s ()
accum Value 'HNat
n List1 Value xs
ix Reducer abt xs a
r1 VReducer s a
VReducer s a
v1 Env
env ST s () -> ST s () -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Value 'HNat
-> List1 Value xs
-> Reducer abt xs b
-> VReducer s b
-> Env
-> ST s ()
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru) s.
ABT Term abt =>
Value 'HNat
-> List1 Value xs
-> Reducer abt xs a
-> VReducer s a
-> Env
-> ST s ()
accum Value 'HNat
n List1 Value xs
ix Reducer abt xs b
r2 VReducer s b
VReducer s b
v2 Env
env'
          accum Value 'HNat
n List1 Value xs
ix (Red_Index abt xs 'HNat
n' abt ('HNat : xs) 'HNat
a1 Reducer abt ('HNat : xs) a
r2) (VRed_Array Vector (VReducer s a)
v)          Env
env' =
              abt ('HNat : xs) 'HNat
-> (Variable 'HNat -> abt xs 'HNat -> ST s ()) -> ST s ()
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind abt ('HNat : xs) 'HNat
a1 ((Variable 'HNat -> abt xs 'HNat -> ST s ()) -> ST s ())
-> (Variable 'HNat -> abt xs 'HNat -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Variable 'HNat
i abt xs 'HNat
a1' ->
              let (List1 Variable xs
vars, abt '[] 'HNat
a1'') = abt xs 'HNat -> (List1 Variable xs, abt '[] 'HNat)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (xs :: [k]) (a :: k).
ABT syn abt =>
abt xs a -> (List1 Variable xs, abt '[] a)
caseBinds abt xs 'HNat
a1'
                  VNat Natural
ov = abt '[] 'HNat -> Env -> Value 'HNat
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] 'HNat
a1''
                            (EAssoc -> Env -> Env
updateEnv (Variable 'HNat -> Value 'HNat -> EAssoc
forall (a :: Hakaru). Variable a -> Value a -> EAssoc
EAssoc Variable 'HNat
i Value 'HNat
n) (List1 Variable xs -> List1 Value xs -> Env -> Env
forall (xs :: [Hakaru]).
List1 Variable xs -> List1 Value xs -> Env -> Env
updateEnvs List1 Variable xs
vars List1 Value xs
ix Env
env'))
                  ov' :: Key
ov' = Natural -> Key
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
ov in
              Value 'HNat
-> List1 Value ('HNat : xs)
-> Reducer abt ('HNat : xs) a
-> VReducer s a
-> Env
-> ST s ()
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru) s.
ABT Term abt =>
Value 'HNat
-> List1 Value xs
-> Reducer abt xs a
-> VReducer s a
-> Env
-> ST s ()
accum Value 'HNat
n (Value 'HNat -> List1 Value xs -> List1 Value ('HNat : xs)
forall a (a :: a -> *) (x :: a) (xs :: [a]).
a x -> List1 a xs -> List1 a (x : xs)
Cons1 (Natural -> Value 'HNat
VNat Natural
ov) List1 Value xs
ix) Reducer abt ('HNat : xs) a
r2 (Vector (VReducer s a)
v Vector (VReducer s a) -> Key -> VReducer s a
forall a. Vector a -> Key -> a
V.! Key
ov') Env
env
          accum Value 'HNat
n List1 Value xs
ix (Red_Split abt ('HNat : xs) ('HData ('TyCon "Bool") '[ '[], '[]])
bb Reducer abt xs a
r1 Reducer abt xs b
r2) (VRed_Pair Sing a
_ Sing b
_ VReducer s a
v1 VReducer s b
v2) Env
env' =
              abt ('HNat : xs) ('HData ('TyCon "Bool") '[ '[], '[]])
-> (Variable 'HNat
    -> abt xs ('HData ('TyCon "Bool") '[ '[], '[]]) -> ST s ())
-> ST s ()
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind abt ('HNat : xs) ('HData ('TyCon "Bool") '[ '[], '[]])
bb ((Variable 'HNat
  -> abt xs ('HData ('TyCon "Bool") '[ '[], '[]]) -> ST s ())
 -> ST s ())
-> (Variable 'HNat
    -> abt xs ('HData ('TyCon "Bool") '[ '[], '[]]) -> ST s ())
-> ST s ()
forall a b. (a -> b) -> a -> b
$ \Variable 'HNat
i abt xs ('HData ('TyCon "Bool") '[ '[], '[]])
b' ->
                  let (List1 Variable xs
vars, abt '[] ('HData ('TyCon "Bool") '[ '[], '[]])
b'') = abt xs ('HData ('TyCon "Bool") '[ '[], '[]])
-> (List1 Variable xs,
    abt '[] ('HData ('TyCon "Bool") '[ '[], '[]]))
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (xs :: [k]) (a :: k).
ABT syn abt =>
abt xs a -> (List1 Variable xs, abt '[] a)
caseBinds abt xs ('HData ('TyCon "Bool") '[ '[], '[]])
b' in
                  case abt '[] ('HData ('TyCon "Bool") '[ '[], '[]])
-> Env -> Value ('HData ('TyCon "Bool") '[ '[], '[]])
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] ('HData ('TyCon "Bool") '[ '[], '[]])
b''
                       (EAssoc -> Env -> Env
updateEnv (Variable 'HNat -> Value 'HNat -> EAssoc
forall (a :: Hakaru). Variable a -> Value a -> EAssoc
EAssoc Variable 'HNat
i Value 'HNat
n) (List1 Variable xs -> List1 Value xs -> Env -> Env
forall (xs :: [Hakaru]).
List1 Variable xs -> List1 Value xs -> Env -> Env
updateEnvs List1 Variable xs
vars List1 Value xs
ix Env
env')) of
                  VDatum Datum Value (HData' t)
bb -> if Datum Value (HData' t)
Datum Value ('HData ('TyCon "Bool") '[ '[], '[]])
bb Datum Value ('HData ('TyCon "Bool") '[ '[], '[]])
-> Datum Value ('HData ('TyCon "Bool") '[ '[], '[]]) -> Bool
forall a. Eq a => a -> a -> Bool
== Datum Value ('HData ('TyCon "Bool") '[ '[], '[]])
forall (ast :: Hakaru -> *).
Datum ast ('HData ('TyCon "Bool") '[ '[], '[]])
dTrue then
                                   Value 'HNat
-> List1 Value xs
-> Reducer abt xs a
-> VReducer s a
-> Env
-> ST s ()
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru) s.
ABT Term abt =>
Value 'HNat
-> List1 Value xs
-> Reducer abt xs a
-> VReducer s a
-> Env
-> ST s ()
accum Value 'HNat
n List1 Value xs
ix Reducer abt xs a
r1 VReducer s a
VReducer s a
v1 Env
env'
                               else
                                   Value 'HNat
-> List1 Value xs
-> Reducer abt xs b
-> VReducer s b
-> Env
-> ST s ()
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
       (a :: Hakaru) s.
ABT Term abt =>
Value 'HNat
-> List1 Value xs
-> Reducer abt xs a
-> VReducer s a
-> Env
-> ST s ()
accum Value 'HNat
n List1 Value xs
ix Reducer abt xs b
r2 VReducer s b
VReducer s b
v2 Env
env'
          accum Value 'HNat
n List1 Value xs
ix (Red_Add HSemiring a
h abt ('HNat : xs) a
ee) (VRed_Num STRef s (Value a)
s) Env
env' =
              abt ('HNat : xs) a
-> (Variable 'HNat -> abt xs a -> ST s ()) -> ST s ()
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind abt ('HNat : xs) a
ee ((Variable 'HNat -> abt xs a -> ST s ()) -> ST s ())
-> (Variable 'HNat -> abt xs a -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Variable 'HNat
i abt xs a
e' ->
                  let (List1 Variable xs
vars, abt '[] a
e'') = abt xs a -> (List1 Variable xs, abt '[] a)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
       (xs :: [k]) (a :: k).
ABT syn abt =>
abt xs a -> (List1 Variable xs, abt '[] a)
caseBinds abt xs a
e'
                      v :: Value a
v = abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] a
e''
                          (EAssoc -> Env -> Env
updateEnv (Variable 'HNat -> Value 'HNat -> EAssoc
forall (a :: Hakaru). Variable a -> Value a -> EAssoc
EAssoc Variable 'HNat
i Value 'HNat
n) (List1 Variable xs -> List1 Value xs -> Env -> Env
forall (xs :: [Hakaru]).
List1 Variable xs -> List1 Value xs -> Env -> Env
updateEnvs List1 Variable xs
vars List1 Value xs
ix Env
env')) in
                  STRef s (Value a) -> (Value a -> Value a) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef' STRef s (Value a)
s (NaryOp a -> Value a -> Value a -> Value a
forall (a :: Hakaru). NaryOp a -> Value a -> Value a -> Value a
evalOp (HSemiring a -> NaryOp a
forall (a :: Hakaru). HSemiring a -> NaryOp a
Sum HSemiring a
h) Value a
v)
          accum Value 'HNat
_ List1 Value xs
_ Reducer abt xs a
Red_Nop VReducer s a
_ Env
_ = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          accum Value 'HNat
_ List1 Value xs
_ Reducer abt xs a
_ VReducer s a
_ Env
_ = [Char] -> ST s ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Some impossible combinations happened?"

          done :: VReducer s a -> ST s (Value a)
          done :: VReducer s a -> ST s (Value a)
done (VRed_Num STRef s (Value a)
s)            = STRef s (Value a) -> ST s (Value a)
forall s a. STRef s a -> ST s a
readSTRef STRef s (Value a)
s
          done VReducer s a
VRed_Unit               = Value a -> ST s (Value a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Datum Value (HData' ('TyCon "Unit"))
-> Value (HData' ('TyCon "Unit"))
forall (t :: HakaruCon). Datum Value (HData' t) -> Value (HData' t)
VDatum Datum Value (HData' ('TyCon "Unit"))
forall (ast :: Hakaru -> *). Datum ast HUnit
dUnit)
          done (VRed_Pair Sing a
s1 Sing b
s2 VReducer s a
v1 VReducer s b
v2) = do
            Value a
v1' <- VReducer s a -> ST s (Value a)
forall s (a :: Hakaru). VReducer s a -> ST s (Value a)
done VReducer s a
v1
            Value b
v2' <- VReducer s b -> ST s (Value b)
forall s (a :: Hakaru). VReducer s a -> ST s (Value a)
done VReducer s b
v2
            Value a -> ST s (Value a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Datum Value (HData' (('TyCon "Pair" ':@ a) ':@ b))
-> Value (HData' (('TyCon "Pair" ':@ a) ':@ b))
forall (t :: HakaruCon). Datum Value (HData' t) -> Value (HData' t)
VDatum (Datum Value (HData' (('TyCon "Pair" ':@ a) ':@ b))
 -> Value (HData' (('TyCon "Pair" ':@ a) ':@ b)))
-> Datum Value (HData' (('TyCon "Pair" ':@ a) ':@ b))
-> Value (HData' (('TyCon "Pair" ':@ a) ':@ b))
forall a b. (a -> b) -> a -> b
$ Sing a -> Sing b -> Value a -> Value b -> Datum Value (HPair a b)
forall (a :: Hakaru) (b :: Hakaru) (ast :: Hakaru -> *).
Sing a -> Sing b -> ast a -> ast b -> Datum ast (HPair a b)
dPair_ Sing a
s1 Sing b
s2 Value a
v1' Value b
v2')
          done (VRed_Array Vector (VReducer s a)
v)          = Vector (Value a) -> Value ('HArray a)
forall (a :: Hakaru). Vector (Value a) -> Value ('HArray a)
VArray (Vector (Value a) -> Value ('HArray a))
-> ST s (Vector (Value a)) -> ST s (Value ('HArray a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector (ST s (Value a)) -> ST s (Vector (Value a))
forall (m :: * -> *) a. Monad m => Vector (m a) -> m (Vector a)
V.sequence ((VReducer s a -> ST s (Value a))
-> Vector (VReducer s a) -> Vector (ST s (Value a))
forall a b. (a -> b) -> Vector a -> Vector b
V.map VReducer s a -> ST s (Value a)
forall s (a :: Hakaru). VReducer s a -> ST s (Value a)
done Vector (VReducer s a)
v)

evaluateDatum
    :: (ABT Term abt)
    => Datum (abt '[]) (HData' a)
    -> Env
    -> Value (HData' a)
evaluateDatum :: Datum (abt '[]) (HData' a) -> Env -> Value (HData' a)
evaluateDatum Datum (abt '[]) (HData' a)
d Env
env = Datum Value (HData' a) -> Value (HData' a)
forall (t :: HakaruCon). Datum Value (HData' t) -> Value (HData' t)
VDatum ((forall (i :: Hakaru). abt '[] i -> Value i)
-> Datum (abt '[]) (HData' a) -> Datum Value (HData' a)
forall k1 k2 (f :: (k1 -> *) -> k2 -> *) (a :: k1 -> *)
       (b :: k1 -> *) (j :: k2).
Functor11 f =>
(forall (i :: k1). a i -> b i) -> f a j -> f b j
fmap11 ((abt '[] i -> Env -> Value i) -> Env -> abt '[] i -> Value i
forall a b c. (a -> b -> c) -> b -> a -> c
flip abt '[] i -> Env -> Value i
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate Env
env) Datum (abt '[]) (HData' a)
d)

evaluateCase
    :: forall abt a b
    .  (ABT Term abt)
    => abt '[] a
    -> [Branch a abt b]
    -> Env
    -> Value b
evaluateCase :: abt '[] a -> [Branch a abt b] -> Env -> Value b
evaluateCase abt '[] a
o [Branch a abt b]
es Env
env =
    case Identity (Maybe (MatchResult Value abt b))
-> Maybe (MatchResult Value abt b)
forall a. Identity a -> a
runIdentity (Identity (Maybe (MatchResult Value abt b))
 -> Maybe (MatchResult Value abt b))
-> Identity (Maybe (MatchResult Value abt b))
-> Maybe (MatchResult Value abt b)
forall a b. (a -> b) -> a -> b
$ DatumEvaluator Value Identity
-> Value a
-> [Branch a abt b]
-> Identity (Maybe (MatchResult Value abt b))
forall (abt :: [Hakaru] -> Hakaru -> *) (m :: * -> *)
       (ast :: Hakaru -> *) (a :: Hakaru) (b :: Hakaru).
(ABT Term abt, Monad m) =>
DatumEvaluator ast m
-> ast a -> [Branch a abt b] -> m (Maybe (MatchResult ast abt b))
matchBranches DatumEvaluator Value Identity
evaluateDatum' (abt '[] a -> Env -> Value a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] a
o Env
env) [Branch a abt b]
es of
    Just (Matched Assocs Value
rho abt '[] b
b) ->
        abt '[] b -> Env -> Value b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] b
b ([Assoc Value] -> Env -> Env
extendFromMatch (Assocs Value -> [Assoc Value]
forall k (ast :: k -> *). Assocs ast -> [Assoc ast]
fromAssocs Assocs Value
rho) Env
env)
    Maybe (MatchResult Value abt b)
_ -> [Char] -> Value b
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing cases in match expression"
    where
    extendFromMatch :: [Assoc Value] -> Env -> Env
    extendFromMatch :: [Assoc Value] -> Env -> Env
extendFromMatch []                Env
env' = Env
env'
    extendFromMatch (Assoc Variable a
x Value a
v : [Assoc Value]
xvs) Env
env' =
        [Assoc Value] -> Env -> Env
extendFromMatch [Assoc Value]
xvs (EAssoc -> Env -> Env
updateEnv (Variable a -> Value a -> EAssoc
forall (a :: Hakaru). Variable a -> Value a -> EAssoc
EAssoc Variable a
x Value a
v) Env
env')

    evaluateDatum' :: DatumEvaluator Value Identity
    evaluateDatum' :: Value (HData' t) -> Identity (Maybe (Datum Value (HData' t)))
evaluateDatum' = Maybe (Datum Value (HData' t))
-> Identity (Maybe (Datum Value (HData' t)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Datum Value (HData' t))
 -> Identity (Maybe (Datum Value (HData' t))))
-> (Value (HData' t) -> Maybe (Datum Value (HData' t)))
-> Value (HData' t)
-> Identity (Maybe (Datum Value (HData' t)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Datum Value (HData' t) -> Maybe (Datum Value (HData' t))
forall a. a -> Maybe a
Just (Datum Value (HData' t) -> Maybe (Datum Value (HData' t)))
-> (Value (HData' t) -> Datum Value (HData' t))
-> Value (HData' t)
-> Maybe (Datum Value (HData' t))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value (HData' t) -> Datum Value (HData' t)
forall (a :: HakaruCon). Value (HData' a) -> Datum Value (HData' a)
getVDatum

    getVDatum :: Value (HData' a) -> Datum Value (HData' a)
    getVDatum :: Value (HData' a) -> Datum Value (HData' a)
getVDatum (VDatum Datum Value (HData' t)
a) = Datum Value (HData' a)
Datum Value (HData' t)
a

evaluateSuperpose
    :: (ABT Term abt)
    => NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
    -> Env
    -> Value ('HMeasure a)
evaluateSuperpose :: NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
-> Env -> Value ('HMeasure a)
evaluateSuperpose ((abt '[] 'HProb
q, abt '[] ('HMeasure a)
m) :| []) Env
env =
    case abt '[] ('HMeasure a) -> Env -> Value ('HMeasure a)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] ('HMeasure a)
m Env
env of
    VMeasure Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb))
m' ->
        let VProb LogFloat
q' = abt '[] 'HProb -> Env -> Value 'HProb
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] 'HProb
q Env
env
        in  (Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb)))
-> Value ('HMeasure a)
forall (b :: Hakaru).
(Value 'HProb -> GenIO -> IO (Maybe (Value b, Value 'HProb)))
-> Value ('HMeasure b)
VMeasure (\(VProb LogFloat
p) GenIO
g -> Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb))
m' (LogFloat -> Value 'HProb
VProb (LogFloat -> Value 'HProb) -> LogFloat -> Value 'HProb
forall a b. (a -> b) -> a -> b
$ LogFloat
p LogFloat -> LogFloat -> LogFloat
forall a. Num a => a -> a -> a
* LogFloat
q') GenIO
g)
        
evaluateSuperpose pms :: NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
pms@((abt '[] 'HProb
_, abt '[] ('HMeasure a)
m) :| [(abt '[] 'HProb, abt '[] ('HMeasure a))]
_) Env
env =
    case abt '[] ('HMeasure a) -> Env -> Value ('HMeasure a)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] ('HMeasure a)
m Env
env of
    VMeasure Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb))
m' ->
        let pms' :: [(abt '[] 'HProb, abt '[] ('HMeasure a))]
pms'     = NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
-> [(abt '[] 'HProb, abt '[] ('HMeasure a))]
forall a. NonEmpty a -> [a]
L.toList NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
pms
            weights :: [Value 'HProb]
weights  = ((abt '[] 'HProb, abt '[] ('HMeasure a)) -> Value 'HProb)
-> [(abt '[] 'HProb, abt '[] ('HMeasure a))] -> [Value 'HProb]
forall a b. (a -> b) -> [a] -> [b]
map (((abt '[] 'HProb -> Env -> Value 'HProb)
-> Env -> abt '[] 'HProb -> Value 'HProb
forall a b c. (a -> b -> c) -> b -> a -> c
flip abt '[] 'HProb -> Env -> Value 'HProb
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate Env
env) (abt '[] 'HProb -> Value 'HProb)
-> ((abt '[] 'HProb, abt '[] ('HMeasure a)) -> abt '[] 'HProb)
-> (abt '[] 'HProb, abt '[] ('HMeasure a))
-> Value 'HProb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (abt '[] 'HProb, abt '[] ('HMeasure a)) -> abt '[] 'HProb
forall a b. (a, b) -> a
fst) [(abt '[] 'HProb, abt '[] ('HMeasure a))]
pms'
            (LogFloat
x,Double
y,[Double]
ys) = [Value 'HProb] -> (LogFloat, Double, [Double])
normalize [Value 'HProb]
weights
        in (Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb)))
-> Value ('HMeasure a)
forall (b :: Hakaru).
(Value 'HProb -> GenIO -> IO (Maybe (Value b, Value 'HProb)))
-> Value ('HMeasure b)
VMeasure ((Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb)))
 -> Value ('HMeasure a))
-> (Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb)))
-> Value ('HMeasure a)
forall a b. (a -> b) -> a -> b
$ \(VProb LogFloat
p) GenIO
g ->
            if Bool -> Bool
not (Double
y Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> (Double
0::Double)) then Maybe (Value a, Value 'HProb) -> IO (Maybe (Value a, Value 'HProb))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Value a, Value 'HProb)
forall a. Maybe a
Nothing else do
            Double
u <- (Double, Double) -> GenIO -> IO Double
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
(a, a) -> Gen (PrimState m) -> m a
MWC.uniformR (Double
0, Double
y) GenIO
g
            case [ abt '[] ('HMeasure a)
m1 | (Double
v,(abt '[] 'HProb
_,abt '[] ('HMeasure a)
m1)) <- [Double]
-> [(abt '[] 'HProb, abt '[] ('HMeasure a))]
-> [(Double, (abt '[] 'HProb, abt '[] ('HMeasure a)))]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Double -> Double -> Double) -> [Double] -> [Double]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) [Double]
ys) [(abt '[] 'HProb, abt '[] ('HMeasure a))]
pms', Double
u Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
v ] of
                abt '[] ('HMeasure a)
m2 : [abt '[] ('HMeasure a)]
_ ->
                    case abt '[] ('HMeasure a) -> Env -> Value ('HMeasure a)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Env -> Value a
evaluate abt '[] ('HMeasure a)
m2 Env
env of
                    VMeasure Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb))
m2' -> Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb))
m2' (LogFloat -> Value 'HProb
VProb (LogFloat -> Value 'HProb) -> LogFloat -> Value 'HProb
forall a b. (a -> b) -> a -> b
$ LogFloat
p LogFloat -> LogFloat -> LogFloat
forall a. Num a => a -> a -> a
* LogFloat
x LogFloat -> LogFloat -> LogFloat
forall a. Num a => a -> a -> a
* Double -> LogFloat
LF.logFloat Double
y) GenIO
g
                []     -> Value 'HProb -> GenIO -> IO (Maybe (Value a, Value 'HProb))
m' (LogFloat -> Value 'HProb
VProb (LogFloat -> Value 'HProb) -> LogFloat -> Value 'HProb
forall a b. (a -> b) -> a -> b
$ LogFloat
p LogFloat -> LogFloat -> LogFloat
forall a. Num a => a -> a -> a
* LogFloat
x LogFloat -> LogFloat -> LogFloat
forall a. Num a => a -> a -> a
* Double -> LogFloat
LF.logFloat Double
y) GenIO
g

----------------------------------------------------------------

-- Useful 'short-hand'
intToNatural :: Int -> Natural
intToNatural :: Key -> Natural
intToNatural = Integer -> Natural
unsafeNatural (Integer -> Natural) -> (Key -> Integer) -> Key -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Integer
forall a. Integral a => a -> Integer
toInteger

unsafeInt :: Natural -> Int
unsafeInt :: Natural -> Key
unsafeInt = Integer -> Key
forall a. Num a => Integer -> a
fromInteger (Integer -> Key) -> (Natural -> Integer) -> Natural -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Integer
fromNatural
----------------------------------------------------------- fin.