text:
{-# LANGUAGE CPP #-}

#if !(MIN_VERSION_base(4,16,0)) || !(MIN_VERSION_transformers(0,6,0))
{-# OPTIONS_GHC -fno-warn-deprecations #-}
#endif

#define GHC_GENERICS_OK __GLASGOW_HASKELL__ >= 702

#if GHC_GENERICS_OK
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
#endif

#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif

{-|
Module:      Data.Functor.Invariant
Copyright:   (C) 2012-2017 Nicolas Frisby, (C) 2015-2017 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Portability: Portable

Haskell98 invariant functors (also known as exponential functors).

For more information, see Edward Kmett's article \"Rotten Bananas\":

<http://comonad.com/reader/2008/rotten-bananas/>

-}
module Data.Functor.Invariant
  ( -- * @Invariant@
    Invariant(..)
  , invmapFunctor
#if GHC_GENERICS_OK
    -- ** @GHC.Generics@
    -- $ghcgenerics
  , genericInvmap
#endif
  , WrappedFunctor(..)
  , invmapContravariant
  , invmapProfunctor
  , invmapArrow
  , WrappedContravariant(..)
  , InvariantProfunctor(..)
  , InvariantArrow(..)
    -- * @Invariant2@
  , Invariant2(..)
  , invmap2Bifunctor
  , WrappedBifunctor(..)
  , invmap2Profunctor
  , WrappedProfunctor(..)
  ) where

-- base
import           Control.Applicative as App
import qualified Control.Arrow as Arr
import           Control.Arrow hiding (first, second)
import qualified Control.Category as Cat
import           Control.Exception (Handler(..))
import           Control.Monad (MonadPlus(..), liftM)
import qualified Control.Monad.ST as Strict (ST)
import qualified Control.Monad.ST.Lazy as Lazy (ST)
#if MIN_VERSION_base(4,4,0)
import           Data.Complex (Complex(..))
#endif
import qualified Data.Foldable as F (Foldable(..))
import qualified Data.Functor.Compose as Functor (Compose(..))
import           Data.Functor.Identity (Identity)
import           Data.Functor.Product as Functor (Product(..))
import           Data.Functor.Sum as Functor (Sum(..))
#if __GLASGOW_HASKELL__ < 711
import           Data.Ix (Ix)
#endif
import           Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Monoid as Monoid (First(..), Last(..), Product(..), Sum(..))
#if MIN_VERSION_base(4,8,0)
import           Data.Monoid (Alt(..))
#endif
import           Data.Monoid (Dual(..), Endo(..))
import           Data.Proxy (Proxy(..))
import qualified Data.Semigroup as Semigroup (First(..), Last(..))
#if !(MIN_VERSION_base(4,16,0))
import qualified Data.Semigroup as Semigroup (Option(..))
#endif
import           Data.Semigroup (Min(..), Max(..), Arg(..))
import qualified Data.Traversable as T (Traversable(..))
#if GHC_GENERICS_OK
import           GHC.Generics
#endif
import           System.Console.GetOpt as GetOpt
import           Text.ParserCombinators.ReadP (ReadP)
import           Text.ParserCombinators.ReadPrec (ReadPrec)

-- array
import           Data.Array (Array)

-- bifunctors
import           Data.Bifunctor
import           Data.Bifunctor.Biff
import           Data.Bifunctor.Clown
import           Data.Bifunctor.Fix
import           Data.Bifunctor.Flip
import           Data.Bifunctor.Join
import           Data.Bifunctor.Joker
import qualified Data.Bifunctor.Product as Bifunctor
import qualified Data.Bifunctor.Sum as Bifunctor
import           Data.Bifunctor.Tannen
import           Data.Bifunctor.Wrapped

-- comonad
import           Control.Comonad (Comonad(..), Cokleisli(..), liftW)

-- containers
import           Data.IntMap (IntMap)
import           Data.Map (Map)
import           Data.Sequence (Seq, ViewL, ViewR)
import           Data.Tree (Tree)

-- contravariant
import           Data.Functor.Contravariant
import           Data.Functor.Contravariant.Compose as Contravariant
import           Data.Functor.Contravariant.Divisible

-- profunctors
import           Data.Profunctor as Pro
import           Data.Profunctor.Cayley
import           Data.Profunctor.Choice
import           Data.Profunctor.Closed
import           Data.Profunctor.Composition
import           Data.Profunctor.Mapping
import           Data.Profunctor.Monad
import           Data.Profunctor.Rep
import           Data.Profunctor.Ran
import           Data.Profunctor.Strong
import           Data.Profunctor.Traversing
import           Data.Profunctor.Unsafe
import           Data.Profunctor.Yoneda

-- StateVar
import           Data.StateVar (StateVar(..), SettableStateVar(..))

-- stm
import           Control.Concurrent.STM (STM)

-- tagged
import           Data.Tagged (Tagged(..))

-- transformers
import           Control.Applicative.Backwards (Backwards(..))
import           Control.Applicative.Lift (Lift(..))
import           Control.Monad.Trans.Cont (ContT)
import           Control.Monad.Trans.Except (ExceptT(..), runExceptT)
import           Control.Monad.Trans.Identity (IdentityT, mapIdentityT)
import           Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)
import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))
import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST(..))
import           Control.Monad.Trans.Reader (ReaderT, mapReaderT)
import qualified Control.Monad.Trans.State.Lazy as Lazy (StateT(..))
import qualified Control.Monad.Trans.State.Strict as Strict (StateT(..))
import qualified Control.Monad.Trans.Writer.Lazy as Lazy (WriterT, mapWriterT)
import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT, mapWriterT)
#if !(MIN_VERSION_transformers(0,6,0))
import           Control.Monad.Trans.Error (ErrorT(..))
import           Control.Monad.Trans.List (ListT, mapListT)
#endif
import           Data.Functor.Constant (Constant(..))
import           Data.Functor.Reverse (Reverse(..))

-- unordered-containers
import           Data.HashMap.Lazy (HashMap)

-------------------------------------------------------------------------------
-- The Invariant class
-------------------------------------------------------------------------------

-- | Any @* -> *@ type parametric in the argument permits an instance of
-- @Invariant@.
--
-- Instances should satisfy the following laws:
--
-- > invmap id id = id
-- > invmap f2 f2' . invmap f1 f1' = invmap (f2 . f1) (f1' . f2')
class Invariant f where
  invmap :: (a -> b) -> (b -> a) -> f a -> f b
#if GHC_GENERICS_OK
  default invmap :: (Generic1 f, Invariant (Rep1 f)) => (a -> b) -> (b -> a) -> f a -> f b
  invmap = genericInvmap
#endif

-- | Every 'Functor' is also an 'Invariant' functor.
invmapFunctor :: Functor f => (a -> b) -> (b -> a) -> f a -> f b
invmapFunctor = flip $ const fmap

-- | Every 'Contravariant' functor is also an 'Invariant' functor.
invmapContravariant :: Contravariant f => (a -> b) -> (b -> a) -> f a -> f b
invmapContravariant = const contramap

-- | A 'Profunctor' with the same input and output types can be seen as an 'Invariant' functor.
invmapProfunctor :: Profunctor p => (a -> b) -> (b -> a) -> p a a -> p b b
invmapProfunctor = flip dimap

-- | An 'Arrow' with the same input and output types can be seen as an 'Invariant' functor.
invmapArrow :: Arrow arr => (a -> b) -> (b -> a) -> arr a a -> arr b b
invmapArrow fn1 fn2 arrow = arr fn1 Cat.. arrow Cat.. arr fn2

-------------------------------------------------------------------------------
-- Invariant instances
-------------------------------------------------------------------------------

instance Invariant Maybe where invmap = invmapFunctor
instance Invariant [] where invmap = invmapFunctor
instance Invariant IO where invmap = invmapFunctor
instance Invariant (Strict.ST s) where invmap = invmapFunctor
instance Invariant (Lazy.ST s) where invmap = invmapFunctor
instance Invariant ReadP where invmap = invmapFunctor
instance Invariant ReadPrec where invmap = invmapFunctor
instance Invariant ((->) a) where invmap = invmapFunctor
instance Invariant (Either a) where invmap = invmapFunctor
instance Invariant ((,) a) where invmap = invmapFunctor
instance Invariant ((,,) a b) where invmap f _ ~(a, b, x) = (a, b, f x)
instance Invariant ((,,,) a b c) where
  invmap f _ ~(a, b, c, x) = (a, b, c, f x)
instance Invariant ((,,,,) a b c d) where
  invmap f _ ~(a, b, c, d, x) = (a, b, c, d, f x)

-- | from "Control.Applicative"
instance Invariant (Const a) where invmap = invmapFunctor
-- | from "Control.Applicative"
instance Invariant ZipList where invmap = invmapFunctor
-- | from "Control.Applicative"
instance Monad m => Invariant (WrappedMonad m) where invmap = invmapFunctor
-- | from "Control.Applicative"
instance Arrow arr => Invariant (App.WrappedArrow arr a) where
  invmap f _ (App.WrapArrow x) = App.WrapArrow $ ((arr f) Cat.. x)

-- | from "Control.Arrow"
instance
#if MIN_VERSION_base(4,4,0)
  Arrow a
#else
  ArrowApply a
#endif
  => Invariant (ArrowMonad a) where
  invmap f _ (ArrowMonad m) = ArrowMonad (m >>> arr f)
-- | from "Control.Arrow"
instance Monad m => Invariant (Kleisli m a) where
  invmap = invmap2 id id

-- | from "Control.Exception"
instance Invariant Handler where
  invmap f _ (Handler h) = Handler (fmap f . h)

#if MIN_VERSION_base(4,4,0)
-- | from "Data.Complex"
instance Invariant Complex where
  invmap f _ (r :+ i) = f r :+ f i
#endif

-- | from "Data.Functor.Compose"
instance (Invariant f, Invariant g) => Invariant (Functor.Compose f g) where
  invmap f g (Functor.Compose x) =
    Functor.Compose (invmap (invmap f g) (invmap g f) x)

-- | from "Data.Functor.Identity"
instance Invariant Identity where
  invmap = invmapFunctor

-- | from "Data.Functor.Product"
instance (Invariant f, Invariant g) => Invariant (Functor.Product f g) where
  invmap f g (Functor.Pair x y) = Functor.Pair (invmap f g x) (invmap f g y)

-- | from "Data.Functor.Sum"
instance (Invariant f, Invariant g) => Invariant (Functor.Sum f g) where
  invmap f g (InL x) = InL (invmap f g x)
  invmap f g (InR y) = InR (invmap f g y)

-- | from "Data.List.NonEmpty"
instance Invariant NonEmpty where
  invmap = invmapFunctor

-- | from "Data.Monoid"
instance Invariant Dual where
  invmap f _ (Dual x) = Dual (f x)
-- | from "Data.Monoid"
instance Invariant Endo where
  invmap f g (Endo x) = Endo (f . x . g)
-- | from "Data.Monoid"
instance Invariant Monoid.First where
  invmap f g (Monoid.First x) = Monoid.First (invmap f g x)
-- | from "Data.Monoid"
instance Invariant Monoid.Last where
  invmap f g (Monoid.Last x) = Monoid.Last (invmap f g x)
-- | from "Data.Monoid"
instance Invariant Monoid.Product where
  invmap f _ (Monoid.Product x) = Monoid.Product (f x)
-- | from "Data.Monoid"
instance Invariant Monoid.Sum where
  invmap f _ (Monoid.Sum x) = Monoid.Sum (f x)
#if MIN_VERSION_base(4,8,0)
-- | from "Data.Monoid"
instance Invariant f => Invariant (Alt f) where
  invmap f g (Alt x) = Alt (invmap f g x)
#endif

-- | from "Data.Proxy"
instance Invariant Proxy where
  invmap = invmapFunctor

-- | from "Data.Semigroup"
instance Invariant Min where
  invmap = invmapFunctor
-- | from "Data.Semigroup"
instance Invariant Max where
  invmap = invmapFunctor
-- | from "Data.Semigroup"
instance Invariant Semigroup.First where
  invmap = invmapFunctor
-- | from "Data.Semigroup"
instance Invariant Semigroup.Last where
  invmap = invmapFunctor
-- | from "Data.Semigroup"
instance Invariant (Arg a) where
  invmap = invmapFunctor
#if !(MIN_VERSION_base(4,16,0))
-- | from "Data.Semigroup"
instance Invariant Semigroup.Option where
  invmap = invmapFunctor
#endif

-- | from "System.Console.GetOpt"
instance Invariant ArgDescr where
  invmap f _ (NoArg a)    = NoArg (f a)
  invmap f _ (ReqArg g s) = ReqArg (f . g) s
  invmap f _ (OptArg g s) = OptArg (f . g) s
-- | from "System.Console.GetOpt"
instance Invariant ArgOrder where
  invmap _ _ RequireOrder      = RequireOrder
  invmap _ _ Permute           = Permute
  invmap f _ (ReturnInOrder g) = ReturnInOrder (f . g)
-- | from "System.Console.GetOpt"
instance Invariant OptDescr where
  invmap f g (GetOpt.Option a b argDescr c) = GetOpt.Option a b (invmap f g argDescr) c

-- | from the @array@ package
instance
#if __GLASGOW_HASKELL__ < 711
  Ix i =>
