diff --git a/Examples/Examples.hs b/Examples/Examples.hs deleted file mode 100644 --- a/Examples/Examples.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE RankNTypes, DataKinds, NoMonomorphismRestriction, BangPatterns #-} - -module Examples where - -import Types -import Data.Dynamic -import Control.Monad - -import InterpreterMH hiding (main) -import Visual - -bayesian_polynomial_regression = undefined - -sparse_linear_regression = undefined - -logistic_regression = undefined - -outlier_detection = undefined - -change_point_model = undefined - -friends_who_smoke = undefined - -latent_dirichelt_allocation = undefined - -categorical_mixture = undefined - -gaussian_mixture = undefined - -naive_bayes = undefined - -hidden_markov_model = undefined - -matrix_factorization = undefined - -rvm = undefined - -item_response_theory = undefined - -gaussian_process = undefined - -hawkes_process = undefined - -bayesian_neural_network = undefined diff --git a/Examples/Tests.hs b/Examples/Tests.hs --- a/Examples/Tests.hs +++ b/Examples/Tests.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RankNTypes, NoMonomorphismRestriction, BangPatterns #-} -module Tests where +module Examples.Tests where import Types import Data.Dynamic diff --git a/Language/Hakaru/Symbolic.hs b/Language/Hakaru/Symbolic.hs --- a/Language/Hakaru/Symbolic.hs +++ b/Language/Hakaru/Symbolic.hs @@ -69,9 +69,9 @@ -- Borel's Paradox exp3 = unconditioned (uniformD (real 1) (real 2)) `bind` \s -> unconditioned (uniformC (real (-1)) (real 1)) `bind` \x -> - let y = (InterpreterSymbolic.sqrt ((real 1 ) `minus` - (InterpreterSymbolic.exp s (real 2)))) `mul` - (InterpreterSymbolic.sin x) in ret y + let y = (Language.Hakaru.Symbolic.sqrt ((real 1 ) `minus` + (Language.Hakaru.Symbolic.exp s (real 2)))) `mul` + (Language.Hakaru.Symbolic.sin x) in ret y test = view exp1 test2 = view exp2 diff --git a/Language/Hakaru/Syntax.hs b/Language/Hakaru/Syntax.hs new file mode 100644 --- /dev/null +++ b/Language/Hakaru/Syntax.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE TypeFamilies, ConstraintKinds, GADTs, FlexibleContexts #-} + +module Language.Hakaru.Syntax where + +-- The syntax + +import GHC.Exts (Constraint) + +-- TODO: The pretty-printing semantics + +import qualified Text.PrettyPrint as PP + +-- The importance-sampling semantics + +import Types (Cond, CSampler) +import Data.Dynamic (Typeable) +import qualified Data.Number.LogFloat as LF +import qualified Language.Hakaru.ImportanceSampler as IS + +-- The Metropolis-Hastings semantics + +import qualified Language.Hakaru.Metropolis as MH + +-- The syntax + +data Prob +data Measure a +data Dist a + +class Mochastic repr where + type Type repr a :: Constraint + real :: Double -> repr Double + bool :: Bool -> repr Bool + add, mul :: repr Double -> repr Double -> repr Double + neg :: repr Double -> repr Double + neg = mul (real (-1)) + logFloat, logToLogFloat + :: repr Double -> repr Prob + unbool :: repr Bool -> repr c -> repr c + -> repr c + pair :: repr a -> repr b -> repr (a, b) + unpair :: repr (a, b) -> (repr a -> repr b -> repr c) + -> repr c + inl :: repr a -> repr (Either a b) + inr :: repr b -> repr (Either a b) + uneither :: repr (Either a b) -> (repr a -> repr c) -> (repr b -> repr c) + -> repr c + nil :: repr [a] + cons :: repr a -> repr [a] -> repr [a] + unlist :: repr [a] -> repr c -> (repr a -> repr [a] -> repr c) + -> repr c + ret :: repr a -> repr (Measure a) + bind :: repr (Measure a) -> (repr a -> repr (Measure b)) + -> repr (Measure b) + conditioned, unconditioned :: repr (Dist a) -> repr (Measure a) + factor :: repr Prob -> repr (Measure ()) + dirac :: (Type repr a) => repr a -> repr (Dist a) + categorical :: (Type repr a) => repr [(a, Prob)] -> repr (Dist a) + bern :: (Type repr Bool) => repr Double -> repr (Dist Bool) + bern p = categorical $ + cons (pair (bool True) (logFloat p)) $ + cons (pair (bool False) (logFloat (add (real 1) (neg p)))) $ + nil + normal, uniform + :: repr Double -> repr Double -> repr (Dist Double) + poisson :: repr Double -> repr (Dist Int) + +-- TODO: The initial (AST) "semantics" +-- (Hey Oleg, is there any better way to deal with the Type constraint, so that +-- the AST constructor doesn't have to take a repr constructor argument?) + +data AST repr a where + Real :: Double -> AST repr Double + Unbool :: AST repr Bool -> AST repr c -> AST repr c -> AST repr c + Categorical :: (Type repr a) => AST repr [(a, Prob)] -> AST repr (Dist a) + -- ... + +instance (Mochastic repr) => Mochastic (AST repr) where + type Type (AST repr) a = Type repr a + real = Real + unbool = Unbool + categorical = Categorical + -- ... + +eval :: (Mochastic repr) => AST repr a -> repr a +eval (Real x) = real x +eval (Unbool b x y) = unbool (eval b) (eval x) (eval y) +eval (Categorical xps) = categorical (eval xps) +-- ... + +-- TODO: The pretty-printing semantics + +newtype PP a = PP (Int -> PP.Doc) + +-- The importance-sampling semantics + +newtype IS a = IS (IS' a) +type family IS' a +type instance IS' (Measure a) = IS.Measure (IS' a) +type instance IS' (Dist a) = CSampler (IS' a) +type instance IS' [a] = [IS' a] +type instance IS' (a, b) = (IS' a, IS' b) +type instance IS' (Either a b) = Either (IS' a) (IS' b) +type instance IS' () = () +type instance IS' Bool = Bool +type instance IS' Double = Double +type instance IS' Prob = LF.LogFloat +type instance IS' Int = Int + +instance Mochastic IS where + type Type IS a = (Eq (IS' a), Typeable (IS' a)) + real = IS + bool = IS + add (IS x) (IS y) = IS (x + y) + mul (IS x) (IS y) = IS (x * y) + neg (IS x) = IS (-x) + logFloat (IS x) = IS (LF.logFloat x) + logToLogFloat (IS x) = IS (LF.logToLogFloat x) + unbool (IS b) x y = if b then x else y + pair (IS x) (IS y) = IS (x, y) + unpair (IS (x, y)) c = c (IS x) (IS y) + inl (IS x) = IS (Left x) + inr (IS x) = IS (Right x) + uneither (IS e) c d = either (c . IS) (d . IS) e + nil = IS [] + cons (IS x) (IS xs) = IS (x:xs) + unlist (IS []) n c = n + unlist (IS (x:xs)) n c = c (IS x) (IS xs) + ret (IS x) = IS (return x) + bind (IS m) k = IS (m >>= \x -> case k (IS x) of IS n -> n) + conditioned (IS dist) = IS (IS.conditioned dist) + unconditioned (IS dist) = IS (IS.unconditioned dist) + factor (IS p) = IS (IS.factor p) + dirac (IS x) = IS (IS.dirac x) + categorical (IS xps) = IS (IS.categorical xps) + bern (IS p) = IS (IS.bern p) + normal (IS m) (IS s) = IS (IS.normal m s) + uniform (IS lo) (IS hi) = IS (IS.uniformC lo hi) + poisson (IS l) = IS (IS.poisson l) + +-- The Metropolis-Hastings semantics + +newtype MH a = MH (MH' a) +type family MH' a +type instance MH' (Measure a) = MH.Measure (MH' a) +type instance MH' (Dist a) = MH.Cond -> MH.Measure (MH' a) +type instance MH' [a] = [MH' a] +type instance MH' (a, b) = (MH' a, MH' b) +type instance MH' (Either a b) = Either (MH' a) (MH' b) +type instance MH' () = () +type instance MH' Bool = Bool +type instance MH' Double = Double +type instance MH' Prob = MH.Likelihood +type instance MH' Int = Int + +instance Mochastic MH where + type Type MH a = (Eq (MH' a), Typeable (MH' a), Show (MH' a)) + real = MH + bool = MH + add (MH x) (MH y) = MH (x + y) + mul (MH x) (MH y) = MH (x * y) + neg (MH x) = MH (-x) + logFloat (MH x) = MH (LF.logFromLogFloat (LF.logFloat x)) + logToLogFloat (MH x) = MH (LF.logFromLogFloat (LF.logToLogFloat x)) + unbool (MH b) x y = if b then x else y + pair (MH x) (MH y) = MH (x, y) + unpair (MH (x, y)) c = c (MH x) (MH y) + inl (MH x) = MH (Left x) + inr (MH x) = MH (Right x) + uneither (MH e) c d = either (c . MH) (d . MH) e + nil = MH [] + cons (MH x) (MH xs) = MH (x:xs) + unlist (MH []) n c = n + unlist (MH (x:xs)) n c = c (MH x) (MH xs) + ret (MH x) = MH (return x) + bind (MH m) k = MH (m >>= \x -> case k (MH x) of MH n -> n) + conditioned (MH dist) = MH (MH.conditioned dist) + unconditioned (MH dist) = MH (MH.unconditioned dist) + factor (MH p) = MH (MH.factor p) + dirac (MH x) = MH (MH.dirac x) + categorical (MH xps) = MH (MH.categorical xps) + bern (MH p) = MH (MH.bern p) + normal (MH m) (MH s) = MH (MH.normal m s) + uniform (MH lo) (MH hi) = MH (MH.uniform lo hi) + poisson = error "poisson: not implemented for MH" -- TODO diff --git a/Sampler.hs b/Sampler.hs deleted file mode 100644 --- a/Sampler.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# OPTIONS -W #-} - -module Sampler (Sampler, deterministic, sbind, smap) where - -import Mixture (Mixture, mnull, empty, scale, point) -import RandomChoice (choose) -import System.Random (RandomGen) - --- Sampling procedures that produce one sample - -type Sampler a = forall g. (RandomGen g) => g -> (Mixture a, g) - -deterministic :: Mixture a -> Sampler a -deterministic m g = (m, g) - -sbind :: Sampler a -> (a -> Sampler b) -> Sampler b -sbind s k g0 = - case s g0 of { (m1, g1) -> - if mnull m1 then (empty, g1) else - case choose m1 g1 of { (a, v, g2) -> - case k a g2 of { (m2, g) -> - (scale v m2, g) } } } - -smap :: (a -> b) -> Sampler a -> Sampler b -smap f s = sbind s (\a -> deterministic (point (f a) 1)) diff --git a/Syntax.hs b/Syntax.hs deleted file mode 100644 --- a/Syntax.hs +++ /dev/null @@ -1,185 +0,0 @@ -{-# LANGUAGE TypeFamilies, ConstraintKinds, GADTs, FlexibleContexts #-} - -module Syntax where - --- The syntax - -import GHC.Exts (Constraint) - --- TODO: The pretty-printing semantics - -import qualified Text.PrettyPrint as PP - --- The importance-sampling semantics - -import Types (Cond, CSampler) -import Data.Dynamic (Typeable) -import qualified Data.Number.LogFloat as LF -import qualified InterpreterDynamic as IS - --- The Metropolis-Hastings semantics - -import qualified InterpreterMH as MH - --- The syntax - -data Prob -data Measure a -data Dist a - -class Mochastic repr where - type Type repr a :: Constraint - real :: Double -> repr Double - bool :: Bool -> repr Bool - add, mul :: repr Double -> repr Double -> repr Double - neg :: repr Double -> repr Double - neg = mul (real (-1)) - logFloat, logToLogFloat - :: repr Double -> repr Prob - unbool :: repr Bool -> repr c -> repr c - -> repr c - pair :: repr a -> repr b -> repr (a, b) - unpair :: repr (a, b) -> (repr a -> repr b -> repr c) - -> repr c - inl :: repr a -> repr (Either a b) - inr :: repr b -> repr (Either a b) - uneither :: repr (Either a b) -> (repr a -> repr c) -> (repr b -> repr c) - -> repr c - nil :: repr [a] - cons :: repr a -> repr [a] -> repr [a] - unlist :: repr [a] -> repr c -> (repr a -> repr [a] -> repr c) - -> repr c - ret :: repr a -> repr (Measure a) - bind :: repr (Measure a) -> (repr a -> repr (Measure b)) - -> repr (Measure b) - conditioned, unconditioned :: repr (Dist a) -> repr (Measure a) - factor :: repr Prob -> repr (Measure ()) - dirac :: (Type repr a) => repr a -> repr (Dist a) - categorical :: (Type repr a) => repr [(a, Prob)] -> repr (Dist a) - bern :: (Type repr Bool) => repr Double -> repr (Dist Bool) - bern p = categorical $ - cons (pair (bool True) (logFloat p)) $ - cons (pair (bool False) (logFloat (add (real 1) (neg p)))) $ - nil - normal, uniform - :: repr Double -> repr Double -> repr (Dist Double) - poisson :: repr Double -> repr (Dist Int) - --- TODO: The initial (AST) "semantics" --- (Hey Oleg, is there any better way to deal with the Type constraint, so that --- the AST constructor doesn't have to take a repr constructor argument?) - -data AST repr a where - Real :: Double -> AST repr Double - Unbool :: AST repr Bool -> AST repr c -> AST repr c -> AST repr c - Categorical :: (Type repr a) => AST repr [(a, Prob)] -> AST repr (Dist a) - -- ... - -instance (Mochastic repr) => Mochastic (AST repr) where - type Type (AST repr) a = Type repr a - real = Real - unbool = Unbool - categorical = Categorical - -- ... - -eval :: (Mochastic repr) => AST repr a -> repr a -eval (Real x) = real x -eval (Unbool b x y) = unbool (eval b) (eval x) (eval y) -eval (Categorical xps) = categorical (eval xps) --- ... - --- TODO: The pretty-printing semantics - -newtype PP a = PP (Int -> PP.Doc) - --- The importance-sampling semantics - -newtype IS a = IS (IS' a) -type family IS' a -type instance IS' (Measure a) = IS.Measure (IS' a) -type instance IS' (Dist a) = CSampler (IS' a) -type instance IS' [a] = [IS' a] -type instance IS' (a, b) = (IS' a, IS' b) -type instance IS' (Either a b) = Either (IS' a) (IS' b) -type instance IS' () = () -type instance IS' Bool = Bool -type instance IS' Double = Double -type instance IS' Prob = LF.LogFloat -type instance IS' Int = Int - -instance Mochastic IS where - type Type IS a = (Eq (IS' a), Typeable (IS' a)) - real = IS - bool = IS - add (IS x) (IS y) = IS (x + y) - mul (IS x) (IS y) = IS (x * y) - neg (IS x) = IS (-x) - logFloat (IS x) = IS (LF.logFloat x) - logToLogFloat (IS x) = IS (LF.logToLogFloat x) - unbool (IS b) x y = if b then x else y - pair (IS x) (IS y) = IS (x, y) - unpair (IS (x, y)) c = c (IS x) (IS y) - inl (IS x) = IS (Left x) - inr (IS x) = IS (Right x) - uneither (IS e) c d = either (c . IS) (d . IS) e - nil = IS [] - cons (IS x) (IS xs) = IS (x:xs) - unlist (IS []) n c = n - unlist (IS (x:xs)) n c = c (IS x) (IS xs) - ret (IS x) = IS (return x) - bind (IS m) k = IS (m >>= \x -> case k (IS x) of IS n -> n) - conditioned (IS dist) = IS (IS.conditioned dist) - unconditioned (IS dist) = IS (IS.unconditioned dist) - factor (IS p) = IS (IS.factor p) - dirac (IS x) = IS (IS.dirac x) - categorical (IS xps) = IS (IS.categorical xps) - bern (IS p) = IS (IS.bern p) - normal (IS m) (IS s) = IS (IS.normal m s) - uniform (IS lo) (IS hi) = IS (IS.uniformC lo hi) - poisson (IS l) = IS (IS.poisson l) - --- The Metropolis-Hastings semantics - -newtype MH a = MH (MH' a) -type family MH' a -type instance MH' (Measure a) = MH.Measure (MH' a) -type instance MH' (Dist a) = MH.Cond -> MH.Measure (MH' a) -type instance MH' [a] = [MH' a] -type instance MH' (a, b) = (MH' a, MH' b) -type instance MH' (Either a b) = Either (MH' a) (MH' b) -type instance MH' () = () -type instance MH' Bool = Bool -type instance MH' Double = Double -type instance MH' Prob = MH.Likelihood -type instance MH' Int = Int - -instance Mochastic MH where - type Type MH a = (Eq (MH' a), Typeable (MH' a), Show (MH' a)) - real = MH - bool = MH - add (MH x) (MH y) = MH (x + y) - mul (MH x) (MH y) = MH (x * y) - neg (MH x) = MH (-x) - logFloat (MH x) = MH (LF.logFromLogFloat (LF.logFloat x)) - logToLogFloat (MH x) = MH (LF.logFromLogFloat (LF.logToLogFloat x)) - unbool (MH b) x y = if b then x else y - pair (MH x) (MH y) = MH (x, y) - unpair (MH (x, y)) c = c (MH x) (MH y) - inl (MH x) = MH (Left x) - inr (MH x) = MH (Right x) - uneither (MH e) c d = either (c . MH) (d . MH) e - nil = MH [] - cons (MH x) (MH xs) = MH (x:xs) - unlist (MH []) n c = n - unlist (MH (x:xs)) n c = c (MH x) (MH xs) - ret (MH x) = MH (return x) - bind (MH m) k = MH (m >>= \x -> case k (MH x) of MH n -> n) - conditioned (MH dist) = MH (MH.conditioned dist) - unconditioned (MH dist) = MH (MH.unconditioned dist) - factor (MH p) = MH (MH.factor p) - dirac (MH x) = MH (MH.dirac x) - categorical (MH xps) = MH (MH.categorical xps) - bern (MH p) = MH (MH.bern p) - normal (MH m) (MH s) = MH (MH.normal m s) - uniform (MH lo) (MH hi) = MH (MH.uniform lo hi) - poisson = error "poisson: not implemented for MH" -- TODO diff --git a/Util/Csv.hs b/Util/Csv.hs deleted file mode 100644 --- a/Util/Csv.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE TypeOperators #-} - -module Util.Csv ((:::)((:::)), decodeFile, decodeGZipFile, - decodeFileStream, decodeGZipFileStream) where - -import Data.Csv ( HasHeader(..), FromRecord(..), FromField(..) - , ToRecord(..), ToField(..), decode) -import qualified Data.Csv.Streaming as CS (decode) -import Codec.Compression.GZip (decompress) -import qualified Data.Foldable as F -import qualified Data.ByteString.Lazy as B -import qualified Data.Vector as V -import Control.Applicative ((<*>), (<$>)) - -data a ::: b = a ::: b deriving (Eq, Ord, Read, Show) -infixr 5 ::: - -instance (FromField a, FromRecord b) => FromRecord (a ::: b) where - parseRecord v | V.null v = fail "too few fields in input record" - | otherwise = (:::) <$> parseField (V.head v) <*> parseRecord (V.tail v) - -instance (ToField a, ToRecord b) => ToRecord (a ::: b) where - toRecord (a ::: b) = V.cons (toField a) (toRecord b) - -decodeBytes :: FromRecord a => B.ByteString -> [a] -decodeBytes bs = case decode HasHeader bs of - Left _ -> [] - Right v -> V.toList v - -decodeFile :: FromRecord a => FilePath -> IO [a] -decodeFile = fmap decodeBytes . B.readFile - -decodeGZipFile :: FromRecord a => FilePath -> IO [a] -decodeGZipFile = fmap (decodeBytes . decompress) . B.readFile - -decodeFileStream :: FromRecord a => FilePath -> IO [a] -decodeFileStream = fmap (F.toList . CS.decode HasHeader) . B.readFile - -decodeGZipFileStream :: FromRecord a => FilePath -> IO [a] -decodeGZipFileStream = fmap (F.toList . CS.decode HasHeader . decompress) . B.readFile diff --git a/Util/FileInterpolater.hs b/Util/FileInterpolater.hs deleted file mode 100644 --- a/Util/FileInterpolater.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE RankNTypes, NoMonomorphismRestriction #-} -{-# OPTIONS -W #-} - -module Main where - -import System.IO -import Text.ParserCombinators.Parsec -import System.Environment (getArgs, getProgName) -import System.Exit (exitFailure) - -data ControlMeas = CM { time1 :: Double, vel :: Double, steer :: Double } -data Sensor = S { time2 :: Double, lat :: Double, long :: Double, orient :: Double } -data Merged = M {cm :: ControlMeas, sens :: Sensor} - -type Table1 = [ ControlMeas ] -type Table2 = [ Sensor ] -type MergedT = [ Merged ] - --- prev will be Nothing on startup -data Tracking a = Tr {prev :: Maybe a, curr :: a, rest :: [a]} - --- interpolate and merge 2 files -main :: IO () -main = do - args <- getArgs - case args of - [fileName1, fileName2] -> do - handle1 <- openFile fileName1 ReadMode - handle2 <- openFile fileName2 ReadMode - contents1 <- hGetContents handle1 - contents2 <- hGetContents handle2 - let list1 = tail $ convertS (parseCSV contents1) - let list2 = tail $ convertS (parseCSV contents2) - let tableM = interpolation (constructTab1 list1) (constructTab2 list2) - writeFile "output.csv" (unlines (convertTable tableM)) - putStrLn "Interpolated data written to output.csv" - _ -> do - progName <- getProgName - hPutStrLn stderr ("Usage: " ++ progName ++ " ") - hPutStrLn stderr ("Example: " ++ progName ++ " \"slam_control.csv\" \"slam_gps.csv\"") - exitFailure - --- parsec (CSV) -csvFile = endBy line eol -line = sepBy cell (char ',') -cell = many (noneOf ",\n") -eol = char '\n' - -parseCSV :: String -> Either ParseError [[String]] -parseCSV input = parse csvFile "(unknown)" input - --- convert table to output format (CSV) -convertTable :: MergedT -> [String] -convertTable = map convertCSV - -convertCSV :: Merged -> String -convertCSV m = show (time1 control) ++ "," ++ - show (vel control) ++ "," ++ - show (steer control) ++ "," ++ - show (lat sensors) ++ "," ++ - show (long sensors) ++ "," ++ - show (orient sensors) - where control = cm m - sensors = sens m - --- Perform Interpolation -interpolation :: Table1 -> Table2 -> MergedT -interpolation [] [] = [] -interpolation [] _ = error "not enough data to interpolate" -interpolation _ [] = error "not enough data to interpolate" -interpolation (x1:xs) (y1:ys) = - go (Tr Nothing x1 xs) (Tr Nothing y1 ys) - --- interpolation using current and previous tracking -go :: Tracking ControlMeas -> Tracking Sensor -> MergedT -go (Tr _ _ []) (Tr _ _ _) = [] -go (Tr pr1 cur1 rst1) (Tr pr2 cur2 rst2) = - let t1 = time1 cur1 - t2 = time2 cur2 in - case compare t1 t2 of - LT -> M cur1 res : go (Tr (Just cur1) (head rst1) (tail rst1)) (Tr pr2 cur2 rst2) - where - S t2p latp longp orientp = maybe (S t1 0 0 0) id pr2 - S t2c latc longc orientc = cur2 - interp x y = ((x-y) / (t2c-t2p)) * (t1-t2p) + y - res = S t1 (interp latc latp) (interp longc longp) (interp orientc orientp) - EQ -> M cur1 cur2 : go (Tr (Just cur1) (head rst1) (tail rst1)) (Tr (Just cur2) (head rst2) (tail rst2)) - GT -> M res cur2 : if null rst2 then [] else go (Tr pr1 cur1 rst1) (Tr (Just cur2) (head rst2) (tail rst2)) - where - CM t1p velp steerp = maybe (CM t2 0 0) id pr1 - CM t1c velc steerc = cur1 - interp x y = ((x-y) / (t1c-t1p)) * (t2-t1p) + y - res = CM t2 (interp velc velp) (interp steerc steerp) - --- helper functions -readD :: String -> Double -readD x = read x :: Double - -convertS :: Either ParseError a -> a -convertS (Left _) = error "something went wrong in the parsing -- FIXME" -convertS (Right s) = s - -constructTab1 :: [[String]] -> Table1 -constructTab1 = map read3 - where - read3 :: [String] -> ControlMeas - read3 (x : y : z : []) = CM (readD x) (readD y) (readD z) - read3 _ = error "Table 1 should have exactly 3 entries per row" - -constructTab2 :: [[String]] -> Table2 -constructTab2 = map read4 - where - read4 :: [String] -> Sensor - read4 (x : y : z : w : []) = S (readD x) (readD y) (readD z) (readD w) - read4 _ = error "Table 2 should have exactly 4 entries per row" diff --git a/Util/Finite.hs b/Util/Finite.hs deleted file mode 100644 --- a/Util/Finite.hs +++ /dev/null @@ -1,85 +0,0 @@ -module Util.Finite (Finite(..), enumEverything, enumCardinality, suchThat) where - -import Data.List (tails) -import Data.Maybe (fromJust) -import Data.Bits (shiftL) -import qualified Data.Set as S -import qualified Data.Map as M - -class (Ord a) => Finite a where - everything :: [a] - cardinality :: a -> Integer - -enumEverything :: (Enum a, Bounded a) => [a] -enumEverything = [minBound..maxBound] - -enumCardinality :: (Enum a, Bounded a) => a -> Integer -enumCardinality dummy = succ - $ fromIntegral (fromEnum (maxBound `asTypeOf` dummy)) - - fromIntegral (fromEnum (minBound `asTypeOf` dummy)) - -instance Finite () where - everything = enumEverything - cardinality = enumCardinality - -instance Finite Bool where - everything = enumEverything - cardinality = enumCardinality - -instance Finite Ordering where - everything = enumEverything - cardinality = enumCardinality - -instance (Finite a) => Finite (Maybe a) where - everything = Nothing : map Just everything - cardinality = succ . cardinality . fromJust - -instance (Finite a, Finite b) => Finite (Either a b) where - everything = map Left everything ++ map Right everything - cardinality x = cardinality l + cardinality r where - (Left l, Right r) = (x, x) - -instance (Finite a, Finite b) => Finite (a, b) where - everything = [ (a, b) | a <- everything, b <- everything ] - cardinality ~(a, b) = cardinality a * cardinality b - -instance (Finite a, Finite b, Finite c) => Finite (a, b, c) where - everything = [ (a, b, c) | a <- everything, b <- everything, c <- everything ] - cardinality ~(a, b, c) = cardinality a * cardinality b * cardinality c - -instance (Finite a, Finite b, Finite c, Finite d) => Finite (a, b, c, d) where - everything = [ (a, b, c, d) | a <- everything, b <- everything, c <- everything, d <- everything ] - cardinality ~(a, b, c, d) = cardinality a * cardinality b * cardinality c * cardinality d - -instance (Finite a, Finite b, Finite c, Finite d, Finite e) => Finite (a, b, c, d, e) where - everything = [ (a, b, c, d, e) | a <- everything, b <- everything, c <- everything, d <- everything, e <- everything ] - cardinality ~(a, b, c, d, e) = cardinality a * cardinality b * cardinality c * cardinality d * cardinality e - -instance (Finite a) => Finite (S.Set a) where - everything = loop everything S.empty where - loop candidates set = set - : concat [ loop xs (S.insert x set) | x:xs <- tails candidates ] - cardinality set = shiftL 1 (fromIntegral (cardinality (S.findMin set))) - -instance (Finite a, Eq b) => Eq (a -> b) where - f == g = all (\x -> f x == g x) everything - f /= g = any (\x -> f x /= g x) everything - -instance (Finite a, Ord b) => Ord (a -> b) where - f `compare` g = map f everything `compare` map g everything - f < g = map f everything < map g everything - f > g = map f everything > map g everything - f <= g = map f everything <= map g everything - f >= g = map f everything >= map g everything - -instance (Finite a, Finite b) => Finite (a -> b) where - everything = [ (M.!) (M.fromDistinctAscList m) - | m <- loop everything ] where - loop [] = [[]] - loop (a:as) = [ (a,b):rest | b <- everything, rest <- loop as ] - cardinality f = cardinality y ^ cardinality x where - (x, y) = (x, f x) - -suchThat :: (Finite a) => (a -> Bool) -> S.Set a -suchThat p = S.fromDistinctAscList (filter p everything) - diff --git a/Util/HList.hs b/Util/HList.hs deleted file mode 100644 --- a/Util/HList.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE TypeFamilies, DataKinds, TypeOperators #-} -{-# OPTIONS -W #-} - -module Util.HList where - -class TList (xs :: [*]) where - data VList (xs :: [*]) :: * - type Append (xs :: [*]) (ys :: [*]) :: [*] - append :: VList xs -> VList ys -> VList (Append xs ys) - vsplit :: VList (Append xs ys) -> (VList xs, VList ys) - -instance TList '[] where - data VList '[] = VNil - type Append '[] ys = ys - append VNil ys = ys - vsplit ys = (VNil, ys) - -instance TList xs => TList (x ': xs) where - data VList (x ': xs) = VCons x (VList xs) - type Append (x ': xs) ys = x ': Append xs ys - append (VCons x xs) ys = VCons x (append xs ys) - vsplit (VCons x zs) = let (xs, ys) = vsplit zs in (VCons x xs, ys) diff --git a/Util/Pretty.hs b/Util/Pretty.hs deleted file mode 100644 --- a/Util/Pretty.hs +++ /dev/null @@ -1,74 +0,0 @@ -module Util.Pretty (Pretty(..)) where - -import Text.PrettyPrint -import Text.Show.Functions -import Data.Ratio (Ratio, numerator, denominator) -import qualified Data.Map as M -import qualified Data.Set as S -import Util.Finite - -class (Show a) => Pretty a where - pretty :: a -> Doc - pretty = text . show - prettyList :: [a] -> Doc - prettyList = brackets . nest 1 . fsep . punctuate comma . map pretty - -instance Pretty Bool -instance Pretty Int -instance Pretty Integer -instance Pretty Float -instance Pretty Double -instance Pretty () -instance Pretty Ordering -instance Pretty Char where prettyList = text . show - -instance (Pretty a, Integral a) => Pretty (Ratio a) where - pretty r | denom == 1 = prnum - | otherwise = cat [prnum, char '/' <> pretty denom] - where denom = denominator r - prnum = pretty (numerator r) - -instance (Pretty a) => Pretty [a] where - pretty = prettyList - -instance (Pretty a) => Pretty (Maybe a) where - pretty Nothing = text "Nothing" - pretty (Just x) = text "Just" <+> pretty x - -instance (Pretty a, Pretty b) => Pretty (Either a b) where - pretty (Left x) = text "Left" <+> pretty x - pretty (Right x) = text "Right" <+> pretty x - -instance (Finite a, Pretty a, Pretty b) => Pretty (a -> b) - where - pretty f = braces $ nest 1 $ sep $ punctuate comma $ - [ hang (pretty x <> colon) 1 (pretty (f x)) | x <- everything ] - -instance (Pretty a, Pretty b) => Pretty (M.Map a b) - where - pretty m = braces . nest 1 . sep . punctuate comma - $ [ hang (pretty k <> colon) 1 (pretty v) | (k,v) <- M.assocs m ] - -instance (Pretty a) => Pretty (S.Set a) - where - pretty = braces . nest 1 . fsep . punctuate comma . map pretty . S.elems - -tuple :: [Doc] -> Doc -tuple = parens . nest 1 . fsep . punctuate comma - -{- The Haskell code below is generated by the following Perl program. -@a = 'a'..'z'; -$" = ", "; -print < Pretty (@a[0..$_-1]) where - pretty (@a[0..$_-1]) = tuple [@{[map "pretty $_", @a[0..$_-1]]}] -END --} -instance (Pretty a, Pretty b) => Pretty (a, b) where - pretty (a, b) = tuple [pretty a, pretty b] -instance (Pretty a, Pretty b, Pretty c) => Pretty (a, b, c) where - pretty (a, b, c) = tuple [pretty a, pretty b, pretty c] -instance (Pretty a, Pretty b, Pretty c, Pretty d) => Pretty (a, b, c, d) where - pretty (a, b, c, d) = tuple [pretty a, pretty b, pretty c, pretty d] -instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e) => Pretty (a, b, c, d, e) where - pretty (a, b, c, d, e) = tuple [pretty a, pretty b, pretty c, pretty d, pretty e] diff --git a/hakaru.cabal b/hakaru.cabal --- a/hakaru.cabal +++ b/hakaru.cabal @@ -2,9 +2,9 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: hakaru -version: 0.1 +version: 0.1.1 synopsis: A probabilistic programming embedded DSL --- description: +description: Hakaru is an embedded DSL for performing probabilistic inference. It supports multiple inference backends. homepage: http://www.indiana.edu/~ppaml license: BSD3 license-file: LICENSE @@ -17,7 +17,7 @@ cabal-version: >=1.10 library - exposed-modules: Types, Visual, Syntax, Mixture, Language.Hakaru.Symbolic, Sampler, RandomChoice, Util.Csv, Util.Extras, Util.Coda, Util.Finite, Util.Pretty, Util.HList, Util.FileInterpolater, Examples.Tests, Examples.Examples, Language.Hakaru.ImportanceSampler, Language.Hakaru.Metropolis + exposed-modules: Types, Visual, Language.Hakaru.Syntax, Mixture, Language.Hakaru.Symbolic, RandomChoice, Util.Extras, Util.Coda, Examples.Tests, Language.Hakaru.ImportanceSampler, Language.Hakaru.Metropolis -- other-modules: other-extensions: RankNTypes, BangPatterns, OverloadedStrings, TypeFamilies, ConstraintKinds, GADTs, FlexibleContexts, TypeOperators, DataKinds, NoMonomorphismRestriction, DeriveDataTypeable, ScopedTypeVariables, ExistentialQuantification, StandaloneDeriving build-depends: base >=4.6 && <4.7, aeson >=0.7 && <0.8, text >=1.1 && <1.2, bytestring >=0.10 && <0.11, pretty >=1.1 && <1.2, logfloat >=0.12 && <0.13, containers >=0.5 && <0.6, random >=1.0 && <1.1, math-functions >=0.1 && <0.2, vector >=0.10 && <0.11, cassava >=0.4 && <0.5, zlib >=0.5 && <0.6, statistics >=0.11 && <0.12, hmatrix >=0.16 && <0.17, parsec >=3.1 && <3.2