hakaru-0.7.0: haskell/Tests/RoundTrip.hs
{-# LANGUAGE NoImplicitPrelude
, DataKinds
, TypeOperators
, TypeFamilies
, ScopedTypeVariables
, FlexibleContexts
, MultiParamTypeClasses
, FunctionalDependencies
, TypeSynonymInstances
, GADTs
, FlexibleInstances
, FlexibleContexts
, ConstraintKinds
#-}
{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
module Tests.RoundTrip where
import Prelude ((.), ($), asTypeOf, String, FilePath, Show(..), (++), Bool(..), concat)
import qualified Prelude
import qualified Data.List.NonEmpty as L
import Data.Ratio
import qualified Data.Text.Utf8 as IO
import Language.Hakaru.Syntax.Prelude
import Language.Hakaru.Types.DataKind
import Language.Hakaru.Pretty.Concrete (pretty)
import Language.Hakaru.Syntax.AST (Term, PrimOp(..))
import Language.Hakaru.Syntax.AST.Transforms
import Language.Hakaru.Syntax.ABT (ABT, TrivialABT(..))
import Language.Hakaru.Expect (total)
import Language.Hakaru.Inference (priorAsProposal, mcmc, mh)
import Language.Hakaru.Types.Sing
import System.IO
import System.Directory
import Control.Monad (mapM_, Monad(return))
import Data.Foldable (null)
import Data.List (intercalate)
import qualified Data.Text as Text
import Test.HUnit
import Tests.TestTools
import Tests.Models
(uniform_0_1, normal_0_1, gamma_1_1,
uniformC, normalC, beta_1_1, norm, unif2)
-- import Tests.Models (t4, t4')
unsafeSuperpose
:: (ABT Term abt)
=> [(abt '[] 'HProb, abt '[] ('HMeasure a))]
-> abt '[] ('HMeasure a)
unsafeSuperpose = superpose . L.fromList
testMeasureUnit :: Test
testMeasureUnit = test [
"t1" ~: testConcreteFiles "tests/RoundTrip/t1,t5.0.hk" "tests/RoundTrip/t1,t5.expected.hk", -- In Maple, should 'evaluate' to "\c -> 1/2*c(Unit)"
"t5" ~: testConcreteFiles "tests/RoundTrip/t1,t5.1.hk" "tests/RoundTrip/t1,t5.expected.hk", -- t5 is "the same" as t1.
"t10" ~: testConcreteFiles "tests/RoundTrip/t10.0.hk" "tests/RoundTrip/t10.expected.hk",
"t11" ~: testConcreteFiles "tests/RoundTrip/t11,t22.0.hk" "tests/RoundTrip/t11,t22.expected.hk",
"t12" ~: testConcreteFilesMany [] "tests/RoundTrip/t12.hk",
"t20" ~: testConcreteFiles "tests/RoundTrip/t20.0.hk" "tests/RoundTrip/t20.expected.hk",
"t22" ~: testConcreteFiles "tests/RoundTrip/t11,t22.1.hk" "tests/RoundTrip/t11,t22.expected.hk",
"t24" ~: testConcreteFiles "tests/RoundTrip/t24.0.hk" "tests/RoundTrip/t24.expected.hk",
"t25" ~: testConcreteFiles "tests/RoundTrip/t25.0.hk" "tests/RoundTrip/t25.expected.hk",
"t44Add" ~: testConcreteFiles "tests/RoundTrip/t44Add.0.hk" "tests/RoundTrip/t44Add.expected.hk",
"t44Mul" ~: testConcreteFiles "tests/RoundTrip/t44Mul.0.hk" "tests/RoundTrip/t44Mul.expected.hk",
"t53" ~: testConcreteFiles "tests/RoundTrip/t53.0.hk" "tests/RoundTrip/t53.expected.hk",
"t53'" ~: testConcreteFiles "tests/RoundTrip/t53.1.hk" "tests/RoundTrip/t53.expected.hk",
"t54" ~: testConcreteFile "tests/RoundTrip/t54.hk",
"t55" ~: testConcreteFiles "tests/RoundTrip/t55.0.hk" "tests/RoundTrip/t55.expected.hk",
"t56" ~: testConcreteFiles "tests/RoundTrip/t56.0.hk" "tests/RoundTrip/t56.expected.hk",
"t56'" ~: testConcreteFiles "tests/RoundTrip/t56.1.hk" "tests/RoundTrip/t56.expected.hk",
"t57" ~: testConcreteFiles "tests/RoundTrip/t57.0.hk" "tests/RoundTrip/t57.expected.hk",
"t58" ~: testConcreteFiles "tests/RoundTrip/t58.0.hk" "tests/RoundTrip/t58.expected.hk",
"t59" ~: testConcreteFile "tests/RoundTrip/t59.hk",
"t60" ~: testConcreteFilesMany [ "tests/RoundTrip/t60.0.hk"
, "tests/RoundTrip/t60.1.hk" ]
"tests/RoundTrip/t60.expected.hk",
"t62" ~: testConcreteFiles "tests/RoundTrip/t62.0.hk" "tests/RoundTrip/t62.expected.hk", ---- "Special case" of t56
"t63" ~: testConcreteFiles "tests/RoundTrip/t63.0.hk" "tests/RoundTrip/t63.expected.hk", ---- "Scalar multiple" of t62
"t64" ~: testConcreteFiles "tests/RoundTrip/t64.0.hk" "tests/RoundTrip/t64.expected.hk", -- Density calculation for (Exp (Log StdRandom)) and StdRandom
"t64'" ~: testConcreteFiles "tests/RoundTrip/t64.1.hk" "tests/RoundTrip/t64.expected.hk", -- Density calculation for (Exp (Log StdRandom)) and StdRandom
"t65" ~: testConcreteFiles "tests/RoundTrip/t65.0.hk" "tests/RoundTrip/t65.expected.hk", -- Density calculation for (Add StdRandom (Exp (Neg StdRandom))); Maple can integrate this but we don't simplify it for some reason.
"t77" ~: testConcreteFilesMany [] "tests/RoundTrip/t77.hk" -- the (x * (-1)) below is an unfortunate artifact not worth fixing
]
testMeasureProb :: Test
testMeasureProb = test [
"t2" ~: testConcreteFiles "tests/RoundTrip/t2.0.hk" "tests/RoundTrip/t2.expected.hk",
"t26" ~: testConcreteFiles "tests/RoundTrip/t26.0.hk" "tests/RoundTrip/t26.expected.hk",
"t30" ~: testConcreteFilesMany [] "tests/RoundTrip/t30.hk",
"t33" ~: testConcreteFilesMany [] "tests/RoundTrip/t33.hk",
"t34" ~: testConcreteFiles "tests/RoundTrip/t34.0.hk" "tests/RoundTrip/t34.expected.hk",
"t35" ~: testConcreteFilesMany [] "tests/RoundTrip/t35.0.hk",
"t35'" ~: testConcreteFilesMany [] "tests/RoundTrip/t35.expected.hk",
"t38" ~: testConcreteFilesMany [] "tests/RoundTrip/t38.hk",
"t42" ~: testConcreteFiles "tests/RoundTrip/t42.0.hk" "tests/RoundTrip/t42.expected.hk",
"t49" ~: testConcreteFilesMany [] "tests/RoundTrip/t49.hk",
"t61" ~: testConcreteFiles "tests/RoundTrip/t61.0.hk" "tests/RoundTrip/t61.expected.hk",
"t66" ~: testConcreteFilesMany [] "tests/RoundTrip/t66.hk",
"t67" ~: testConcreteFilesMany [] "tests/RoundTrip/t67.hk",
"t69x" ~: testConcreteFiles "tests/RoundTrip/t69x.0.hk" "tests/RoundTrip/t69x.expected.hk",
"t69y" ~: testConcreteFiles "tests/RoundTrip/t69y.0.hk" "tests/RoundTrip/t69y.expected.hk"
]
-- t45, t46, t47 are all equivalent.
-- But t47 is worse than t45 and t46 because the importance weight generated by
-- t47 as a sampler varies between 0 and 1 whereas the importance weight generated
-- by t45 and t46 is always 1. In general it's good to reduce weight variance.
testMeasureReal :: Test
testMeasureReal = test [
"t3" ~: testConcreteFilesMany [] "tests/RoundTrip/t3.hk",
"t6" ~: testConcreteFiles "tests/RoundTrip/t6.0.hk" "tests/RoundTrip/t6.expected.hk",
"t7" ~: testConcreteFiles "tests/RoundTrip/t7.0.hk" "tests/RoundTrip/t7.expected.hk",
"t7n" ~: testConcreteFiles "tests/RoundTrip/t7n.0.hk" "tests/RoundTrip/t7n.expected.hk",
"t8'" ~: testConcreteFiles "tests/RoundTrip/t8'.0.hk" "tests/RoundTrip/t8'.expected.hk", -- Normal is conjugate to normal
"t9" ~: testConcreteFiles "tests/RoundTrip/t9.0.hk" "tests/RoundTrip/t9.expected.hk",
"t13" ~: testConcreteFiles "tests/RoundTrip/t13.0.hk" "tests/RoundTrip/t13.expected.hk",
"t14" ~: testConcreteFiles "tests/RoundTrip/t14.0.hk" "tests/RoundTrip/t14.expected.hk",
"t21" ~: testConcreteFile "tests/RoundTrip/t21.hk",
"t28" ~: testConcreteFilesMany [] "tests/RoundTrip/t28.hk",
"t31" ~: testConcreteFilesMany [] "tests/RoundTrip/t31.hk",
"t36" ~: testConcreteFilesMany [] "tests/RoundTrip/t36.hk",
"t37" ~: testConcreteFilesMany [] "tests/RoundTrip/t37.hk",
"t39" ~: testConcreteFilesMany [] "tests/RoundTrip/t39.hk",
"t40" ~: testConcreteFilesMany [] "tests/RoundTrip/t40.hk",
"t43" ~: testConcreteFiles "tests/RoundTrip/t43.0.hk" "tests/RoundTrip/t43.expected.hk",
"t43'" ~: testConcreteFiles "tests/RoundTrip/t43.1.hk" "tests/RoundTrip/t43.expected.hk",
"t45" ~: testConcreteFiles "tests/RoundTrip/t45.1.hk" "tests/RoundTrip/t45.expected.hk",
"t46" ~: testConcreteFilesMany [] "tests/RoundTrip/t45.0.hk",
"t50" ~: testConcreteFile "tests/RoundTrip/t50.hk",
"t51" ~: testConcreteFile "tests/RoundTrip/t51.hk",
"t68" ~: testConcreteFile "tests/RoundTrip/t68.hk",
"t68'" ~: testConcreteFile "tests/RoundTrip/t68'.hk",
"t70a" ~: testConcreteFiles "tests/RoundTrip/t70a.0.hk" "tests/RoundTrip/t70a.expected.hk",
"t71a" ~: testConcreteFiles "tests/RoundTrip/t71a.0.hk" "tests/RoundTrip/t71a.expected.hk",
"t72a" ~: testConcreteFiles "tests/RoundTrip/t72a.0.hk" "tests/RoundTrip/t72a.expected.hk",
"t73a" ~: testConcreteFiles "tests/RoundTrip/t73a.0.hk" "tests/RoundTrip/t73a.expected.hk",
"t74a" ~: testConcreteFiles "tests/RoundTrip/t74a.0.hk" "tests/RoundTrip/t74a.expected.hk",
"t70b" ~: testConcreteFiles "tests/RoundTrip/t70b.0.hk" "tests/RoundTrip/t70b.expected.hk",
"t71b" ~: testConcreteFiles "tests/RoundTrip/t71b.0.hk" "tests/RoundTrip/t71b.expected.hk",
"t72b" ~: testConcreteFiles "tests/RoundTrip/t72b.0.hk" "tests/RoundTrip/t72b.expected.hk",
"t73b" ~: testConcreteFiles "tests/RoundTrip/t73b.0.hk" "tests/RoundTrip/t73b.expected.hk",
"t74b" ~: testConcreteFiles "tests/RoundTrip/t74b.0.hk" "tests/RoundTrip/t74b.expected.hk",
"t70c" ~: testConcreteFiles "tests/RoundTrip/t70c.0.hk" "tests/RoundTrip/t70c.expected.hk",
"t71c" ~: testConcreteFiles "tests/RoundTrip/t71c.0.hk" "tests/RoundTrip/t71c.expected.hk",
"t72c" ~: testConcreteFiles "tests/RoundTrip/t72c.0.hk" "tests/RoundTrip/t72c.expected.hk",
"t73c" ~: testConcreteFiles "tests/RoundTrip/t73c.0.hk" "tests/RoundTrip/t73c.expected.hk",
"t74c" ~: testConcreteFiles "tests/RoundTrip/t74c.0.hk" "tests/RoundTrip/t74c.expected.hk",
"t70d" ~: testConcreteFiles "tests/RoundTrip/t70d.0.hk" "tests/RoundTrip/t70d.expected.hk",
"t71d" ~: testConcreteFiles "tests/RoundTrip/t71d.0.hk" "tests/RoundTrip/t71d.expected.hk",
"t72d" ~: testConcreteFiles "tests/RoundTrip/t72d.0.hk" "tests/RoundTrip/t72d.expected.hk",
"t73d" ~: testConcreteFiles "tests/RoundTrip/t73d.0.hk" "tests/RoundTrip/t73d.expected.hk",
"t74d" ~: testConcreteFiles "tests/RoundTrip/t74d.0.hk" "tests/RoundTrip/t74d.expected.hk",
"t76" ~: testConcreteFile "tests/RoundTrip/t76.hk",
"t78" ~: testConcreteFiles "tests/RoundTrip/t78.0.hk" "tests/RoundTrip/t78.expected.hk",
"t79" ~: testConcreteFiles "tests/RoundTrip/t79.0.hk" "tests/RoundTrip/t79.expected.hk", -- what does this simplify to?
"t80" ~: testConcreteFile "tests/RoundTrip/t80.hk",
"t81" ~: testConcreteFilesMany [] "tests/RoundTrip/t81.hk",
-- TODO "kalman" ~: testConcreteFile "tests/RoundTrip/kalman.hk",
-- TODO "seismic" ~: testConcreteFilesMany [] "tests/RoundTrip/seismic.hk",
"lebesgue1" ~: testConcreteFiles
"tests/RoundTrip/lebesgue1.hk"
"tests/RoundTrip/lebesgue1.expected.hk",
"lebesgue2" ~: testConcreteFiles
"tests/RoundTrip/lebesgue2.hk"
"tests/RoundTrip/lebesgue2.expected.hk",
"lebesgue3" ~: testConcreteFiles "tests/RoundTrip/lebesgue3.0.hk" "tests/RoundTrip/lebesgue3.expected.hk",
"testexponential" ~: testConcreteFile "tests/RoundTrip/testexponential.hk", -- Testing round-tripping of some other distributions
"testcauchy" ~: testConcreteFile "tests/RoundTrip/testcauchy.hk",
"exceptionLebesgue" ~: testConcreteFiles "tests/RoundTrip/exceptionLebesgue.0.hk" "tests/RoundTrip/exceptionLebesgue.expected.hk",
"exceptionUniform" ~: testConcreteFiles "tests/RoundTrip/exceptionUniform.0.hk" "tests/RoundTrip/exceptionUniform.expected.hk"
-- TODO "two_coins" ~: testConcreteFile "tests/RoundTrip/two_coins.hk" -- needs support for lists
]
testMeasureNat :: Test
testMeasureNat = test [
"size" ~: testConcreteFiles "tests/RoundTrip/size.0.hk" "tests/RoundTrip/size.expected.hk"
]
testMeasureInt :: Test
testMeasureInt = test [
"t75" ~: testConcreteFile "tests/RoundTrip/t75.hk",
"t75'" ~: testConcreteFile "tests/RoundTrip/t75'.hk",
"t83" ~: testConcreteFiles "tests/RoundTrip/t83.0.hk" "tests/RoundTrip/t83.expected.hk",
"exceptionCounting" ~: testConcreteFilesMany [] "tests/RoundTrip/exceptionCounting.hk", -- Jacques wrote: "bug: [simp_pw_equal] implicitly assumes the ambient measure is Lebesgue"
"exceptionSuperpose" ~: testConcreteFiles "tests/RoundTrip/exceptionSuperpose.0.hk" "tests/RoundTrip/exceptionSuperpose.expected.hk"
]
testMeasurePair :: Test
testMeasurePair = test [
"t4" ~: testConcreteFiles "tests/RoundTrip/t4.0.hk" "tests/RoundTrip/t4.expected.hk",
"t8" ~: testConcreteFile "tests/RoundTrip/t8.hk", -- For sampling efficiency (to keep importance weights at or close to 1); t8 below should read back to uses of "normal", not uses of "lebesgue" then "weight".
"t23" ~: testConcreteFiles "tests/RoundTrip/t23.0.hk" "tests/RoundTrip/t23.expected.hk", -- was called bayesNet in Nov.06 msg by Ken for exact inference
"t48" ~: testConcreteFile "tests/RoundTrip/t48.hk",
"t52" ~: testConcreteFile "tests/RoundTrip/t52.hk", -- Example 1 from Chang & Pollard's Conditioning as Disintegration
"dup" ~: testConcreteFiles "tests/RoundTrip/dup.0.hk" "tests/RoundTrip/dup.expected.hk",
"norm" ~: testConcreteFile "tests/RoundTrip/norm.hk",
"norm_nox" ~: testConcreteFiles "tests/RoundTrip/norm_nox.0.hk" "tests/RoundTrip/norm_nox.expected.hk",
"norm_noy" ~: testConcreteFiles "tests/RoundTrip/norm_noy.0.hk" "tests/RoundTrip/norm_noy.expected.hk",
"flipped_norm" ~: testConcreteFiles "tests/RoundTrip/flipped_norm.0.hk" "tests/RoundTrip/flipped_norm.expected.hk",
"priorProp" ~: testConcreteFiles "tests/RoundTrip/priorProp.0.hk" "tests/RoundTrip/priorProp.expected.hk",
"mhPriorProp" ~: testConcreteFiles "tests/RoundTrip/mhPriorProp.0.hk" "tests/RoundTrip/mhPriorProp.expected.hk",
"unif2" ~: testConcreteFile "tests/RoundTrip/unif2.hk",
"easyHMM" ~: testConcreteFile "tests/RoundTrip/easyHMM.hk",
"testMCMCPriorProp" ~: testConcreteFile "tests/RoundTrip/testMCMCPriorProp.hk"
]
testStdChiSqRelations :: Test
testStdChiSqRelations = test [
"t_stdChiSq_superposition" ~: testConcreteFiles "tests/RoundTrip2/t_stdChiSq_superposition.0.hk" "tests/RoundTrip2/t_stdChiSq_superposition.expected.hk",
"t_uniform_to_stdChiSq" ~: testConcreteFiles "tests/RoundTrip2/t_uniform_to_stdChiSq.0.hk" "tests/RoundTrip2/t_uniform_to_stdChiSq.expected.hk",
"t_stdChiSq_to_beta" ~: testConcreteFiles "tests/RoundTrip2/t_stdChiSq_to_beta.0.hk" "tests/RoundTrip2/t_stdChiSq_to_beta.expected.hk",
"t_stdChiSq_to_gamma" ~: testConcreteFiles "tests/RoundTrip/t_stdChiSq_to_gamma.0.hk" "tests/RoundTrip/t_stdChiSq_to_gamma.expected.hk",
"t_stdChiSq_to_exponential" ~: testConcreteFiles "tests/RoundTrip2/t_stdChiSq_to_exponential.0.hk" "tests/RoundTrip2/t_stdChiSq_to_exponential.expected.hk",
"t_rayleigh_to_stdChiSq" ~: testConcreteFiles "tests/RoundTrip2/t_rayleigh_to_stdChiSq.0.hk" "tests/RoundTrip2/t_rayleigh_to_stdChiSq.expected.hk"
]
testCauchyRelations :: Test
testCauchyRelations = test [
"t_cauchy_add_transformation" ~: testConcreteFiles "tests/RoundTrip2/t_cauchy_add_transformation.0.hk" "tests/RoundTrip2/t_cauchy_add_transformation.expected.hk",
"t_cauchy_sub_transformation" ~: testConcreteFiles "tests/RoundTrip2/t_cauchy_sub_transformation.0.hk" "tests/RoundTrip2/t_cauchy_sub_transformation.expected.hk"
]
testExponentialRelations :: Test
testExponentialRelations = test [
"t_pareto_to_exponential" ~: testConcreteFiles "tests/RoundTrip/t_pareto_to_exponential.0.hk" "tests/RoundTrip/t_pareto_to_exponential.expected.hk",
"t_exponential_to_pareto" ~: testConcreteFiles "tests/RoundTrip/t_exponential_to_pareto.0.hk" "tests/RoundTrip/t_exponential_to_pareto.expected.hk",
"t_exponential_to_laplace" ~: testConcreteFiles "tests/RoundTrip/t_exponential_to_laplace.0.hk" "tests/RoundTrip/t_exponential_to_laplace.expected.hk",
"t_exponential_to_beta" ~: testConcreteFiles "tests/RoundTrip/t_exponential_to_beta.0.hk" "tests/RoundTrip/t_exponential_to_beta.expected.hk",
"t_exponential_sum_to_erlang" ~: testConcreteFiles "tests/RoundTrip/t_exponential_sum_to_erlang.0.hk" "tests/RoundTrip/t_exponential_sum_to_erlang.expected.hk",
"t_exp_erlang_to_pareto" ~: testConcreteFiles "tests/RoundTrip/t_exp_erlang_to_pareto.0.hk" "tests/RoundTrip/t_exp_erlang_to_pareto.expected.hk",
"t_exponential_sum_rates" ~: testConcreteFiles "tests/RoundTrip/t_exponential_sum_rates.0.hk" "tests/RoundTrip/t_exponential_sum_rates.expected.hk",
"t_exponential_to_stdChiSq" ~: testConcreteFiles "tests/RoundTrip/t_exponential_to_stdChiSq.0.hk" "tests/RoundTrip/t_exponential_to_stdChiSq.expected.hk",
"t_exponential_scale_closure" ~: testConcreteFiles "tests/RoundTrip/t_exponential_scale_closure.0.hk" "tests/RoundTrip/t_exponential_scale_closure.expected.hk"
]
testErlangRelations :: Test
testErlangRelations = test [
"t_erlang_to_erlang" ~: testConcreteFiles "tests/RoundTrip/t_erlang_to_erlang.0.hk" "tests/RoundTrip/t_erlang_to_erlang.expected.hk",
"t_erlang_to_erlang_2" ~: testConcreteFiles "tests/RoundTrip/t_erlang_to_erlang_1.0.hk" "tests/RoundTrip/t_erlang_to_erlang_1.expected.hk",
"t_exponential_to_erlang" ~: testConcreteFiles "tests/RoundTrip/t_exponential_to_erlang.0.hk" "tests/RoundTrip/t_exponential_to_erlang.expected.hk",
"t_erlang_to_pareto" ~: testConcreteFiles "tests/RoundTrip2/t_erlang_to_pareto.0.hk" "tests/RoundTrip2/t_erlang_to_pareto.expected.hk",
"t_erlang_to_stdChiSq" ~: testConcreteFiles "tests/RoundTrip2/t_erlang_to_stdChiSq.0.hk" "tests/RoundTrip2/t_erlang_to_stdChiSq.expected.hk"
]
testRayleighRelations :: Test
testRayleighRelations = test [
"t_exponential_to_rayleigh" ~: testConcreteFiles "tests/RoundTrip2/t_exponential_to_rayleigh.0.hk" "tests/RoundTrip2/t_exponential_to_rayleigh.expected.hk",
"t_gamma_to_rayleigh" ~: testConcreteFiles "tests/RoundTrip2/t_gamma_to_rayleigh.0.hk" "tests/RoundTrip2/t_gamma_to_rayleigh.expected.hk",
"t_weibull_to_rayleigh" ~: testConcreteFiles "tests/RoundTrip2/t_weibull_to_rayleigh.0.hk" "tests/RoundTrip2/t_weibull_to_rayleigh.expected.hk"
]
testOther :: Test
testOther = test [
"t82" ~: testConcreteFiles "tests/RoundTrip/t82.0.hk" "tests/RoundTrip/t82.expected.hk",
"testRoadmapProg1" ~: testConcreteFile "tests/RoundTrip/testRoadmapProg1.hk",
"testKernel" ~: testConcreteFiles "tests/RoundTrip/testKernel.0.hk" "tests/RoundTrip/testKernel.expected.hk",
"LDA" ~: testConcreteFilesET defaultMapleOptions
[ "tests/RoundTrip/lda2.hk" ]
"tests/RoundTrip/lda2_res.hk",
"LDA - hand simplified" ~: testConcreteFilesET defaultMapleOptions
[ "tests/RoundTrip/lda3-ds.0.hk"
, "tests/RoundTrip/lda3-ds.1.hk" ]
"tests/RoundTrip/lda3-ds.expected.hk",
"gmm_gibbs" ~: testConcreteFilesET
defaultMapleOptions { timelimit=300 }
[ "tests/RoundTrip/gmm_gibbs.0.hk" ]
"tests/RoundTrip/gmm_gibbs.expected.hk",
"naive_bayes_gibbs" ~: testConcreteFilesET defaultMapleOptions
[ "tests/RoundTrip/naive_bayes_gibbs.0.hk" ]
"tests/RoundTrip/naive_bayes_gibbs.expected.hk",
"\"thermometer\" pipeline" ~:
testConcreteFilesET defaultMapleOptions
[ "tests/RoundTrip/thermometer_workflow.hk" ]
"tests/RoundTrip/thermometer_workflow_res.hk",
"\"burglary\" pipeline" ~:
testConcreteFilesET defaultMapleOptions
[ "tests/RoundTrip/burglary_workflow.hk" ]
"tests/RoundTrip/burglary_workflow_res.hk"
--"testFalseDetection" ~: testStriv (lam seismicFalseDetection),
--"testTrueDetection" ~: testStriv (lam2 seismicTrueDetection)
--"testTrueDetectionL" ~: testStriv tdl,
--"testTrueDetectionR" ~: testStriv tdr
]
allTests :: Test
allTests = test
[ testMeasureUnit
, testMeasureProb
, testMeasureReal
, testMeasurePair
, testMeasureNat
, testMeasureInt
, testErlangRelations
, testStdChiSqRelations
, testCauchyRelations
, testExponentialRelations
, testRayleighRelations
, testCauchyRelations
, testOther
]
----------------------------------------------------------------
t46 :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
t46 = normal (real_ 4) (prob_ 5) >>= \x -> dirac (if_ (x < (real_ 3)) (x*x) (x-one))
t47 :: (ABT Term abt) => abt '[] ('HMeasure 'HReal)
t47 = unsafeSuperpose
[ (one, normal (real_ 4) (prob_ 5) >>= \x -> if_ (x < (real_ 3)) (dirac (x*x)) (reject sing))
, (one, normal (real_ 4) (prob_ 5) >>= \x -> if_ (x < (real_ 3)) (reject sing) (dirac (x-one)))
]
-- pull out some of the intermediate expressions for independent study
expr1 :: (ABT Term abt) => abt '[] ('HReal ':-> 'HProb)
expr1 =
lam $ \x0 ->
(lam $ \_ ->
lam $ \x2 ->
lam $ \x3 ->
(lam $ \x4 ->
zero
+ one
* (lam $ \x5 ->
(lam $ \x6 ->
zero
+ exp (negate (x2 - zero) * (x2 - zero) / fromProb ((fromRational 2) * exp (log (fromRational 5) * (fromRational 2))))
/ (fromRational 5)
/ exp (log ((fromRational 2) * pi) * half)
* (lam $ \x7 -> x7 `app` unit) `app` x6)
`app` (lam $ \_ ->
(lam $ \x7 ->
(lam $ \x8 -> x8 `app` x2)
`app` (lam $ \_ ->
(lam $ \x9 ->
(lam $ \x10 -> x10 `app` unit)
`app` (lam $ \x10 ->
(lam $ \x11 ->
(lam $ \x12 -> x12 `app` x2)
`app` (lam $ \_ ->
(lam $ \x13 -> x13 `app` pair x2 x10) `app` x11))
`app` x9))
`app` x7))
`app` x5))
`app` x4)
`app` (lam $ \x4 ->
(lam $ \x5 -> x5 `app` (x4 `unpair` \_ x7 -> x7)) `app` x3)
)
`app` unit
`app` x0
`app` (lam $ \_ -> one)
expr2 :: (ABT Term abt) => abt '[] ('HReal ':-> 'HReal ':-> 'HProb)
expr2 =
lam $ \x1 ->
lam $ \x2 ->
(lam $ \x3 ->
lam $ \x4 ->
lam $ \x5 ->
(lam $ \x6 ->
zero
+ one
* (lam $ \x7 ->
(lam $ \x8 ->
zero
+ exp (((negate x4) - x3) * (x4 - x3) / fromProb ((fromRational 2) * exp (log one * (fromRational 2))))
/ one
/ exp (log ((fromRational 2) * pi) * half)
* (lam $ \x9 -> x9 `app` unit) `app` x8)
`app` (lam $ \_ ->
(lam $ \x9 ->
(lam $ \x10 -> x10 `app` x4)
`app` (lam $ \_ ->
(lam $ \x11 ->
(lam $ \x12 -> x12 `app` unit)
`app` (lam $ \x12 ->
(lam $ \x13 ->
(lam $ \x14 -> x14 `app` x4)
`app` (lam $ \_ ->
(lam $ \x15 -> x15 `app` pair x4 x12) `app` x13))
`app` x11))
`app` x9))
`app` x7))
`app` x6)
`app` (lam $ \x6 ->
(lam $ \x7 -> x7 `app` (x6 `unpair` \_ x9 -> x9)) `app` x5)
)
`app` x1
`app` x2
`app` (lam $ \_ -> one)
-- the one we need in testKernel
expr3 :: (ABT Term abt)
=> abt '[] (d ':-> 'HProb)
-> abt '[] (d ':-> d ':-> 'HProb)
-> abt '[] d -> abt '[] d -> abt '[] 'HProb
expr3 x0 x1 x2 x3 =
let q = x0 `app` x3
/ x1 `app` x2 `app` x3
* x1 `app` x3 `app` x2
/ x0 `app` x2
in if_ (one < q) one q
-- testKernel :: Sample IO ('HReal ':-> 'HMeasure 'HReal)
testKernel :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure 'HReal)
testKernel =
-- Below is the output of testMcmc as of 2014-11-05
let_ expr1 $ \x0 ->
let_ expr2 $ \x1 ->
lam $ \x2 ->
normal x2 one >>= \x3 ->
let_ (expr3 x0 x1 x2 x3) $ \x4 ->
bern x4 >>= \x5 ->
dirac (if_ x5 x3 x2)
-- this should be equivalent to the above
testKernel2 :: (ABT Term abt) => abt '[] ('HReal ':-> 'HMeasure 'HReal)
testKernel2 =
lam $ \x2 ->
normal x2 one >>= \x3 ->
let q = exp(negate (real_ 1)/(real_ 50)*(x3-x2)*(x3+x2)) in
let_ (if_ (one < q) one q) $ \x4 ->
bern x4 >>= \x5 ->
dirac $ if_ x5 x3 x2
-- this comes from {Tests.Lazy,Examples.EasierRoadmap}.easierRoadmapProg1. It is the
-- program post-disintegrate, as passed to Maple to simplify
rmProg1 :: (ABT Term abt) => abt '[]
(HUnit
':-> HPair 'HReal 'HReal
':-> 'HMeasure (HPair 'HProb 'HProb))
rmProg1 =
lam $ \_ ->
lam $ \x1 ->
x1 `unpair` \x2 x3 ->
withWeight one $
withWeight one $
unsafeSuperpose
[(one,
withWeight one $
lebesgue >>= \x4 ->
unsafeSuperpose
[(one,
withWeight one $
lebesgue >>= \x5 ->
withWeight one $
lebesgue >>= \x6 ->
withWeight
( exp (negate (x3 - x6) * (x3 - x6)
/ (fromProb ((fromRational 2) * exp (log (unsafeProb x5) * (fromRational 2)))))
/ unsafeProb x5
/ (exp (log ((fromRational 2) * pi) * half))) $
withWeight one $
lebesgue >>= \x7 ->
withWeight
( exp (negate (x6 - x7) * (x6 - x7)
/ (fromProb ((fromRational 2) * exp (log (unsafeProb x4) * (fromRational 2)))))
/ (unsafeProb x4)
/ (exp (log ((fromRational 2) * pi) * half))) $
withWeight
( exp (negate (x2 - x7) * (x2 - x7)
/ (fromProb ((fromRational 2) * exp (log (unsafeProb x5) * (fromRational 2)))))
/ unsafeProb x5
/ (exp (log ((fromRational 2) * pi) * half))) $
withWeight
( exp (negate x7 * x7
/ (fromProb ((fromRational 2) * exp (log (unsafeProb x4) * (fromRational 2)))))
/ unsafeProb x4
/ (exp (log ((fromRational 2) * pi) * half))) $
withWeight (recip (fromRational 3)) $
unsafeSuperpose
[(one,
if_ (x5 < (real_ 4))
(if_ (one < x5)
(withWeight (recip (prob_ 5)) $
unsafeSuperpose
[(one,
if_ (x4 < (real_ 8))
(if_ ((real_ 3) < x4)
(dirac (pair (unsafeProb x4)
(unsafeProb x5)))
(reject sing))
(reject sing))
, (one, reject sing)])
(reject sing))
(reject sing))
, (one, reject sing)])
, (one, reject sing)])
, (one, reject sing)]
-- this comes from Examples.EasierRoadmap.easierRoadmapProg4'.
-- TODO: this needs to be regenerated from original program
rmProg4
:: (ABT Term abt)
=> abt '[]
(HPair 'HReal 'HReal
':-> HPair 'HProb 'HProb
':-> 'HMeasure (HPair (HPair 'HProb 'HProb) 'HProb))
rmProg4 =
lam $ \x0 ->
let_ (lam $ \x1 ->
(lam $ \x2 ->
lam $ \x3 ->
x3 `unpair` \x4 x5 ->
let_ one $ \x6 ->
let_ (let_ one $ \x7 ->
let_ (let_ one $ \x8 ->
let_ (let_ one $ \x9 ->
let_ (let_ one $ \x10 ->
let_ (let_ one $ \x11 ->
let_ (x2 `unpair` \x12 _ ->
x2 `unpair` \x14 _ ->
x2 `unpair` \x16 _ ->
x2 `unpair` \_ x19 ->
x2 `unpair` \_ x21 ->
x2 `unpair` \_ x23 ->
x2 `unpair` \x24 _ ->
x2 `unpair` \x26 _ ->
x2 `unpair` \_ x29 ->
x2 `unpair` \_ x31 ->
let_ (recip pi
* exp ((x12 * x14 * (fromProb x4 * fromProb x4)
* (fromRational 2)
+ fromProb x4 * fromProb x4 * x16 * x19
* (negate (fromRational 2))
+ x21 * x23 * (fromProb x4 * fromProb x4)
+ fromProb x5 * fromProb x5 * (x24 * x26)
+ fromProb x5 * fromProb x5 * (x29 * x31))
* recip (fromProb x4 * fromProb x4
* (fromProb x4 * fromProb x4)
+ fromProb x5 * fromProb x5
* (fromProb x4 * fromProb x4)
* (fromRational 3)
+ fromProb x5 * fromProb x5
* (fromProb x5 * fromProb x5))
* (negate half))
* exp (log (exp (log x4 * (fromRational 4))
+ exp (log x5 * (fromRational 2))
* exp (log x4 * (fromRational 2))
* (fromRational 3)
+ exp (log x5 * (fromRational 4)))
* (negate half))
* (fromRational 1)/(fromRational 10)) $ \x32 ->
let_ (let_ (recip (fromRational 3)) $ \x33 ->
let_ (let_ one $ \x34 ->
let_ (if_ (fromProb x5 < (fromRational 4))
(if_ (one < fromProb x5)
(let_ (recip (fromRational 5)) $ \x35 ->
let_ (let_ one $ \x36 ->
let_ (if_ (fromProb x4
< (fromRational 8))
(if_ ((fromRational 3)
< fromProb x4)
(let_ (fromRational 5) $ \x37 ->
let_ (let_ (pair x4 x5) $ \x38 ->
pair (dirac x38)
(lam $ \x39 ->
x39
`app` x38)) $ \x38 ->
pair (withWeight x37 $
x38 `unpair` \x39 _ ->
x39)
(lam $ \x39 ->
zero
+ x37
* (x38 `unpair` \_ x41 ->
x41)
`app` x39))
(pair (reject sing)
(lam $ \x37 ->
zero)))
(pair (reject sing)
(lam $ \x37 ->
zero))) $ \x37 ->
let_ one $ \x38 ->
let_ (pair (reject sing)
(lam $ \x39 ->
zero)) $ \x39 ->
pair (unsafeSuperpose [(x36,
x37 `unpair` \x40 x41 ->
x40),
(x38,
x39 `unpair` \x40 x41 ->
x40)])
(lam $ \x40 ->
zero
+ x36
* (x37 `unpair` \x41 x42 ->
x42)
`app` x40
+ x38
* (x39 `unpair` \x41 x42 ->
x42)
`app` x40)) $ \x36 ->
pair (withWeight x35 $
x36 `unpair` \x37 x38 ->
x37)
(lam $ \x37 ->
zero
+ x35
* (x36 `unpair` \x38 x39 ->
x39)
`app` x37))
(pair (reject sing)
(lam $ \x35 -> zero)))
(pair (reject sing)
(lam $ \x35 -> zero))) $ \x35 ->
let_ one $ \x36 ->
let_ (pair (reject sing)
(lam $ \x37 -> zero)) $ \x37 ->
pair (unsafeSuperpose [(x34,
x35 `unpair` \x38 x39 ->
x38),
(x36,
x37 `unpair` \x38 x39 ->
x38)])
(lam $ \x38 ->
zero
+ x34
* (x35 `unpair` \x39 x40 -> x40)
`app` x38
+ x36
* (x37 `unpair` \x39 x40 -> x40)
`app` x38)) $ \x34 ->
pair (withWeight x33 $ x34 `unpair` \x35 x36 -> x35)
(lam $ \x35 ->
zero
+ x33
* (x34 `unpair` \x36 x37 -> x37)
`app` x35)) $ \x33 ->
pair (withWeight x32 $ x33 `unpair` \x34 x35 -> x34)
(lam $ \x34 ->
zero
+ x32
* (x33 `unpair` \x35 x36 -> x36)
`app` x34)) $ \x12 ->
pair (withWeight x11 $ x12 `unpair` \x13 x14 -> x13)
(lam $ \x13 ->
zero
+ x11
* (x12 `unpair` \x14 x15 -> x15) `app` x13)) $ \x11 ->
let_ one $ \x12 ->
let_ (pair (reject sing) (lam $ \x13 -> zero)) $ \x13 ->
pair (unsafeSuperpose [(x10, x11 `unpair` \x14 x15 -> x14),
(x12, x13 `unpair` \x14 x15 -> x14)])
(lam $ \x14 ->
zero + x10 * (x11 `unpair` \x15 x16 -> x16) `app` x14
+ x12 * (x13 `unpair` \x15 x16 -> x16) `app` x14)) $ \x10 ->
pair (withWeight x9 $ x10 `unpair` \x11 x12 -> x11)
(lam $ \x11 ->
zero + x9 * (x10 `unpair` \x12 x13 -> x13) `app` x11)) $ \x9 ->
let_ one $ \x10 ->
let_ (pair (reject sing) (lam $ \x11 -> zero)) $ \x11 ->
pair (unsafeSuperpose [(x8, x9 `unpair` \x12 x13 -> x12),
(x10, x11 `unpair` \x12 x13 -> x12)])
(lam $ \x12 ->
zero + x8 * (x9 `unpair` \x13 x14 -> x14) `app` x12
+ x10 * (x11 `unpair` \x13 x14 -> x14) `app` x12)) $ \x8 ->
pair (withWeight x7 $ x8 `unpair` \x9 x10 -> x9)
(lam $ \x9 ->
zero + x7 * (x8 `unpair` \x10 x11 -> x11) `app` x9)) $ \x7 ->
pair (withWeight x6 $ x7 `unpair` \x8 x9 -> x8)
(lam $ \x8 -> zero + x6 * (x7 `unpair` \x9 x10 -> x10) `app` x8))
`app` x0
`app` x1 `unpair` \x2 x3 ->
x3 `app` (lam $ \x4 -> one)) $ \x1 ->
lam $ \x2 ->
(x2 `unpair` \x3 x4 ->
unsafeSuperpose [(half,
uniform (real_ 3) (real_ 8) >>= \x5 -> dirac (pair (unsafeProb x5) x4)),
(half,
uniform one (real_ 4) >>= \x5 ->
dirac (pair x3 (unsafeProb x5)))]) >>= \x3 ->
dirac (pair x3 (x1 `app` x3 / x1 `app` x2))
pairReject
:: (ABT Term abt)
=> abt '[] (HPair ('HMeasure 'HReal) 'HReal)
pairReject =
pair (reject (SMeasure SReal) >>= \_ -> dirac one)
(real_ 2)
-- from a web question
-- these are mathematically equivalent, albeit at different types
chal1 :: (ABT Term abt) => abt '[]
('HProb ':-> 'HReal ':-> 'HReal ':-> 'HReal ':-> 'HMeasure HBool)
chal1 =
lam $ \sigma ->
lam $ \a ->
lam $ \b ->
lam $ \c ->
normal a sigma >>= \ya ->
normal b sigma >>= \yb ->
normal c sigma >>= \yc ->
dirac (yb < ya && yc < ya)
chal2 :: (ABT Term abt) => abt '[]
('HProb ':-> 'HReal ':-> 'HReal ':-> 'HReal ':-> 'HMeasure 'HReal)
chal2 =
lam $ \sigma ->
lam $ \a ->
lam $ \b ->
lam $ \c ->
normal a sigma >>= \ya ->
normal b sigma >>= \yb ->
normal c sigma >>= \yc ->
dirac (if_ (yb < ya && yc < ya) one zero)
chal3 :: (ABT Term abt) => abt '[] ('HProb ':-> 'HMeasure 'HReal)
chal3 = lam $ \sigma -> app3 (app chal2 sigma) zero zero zero
--seismic :: (ABT Term abt) => abt '[]
-- (SE.HStation
-- ':-> HPair 'HReal (HPair 'HReal (HPair 'HProb 'HReal))
-- ':-> HPair 'HReal (HPair 'HReal (HPair 'HReal 'HProb))
-- ':-> 'HMeasure 'HProb)
--seismic = lam3 (\s e d -> dirac $ SE.densT s e d)
easyHMM :: (ABT Term abt) => abt '[]
('HMeasure (HPair (HPair 'HReal 'HReal) (HPair 'HProb 'HProb)))
easyHMM =
gamma (prob_ 3) one >>= \noiseT ->
gamma_1_1 >>= \noiseE ->
normal zero noiseT >>= \x1 ->
normal x1 noiseE >>= \m1 ->
normal x1 noiseT >>= \x2 ->
normal x2 noiseE >>= \m2 ->
dirac (pair (pair m1 m2) (pair noiseT noiseE))