text:
{-# LANGUAGE CPP #-}

{-# LANGUAGE MultiParamTypeClasses  #-} -- for 'Bind' class.
{-# LANGUAGE ConstraintKinds        #-} -- for 'Bind' class.
{-# LANGUAGE TypeFamilies           #-} -- for 'Bind' class.

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

{-# LANGUAGE UndecidableInstances #-}

{-# LANGUAGE TypeOperators #-} -- For ':*:' instance and others.

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
-- Some of the constraints may be unnecessary, but they are intentional.
-- This is especially true for the 'Fail' instances.
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
#endif

-- | Representation of supermonads in Haskell.
module Control.Super.Monad
  ( -- * Supermonads
    Bind(..), Return(..), Fail(..)
    -- * Super-Applicatives
  , Applicative(..), pure
  , Functor(..)
    -- * Conveniences
  , Monad
  ) where

import Prelude
  ( String
  , Maybe(..), Either(..)
  , Functor(..)
  , (.), ($), const, id
  )
import qualified Prelude as P

import Data.Functor.Identity ( Identity )

import GHC.Exts ( Constraint )

-- To define standard instances:
import qualified Data.Monoid as Mon
import qualified Data.Proxy as Proxy
import qualified Data.Functor.Product as Product
import qualified Data.Functor.Compose as Compose
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
import qualified Data.Complex as Complex
import qualified Data.Semigroup as Semigroup
import qualified Data.List.NonEmpty as NonEmpty
#endif

import qualified Control.Arrow as Arrow
import qualified Control.Applicative as App
import qualified Control.Monad.ST as ST
import qualified Control.Monad.ST.Lazy as STL

import qualified Text.ParserCombinators.ReadP as Read
import qualified Text.ParserCombinators.ReadPrec as Read

import qualified GHC.Conc as STM
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
import qualified GHC.Generics as Generics
#endif

-- To define "transformers" instances:
import qualified Control.Monad.Trans.Cont     as Cont
import qualified Control.Monad.Trans.Except   as Except
import qualified Control.Monad.Trans.Identity as Identity
import qualified Control.Monad.Trans.Maybe    as Maybe
import qualified Control.Monad.Trans.RWS.Lazy      as RWSL
import qualified Control.Monad.Trans.RWS.Strict    as RWSS
import qualified Control.Monad.Trans.Reader        as Reader
import qualified Control.Monad.Trans.State.Lazy    as StateL
import qualified Control.Monad.Trans.State.Strict  as StateS
import qualified Control.Monad.Trans.Writer.Lazy   as WriterL
import qualified Control.Monad.Trans.Writer.Strict as WriterS

-- -----------------------------------------------------------------------------
-- Super-Applicative Type Class
-- -----------------------------------------------------------------------------

infixl 4 <*>, <*, *>

-- | TODO
class (Functor m, Functor n, Functor p) => Applicative m n p where
  type ApplicativeCts m n p :: Constraint
  type ApplicativeCts m n p = ()

  (<*>) :: (ApplicativeCts m n p) => m (a -> b) -> n a -> p b

  (*>) :: (ApplicativeCts m n p) => m a -> n b -> p b
  ma *> nb = (id <$ ma) <*> nb
  (<*) :: (ApplicativeCts m n p) => m a -> n b -> p a
  ma <* nb = fmap const ma <*> nb

-- | 'pure' is defined in terms of return.
pure :: (Return f, ReturnCts f) => a -> f a
pure = return

-- Standard Instances ----------------------------------------------------------

instance Applicative ((->) r) ((->) r) ((->) r) where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Identity Identity Identity where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative [] [] [] where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Maybe Maybe Maybe where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative P.IO P.IO P.IO where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative (Either e) (Either e) (Either e) where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)

instance Applicative Mon.First Mon.First Mon.First where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Mon.Last Mon.Last Mon.Last where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Applicative Mon.Sum Mon.Sum Mon.Sum where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Mon.Product Mon.Product Mon.Product where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Mon.Dual Mon.Dual Mon.Dual where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
#endif
instance (Applicative m n p) => Applicative (Mon.Alt m) (Mon.Alt n) (Mon.Alt p) where
  type ApplicativeCts (Mon.Alt m) (Mon.Alt n) (Mon.Alt p) = ApplicativeCts m n p
  mf <*> na = Mon.Alt $ (Mon.getAlt mf) <*> (Mon.getAlt na)
  mf *> na = Mon.Alt $ (Mon.getAlt mf) *> (Mon.getAlt na)
  mf <* na = Mon.Alt $ (Mon.getAlt mf) <* (Mon.getAlt na)

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Applicative Semigroup.Min Semigroup.Min Semigroup.Min where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Semigroup.Max Semigroup.Max Semigroup.Max where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Semigroup.Option Semigroup.Option Semigroup.Option where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Semigroup.First Semigroup.First Semigroup.First where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Semigroup.Last Semigroup.Last Semigroup.Last where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
#endif

instance Applicative Proxy.Proxy Proxy.Proxy Proxy.Proxy where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Applicative Complex.Complex Complex.Complex Complex.Complex where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative NonEmpty.NonEmpty NonEmpty.NonEmpty NonEmpty.NonEmpty where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
#endif
instance (Applicative m1 n1 p1, Applicative m2 n2 p2) => Applicative (Product.Product m1 m2) (Product.Product n1 n2) (Product.Product p1 p2) where
  type ApplicativeCts (Product.Product m1 m2) (Product.Product n1 n2) (Product.Product p1 p2) = (ApplicativeCts m1 n1 p1, ApplicativeCts m2 n2 p2)
  Product.Pair m1 m2 <*> Product.Pair n1 n2 = Product.Pair (m1 <*> n1) (m2 <*> n2)
  Product.Pair m1 m2  *> Product.Pair n1 n2 = Product.Pair (m1  *> n1) (m2  *> n2)
  Product.Pair m1 m2 <*  Product.Pair n1 n2 = Product.Pair (m1 <*  n1) (m2 <*  n2)

instance (Applicative f g h, Applicative f' g' h') => Applicative (Compose.Compose f f') (Compose.Compose g g') (Compose.Compose h h') where
  type ApplicativeCts (Compose.Compose f f') (Compose.Compose g g') (Compose.Compose h h') = (ApplicativeCts f g h, ApplicativeCts f' g' h')
  Compose.Compose f <*> Compose.Compose x = Compose.Compose $ fmap (<*>) f <*> x
  Compose.Compose f  *> Compose.Compose x = Compose.Compose $ fmap ( *>) f <*> x
  Compose.Compose f <*  Compose.Compose x = Compose.Compose $ fmap (<* ) f <*> x

instance Applicative Read.ReadP Read.ReadP Read.ReadP where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Read.ReadPrec Read.ReadPrec Read.ReadPrec where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)

instance Applicative (ST.ST s) (ST.ST s) (ST.ST s) where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative (STL.ST s) (STL.ST s) (STL.ST s) where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)

instance (Arrow.Arrow a) => Applicative (Arrow.ArrowMonad a) (Arrow.ArrowMonad a) (Arrow.ArrowMonad a) where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
-- | TODO / FIXME: The wrapped monad instances for 'Functor' and 'P.Monad' are both
--   based on @m@ being a monad, although the functor instance should only be
--   dependend on @m@ being a functor (as can be seen below). This can only be
--   fixed by either giving a custom version of 'App.WrappedMonad' here or by fixing
--   the version of 'App.WrappedMonad' in base.
--   Once this issue is fixed we can replace the 'P.Monad' constraint
--   with a 'Functor' constraint.
--
--   > instance (Functor m) => Functor (App.WrappedMonad m) where
--   >   fmap f m = App.WrapMonad $ fmap (App.unwrapMonad m) f
--
instance (Applicative m m m, P.Monad m) => Applicative (App.WrappedMonad m) (App.WrappedMonad m) (App.WrappedMonad m) where
  type ApplicativeCts (App.WrappedMonad m) (App.WrappedMonad m) (App.WrappedMonad m) = ApplicativeCts m m m
  mf <*> na = App.WrapMonad $ (App.unwrapMonad mf) <*> (App.unwrapMonad na)
  mf  *> na = App.WrapMonad $ (App.unwrapMonad mf)  *> (App.unwrapMonad na)
  mf <*  na = App.WrapMonad $ (App.unwrapMonad mf) <*  (App.unwrapMonad na)

instance Applicative STM.STM STM.STM STM.STM where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Applicative Generics.U1 Generics.U1 Generics.U1 where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance (Applicative f g h) => Applicative (Generics.Rec1 f) (Generics.Rec1 g) (Generics.Rec1 h) where
  type ApplicativeCts (Generics.Rec1 f) (Generics.Rec1 g) (Generics.Rec1 h) = ApplicativeCts f g h
  (Generics.Rec1 mf) <*> (Generics.Rec1 ma) = Generics.Rec1 $ mf <*> ma
  (Generics.Rec1 mf)  *> (Generics.Rec1 ma) = Generics.Rec1 $ mf  *> ma
  (Generics.Rec1 mf) <*  (Generics.Rec1 ma) = Generics.Rec1 $ mf <*  ma
instance (Applicative f g h, Applicative f' g' h') => Applicative (f Generics.:*: f') (g Generics.:*: g') (h Generics.:*: h') where
  type ApplicativeCts (f Generics.:*: f') (g Generics.:*: g') (h Generics.:*: h') = (ApplicativeCts f g h, ApplicativeCts f' g' h')
  (f Generics.:*: g) <*> (f' Generics.:*: g') = (f <*> f') Generics.:*: (g <*> g')
  (f Generics.:*: g)  *> (f' Generics.:*: g') = (f  *> f') Generics.:*: (g  *> g')
  (f Generics.:*: g) <*  (f' Generics.:*: g') = (f <*  f') Generics.:*: (g <*  g')
instance (Applicative f g h, Applicative f' g' h') => Applicative (f Generics.:.: f') (g Generics.:.: g') (h Generics.:.: h') where
  type ApplicativeCts (f Generics.:.: f') (g Generics.:.: g') (h Generics.:.: h') = (ApplicativeCts f g h, ApplicativeCts f' g' h')
  (Generics.Comp1 mf) <*> (Generics.Comp1 ma) = Generics.Comp1 $ fmap (<*>) mf <*> ma
instance Applicative f g h => Applicative (Generics.M1 i c f) (Generics.M1 i c g) (Generics.M1 i c h) where
  type ApplicativeCts  (Generics.M1 i c f) (Generics.M1 i c g) (Generics.M1 i c h) = ApplicativeCts  f g h
  (Generics.M1 mf) <*> (Generics.M1 ma) = Generics.M1 $ mf <*> ma
  (Generics.M1 mf)  *> (Generics.M1 ma) = Generics.M1 $ mf  *> ma
  (Generics.M1 mf) <*  (Generics.M1 ma) = Generics.M1 $ mf <*  ma
#endif

-- "transformers" package instances: -------------------------------------------

-- Continuations are so wierd...
-- | TODO / FIXME: Still need to figure out how and if we can generalize the continuation implementation.
instance Applicative (Cont.ContT r m) (Cont.ContT r m) (Cont.ContT r m) where
  type ApplicativeCts (Cont.ContT r m) (Cont.ContT r m) (Cont.ContT r m) = ()
  f <*> a = Cont.ContT $ \ c -> Cont.runContT f $ \ g -> Cont.runContT a (c . g)
  {-# INLINE (<*>) #-}

instance (Applicative m n p) => Applicative (Except.ExceptT e m) (Except.ExceptT e n) (Except.ExceptT e p) where
  type ApplicativeCts (Except.ExceptT e m) (Except.ExceptT e n) (Except.ExceptT e p) = (ApplicativeCts m n p)
  Except.ExceptT f <*> Except.ExceptT v = Except.ExceptT $ fmap (<*>) f <*> v
  {-# INLINEABLE (<*>) #-}

instance (Applicative m n p) => Applicative (Identity.IdentityT m) (Identity.IdentityT n) (Identity.IdentityT p) where
  type ApplicativeCts (Identity.IdentityT m) (Identity.IdentityT n) (Identity.IdentityT p) = (ApplicativeCts m n p)
  Identity.IdentityT m <*> Identity.IdentityT k = Identity.IdentityT $ m <*> k
  {-# INLINE (<*>) #-}

instance (Applicative m n p) => Applicative (Maybe.MaybeT m) (Maybe.MaybeT n) (Maybe.MaybeT p) where
  type ApplicativeCts (Maybe.MaybeT m) (Maybe.MaybeT n) (Maybe.MaybeT p) = (ApplicativeCts m n p)
  Maybe.MaybeT f <*> Maybe.MaybeT x = Maybe.MaybeT $ fmap (<*>) f <*> x
  {-# INLINE (<*>) #-}

instance (P.Monoid w, Bind m n p) => Applicative (RWSL.RWST r w s m) (RWSL.RWST r w s n) (RWSL.RWST r w s p) where
  type ApplicativeCts (RWSL.RWST r w s m) (RWSL.RWST r w s n) (RWSL.RWST r w s p) = (BindCts m n p)
  RWSL.RWST mf <*> RWSL.RWST ma  = RWSL.RWST $ \r s -> mf r s >>= \ ~(f, s', w) -> fmap (\ ~(a, s'', w') -> (f a, s'', P.mappend w w')) (ma r s')
  {-# INLINE (<*>) #-}

instance (P.Monoid w, Bind m n p) => Applicative (RWSS.RWST r w s m) (RWSS.RWST r w s n) (RWSS.RWST r w s p) where
  type ApplicativeCts (RWSS.RWST r w s m) (RWSS.RWST r w s n) (RWSS.RWST r w s p) = (BindCts m n p)
  RWSS.RWST mf <*> RWSS.RWST ma = RWSS.RWST $ \r s -> mf r s >>= \ (f, s', w) -> fmap (\ (a, s'', w') -> (f a, s'', P.mappend w w')) (ma r s')
  {-# INLINE (<*>) #-}

instance (Applicative m n p) => Applicative (Reader.ReaderT r m) (Reader.ReaderT r n) (Reader.ReaderT r p) where
  type ApplicativeCts (Reader.ReaderT r m) (Reader.ReaderT r n) (Reader.ReaderT r p) = (ApplicativeCts m n p)
  Reader.ReaderT mf <*> Reader.ReaderT ma  = Reader.ReaderT $ \r -> mf r <*> ma r
  {-# INLINE (<*>) #-}

instance (Bind m n p) => Applicative (StateL.StateT s m) (StateL.StateT s n) (StateL.StateT s p) where
  type ApplicativeCts (StateL.StateT s m) (StateL.StateT s n) (StateL.StateT s p) = (BindCts m n p)
  StateL.StateT mf <*> StateL.StateT ma = StateL.StateT $ \s -> mf s >>= \ ~(f, s') -> fmap (\ ~(a, s'') -> (f a, s'')) (ma s')
  {-# INLINE (<*>) #-}

instance (Bind m n p) => Applicative (StateS.StateT s m) (StateS.StateT s n) (StateS.StateT s p) where
  type ApplicativeCts (StateS.StateT s m) (StateS.StateT s n) (StateS.StateT s p) = (BindCts m n p)
  StateS.StateT mf <*> StateS.StateT ma = StateS.StateT $ \s -> mf s >>= \ (f, s') -> fmap (\ (a, s'') -> (f a, s'')) (ma s')
  {-# INLINE (<*>) #-}

instance (P.Monoid w, Applicative m n p) => Applicative (WriterL.WriterT w m) (WriterL.WriterT w n) (WriterL.WriterT w p) where
  type ApplicativeCts (WriterL.WriterT w m) (WriterL.WriterT w n) (WriterL.WriterT w p) = (ApplicativeCts m n p)
  WriterL.WriterT mf <*> WriterL.WriterT ma = WriterL.WriterT $ fmap (\ ~(f, w) ~(a, w') -> (f a, P.mappend w w')) mf <*> ma
  {-# INLINE (<*>) #-}

instance (P.Monoid w, Applicative m n p) => Applicative (WriterS.WriterT w m) (WriterS.WriterT w n) (WriterS.WriterT w p) where
  type ApplicativeCts (WriterS.WriterT w m) (WriterS.WriterT w n) (WriterS.WriterT w p) = (ApplicativeCts m n p)
  WriterS.WriterT mf <*> WriterS.WriterT ma = WriterS.WriterT $ fmap (\ (f, w) (a, w') -> (f a, P.mappend w w')) mf <*> ma
  {-# INLINE (<*>) #-}

-- -----------------------------------------------------------------------------
-- Supermonad Type Class - Bind
-- -----------------------------------------------------------------------------

infixl 1 >>, >>=

-- | Representation of bind operations for supermonads.
--   A proper supermonad consists of an instance
--   for 'Bind', 'Return' and optionally 'Fail'.
--
--   The instances are required to follow a certain scheme.
--   If the type constructor of your supermonad is @M@ there
--   may only be exactly one 'Bind' and one 'Return' instance
--   that look as follows:
--
-- > instance Bind (M ...) (M ...) (M ...) where
-- >   ...
-- > instance Return (M ...) where
-- >   ...
--
--   This is enforced by the plugin. A compilation error will
--   result from either instance missing or multiple instances
--   for @M@.
--
--   For supermonads we expect the usual monad laws to hold:
--
--   * @'return' a '>>=' k  =  k a@
--   * @m '>>=' 'return'  =  m@
--   * @m '>>=' (\\x -> k x '>>=' h)  =  (m '>>=' k) '>>=' h@
--   * @'fmap' f xs  =  xs '>>=' 'return' . f@
--
class (Functor m, Functor n, Functor p) => Bind m n p where
  type BindCts m n p :: Constraint
  type BindCts m n p = ()
  (>>=) :: (BindCts m n p) => m a -> (a -> n b) -> p b
  (>>)  :: (BindCts m n p) => m a -> n b -> p b
  ma >> mb = ma >>= const mb

instance Bind ((->) r) ((->) r) ((->) r) where
  (>>=) = (P.>>=)
instance Bind Identity Identity Identity where
  (>>=) = (P.>>=)
instance Bind [] [] [] where
  (>>=) = (P.>>=)
instance Bind P.Maybe P.Maybe P.Maybe where
  (>>=) = (P.>>=)
instance Bind P.IO P.IO P.IO where
  (>>=) = (P.>>=)
instance Bind (P.Either e) (P.Either e) (P.Either e) where
  (>>=) = (P.>>=)

instance Bind Mon.First Mon.First Mon.First where
  (>>=) = (P.>>=)
instance Bind Mon.Last Mon.Last Mon.Last where
  (>>=) = (P.>>=)
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Bind Mon.Sum Mon.Sum Mon.Sum where
  (>>=) = (P.>>=)
instance Bind Mon.Product Mon.Product Mon.Product where
  (>>=) = (P.>>=)
instance Bind Mon.Dual Mon.Dual Mon.Dual where
  (>>=) = (P.>>=)
#endif
instance (Bind m n p) => Bind (Mon.Alt m) (Mon.Alt n) (Mon.Alt p) where
  type BindCts (Mon.Alt m) (Mon.Alt n) (Mon.Alt p) = BindCts m n p
  m >>= f = Mon.Alt $ (Mon.getAlt m) >>= (Mon.getAlt . f)

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Bind Semigroup.Min Semigroup.Min Semigroup.Min where
  (>>=) = (P.>>=)
instance Bind Semigroup.Max Semigroup.Max Semigroup.Max where
  (>>=) = (P.>>=)
instance Bind Semigroup.Option Semigroup.Option Semigroup.Option where
  (>>=) = (P.>>=)
instance Bind Semigroup.First Semigroup.First Semigroup.First where
  (>>=) = (P.>>=)
instance Bind Semigroup.Last Semigroup.Last Semigroup.Last where
  (>>=) = (P.>>=)
#endif

instance Bind Proxy.Proxy Proxy.Proxy Proxy.Proxy where
  (>>=) = (P.>>=)
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Bind Complex.Complex Complex.Complex Complex.Complex where
  (>>=) = (P.>>=)
instance Bind NonEmpty.NonEmpty NonEmpty.NonEmpty NonEmpty.NonEmpty where
  (>>=) = (P.>>=)
#endif
instance (Bind m1 n1 p1, Bind m2 n2 p2) => Bind (Product.Product m1 m2) (Product.Product n1 n2) (Product.Product p1 p2) where
  type BindCts (Product.Product m1 m2) (Product.Product n1 n2) (Product.Product p1 p2) = (BindCts m1 n1 p1, BindCts m2 n2 p2)
  Product.Pair m1 m2 >>= f = Product.Pair (m1 >>= (fstP . f)) (m2 >>= (sndP . f))
    where fstP (Product.Pair a _) = a
          sndP (Product.Pair _ b) = b

instance Bind Read.ReadP Read.ReadP Read.ReadP where
  (>>=) = (P.>>=)
instance Bind Read.ReadPrec Read.ReadPrec Read.ReadPrec where
  (>>=) = (P.>>=)

instance Bind (ST.ST s) (ST.ST s) (ST.ST s) where
  (>>=) = (P.>>=)
instance Bind (STL.ST s) (STL.ST s) (STL.ST s) where
  (>>=) = (P.>>=)
instance (Arrow.ArrowApply a) => Bind (Arrow.ArrowMonad a) (Arrow.ArrowMonad a) (Arrow.ArrowMonad a) where
  (>>=) = (P.>>=)
-- | TODO / FIXME: The wrapped monad instances for 'Functor' and 'P.Monad' are both
--   based on @m@ being a monad, although the functor instance should only be
--   dependend on @m@ being a functor (as can be seen below). This can only be
--   fixed by either giving a custom version of 'App.WrappedMonad' here or by fixing
--   the version of 'App.WrappedMonad' in base.
--   Once this issue is fixed we can replace the 'P.Monad' constraint
--   with a 'Functor' constraint.
--
--   > instance (Functor m) => Functor (App.WrappedMonad m) where
--   >   fmap f m = App.WrapMonad $ fmap (App.unwrapMonad m) f
--
instance (Bind m m m, P.Monad m) => Bind (App.WrappedMonad m) (App.WrappedMonad m) (App.WrappedMonad m) where
  type BindCts (App.WrappedMonad m) (App.WrappedMonad m) (App.WrappedMonad m) = BindCts m m m
  m >>= f = App.WrapMonad $ (App.unwrapMonad m) >>= (App.unwrapMonad . f)

instance Bind STM.STM STM.STM STM.STM where
  (>>=) = (P.>>=)

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Bind Generics.U1 Generics.U1 Generics.U1 where
  (>>=) = (P.>>=)
instance (Bind m n p) => Bind (Generics.Rec1 m) (Generics.Rec1 n) (Generics.Rec1 p) where
  type BindCts (Generics.Rec1 m) (Generics.Rec1 n) (Generics.Rec1 p) = BindCts m n p
  (Generics.Rec1 mf) >>= f = Generics.Rec1 $ mf >>= (Generics.unRec1 . f)
instance (Bind f g h, Bind f' g' h') => Bind (f Generics.:*: f') (g Generics.:*: g') (h Generics.:*: h') where
  type BindCts (f Generics.:*: f') (g Generics.:*: g') (h Generics.:*: h') = (BindCts f g h, BindCts f' g' h')
  (f Generics.:*: g) >>= m = (f >>= \a -> let (f' Generics.:*: _g') = m a in f') Generics.:*: (g >>= \a -> let (_f' Generics.:*: g') = m a in g')
instance Bind f g h => Bind (Generics.M1 i c f) (Generics.M1 i c g) (Generics.M1 i c h) where
  type BindCts  (Generics.M1 i c f) (Generics.M1 i c g) (Generics.M1 i c h) = BindCts  f g h
  (Generics.M1 ma) >>= f = Generics.M1 $ ma >>= Generics.unM1 . f
#endif

-- "transformers" package instances: -------------------------------------------

-- Continuations are so wierd...
-- | TODO / FIXME: Still need to figure out how and if we can generalize the continuation implementation.
instance {- (Bind m n p) => -} Bind (Cont.ContT r m) (Cont.ContT r m) (Cont.ContT r m) where
  type BindCts (Cont.ContT r m) (Cont.ContT r m) (Cont.ContT r m) = () -- (BindCts m n p)
  m >>= k = Cont.ContT $ \ c -> Cont.runContT m (\ x -> Cont.runContT (k x) c)
  {-# INLINE (>>=) #-}

instance (Bind m n p, Return n) => Bind (Except.ExceptT e m) (Except.ExceptT e n) (Except.ExceptT e p) where
  type BindCts (Except.ExceptT e m) (Except.ExceptT e n) (Except.ExceptT e p) = (BindCts m n p, ReturnCts n)
  m >>= k = Except.ExceptT $
      Except.runExceptT m >>=
      \ a -> case a of
          Left e -> return (Left e)
          Right x -> Except.runExceptT (k x)
  {-# INLINE (>>=) #-}

instance (Bind m n p) => Bind (Identity.IdentityT m) (Identity.IdentityT n) (Identity.IdentityT p) where
  type BindCts (Identity.IdentityT m) (Identity.IdentityT n) (Identity.IdentityT p) = (BindCts m n p)
  m >>= k = Identity.IdentityT $ Identity.runIdentityT m >>= (Identity.runIdentityT . k)
  {-# INLINE (>>=) #-}

instance (Return n, Bind m n p) => Bind (Maybe.MaybeT m) (Maybe.MaybeT n) (Maybe.MaybeT p) where
  type BindCts (Maybe.MaybeT m) (Maybe.MaybeT n) (Maybe.MaybeT p) = (ReturnCts n, BindCts m n p)
  x >>= f = Maybe.MaybeT $
    Maybe.runMaybeT x >>=
    \v -> case v of
      Nothing -> return Nothing
      Just y  -> Maybe.runMaybeT (f y)
  {-# INLINE (>>=) #-}

instance (P.Monoid w, Bind m n p) => Bind (RWSL.RWST r w s m) (RWSL.RWST r w s n) (RWSL.RWST r w s p) where
  type BindCts (RWSL.RWST r w s m) (RWSL.RWST r w s n) (RWSL.RWST r w s p) = (BindCts m n p)
  m >>= k  = RWSL.RWST $
    \ r s -> RWSL.runRWST m r s >>=
    \ ~(a, s', w) -> fmap (\ ~(b, s'',w') -> (b, s'', w `P.mappend` w')) $ RWSL.runRWST (k a) r s'
  {-# INLINE (>>=) #-}

instance (P.Monoid w, Bind m n p) => Bind (RWSS.RWST r w s m) (RWSS.RWST r w s n) (RWSS.RWST r w s p) where
  type BindCts (RWSS.RWST r w s m) (RWSS.RWST r w s n) (RWSS.RWST r w s p) = (BindCts m n p)
  m >>= k  = RWSS.RWST $
    \ r s -> RWSS.runRWST m r s >>=
    \ (a, s', w) -> fmap (\(b, s'',w') -> (b, s'', w `P.mappend` w')) $ RWSS.runRWST (k a) r s'
  {-# INLINE (>>=) #-}

instance (Bind m n p) => Bind (Reader.ReaderT r m) (Reader.ReaderT r n) (Reader.ReaderT r p) where
  type BindCts (Reader.ReaderT r m) (Reader.ReaderT r n) (Reader.ReaderT r p) = (BindCts m n p)
  m >>= k  = Reader.ReaderT $
      \ r -> Reader.runReaderT m r >>=
      \ a -> Reader.runReaderT (k a) r
  {-# INLINE (>>=) #-}

instance (Bind m n p) => Bind (StateL.StateT s m) (StateL.StateT s n) (StateL.StateT s p) where
  type BindCts (StateL.StateT s m) (StateL.StateT s n) (StateL.StateT s p) = (BindCts m n p)
  m >>= k = StateL.StateT
          $ \ s -> StateL.runStateT m s >>=
            \ ~(a, s') -> StateL.runStateT (k a) s'
  {-# INLINE (>>=) #-}

instance (Bind m n p) => Bind (StateS.StateT s m) (StateS.StateT s n) (StateS.StateT s p) where
  type BindCts (StateS.StateT s m) (StateS.StateT s n) (StateS.StateT s p) = (BindCts m n p)
  m >>= k = StateS.StateT
          $ \ s -> StateS.runStateT m s >>=
            \ (a, s') -> StateS.runStateT (k a) s'
  {-# INLINE (>>=) #-}

instance (P.Monoid w, Bind m n p) => Bind (WriterL.WriterT w m) (WriterL.WriterT w n) (WriterL.WriterT w p) where
  type BindCts (WriterL.WriterT w m) (WriterL.WriterT w n) (WriterL.WriterT w p) = (BindCts m n p)
  m >>= k  = WriterL.WriterT $
      WriterL.runWriterT m >>=
      \ ~(a, w) -> fmap (\ ~(b, w') -> (b, w `P.mappend` w')) $ WriterL.runWriterT (k a)
  {-# INLINE (>>=) #-}

instance (P.Monoid w, Bind m n p) => Bind (WriterS.WriterT w m) (WriterS.WriterT w n) (WriterS.WriterT w p) where
  type BindCts (WriterS.WriterT w m) (WriterS.WriterT w n) (WriterS.WriterT w p) = (BindCts m n p)
  m >>= k  = WriterS.WriterT $
      WriterS.runWriterT m >>=
      \ (a, w) -> fmap (\ (b, w') -> (b, w `P.mappend` w')) $ WriterS.runWriterT (k a)
  {-# INLINE (>>=) #-}

-- -----------------------------------------------------------------------------
-- Return Type Class
-- -----------------------------------------------------------------------------

-- | See 'Bind' or 'Ap' for details on laws and requirements.
class (Functor m) => Return m where
  type ReturnCts m :: Constraint
  type ReturnCts m = ()
  return :: (ReturnCts m) => a -> m a

instance Return ((->) r) where
  return = P.return
instance Return Identity where
  return = P.return
instance Return [] where
  return = P.return
instance Return P.Maybe where
  return = P.return
instance Return P.IO where
  return = P.return
instance Return (P.Either e) where
  return = P.return

instance Return Mon.First where
  return = P.return
instance Return Mon.Last where
  return = P.return
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Return Mon.Sum where
  return = P.return
instance Return Mon.Product where
  return = P.return
instance Return Mon.Dual where
  return = P.return
#endif
instance (Return a) => Return (Mon.Alt a) where
  type ReturnCts (Mon.Alt a) = ReturnCts a
  return a = Mon.Alt $ return a

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Return Semigroup.Min where
  return = P.return
instance Return Semigroup.Max where
  return = P.return
instance Return Semigroup.Option where
  return = P.return
instance Return Semigroup.First where
  return = P.return
instance Return Semigroup.Last where
  return = P.return
#endif

instance Return Proxy.Proxy where
  return = P.return
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Return Complex.Complex where
  return = P.return
instance Return NonEmpty.NonEmpty where
  return = P.return
#endif

instance (Return m1, Return m2) => Return (Product.Product m1 m2) where
  type ReturnCts (Product.Product m1 m2) = (ReturnCts m1, ReturnCts m2)
  return a = Product.Pair (return a) (return a)

instance (Return f, Return f') => Return (Compose.Compose f f') where
  type ReturnCts (Compose.Compose f f') = (ReturnCts f, ReturnCts f')
  return = Compose.Compose . return . return

instance Return Read.ReadP where
  return = P.return
instance Return Read.ReadPrec where
  return = P.return

instance Return (ST.ST s) where
  return = P.return
instance Return (STL.ST s) where
  return = P.return
instance (Arrow.ArrowApply a) => Return (Arrow.ArrowMonad a) where
  return = P.return
-- | TODO / FIXME: This has the same issue as the 'Bind' instance for 'App.WrappedMonad'.
instance (Return m, P.Monad m) => Return (App.WrappedMonad m) where
  type ReturnCts (App.WrappedMonad m) = ReturnCts m
  return a = App.WrapMonad $ return a

instance Return STM.STM where
  return = P.return

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Return Generics.U1 where
  return = P.return
instance (Return m) => Return (Generics.Rec1 m) where
  type ReturnCts (Generics.Rec1 m) = ReturnCts m
  return = Generics.Rec1 . return
instance (Return f, Return g) => Return (f Generics.:*: g) where
  type ReturnCts (f Generics.:*: g) = (ReturnCts f, ReturnCts g)
  return a = return a Generics.:*: return a
instance (Return f, Return g) => Return (f Generics.:.: g) where
  type ReturnCts (f Generics.:.: g) = (ReturnCts f, ReturnCts g)
  return = Generics.Comp1 . return . return
instance Return f => Return (Generics.M1 i c f) where
  type ReturnCts (Generics.M1 i c f) = ReturnCts f
  return = Generics.M1 . return
#endif

-- "transformers" package instances: -------------------------------------------

-- Continuations are so weird...
instance {- (Return m) => -} Return (Cont.ContT r m) where
  type ReturnCts (Cont.ContT r m) = () -- ReturnCts m
  return x = Cont.ContT ($ x)
  {-# INLINE return #-}

instance (Return m) => Return (Except.ExceptT e m) where
  type ReturnCts (Except.ExceptT e m) = ReturnCts m
  return = Except.ExceptT . return . Right
  {-# INLINE return #-}

instance (Return m) => Return (Identity.IdentityT m) where
  type ReturnCts (Identity.IdentityT m) = ReturnCts m
  return = (Identity.IdentityT) . return
  {-# INLINE return #-}

instance (Return m) => Return (Maybe.MaybeT m) where
  type ReturnCts (Maybe.MaybeT m) = ReturnCts m
  return = Maybe.MaybeT . return . Just
  {-# INLINE return #-}

instance (P.Monoid w, Return m) => Return (RWSL.RWST r w s m) where
  type ReturnCts (RWSL.RWST r w s m) = ReturnCts m
  return a = RWSL.RWST $ \ _ s -> return (a, s, P.mempty)
  {-# INLINE return #-}

instance (P.Monoid w, Return m) => Return (RWSS.RWST r w s m) where
  type ReturnCts (RWSS.RWST r w s m) = ReturnCts m
  return a = RWSS.RWST $ \ _ s -> return (a, s, P.mempty)
  {-# INLINE return #-}

instance (Return m) => Return (Reader.ReaderT r m) where
  type ReturnCts (Reader.ReaderT r m) = ReturnCts m
  return = Reader.ReaderT . const . return
  {-# INLINE return #-}

instance (Return m) => Return (StateL.StateT s m) where
  type ReturnCts (StateL.StateT s m) = ReturnCts m
  return x = StateL.StateT $ \s -> return (x, s)
  {-# INLINE return #-}

instance (Return m) => Return (StateS.StateT s m) where
  type ReturnCts (StateS.StateT s m) = ReturnCts m
  return x = StateS.StateT $ \s -> return (x, s)
  {-# INLINE return #-}

instance (P.Monoid w, Return m) => Return (WriterL.WriterT w m) where
  type ReturnCts (WriterL.WriterT w m) = ReturnCts m
  return a = WriterL.WriterT $ return (a, P.mempty)
  {-# INLINE return #-}

instance (P.Monoid w, Return m) => Return (WriterS.WriterT w m) where
  type ReturnCts (WriterS.WriterT w m) = ReturnCts m
  return a = WriterS.WriterT $ return (a, P.mempty)
  {-# INLINE return #-}

-- -----------------------------------------------------------------------------
-- Fail Type Class
-- -----------------------------------------------------------------------------

-- | See 'Bind' for details on laws and requirements.
class Fail m where
  type FailCts m :: Constraint
  type FailCts m = ()
  fail :: (FailCts m) => String -> m a

instance Fail ((->) r) where
  fail = P.fail
instance Fail Identity where
  fail = P.fail
instance Fail [] where
  fail = P.fail
instance Fail P.Maybe where
  fail = P.fail
instance Fail P.IO where
  fail = P.fail
instance Fail (P.Either e) where
  fail = P.fail

instance Fail Mon.First where
  fail = P.fail
instance Fail Mon.Last where
  fail = P.fail
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Fail Mon.Sum where
  fail = P.fail
instance Fail Mon.Product where
  fail = P.fail
instance Fail Mon.Dual where
  fail = P.fail
#endif
instance (Fail a) => Fail (Mon.Alt a) where
  type FailCts (Mon.Alt a) = (FailCts a)
  fail a = Mon.Alt $ fail a

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Fail Semigroup.Min where
  fail = P.fail
instance Fail Semigroup.Max where
  fail = P.fail
instance Fail Semigroup.Option where
  fail = P.fail
instance Fail Semigroup.First where
  fail = P.fail
instance Fail Semigroup.Last where
  fail = P.fail
#endif

instance Fail Proxy.Proxy where
  fail = P.fail
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Fail Complex.Complex where
  fail = P.fail
instance Fail NonEmpty.NonEmpty where
  fail = P.fail
#endif
instance (Fail m1, Fail m2) => Fail (Product.Product m1 m2) where
  type FailCts (Product.Product m1 m2) = (FailCts m1, FailCts m2)
  fail a = Product.Pair (fail a) (fail a)

instance Fail Read.ReadP where
  fail = P.fail
instance Fail Read.ReadPrec where
  fail = P.fail

instance Fail (ST.ST s) where
  fail = P.fail
instance Fail (STL.ST s) where
  fail = P.fail
instance (Arrow.ArrowApply a) => Fail (Arrow.ArrowMonad a) where
  fail = P.fail
-- | TODO / FIXME: This has the same issue as the 'Bind' instance for 'App.WrappedMonad'.
instance (Fail m, P.Monad m) => Fail (App.WrappedMonad m) where
  type FailCts (App.WrappedMonad m) = (FailCts m)
  fail a = App.WrapMonad $ fail a

instance Fail STM.STM where
  fail = P.fail

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Fail Generics.U1 where
  fail = P.fail
instance (Fail m) => Fail (Generics.Rec1 m) where
  type FailCts (Generics.Rec1 m) = FailCts m
  fail = Generics.Rec1 . fail
instance (Fail f, Fail g) => Fail (f Generics.:*: g) where
  type FailCts (f Generics.:*: g) = (FailCts f, FailCts g)
  fail a = fail a Generics.:*: fail a
instance Fail f => Fail (Generics.M1 i c f) where
  type FailCts (Generics.M1 i c f) = FailCts f
  fail = Generics.M1 . fail
#endif

-- "transformers" package instances: -------------------------------------------

instance (Fail m) => Fail (Cont.ContT r m) where
  type FailCts (Cont.ContT r m) = (FailCts m)
  fail = (Cont.ContT) . const . fail
  {-# INLINE fail #-}

instance (Fail m) => Fail (Except.ExceptT e m) where
  type FailCts (Except.ExceptT e m) = (FailCts m)
  fail = Except.ExceptT . fail
  {-# INLINE fail #-}

instance (Fail m) => Fail (Identity.IdentityT m) where
  type FailCts (Identity.IdentityT m) = (FailCts m)
  fail msg = Identity.IdentityT $ fail msg
  {-# INLINE fail #-}

instance (Return m) => Fail (Maybe.MaybeT m) where
  type FailCts (Maybe.MaybeT m) = (ReturnCts m)
  fail _ = Maybe.MaybeT (return Nothing)
  {-# INLINE fail #-}

instance (P.Monoid w, Fail m) => Fail (RWSL.RWST r w s m) where
  type FailCts (RWSL.RWST r w s m) = (FailCts m)
  fail msg = RWSL.RWST $ \ _ _ -> fail msg
  {-# INLINE fail #-}

instance (P.Monoid w, Fail m) => Fail (RWSS.RWST r w s m) where
  type FailCts (RWSS.RWST r w s m) = (FailCts m)
  fail msg = RWSS.RWST $ \ _ _ -> fail msg
  {-# INLINE fail #-}

instance (Fail m) => Fail (Reader.ReaderT r m) where
  type FailCts (Reader.ReaderT r m) = (FailCts m)
  fail = Reader.ReaderT . const . fail
  {-# INLINE fail #-}

instance (Fail m) => Fail (StateL.StateT s m) where
  type FailCts (StateL.StateT s m) = (FailCts m)
  fail = StateL.StateT . const . fail
  {-# INLINE fail #-}

instance (Fail m) => Fail (StateS.StateT s m) where
  type FailCts (StateS.StateT s m) = (FailCts m)
  fail = StateS.StateT . const . fail
  {-# INLINE fail #-}

instance (P.Monoid w, Fail m) => Fail (WriterL.WriterT w m) where
  type FailCts (WriterL.WriterT w m) = (FailCts m)
  fail msg = WriterL.WriterT $ fail msg
  {-# INLINE fail #-}

instance (P.Monoid w, Fail m) => Fail (WriterS.WriterT w m) where
  type FailCts (WriterS.WriterT w m) = (FailCts m)
  fail msg = WriterS.WriterT $ fail msg
  {-# INLINE fail #-}

-- -----------------------------------------------------------------------------
-- Convenient type synonyms
-- -----------------------------------------------------------------------------

-- | A short-hand for writing polymorphic standard monad functions.
type family Monad m :: Constraint where
  Monad m = (Bind m m m, Return m, Fail m)

max_stars_repo_name: jbracker/supermonad-plugin

max_issues_repo_name: jbracker/supermonad

max_forks_repo_name: jbracker/supermonad-plugin


text:
module Math.HiddenMarkovModel.CSV where

import qualified Numeric.LinearAlgebra.Algorithms as Algo
import qualified Data.Packed.Matrix as Matrix
import qualified Data.Packed.Vector as Vector
import Data.Packed.Matrix (Matrix)
import Data.Packed.Vector (Vector)

import qualified Text.CSV.Lazy.String as CSV
import Text.Read.HT (maybeRead)
import Text.Printf (printf)

import qualified Control.Monad.Exception.Synchronous as ME
import qualified Control.Monad.Trans.Class as MT
import qualified Control.Monad.Trans.State as MS
import Control.Monad.Exception.Synchronous (Exceptional)
import Control.Monad (liftM2, replicateM, unless)

import qualified Data.List.HT as ListHT

cellsFromVector ::
   (Show a, Algo.Field a) =>
   Vector a -> [String]
cellsFromVector = map show . Vector.toList

cellsFromMatrix ::
   (Show a, Matrix.Element a) =>
   Matrix.Matrix a -> [[String]]
cellsFromMatrix = map (map show) . Matrix.toLists

padTable :: a -> [[a]] -> [[a]]
padTable x xs =
   let width = maximum (map length xs)
   in  map (ListHT.padRight x width) xs

type CSVParser = MS.StateT CSV.CSVResult (Exceptional String)

assert :: Bool -> String -> CSVParser ()
assert cond msg =
   unless cond $ MT.lift $ ME.throw msg

retrieveShortRow :: CSV.CSVError -> Maybe CSV.CSVRow
retrieveShortRow err =
   case err of
      CSV.IncorrectRow {CSV.csvFields = row} -> Just row
      _ -> Nothing

fixShortRow ::
   Either [CSV.CSVError] CSV.CSVRow -> Either [CSV.CSVError] CSV.CSVRow
fixShortRow erow =
   case erow of
      Left errs ->
         case ListHT.partitionMaybe retrieveShortRow errs of
            ([row], []) -> Right row
            _ -> Left errs
      _ -> erow

maybeGetRow :: CSVParser (Maybe CSV.CSVRow)
maybeGetRow = do
   csv0 <- MS.get
   case csv0 of
      [] -> return Nothing
      item : csv1 -> do
         MS.put csv1
         case item of
            Right row -> return (Just row)
            Left errors ->
               MT.lift $ ME.throw $ unlines $ map CSV.ppCSVError errors

getRow :: CSVParser CSV.CSVRow
getRow =
   MT.lift . ME.fromMaybe "unexpected end of file" =<< maybeGetRow

checkEmptyRow :: CSV.CSVRow -> Exceptional String ()
checkEmptyRow row =
   case filter (not . null . CSV.csvFieldContent) row of
      [] -> return ()
      cell:_ -> ME.throw $ printf "%d: expected empty row" (CSV.csvRowNum cell)

skipEmptyRow :: CSVParser ()
skipEmptyRow  =  MT.lift . checkEmptyRow =<< getRow

manySepUntilEnd :: CSVParser a -> CSVParser [a]
manySepUntilEnd p =
   let go = liftM2 (:) p $ do
          mrow <- maybeGetRow
          case mrow of
             Nothing -> return []
             Just row -> do
                MT.lift $ checkEmptyRow row
                go
   in  go

manyRowsUntilEnd :: (CSV.CSVRow -> CSVParser a) -> CSVParser [a]
manyRowsUntilEnd p =
   let go = do
          mrow <- maybeGetRow
          case mrow of
             Nothing -> return []
             Just row -> liftM2 (:) (p row) go
   in  go

parseVectorCells ::
   (Read a, Algo.Field a) =>
   CSVParser (Vector a)
parseVectorCells =
   parseVectorFields =<< getRow

parseVectorFields ::
   (Read a, Algo.Field a) =>
   CSV.CSVRow -> CSVParser (Vector a)
parseVectorFields =
   MT.lift . fmap Vector.fromList . mapM parseNumberCell .
   ListHT.dropWhileRev (null . CSV.csvFieldContent)

parseNonEmptyVectorCells ::
   (Read a, Algo.Field a) =>
   CSVParser (Vector a)
parseNonEmptyVectorCells = do
   v <- parseVectorCells
   assert (Vector.dim v > 0) "no data for vector"
   return v

cellContent :: CSV.CSVField -> Exceptional String String
cellContent field =
   case field of
      CSV.CSVFieldError {} -> ME.throw $ CSV.ppCSVField field
      CSV.CSVField { CSV.csvFieldContent = str } -> return str

parseNumberCell :: (Read a) => CSV.CSVField -> Exceptional String a
parseNumberCell field = do
   str <- cellContent field
   ME.fromMaybe (printf "field content \"%s\" is not a number" str) $
      maybeRead str

parseSquareMatrixCells ::
   (Read a, Algo.Field a) =>
   Int -> CSVParser (Matrix a)
parseSquareMatrixCells n = do
   rows <- replicateM n parseVectorCells
   assert (not $ null rows) "no rows"
   assert (all ((n==) . Vector.dim) rows) "inconsistent matrix dimensions"
   return $ Matrix.fromRows rows

parseStringList ::
   CSV.CSVRow -> CSVParser [String]
parseStringList =
   MT.lift . mapM cellContent .
   ListHT.dropWhileRev (null . CSV.csvFieldContent)

ext: hs

max_stars_repo_name: rybern/hmm-hmatrix

max_issues_repo_name: rybern/hmm-hmatrix

max_forks_repo_name: rybern/hmm-hmatrix


text:
{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-}
{-# LANGUAGE MultiParamTypeClasses, TypeFamilies                   #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | This Library provides some *dangerous* instances for @Double@s and @Complex@.
module Algebra.Instances () where
import Algebra.Scalar

import           AlgebraicPrelude
import           Control.DeepSeq       (NFData (..))
import           Control.Monad.Random  (Random (..), getRandom)
import           Control.Monad.Random  (getRandomR, runRand)
import           Data.Complex          (Complex (..))
import           Data.Convertible.Base (Convertible (..))
import qualified Data.Ratio            as P
import qualified Data.Vector           as DV
import           Data.Vector.Instances ()
import qualified Numeric.Algebra       as NA
import qualified Prelude               as P

instance Additive r => Additive (DV.Vector r) where
  (+) = DV.zipWith (+)

-- | These Instances are not algebraically right, but for the sake of convenience.
instance DecidableZero r => DecidableZero (Complex r) where
  isZero (a :+ b) = isZero a && isZero b

instance (NFData a) => NFData (Fraction a) where
  rnf a = rnf (numerator a) `seq` rnf (denominator a) `seq` ()

instance Additive r => Additive (Complex r) where
  (a :+ b) + (c :+ d) = (a + c) :+ (b + d)
instance Abelian r => Abelian (Complex r) where
instance (Group r, Semiring r) => Semiring (Complex r) where
instance (Group r, Rig r) => Rig (Complex r) where
  fromNatural = (:+ zero) . fromNatural
instance (Group r, Commutative r) => Commutative (Complex r) where
instance Ring r => Ring (Complex r) where
  fromInteger = (:+ zero) . fromInteger'
instance Group r => Group (Complex r) where
  (a :+ b) - (c :+ d) = (a - c) :+ (b - d)
  negate (a :+ b) = negate a :+ negate b
  times n (a :+ b) = times n a :+ times n b
instance LeftModule a r => LeftModule a (Complex r) where
  r .* (a :+ b) = (r .* a) :+ (r .* b)
instance RightModule a r => RightModule a (Complex r) where
  (a :+ b) *. r = (a *. r) :+ (b *. r)
instance Monoidal r => Monoidal (Complex r) where
  zero = zero :+ zero
instance (Group r, Monoidal r, Unital r) => Unital (Complex r) where
  one = one :+ zero
instance Additive Double where
  (+) = (P.+)
instance (Group r, Multiplicative r) => Multiplicative (Complex r) where
  (a :+ b) * (c :+ d) = (a*c - b*d) :+ (a*d + b*c)
instance LeftModule Natural Double where
  n .* d = fromIntegral n P.* d
instance RightModule Natural Double where
  d *. n = d P.* fromIntegral n
instance Monoidal Double where
  zero = 0
instance Unital Double where
  one = 1
instance Multiplicative Double where
  (*) = (P.*)
instance Commutative Double where
instance Group Double where
  (-) = (P.-)
  negate = P.negate
  subtract = P.subtract
  times n r = P.fromIntegral n P.* r
instance LeftModule Integer Double where
  n .* r = P.fromInteger n * r
instance RightModule Integer Double where
  r *. n = r * P.fromInteger n
instance Rig Double where
  fromNatural = P.fromInteger . fromNatural
instance Semiring Double where
instance Abelian Double where
instance Ring Double where
  fromInteger = P.fromInteger
instance DecidableZero Double where
  isZero 0 = True
  isZero _ = False

instance Division Double where
  recip = P.recip
  (/)   = (P./)

instance P.Integral r => Additive (P.Ratio r) where
  (+) = (P.+)

instance P.Integral r => Abelian (P.Ratio r)

instance P.Integral r => LeftModule Natural (P.Ratio r) where
  n .* r = fromIntegral n P.* r

instance P.Integral r => RightModule Natural (P.Ratio r) where
  r *. n = r P.* fromIntegral n

instance P.Integral r => LeftModule Integer (P.Ratio r) where
  n .* r = P.fromInteger n P.* r

instance P.Integral r => RightModule Integer (P.Ratio r) where
  r *. n = r P.* P.fromInteger n

instance P.Integral r => Group (P.Ratio r) where
  (-)    = (P.-)
  negate = P.negate
  subtract = P.subtract
  times n r = P.fromIntegral n P.* r

instance P.Integral r => Commutative (P.Ratio r)

instance (Semiring r, P.Integral r) => LeftModule (Scalar r) (P.Ratio r) where
  Scalar n .* r = (n P.% 1) * r

instance (Semiring r, P.Integral r) => RightModule (Scalar r) (P.Ratio r) where
  r *. Scalar n = r * (n P.% 1)

instance P.Integral r => Multiplicative (P.Ratio r) where
  (*) = (P.*)

instance P.Integral r => Unital (P.Ratio r) where
  one = 1

instance P.Integral r => Division (P.Ratio r) where
  (/) = (P./)
  recip = P.recip

instance P.Integral r => Monoidal (P.Ratio r) where
  zero = 0

instance P.Integral r => Semiring (P.Ratio r)

instance P.Integral r => Rig (P.Ratio r) where
  fromNatural = P.fromIntegral

instance P.Integral r => Ring (P.Ratio r) where
  fromInteger = P.fromInteger

instance P.Integral r => DecidableZero (P.Ratio r) where
  isZero 0 = True
  isZero _ = False

instance P.Integral r => DecidableUnits (P.Ratio r) where
  isUnit 0 = False
  isUnit _ = True
  recipUnit 0 = Nothing
  recipUnit n = Just (P.recip n)
  r ^? n
    | r == 0 = Just 1
    | r /= 0 = Just (r P.^^ n)
    | r == 0 && n P.> 0 = Just 0
    | otherwise = Nothing

instance Convertible (Fraction Integer) Double where
  safeConvert a = Right $ P.fromInteger (numerator a) P./ P.fromInteger (denominator a)

instance Convertible (Fraction Integer) (Complex Double) where
  safeConvert a = Right $ P.fromInteger (numerator a) P./ P.fromInteger (denominator a) :+ 0

instance (Random (Fraction Integer)) where
  random = runRand $ do
    i <- getRandom
    j <- getRandom
    return $ i % (P.abs j + 1)
  randomR (a, b) = runRand $ do
    j <- succ . P.abs <$> getRandom
    let g = foldl1 P.lcm  [denominator a, denominator b, j]
        lb = g * numerator a `quot` denominator a
        ub = g * numerator b `quot` denominator b
    i <- getRandomR (lb, ub)
    return $ i % g

max_stars_repo_name: hangingman/computational-algebra

max_issues_repo_name: hangingman/computational-algebra

max_forks_repo_name: hangingman/computational-algebra


text:
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}

module Spinell.Fitting
    (fit,
     unscaledFit,
     mvarFit,
     mvarUnscaledFit,
     defFitOpt,
     FitOptions(..),
     Jacobianable(..),
     Model,
     UnboxedModel,
     getParams,
     getUnscaledParams) where

import Numeric.GSL.Fitting
import Numeric.LinearAlgebra
import Numeric.AD
import Numeric.AD.Internal.Reverse
import Data.Reflection

type FitData = [([Double],([Double],Double))]
type FitRes = ([(Double, Double)], Matrix Double)
type UnscaledFitRes = ([Double], Matrix Double)

--
type Model = (forall a . Floating a => [a]->[a]->[a])

type UnboxedModel = (forall a . Floating a => [a]->a->a)

box :: UnboxedModel -> Model
box unmodel = (\p -> \x -> return (unmodel p (x !! 0)))

--
type FullJacob = ([Double] -> [Double] -> [[Double]])

data Jacobianable = AutoJacob | ManualJacob FullJacob

sanitize :: Jacobianable -> Model -> FullJacob
sanitize AutoJacob model = mkJac model
sanitize (ManualJacob jac) model = jac

--

data FitOptions = FitOptions {
        jacob :: Jacobianable,
        iter :: Int,
        absTol :: Double,
        relTol :: Double
    }

defFitOpt = FitOptions { jacob = AutoJacob,iter = 1000,absTol = 1E-20,relTol = 1E-20 }

--

fit :: [Double]
     -> [Double]
     -> [Double]
     -> UnboxedModel
     -> [Double]
     -> FitOptions
     -> FitRes

fit xs ys sigma rawmodel guess fitparams
    | xeqy && ( seqx || seqone) = fitModelScaled setAbsTol setResTol setIter (box rawmodel, sanitize jacobian (box rawmodel)) fitdata guess
    | otherwise = error "Input data has the wrong size"
    where
    lx = length xs
    ly = length ys
    ls = length sigma
    xeqy = lx == ly
    seqx = ls == lx
    seqone = ls == 1

    jacobian = jacob fitparams --we extract the "jacobian" parameter from the record

    setIter = iter fitparams
    setAbsTol = absTol fitparams
    setResTol = relTol fitparams

    fitdata = formatData xs ys sigma

formatData :: [Double] -> [Double] -> [Double] -> FitData
formatData xs ys sigma
    |  length sigma == length xs = zip (return <$> xs) $ zip (return <$> ys) sigma
    |  length sigma == 1 = zip (return <$> xs) $ zip (return <$> ys) (repeat (head sigma))

unscaledFit :: [Double]
     -> [Double]
     -> UnboxedModel
     -> [Double]
     -> FitOptions
     -> UnscaledFitRes

unscaledFit xs ys rawmodel guess fitparams
    | xeqy = fitModel setAbsTol setResTol setIter (box rawmodel, sanitize jacobian (box rawmodel)) fitdata guess
    | otherwise = error "Input data has the wrong size"
    where
    lx = length xs
    ly = length ys
    xeqy = lx == ly

    jacobian = jacob fitparams

    setIter = iter fitparams
    setAbsTol = absTol fitparams
    setResTol = relTol fitparams

    fitdata = zip (return <$> xs) (return <$> ys)

mvarFit :: [[Double]]
     -> [[Double]]
     -> [Double]
     -> Model
     -> [Double]
     -> FitOptions
     -> FitRes

mvarFit xs ys sigma model guess fitparams
    | xeqy && ( seqx || seqone) = fitModelScaled setAbsTol setResTol setIter (model, sanitize jacobian model) fitdata guess
    | otherwise = error "Input data has the wrong size"
    where
    lx = length xs
    ly = length ys
    ls = length sigma
    xeqy = lx == ly
    seqx = ls == lx
    seqone = ls == 1

    jacobian = jacob fitparams

    setIter = iter fitparams
    setAbsTol = absTol fitparams
    setResTol = relTol fitparams

    fitdata = formatDataBoxed xs ys sigma

formatDataBoxed :: [[Double]] -> [[Double]] -> [Double] -> FitData
formatDataBoxed xs ys sigma
    |  length sigma == length xs = zip xs $ zip ys sigma
    |  length sigma == 1 = zip xs $ zip ys (repeat (head sigma))

mvarUnscaledFit :: [[Double]]
     -> [[Double]]
     -> Model
     -> [Double]
     -> FitOptions
     -> UnscaledFitRes

mvarUnscaledFit xs ys model guess fitparams
    | xeqy = fitModel setAbsTol setResTol setIter (model, sanitize jacobian model) fitdata guess
    | otherwise = error "Input data has the wrong size"
    where
    lx = length xs
    ly = length ys
    xeqy = lx == ly

    jacobian = jacob fitparams

    setIter = iter fitparams
    setAbsTol = absTol fitparams
    setResTol = relTol fitparams

    fitdata = zip xs ys

mkJac :: (Num a) => (forall s. Reifies s Tape => [Reverse s a] -> [Reverse s a] -> [Reverse s a])
       -> [a]
       -> [a]
       -> [[a]]

mkJac f p x = jacobian ((flip f) (fmap auto x)) p

getParams :: FitRes -> [Double]
getParams res = fst . unzip . fst $ res

getUnscaledParams :: UnscaledFitRes -> [Double]
getUnscaledParams res = fst res

max_stars_repo_name: Magalame/Spinell

max_issues_repo_name: Magalame/Spinell

max_forks_repo_name: Magalame/Spinell


text:
{-# LANGUAGE DataKinds       #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns    #-}

import           Data.Maybe
import           Numeric.Hamilton
import           Numeric.LinearAlgebra.Static
import qualified Data.Vector.Sized            as V

twoBody :: System 4 2
twoBody = mkSystem masses coordinates potential
  where
    masses :: R 4
    masses = vec4 10 10 1 1
    coordinates
        :: Floating a
        => V.Vector 2 a
        -> V.Vector 4 a
    coordinates (V2 r θ) = V4 (r1 * cos θ) (r1 * sin θ)
                              (r2 * cos θ) (r2 * sin θ)
      where
        r1 =   r *  1 / 11
        r2 = - r * 10 / 11
    potential
        :: Fractional a
        => V.Vector 2 a
        -> a
    potential (V2 r _) = - 10 / r       -- G = 1

pattern V2 :: a -> a -> V.Vector 2 a
pattern V2 x y <- (V.toList->[x,y])
  where
    V2 x y = fromJust (V.fromList [x,y])

pattern V4 :: a -> a -> a -> a -> V.Vector 4 a
pattern V4 x y z a <- (V.toList->[x,y,z,a])
  where
    V4 x y z a = fromJust (V.fromList [x,y,z,a])

config0 :: Config 2
config0 = Cfg (vec2 2   0)  -- initial positions
              (vec2 0 0.5)  -- initial velocities

phase0 :: Phase 2
phase0 = toPhase twoBody config0

evolution :: [Phase 2]
evolution = evolveHam' twoBody phase0 [0,0.1 .. 1]

evolution' :: [Phase 2]
evolution' = iterate (stepHam 0.1 twoBody) phase0

positions :: [R 2]
positions = phsPositions <$> evolution'

positions' :: [R 4]
positions' = underlyingPos twoBody <$> positions

main :: IO ()
main = withRows (take 25 positions) (disp 4)

max_stars_repo_name: mstksg/inCode

max_issues_repo_name: mstksg/inCode

max_forks_repo_name: mstksg/inCode


text:
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Data.Fingerprint (
  Fingerprint (..)
, WithFingerprint (..)
, HasFingerprint (..)
, fp
, fromByteString
, toByteString
, fromByteString16
, toByteString16
, sinkFingerprint
) where

import           Control.DeepSeq (NFData(rnf), ($!!))
import           Crypto.Hash
import           Crypto.Hash.Conduit (sinkHash)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Unsafe as BS
import           Data.Int
import           Data.Word
import           Data.Complex
import           Data.Conduit (Consumer)
import           Data.Maybe (fromJust)
import           Language.Haskell.TH
import           Language.Haskell.TH.Quote
import           Language.Haskell.TH.Syntax
import           System.IO.Unsafe
import           Foreign.Marshal.Utils (with)
import           Foreign.C.Types
import           Foreign.Ptr (castPtr)
import           Foreign.Storable (Storable, sizeOf)

newtype Fingerprint = FP { unFP :: Digest SHA256 }
  deriving (Eq, Ord, NFData)

instance Show Fingerprint where show = show . unFP

data WithFingerprint a = WithFingerprint Fingerprint a
  deriving (Eq, Ord, Show)

instance NFData a => NFData (WithFingerprint a) where
  rnf (WithFingerprint f a) = rnf f `seq` rnf a

fromByteString :: BS.ByteString -> Maybe Fingerprint
fromByteString = fmap FP . digestFromByteString

toByteString :: Fingerprint -> BS.ByteString
toByteString (FP h) = unsafeDupablePerformIO $
  BA.withByteArray h (BS.packCStringLen . (,BA.length h))

fromByteString16 :: BS.ByteString -> Maybe Fingerprint
fromByteString16 b16 =
  case B16.decode b16 of
    (bs,bad) | B.null bad -> fromByteString bs
    _                     -> Nothing

toByteString16 :: Fingerprint -> BS.ByteString
toByteString16 = B16.encode . toByteString

sinkFingerprint :: Monad m => Consumer BS.ByteString m Fingerprint
sinkFingerprint = fmap FP sinkHash

class HasFingerprint o where
  fingerprint :: o -> Fingerprint
  default fingerprint :: Storable o => o -> Fingerprint
  fingerprint o = unsafeDupablePerformIO $ with o $ \oPtr -> do
    x <- fingerprint <$> BS.unsafePackCStringLen (castPtr oPtr, sizeOf (undefined :: o))
    return $!! x
  {-# INLINE fingerprint #-}

instance Monoid Fingerprint where
  mempty = FP (hashFinalize hashInit)
  {-# INLINE mempty #-}
  mappend (FP a) (FP b) = FP . hashFinalize $ hashUpdates hashInit [a, b]
  {-# INLINE mappend #-}
  mconcat = FP . hashFinalize . hashUpdates hashInit . map unFP
  {-# INLINE mconcat #-}

instance {-# OVERLAPPABLE #-} (Foldable f, HasFingerprint o) => HasFingerprint (f o) where
  fingerprint = foldMap fingerprint
  {-# INLINE fingerprint #-}

fp ::QuasiQuoter
fp = QuasiQuoter
  { quoteExp = \s -> do
      loc <- location
      let h = fingerprint . BS.pack
            $ concatMap ($ loc) [loc_package, loc_module, show . loc_start, const s]
      [e|WithFingerprint h|]
  , quotePat = const (fail "Cannot apply fp quasiquoter in patterns")
  , quoteType = const (fail "Cannot apply fp quasiquoter in types")
  , quoteDec  = const (fail "Cannot apply fp quasiquoter in declarations")
  }

instance Lift Fingerprint where
  lift fp_ =
    return $ ConE 'FP
      `AppE` (VarE 'fromJust
      `AppE` (VarE 'digestFromByteString
      `AppE` (VarE 'unsafeDupablePerformIO
      `AppE` (VarE 'BS.unsafePackAddressLen
      `AppE` LitE (IntegerL $ fromIntegral $ BS.length bs)
      `AppE` LitE (StringPrimL (B.unpack bs))))))
    where bs = toByteString fp_

instance HasFingerprint (WithFingerprint a) where
  fingerprint (WithFingerprint f _) = f
  {-# INLINE fingerprint #-}

instance HasFingerprint Fingerprint where
  fingerprint = id
  {-# INLINE fingerprint #-}

instance HasFingerprint BS.ByteString where
  fingerprint = FP . hash
  {-# INLINE fingerprint #-}

instance HasFingerprint String where
  fingerprint = fingerprint . BS.pack
  {-# INLINE fingerprint #-}

instance HasFingerprint ()
instance HasFingerprint Word8
instance HasFingerprint Word16
instance HasFingerprint Word32
instance HasFingerprint Word64
instance HasFingerprint Int8
instance HasFingerprint Int16
instance HasFingerprint Int32
instance HasFingerprint Int64
instance HasFingerprint Int
instance HasFingerprint Float
instance HasFingerprint Double
instance HasFingerprint CInt
instance HasFingerprint CChar
instance HasFingerprint CShort
instance HasFingerprint CLong
instance HasFingerprint CLLong
instance HasFingerprint CUInt
instance HasFingerprint CUChar
instance HasFingerprint CUShort
instance HasFingerprint CULong
instance HasFingerprint CULLong
instance HasFingerprint CFloat
instance HasFingerprint CDouble
instance HasFingerprint (Complex Int)
instance HasFingerprint (Complex Int32)
instance HasFingerprint (Complex Int16)
instance HasFingerprint (Complex Float)
instance HasFingerprint (Complex Double)

max_stars_repo_name: GeoHS/geohs-fingerprint

max_issues_repo_name: GeoHS/geohs-fingerprint

max_forks_repo_name: GeoHS/geohs-fingerprint


text:
{-
 - Hacq (c) 2013 NEC Laboratories America, Inc.  All rights reserved.
 -
 - This file is part of Hacq.
 - Hacq is distributed under the 3-clause BSD license.
 - See the LICENSE file for more details.
 -}

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}

module Control.Monad.Quantum.ApproxSequence.Class (MonadApproxSequence(..), applyPrepareQubitApprox, applyGlobalPhase) where

import Control.Monad.Reader (ReaderT)
import Control.Monad.Trans (MonadTrans, lift)
import Data.Complex

import Control.Monad.Quantum.Class

class MonadQuantumBase w m => MonadApproxSequence w m | m -> w where
  -- |@applyOneQubitUnitary a c d w@ applies unitary U to wire w, where U is given by the following matrix:
  --
  -- > a c*
  -- > c d
  applyOneQubitUnitary :: Complex Double -> Complex Double -> Complex Double -> w -> m ()

-- |@applyPrepareQubitApprox a b@ prepares a qubit in a state a|0>+b|1>.
applyPrepareQubitApprox :: MonadApproxSequence w m => Complex Double -> Complex Double -> m w
applyPrepareQubitApprox a b = do
    w <- ancilla
    applyOneQubitUnitary a b (-conjugate a) w
    return w
{-# INLINABLE applyPrepareQubitApprox #-}

applyGlobalPhase :: (MonadQuantum w m, MonadApproxSequence w m) => Double -> m ()
applyGlobalPhase fraction =
    handleMaybeCtrl $ \ctrl ->
      case ctrl of
        Nothing -> return ()
        Just ctrlwire ->
          applyOneQubitUnitary 1 0 (cis (2 * pi * fraction)) ctrlwire
{-# INLINABLE applyGlobalPhase #-}

-- Instance for ReaderT

instance MonadApproxSequence w m => MonadApproxSequence w (ReaderT r m) where
  applyOneQubitUnitary a c d w = lift $ applyOneQubitUnitary a c d w
  {-# INLINABLE applyOneQubitUnitary #-}


text:
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
module Models.Rover
  (
    Rover (..)
  , getPolicyInput
  , nnVars
  , nnVarsNaive
  ) where

import Models.RoverDomain
import Models.Location
import Models.State

import qualified Data.Map as Map
import Data.List (sortOn)
import Numeric.LinearAlgebra.HMatrix (Vector, fromList, (!))

import NN.NeuralNetwork

import System.IO.Unsafe

data Rover = Rover
             {
               _roverState :: State
             , _roverNet   :: ((Network Double), NNVars)
             , _roverUuid :: Int
             }
           | Traitor
             {
               _roverState :: State
             , _roverNet :: ((Network Double), NNVars)
             , _roverUuid :: Int
             }

nnVars :: NNVars
nnVars = Map.fromList [("numberInputs", 12)
                      ,("numberHidden", 13)
                      ,("numberOutputs", 2)
                      ,("timesToTrain", 3)
                      ,("learningRate", 0.8)
                      ,("sigmoidOrTanh", 0)
                      ,("randomLowerBound", (-10))
                      ,("randomUpperBound", 10)
                      ,("mutationRate", 0.1)
                      ,("gaussianStdDev",1)
                      ,("gaussianMean",0)]

nnVarsNaive :: NNVars
nnVarsNaive = Map.fromList [("numberInputs", 8)
                           ,("numberHidden", 13)
                           ,("numberOutputs", 2)
                           ,("timesToTrain", 3)
                           ,("learningRate", 0.8)
                           ,("sigmoidOrTanh", 0)
                           ,("randomLowerBound", (-10))
                           ,("randomUpperBound", 10)
                           ,("mutationRate", 0.1)
                           ,("gaussianStdDev",1)
                           ,("gaussianMean",0)]

instance Actor Rover where
  getState (Rover s _ _) = s
  getState (Traitor s _ _) = s
  setState (Rover _ n i) s = Rover s n i
  setState (Traitor _ n i) s = Traitor s n i
  getID (Rover _ _ i) = i
  getID (Traitor _ _ i) = i
  getMove = getNextMove
  move r cmd = setState r (moveState (getState r) cmd)
  resetActor (x,y) g r = let b = (fromIntegral x, fromIntegral y)
                             (g', s) = getRandomState g b
                         in (g', setState r s)

instance Agent Rover where
  setPolicy (Rover s (_,v) i) n = Rover s (n,v) i
  setPolicy (Traitor s (_,v) i) n = Traitor s (n,v) i
  getPolicy (Rover _ n _) = fst n
  getPolicy (Traitor _ n _) = fst n
  getFitness d r = let s = getGlobalScore d in if isLoyal r then s else (-1) * s
  isLoyal (Rover _ _ _) = True
  isLoyal (Traitor _ _ _) = False

instance Show Rover where
  show (Rover _ _ i) = "R" ++ (show i)
  show (Traitor _ _ i) = "T" ++ (show i)

instance Eq Rover where
  (==) r1 r2 = getID r1 == getID r2

getNextMove domain agent =
  let cmd = toCmd $ get (getVars agent) (getPolicy agent) (getPolicyInput domain agent)
      currentState = getState agent
  in if inBounds domain (moveState currentState cmd) then cmd
     else getBackupMove domain currentState cmd

getPolicyInput dom a = let as = getState a
                           likeMe = if isLoyal a then isLoyal else not . isLoyal
                           numInputs = getNumInputs a

                           agentStates = map getState $ (getAgents dom)
                           otherStates = map getState $ filter (not . likeMe) (getAgents dom)
                           scoreStates = map getState (getScoring dom)
                           actorStates = filter (/= as) agentStates

                           quadActor = map (getQuad as) actorStates
                           quadScore = map ((+) 4 . getQuad as) scoreStates
                           quadOther = map ((+) 8 . getQuad as) otherStates

                           actorSWithQuad = zip actorStates quadActor
                           scoreSWithQuad = zip scoreStates quadScore
                           otherSWithQuad = zip otherStates quadOther
                           all = actorSWithQuad ++ scoreSWithQuad ++ otherSWithQuad

                           allOverR = map (\(a',q) -> (1.0 / (stateDistance as a'), q)) all
                           blanks = zip (replicate numInputs 0.0) [1..numInputs]
                           allSorted = sortOn snd (allOverR ++ blanks)
                       in fromList $ take numInputs $ map fst $ compress allSorted

-- given a list sorted by the second tuple value, if the second values are equal for
-- consecutive elements, sum the fst value
compress :: (Num a, Eq b) => [(a, b)] -> [(a, b)]
compress [] = []
compress (x:[]) = [x]
compress (x:y:zs) = if snd x == snd y then compress $ (fst x + fst y, snd x):zs
                    else x:(compress (y:zs))

getNumInputs :: Rover -> Int
getNumInputs r = round $ (getVars r) Map.! "numberInputs"

getVars (Rover _ (_,v) _) = v
getVars (Traitor _ (_,v) _) = v

-- difference in locations, as vector, then get angle with atan2 y' x'.
-- Rotate angle by x's orientation backwards, then compare to sectors
getBackupMove dom s (Move dx dy) =
  if inBounds dom (moveState s (Move dx 0)) then Move dx 0
  else if inBounds dom (moveState s (Move 0 dy)) then Move 0 dy
       else Turn (pi / 2)
getBackupMove _ _ _ = Turn (pi / 2)

-- Assuming tanh activation function, output will be between -1 and 1
-- In that case, take values directly as x and y and normalize to unit vector
-- Test: Don't normalize
toCmd :: Vector Double -> Cmd
toCmd vec = let (x,y) = (vec ! 0, vec ! 1)
            in Move x y

max_stars_repo_name: eklinkhammer/rover-domain

max_issues_repo_name: eklinkhammer/rover-domain

max_forks_repo_name: eklinkhammer/rover-domain


text:
{-|
Module: MachineLearning.MultiSvmClassifier
Description: Multiclass Support Vector Machines Classifier.
Copyright: (c) Alexander Ignatyev, 2017-2018.
License: BSD-3
Stability: experimental
Portability: POSIX

Multicalss Support Vector Machines Classifier.
-}

module MachineLearning.MultiSvmClassifier
(
  module MachineLearning.Model
  , module MachineLearning.Classification.MultiClass
  , MultiSvmClassifier(..)
)

where

import Prelude hiding ((<>))
import qualified Numeric.LinearAlgebra as LA
import Numeric.LinearAlgebra((<>), (<.>), (|||))
import qualified Data.Vector.Storable as V

import qualified MachineLearning as ML
import MachineLearning.Types (R, Vector, Matrix)
import MachineLearning.Utils (sumByRows, reduceByRowsV)
import MachineLearning.Model
import MachineLearning.Classification.MultiClass

-- | Multiclass SVM Classifier, takes delta and number of futures. Delta = 1.0 is good for all cases.
data MultiSvmClassifier = MultiSvm R Int

instance Classifier MultiSvmClassifier where
  cscore (MultiSvm _ _) x theta = x <> (LA.tr theta)

  chypothesis m x theta = predictions
    where scores = cscore m x theta
          predictions = reduceByRowsV (fromIntegral . LA.maxIndex) scores

  ccost m@(MultiSvm d _) lambda x y theta =
    let nSamples = fromIntegral $ LA.rows x
        scores = cscore m x theta
        correct_scores = LA.remap (LA.asColumn $ V.fromList [0..(fromIntegral $ LA.rows x)-1]) (LA.toInt $ LA.asColumn y) scores
        margins = scores - (correct_scores - (LA.scalar d))
        margins' = margins * LA.step margins
        loss = LA.sumElements(margins') / nSamples - d
        reg = (ccostReg lambda theta) / nSamples
    in loss + reg

  cgradient m@(MultiSvm d _) lambda x y theta =
    let nSamples = fromIntegral $ LA.rows x
        ys = processOutput m y
        scores = cscore m x theta
        correct_scores = LA.remap (LA.asColumn $ V.fromList [0..(fromIntegral $ LA.rows x)-1]) (LA.toInt $ LA.asColumn y) scores
        margins = scores - (correct_scores - (LA.scalar d))
        margins' = (1-ys)*(LA.step margins)  -- step == cmap (\x -> if x>0 then 1 else 0)
        k = sumByRows margins'
        margins'' = margins' - (ys * k)
        dw = ((LA.tr margins'') <> x) / nSamples
        reg = (cgradientReg lambda theta) / nSamples
     in dw + reg

  cnumClasses (MultiSvm _ nLabels) = nLabels

max_stars_repo_name: aligusnet/mltool

max_issues_repo_name: aligusnet/mltool

max_forks_repo_name: aligusnet/mltool


text:
import Control.Arrow
import System.Directory
import Data.Char
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.List
import qualified Data.Set as S
import qualified Data.Map.Strict as M
import qualified Data.IntMap.Strict as IM
import NLP.Stemmer
import Data.Ord
import Data.Function
import Data.SVM
import qualified Numeric.LinearAlgebra.Data as LA
import qualified Numeric.LinearAlgebra as LA

common_threshold = 200

-- Ratings are embedded in the file names, e.g., 100_7.txt has a rating of 7/10. Extract it.
getRating :: (Fractional a, Read a) => String -> a
getRating = (\x -> (x-5.5)/4.5) . read . takeWhile (/= '.') . drop 1 . dropWhile (/= '_')

-- Get the rating and text from all files in a directory.
readSamples :: (Fractional a, Read a) => String -> IO [(a, T.Text)]
readSamples dir = mapM ((sequence .) $ getRating &&& T.readFile . (dir++)) . filter ((/= '.') . head) =<< getDirectoryContents dir

-- All of the training data, which is located across two directories.
trainingSamples :: (Fractional a, Read a) => IO [(a, T.Text)]
validationSamples :: (Fractional a, Read a) => IO [(a, T.Text)]
--trainingSamples = (++) <$> readSamples "aclImdb/train/pos/" <*> readSamples "aclImdb/train/neg/"
trainingSamples = do
  pos <- readSamples "aclImdb/train/pos/"
  neg <- readSamples "aclImdb/train/neg/"
  return $ takeEvery 5 (pos ++ neg)

validationSamples = do
  pos <- readSamples "aclImdb/train/pos/"
  neg <- readSamples "aclImdb/train/neg/"
  return $ takeEvery 10 (undefined:(pos ++ neg))

-- Words to ignore
stoplist :: S.Set T.Text
stoplist = S.fromList $ map T.pack ["i", "me", "my", "she", "her", "he", "him", "his", "they", "them", "their", "it", "who", "this", "that", "which",
  "", "br", "the", "a", "an", "is", "was", "be", "have", "are", "had", "were", "do", "did",
  "and", "or", "to", "in", "for", "with", "as", "one", "at", "by", "about", "from", "other", "into", "when", "would", "than",
  "also", "how", "becaus", "could", "after", "thing", "dont", "year", "two", "after", "peopl", "get", "where", "did", "off"]

minimalStoplist = S.fromList $ map T.pack ["the", "a", "an", "to", "is", "that", ""]
negateList = S.fromList $ map T.pack ["not", "isnt"]

-- Word splitter which ignores puctuation and doesn't care about capitalization or apostrophes.
words' :: T.Text -> [T.Text]
words' = map (stem' English) . filter (not . T.null) . T.split (not . isAlpha) . T.toLower . T.filter (/= '\'')

-- Apply +/- modifier to word list
preFilter :: Num a => [T.Text] -> [(a, T.Text)]
preFilter [] = []
preFilter (w:ws)
  | w `S.member` negateList = alterFirst (first negate) (preFilter ws)
  | w `S.member` minimalStoplist = preFilter ws
  | T.pack "un" `T.isPrefixOf` w = (-1, T.drop 2 w) : preFilter ws
  | T.pack "nt" `T.isSuffixOf` w = (-1, T.dropEnd 2 w) : preFilter ws
  | otherwise = (1, w) : preFilter ws
  where alterFirst f [] = []
        alterFirst f (x:xs) = (f x) : xs

-- Unify the number of occurences
bag :: Num a => [(a, T.Text)] -> [(a, T.Text)]
bag = map (sum . map fst &&& snd . head) . groupBy (curry $ uncurry (==) . both snd) . sortBy (comparing snd)

-- The stemming method from NLP.Stemmer, wrapped up to use Text insead of String
stem' :: Stemmer -> T.Text -> T.Text
stem' lang = T.pack . stem lang . T.unpack

-- The set of words in a dataset that meet the common threshold
common :: [(a, T.Text)] -> S.Set T.Text
common dataset = S.fromList . map snd . filter (\w -> fst w * common_threshold >= datalen) $ (df (`S.notMember` stoplist) dataset)
  where datalen = length dataset

-- Number of documents with each word not excluded by filter
df :: (T.Text -> Bool) -> [(a, T.Text)] -> [(Int, T.Text)]
df' :: (T.Text -> Bool) -> [(a, T.Text)] -> [(Float, T.Text)]
df' wf = map (log . balance . sum . map fst &&& snd . head) . groupBy ((==) `on` snd) . sortBy (comparing snd) . concatMap (bag . filter (wf . snd) . preFilter . words' . snd)
df wf = map (length &&& head) . group . sort . concatMap (map head . group . sort . filter wf . map snd . preFilter . words' . snd)
--df wf = map (length &&& head) . group . sort . concatMap (map head . group . sort . filter wf . words' . snd)

-- Calculates the Delta Inverse Document Frequency of the dataset
didf :: (Num a, Ord a) => S.Set T.Text -> [(a, T.Text)] -> M.Map T.Text Float
didf legalWords dataset = uncurry (M.unionWith (+)) . both (M.fromList . map swap) .
    (                     df' (`S.member` legalWords) . filter ((>0) . fst) &&&
     map (first negate) . df' (`S.member` legalWords) . filter ((<0) . fst)) $ dataset

massCorr :: Floating a => S.Set T.Text -> [(a, T.Text)] -> M.Map T.Text a
massCorr legalWords dataset = let (n, ex, ex2, eys) = moments in
    M.map (\(ey, ey2, exy) -> (exy - ex*ey/n) / sqrt ((ex2 - ex^2/n) * (ey2 - ey^2/n))) eys
  where initial = (0, 0, 0,                                                   -- n, E[x], E[x^2]
                   M.fromList (zip (S.toList legalWords) $ repeat (0, 0, 0))) -- E[y], E[y^2], E[xy]
        --updateInner (n, ex, ex2, eys) (x, (y, w)) = (n, ex, ex2, M.adjust (\(ey, ey2, exy) -> (ey+y, ey2+y^2, exy+x*y)) w eys)
        --updateInner :: (Float, Float, Float, M.Map T.Text (Float, Float, Float)) -> (Float, (Float, T.Text)) -> (Float, Float, Float, M.Map T.Text (Float, Float, Float))
        updateInner (n, ex, ex2, eys) (x, (y, w)) = (n, ex, ex2, M.adjust (\(ey, ey2, exy) -> (ey+y, ey2+y^2, exy+x*y)) w eys)
        --updateOuter :: (Float, Float, Float, M.Map T.Text (Float, Float, Float)) -> (Float, a) -> (Float, Float, Float, M.Map T.Text (Float, Float, Float))
        updateOuter (n, ex, ex2, eys) (x, _) = (n+1, ex+x, ex2+x^2, eys) -- TODO update this with bag
        --tokens :: (Float, T.Text) -> [(Float, (Float, T.Text))]
        tokens str = let wordList = preFilter . words' $ snd str; n = fromIntegral (length wordList) in
        --tokens str = let n = fromIntegral . length . words' . snd $ str in
            zip (repeat $ fst str) (map (first (/n)) $ bag wordList)
            --sequence $ second (map ((/n) . fromIntegral . length &&& head) . group . sort . words') str
        moments = foldl' (\acc d -> foldl' updateInner (updateOuter acc d) (tokens d)) initial dataset

massCorr' :: [(Double, b)] -> LA.Matrix Double -> (LA.Vector Double, Double)
massCorr' ys xss = let cov = (exy - LA.scale ey ex)
                       sx = LA.cmap sqrt (ex2 - ex^2)
                       sy = LA.konst (sqrt $ ey2 - ey^2) w
                   in (sx/sy, LA.dot ex (sy/sx) - ey)
  where (n, w) = first fromIntegral $ LA.size xss
        initial = (0, 0, LA.konst 0 w, LA.konst 0 w, LA.konst 0 w)
        update (sy, sy2, sx, sx2, sxy) (y, xs) = (sy+y, sy2+y^2, sx+xs, sx2+xs^2, sxy + LA.scale y xs)
        (ey, ey2, ex, ex2, exy) = (sy/n, sy2/n, LA.scale (1/n) sx, LA.scale (1/n) sx2, LA.scale (1/n) sxy)
          where (sy, sy2, sx, sx2, sxy) = foldl' update initial $ zip (map fst ys) (LA.toRows xss)

--model :: M.Map T.Text Float -> T.Text -> Float
--model weights str = let tokens = preFilter (words' str) in
--  (sum . map (\(n, w) -> n * M.findWithDefault 0 w weights)) (bag tokens) / fromIntegral (length tokens)

t2v :: M.Map T.Text Int -> M.Map T.Text Double -> T.Text -> LA.Vector Double
t2v lut weights t = LA.fromList $ map (flip (IM.findWithDefault 0) (t2v' lut weights t)) [0 .. length lut - 1]

t2v' :: M.Map T.Text Int -> M.Map T.Text Double -> T.Text -> IM.IntMap Double
t2v' lut weights t = IM.fromList . map (\(x, w) -> (lut M.! w, realToFrac $ weights M.! w * x)) . filter ((`M.member` lut) . snd) . bag . preFilter $ wordList
  where wordList = words' t
        n = fromIntegral $ length wordList
-- x, can also be x * weights!w or x * weights!w / n

data2m :: M.Map T.Text Int -> M.Map T.Text Double -> [(a, T.Text)] -> LA.Matrix Double
data2m lut weights = LA.fromRows . map (t2v lut weights . snd)

m2p :: [(Double, a)] -> LA.Matrix Double -> [(Double, IM.IntMap Double)]
m2p dataset = zip (map (clamp . fst) dataset) . map (\row -> IM.fromList $ map (id &&& (row LA.!)) [0 .. LA.size row - 1]) . LA.toRows

checkProblem :: Model -> [(Double, IM.IntMap Double)] -> IO [(Double, Double)]
checkProblem model = sequence . map (sequence . second (predict model))
--main = do
--  dataset <- trainingSamples
--  putStrLn "Data Loaded"
--  let legalWords = common dataset
--  let weights = didf legalWords dataset
--  --let weights = massCorr legalWords $ map (\(x, t) -> (if x > 0 then 1 else -1, t)) dataset
--  putStrLn "word scores:"
--  putStrLn . show $ sortBy (comparing snd) (M.toList weights)
--  let results = map (second $ model weights) dataset
--  let adjustment = r2 results
--  let results' =  map (\(x, t) -> ((x, crop $ model weights t * fst (snd adjustment) + snd (snd adjustment)), t)) dataset
--  let errors = sortBy (comparing $ abs . uncurry (-) . fst) results'
--  let accuracy = fromIntegral (length $ filter (uncurry (==) . both (>0) . fst) results') / fromIntegral (length results')
--  putStrLn $ "r²=" ++ show (fst adjustment) ++ "\taccuracy=" ++ show accuracy
--  putStrLn "least accurate:"
--  putStrLn . show $ take 50 (reverse errors)

main = do
  dataset <- trainingSamples
  let legalWords = common dataset
  let weights = realToFrac <$> didf legalWords dataset
  --let wordIndexes = let list = S.toList legalWords -- map fst . sortBy (comparing snd) . M.toList $ weights
  --                  in  M.fromList . (flip zip) [0..] $ take 300 list ++ take 300 (reverse list)
  putStrLn $ "words: (" ++ show (length legalWords) ++ ")"
  --putStrLn . show $ S.toList legalWords
  let wordIndexes = M.fromList $ zip (S.toList legalWords) [0..]
  let (u, s, v) = LA.thinSVD (data2m wordIndexes weights dataset)
  let nsv = 300
  let (u', s', v') = (u LA.?? (LA.All, LA.Take nsv), LA.subVector 0 nsv s, v LA.?? (LA.All, LA.Take nsv))
  --let (weights2, bias) = massCorr' dataset u'
  --putStrLn . show $ (weights2, bias)
  let dataset' = m2p dataset (u' LA.<> LA.diag s')
  svmModel <- train (CSvc 1.5) (RBF 0.01) dataset'
  resultsTraining <- checkProblem svmModel dataset'
  --let resultsTraining = zip (map fst dataset) (LA.toList $ (u' LA.#> weights2) + LA.konst bias nsv)
  validationDataset <- validationSamples
  --let u'2 = (LA.<> v') . data2m wordIndexes weights $ validationDataset
  --let resultsValidation = zip (map fst validationDataset) (LA.toList $ (u'2 LA.#> weights2) + LA.konst bias nsv)
  resultsValidation <- checkProblem svmModel . m2p validationDataset . (LA.<> v') . data2m wordIndexes weights $ validationDataset
  --let dataset' = map (\(x, t) -> (clamp x, t2v' wordIndexes t)) dataset
  --svmModel <- train (CSvc 10) Linear (dropEvery 5 dataset')
  --resultsTraining <- sequence $ map (sequence . second (predict svmModel)) (dropEvery 5 $ dataset')
  --resultsValidation <- sequence $ map (sequence . second (predict svmModel)) (takeEvery 5 $ dataset')
  let accuracy results = let a = (length $ filter (\(a, b) -> (a>0) == (b>0)) results)
                             n = (length results)
                         in show a ++ "/" ++ show n ++ " (" ++ show (100 * fromIntegral a / fromIntegral n) ++ "%)" -- corr=" ++ show (r2 results)
  putStrLn $ "training accuracy: " ++ accuracy resultsTraining ++ "\tvalidation accuracy: " ++ accuracy resultsValidation

crop :: (Num a, Ord a) => a -> a
crop = max (-1) . min 1

clamp :: (Num a, Ord a) => a -> a
clamp x = if x > 0 then 1 else -1

balance :: (Ord a, Fractional a) => a -> a
balance x = if x > 0 then 1 + x else 1 / (1 - x)

takeEvery :: Int -> [a] -> [a]
takeEvery n xs = case drop (n-1) xs of (y:ys) -> y : takeEvery n ys; [] -> []

dropEvery :: Int -> [a] -> [a]
dropEvery n xs = case splitAt (n-1) xs of (x, (y:ys)) -> x ++ dropEvery n ys; (x, []) -> x

r2 :: Floating a => [(a, a)] -> (a, (a, a))
r2 points = let n = fromIntegral (length points)
                ex = sum (map fst points) / n
                ey = sum (map snd points) / n
                sx = sqrt $ sum (map ((^2) . ((-)ex) . fst) points) / n
                sy = sqrt $ sum (map ((^2) . ((-)ey) . snd) points) / n
                cov = sum (map (\(x, y) -> (x - ex) * (y - ey)) points) / n
            in (cov / (sx * sy), (sx / sy, ex * sy / sx - ey))

both :: (a -> b) -> (a, a) -> (b, b)
both f (x, y) = (f x, f y)

swap :: (a, b) -> (b, a)
swap (x, y) = (y, x)

max_stars_repo_name: LyraSolomon/sentiment-analysis

max_issues_repo_name: LyraSolomon/sentiment-analysis

max_forks_repo_name: LyraSolomon/sentiment-analysis


text:
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleContexts #-}

module SymbolicDistr where

import Control.Monad (replicateM)
import Control.Monad.Bayes.Class (MonadSample)

import Data.Proxy (Proxy (Proxy))
import GHC.TypeNats (KnownNat)

import Numeric.LinearAlgebra.Static (R, Sym, L)

import DelayedSampling hiding (sample, observe, score)
import qualified DelayedSampling as DelS
import qualified Distributions as D
import qualified MVDistributions as D
import DSProg
import Util.Ref (Heap, Ref, MonadState)

data Distr s = DeepForce s => Distr
  { sample :: forall m. MonadState Heap m => MonadSample m => m s
  , observe :: forall m. DelayedInfer m => Forced s -> m ()
  -- Score should not modify the heap, but currently we do not
  -- enforce this
  , score :: forall m. DelayedInfer m => Forced s -> m Double
  }

distrToSymDistr :: forall a. D.Distr a -> Distr (Expr a)
distrToSymDistr d = Distr (Const <$> D.sample d) (D.observe d)
  (pure . D.score d)

symDistrWithFallback  :: forall a. (forall m. MonadState Heap m => MonadSample m => m (D.Distr a))
  -> (forall m. MonadState Heap m => MonadSample m => m (Maybe (Expr a)))
  -> (forall m. DelayedInfer m => (a -> m (Maybe ())))
  -> (forall m. DelayedInfer m => (a -> m (Maybe Double)))
  -> Distr (Expr a)
symDistrWithFallback  d is iobs iscore = Distr is' iobs' iscore' where
  pd :: MonadState Heap m => MonadSample m => m (Distr (Expr a))
  pd = distrToSymDistr <$> d
  is' :: MonadState Heap m => MonadSample m => m (Expr a)
  is' = do
    mx <- is
    case mx of
      Nothing -> pd >>= sample
      Just x -> pure x
  iobs' :: DelayedInfer m => a -> m ()
  iobs' obs = do
    mupd <- iobs obs
    case mupd of
      Nothing -> do
        d <- pd
        observe d obs
      Just () -> pure ()
  iscore' :: DelayedInfer m => a -> m Double
  iscore' obs = do
    mupd <- iscore obs
    case mupd of
      Nothing -> do
        d <- pd
        score d obs
      Just ll -> pure ll

replicateIID :: forall a. DeepForce a => D.Distr Int -> Distr a -> Distr [a]
replicateIID howMany d = Distr sam obs scorer where
  sam :: MonadState Heap m => MonadSample m => m [a]
  sam = do
    n <- D.sample howMany
    replicateM n (sample d)
  obs :: DelayedInfer m => [Forced a] -> m ()
  obs xs = D.observe howMany (length xs) >> mapM_ (observe d) xs
  scorer :: DelayedInfer m => [Forced a] -> m Double
  scorer xs = do
    let ll = D.score howMany (length xs)
    ll' <- sum <$> mapM (score d) xs
    pure (ll + ll')

bind :: forall a b. a ~ Forced a => DeepForce a => DeepForce b => D.Distr a -> (a -> Distr b) -> Distr (a, b)
bind d f = Distr sam obs scorer where
  sam :: MonadState Heap m => MonadSample m => m (a, b)
  sam = do
    x <- D.sample d
    y <- sample (f x)
    pure (x, y)
  obs :: DelayedInfer m => (a, Forced b) -> m ()
  obs (x, y) = D.observe d x >> observe (f x) y
  scorer :: DelayedInfer m => (a, Forced b) -> m Double
  scorer (x, y) = (D.score d x +) <$> score (f x) y

indep :: forall a b. DeepForce a => DeepForce b => Distr a -> Distr b -> Distr (a, b)
indep dx dy = Distr ((,) <$> sample dx <*> sample dy)
                    (\(x, y) -> observe dx x >> observe dy y)
                    (\(x, y) -> (+) <$> score dx x <*> score dy y)

normal :: Expr Double -> Double -> Distr (Expr Double)
normal mu var = symDistrWithFallback (D.normal <$> force mu <*> pure var) is iobs iscore where
  is :: MonadState Heap m => MonadSample m => m (Maybe (Expr Double))
  is = do
      mu' <- realizedToConst mu
      case getAffine1 mu' of
        Nothing -> pure Nothing
        Just (b, mx) -> do
          case mx of
            Nothing -> do
              nref <- assumeConstant "" (MGaussian b var)
              Just <$> forgettableVar nref
            Just (RefNodeToT par, m) -> do
              ty <- typeOfRefNodeToT par
              case ty of
                SMGaussianT -> do
                  nref <- assumeConditional "" par (AffineMeanGaussian m b var)
                  Just <$> forgettableVar nref
                _ -> pure Nothing
  withPrior :: forall m x. MonadState Heap m => MonadSample m => (forall a. Double -> Double -> Ref (Node a MGaussianT) -> m x) -> m (Maybe x)
  withPrior f = do
    mu' <- realizedToConst mu
    case getAffine1 mu' of
      Nothing -> pure Nothing
      Just (b, Nothing) -> pure Nothing
      Just (b, Just (RefNodeToT par, m)) -> do
        ty <- typeOfRefNodeToT par
        case ty of
          SMGaussianT -> Just <$> f m b par
          _ -> pure Nothing
  iobs :: DelayedInfer m => Double -> m (Maybe ())
  iobs obs = withPrior $ \m b par -> observeConditional "" par (AffineMeanGaussian m b var) obs
  iscore :: DelayedInfer m => Double -> m (Maybe Double)
  iscore obs = withPrior $ \m b par -> scoreConditional "" par (AffineMeanGaussian m b var) obs

mvNormal :: forall n. KnownNat n => Expr (R n) -> Sym n -> Distr (Expr (R n))
mvNormal mu var = symDistrWithFallback (D.mvNormal <$> force mu <*> pure var) is iobs iscore where
  is :: MonadState Heap m => MonadSample m => m (Maybe (Expr (R n)))
  is = do
    mu' <- realizedToConst mu
    case getAffineMV1 mu' of
      Nothing -> pure Nothing
      Just (b, mx) -> do
        case mx of
          Nothing -> do
            nref <- assumeConstant "" (MMVGaussian b var)
            Just <$> forgettableVar nref
          Just (AffineMVMult (RefNodeToT par) m) -> do
            ty <- typeOfRefNodeToT par
            case ty of
              SMMVGaussianT -> do
                nref <- assumeConditional "" par (MVAffineMeanGaussian m b var)
                Just <$> forgettableVar nref
  withPrior :: forall m x. MonadState Heap m => MonadSample m => (forall a k (p :: Proxy k). KnownNat k => L n k -> R n -> Ref (Node a (MMVGaussianT p)) -> m x) -> m (Maybe x)
  withPrior f = do
    mu' <- realizedToConst mu
    case getAffineMV1 mu' of
      Nothing -> pure Nothing
      Just (b, Nothing) -> pure Nothing
      Just (b, Just (AffineMVMult (RefNodeToT par) m)) -> do
        ty <- typeOfRefNodeToT par
        case ty of
          SMMVGaussianT -> Just <$> f m b par
  iobs :: DelayedInfer m => R n -> m (Maybe ())
  iobs obs = withPrior $ \m b par -> observeConditional "" par (MVAffineMeanGaussian m b var) obs
  iscore :: DelayedInfer m => R n -> m (Maybe Double)
  iscore obs = withPrior $ \m b par -> scoreConditional "" par (MVAffineMeanGaussian m b var) obs

betaSD :: Double -> Double -> Distr (Expr Double)
betaSD a b = symDistrWithFallback  (pure $ D.beta a b) is iobs (const (pure Nothing)) where
  is :: MonadState Heap m => MonadSample m => m (Maybe (Expr Double))
  is = Just <$> (assumeConstant "" (MBeta a b) >>= forgettableVar)
  iobs obs = pure Nothing

bernoulliSD :: Expr Double -> Distr (Expr Bool)
bernoulliSD p = symDistrWithFallback (D.bernoulli <$> force p) is iobs iscore where
  withBetaPrior :: forall m x. MonadState Heap m => MonadSample m => (forall a. Ref (Node a MBetaT) -> m x) -> m (Maybe x)
  withBetaPrior f = case p of
    Var (RefNodeToT par) -> do
      ty <- typeOfRefNodeToT par
      case ty of
        SMBetaT -> do
          Just <$> f par
        _ -> pure Nothing
    _ -> pure Nothing
  is :: MonadState Heap m => MonadSample m => m (Maybe (Expr Bool))
  is = withBetaPrior $ \par ->
    forgettableVar =<< assumeConditional "" par CBernoulli
  iobs obs = withBetaPrior $ \par ->
    observeConditional "" par CBernoulli obs
  iscore obs = withBetaPrior $ \par ->
    scoreConditional "" par CBernoulli obs

max_stars_repo_name: psg-mit/probzelus-haskell

max_issues_repo_name: psg-mit/probzelus-haskell

max_forks_repo_name: psg-mit/probzelus-haskell


text:
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLabels #-}

module Lib where

import Control.Applicative
import Prelude

import Data.Maybe
import GI.Gtk
       (widgetShowAll, onWidgetDestroy, setWindowDefaultHeight,
        setWindowDefaultWidth, setWindowTitle, boxPackStart, boxNew,
        frameSetShadowType, aspectFrameNew,
        widgetGetAllocatedHeight, widgetGetAllocatedWidth, onWidgetDraw,
        onWidgetLeaveNotifyEvent, onWidgetMotionNotifyEvent,
        widgetAddEvents, alignmentSetPadding, alignmentNew, rangeSetValue,
        scaleSetDigits, scaleSetValuePos, rangeGetValue,
        afterScaleButtonValueChanged, scaleNewWithRange, containerAdd,
        buttonBoxNew, mainQuit, onButtonActivate,
        toggleButtonGetActive, onToggleButtonToggled, buttonSetUseStock,
        toggleButtonNewWithLabel, onButtonClicked,
        buttonNewWithLabel, widgetQueueDraw, drawingAreaNew,
        windowNew, widgetDestroy, dialogRun, setAboutDialogComments,
        setAboutDialogAuthors, setAboutDialogVersion,
        setAboutDialogProgramName, aboutDialogNew, labelNew, get)
import qualified GI.Gtk as Gtk (DrawingArea(..), unsafeCastTo, Window(..)
                               , builderGetObject, builderAddFromFile, builderNew)
import GI.Cairo
import Control.Monad
import Data.IORef
import Data.List
import Data.Time
import Data.Complex
import Control.Monad.IO.Class (MonadIO(..))
import Graphics.Rendering.Cairo
       (fill, restore, save, stroke, arc, setDash, setLineWidth, rotate, rectangle,
        setSourceRGBA, setSourceRGB, newPath, scale, translate, lineTo,
        moveTo, Render)
import qualified GI.Gtk as GI (init, main)
import GI.GLib (sourceRemove, timeoutAdd)
import GI.Gdk
       (getEventMotionY, getEventMotionX, windowGetHeight,
        windowGetWidth, getEventMotionWindow)
import GI.Gdk.Flags (EventMask(..))
import Control.Monad.Trans.Reader (ReaderT(..))
import GI.Gtk.Enums
       (Orientation(..), WindowType(..), ShadowType(..), PositionType(..))

import Data.Monoid ((<>))
import Data.GI.Base.BasicConversions (gflagsToWord)
import Graphics.Rendering.Cairo.Types (Cairo(..))
import Foreign.Ptr (castPtr)
import Graphics.Rendering.Cairo.Internal (Render(..))

main :: IO ()
main = do

    GI.init Nothing

    builder <- Gtk.builderNew
    Gtk.builderAddFromFile builder "transparent.glade"
    mainWindow <- Gtk.builderGetObject builder "main_window" >>= Gtk.unsafeCastTo Gtk.Window . fromJust
    drawingArea <- Gtk.builderGetObject builder "drawing_area" >>= Gtk.unsafeCastTo Gtk.DrawingArea . fromJust

    screen <- mainWindow `get` #screen
    visual <- #getRgbaVisual screen
    #setVisual mainWindow visual

    onWidgetDraw drawingArea $ \(Context fp) -> withManagedPtr fp $ \p -> (`runReaderT` Cairo (castPtr p)) $ runRender $ do
      w <- liftIO $ fromIntegral <$> widgetGetAllocatedWidth drawingArea
      h <- liftIO $ fromIntegral <$> widgetGetAllocatedHeight drawingArea
      renderBG w h
      return True

    setWindowTitle mainWindow "TransparentHs"
    onWidgetDestroy mainWindow mainQuit
    widgetShowAll mainWindow

    GI.main

renderBG :: Double -> Double -> Render ()
renderBG w h = do
--  save
  setSourceRGBA 0.1953125 0.203125 0 0.6640625
  rectangle 0 0 w h
  fill
--  restore


text:
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeOperators    #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
module Main where

import qualified Control.Foldl                 as FL
import qualified Data.List                     as List
import           Data.Maybe                     ( fromMaybe )
import qualified Data.Text                     as T
import qualified Data.Vector.Storable          as V
import qualified Data.Vinyl                    as V
import qualified Frames                        as F

import           Numeric.LinearAlgebra          ( (#>)
                                                , (<#)
                                                , (<.>)
                                                , (<\>)
                                                )
import qualified Numeric.LinearAlgebra         as LA
import           Numeric.LinearAlgebra.Data     ( Matrix
                                                , R
                                                , Vector
                                                )
import qualified Numeric.LinearAlgebra.Data    as LA
import           Statistics.Types               ( cl95 )

import           Control.Applicative
import           Control.Monad
import           EasyTest
import           Control.Monad.IO.Class         ( MonadIO
                                                , liftIO
                                                )

import qualified Math.Regression.LeastSquares  as LS
import qualified Math.Regression.Regression    as RE

import qualified Knit.Effect.Logger            as KL
import qualified Polysemy.IO                   as P
import qualified Polysemy                      as P

main = runOnly "all" suite

suite :: Test
suite = scope "all.Regression" $ tests [testOLS, testWOLS, testTLS, testWTLS]

logged
  :: forall m a
   . MonadIO m
  => P.Sem '[KL.Logger KL.LogEntry, KL.PrefixLog, P.Lift IO, P.Lift m] a
  -> m a
logged = P.runM . P.runIO @m . KL.filteredLogEntriesToIO KL.logAll
-- regression tests

-- build some data for testing
-- uniformly distributed measurements, normally distributed noise.  Separate noise amplitudes for xs and ys
-- also allow building heteroscedastic data
buildRegressable
  :: [Double]
  -> Maybe (LA.Vector R)
  -> Double
  -> LA.Vector R
  -> Double
  -> IO (LA.Vector R, LA.Matrix R)
buildRegressable variances offsetsM noiseObs coeffs noiseMeas = do
  -- generate random measurements
  let d    = LA.size coeffs
      nObs = List.length variances
      xsO  = LA.asColumn (LA.fromList (List.replicate nObs 1))
        LA.<> LA.asRow (fromMaybe (LA.fromList $ List.replicate d 0) offsetsM)
  xs0    <- LA.rand nObs d
  xNoise <- LA.randn nObs d
  let xs  = xs0 + xsO + LA.scale noiseMeas xNoise
  let ys0 = (xs0 + xsO) LA.<> LA.asColumn coeffs
  yNoise <- fmap (List.head . LA.toColumns) (LA.randn nObs 1)
  let ys = ys0 + LA.asColumn
        (LA.scale
          noiseObs
          (V.zipWith (*) yNoise (LA.cmap sqrt (LA.fromList variances)))
        )
  return (List.head (LA.toColumns ys), xs)

unweighted :: Int -> [Double]
unweighted n = List.replicate n (1.0)

coneWeighted :: Int -> Double -> [Double]
coneWeighted n increment =
  let w0 = [ 1 + (realToFrac i) * increment | i <- [0 .. n] ]
      s  = realToFrac n / FL.fold FL.sum w0
  in  fmap (* s) w0

showText :: Show a => a -> T.Text
showText = T.pack . show

errR2 res = let r2 = RE.rSquared res in (r2 <= 1 && r2 > 0.0)
coeffs :: LA.Vector R = LA.fromList [1.0, 2.2, 0.3]
offsets :: LA.Vector R = LA.fromList [0, 1, 0]
vars = coneWeighted 100 0.1
varListToWeights = LA.cmap (\x -> 1 / sqrt x) . LA.fromList
wgts = varListToWeights vars

testRegression
  :: ( r
         ~
         '[KL.Logger KL.LogEntry, KL.PrefixLog, P.Lift IO, P.Lift (PropertyT IO)]
     ) --KL.LogWithPrefixesLE r
  => Double
  -> Double
  -> Bool
  -> Bool
  -> (  Matrix R
     -> Vector R
     -> Vector R
     -> P.Sem r (RE.RegressionResult R)
     )
  -> Test
testRegression yNoise xNoise weighted offset f = do
  let scopeT =
        "Vy="
          <> showText yNoise
          <> "; Vx="
          <> showText xNoise
          <> (if weighted then "; cone weights" else "")
          <> (if offset then "; w/offsets" else "")
      vars    = if weighted then coneWeighted 100 0.1 else unweighted 100
      wgts    = varListToWeights vars
      offsetM = if offset then (Just offsets) else Nothing
  property $ do
    (ys, xs) <- liftIO $ buildRegressable vars offsetM yNoise coeffs xNoise
    result   <- logged $ f xs ys wgts
    footnote
      ( T.unpack
      $ RE.prettyPrintRegressionResult "y" ["x1", "x2", "x3"] result cl95
      )
    success -- expect $ errR2 result

const3 f x y z = f x y

type RegressF = (Matrix R
                -> Vector R
                -> Vector R
                -> P.Sem
                   '[KL.Logger KL.LogEntry, KL.PrefixLog, P.Lift IO, P.Lift
                                                                     (PropertyT IO)]
                   (RE.RegressionResult R))

testOLS :: Test
testOLS =
  let regress :: RegressF
      regress xs ys ws = LS.ordinaryLS False xs ys
  in  scope "OLS" $ tests
        [ testRegression 0   0   False False regress
        , testRegression 0.1 0   False False regress
        , testRegression 0.5 0   False False regress
        , testRegression 0.1 0   False True  regress
        , testRegression 0.3 0.3 False False regress
        , testRegression 0.3 0   True  False regress
        , testRegression 0.3 0.3 True  False regress
        ]

testWOLS :: Test
testWOLS =
  let regress :: RegressF = LS.weightedLS False
  in  scope "WOLS" $ tests
        [ testRegression 0   0   True  False regress
        , testRegression 0.1 0   True  False regress
        , testRegression 0.1 0   False False regress
        , testRegression 0.3 0   True  False regress
        , testRegression 0.1 0.1 True  False regress
        , testRegression 0.1 0.1 True  True  regress
        , testRegression 0.3 0.3 True  False regress
        ]

testTLS :: Test
testTLS =
  let regress :: RegressF
      regress xs ys ws = LS.totalLS False xs ys
  in  scope "TLS" $ tests
        [ testRegression 0   0   False False regress
        , testRegression 0.1 0   False False regress
        , testRegression 0.5 0   False False regress
        , testRegression 0.1 0   False True  regress
        , testRegression 0.3 0.3 False False regress
        , testRegression 0.3 0   True  False regress
        , testRegression 0.3 0.3 True  False regress
        ]

testWTLS :: Test
testWTLS =
  let regress :: RegressF
      regress = LS.weightedTLS False
  in  scope "WTLS" $ tests
        [ testRegression 0   0   True  False regress
        , testRegression 0.1 0   True  False regress
        , testRegression 0.1 0   False False regress
        , testRegression 0.3 0   True  False regress
        , testRegression 0.1 0.1 True  False regress
        , testRegression 0.1 0.1 True  True  regress
        , testRegression 0.3 0.3 True  False regress
        ]

max_stars_repo_name: teto/Frames-utils

max_issues_repo_name: teto/Frames-utils

max_forks_repo_name: teto/Frames-utils