#endif
    Invariant (Array i) where
  invmap = invmapFunctor

-- | from the @bifunctors@ package
instance (Invariant2 p, Invariant g) => Invariant (Biff p f g a) where
  invmap f g = Biff . invmap2 id id (invmap f g) (invmap g f) . runBiff
-- | from the @bifunctors@ package
instance Invariant (Clown f a) where
  invmap = invmapFunctor
-- | from the @bifunctors@ package
instance Invariant2 p => Invariant (Fix p) where
  invmap f g = In . invmap2 (invmap f g) (invmap g f) f g . out
-- | from the @bifunctors@ package
instance Invariant2 p => Invariant (Flip p a) where
  invmap = invmap2 id id
-- | from the @bifunctors@ package
instance Invariant2 p => Invariant (Join p) where
  invmap f g = Join . invmap2 f g f g . runJoin
-- | from the @bifunctors@ package
instance Invariant g => Invariant (Joker g a) where
  invmap f g = Joker . invmap f g . runJoker
-- | from the @bifunctors@ package
instance (Invariant f, Invariant2 p) => Invariant (Tannen f p a) where
  invmap = invmap2 id id
-- | from the @bifunctors@ package
instance Bifunctor p => Invariant (WrappedBifunctor p a) where
  invmap = invmap2 id id

-- | from the @comonad@ package
instance Invariant (Cokleisli w a) where
  invmap = invmapFunctor

-- | from the @containers@ package
instance Invariant IntMap where
  invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant (Map k) where
  invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant Seq where
  invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant ViewL where
  invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant ViewR where
  invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant Tree where
  invmap = invmapFunctor

-- | from the @contravariant@ package
instance Invariant Predicate where invmap = invmapContravariant
-- | from the @contravariant@ package
instance Invariant Comparison where invmap = invmapContravariant
-- | from the @contravariant@ package
instance Invariant Equivalence where invmap = invmapContravariant
-- | from the @contravariant@ package
instance Invariant (Op a) where invmap = invmapContravariant
-- | from the @contravariant@ package
instance (Invariant f, Invariant g) => Invariant (Contravariant.Compose f g) where
  invmap f g (Contravariant.Compose x) =
    Contravariant.Compose $ invmap (invmap f g) (invmap g f) x
-- | from the @contravariant@ package
instance (Invariant f, Invariant g) => Invariant (ComposeCF f g) where
  invmap f g (ComposeCF x) = ComposeCF $ invmap (invmap f g) (invmap g f) x
-- | from the @contravariant@ package
instance (Invariant f, Invariant g) => Invariant (ComposeFC f g) where
  invmap f g (ComposeFC x) = ComposeFC $ invmap (invmap f g) (invmap g f) x

-- | from the @profunctors@ package
instance Invariant f => Invariant (Star f a) where
  invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant (Costar f a) where
  invmap = invmapFunctor
-- | from the @profunctors@ package
instance Arrow arr => Invariant (Pro.WrappedArrow arr a) where
  invmap f _ (Pro.WrapArrow x) = Pro.WrapArrow $ ((arr f) Cat.. x)
-- | from the @profunctors@ package
instance Invariant (Forget r a) where
  invmap = invmapFunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Closure p a) where
  invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Codensity p a) where
  invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Coprep p) where
  invmap f g (Coprep h) = Coprep (h . invmap2 g f id id)
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Prep p) where
  invmap f g (Prep x p) = Prep x (invmap2 id id f g p)
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Procompose p q a) where
  invmap k k' (Procompose f g) = Procompose (invmap2 id id k k' f) g
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Rift p q a) where
  invmap bd db (Rift f) = Rift (f . invmap2 db bd id id)
-- | from the @profunctors@ package
instance Invariant2 q => Invariant (Ran p q a) where
  invmap bd db (Ran f) = Ran (invmap2 id id bd db . f)
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Tambara p a) where
  invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant (Cotambara p a) where
  invmap = invmapFunctor
-- | from the @profunctors@ package
instance Invariant (CotambaraSum p a) where
  invmap = invmapFunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (TambaraSum p a) where
  invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant (Yoneda p a) where
  invmap = invmapFunctor

-- | from the @StateVar@ package
instance Invariant StateVar where
  invmap f g (StateVar ga sa) = StateVar (fmap f ga) (lmap g sa)
-- | from the @StateVar@ package
instance Invariant SettableStateVar where
  invmap = invmapContravariant

-- | from the @stm@ package
instance Invariant STM where
  invmap = invmapFunctor

-- | from the @tagged@ package
instance Invariant (Tagged s) where
  invmap = invmapFunctor

-- | from the @transformers@ package
instance Invariant f => Invariant (Backwards f) where
  invmap f g (Backwards a) = Backwards (invmap f g a)
-- | from the @transformers@ package
instance Invariant f => Invariant (Lift f) where
  invmap f _ (Pure x)  = Pure (f x)
  invmap f g (Other y) = Other (invmap f g y)
-- | from the @transformers@ package
instance Invariant (ContT r m) where
  invmap = invmapFunctor
-- | from the @transformers@ package
instance Invariant m => Invariant (ExceptT e m) where
  invmap f g = ExceptT . invmap (invmap f g) (invmap g f) . runExceptT
-- | from the @transformers@ package
instance Invariant m => Invariant (IdentityT m) where
  invmap f g = mapIdentityT (invmap f g)
-- | from the @transformers@ package
instance Invariant m => Invariant (MaybeT m) where
  invmap f g = mapMaybeT $ invmap (invmap f g) (invmap g f)
-- | from the @transformers@ package
instance Invariant m => Invariant (Lazy.RWST r w s m) where
  invmap f g m = Lazy.RWST $ \r s ->
    invmap (mapFstTriple f) (mapFstTriple g) $ Lazy.runRWST m r s
      where mapFstTriple :: (a -> b) -> (a, c, d) -> (b, c, d)
            mapFstTriple h ~(a, s, w) = (h a, s, w)
-- | from the @transformers@ package
instance Invariant m => Invariant (Strict.RWST r w s m) where
  invmap f g m = Strict.RWST $ \r s ->
    invmap (mapFstTriple f) (mapFstTriple g) $ Strict.runRWST m r s
      where mapFstTriple :: (a -> b) -> (a, c, d) -> (b, c, d)
            mapFstTriple h (a, s, w) = (h a, s, w)
-- | from the @transformers@ package
instance Invariant m => Invariant (ReaderT r m) where
  invmap f g = mapReaderT (invmap f g)
-- | from the @transformers@ package
instance Invariant m => Invariant (Lazy.StateT s m) where
  invmap f g m = Lazy.StateT $ \s ->
    invmap (mapFstPair f) (mapFstPair g) $ Lazy.runStateT m s
      where mapFstPair :: (a -> b) -> (a, c) -> (b, c)
            mapFstPair h ~(a, s) = (h a, s)
-- | from the @transformers@ package
instance Invariant m => Invariant (Strict.StateT s m) where
  invmap f g m = Strict.StateT $ \s ->
    invmap (mapFstPair f) (mapFstPair g) $ Strict.runStateT m s
      where mapFstPair :: (a -> b) -> (a, c) -> (b, c)
            mapFstPair h (a, s) = (h a, s)
-- | from the @transformers@ package
instance Invariant m => Invariant (Lazy.WriterT w m) where
  invmap f g = Lazy.mapWriterT $ invmap (mapFstPair f) (mapFstPair g)
    where mapFstPair :: (a -> b) -> (a, c) -> (b, c)
          mapFstPair h ~(a, w) = (h a, w)
-- | from the @transformers@ package
instance Invariant m => Invariant (Strict.WriterT w m) where
  invmap f g = Strict.mapWriterT $ invmap (mapFstPair f) (mapFstPair g)
    where mapFstPair :: (a -> b) -> (a, c) -> (b, c)
          mapFstPair h (a, w) = (h a, w)
-- | from the @transformers@ package
instance Invariant (Constant a) where
  invmap = invmapFunctor
-- | from the @transformers@ package
instance Invariant f => Invariant (Reverse f) where
  invmap f g (Reverse a) = Reverse (invmap f g a)
#if !(MIN_VERSION_transformers(0,6,0))
-- | from the @transformers@ package
instance Invariant m => Invariant (ErrorT e m) where
  invmap f g = ErrorT . invmap (invmap f g) (invmap g f) . runErrorT
-- | from the @transformers@ package
instance Invariant m => Invariant (ListT m) where
  invmap f g = mapListT $ invmap (invmap f g) (invmap g f)
#endif

-- | from the @unordered-containers@ package
instance Invariant (HashMap k) where
  invmap = invmapFunctor

-------------------------------------------------------------------------------
-- WrappedFunctor
-------------------------------------------------------------------------------

-- | Wrap a 'Functor' to be used as a member of 'Invariant'.
newtype WrappedFunctor f a = WrapFunctor { unwrapFunctor :: f a }
  deriving (Eq, Ord, Read, Show)

instance Functor f => Invariant (WrappedFunctor f) where
  invmap = invmapFunctor

instance Functor f => Functor (WrappedFunctor f) where
  fmap f = WrapFunctor . fmap f . unwrapFunctor
  x <$ WrapFunctor f = WrapFunctor (x <$ f)

instance Applicative f => Applicative (WrappedFunctor f) where
  pure = WrapFunctor . pure
  WrapFunctor f <*> WrapFunctor x = WrapFunctor (f <*> x)
  WrapFunctor a *>  WrapFunctor b = WrapFunctor (a *>  b)
  WrapFunctor a <*  WrapFunctor b = WrapFunctor (a <*  b)

instance Alternative f => Alternative (WrappedFunctor f) where
  empty = WrapFunctor empty
  WrapFunctor x <|> WrapFunctor y = WrapFunctor (x <|> y)
  some = WrapFunctor . some . unwrapFunctor
  many = WrapFunctor . many . unwrapFunctor

instance Monad m => Monad (WrappedFunctor m) where
  WrapFunctor x >>= f = WrapFunctor (x >>= unwrapFunctor . f)
#if !(MIN_VERSION_base(4,11,0))
  return = WrapFunctor . return
  WrapFunctor a >> WrapFunctor b = WrapFunctor (a >> b)
#endif

instance MonadPlus m => MonadPlus (WrappedFunctor m) where
  mzero = WrapFunctor mzero
  WrapFunctor x `mplus` WrapFunctor y = WrapFunctor (x `mplus` y)

instance F.Foldable f => F.Foldable (WrappedFunctor f) where
  fold       = F.fold       . unwrapFunctor
  foldMap f  = F.foldMap f  . unwrapFunctor
  foldr f z  = F.foldr f z  . unwrapFunctor
  foldl f q  = F.foldl f q  . unwrapFunctor
  foldr1 f   = F.foldr1 f   . unwrapFunctor
  foldl1 f   = F.foldl1 f   . unwrapFunctor
#if MIN_VERSION_base(4,6,0)
  foldr' f z = F.foldr' f z . unwrapFunctor
  foldl' f q = F.foldl' f q . unwrapFunctor
#endif
#if MIN_VERSION_base(4,8,0)
  toList     = F.toList     . unwrapFunctor
  null       = F.null       . unwrapFunctor
  length     = F.length     . unwrapFunctor
  elem x     = F.elem x     . unwrapFunctor
  maximum    = F.maximum    . unwrapFunctor
  minimum    = F.minimum    . unwrapFunctor
  sum        = F.sum        . unwrapFunctor
  product    = F.product    . unwrapFunctor
#endif
#if MIN_VERSION_base(4,13,0)
  foldMap' f = F.foldMap' f . unwrapFunctor
#endif

instance T.Traversable f => T.Traversable (WrappedFunctor f) where
  traverse f = fmap  WrapFunctor . T.traverse f . unwrapFunctor
  sequenceA  = fmap  WrapFunctor . T.sequenceA  . unwrapFunctor
  mapM f     = liftM WrapFunctor . T.mapM f     . unwrapFunctor
  sequence   = liftM WrapFunctor . T.sequence   . unwrapFunctor

-------------------------------------------------------------------------------
-- WrappedContravariant
-------------------------------------------------------------------------------

-- | Wrap a 'Contravariant' functor to be used as a member of 'Invariant'.
newtype WrappedContravariant f a = WrapContravariant { unwrapContravariant :: f a }
  deriving (Eq, Ord, Read, Show)

instance Contravariant f => Invariant (WrappedContravariant f) where
  invmap = invmapContravariant

instance Contravariant f => Contravariant (WrappedContravariant f) where
  contramap f = WrapContravariant . contramap f . unwrapContravariant
  x >$ WrapContravariant f = WrapContravariant (x >$ f)

instance Divisible f => Divisible (WrappedContravariant f) where
  divide f (WrapContravariant l) (WrapContravariant r) =
    WrapContravariant $ divide f l r
  conquer = WrapContravariant conquer

instance Decidable f => Decidable (WrappedContravariant f) where
  lose = WrapContravariant . lose
  choose f (WrapContravariant l) (WrapContravariant r) =
    WrapContravariant $ choose f l r

-------------------------------------------------------------------------------
-- The Invariant2 class
-------------------------------------------------------------------------------

-- | Any @* -> * -> *@ type parametric in both arguments permits an instance of
-- @Invariant2@.
--
-- Instances should satisfy the following laws:
--
-- > invmap2 id id id id = id
-- > invmap2 f2 f2' g2 g2' . invmap2 f1 f1' g1 g1' =
-- >   invmap2 (f2 . f1) (f1' . f2') (g2 . g1) (g1' . g2')
class Invariant2 f where
  invmap2 :: (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> f a b -> f c d

-- | Every 'Bifunctor' is also an 'Invariant2' functor.
invmap2Bifunctor :: Bifunctor f
                 => (a -> c) -> (c -> a)
                 -> (b -> d) -> (d -> b)
                 -> f a b    -> f c d
invmap2Bifunctor f _ g _ = bimap f g

-- | Every 'Profunctor' is also an 'Invariant2' functor.
invmap2Profunctor :: Profunctor f
                  => (a -> c) -> (c -> a)
                  -> (b -> d) -> (d -> b)
                  -> f a b    -> f c d
invmap2Profunctor _ f' g _ = dimap f' g

-------------------------------------------------------------------------------
-- Invariant2 instances
-------------------------------------------------------------------------------

instance Invariant2 (->) where invmap2 = invmap2Profunctor
instance Invariant2 Either where invmap2 = invmap2Bifunctor
instance Invariant2 (,) where invmap2 f _ g _ ~(x, y) = (f x, g y)
instance Invariant2 ((,,) a) where invmap2 f _ g _ ~(a, x, y) = (a, f x, g y)
instance Invariant2 ((,,,) a b) where
  invmap2 f _ g _ ~(a, b, x, y) = (a, b, f x, g y)
instance Invariant2 ((,,,,) a b c) where
  invmap2 f _ g _ ~(a, b, c, x, y) = (a, b, c, f x, g y)

-- | from "Control.Applicative"
instance Invariant2 Const where invmap2 = invmap2Bifunctor
-- | from "Control.Applicative"
instance Arrow arr => Invariant2 (App.WrappedArrow arr) where
  invmap2 _ f' g _ (App.WrapArrow x) = App.WrapArrow $ arr g Cat.. x Cat.. arr f'

-- | from "Control.Arrow"
instance Monad m => Invariant2 (Kleisli m) where
  invmap2 _ f' g _ (Kleisli m) = Kleisli $ liftM g . m . f'

-- | from "Data.Semigroup"
instance Invariant2 Arg where
  invmap2 = invmap2Bifunctor

-- | from the @bifunctors@ package
instance (Invariant2 p, Invariant f, Invariant g) => Invariant2 (Biff p f g) where
  invmap2 f f' g g' =
    Biff . invmap2 (invmap f f') (invmap f' f) (invmap g g') (invmap g' g) . runBiff
-- | from the @bifunctors@ package
instance Invariant f => Invariant2 (Clown f) where
  invmap2 f f' _ _ = Clown . invmap f f' . runClown
-- | from the @bifunctors@ package
instance Invariant2 p => Invariant2 (Flip p) where
  invmap2 f f' g g' = Flip . invmap2 g g' f f' . runFlip
-- | from the @bifunctors@ package
instance Invariant g => Invariant2 (Joker g) where
  invmap2 _ _ g g' = Joker . invmap g g' . runJoker
-- | from the @bifunctors@ package
instance (Invariant2 f, Invariant2 g) => Invariant2 (Bifunctor.Product f g) where
  invmap2 f f' g g' (Bifunctor.Pair x y) =
    Bifunctor.Pair (invmap2 f f' g g' x) (invmap2 f f' g g' y)
-- | from the @bifunctors@ package
instance (Invariant2 p, Invariant2 q) => Invariant2 (Bifunctor.Sum p q) where
  invmap2 f f' g g' (Bifunctor.L2 l) = Bifunctor.L2 (invmap2 f f' g g' l)
  invmap2 f f' g g' (Bifunctor.R2 r) = Bifunctor.R2 (invmap2 f f' g g' r)
-- | from the @bifunctors@ package
instance (Invariant f, Invariant2 p) => Invariant2 (Tannen f p) where
  invmap2 f f' g g' =
    Tannen . invmap (invmap2 f f' g g') (invmap2 f' f g' g) . runTannen
-- | from the @bifunctors@ package
instance Bifunctor p => Invariant2 (WrappedBifunctor p) where
  invmap2 = invmap2Bifunctor

-- | from the @comonad@ package
instance Comonad w => Invariant2 (Cokleisli w) where
   invmap2 _ f' g _ (Cokleisli w) = Cokleisli $ g . w . liftW f'

-- | from the @contravariant@ package
instance Invariant2 Op where
  invmap2 f f' g g' (Op x) = Op $ invmap2 g g' f f' x

-- | from the @profunctors@ package
instance Invariant f => Invariant2 (Star f) where
  invmap2 _ ba cd dc (Star afc) = Star $ invmap cd dc . afc . ba
-- | from the @profunctors@ package
instance Invariant f => Invariant2 (Costar f) where
  invmap2 ab ba cd _ (Costar fbc) = Costar $ cd . fbc . invmap ba ab
-- | from the @profunctors@ package
instance Arrow arr => Invariant2 (Pro.WrappedArrow arr) where
  invmap2 _ f' g _ (Pro.WrapArrow x) = Pro.WrapArrow $ arr g Cat.. x Cat.. arr f'
-- | from the @profunctors@ package
instance Invariant2 (Forget r) where
  invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance (Invariant f, Invariant2 p) => Invariant2 (Cayley f p) where
  invmap2 f f' g g' =
    Cayley . invmap (invmap2 f f' g g') (invmap2 f' f g' g) . runCayley
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (Closure p) where
  invmap2 f f' g g' (Closure p) = Closure $ invmap2 (f .) (f' .) (g .) (g' .) p
-- | from the @profunctors@ package
instance Invariant2 (Environment p) where
  invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (Codensity p) where
  invmap2 ac ca bd db (Codensity f) =
    Codensity (invmap2 id id bd db . f . invmap2 id id ca ac)
-- | from the @profunctors@ package
instance (Invariant2 p, Invariant2 q) => Invariant2 (Procompose p q) where
  invmap2 l l' r r' (Procompose f g) =
    Procompose (invmap2 id id r r' f) (invmap2 l l' id id g)
-- | from the @profunctors@ package
instance (Invariant2 p, Invariant2 q) => Invariant2 (Rift p q) where
  invmap2 ac ca bd db (Rift f) = Rift (invmap2 ac ca id id . f . invmap2 db bd id id)
-- | from the @profunctors@ package
instance (Invariant2 p, Invariant2 q) => Invariant2 (Ran p q) where
  invmap2 ac ca bd db (Ran f) = Ran (invmap2 id id bd db . f . invmap2 id id ca ac)
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (Tambara p) where
  invmap2 f f' g g' (Tambara p) =
    Tambara $ invmap2 (first f) (first f') (first g) (first g') p
-- | from the @profunctors@ package
instance Invariant2 (PastroSum p) where
  invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (CofreeMapping p) where
  invmap2 f f' g g' (CofreeMapping p) =
    CofreeMapping (invmap2 (fmap f) (fmap f') (fmap g) (fmap g') p)
-- | from the @profunctors@ package
instance Invariant2 (FreeMapping p) where
  invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (CofreeTraversing p) where
  invmap2 f f' g g' (CofreeTraversing p) =
    CofreeTraversing (invmap2 (fmap f) (fmap f') (fmap g) (fmap g') p)
-- | from the @profunctors@ package
instance Invariant2 (FreeTraversing p) where
  invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 (Pastro p) where
  invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 (Cotambara p) where
  invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 (CopastroSum p) where
  invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 (CotambaraSum p) where
  invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (TambaraSum p) where
  invmap2 f f' g g' (TambaraSum p) =
    TambaraSum (invmap2 (first f) (first f') (first g) (first g') p)
-- | from the @profunctors@ package
instance Invariant2 (Yoneda p) where
  invmap2 = invmap2Profunctor

-- | from the @tagged@ package
instance Invariant2 Tagged where
  invmap2 = invmap2Bifunctor

-- | from the @transformers@ package
instance Invariant2 Constant where
  invmap2 f _ _ _ (Constant x) = Constant (f x)

-------------------------------------------------------------------------------
-- WrappedProfunctor
-------------------------------------------------------------------------------

-- | Wrap a 'Profunctor' to be used as a member of 'Invariant2'.
newtype WrappedProfunctor p a b = WrapProfunctor { unwrapProfunctor :: p a b }
  deriving (Eq, Ord, Read, Show)

instance Profunctor p => Invariant2 (WrappedProfunctor p) where
  invmap2 = invmap2Profunctor

instance Profunctor p => Invariant (WrappedProfunctor p a) where
  invmap = invmap2 id id

instance Profunctor p => Profunctor (WrappedProfunctor p) where
  dimap f g = WrapProfunctor . dimap f g . unwrapProfunctor
  lmap f    = WrapProfunctor . lmap f    . unwrapProfunctor
  rmap g    = WrapProfunctor . rmap g    . unwrapProfunctor
  WrapProfunctor x .# f = WrapProfunctor (x .# f)
  g #. WrapProfunctor x = WrapProfunctor (g #. x)

instance Cat.Category p => Cat.Category (WrappedProfunctor p) where
  id = WrapProfunctor Cat.id
  WrapProfunctor p1 . WrapProfunctor p2 = WrapProfunctor (p1 Cat.. p2)

instance Arrow p => Arrow (WrappedProfunctor p) where
  arr    = WrapProfunctor . arr
  first  = WrapProfunctor . Arr.first  . unwrapProfunctor
  second = WrapProfunctor . Arr.second . unwrapProfunctor
  WrapProfunctor p1 *** WrapProfunctor p2 = WrapProfunctor (p1 *** p2)
  WrapProfunctor p1 &&& WrapProfunctor p2 = WrapProfunctor (p1 &&& p2)

instance ArrowZero p => ArrowZero (WrappedProfunctor p) where
  zeroArrow = WrapProfunctor zeroArrow

instance ArrowPlus p => ArrowPlus (WrappedProfunctor p) where
  WrapProfunctor p1 <+> WrapProfunctor p2 = WrapProfunctor (p1 <+> p2)

instance ArrowChoice p => ArrowChoice (WrappedProfunctor p) where
  left  = WrapProfunctor . left  . unwrapProfunctor
  right = WrapProfunctor . right . unwrapProfunctor
  WrapProfunctor p1 +++ WrapProfunctor p2 = WrapProfunctor (p1 +++ p2)
  WrapProfunctor p1 ||| WrapProfunctor p2 = WrapProfunctor (p1 ||| p2)

instance ArrowLoop p => ArrowLoop (WrappedProfunctor p) where
  loop = WrapProfunctor . loop . unwrapProfunctor

instance Strong p => Strong (WrappedProfunctor p) where
  first'  = WrapProfunctor . first'  . unwrapProfunctor
  second' = WrapProfunctor . second' . unwrapProfunctor

instance Choice p => Choice (WrappedProfunctor p) where
  left'  = WrapProfunctor . left'  . unwrapProfunctor
  right' = WrapProfunctor . right' . unwrapProfunctor

instance Costrong p => Costrong (WrappedProfunctor p) where
  unfirst  = WrapProfunctor . unfirst  . unwrapProfunctor
  unsecond = WrapProfunctor . unsecond . unwrapProfunctor

instance Cochoice p => Cochoice (WrappedProfunctor p) where
  unleft  = WrapProfunctor . unleft  . unwrapProfunctor
  unright = WrapProfunctor . unright . unwrapProfunctor

instance Closed p => Closed (WrappedProfunctor p) where
  closed = WrapProfunctor . closed . unwrapProfunctor

instance Traversing p => Traversing (WrappedProfunctor p) where
  traverse' = WrapProfunctor . traverse' . unwrapProfunctor
  wander f  = WrapProfunctor . wander f  . unwrapProfunctor

instance Mapping p => Mapping (WrappedProfunctor p) where
  map' = WrapProfunctor . map' . unwrapProfunctor

instance ProfunctorFunctor WrappedProfunctor where
  promap f = WrapProfunctor . f . unwrapProfunctor

instance ProfunctorMonad WrappedProfunctor where
  proreturn = WrapProfunctor
  projoin   = unwrapProfunctor

instance ProfunctorComonad WrappedProfunctor where
  proextract   = unwrapProfunctor
  produplicate = WrapProfunctor

#if GHC_GENERICS_OK
-------------------------------------------------------------------------------
-- GHC Generics
-------------------------------------------------------------------------------

-- | from "GHC.Generics"
instance Invariant V1 where
  -- NSF 25 July 2015: I'd prefer an -XEmptyCase, but Haskell98.
  invmap _ _ x = x `seq` error "Invariant V1"
-- | from "GHC.Generics"
instance Invariant U1 where invmap _ _ _ = U1
-- | from "GHC.Generics"
instance (Invariant l, Invariant r) => Invariant ((:+:) l r) where
  invmap f g (L1 l) = L1 $ invmap f g l
  invmap f g (R1 r) = R1 $ invmap f g r
-- | from "GHC.Generics"
instance (Invariant l, Invariant r) => Invariant ((:*:) l r) where
  invmap f g ~(l :*: r) = invmap f g l :*: invmap f g r
-- | from "GHC.Generics"
instance Invariant (K1 i c) where invmap _ _ (K1 c) = K1 c
-- | from "GHC.Generics"
instance Invariant2 (K1 i) where invmap2 f _ _ _ (K1 c) = K1 $ f c
-- | from "GHC.Generics"
instance Invariant f => Invariant (M1 i t f) where invmap f g (M1 fp) = M1 $ invmap f g fp
-- | from "GHC.Generics"
instance Invariant Par1 where invmap f _ (Par1 c) = Par1 $ f c
-- | from "GHC.Generics"
instance Invariant f => Invariant (Rec1 f) where invmap f g (Rec1 fp) = Rec1 $ invmap f g fp
-- | from "GHC.Generics"
instance (Invariant f, Invariant g) => Invariant ((:.:) f g) where
  invmap f g (Comp1 fgp) = Comp1 $ invmap (invmap f g) (invmap g f) fgp

# if __GLASGOW_HASKELL__ >= 800
-- | from "GHC.Generics"
instance Invariant UAddr where
  invmap _ _ (UAddr a) = UAddr a

-- | from "GHC.Generics"
instance Invariant UChar where
  invmap _ _ (UChar c) = UChar c

-- | from "GHC.Generics"
instance Invariant UDouble where
  invmap _ _ (UDouble d) = UDouble d

-- | from "GHC.Generics"
instance Invariant UFloat where
  invmap _ _ (UFloat f) = UFloat f

-- | from "GHC.Generics"
instance Invariant UInt where
  invmap _ _ (UInt i) = UInt i

-- | from "GHC.Generics"
instance Invariant UWord where
  invmap _ _ (UWord w) = UWord w
# endif

{- $ghcgenerics
With GHC 7.2 or later, 'Invariant' instances can be defined easily using GHC
generics like so:

@
{-# LANGUAGE DeriveGeneric, FlexibleContexts #-}

import Data.Functor.Invariant
import GHC.Generics

data T f a = T (f a) deriving Generic1

instance Invariant f => 'Invariant' (T f)
@

Be aware that generic 'Invariant' instances cannot be derived for data types
that have function arguments in which the last type parameter appears in a
position other than the result type (e.g., @data Fun a = Fun (a -> a)@). For
these, you can derive them using the "Data.Functor.Invariant.TH" module.
-}

-- | A generic implementation of 'invmap'.
genericInvmap :: (Generic1 f, Invariant (Rep1 f)) => (a -> b) -> (b -> a) -> f a -> f b
genericInvmap f g = to1 . invmap f g . from1
#endif

-------------------------------------------------------------------------------
-- Wrappers
-------------------------------------------------------------------------------

-- | A 'Profunctor' with the same input and output types can be seen as an 'Invariant' functor.
newtype InvariantProfunctor p a = InvariantProfunctor (p a a)

instance Profunctor p => Invariant (InvariantProfunctor p) where
  invmap fn1 fn2 (InvariantProfunctor f) = InvariantProfunctor (dimap fn2 fn1 f)

-- | An 'Arrow' with the same input and output types can be seen as an 'Invariant' functor.
newtype InvariantArrow c a = InvariantArrow (c a a)

instance Arrow c => Invariant (InvariantArrow c) where
  invmap fn1 fn2 (InvariantArrow arrow) = InvariantArrow (arr fn1 Cat.. arrow Cat.. arr fn2)

max_stars_repo_name: nikita-volkov/invariant-functors

max_issues_repo_name: nikita-volkov/invariant-functors

max_forks_repo_name: nikita-volkov/invariant-functors


text:
module Shrinkage (
    strimmerX
  , testShrinkage
  ) where

import Numeric.LinearAlgebra
import Test.Tasty
import Test.Tasty.HUnit

import Statistics.Covariance.Shrinkage.Strimmer

strimmerX :: Matrix Double
strimmerX = matrix 3 [
    -1.1541680,  0.1229077,  0.2964592
  , -0.4574491, -0.0106610, -0.2497785
  ,  1.2711852,  0.2362810,  0.3653930
  ]

withinTolVec :: Double -> Vector Double -> Vector Double -> Bool
withinTolVec tol x x' = abs (x - x') < scalar tol

withinTolMat :: Double -> Matrix Double -> Matrix Double -> Bool
withinTolMat tol x x' = withinTolVec tol (flatten x) (flatten x')

strimmerpsmallSVD :: Assertion
strimmerpsmallSVD = assertBool "psmallSVD" $ withinTolMat tol u' u
  && withinTolVec tol s' s
  && withinTolMat tol v' v
  where
    tol = 1e-6
    (u, s, v) = psmallSVD strimmerX
    u' = matrix 3 [
         0.6256382, -0.7737046, -0.0997895
      ,  0.2669970,  0.3325596, -0.9044980
      , -0.7330003, -0.5392451, -0.4146388
      ]
    s' = vector [1.7850070, 0.5601167, 0.1101480]
    v' = matrix 3 [
        -0.99495870,  0.09886453,  0.01682235
      , -0.05554307, -0.40358205, -0.91325599
      , -0.08349942, -0.90958635,  0.40703871
      ]

strimmernsmallSVD :: Assertion
strimmernsmallSVD = assertBool "nsmallSVD" $ withinTolMat tol u' u
  && withinTolVec tol s' s
  && withinTolMat tol v' v
  where
    tol = 1e-6
    (u, s, v) = nsmallSVD strimmerX
    u' = matrix 3 [
        -0.6256382,  0.7737046, 0.0997895
      , -0.2669970, -0.3325596, 0.9044980
      ,  0.7330003,  0.5392451, 0.4146388
      ]
    s' = vector [1.7850070, 0.5601167, 0.1101480]
    v' = matrix 3 [
        0.99495870, -0.09886453, -0.01682235
      , 0.05554307,  0.40358205,  0.91325599
      , 0.08349942,  0.90958635, -0.40703871
      ]

strimmerposSVD :: Assertion
strimmerposSVD = assertBool "posSVD" $ withinTolMat tol u' u
  && withinTolVec tol s' s
  && withinTolMat tol v' v
  where
    tol = 1e-6
    (u, s, v) = posSVD strimmerX
    u' = matrix 3 [
        -0.6256382,  0.7737046, 0.0997895
      , -0.2669970, -0.3325596, 0.9044980
      ,  0.7330003,  0.5392451, 0.4146388
      ]
    s' = vector [1.7850070, 0.5601167, 0.1101480]
    v' = matrix 3 [
        0.99495870, -0.09886453, -0.01682235
      , 0.05554307,  0.40358205,  0.91325599
      , 0.08349942,  0.90958635, -0.40703871
      ]

strimmerCovShrink :: Assertion
strimmerCovShrink = assertBool "corpcor cor shrink is wrong" $ withinTolMat 1e-6 cov' cov
  where
    cov = unSym (covShrink strimmerX)
    cov' = matrix 3 [
        1.13853590, 0.06889376, 0.05675350
      , 0.06889376, 0.04389409, 0.03081658
      , 0.05675350, 0.03081658, 0.11359393
      ]

strimmerCorShrink :: Assertion
strimmerCorShrink = assertBool "corpcor cor shrink is wrong" $ withinTolMat 1e-6 cor' cor
  where
    cor = unSym (corShrink strimmerX)
    cor' = matrix 3 [
        1.0000000, 0.3081793, 0.1578126
      , 0.3081793, 1.0000000, 0.4364192
      , 0.1578126, 0.4364192, 1.0000000
      ]

strimmerCorCoef :: Assertion
strimmerCorCoef = assertBool msg $ abs (lambda - coef) < 0.0000001
  where
    lambda = 0.5311773
    coef = corCoef strimmerX
    msg = "expected: " ++ show lambda ++ "\n     got: " ++ show coef

strimmerVarCoef :: Assertion
strimmerVarCoef = assertBool "corpcor var coef is wrong" $ abs (lambda - varCoef strimmerX) < 0.0000001
  where lambda = 0.2910548

strimmerVarShrink :: Assertion
strimmerVarShrink = assertBool "corp var shrink" $ abs (v - varShrink strimmerX) < 0.0000001
  where v = vector [1.13853590, 0.04389409, 0.11359393]

testShrinkage :: TestTree
testShrinkage = testGroup "shrinkage" [
    testCase "strimmer varCoef" strimmerVarCoef
  , testCase "strimmer varShrink" strimmerVarShrink
  , testCase "strimmer corCoef" strimmerCorCoef
  , testCase "strimmer corShrink" strimmerCorShrink
  , testCase "strimmer covShrink" strimmerCovShrink
  , testCase "strimmer psmallSVD" strimmerpsmallSVD
  , testCase "strimmer nsmallSVD" strimmernsmallSVD
  , testCase "strimmer posSVD" strimmerposSVD
  ]

ext: hs

max_stars_repo_name: tsbattman/coviest

max_issues_repo_name: tsbattman/coviest

max_forks_repo_name: tsbattman/coviest


text:
module Haskfem
    ( solvePoisson
    , makeInterval
    , standardInterval
    ) where

import Numeric.LinearAlgebra

import Grid
import HaskfemInternal

-- $setup
-- >>> import Test.QuickCheck
-- >>> import Numeric.LinearAlgebra

-- | Return the solution of the Poisson's equation
-- > -c Δu = f
--
-- * Right-hand side is a constant
-- * Left-hand side parameter is a constant
-- * Domain is the unit interval
-- * homogeneous Dirichlet boundary conditions
--
-- No proper error handling for @c = 0.0@.
-- The constant 0.0 functions is the standard solution
-- The solution can be evaluated for all x in [0, 1] and returns 0 for points
-- outside of the domain.
--
-- The solution has same sign as @fc@ everywhere:
--
-- prop> (c :: R) * (f :: R) * (solvePoisson standardInterval (c :: R) (f :: R) (x :: R)) >= 0.0
--
-- Dirichlet boundary conditions are fulfilled:
--
-- prop> solvePoisson standardInterval (c :: R) (f :: R) 0.0 == 0.0
-- prop> solvePoisson standardInterval (c :: R) (f :: R) 1.0 == 0.0
solvePoisson :: Grid     -- ^ Grid on which to solve the equation
             -> R        -- ^ left-hand side constant parameter @c@
             -> R        -- ^ right-hand side constant @f@
             -> (R -> R)
solvePoisson _ 0 _ _ = 0.0
solvePoisson grid c f x = sum $ zipWith (*) (toList solVecFree) $ evalBasisF
  where evalBasisF = fmap ($ x) $ basisFuncs grid

        solVecFree = inv (sysMatFreeFree grid c) #> rhs grid f

max_stars_repo_name: bschwb/haskfem

max_issues_repo_name: bschwb/haskfem

max_forks_repo_name: bschwb/haskfem


text:
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}
{-|
Module      : Grenade.Layers.Deconvolution
Description : Deconvolution layer
Copyright   : (c) Huw Campbell, 2016-2017
License     : BSD2
Stability   : experimental

A deconvolution layer is in many ways a convolution layer in reverse.
It learns a kernel to apply to each pixel location, spreading it out
into a larger layer.

This layer is important for image generation tasks, such as GANs on
images.
-}
module Grenade.Layers.Deconvolution (
    Deconvolution (..)
  , Deconvolution' (..)
  ) where

import           Control.DeepSeq                     (NFData (..))
import           Data.Kind                           (Type)
import           Data.List                           (foldl1')
import           Data.Maybe
import           Data.Proxy
import           Data.Serialize
import           Data.Singletons.TypeLits            hiding (natVal)
import           GHC.TypeLits

import           Numeric.LinearAlgebra               hiding (konst,
                                                      uniformSample)
import qualified Numeric.LinearAlgebra               as LA
import           Numeric.LinearAlgebra.Static        hiding (build, toRows,
                                                      (|||))

import           Grenade.Core
import           Grenade.Layers.Internal.Convolution
import           Grenade.Layers.Internal.Update
import           Grenade.Utils.LinearAlgebra
import           Grenade.Utils.ListStore

-- | A Deconvolution layer for a neural network.
--   This uses the im2col Convolution trick popularised by Caffe.
--
--   The Deconvolution layer is a way of spreading out a single response
--   into a larger image, and is useful in generating images.
--
data Deconvolution :: Nat -- Number of channels, for the first layer this could be RGB for instance.
                   -> Nat -- Number of filters, this is the number of channels output by the layer.
                   -> Nat -- The number of rows in the kernel filter
                   -> Nat -- The number of column in the kernel filter
                   -> Nat -- The row stride of the Deconvolution filter
                   -> Nat -- The columns stride of the Deconvolution filter
                   -> Type where
  Deconvolution :: ( KnownNat channels
                   , KnownNat filters
                   , KnownNat kernelRows
                   , KnownNat kernelColumns
                   , KnownNat strideRows
                   , KnownNat strideColumns
                   , KnownNat kernelFlattened
                   , kernelFlattened ~ (kernelRows * kernelColumns * filters))
                 => !(L kernelFlattened channels) -- The kernel filter weights
                 -> !(ListStore (L kernelFlattened channels)) -- The last kernel update (or momentum)
                 -> Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns

instance NFData (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) where
  rnf (Deconvolution a b) = rnf a `seq` rnf b

instance ( KnownNat channels
         , KnownNat filters
         , KnownNat kernelRows
         , KnownNat kernelColumns
         , KnownNat strideRows
         , KnownNat strideColumns
         , KnownNat (kernelRows * kernelColumns * filters)
         ) => Serialize (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) where
  put (Deconvolution w store) = do
    putListOf put . toList . flatten . extract $ w
    put (fmap (toList . flatten . extract) store)
  get = do
      let f  = fromIntegral $ natVal (Proxy :: Proxy channels)
      wN    <- maybe (fail "Vector of incorrect size") return . create . reshape f . LA.fromList =<< getListOf get
      store <- fmap (fromMaybe (error "Vector of incorrect size") . create . reshape f . LA.fromList)  <$> get
      return $ Deconvolution wN store

data Deconvolution' :: Nat -- Number of channels, for the first layer this could be RGB for instance.
                    -> Nat -- Number of filters, this is the number of channels output by the layer.
                    -> Nat -- The number of rows in the kernel filter
                    -> Nat -- The number of column in the kernel filter
                    -> Nat -- The row stride of the Deconvolution filter
                    -> Nat -- The columns stride of the Deconvolution filter
                    -> Type where
  Deconvolution' :: ( KnownNat channels
                    , KnownNat filters
                    , KnownNat kernelRows
                    , KnownNat kernelColumns
                    , KnownNat strideRows
                    , KnownNat strideColumns
                    , KnownNat kernelFlattened
                    , kernelFlattened ~ (kernelRows * kernelColumns * filters))
                 => !(L kernelFlattened channels) -- The kernel filter gradient
                 -> Deconvolution' channels filters kernelRows kernelColumns strideRows strideColumns

instance NFData (Deconvolution' channels filters kernelRows kernelColumns strideRows strideColumns) where
  rnf (Deconvolution' a) = rnf a `seq` ()

instance ( KnownNat channels
         , KnownNat filters
         , KnownNat kernelRows
         , KnownNat kernelColumns
         , KnownNat strideRows
         , KnownNat strideColumns
         , KnownNat (kernelRows * kernelColumns * filters)
         ) =>
         Serialize (Deconvolution' channels filters kernelRows kernelColumns strideRows strideColumns) where
  put (Deconvolution' w) = putListOf put . toList . flatten . extract $ w
  get = do
    let f = fromIntegral $ natVal (Proxy :: Proxy channels)
    wN <- maybe (fail "Vector of incorrect size") return . create . reshape f . LA.fromList =<< getListOf get
    return $ Deconvolution' wN

instance (KnownNat channels
         , KnownNat filters
         , KnownNat kernelRows
         , KnownNat kernelColumns
         , KnownNat strideRows
         , KnownNat strideColumns) => FoldableGradient (Deconvolution' channels filters kernelRows kernelColumns strideRows strideColumns) where
  mapGradient f (Deconvolution' kernelGradient) = Deconvolution' (dmmap f kernelGradient)
  squaredSums (Deconvolution' kernelGradient) = [sumM . squareM $ kernelGradient]

instance Show (Deconvolution c f k k' s s') where
  show (Deconvolution a _) = renderConv a
    where
      renderConv mm =
        let m = extract mm
            ky = fromIntegral $ natVal (Proxy :: Proxy k)
            rs = LA.toColumns m
            ms = map (take ky) $ toLists . reshape ky <$> rs
            render n'
              | n' <= 0.2 = ' '
              | n' <= 0.4 = '.'
              | n' <= 0.6 = '-'
              | n' <= 0.8 = '='
              | otherwise = '#'
            px = (fmap . fmap . fmap) render ms
         in unlines $ foldl1 (zipWith (\a' b' -> a' ++ "   |   " ++ b')) px

instance ( KnownNat channels
         , KnownNat filters
         , KnownNat kernelRows
         , KnownNat kernelColumns
         , KnownNat strideRows
         , KnownNat strideColumns
         , KnownNat ((kernelRows * kernelColumns) * filters)
         , KnownNat ((kernelRows * kernelColumns) * channels)
         , KnownNat (channels * ((kernelRows * kernelColumns) * filters))
         ) =>
         RandomLayer (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) where
  createRandomWith m gen = do
    wN <- getRandomMatrix i i m gen
    return $ Deconvolution wN mkListStore
    where
      i = natVal (Proxy :: Proxy ((kernelRows * kernelColumns) * channels))

instance ( KnownNat channels
         , KnownNat filters
         , KnownNat kernelRows
         , KnownNat kernelColumns
         , KnownNat strideRows
         , KnownNat strideColumns
         , KnownNat (kernelRows * kernelColumns * filters)
         ) => UpdateLayer (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) where
  type Gradient (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) = (Deconvolution' channels filters kernelRows kernelColumns strideRows strideColumns)

  type MomentumStore (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns)  = ListStore (L (kernelRows * kernelColumns * filters) channels)

  runUpdate opt@OptSGD{} x@(Deconvolution oldKernel store) (Deconvolution' kernelGradient) =
    let oldMomentum = getData opt x store
        result = descendMatrix opt (MatrixValuesSGD oldKernel kernelGradient oldMomentum)
        newStore = setData opt x store (matrixMomentum result)
    in Deconvolution (matrixActivations result) newStore
  runUpdate opt@OptAdam{} x@(Deconvolution oldKernel store) (Deconvolution' kernelGradient) =
    let (m, v) = toTuple $ getData opt x store
        result = descendMatrix opt (MatrixValuesAdam (getStep store) oldKernel kernelGradient m v)
        newStore = setData opt x store [matrixM result, matrixV result]
    in Deconvolution (matrixActivations result) newStore
    where toTuple [m ,v] = (m, v)
          toTuple xs = error $ "unexpected input of length " ++ show (length xs) ++ "in toTuple in Convolution.hs"

  reduceGradient grads = Deconvolution' $ dmmap (/ (fromIntegral $ length grads)) (foldl1' add (map (\(Deconvolution' x) -> x) grads))

instance ( KnownNat channels
         , KnownNat filters
         , KnownNat kernelRows
         , KnownNat kernelColumns
         , KnownNat strideRows
         , KnownNat strideColumns
         , KnownNat (kernelRows * kernelColumns * filters)
         ) =>
         LayerOptimizerData (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) (Optimizer 'SGD) where
  type MomentumExpOptResult (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) (Optimizer 'SGD) = L (kernelRows * kernelColumns * filters) channels
  type MomentumDataType (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) (Optimizer 'SGD) = L (kernelRows * kernelColumns * filters) channels
  getData opt x store = head $ getListStore opt x store
  setData opt x store = setListStore opt x store . return
  newData _ _ = konst 0

instance ( KnownNat channels
         , KnownNat filters
         , KnownNat kernelRows
         , KnownNat kernelColumns
         , KnownNat strideRows
         , KnownNat strideColumns
         , KnownNat (kernelRows * kernelColumns * filters)
         ) => LayerOptimizerData (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) (Optimizer 'Adam) where
  type MomentumExpOptResult (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) (Optimizer 'Adam)  = [L (kernelRows * kernelColumns * filters) channels]
  type MomentumDataType (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) (Optimizer 'Adam) = L (kernelRows * kernelColumns * filters) channels
  getData = getListStore
  setData = setListStore
  newData _ _ = konst 0

-- | A two dimentional image may have a Deconvolution filter applied to it
instance ( KnownNat kernelRows
         , KnownNat kernelCols
         , KnownNat filters
         , KnownNat strideRows
         , KnownNat strideCols
         , KnownNat inputRows
         , KnownNat inputCols
         , KnownNat outputRows
         , KnownNat outputCols
         , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)
         , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)
         , KnownNat (kernelRows * kernelCols * filters)
         , KnownNat (outputRows * filters)
         ) => Layer (Deconvolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) where
  type Tape (Deconvolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols 1)
  runForwards c (S2D input) =
    runForwards c (S3D input :: S ('D3 inputRows inputCols 1))

  runBackwards c tape grads =
    case runBackwards c tape grads of
      (c', S3D back :: S ('D3 inputRows inputCols 1)) ->  (c', S2D back)

-- | A two dimentional image may have a Deconvolution filter applied to it
instance ( KnownNat kernelRows
         , KnownNat kernelCols
         , KnownNat strideRows
         , KnownNat strideCols
         , KnownNat inputRows
         , KnownNat inputCols
         , KnownNat outputCols
         , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)
         , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)
         , KnownNat (kernelRows * kernelCols * 1)
         , KnownNat (outputRows * 1)
         ) => Layer (Deconvolution 1 1 kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D2 outputRows outputCols) where
  type Tape (Deconvolution 1 1 kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D2 outputRows outputCols) = S ('D3 inputRows inputCols 1)
  runForwards c (S2D input) =
    case runForwards c (S3D input :: S ('D3 inputRows inputCols 1)) of
      (tps, S3D fore :: S ('D3 outputRows outputCols 1)) ->  (tps, S2D fore)

  runBackwards c tape (S2D grads) =
    case runBackwards c tape (S3D grads :: S ('D3 outputRows outputCols 1)) of
      (c', S3D back :: S ('D3 inputRows inputCols 1)) ->  (c', S2D back)

-- | A two dimentional image may have a Deconvolution filter applied to it
instance ( KnownNat kernelRows
         , KnownNat kernelCols
         , KnownNat strideRows
         , KnownNat strideCols
         , KnownNat inputRows
         , KnownNat inputCols
         , KnownNat outputCols
         , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)
         , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)
         , KnownNat (kernelRows * kernelCols * 1)
         , KnownNat (outputRows * 1)
         , KnownNat channels
         ) => Layer (Deconvolution channels 1 kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D2 outputRows outputCols) where
  type Tape (Deconvolution channels 1 kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D2 outputRows outputCols) = S ('D3 inputRows inputCols channels)
  runForwards c input =
    case runForwards c input of
      (tps, S3D fore :: S ('D3 outputRows outputCols 1)) ->  (tps, S2D fore)

  runBackwards c tape (S2D grads) =
    runBackwards c tape (S3D grads :: S ('D3 outputRows outputCols 1))

-- | A three dimensional image (or 2d with many channels) can have
--   an appropriately sized Deconvolution filter run across it.
instance ( KnownNat kernelRows
         , KnownNat kernelCols
         , KnownNat filters
         , KnownNat strideRows
         , KnownNat strideCols
         , KnownNat inputRows
         , KnownNat inputCols
         , KnownNat outputRows
         , KnownNat outputCols
         , KnownNat channels
         , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)
         , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)
         , KnownNat (kernelRows * kernelCols * filters)
         , KnownNat (outputRows * filters)
         ) => Layer (Deconvolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) where

  type Tape (Deconvolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols channels)

  runForwards (Deconvolution kernel _) (S3D input) =
    let ex = extract input
        ek = extract kernel
        ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
        iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)
        kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
        ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)
        sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
        sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)
        ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
        oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

        c  = vid2col 1 1 1 1 ix iy ex

        mt = c LA.<> tr ek

        r  = col2vid kx ky sx sy ox oy mt
        rs = fromJust . create $ r
    in  (S3D input, S3D rs)
  runBackwards (Deconvolution kernel _) (S3D input) (S3D dEdy) =
    let ex = extract input
        ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
        iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)
        kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
        ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)
        sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
        sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)
        ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
        oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

        c  = vid2col 1 1 1 1 ix iy ex

        eo = extract dEdy
        ek = extract kernel

        vs = vid2col kx ky sx sy ox oy eo

        kN = fromJust . create . tr $ tr c LA.<> vs

        dW = vs LA.<> ek

        xW = col2vid 1 1 1 1 ix iy dW
    in  (Deconvolution' kN, S3D . fromJust . create $ xW)

max_stars_repo_name: th-char/grenade

max_issues_repo_name: th-char/grenade

max_forks_repo_name: th-char/grenade


text:
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf            #-}
{-# LANGUAGE PatternSynonyms       #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeInType            #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE ViewPatterns          #-}

module Backprop.Learn.Model.Function (
  -- * Statistics
    meanModel
  , varModel
  , stdevModel
  , rangeModel
  -- * Activation functions
  -- | See <https://en.wikipedia.org/wiki/Activation_function>
  --
  -- ** Maps
  -- *** Unparameterized
  , step
  , logistic
  , softsign
  , reLU
  , softPlus
  , bentIdentity
  , siLU
  , softExponential
  , sinc
  , gaussian
  , tanh
  , atan
  , sin
  , vmap
  , vmap'
  -- *** Parameterized
  , liftUniform
  , isru
  , preLU
  , sreLU
  , sreLUPFP
  , eLU
  , isrLU
  , apl
  , aplPFP
  -- ** Mixing
  , softMax
  , maxout
  , kSparse
  ) where

import           Control.Category
import           Data.Foldable
import           Data.Profunctor
import           Data.Proxy
import           Data.Type.Tuple
import           GHC.TypeNats
import           Numeric.Backprop
import           Numeric.LinearAlgebra.Static.Backprop hiding (tr)
import           Prelude hiding                               ((.), id)
import qualified Control.Foldl                                as F
import qualified Data.Vector.Sized                            as SV
import qualified Data.Vector.Storable.Sized                   as SVS
import qualified Numeric.LinearAlgebra                        as HU
import qualified Numeric.LinearAlgebra.Static                 as H
import qualified Numeric.LinearAlgebra.Static.Vector          as H

meanModel
    :: (Backprop (t a), Foldable t, Functor t, Fractional a, Reifies s W)
    => BVar s (t a)
    -> BVar s a
meanModel = liftOp1 . op1 $ \xs ->
    let x :# n = F.fold ((:#) <$> F.sum <*> F.length) xs
    in  (x / fromIntegral n, \d -> (d / fromIntegral n) <$ xs)

varModel
    :: (Backprop (t a), Foldable t, Functor t, Fractional a, Reifies s W)
    => BVar s (t a)
    -> BVar s a
varModel = liftOp1 . op1 $ \xs ->
    let x2 :# x1 :# x0 = F.fold ((\x2' x1' x0' -> x2' :# x1' :# x0') <$> lmap (^(2::Int)) F.sum <*> F.sum <*> F.length) xs
        meanx  = x1 / fromIntegral x0
        subAll = 2 * x1 / (fromIntegral x0 ^ (2 :: Int))
    in  ( (x2 / fromIntegral x0) - meanx * meanx
        , \d -> let subAllD = d * subAll
                in  (\x -> d * 2 * x / fromIntegral x0 - subAllD) <$> xs
        )

stdevModel
    :: (Backprop (t a), Foldable t, Functor t, Floating a, Reifies s W)
    => BVar s (t a)
    -> BVar s a
stdevModel = sqrt . varModel

rangeModel
    :: (Backprop (t a), Foldable t, Functor t, Ord a, Num a, Reifies s W)
    => BVar s (t a)
    -> BVar s a
rangeModel = liftOp1 . op1 $ \xs ->
    let mn :# mx = F.fold ((:#) <$> F.minimum <*> F.maximum) xs
    in  case (:#) <$> mn <*> mx of
          Nothing           -> errorWithoutStackTrace "Backprop.Learn.Model.Function.range: empty range"
          Just (mn' :# mx') ->
            ( mx' - mn'
            , \d -> (\x -> if | x == mx'  -> d
                              | x == mn'  -> -d
                              | otherwise -> 0
                    ) <$> xs
            )

-- | Softmax normalizer
softMax
    :: (KnownNat i, Reifies s W)
    => BVar s (R i)
    -> BVar s (R i)
softMax x = expx / konst (norm_1V expx)
  where
    expx = exp x

-- | Logistic function
--
-- \[
-- \sigma(x) = \frac{1}{1 + e^{-x}}
-- \]
logistic :: Floating a => a -> a
logistic x = 1 / (1 + exp (-x))

-- | Binary step / heaviside step
--
-- To use with vectors ('R'), use 'vmap''.
--
-- \[
-- \begin{cases}
-- 0 & \text{for } x < 0 \\
-- 1 & \text{for } x \ge 0
-- \end{cases}
-- \]
step :: (Ord a, Num a) => a -> a
step x | x < 0     = 0
       | otherwise = 1

-- | Softsign activation function
--
-- \[
-- \frac{x}{1 + \lvert x \rvert}
-- \]
softsign :: Fractional a => a -> a
softsign x = x / (1 + abs x)

-- | Inverse square root unit
--
-- \[
-- \frac{x}{\sqrt{1 + \alpha x^2}}
-- \]
--
-- See 'liftUniform' to make this compatible with 'PFP'.
--
-- You can also just use this after partially applying it, to fix the
-- parameter (and not have it trained).
isru
    :: Floating a
    => a        -- ^ α (scaling parameter)
    -> a        -- ^ x
    -> a
isru α x = x / sqrt (1 + α * x * x)

-- | Rectified linear unit.
--
-- To use with vectors ('R'), use 'vmap''.
--
--
-- \[
-- \max(0,x)
-- \]
--
-- @
-- 'reLU' = 'preLU' 0
-- @
--
reLU :: (Num a, Ord a) => a -> a
reLU x | x < 0     = 0
       | otherwise = x

-- | Parametric rectified linear unit
--
-- To use with vectors ('R'), use 'vmap''.
--
-- If scaling parameter is a fixed (and not learned) parameter, this is
-- typically called a leaky recitified linear unit (typically with
-- α = 0.01).
--
-- To use as a learned parameter:
--
-- @
-- 'vmap' . 'preLU' :: 'BVar' s Double -> 'BVar' s ('R' n) -> BVar s (R n)
-- @
--
-- This can be give directly to 'PFP'.
--
-- To fix the paramater ("leaky"), just partially apply a parameter:
--
-- @
-- 'preLU' 0.01           :: 'BVar' s ('R' n) -> BVar s (R n)
-- preLU ('realToFrac' α) :: BVar s (R n) -> BVar s (R n)
-- @
--
-- See also 'rreLU'.
--
-- \[
-- \begin{cases}
-- \alpha x & \text{for } x < 0 \\
-- x        & \text{for } x \ge 0
-- \end{cases}
-- \]
preLU
    :: (Num a, Ord a)
    => a        -- ^ α (scaling parameter)
    -> a        -- ^ x
    -> a
preLU α x | x < 0     = α * x
          | otherwise = x

-- | Exponential linear unit
--
-- To use with vectors ('R'), use 'vmap''.
--
-- To use as a learned parameter:
--
-- @
-- 'vmap' . 'eLU' :: 'BVar' s Double -> 'BVar' s ('R' n) -> BVar s (R n)
-- @
--
-- This can be give directly to 'PFP'.
--
-- To fix the paramater, just partially apply a parameter:
--
-- @
-- 'vmap'' ('eLU' 0.01) :: 'BVar' s ('R' n) -> BVar s (R n)
-- @
--
-- \[
-- \begin{cases}
-- \alpha (e^x - 1) & \text{for } x < 0 \\
-- x                & \text{for } x \ge 0
-- \end{cases}
-- \]
eLU :: (Floating a, Ord a)
    => a        -- ^ α (scaling parameter)
    -> a        -- ^ x
    -> a
eLU α x | x < 0     = α * (exp x - 1)
        | otherwise = x

-- | S-shaped rectified linear activiation unit
--
-- See 'sreLUPFP' for an uncurried and uniformly lifted version usable with
-- 'PFP'.
--
-- \[
-- \begin{cases}
-- t_l + a_l (x - t_l) & \text{for } x \le t_l  \\
-- x                   & \text{for } t_l < x < t_r  \\
-- t_r + a_r (x - t_r) & \text{for } x \ge t_r
-- \end{cases}
-- \]
sreLU
    :: (Num a, Ord a)
    => a        -- ^ @t_l@
    -> a        -- ^ @a_l@
    -> a        -- ^ @t_r@
    -> a        -- ^ @a_l@
    -> a        -- ^ @x@
    -> a
sreLU tl al tr ar x
    | x < tl    = tl + al * (x - tl)
    | x > tr    = tr + ar * (x - tr)
    | otherwise = x

-- | An uncurried and uniformly lifted version of 'sreLU' directly usable
-- with 'PFP'.
sreLUPFP
    :: (KnownNat n, Reifies s W)
    => BVar s ((Double :# Double) :# (Double :# Double))
    -> BVar s (R n)
    -> BVar s (R n)
sreLUPFP ((tl :## al) :## (tr :## ar)) = vmap (sreLU tl al tr ar)

-- | Inverse square root linear unit
--
-- To use with vectors ('R'), use 'vmap''.
--
-- \[
-- \begin{cases}
-- \frac{x}{1 + \alpha x^2} & \text{for } x < 0 \\
-- x                        & \text{for } x \ge 0
-- \end{cases}
-- \]
isrLU
    :: (Floating a, Ord a)
    => a        -- ^ α
    -> a        -- ^ x
    -> a
isrLU α x
    | x < 0     = x / sqrt (1 + α * x * x)
    | otherwise = x

-- | Adaptive piecewise linear activation unit
--
-- See 'aplPFP' for an uncurried version usable with 'PFP'.
--
-- \[
-- \max(0, x_i) + \sum_j^M a_i^j \max(0, -x_i + b_i^j)
-- \]
apl :: (KnownNat n, KnownNat m, Reifies s W)
    => BVar s (L n m)     -- ^ a
    -> BVar s (L n m)     -- ^ b
    -> BVar s (R m)       -- ^ x
    -> BVar s (R m)
apl as bs x = vmap' (max 0) x
            + sum (toRows (as * (bs - fromRows (SV.replicate x))))

-- | 'apl' uncurried, to be directly usable with 'PFP'.
aplPFP
    :: (KnownNat n, KnownNat m, Reifies s W)
    => BVar s (L n m :# L n m)
    -> BVar s (R m)
    -> BVar s (R m)
aplPFP (a :## b) = apl a b

-- | SoftPlus
--
-- \[
-- \ln(1 + e^x)
-- \]
softPlus :: Floating a => a -> a
softPlus x = log (1 + exp x)

-- | Bent identity
--
-- \[
-- \frac{\sqrt{x^2 + 1} - 1}{2} + x
-- \]
bentIdentity :: Floating a => a -> a
bentIdentity x = (sqrt (x * x + 1) - 1) / 2 + x

-- | Sigmoid-weighted linear unit.  Multiply 'logistic' by its input.
--
-- \[
-- x \sigma(x)
-- \]
siLU :: Floating a => a -> a
siLU x = x * logistic x

-- | SoftExponential
--
-- To use with vectors ('R'), use 'vmap''.
--
-- \[
-- \begin{cases}
-- - \frac{\ln(1 - \alpha (x + \alpha))}{\alpha} & \text{for } \alpha < 0  \\
-- x                                             & \text{for } \alpha = 0  \\
-- \frac{e^{\alpha x} - 1}{\alpha} + \alpha      & \text{for } \alpha > 0
-- \end{cases}
-- \]
softExponential
    :: (Floating a, Ord a)
    => a            -- ^ α
    -> a            -- ^ x
    -> a
softExponential α x = case compare α x of
    LT -> - log (1 - α * (x + α)) / α
    EQ -> x
    GT -> (exp (α * x) - 1) / α + α

-- | Sinc
--
-- \[
-- \begin{cases}
-- 1                 & \text{for } x = 0  \\
-- \frac{\sin(x)}{x} & \text{for } x \ne 0
-- \end{cases}
-- \]
sinc :: (Floating a, Eq a) => a -> a
sinc 0 = 1
sinc x = sin x / x

-- | Gaussian
--
-- \[
-- e^{-x^2}
-- \]
gaussian :: Floating a => a -> a
gaussian x = exp (- (x * x))

-- | Maximum of vector.
--
-- Compare to 'norm_InfV', which gives the maximum absolute value.
maxout :: (KnownNat n, Reifies s W) => BVar s (R n) -> BVar s Double
maxout = liftOp1 . op1 $ \x ->
    let n = HU.maxElement . H.extract $ x
    in  ( n
        , \d -> H.vecR . SVS.map (\e -> if e == n then d else 0) . H.rVec $ x
        )

-- | Usable with functions like '*', 'isru', etc. to turn them into a form
-- usable with 'PFP':
--
-- @
-- 'liftUniform' ('*')  :: 'BVar' s 'Double' -> BVar s ('R' n) -> BVar s (R n)
-- liftUniform 'isru' :: BVar s Double -> BVar s (R n) -> BVar s (R n)
-- @
--
-- Basically turns a parmaeterized function on individual elements of
-- into one that shares the same parameter across all elements of the
-- vector.
liftUniform
    :: (Reifies s W, KnownNat n)
    => (BVar s (R n) -> r)
    -> BVar s Double
    -> r
liftUniform f = f . konst

-- -- TODO: vmap can do better.

-- | Keep only the top @k@ values, and zero out all of the rest.
--
-- Useful for postcomposing in between layers (with a logistic function
-- before) to encourage the number of "activated" neurons is kept to be
-- around @k@.  Used in k-Sprase autoencoders (see 'KAutoencoder').
--
-- <http://www.ericlwilkinson.com/blog/2014/11/19/deep-learning-sparse-autoencoders>
kSparse
    :: forall n s. (Reifies s W, KnownNat n)
    => Int                      -- ^ number of items to keep
    -> BVar s (R n)
    -> BVar s (R n)
kSparse k = liftOp1 . op1 $ \xs ->
    let xsSort = HU.sortVector (H.extract xs)
        thresh = xsSort `HU.atIndex` (n - k)
        mask   = H.dvmap (\x -> if x >= thresh then 1 else 0) xs
    in  ( H.dvmap (\x -> if x >= thresh then x else 0) xs
        , (* mask)
        )
  where
    n = fromIntegral $ natVal (Proxy @n)

max_stars_repo_name: mstksg/backprop-learn

max_issues_repo_name: mstksg/backprop-learn

max_forks_repo_name: mstksg/backprop-learn


text:
module Lib where

import Data.Complex
import qualified Data.Vector as V
import qualified Data.Vector.Storable as S
import qualified Data.Vector.Generic as G
import Codec.Picture

w :: Int
w = 500
h :: Int
h = 500
sz :: Float
sz = fromIntegral st / 2.5
st :: Int
st = 30

colors :: V.Vector PixelRGB8
colors = V.fromList [
    PixelRGB8 22 160 133,
    PixelRGB8 192 57 43,
    PixelRGB8 44 62 80,
    PixelRGB8 142 68 173 ]

roots :: [Complex Float]
roots = [
    10 :+ 6,
    (-2) :+ 4,
    (-3) :+ (-9),
    6 :+ (-3) ]

rootsV :: V.Vector (Complex Float)
rootsV = V.fromList roots

coefs :: [Complex Float]
coefs = coefsFromRoots rootsV
coefs' :: [Complex Float]
coefs' = deriveCoefs coefs

podd :: (Integral a, Num p) => a -> p
podd n
    | odd n = -1
    | otherwise = 1

binom :: Int -> Int -> [S.Vector Int]
binom n k
  | k < 0 = []
  | k > n = []
  | n <= 0 = [G.empty]
  | k == n = [G.enumFromN 1 n]
  | otherwise = binom (n-1) k ++ ((`G.snoc` n) <$> binom (n-1) (k-1))

coefsFromRoots :: (Num a, S.Storable a, G.Vector v a) => v a -> [a]
coefsFromRoots roots =
    let n = G.length roots
     in [ podd (n-k) * sum [ G.product (G.map (\i -> roots G.! (i-1)) p) | p <- binom n (n-k) ] | k <- [0..n] ]

deriveCoefs :: Num b => [b] -> [b]
deriveCoefs coefs = (\(i, c) -> fromIntegral i * c) <$> zip [1..] (tail coefs)

evalPoly :: Num a => [a] -> a -> a
evalPoly [] _ = 0
evalPoly (c0:cs) z = c0 + z * evalPoly cs z

newton :: (RealFloat a, Num t, Eq t) => t -> [Complex a] -> [Complex a] -> Complex a -> Complex a
newton steps coefs coefs' x0 =
    if steps == 0 || magnitude fx < 0.1 then x0
    else newton (steps - 1) coefs coefs' (x0 - fx/fpx)
    where
        fx = evalPoly coefs x0
        fpx = evalPoly coefs' x0

d :: RealFloat a => Complex a -> Complex a -> a
d c1 c2 = magnitude (c2 - c1)

pix :: Int -> Float -> Int -> Int -> PixelRGB8
pix st sz i j =
    let z = realToFrac i / sz :+ realToFrac j / sz
        zr = newton st coefs coefs' z
        (dist, idx) = minimum (zip [d zr r | r <- roots] [0..])
    in colors V.! idx

max_stars_repo_name: BENICHN/nf

max_issues_repo_name: BENICHN/nf

max_forks_repo_name: BENICHN/nf


text:
{-# LANGUAGE ScopedTypeVariables #-}

module AM (AMOptions(..), run, parseOpts) where

import           Data.ByteString.Builder
import           Data.Complex
import qualified Data.Vector.Storable as V
import           IQ
import qualified Filter as F
import           Pipes
import qualified Pipes.Prelude as P
import           Control.Monad
import           ZeroStuff
import           Render
import           Options.Applicative
import qualified Sound.File.Sndfile as SF
import qualified Sound.File.Sndfile.Buffer.Vector as SV
import           System.IO

data AMOptions = AMOptions
  { inputFile :: String
  , outputFile :: String
  , modIndex :: Int
  , upsample :: Int
  , filterOpts :: F.FilterOptions }

parseOpts :: Parser AMOptions
parseOpts = AMOptions
         <$> strOption
             ( long "in-file"
            <> short 'i'
            <> metavar "INPUT_FILE"
            <> help "Input sound file" )
         <*> strOption
             ( long "out-file"
            <> short 'o'
            <> metavar "OUTPUT_FILE"
            <> help "Output IQ file")
         <*> option auto
             ( long "modulation-index"
            <> short 'm'
            <> value 100
            <> showDefault
            <> metavar "MOD_INDEX"
            <> help "Modulation index, value between 1-100")
         <*> option auto
             ( long "upsample-factor"
            <> short 'u'
            <> value 10
            <> showDefault
            <> metavar "UPSAMPLE_FAC"
            <> help "Upsample factor, outSR = inSR * UPSAMPLE_FAC")
         <*> F.parseOpts

modulateAM' :: Int -> Float -> IQ
modulateAM' modIdx s = (base + amp) :+ 0.0
  where x = fromIntegral modIdx / 200
        amp = s * x
        base = 1 - x

modulateAM :: Monad m => Int -> Pipe Float IQ m ()
modulateAM x = P.map $ modulateAM' x

yieldEvery :: Monad m => Int -> Pipe a a m ()
yieldEvery n = do
  replicateM_ (n - 1) await
  await >>= yield
  yieldEvery n

run :: AMOptions -> IO ()
run opts = do
  (info, Just (aSamps :: SV.Buffer Float)) <- SF.readFile $ inputFile opts

  let sampsVec = SV.fromBuffer aSamps
      upsampleRate = upsample opts * SF.samplerate info
      filterKernel = F.lowPass upsampleRate $ filterOpts opts

  putStr "Processing samples... "
  hFlush stdout

  withBinaryFile (outputFile opts) WriteMode  $ \f ->
    runEffect $ V.mapM_ yield sampsVec
            >-> yieldEvery (SF.channels info)
            >-> modulateAM (modIndex opts)
            >-> zeroStuff (upsample opts)
            >-> F.convolve filterKernel
            >-> cfileSink f

  putStrLn "Done."

  putStrLn $  "CFile sample rate: " ++ show  upsampleRate ++ "Hz"

max_stars_repo_name: hexagonal-sun/ayeQ

max_issues_repo_name: hexagonal-sun/ayeQ

max_forks_repo_name: hexagonal-sun/ayeQ


text:
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
-- |
-- Module    : Statistics.Distribution.Laplace
-- Copyright : (c) 2015 Mihai Maruseac
-- License   : BSD3
--
-- Maintainer  : mihai.maruseac@maruseac.com
-- Stability   : experimental
-- Portability : portable
--
-- The Laplace distribution.  This is the continuous probability
-- defined as the difference of two iid exponential random variables
-- or a Brownian motion evaluated as exponentially distributed times.
-- It is used in differential privacy (Laplace Method), speech
-- recognition and least absolute deviations method (Laplace's first
-- law of errors, giving a robust regression method)
--
module Statistics.Distribution.Laplace
    (
      LaplaceDistribution
    -- * Constructors
    , laplace
    , laplaceE
    -- * Accessors
    , ldLocation
    , ldScale
    ) where

import Control.Applicative
import Data.Data            (Data, Typeable)
import GHC.Generics         (Generic)
import qualified Data.Vector.Generic             as G
import qualified Statistics.Distribution         as D
import qualified Statistics.Quantile             as Q
import qualified Statistics.Sample               as S
import Statistics.Internal

data LaplaceDistribution = LD {
      ldLocation :: {-# UNPACK #-} !Double
    -- ^ Location.
    , ldScale    :: {-# UNPACK #-} !Double
    -- ^ Scale.
    } deriving (Eq, Typeable, Data, Generic)

instance Show LaplaceDistribution where
  showsPrec i (LD l s) = defaultShow2 "laplace" l s i
instance Read LaplaceDistribution where
  readPrec = defaultReadPrecM2 "laplace" laplaceE

instance D.Distribution LaplaceDistribution where
    cumulative      = cumulative
    complCumulative = complCumulative

instance D.ContDistr LaplaceDistribution where
    density    (LD l s) x = exp (- abs (x - l) / s) / (2 * s)
    logDensity (LD l s) x = - abs (x - l) / s - log 2 - log s
    quantile      = quantile
    complQuantile = complQuantile

instance D.Mean LaplaceDistribution where
    mean (LD l _) = l

instance D.Variance LaplaceDistribution where
    variance (LD _ s) = 2 * s * s

instance D.MaybeMean LaplaceDistribution where
    maybeMean = Just . D.mean

instance D.MaybeVariance LaplaceDistribution where
    maybeStdDev   = Just . D.stdDev
    maybeVariance = Just . D.variance

instance D.Entropy LaplaceDistribution where
  entropy (LD _ s) = 1 + log (2 * s)

instance D.MaybeEntropy LaplaceDistribution where
  maybeEntropy = Just . D.entropy

instance D.ContGen LaplaceDistribution where
  genContVar = D.genContinuous

cumulative :: LaplaceDistribution -> Double -> Double
cumulative (LD l s) x
  | x <= l    = 0.5 * exp ( (x - l) / s)
  | otherwise = 1 - 0.5 * exp ( - (x - l) / s )

complCumulative :: LaplaceDistribution -> Double -> Double
complCumulative (LD l s) x
  | x <= l    = 1 - 0.5 * exp ( (x - l) / s)
  | otherwise = 0.5 * exp ( - (x - l) / s )

quantile :: LaplaceDistribution -> Double -> Double
quantile (LD l s) p
  | p == 0             = -inf
  | p == 1             = inf
  | p == 0.5           = l
  | p > 0   && p < 0.5 = l + s * log (2 * p)
  | p > 0.5 && p < 1   = l - s * log (2 - 2 * p)
  | otherwise          =
    error $ "Statistics.Distribution.Laplace.quantile: p must be in [0,1] range. Got: "++show p
  where
    inf = 1 / 0

complQuantile :: LaplaceDistribution -> Double -> Double
complQuantile (LD l s) p
  | p == 0             = inf
  | p == 1             = -inf
  | p == 0.5           = l
  | p > 0   && p < 0.5 = l - s * log (2 * p)
  | p > 0.5 && p < 1   = l + s * log (2 - 2 * p)
  | otherwise          =
    error $ "Statistics.Distribution.Laplace.quantile: p must be in [0,1] range. Got: "++show p
  where
    inf = 1 / 0

-- | Create an Laplace distribution.
laplace :: Double         -- ^ Location
        -> Double        -- ^ Scale
        -> LaplaceDistribution
laplace l s = maybe (error $ errMsg l s) id $ laplaceE l s

-- | Create an Laplace distribution.
laplaceE :: Double         -- ^ Location
         -> Double        -- ^ Scale
         -> Maybe LaplaceDistribution
laplaceE l s
  | s >= 0    = Just (LD l s)
  | otherwise = Nothing

errMsg :: Double -> Double -> String
errMsg _ s = "Statistics.Distribution.Laplace.laplace: scale parameter must be positive. Got " ++ show s

-- | Create Laplace distribution from sample. No tests are made to
--   check whether it truly is Laplace. Location of distribution
--   estimated as median of sample.
instance D.FromSample LaplaceDistribution Double where
  fromSample xs
    | G.null xs = Nothing
    | otherwise = Just $! LD s l
    where
      s = Q.median Q.medianUnbiased xs
      l = S.mean $ G.map (\x -> abs $ x - s) xs

max_stars_repo_name: vmchale/statistics

max_issues_repo_name: vmchale/statistics

max_forks_repo_name: vmchale/statistics


text:
-- test for trac #8532

import Data.Complex

main :: IO ()
main = do
    print $ acosh ((-1)::Complex Double)
    print $ acosh ((-1)::Complex Float)


text:
import Graphics.UI.SDL.General (withInit, InitFlag(InitVideo, InitEventthread))
import Graphics.UI.SDL.Types (Surface, surfaceGetPixels, surfaceGetPixelFormat, SurfaceFlag(SWSurface))
import Graphics.UI.SDL.Video (setVideoMode, mapRGB)
import qualified Graphics.UI.SDL.Video as V (flip)
import Graphics.UI.SDL.WindowManagement (setCaption)
import Graphics.UI.SDL.Events (Event(Quit, KeyDown), waitEvent)
import Graphics.UI.SDL.Keysym (Keysym(Keysym), SDLKey(SDLK_SPACE))
import Foreign.Ptr (castPtr)
import Data.Array (elems)
import Foreign.Marshal.Array (pokeArray)
import Control.Monad (liftM)

import Control.Applicative ((<*>))

import Data.Maybe (fromJust, isJust)
import Data.List (intersperse)

import Numeric.LinearAlgebra.Data ((|>))

import Raytracer.Geometry (cube)
import Raytracer.Camera (Camera(Camera), calculate_rays, fire_rays)

wres = 400
hres = 300
color_depth = 32

test_camera = Camera 4 3 wres hres (Just 1)
test_positions = map (3 |>) [[1, 1, -1], [2, 1, -1], [2, 2, -1], [2, 2, -2]]
test_directions = map (3 |>) [[0,0,1], [-1, 0, 1], [0,1,1], [0,-1,1]]

test_cube = cube (3 |> [2, 0, 0]) (3 |> [0, 2, 0]) (3 |> [0, 0, 2]) (3 |> [0, 0, 0])

transpose (a, b) (c, d) v = (((v-c) * (b-a)) / (d-c)) + a

compute_pixels surface array = mapM (pixel (minimum just_list, maximum just_list)) list
	where
	list = elems array
	just_list = map fromJust $ filter isJust list
	pixel_format = surfaceGetPixelFormat surface
	pixel range (Just n) = greyscale $ round $ transpose (200, 100) range n
	pixel _ Nothing = greyscale 0
	greyscale a = mapRGB pixel_format a a a

array_to_surface surface array = array_ptr >>= ((flip pokeArray) array)
	where
	array_ptr = liftM castPtr $ surfaceGetPixels surface

wait_to_quit _ = waitEvent >>= handle
	where
	handle Quit = return ()
	handle _ = wait_to_quit ()

wait_to_space _ = waitEvent >>= handle
	where
	handle (KeyDown (Keysym SDLK_SPACE _ _)) = return ()
	handle _ = wait_to_space ()

render _ = do
	screen <- setVideoMode wres hres color_depth [SWSurface]
	pixels <- mapM (compute_pixels screen) $ fmap ((flip fire_rays) test_cube) $ fmap calculate_rays $ fmap test_camera test_positions <*> test_directions
	putStrLn "Images Rendered"
	sequence $ intersperse (V.flip screen >>= wait_to_space) $ map (array_to_surface screen) pixels
	V.flip screen

main = withInit [InitVideo, InitEventthread] $ setCaption "SDL Test" "" >>= render >> putStrLn "Ready To Quit" >>= wait_to_quit


text:
module Parser
    (
      -- * Expression
      readExpr
    ) where

import Data.Array (listArray)
import Data.Char (digitToInt)
import Data.Complex (Complex(..))
import Data.Ratio ((%))
import Numeric (readFloat, readHex, readInt, readOct)

import Control.Monad.Except (throwError)
import Text.ParserCombinators.Parsec

import Type (LispError(..), LispVal(..), ThrowsError)

-- | Read an expression. Returns the parsed `LispVal`.
readExpr :: String -> ThrowsError LispVal
readExpr input =
    case parse parseExpr "lisp" input of
        Left err   -> throwError $ Parser err
        Right expr -> return expr

-- | Parses an expression. Returns the parsed `LispVal`.
parseExpr :: Parser LispVal
parseExpr = parseSymbol
    -- Expressions started with `#`
    <|> try parseNumber <|> try parseBoolean <|> try parseCharacter
    <|> parseVector
    -- Expressions started with `unquote` (,)
    <|> try parseUnquoteSplicing <|> parseUnquote
    <|> parseString <|> parseQuasiquote <|> parseQuoted <|> parseList

-- | Parses a boolean. Returns the parsed `Boolean`.
parseBoolean :: Parser LispVal
parseBoolean = do
    _ <- char '#'
    v <- char 't' <|> char 'f'

    return $
        case v of
            't' -> Boolean True
            _   -> Boolean False

-- | Parses an symbol. Returns the parsed `Symbol`.
parseSymbol :: Parser LispVal
parseSymbol = do
    first <- letter <|> extendedAlphabet
    rest  <- many $ letter <|> digit <|> extendedAlphabet
    return $ Symbol $ first:rest

-- | Parses a literal expression. Returns the parsed `List`.
parseQuoted :: Parser LispVal
parseQuoted = do
    _ <- char '\''
    x <- parseExpr
    return $ List [Symbol "quote", x]

-- | Parses a vector. Returns the parsed `Vector`.
parseVector :: Parser LispVal
parseVector = do
    _  <- string "#("
    xs <- sepBy parseExpr spaces1
    _  <- char ')'
    return $ Vector $ listArray (0, length xs - 1) xs

-- | Parses a quasiquote expression. Returns the parsed `List`.
parseQuasiquote :: Parser LispVal
parseQuasiquote = do
    _ <- char '`'
    x <- parseExpr
    return $ List [Symbol "quasiquote", x]

-- | Parses an unquote expression. Returns the parsed `List`.
parseUnquote :: Parser LispVal
parseUnquote = do
    _ <- char ','
    x <- parseExpr
    return $ List [Symbol "unquote", x]

-- | Parses an unquote-splicing expression. Returns the parsed `List`.
parseUnquoteSplicing :: Parser LispVal
parseUnquoteSplicing = do
    _ <- string ",@"
    x <- parseExpr
    return $ List [Symbol "unquote-splicing", x]

-- | Parses a list. Returns the parsed `List` or `DottedList`.
parseList :: Parser LispVal
parseList = do
    _  <- char '(' >> spaces
    xs <- parseExpr `sepEndBy` spaces1
    parseDottedListTail xs <|> parseListEnd xs

-- | Parses the end of a list. Returns the parsed `List`.
parseListEnd :: [LispVal] -> Parser LispVal
parseListEnd xs = do
    _  <- spaces >> char ')'
    return $ List xs

-- | Parses the tail of a dotted list. Returns the parsed `DottedList`.
parseDottedListTail :: [LispVal] -> Parser LispVal
parseDottedListTail xs = do
    _  <- char '.' >> spaces1
    t  <- parseExpr
    _  <- spaces >> char ')'
    return $ DottedList xs t

-- | Parses a numberical constant.
--
--   Returns the parsed `Integer`, `Rational`, `Real` or `Complex`.
parseNumber :: Parser LispVal
parseNumber =
    try parseReal <|> try parseRational <|> try parseComplex
    <|> try parseBin <|> try parseOct <|> try parseHex <|> parseDecimal

-- | Parses a floating point constant. Returns the parsed `Real`.
parseReal :: Parser LispVal
parseReal = do
    i <- many1 digit
    _ <- char '.'
    d <- many1 digit

    let n = concat [i, ".", d]
    return $
        case readFloat n of
            [(v, "")] -> Real v
            _         -> error $ "parseReal: no match for " ++ n

-- | Parses an rational number constant. Returns the parsed `Rational`.
--
--   For `a/b`, only integers are supported for `a` and `b` to ease
--   implementation.
parseRational :: Parser LispVal
parseRational = do
    n <- many1 digit
    _ <- char '/'
    d <- many1 digit
    return $ Rational $ read n % read d

-- | Parses an complex number constant. Returns the parsed `Complex`.
--
--   For `a+bi`, only integers are supported for `a` and `b` to ease
--   implementation.
parseComplex :: Parser LispVal
parseComplex = do
    n <- many1 digit
    _ <- char '+'
    d <- many1 digit
    _ <- char 'i'
    return $ Complex $ read n :+ read d

-- | Parses a decimal numberical constant. Returns the parsed `Integer`.
parseDecimal :: Parser LispVal
parseDecimal = do
    _ <- optional $ string "#d"
    Integer . read <$> many1 digit

-- | Parses an binary numberical constant. Returns the parsed `Integer`.
parseBin :: Parser LispVal
parseBin = do
    _ <- string "#b"
    n <- many1 $ oneOf "01"
    return $
        case readBin n of
            [(v, "")] -> Integer v
            _         -> error $ "parseBin: no match for " ++ n

-- | Parses an octal numberical constant. Returns the parsed `Integer`.
parseOct :: Parser LispVal
parseOct = do
    _ <- string "#o"
    n <- many1 octDigit
    return $
        case readOct n of
            [(v, "")] -> Integer v
            _         -> error $ "parseOct: no match for " ++ n

-- | Parses a hexadecimal numberics constant. Returns the parsed `Integer`.
parseHex :: Parser LispVal
parseHex = do
    _ <- string "#x"
    n <- many1 hexDigit
    return $
        case readHex n of
            [(v, "")] -> Integer v
            _         -> error $ "parseHex: no match for " ++ n

-- | Parses a character constant. Returns the parsed `Character`.
--
--   Only `#\space` is supported instead of `#\` to ease implementation.
parseCharacter :: Parser LispVal
parseCharacter = do
    _ <- string "#\\"
    s <- string "space" <|> string "newline" <|> count 1 (noneOf " ")
    return $
        case s of
            "space"   -> Character ' '
            "newline" -> Character '\n'
            [c]       -> Character c
            _         -> error $ "parseCharacter: no match for " ++ s

-- | Parses a string constant. Returns the parsed `String`.
parseString :: Parser LispVal
parseString = do
    _ <- char '"'
    x <- many $ noneOf "\\\"" <|> parseQuotedCharacter
    _ <- char '"'
    return $ String x

-- | Parses a quoted character (\\, \", \n, \r, \t).
--
--   Returns the parsed character.
parseQuotedCharacter :: Parser Char
parseQuotedCharacter = do
    _  <- char '\\'
    qc <- oneOf "\\\"nrt"
    return $
        case qc of
            'n' -> '\n'
            'r' -> '\r'
            't' -> '\t'
            _   -> qc

-- | Skips one or more white space characters.
spaces1 :: Parser ()
spaces1 = skipMany1 space

-- | Parses an extended alphabetic character (!$%&*+-/:<=>?@^_~).
--
--   Dot (.) was removed to ease implementation of dotted list.
--
--   Returns the parsed character.
extendedAlphabet :: Parser Char
extendedAlphabet = oneOf "!$%&*+-/:<=>?@^_~"

-- | Read an unsigned number in binary notation.
readBin :: (Eq a, Num a) => ReadS a
readBin = readInt 2 (`elem` "01") digitToInt

max_stars_repo_name: gavinkflam/backspin

max_issues_repo_name: gavinkflam/backspin

max_forks_repo_name: gavinkflam/backspin


text:
-- might not work if module is not installed, possible fix is to place the file in
-- hnn-master root folder

import AI.HNN.FF.ComplexNetwork
import Numeric.LinearAlgebra
import Data.Complex
import System.Random.MWC
import Foreign.Storable           (Storable)

-- actually ignoring imaginary part, adding constant +0i to all real numbers
samples :: Samples (Complex Double)
samples = [
  (fromList [ 1:+0, 1:+0, 1:+0, 1:+0, 1:+0
            , 0:+0, 0:+0, 0:+0, 0:+0, 1:+0
            , 0:+0, 0:+0, 1:+0, 1:+0, 1:+0
            , 0:+0, 0:+0, 0:+0, 0:+0, 1:+0
            , 1:+0, 1:+0, 1:+0, 1:+0, 1:+0 ], fromList [1:+0]),   -- three

  (fromList [ 1:+0, 1:+0, 1:+0, 1:+0, 1:+0
            , 0:+0, 0:+0, 0:+0, 0:+0, 1:+0
            , 1:+0, 1:+0, 1:+0, 1:+0, 1:+0
            , 0:+0, 0:+0, 0:+0, 0:+0, 1:+0
            , 1:+0, 1:+0, 1:+0, 1:+0, 1:+0 ], fromList [1:+0]),   -- three

  (fromList [ 0:+0, 1:+0, 1:+0, 1:+0, 1:+0
            , 0:+0, 0:+0, 0:+0, 0:+0, 1:+0
            , 0:+0, 0:+0, 0:+0, 1:+0, 1:+0
            , 0:+0, 0:+0, 0:+0, 0:+0, 1:+0
            , 0:+0, 1:+0, 1:+0, 1:+0, 1:+0 ], fromList [1:+0]),   -- three

  (fromList [ 1:+0, 1:+0, 1:+0, 1:+0, 1:+0
            , 1:+0, 0:+0, 0:+0, 0:+0, 1:+0
            , 1:+0, 0:+0, 0:+0, 0:+0, 1:+0
            , 1:+0, 0:+0, 0:+0, 0:+0, 1:+0
            , 1:+0, 1:+0, 1:+0, 1:+0, 1:+0 ], fromList [0:+0]),   -- not a three

  (fromList [ 1:+0, 1:+0, 1:+0, 1:+0, 1:+0
            , 1:+0, 0:+0, 0:+0, 0:+0, 0:+0
            , 1:+0, 0:+0, 0:+0, 0:+0, 0:+0
            , 1:+0, 0:+0, 0:+0, 0:+0, 0:+0
            , 1:+0, 0:+0, 0:+0, 0:+0, 0:+0 ], fromList [0:+0]),   -- not a three

  (fromList [ 0:+0, 1:+0, 1:+0, 1:+0, 0:+0
            , 0:+0, 1:+0, 0:+0, 1:+0, 0:+0
            , 0:+0, 1:+0, 1:+0, 1:+0, 0:+0
            , 0:+0, 1:+0, 0:+0, 1:+0, 0:+0
            , 0:+0, 1:+0, 1:+0, 1:+0, 0:+0 ], fromList [0:+0]),   -- not a three

  (fromList [ 0:+0, 0:+0, 1:+0, 0:+0, 0:+0
            , 0:+0, 1:+0, 1:+0, 0:+0, 0:+0
            , 1:+0, 0:+0, 1:+0, 0:+0, 0:+0
            , 0:+0, 0:+0, 1:+0, 0:+0, 0:+0
            , 0:+0, 0:+0, 1:+0, 0:+0, 0:+0 ], fromList [0:+0]) ]  -- not a three

main :: IO ()
main = do
  n <- createComplexNetwork 25 [250] 1
  let n' = trainNTimes 100 0.5 complexSigmoid complexSigmoid' n samples
  mapM_ (putStrLn . show . output n' complexSigmoid . fst) samples
  putStrLn "-------------"
  putStrLn . show . output n' complexSigmoid $ testInput

  where testInput = fromList [ 0:+0, 0:+0, 1:+0, 1:+0, 1:+0
                             , 0:+0, 0:+0, 0:+0, 0:+0, 1:+0
                             , 0:+0, 0:+0, 1:+0, 1:+0, 1:+0
                             , 0:+0, 0:+0, 0:+0, 0:+0, 1:+0
                             , 0:+0, 0:+0, 1:+0, 1:+0, 1:+0 ]

max_stars_repo_name: EditResearch/HsANN

max_issues_repo_name: EditResearch/HsANN

max_forks_repo_name: EditResearch/HsANN