text:
{-|
Module      : Flipper.Bufferable
Description : Serialization/Deserialization typeclass.
Copyright   : George Morgan, Travis Whitaker 2016
License     : All rights reserved.
Maintainer  : travis@flipper.io
Stability   : Provisional
Portability : Windows, POSIX

This module provides the 'Bufferable' typeclass, representing any data that may
be sent to or received from the device over an arbitrary bus. This is
accomplished by providing a 'Put' serializer and a 'Get' deserializer. While
serializers and deserializers may be written from scratch, often the Haskell
data type representing the data being exchanged is analogous to the
corresponding C struct. When this is the case, a 'Bufferable' instance may be
derived automatically with GHC generics. For example:

> -- Needs -XDeriveGeneric, -XDeriveAnyClass
>
> import GHC.Generics
>
> import qualified Data.ByteString as B
>
> import Flipper.Bufferable
>
> data SomeStruct = SomeStruct {
>     ssID      :: Int
>   , ssName    :: String
>   , ssPayload :: B.ByteString
>   } deriving (Generic, Bufferable)

The following conditions must be satisfied for a 'Bufferable' instance to be
automatically generated:

 - The data type must have exactly one constructor.
 - The data type's constructor's arguments' types must have 'Bufferable'
   instances.
 - The data type's constructor must not be recursive.

== Struct Packing

The machinery for deriving 'Bufferable' instances assumes that the analogous C
struct's fields are arranged in the same order as the Haskell data type
constructor's arguments. However, no assumptions are made about how the struct
is packed. If possible, use @\_\_attribute\_\_((\_\_packed\_\_))@ on the
corresponding struct, and use fundamental Haskell types from "Data.Int",
"Data.Word", and "Foreign.C.Types" whose widths are guaranteed.

Even if the use of a padded struct unavoidable, it is still not necessary to
write a serializer/deserializer pair by hand. The 'Padding' type may be used in
Haskell data types to indicate where padding is present in the corresponding C
struct and how wide it is. Suppose we're dealing with the following C struct on
a machine with 32-bit words (like Flipper):

> typedef struct _rec
> {
>         uint8_t   a;
>         uint16_t b;
>         uint8_t  c;
>         uint32_t d;
> } rec;

If this struct is not packed, it will look like this in memory:

> ┌───────────┬─────────────────┬────────────┬───────────┬──────────────────┬────────────┐
> │8 bits of a│8 bits of padding│16 bits of b│8 bits of c│24 bits of padding│32 bits of d│
> └───────────┴─────────────────┴────────────┴───────────┴──────────────────┴────────────┘

This struct may be represented with the following Haskell data type:

> -- Needs -XDeriveGeneric, -XDeriveAnyClass, -XDataKinds
>
> import Data.Word
>
> import GHC.Generics
>
> import Flipper.Bufferable
>
> data Rec = Rec {
>    a    :: Word8
>  , pad1 :: Padding 1
>  , b    :: Word16
>  , c    :: Word8
>  , pad2 :: Padding 3
>  , d    :: Word32
>  } deriving (Generic, Bufferable)

== C Arrays

In C there are two common strategies for delimiting arrays. The first involves
a distinguished sentinel element whose presence indicates the end of the array;
C strings are an example of this strategy. To accomodate such structures the
'SentinelSequence' data type and accompanying 'Sentinel' typeclass are provided.
A value of type @SentinelSequence a s@ will generate a 'Bufferable' instance
that reads consecutive values of type @a@ until the 'sentinel' value of type @s@
is encountered. Analogously the generated serializer will encode adjacent values
of type @a@, followed by the 'sentinel' value of type @s@. An example for C
strings:

> newtype CString = CString { unCString :: SentinelSequence Char Char }
>                 deriving (Generic, Bufferable)
>
> instance Sentinel Char where
>     sentinel = '\0'

This example is redundant; the 'Bufferable' instance for 'String' already
provides this exact behavior, and the 'CBlock' 'Bufferable' instance provides
this behavior for 'B.ByteStrings'.

Another technique is to lead the array with an unsigned integer providing the
number of elements in the array. Applied to character data, such a structure is
known as a Pascal string. The 'SizedSequence' data type provides 'Bufferable'
instances for such structures. A value of type @SizedSequence a l@ will first
read a quantity of type @l@, and then read @l@ following elements. Here @l@ is a
phantom type that merely encodes what sort of integer is present at the
beginning of the array. Analogously the generated serializer will encode the
length of the sequence as type @l@, then encode adjacent values of type @a@. An
example for 32-bit led Pascal strings:

> newtype PString = PString { unPascalString :: SizedSequence Char Word32 }
>                 deriving (Generic, Bufferable)

The related type 'SizedByteString' provides the same behavior for
'B.ByteStrings'.

-}

{-# LANGUAGE FlexibleInstances
           , TypeOperators
           , DataKinds
           , DefaultSignatures
           , KindSignatures
           , FlexibleContexts
           , LambdaCase
           , ScopedTypeVariables
           , DeriveFunctor
           , DeriveFoldable
           , DeriveGeneric
           , DeriveTraversable
           , GeneralizedNewtypeDeriving
           #-}

module Flipper.Bufferable (
    -- * The 'Bufferable' Class
    Bufferable(..)
    -- * Types for Generic 'Bufferable' Instances
  , Sentinel(..)
  , SentinelSequence(..)
  , SizedSequence(..)
  , CBlock(..)
  , SizedByteString(..)
  , Padding()
  ) where

import Control.Applicative
import Control.DeepSeq
import Control.Monad

import Data.Complex
import Data.Data
import Data.Int
import Data.Ix
import Data.Monoid
import Data.Ratio
import Data.Word

import qualified Data.ByteString as B
import qualified Data.Text       as T

import Flipper.Buffer
import Flipper.Get
import Flipper.Put

import Foreign.C.Types
import Foreign.Ptr
import Foreign.StablePtr
import Foreign.Storable

import GHC.Generics
import GHC.TypeLits

import System.Posix.Types

import Text.Read hiding (get)

-- | Generic class for 'Bufferable'.
class GBufferable g where
    gput :: g p -> Put
    gget :: Get (g p)

-- | Instance for uninhabited types.
instance GBufferable V1 where
    gput = undefined
    gget = undefined

-- | Instance for concretized types.
instance (Bufferable a) => GBufferable (K1 i a) where
    gput (K1 x) = put x
    gget        = K1 <$> get

-- | Instance for sum types.
instance (GBufferable f, GBufferable g) => GBufferable (f :*: g) where
    gput (f :*: g) = gput f <> gput g
    gget           = (:*:) <$> gget <*> gget

-- | Instance for metadata.
instance GBufferable a => GBufferable (M1 i t a) where
    gput (M1 x) = gput x
    gget        = M1 <$> gget

-- | Provides a 'Bufferable' instance whose deserializer sequentially decodes
--   values of type @a@ until the 'sentinel' value of type @s@ is encoded, where
--   'sentinel' is provided by the 'Sentinel' class. Analogously the generated
--   serializer will sequentially encode values of type @a@, followed by the
--   'sentinel' value of type @s@. @s@ is a phantom type, merely encoding the
--   type whose 'Sentinel' instance provides the 'sentinel' for values of this
--   type.
newtype SentinelSequence a s = SentinelSequence { unSentinelSequence :: [a] }
                             deriving ( Eq
                                      , Ord
                                      , Read
                                      , Show
                                      , Functor
                                      , Monoid
                                      , Foldable
                                      , Traversable
                                      )

-- | The class of types containing a single 'sentinel' value.
class Sentinel s where
    -- | The sentinel value.
    sentinel :: s

-- | Provides a 'Bufferable' instance whose deserializer first decodes an
--   integer of type @l@, then decodes @l@ values of type @a@. Analogously the
--   generated serializer will first encode the length of the sequence as type
--   @l@, then sequentially encode values of type @a@. @l@ is a phantom type,
--   merely encoding the width and interpretation of the integer leading the
--   array.
newtype SizedSequence a l = SizedSequence { unSizedSequence :: [a] }
                          deriving ( Eq
                                   , Ord
                                   , Read
                                   , Show
                                   , Functor
                                   , Monoid
                                   , Foldable
                                   , Traversable
                                   )

-- | Provides a 'Bufferable' instance for C strings, i.e. a contiguous block of
--   non-null bytes terminted by the null byte.
newtype CBlock = CBlock { unCBlock :: B.ByteString }
               deriving ( Eq
                        , Ord
                        , Read
                        , Show
                        , Generic
                        , NFData
                        , Monoid
                        )

-- | Provides a 'Bufferable' instance for arrays of bytes accompanied by a
--   leading integer of type @l@ indicating the number of bytes in the array.
newtype SizedByteString l = SizedByteString { unSizedByteString :: B.ByteString }
                          deriving ( Eq
                                   , Ord
                                   , Read
                                   , Show
                                   , Generic
                                   , NFData
                                   , Monoid
                                   )

-- | A type for encoding struct padding at the Haskell type level. Use of this
--   type requires a recent GHC supporting the @-XDataKinds@ language extension.
--   The type level natural @s@ is the number of bytes of padding provided by
--   the generated 'Bufferable' instance. Although this type is uninhabited
--   (i.e. 'undefined' or ⊥ is the only value of any 'Padding' type), degenerate
--   instances are provided for common typeclasses so that they may be derived
--   for data types containing padding.
data Padding (s :: Nat) deriving (Generic)

instance NFData (Padding s)

-- | '(==)' always returns 'True'.
instance Eq (Padding s) where
    _ == _ = True

-- | 'compare' always returns 'EQ'.
instance Ord (Padding s) where
    compare _ _ = EQ

-- | 'readPrec' consumes no input and returns 'undefined'.
instance Read (Padding s) where
    readPrec = pure undefined

-- | Outputs "Padding s" where s is a type level natural.
instance KnownNat s => Show (Padding s) where
    show p = "Padding " ++ show (padSize p)

-- | 'toEnum' returns 'undefined', 'fromEnum' returns 0.
instance Enum (Padding s) where
    toEnum _   = undefined
    fromEnum _ = 0

-- | 'minBound' = 'maxBound' = 0
instance Bounded (Padding s) where
    minBound = undefined
    maxBound = undefined

-- | 'range' = [], 'index' = 0, 'inRange' = True
instance Ix (Padding s) where
    range _     = []
    index _ _   = 0
    inRange _ _ = True

-- | Returns a 'Proxy' for the padding width.
padProxy :: Padding s -> Proxy s
padProxy _ = Proxy

-- | Provides the padding width at the term level.
padSize :: KnownNat s => Padding s -> Integer
padSize = natVal . padProxy

-- | The class of types for which 'Put' serializers and 'Get' deserializers are
--   available. Instances may be derived with GHC generics or written by hand
--   with the utilities in the "Flipper.Put" and "Flipper.Get" modules.
class Bufferable a where
    put :: a -> Put -- ^ Serializer.
    get :: Get a    -- ^ Deserializer.
    default put :: (Generic a, GBufferable (Rep a)) => a -> Put
    put = gput . from
    default get :: (Generic a, GBufferable (Rep a)) => Get a
    get = to <$> gget

instance ( Bufferable a
         , Bufferable s
         , Sentinel s
         ) => Bufferable (SentinelSequence a s) where
    put (SentinelSequence as) = mconcat (map put as) <> put (sentinel :: s)
    get = SentinelSequence <$> g
        where g = (Nothing <$ (get :: Get s)) <|> (Just <$> (get :: Get a))
                  >>= \case Nothing  -> return []
                            (Just v) -> (v:) <$> g

instance ( Bufferable a
         , Integral l
         , Num l
         , Bufferable l
         ) => Bufferable (SizedSequence a l) where
    put (SizedSequence as) = put (fromIntegral (length as) :: l)
                          <> mconcat (map put as)
    get = SizedSequence <$> ( (get :: Get l) >>= (\s ->
                              replicateM (fromIntegral s) (get :: Get a))
                            )

instance Bufferable CBlock where
    put = putBufferC . fromByteString . unCBlock
    get = (CBlock . B.pack) <$> getCBlock

instance ( Bufferable l
         , Integral l
         , Num l
         ) => Bufferable (SizedByteString l) where
    put (SizedByteString bs) = put (fromIntegral (B.length bs) :: l)
                            <> putBuffer (fromByteString bs)
    get = SizedByteString <$> ( (get :: Get l) >>=
                                (getSizedByteString . fromIntegral)
                              )

instance KnownNat p => Bufferable (Padding p) where
    put p = mconcat (replicate (fromIntegral (padSize p)) (putWord8 0))
    get = getSizedBlock (fromIntegral (padSize (undefined :: Padding p)))
       *> pure undefined

instance Bufferable Bool where
    put = putStorable
    get = getStorable

instance Bufferable Char where
    put = putStorable
    get = getStorable

instance Bufferable Double where
    put = putStorable
    get = getStorable

instance Bufferable Float where
    put = putStorable
    get = getStorable

instance Bufferable Int where
    put = putStorable
    get = getStorable

instance Bufferable Int8 where
    put = putStorable
    get = getStorable

instance Bufferable Int16 where
    put = putStorable
    get = getStorable

instance Bufferable Int32 where
    put = putStorable
    get = getStorable

instance Bufferable Int64 where
    put = putStorable
    get = getStorable

instance Bufferable Word where
    put = putStorable
    get = getStorable

instance Bufferable Word8 where
    put = putStorable
    get = getStorable

instance Bufferable Word16 where
    put = putStorable
    get = getStorable

instance Bufferable Word32 where
    put = putStorable
    get = getStorable

instance Bufferable Word64 where
    put = putStorable
    get = getStorable

instance Bufferable CUIntMax where
    put = putStorable
    get = getStorable

instance Bufferable CIntMax where
    put = putStorable
    get = getStorable

instance Bufferable CUIntPtr where
    put = putStorable
    get = getStorable

instance Bufferable CSUSeconds where
    put = putStorable
    get = getStorable

instance Bufferable CUSeconds where
    put = putStorable
    get = getStorable

instance Bufferable CTime where
    put = putStorable
    get = getStorable

instance Bufferable CClock where
    put = putStorable
    get = getStorable

instance Bufferable CSigAtomic where
    put = putStorable
    get = getStorable

instance Bufferable CWchar where
    put = putStorable
    get = getStorable

instance Bufferable CSize where
    put = putStorable
    get = getStorable

instance Bufferable CPtrdiff where
    put = putStorable
    get = getStorable

instance Bufferable CDouble where
    put = putStorable
    get = getStorable

instance Bufferable CFloat where
    put = putStorable
    get = getStorable

instance Bufferable CULLong where
    put = putStorable
    get = getStorable

instance Bufferable CULong where
    put = putStorable
    get = getStorable

instance Bufferable CLong where
    put = putStorable
    get = getStorable

instance Bufferable CUInt where
    put = putStorable
    get = getStorable

instance Bufferable CInt where
    put = putStorable
    get = getStorable

instance Bufferable CUShort where
    put = putStorable
    get = getStorable

instance Bufferable CShort where
    put = putStorable
    get = getStorable

instance Bufferable CUChar where
    put = putStorable
    get = getStorable

instance Bufferable CSChar where
    put = putStorable
    get = getStorable

instance Bufferable CChar where
    put = putStorable
    get = getStorable

instance Bufferable IntPtr where
    put = putStorable
    get = getStorable

instance Bufferable WordPtr where
    put = putStorable
    get = getStorable

instance Bufferable Fd where
    put = putStorable
    get = getStorable

instance Bufferable CRLim where
    put = putStorable
    get = getStorable

instance Bufferable CTcflag where
    put = putStorable
    get = getStorable

instance Bufferable CSpeed where
    put = putStorable
    get = getStorable

instance Bufferable CCc where
    put = putStorable
    get = getStorable

instance Bufferable CUid where
    put = putStorable
    get = getStorable

instance Bufferable CNlink where
    put = putStorable
    get = getStorable

instance Bufferable CGid where
    put = putStorable
    get = getStorable

instance Bufferable CSsize where
    put = putStorable
    get = getStorable

instance Bufferable CPid where
    put = putStorable
    get = getStorable

instance Bufferable COff where
    put = putStorable
    get = getStorable

instance Bufferable CMode where
    put = putStorable
    get = getStorable

instance Bufferable CIno where
    put = putStorable
    get = getStorable

instance Bufferable CDev where
    put = putStorable
    get = getStorable

instance (Storable a, Integral a) => Bufferable (Ratio a) where
    put = putStorable
    get = getStorable

instance Bufferable (StablePtr a) where
    put = putStorable
    get = getStorable

instance Bufferable (Ptr a) where
    put = putStorable
    get = getStorable

instance Bufferable (FunPtr a) where
    put = putStorable
    get = getStorable

instance Storable a => Bufferable (Complex a) where
    put = putStorable
    get = getStorable

-- | Assumes ASCII encoding and the presence of a null terminator.
instance Bufferable String where
    put = putString
    get = getString

-- | Assumes UTF8 encoding and the presence of a null terminator.
instance Bufferable T.Text where
    put = putText
    get = getText

-- | Assumes the initial 4 bytes are an unsigned 32-bit little-endian length.
--   Identical to 'SizedByteString Word32'.
instance Bufferable B.ByteString where
    put = putByteString
    get = getByteString

max_stars_repo_name: nicholastmosher/flipper

max_issues_repo_name: nicholastmosher/flipper

max_forks_repo_name: nicholastmosher/flipper


text:
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}

module CNVectorSpec where

import Data.Complex
import Data.Proxy

import Test.QuickCheck
import Test.QuickCheck.Poly

import CNVector
import Category
import Comonad
import Functor
import Unboxed
-- import Vec

type N = 10

prop_CNVector_Functor_id :: FnProp (CNVector N A)
prop_CNVector_Functor_id = checkFnEqual law_Functor_id

prop_CNVector_Functor_comp :: Fun B C -> Fun A B -> FnProp (CNVector N A)
prop_CNVector_Functor_comp f g = checkFnEqual (law_Functor_comp f g)

prop_CNVector_Semicomonad_comm ::
    Fun (CNVector N B) C -> Fun (CNVector N A) B -> FnProp (CNVector N A)
prop_CNVector_Semicomonad_comm f g = checkFnEqual (law_Semicomonad_comm f g)

prop_CNVector_Comonad_id :: FnProp (CNVector N A)
prop_CNVector_Comonad_id = checkFnEqual (law_Comonad_id (Proxy @(->)))

prop_CNVector_Comonad_apply :: Fun (CNVector N A) B -> FnProp (CNVector N A)
prop_CNVector_Comonad_apply f = checkFnEqual (law_Comonad_apply f)

prop_CNVector_Semicomonad1_comm ::
    Fun (CNVector N B) C -> Fun (CNVector N A) B -> FnProp (CNVector N A)
prop_CNVector_Semicomonad1_comm f g = checkFnEqual (law_Semicomonad1_comm f g)

prop_CNVector_Semicomonad1_comm' ::
    Fun (CNVector N B) C -> Fun (CNVector N A) B -> FnProp (CNVector N A)
prop_CNVector_Semicomonad1_comm' (Fn f) (Fn g) =
    checkFnEqual (law_Semicomonad1_comm' f g)

prop_CNVector_Comonad1_id :: FnProp (CNVector N A)
prop_CNVector_Comonad1_id = checkFnEqual (law_Comonad1_id (Proxy @(->)))

prop_CNVector_Comonad1_id' :: FnProp (CNVector N A)
prop_CNVector_Comonad1_id' = checkFnEqual law_Comonad1_id'

prop_CNVector_Comonad1_apply ::
    Fun (CNVector N A) B -> FnProp (CNVector N A)
prop_CNVector_Comonad1_apply f = checkFnEqual (law_Comonad1_apply f)

prop_CNVector_Comonad1_apply' ::
    Fun (CNVector N A) B -> FnProp (CNVector N A)
prop_CNVector_Comonad1_apply' (Fn f) = checkFnEqual (law_Comonad1_apply' f)

type UA = Int
type UB = Double
type UC = Complex Double

prop_CNUVector_Functor_id :: FnProp (CNUVector N UA)
prop_CNUVector_Functor_id = checkFnEqual law_Functor_id

prop_CNUVector_Functor_comp ::
    (UB -#> UC) -> (UA -#> UB) -> FnProp (CNUVector N UA)
prop_CNUVector_Functor_comp f g = checkFnEqual (law_Functor_comp f g)

-- prop_CNUVector_NatAdjunction_restrict ::
--     Proxy (CNUVector N) -> (UVec3 N) UA -> Property
-- prop_CNUVector_NatAdjunction_restrict = law_NatAdjunction_restrict

prop_CNUVector_Semicomonad1_comm' ::
    Fun (CNUVector N UB) UC -> Fun (CNUVector N UA) UB ->
    FnProp (CNUVector N UA)
prop_CNUVector_Semicomonad1_comm' (Fn f) (Fn g) =
    checkFnEqual (law_Semicomonad1_comm'
                     (f :: CNUVector N UB -> UC)
                     (g :: CNUVector N UA -> UB))

prop_CNUVector_Comonad1_id' :: FnProp (CNUVector N UA)
prop_CNUVector_Comonad1_id' = checkFnEqual law_Comonad1_id'

prop_CNUVector_Comonad1_apply' ::
    Fun (CNVector N UA) UB -> FnProp (CNVector N UA)
prop_CNUVector_Comonad1_apply' (Fn f) = checkFnEqual (law_Comonad1_apply' f)

ext: hs


text:
{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE LambdaCase                #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE StandaloneDeriving        #-}
{-# LANGUAGE TypeApplications          #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE TypeInType                #-}
{-# LANGUAGE TypeSynonymInstances      #-}
{-# LANGUAGE UndecidableInstances      #-}

module Learn.Neural.Layer.Recurrent.FullyConnected (
    FullyConnectedR
  , FullyConnectedR'
  , CommonMap(..)
  , MapFunc(..)
  ) where

import           Data.Kind
import           Data.Proxy
import           Data.Reflection
import           Data.Singletons.Prelude
import           GHC.Generics                   (Generic)
import           GHC.TypeLits
import           Learn.Neural.Layer
import           Learn.Neural.Layer.Mapping
import           Numeric.BLAS
import           Numeric.Backprop
import           Numeric.Backprop.Iso           (iso)
import           Numeric.Backprop.Op
import           Statistics.Distribution
import           Statistics.Distribution.Normal
import qualified Generics.SOP                   as SOP

data FullyConnectedR :: Type

deriving instance Generic (CParam FullyConnectedR b '[i] '[o])
instance SOP.Generic (CParam FullyConnectedR b '[i] '[o])

instance (Num (b '[o,o]), Num (b '[o,i]), Num (b '[o]))
      => Num (CParam FullyConnectedR b '[i] '[o]) where
    FCRP wI1 wS1 b1 + FCRP wI2 wS2 b2 = FCRP (wI1 + wI2) (wS1 + wS2) (b1 + b2)
    FCRP wI1 wS1 b1 - FCRP wI2 wS2 b2 = FCRP (wI1 - wI2) (wS1 - wS2) (b1 - b2)
    FCRP wI1 wS1 b1 * FCRP wI2 wS2 b2 = FCRP (wI1 * wI2) (wS1 * wS2) (b1 * b2)
    negate (FCRP wI wS b) = FCRP (negate wI) (negate wS) (negate b)
    signum (FCRP wI wS b) = FCRP (signum wI) (signum wS) (signum b)
    abs    (FCRP wI wS b) = FCRP (abs    wI) (abs    wS) (abs    b)
    fromInteger x = FCRP (fromInteger x) (fromInteger x) (fromInteger x)

instance (Fractional (b '[o,o]), Fractional (b '[o,i]), Fractional (b '[o]))
      => Fractional (CParam FullyConnectedR b '[i] '[o]) where
    FCRP wI1 wS1 b1 / FCRP wI2 wS2 b2 = FCRP (wI1 / wI2) (wS1 / wS2) (b1 / b2)
    recip (FCRP wI wS b) = FCRP (recip wI) (recip wS) (recip b)
    fromRational x       = FCRP (fromRational x) (fromRational x) (fromRational x)

instance (Floating (b '[o,o]), Floating (b '[o,i]), Floating (b '[o]))
      => Floating (CParam FullyConnectedR b '[i] '[o]) where
    sqrt (FCRP wI wS b) = FCRP (sqrt wI) (sqrt wS) (sqrt b)

instance Num (b '[o]) => Num (CState FullyConnectedR b '[i] '[o]) where
    FCRS s1 + FCRS s2 = FCRS (s1 + s2)
    FCRS s1 - FCRS s2 = FCRS (s1 - s2)
    FCRS s1 * FCRS s2 = FCRS (s1 * s2)
    negate (FCRS s) = FCRS (negate s)
    signum (FCRS s) = FCRS (signum s)
    abs    (FCRS s) = FCRS (abs    s)
    fromInteger x  = FCRS (fromInteger x)

instance Fractional (b '[o]) => Fractional (CState FullyConnectedR b '[i] '[o]) where
    FCRS s1 / FCRS s2 = FCRS (s1 / s2)
    recip (FCRS s)    = FCRS (recip s)
    fromRational x    = FCRS (fromRational x)

instance Floating (b '[o]) => Floating (CState FullyConnectedR b '[i] '[o]) where
    sqrt (FCRS s)    = FCRS (sqrt s)

instance ( BLAS b
         , KnownNat i
         , KnownNat o
         , Floating (b '[o])
         , Floating (b '[o,i])
         , Floating (b '[o,o])
         )
        => Component FullyConnectedR b '[i] '[o] where
    data CParam  FullyConnectedR b '[i] '[o] =
            FCRP { _fcrInpWeights   :: !(b '[o,i])
                 , _fcrStateWeights :: !(b '[o,o])
                 , _fcrBiases       :: !(b '[o])
                 }
    data CState  FullyConnectedR b '[i] '[o] = FCRS { _fcrState :: !(b '[o]) }
    type CConstr FullyConnectedR b '[i] '[o] = (Num (b '[o,i]), Num (b '[o,o]))
    data CConf   FullyConnectedR b '[i] '[o] = forall d. ContGen d => FCRC d

    componentOp = bpOp . withInps $ \(x :< p :< s :< Ø) -> do
        wI :< wS :< b :< Ø <- gTuple #<~ p
        s0 <- opIso (iso _fcrState FCRS) ~$ (s :< Ø)
        y  <- matVecOp ~$ (wI :< x  :< Ø)
        s1 <- matVecOp ~$ (wS :< s0 :< Ø)
        let z = y + s1 + b
        s' <- opIso (iso FCRS _fcrState) ~$ (s1 :< Ø)
        return $ z :< s' :< Ø

    defConf = FCRC (normalDistr 0 0.01)
    initParam = \case
      i `SCons` SNil -> \case
        so@(o `SCons` SNil) -> \(FCRC d) g -> do
          wI <- genA (o `SCons` (i `SCons` SNil)) $ \_ ->
            realToFrac <$> genContVar d g
          wS <- genA (o `SCons` (o `SCons` SNil)) $ \_ ->
            realToFrac <$> genContVar d g
          b <- genA so $ \_ ->
            realToFrac <$> genContVar d g
          return $ FCRP wI wS b
        _ -> error "inaccessible"
      _ -> error "inaccessible"
    initState _ so (FCRC d) g =
        FCRS <$> genA so (\_ -> realToFrac <$> genContVar d g)

instance ( BLAS b
         , KnownNat i
         , KnownNat o
         , Floating (b '[o])
         , Floating (b '[o,i])
         , Floating (b '[o,o])
         )
        => ComponentLayer 'Recurrent FullyConnectedR b '[i] '[o] where
    componentRunMode = RMNotFF

data FullyConnectedR' :: k -> Type

deriving instance Generic (CParam (FullyConnectedR' c) b '[i] '[o])
instance SOP.Generic (CParam (FullyConnectedR' c) b '[i] '[o])

instance (Num (b '[o,o]), Num (b '[o,i]), Num (b '[o]))
      => Num (CParam (FullyConnectedR' s) b '[i] '[o]) where
    FCRP' wI1 wS1 b1 + FCRP' wI2 wS2 b2 = FCRP' (wI1 + wI2) (wS1 + wS2) (b1 + b2)
    FCRP' wI1 wS1 b1 - FCRP' wI2 wS2 b2 = FCRP' (wI1 - wI2) (wS1 - wS2) (b1 - b2)
    FCRP' wI1 wS1 b1 * FCRP' wI2 wS2 b2 = FCRP' (wI1 * wI2) (wS1 * wS2) (b1 * b2)
    negate (FCRP' wI wS b) = FCRP' (negate wI) (negate wS) (negate b)
    signum (FCRP' wI wS b) = FCRP' (signum wI) (signum wS) (signum b)
    abs    (FCRP' wI wS b) = FCRP' (abs    wI) (abs    wS) (abs    b)
    fromInteger x = FCRP' (fromInteger x) (fromInteger x) (fromInteger x)

instance (Fractional (b '[o,o]), Fractional (b '[o,i]), Fractional (b '[o]))
      => Fractional (CParam (FullyConnectedR' s) b '[i] '[o]) where
    FCRP' wI1 wS1 b1 / FCRP' wI2 wS2 b2 = FCRP' (wI1 / wI2) (wS1 / wS2) (b1 / b2)
    recip (FCRP' wI wS b) = FCRP' (recip wI) (recip wS) (recip b)
    fromRational x        = FCRP' (fromRational x) (fromRational x) (fromRational x)

instance (Floating (b '[o,o]), Floating (b '[o,i]), Floating (b '[o]))
      => Floating (CParam (FullyConnectedR' s) b '[i] '[o]) where
    sqrt (FCRP' wI wS b) = FCRP' (sqrt wI) (sqrt wS) (sqrt b)

instance Num (b '[o]) => Num (CState (FullyConnectedR' s) b '[i] '[o]) where
    FCRS' s1 + FCRS' s2 = FCRS' (s1 + s2)
    FCRS' s1 - FCRS' s2 = FCRS' (s1 - s2)
    FCRS' s1 * FCRS' s2 = FCRS' (s1 * s2)
    negate (FCRS' s) = FCRS' (negate s)
    signum (FCRS' s) = FCRS' (signum s)
    abs    (FCRS' s) = FCRS' (abs    s)
    fromInteger x  = FCRS' (fromInteger x)

instance Fractional (b '[o]) => Fractional (CState (FullyConnectedR' s) b '[i] '[o]) where
    FCRS' s1 / FCRS' s2 = FCRS' (s1 / s2)
    recip (FCRS' s)     = FCRS' (recip s)
    fromRational x      = FCRS' (fromRational x)

instance Floating (b '[o]) => Floating (CState (FullyConnectedR' s) b '[i] '[o]) where
    sqrt (FCRS' s)     = FCRS' (sqrt s)

instance ( BLAS b
         , KnownNat i
         , KnownNat o
         , Floating (b '[o])
         , Floating (b '[o,i])
         , Floating (b '[o,o])
         , Reifies s MapFunc
         )
      => Component (FullyConnectedR' s) b '[i] '[o] where
    data CParam  (FullyConnectedR' c) b '[i] '[o] =
            FCRP' { _fcrInpWeights'   :: !(b '[o,i])
                  , _fcrStateWeights' :: !(b '[o,o])
                  , _fcrBiases'       :: !(b '[o])
                  }
    data CState  (FullyConnectedR' c) b '[i] '[o] = FCRS' { _fcrState' :: !(b '[o]) }
    type CConstr (FullyConnectedR' c) b '[i] '[o] =
      ( Num (b '[o,i])
      , Num (b '[o,o])
      )
    data CConf   (FullyConnectedR' c) b '[i] '[o] = forall d. ContGen d => FCRC' d

    componentOp = bpOp . withInps $ \(x :< p :< s :< Ø) -> do
        wI :< wS :< b :< Ø <- gTuple #<~ p
        s0 <- opIso (iso _fcrState' FCRS') ~$ (s :< Ø)
        y  <- matVecOp ~$ (wI :< x  :< Ø)
        s1 <- matVecOp ~$ (wS :< s0 :< Ø)
        s2 <- tmapOp (runMapFunc mf) ~$ (s1 :< Ø)
        let z = y + s2 + b
        s' <- opIso (iso FCRS' _fcrState') ~$ (s2 :< Ø)
        return $ z :< s' :< Ø
      where
        mf :: MapFunc
        mf = reflect (Proxy @s)

    defConf = FCRC' (normalDistr 0 0.01)

    initParam = \case
      i `SCons` SNil -> \case
        so@(o `SCons` SNil) -> \(FCRC' d) g -> do
          wI <- genA (o `SCons` (i `SCons` SNil)) $ \_ ->
            realToFrac <$> genContVar d g
          wS <- genA (o `SCons` (o `SCons` SNil)) $ \_ ->
            realToFrac <$> genContVar d g
          b <- genA so $ \_ ->
            realToFrac <$> genContVar d g
          return $ FCRP' wI wS b
        _ -> error "inaccessible"
      _ -> error "inaccessible"

    initState _ so (FCRC' d) g =
        FCRS' <$> genA so (\_ -> realToFrac <$> genContVar d g)

instance ( BLAS b
         , KnownNat i
         , KnownNat o
         , Floating (b '[o])
         , Floating (b '[o,i])
         , Floating (b '[o,o])
         , Reifies s MapFunc
         )
      => ComponentLayer 'Recurrent (FullyConnectedR' s) b '[i] '[o] where
    componentRunMode = RMNotFF

max_stars_repo_name: mstksg/backprop-learn

max_issues_repo_name: mstksg/backprop-learn

max_forks_repo_name: mstksg/backprop-learn


text:
{-# LANGUAGE OverloadedStrings #-}
module Lisp.ReadSpec (spec) where

import Data.Complex
import Data.Ratio
import Data.Text
import Test.Hspec
import Control.Exception (evaluate)

import Lisp

spec :: Spec

spec = do
  let foo = Symbol "foo"
  let bar = Symbol "bar"

  describe "parses symbols" $ do
    it "parses a '$' as a symbol" $
      readL "$" `shouldBe` Symbol "$"

    it "parses a 'f' as a symbol" $
      readL "f" `shouldBe` Symbol "f"

    it "fails to parse '@'" $
      evaluate (readL "@") `shouldThrow` anyErrorCall

    it "parses 'foo' as a symbol" $
      readL "foo" `shouldBe` foo

    it "parses 'f@' as a symbol" $
      readL "f@" `shouldBe` Symbol "f@"

    it "ignores leading spaces" $
      readL "  bar" `shouldBe` bar

    it "ignores trailing spaces" $
      readL "foo  " `shouldBe` foo

  describe "parses numbers" $ do
    it "parses '123' as a number" $
      readL "123" `shouldBe` Int 123

    it "parses '2.13' as a number" $
      readL "3.14" `shouldBe` Real 3.14

    it "parses '3/4' as a number" $
      readL "3/4" `shouldBe` Rational (3%4)

    it "Rationals have to have integer numerators" $
      evaluate (readL "3.1/4") `shouldThrow` anyErrorCall

    it "Rationals have to have integer denominators" $
      evaluate (readL "3/4.5") `shouldThrow` anyErrorCall

    it "parses '3.0+4.0i' as a complex number" $
      readL "3.0+4.0i" `shouldBe` Complex (3.0:+4.0)

  describe "parse strings" $ do
    let aString = "a string"
    let quote t = cons '"' (snoc (replace "\"" "\\\"" t) '"')

    it "parses \"a string\" as a string LispVal" $
      readL (quote aString) `shouldBe` String aString

  describe "parse booleans" $ do
    it "parses #t as a True LispVal" $
      readL "#t" `shouldBe` Bool True

    it "parses #f as a False LispVal" $
      readL "#f" `shouldBe` Bool False

    it "fails to parse #true" $
      evaluate (readL "#true") `shouldThrow` anyErrorCall

  describe "parse lists and pairs" $ do
    it "parses () as Nil" $
      readL "()" `shouldBe` Nil

    it "parses (foo . bar) as a dotted pair" $
      readL "(foo . bar)" `shouldBe` Pair foo bar

    it "dotted pairs have to be end of list" $
      evaluate (readL "(foo . bar baz)") `shouldThrow` anyErrorCall

    it "singleton lists get read as pair with cdr nil" $
      readL "(foo)" `shouldBe` Pair foo Nil

    it "longer lists get to be chains of pairs" $
      readL "(foo bar)" `shouldBe` Pair foo (Pair bar Nil)

    it "Longer lists can end in dotted pairs" $
      readL "(foo bar . foo)" `shouldBe` Pair foo (Pair bar foo)

    it "parses 'foo as (quote foo)" $
      readL "'foo" `shouldBe` Pair (Symbol "quote") (Pair foo Nil)

--    it "parses `foo as (quasiquote foo)" $
--      readL "`foo" `shouldBe` Pair (Symbol "quasiquote") (Pair foo Nil)

--    it "parses `(foo ,bar) as (quasiquote (foo (unquote bar)))" $
--      readL "`(foo ,bar)" `shouldBe` Pair (Symbol "quasiquote") (Pair foo (Pair (Symbol "unquote") (Pair bar Nil)))

max_stars_repo_name: blaisepascal/Haskell-LiSP

max_issues_repo_name: blaisepascal/Haskell-LiSP

max_forks_repo_name: blaisepascal/Haskell-LiSP


text:
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -fenable-rewrite-rules #-}
----------------------------------------------------------------------
-- |
-- Copyright   :  (c) Edward Kmett 2011-2014
-- License     :  BSD3
--
-- Maintainer  :  ekmett@gmail.com
-- Stability   :  experimental
--
-- Representable endofunctors over the category of Haskell types are
-- isomorphic to the reader monad and so inherit a very large number
-- of properties for free.
----------------------------------------------------------------------

module Data.Functor.Rep
  (
  -- * Representable Functors
    Representable(..)
  , tabulateAlg
  , tabulated
  -- * Logarithms
  , Logarithm(..)
  , contramapLogarithm
  , logarithmRep
  -- * Wrapped representable functors
  , Co(..)
  -- * Default definitions
  -- ** Functor
  , fmapRep
  -- ** Distributive
  , distributeRep
  , collectRep
  , cotraverseRep
  -- ** Apply/Applicative
  , apRep
  , pureRep
  , liftR2
  , liftR3
  -- ** Bind/Monad
  , bindRep
  -- ** MonadFix
  , mfixRep
  -- ** MonadZip
  , mzipRep
  , mzipWithRep
  -- ** MonadReader
  , askRep
  , localRep
  -- ** Extend
  , duplicatedRep
  , extendedRep
  -- ** Comonad
  , duplicateRep
  , extendRep
  , extractRep
  -- ** Comonad, with user-specified monoid
  , duplicateRepBy
  , extendRepBy
  , extractRepBy
  -- ** WithIndex
  , imapRep
  , ifoldMapRep
  , itraverseRep
  -- ** Representable
  , tabulateCotraverse1
  , indexLogarithm
  , cotraverse1Iso
  -- ** Generics
  , gcotraverse1
  , GRep
  , gindex
  , gtabulate
  , WrappedRep(..)
  ) where

import Control.Applicative
import Control.Applicative.Backwards
#if __GLASGOW_HASKELL__ >= 708
import Data.Coerce
#endif
import Control.Comonad
import Control.Comonad.Trans.Class
import Control.Comonad.Trans.Traced
import Control.Comonad.Cofree
import Control.Monad.Trans.Identity
import Control.Monad.Reader
#if MIN_VERSION_base(4,4,0)
import Data.Complex
#endif
import Data.Distributive
import Data.Foldable (Foldable(fold))
import Data.Functor.Bind
import Data.Functor.Identity
import Data.Functor.Compose
import Data.Functor.Extend
import Data.Functor.Product
import Data.Functor.Reverse
import Data.Functor1
import Data.Functor1.Applied
import qualified Data.Monoid as Monoid
import Data.Profunctor.Unsafe
import Data.Proxy
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Semigroup hiding (Product)
import Data.Tagged
import Data.Traversable (Traversable(sequenceA))
import Data.Void
import GHC.Generics hiding (Rep)
import Prelude

-- | A 'Functor' @f@ is 'Representable' if 'tabulate' and 'index' witness an
-- isomorphism to @(->) r@, for some @r@.
--
-- Alternatively, an instance can be derived from 'cotraverse1', by defining:
--
-- @
-- 'Rep' f = 'Logarithm' f
-- 'tabulate' = 'tabulateCotraverse1'
-- 'index' = 'indexLogarithm'
-- @
--
-- Instances without random access should implement 'cotraverse1', as it can
-- allow asymptotically faster zipping.
--
-- Every 'Distributive' 'Functor' is actually 'Representable'.
--
-- Every 'Representable' 'Functor' from Hask to Hask is a right adjoint.
--
-- @
-- 'tabulate' . 'index'  ≡ id
-- 'index' . 'tabulate'  ≡ id
-- 'tabulate' . 'return' ≡ 'return'
--
-- 'distribute1' . 'Applied' ≡ 'fmap' ('Applied' . 'Identity')
-- 'distribute1' ('Const' x) ≡ 'Const' x '<$' xs
--
-- 'cotraverse1' f ≡ 'fmap' f . 'distribute1'
-- 'collect1' f ≡ 'distribute1' . 'map1' f
-- 'cotraverseMap1' f g ≡ 'cotraverse1' f . 'map1' g
-- @

class Distributive f => Representable f where
  -- | If no definition is provided, this will default to 'GRep'.
  type Rep f :: *
  type Rep f = GRep f

  -- |
  -- @
  -- 'fmap' f . 'tabulate' ≡ 'tabulate' . 'fmap' f
  -- @
  --
  -- If no definition is provided, this will default to 'gtabulate'.
  tabulate :: (Rep f -> a) -> f a
  default tabulate :: (Generic1 f, GRep f ~ Rep f, GTabulate (Rep1 f))
                   => (Rep f -> a) -> f a
  tabulate = gtabulate

  -- | If no definition is provided, this will default to 'gindex'.
  index    :: f a -> Rep f -> a
  default index :: (Generic1 f, GRep f ~ Rep f, GIndex (Rep1 f))
                => f a -> Rep f -> a
  index = gindex

  -- | A more powerful version of 'cotraverse'
  --
  -- @'cotraverse1' f = 'fmap' f . 'distribute1'@
  cotraverse1 :: Functor1 w => (w Identity -> a) -> w f -> f a
  cotraverse1 f w = tabulateAlg (\g -> f $ map1Identity g w)

  -- | A more powerful version of 'distribute'
  --
  -- @
  -- 'distribute1' . 'Applied' ≡ 'fmap' ('Applied' . 'Identity')
  -- 'distribute1' ('Const' x) ≡ 'Const' x '<$' xs
  -- @
  distribute1 :: Functor1 w => w f -> f (w Identity)
  distribute1 = cotraverse1 id

  -- | A more powerful version of 'collect'
  --
  -- @'collect1' f ≡ 'distribute1' . 'map1' f@
  collect1 :: Functor1 w => (forall x. g x -> f x) -> w g -> f (w Identity)
  collect1 f = distribute1 . map1 f

  -- | @'cotraverseMap1' f g ≡ 'cotraverse1' f . 'map1' g@
  cotraverseMap1 ::
       Functor1 w => (w Identity -> a) -> (forall x. g x -> f x) -> w g -> f a
  cotraverseMap1 f g = cotraverse1 f . map1 g

tabulateAlg :: Representable f => ((forall x. f x -> x) -> a) -> f a
tabulateAlg f = tabulate $ \i -> f (`index` i)

-- | A default implementation of 'Rep' for a datatype that is an instance of
-- 'Generic1'. This is usually composed of 'Either', tuples, unit tuples, and
-- underlying 'Rep' values. For instance, if you have:
--
-- @
-- data Foo a = MkFoo a (Bar a) (Baz (Quux a)) deriving ('Functor', 'Generic1')
-- instance 'Representable' Foo
-- @
--
-- Then you'll get:
--
-- @
-- 'GRep' Foo = Either () (Either ('WrappedRep' Bar) ('WrappedRep' Baz, 'WrappedRep' Quux))
-- @
--
-- (See the Haddocks for 'WrappedRep' for an explanation of its purpose.)
type GRep f = GRep' (Rep1 f)

-- | A default implementation of 'tabulate' in terms of 'GRep'.
gtabulate :: (Generic1 f, GRep f ~ Rep f, GTabulate (Rep1 f))
          => (Rep f -> a) -> f a
gtabulate = to1 . gtabulate'

-- | A default implementation of 'index' in terms of 'GRep'.
gindex :: (Generic1 f, GRep f ~ Rep f, GIndex (Rep1 f))
       => f a -> Rep f -> a
gindex = gindex' . from1

type family GRep' (f :: * -> *) :: *
class GTabulate f where
  gtabulate' :: (GRep' f -> a) -> f a
class GIndex f where
  gindex' :: f a -> GRep' f -> a

type instance GRep' (f :*: g) = Either (GRep' f) (GRep' g)
instance (GTabulate f, GTabulate g) => GTabulate (f :*: g) where
  gtabulate' f = gtabulate' (f . Left) :*: gtabulate' (f . Right)
instance (GIndex f, GIndex g) => GIndex (f :*: g) where
  gindex' (a :*: _) (Left  i) = gindex' a i
  gindex' (_ :*: b) (Right j) = gindex' b j

type instance GRep' (f :.: g) = (WrappedRep f, GRep' g)
instance (Representable f, GTabulate g) => GTabulate (f :.: g) where
  gtabulate' f = Comp1 $ tabulate $ gtabulate' <$> fmap (curry f) WrapRep
instance (Representable f, GIndex g) => GIndex (f :.: g) where
  gindex' (Comp1 fg) (i, j) = gindex' (index fg (unwrapRep i)) j

type instance GRep' Par1 = ()
instance GTabulate Par1 where
  gtabulate' f = Par1 (f ())
instance GIndex Par1 where
  gindex' (Par1 a) () = a

type instance GRep' (Rec1 f) = WrappedRep f
#if __GLASGOW_HASKELL__ >= 708
-- Using coerce explicitly here seems a bit more readable, and
-- likely a drop easier on the simplifier.
instance Representable f => GTabulate (Rec1 f) where
  gtabulate' = coerce (tabulate :: (Rep f -> a) -> f a)
                 :: forall a . (WrappedRep f -> a) -> Rec1 f a
instance Representable f => GIndex (Rec1 f) where
  gindex' = coerce (index :: f a -> Rep f -> a)
                 :: forall a . Rec1 f a -> WrappedRep f -> a
#else
instance Representable f => GTabulate (Rec1 f) where
  gtabulate' = Rec1 #. tabulate .# (. WrapRep)
instance Representable f => GIndex (Rec1 f) where
  gindex' = (. unwrapRep) #. index .# unRec1
#endif

type instance GRep' (M1 i c f) = GRep' f
instance GTabulate f => GTabulate (M1 i c f) where
  gtabulate' = M1 #. gtabulate'
instance GIndex f => GIndex (M1 i c f) where
  gindex' = gindex' .# unM1

-- | On the surface, 'WrappedRec' is a simple wrapper around 'Rep'. But it plays
-- a very important role: it prevents generic 'Representable' instances for
-- recursive types from sending the typechecker into an infinite loop. Consider
-- the following datatype:
--
-- @
-- data Stream a = a :< Stream a deriving ('Functor', 'Generic1')
-- instance 'Representable' Stream
-- @
--
-- With 'WrappedRep', we have its 'Rep' being:
--
-- @
-- 'Rep' Stream = 'Either' () ('WrappedRep' Stream)
-- @
--
-- If 'WrappedRep' didn't exist, it would be:
--
-- @
-- 'Rep' Stream = Either () (Either () (Either () ...))
-- @
--
-- An infinite type! 'WrappedRep' breaks the potentially infinite loop.
newtype WrappedRep f = WrapRep { unwrapRep :: Rep f }

{-# RULES
"tabulate/index" forall t. tabulate (index t) = t #-}

-- | 'tabulate' and 'index' form two halves of an isomorphism.
--
-- This can be used with the combinators from the @lens@ package.
--
-- @'tabulated' :: 'Representable' f => 'Iso'' ('Rep' f -> a) (f a)@
tabulated :: (Representable f, Representable g, Profunctor p, Functor h)
          => p (f a) (h (g b)) -> p (Rep f -> a) (h (Rep g -> b))
tabulated = dimap tabulate (fmap index)
{-# INLINE tabulated #-}

-- * Logarithms

-- | Can be used as a value for 'Rep'
newtype Logarithm f = Logarithm { runLogarithm :: forall x. f x -> x }

contramapLogarithm :: (forall x. f x -> g x) -> Logarithm g -> Logarithm f
contramapLogarithm f (Logarithm g) = Logarithm (g . f)

-- | An index is equivalent to a function which gets the element at that index.
--
-- This can be used with the combinators from the @lens@ package.
--
-- @'logarithmRep' :: 'Representable' f => 'Iso' ('Logarithm' f) ('Rep' f)@
logarithmRep ::
  (Representable f, Representable g, Profunctor p, Functor h) =>
  p (Rep f) (h (Rep g)) -> p (Logarithm f) (h (Logarithm g))
logarithmRep =
  dimap (\(Logarithm f) -> f askRep) (fmap (\x -> Logarithm (`index` x)))

-- * Default definitions

fmapRep :: Representable f => (a -> b) -> f a -> f b
fmapRep f = cotraverse1 (f . runIdentity . runApplied) . Applied

pureRep :: Representable f => a -> f a
pureRep = tabulate . const

bindRep :: Representable f => f a -> (a -> f b) -> f b
bindRep m f = distribute f `apRep` m

mfixRep :: Representable f => (a -> f a) -> f a
mfixRep = cotraverseRep fix

data PairOf a b f = PairOf (f a) (f b)
instance Functor1 (PairOf a b) where
  map1 f (PairOf x y) = PairOf (f x) (f y)

mzipWithRep :: Representable f => (a -> b -> c) -> f a -> f b -> f c
mzipWithRep f as bs =
  cotraverse1 (\(PairOf (Identity a) (Identity b)) -> f a b) (PairOf as bs)

mzipRep :: Representable f => f a -> f b -> f (a, b)
mzipRep = mzipWithRep (,)

askRep :: Representable f => f (Rep f)
askRep = tabulate id

localRep :: Representable f => (Rep f -> Rep f) -> f a -> f a
localRep f m = tabulate (index m . f)

apRep :: Representable f => f (a -> b) -> f a -> f b
apRep = mzipWithRep ($)

distributeRep :: (Representable f, Functor w) => w (f a) -> f (w a)
distributeRep = cotraverseRep id

collectRep :: (Representable f, Functor w) => (a -> f b) -> w a -> f (w b)
collectRep f = distributeRep . fmap f

newtype Composed g a f = Composed { runComposed :: g (f a) }
instance Functor g => Functor1 (Composed g a) where
  map1 f = Composed . fmap f . runComposed

cotraverseRep :: (Representable f, Functor w) => (w a -> b) -> w (f a) -> f b
cotraverseRep f = cotraverse1 (f . fmap runIdentity . runComposed) . Composed

duplicateRepBy :: Representable f => (Rep f -> Rep f -> Rep f) -> f a -> f (f a)
duplicateRepBy plus w = tabulate (\m -> tabulate (index w . plus m))

extendRepBy :: Representable f => (Rep f -> Rep f -> Rep f) -> (f a -> b) -> f a -> f b
extendRepBy plus f w = tabulate (\m -> f (tabulate (index w . plus m)))

extractRepBy :: Representable f => Rep f -> f a -> a
extractRepBy = flip index

duplicatedRep :: (Representable f, Semigroup (Rep f)) => f a -> f (f a)
duplicatedRep = duplicateRepBy (<>)

extendedRep :: (Representable f, Semigroup (Rep f)) => (f a -> b) -> f a -> f b
extendedRep = extendRepBy (<>)

duplicateRep :: (Representable f, Monoid (Rep f)) => f a -> f (f a)
duplicateRep = duplicateRepBy mappend

extendRep :: (Representable f, Monoid (Rep f)) => (f a -> b) -> f a -> f b
extendRep = extendRepBy mappend

extractRep :: (Representable f, Monoid (Rep f)) => f a -> a
extractRep = extractRepBy mempty

imapRep :: Representable r => (Rep r -> a -> b) -> r a -> r b
imapRep f = mzipWithRep f askRep

ifoldMapRep :: forall r m a. (Representable r, Foldable r, Monoid m)
            => (Rep r -> a -> m) -> (r a -> m)
ifoldMapRep ix = fold . imapRep ix

itraverseRep :: forall r f a a'. (Representable r, Traversable r, Applicative f)
             => (Rep r -> a -> f a') -> (r a -> f (r a'))
itraverseRep ix = sequenceA . imapRep ix

newtype TabulateArg a f = TabulateArg (Logarithm f -> a)
instance Functor1 (TabulateArg a) where
  map1 f (TabulateArg g) = TabulateArg (g . contramapLogarithm f)

-- | Derive 'tabulate' given @'Rep' f ~ 'Logarithm' f@ and an
-- implementation of 'cotraverse1'
tabulateCotraverse1 :: Representable f => (Logarithm f -> a) -> f a
tabulateCotraverse1 =
  cotraverse1 (\(TabulateArg g) -> g (Logarithm runIdentity)) . TabulateArg

-- | Derive 'index', given @'Rep' f ~ 'Logarithm' f@
indexLogarithm :: f a -> Logarithm f -> a
indexLogarithm = flip runLogarithm

-- | Derive 'cotraverse1' via an isomorphism
cotraverse1Iso ::
     (Representable g, Functor1 w)
  => (forall x. f x -> g x)
  -> (forall x. g x -> f x)
  -> (w Identity -> a)
  -> w f
  -> f a
cotraverse1Iso t frm f = frm . cotraverseMap1 f t

gcotraverse1 ::
     (Representable (Rep1 f), Functor1 w, Generic1 f)
  => (w Identity -> a)
  -> w f
  -> f a
gcotraverse1 = cotraverse1Iso from1 to1

-- * Instances

instance Representable Proxy where
  type Rep Proxy = Void
  index Proxy = absurd
  tabulate _ = Proxy

instance Representable Identity where
  type Rep Identity = ()
  index (Identity a) () = a
  tabulate f = Identity (f ())

instance Representable (Tagged t) where
  type Rep (Tagged t) = ()
  index (Tagged a) () = a
  tabulate f = Tagged (f ())

instance Representable m => Representable (IdentityT m) where
  type Rep (IdentityT m) = Rep m
  index = index .# runIdentityT
  tabulate = IdentityT #. tabulate
  cotraverse1 = cotraverse1Iso runIdentityT IdentityT

instance Representable ((->) e) where
  type Rep ((->) e) = e
  index = id
  tabulate = id

instance Representable m => Representable (ReaderT e m) where
  type Rep (ReaderT e m) = (e, Rep m)
  index (ReaderT f) (e,k) = index (f e) k
  tabulate = ReaderT . fmap tabulate . curry
  cotraverse1 = cotraverse1Iso (Comp1 . runReaderT) (ReaderT . unComp1)

instance (Representable f, Representable g) => Representable (Compose f g) where
  type Rep (Compose f g) = (Rep f, Rep g)
  index (Compose fg) (i,j) = index (index fg i) j
  tabulate = Compose . tabulate . fmap tabulate . curry
  cotraverse1 = cotraverse1Iso (Comp1 . getCompose) (Compose . unComp1)

instance Representable w => Representable (TracedT s w) where
  type Rep (TracedT s w) = (s, Rep w)
  index (TracedT w) (e,k) = index w k e
  tabulate = TracedT . unCo . collect (Co #. tabulate) . curry
  cotraverse1 = cotraverse1Iso (Comp1 . runTracedT) (TracedT . unComp1)

instance (Representable f, Representable g) => Representable (Product f g) where
  type Rep (Product f g) = Either (Rep f) (Rep g)
  index (Pair a _) (Left i)  = index a i
  index (Pair _ b) (Right j) = index b j
  tabulate f = Pair (tabulate (f . Left)) (tabulate (f . Right))
  cotraverse1 = cotraverse1Iso (\(Pair x y) -> x :*: y) (\(x :*: y) -> Pair x y)

instance Representable f => Representable (Cofree f) where
  type Rep (Cofree f) = Seq (Rep f)
  index (a :< as) key = case Seq.viewl key of
      Seq.EmptyL -> a
      k Seq.:< ks -> index (index as k) ks
  tabulate f = f Seq.empty :< tabulate (\k -> tabulate (f . (k Seq.<|)))

  -- this could be derived via isomorphism to
  -- Identity :*: (f :.: Cofree f), but then the instance would be
  -- recursive which would prevent specialization
  cotraverse1 f = go
    where
      go w =
        f (map1Identity extract w) :<
        cotraverse1
          (go . map1 (runIdentity . unComp1) . runAppCompose)
          (AppCompose $ map1 (Comp1 . unwrap) w)

instance Representable f => Representable (Backwards f) where
  type Rep (Backwards f) = Rep f
  index = index .# forwards
  tabulate = Backwards #. tabulate
  cotraverse1 = cotraverse1Iso forwards Backwards

instance Representable f => Representable (Reverse f) where
  type Rep (Reverse f) = Rep f
  index = index .# getReverse
  tabulate = Reverse #. tabulate
  cotraverse1 = cotraverse1Iso getReverse Reverse

instance Representable Monoid.Dual where
  type Rep Monoid.Dual = ()
  index (Monoid.Dual d) () = d
  tabulate f = Monoid.Dual (f ())

instance Representable Monoid.Product where
  type Rep Monoid.Product = ()
  index (Monoid.Product p) () = p
  tabulate f = Monoid.Product (f ())

instance Representable Monoid.Sum where
  type Rep Monoid.Sum = ()
  index (Monoid.Sum s) () = s
  tabulate f = Monoid.Sum (f ())

#if MIN_VERSION_base(4,4,0)
instance Representable Complex where
  type Rep Complex = Bool
  index (r :+ i) key = if key then i else r
  tabulate f = f False :+ f True
#endif

instance Representable U1 where
  type Rep U1 = Void
  index U1 = absurd
  tabulate _ = U1

instance (Representable f, Representable g) => Representable (f :*: g) where
  type Rep (f :*: g) = Either (Rep f) (Rep g)
  index (a :*: _) (Left  i) = index a i
  index (_ :*: b) (Right j) = index b j
  tabulate f = tabulate (f . Left) :*: tabulate (f . Right)
  cotraverse1 f w =
    cotraverseMap1 f (\(a :*: _) -> a) w :*: cotraverseMap1 f (\(_ :*: b) -> b) w

newtype AppCompose w g f = AppCompose { runAppCompose :: w (f :.: g) }
instance Functor1 w => Functor1 (AppCompose w g) where
  map1 f = AppCompose . map1 (Comp1 . f . unComp1) . runAppCompose

instance (Representable f, Representable g) => Representable (f :.: g) where
  type Rep (f :.: g) = (Rep f, Rep g)
  index (Comp1 fg) (i, j) = index (index fg i) j
  tabulate = Comp1 . tabulate . fmap tabulate . curry
  cotraverse1 f w =
    Comp1 $
    cotraverse1 (cotraverseMap1 f (runIdentity . unComp1) . runAppCompose) $
    AppCompose w

instance Representable Par1 where
  type Rep Par1 = ()
  index (Par1 a) () = a
  tabulate f = Par1 (f ())

instance Representable f => Representable (Rec1 f) where
  type Rep (Rec1 f) = Rep f
  index = index .# unRec1
  tabulate = Rec1 #. tabulate
  cotraverse1 = cotraverse1Iso unRec1 Rec1

instance Representable f => Representable (M1 i c f) where
  type Rep (M1 i c f) = Rep f
  index = index .# unM1
  tabulate = M1 #. tabulate
  cotraverse1 = cotraverse1Iso unM1 M1

newtype Co f a = Co { unCo :: f a } deriving Functor

instance Representable f => Representable (Co f) where
  type Rep (Co f) = Rep f
  tabulate = Co #. tabulate
  index = index .# unCo
  cotraverse1 = cotraverse1Iso unCo Co

instance Representable f => Apply (Co f) where
  (<.>) = apRep

instance Representable f => Applicative (Co f) where
  pure = pureRep
  (<*>) = apRep

instance Representable f => Distributive (Co f) where
  distribute = distributeRep
  collect = collectRep

instance Representable f => Bind (Co f) where
  (>>-) = bindRep

instance Representable f => Monad (Co f) where
  return = pure
  (>>=) = bindRep

#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704
instance (Representable f, Rep f ~ a) => MonadReader a (Co f) where
  ask = askRep
  local = localRep
#endif

instance (Representable f, Semigroup (Rep f)) => Extend (Co f) where
  extended = extendedRep

instance (Representable f, Monoid (Rep f)) => Comonad (Co f) where
  extend = extendRep
  extract = extractRep

instance ComonadTrans Co where
  lower (Co f) = f

liftR2 :: Representable f => (a -> b -> c) -> f a -> f b -> f c
liftR2 = mzipWithRep

data TripleOf a b c f = TripleOf (f a) (f b) (f c)
instance Functor1 (TripleOf a b c) where
  map1 f (TripleOf a b c) = TripleOf (f a) (f b) (f c)

liftR3 :: Representable f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftR3 f fa fb fc =
  cotraverse1
    (\(TripleOf (Identity a) (Identity b) (Identity c)) -> f a b c)
    (TripleOf fa fb fc)

max_stars_repo_name: hololeap/adjunctions

max_issues_repo_name: hololeap/adjunctions

max_forks_repo_name: hololeap/adjunctions


text:
module FFT.Samples where

import System.Random
import FFT.Normal
import Data.Complex

generate2DSamplesList ::
                     Int           -- random number seed
                  -> Int           -- number of samples to generate
                  -> Float -> Float    -- X and Y mean
                  -> Float -> Float    -- X and Y standard deviations
                  -> [Complex Float]
generate2DSamplesList seed n mx my sdx sdy  = do
  let gen = mkStdGen seed in
    let (genx, geny) = split gen
        xsamples = normals' (mx,sdx) genx
        ysamples = normals' (my,sdy) geny
    in
      zipWith (:+) (take n xsamples) ysamples

-- generating input for FFT or DFT.
mX, mY, sdX, sdY :: Float
mX = 0
mY = 0
sdX = 0.5
sdY = 1.5

-- Produce a number of samples
samples seed n = generate2DSamplesList seed n mX mY sdX sdY

samplesi seed max n =
    let g = mkStdGen seed in
        take n (map (floor . (*) max) (normals g :: [Double]))

max_stars_repo_name: BNJHope/parallel-fourier-transforms

max_issues_repo_name: BNJHope/parallel-fourier-transforms

max_forks_repo_name: BNJHope/parallel-fourier-transforms


text:
{-# LANGUAGE GADTs, FlexibleContexts, RankNTypes #-}

module Numeric.Trainee.Neural (
	Net, net, netSeed,
	(⭃),
	ndup, npar, ndupWith, nsum, nfold,
	pad, pad2,
	maxPool, maxPool2,
	fc, conv, conv2,
	dconv, dconv2,

	sigma, relu, softplus,
	summator, biaser, activator, convolver, convolver2,
	normVar,

	module Numeric.Trainee.Types,
	module Numeric.Trainee.Learnee
	) where

import Prelude hiding ((.), id)
import Prelude.Unicode

import Control.Monad (replicateM, liftM2)
import Data.Random
import qualified Data.Vector as V
import Numeric.LinearAlgebra hiding (conv, conv2)
import System.Random (newStdGen, StdGen)

import Numeric.Trainee.Types
import Numeric.Trainee.Gradee
import Numeric.Trainee.Learnee

type Net a = Learnee (Vector a) (Vector a)

net ∷ RVar a → IO a
net n = netSeed <$> newStdGen <*> pure n

netSeed ∷ StdGen → RVar a → a
netSeed g n = fst $ sampleState n g

(⭃) ∷ RVar (Learnee a b) → RVar (Learnee b c) → RVar (Learnee a c)
n ⭃ l = liftM2 (⇉) n l

-- | Split layers, just wraps @vdup@
ndup ∷ Num a ⇒ Int → RVar (Learnee a (V.Vector a))
ndup = return ∘ computee ∘ vdup

-- | Process vector of layers
npar ∷ Int → RVar (Learnee a b) → RVar (Learnee (V.Vector a) (V.Vector b))
npar n = fmap (parallel ∘ V.fromList) ∘ replicateM n

-- | Split layers, justs wraps @vdupWith@
ndupWith ∷ (a → a → a) → Int → RVar (Learnee a (V.Vector a))
ndupWith fn = return ∘ computee ∘ vdupWith fn

-- | Join layers with sum
nsum ∷ Num a ⇒ RVar (Learnee (V.Vector a) a)
nsum = return (computee vsum)

-- | Join layers with custom sum
nfold ∷ (a → a → a) → RVar (Learnee (V.Vector a) a)
nfold = return ∘ computee ∘ vfold

-- | Padding
pad ∷ Numeric a ⇒ Int → RVar (Learnee (Vector a) (Vector a))
pad = return ∘ computee ∘ padVec

-- | 2d padding
pad2 ∷ Numeric a ⇒ Int → Int → RVar (Learnee (Matrix a) (Matrix a))
pad2 w h = return ∘ computee $ padMat w h

-- | Max pool layer
maxPool ∷ (RealFrac a, Numeric a) ⇒ Int → RVar (Learnee (Vector a) (Vector a))
maxPool = return ∘ computee ∘ maxPoolVec

-- | 2d max pool layer
maxPool2 ∷ (RealFrac a, Numeric a) ⇒ Int → Int → RVar (Learnee (Matrix a) (Matrix a))
maxPool2 w h = return ∘ computee $ maxPoolMat w h

-- | Fully connected layer
fc ∷ (Distribution Normal a, Numeric a, Parametric (Vector a), Parametric a) ⇒ Unary (Vector a) → Int → Int → RVar (Net a)
fc f inputs outputs = do
	s ← summator inputs outputs
	b ← biaser outputs
	return $ s ⇉ b ⇉ activator f

-- | Convolution layer 1-d
conv ∷ (Distribution Normal a, Numeric a, Parametric (Vector a), Parametric a) ⇒ Unary (Vector a) → Int → RVar (Net a)
conv f w = do
	c ← convolver w
	b ← do
		bs ← normVar
		return $ learnee biasVec bs
	return $ c ⇉ b ⇉ activator f

-- | Convolution layer 2-d
conv2 ∷ (Distribution Normal a, Numeric a, Parametric (Vector a), Parametric a) ⇒ Unary (Matrix a) → (Int, Int) → RVar (Learnee (Matrix a) (Matrix a))
conv2 f (w, h) = do
	c ← convolver2 w h
	b ← do
		bs ← normVar
		return $ learnee biasMat bs
	return $ c ⇉ b ⇉ activator f

-- | Depth (with several input and output channels) convolution 1-d
dconv ∷ (Distribution Normal a, Numeric a, Parametric (Vector a), Parametric a) ⇒ Unary (Vector a) → Int → Int → Int → RVar (Learnee (V.Vector (Vector a)) (V.Vector (Vector a)))
dconv f inputs outputs width =
	ndupWith (V.zipWith (+)) outputs ⭃
	npar outputs (npar inputs (conv f width) ⭃ nsum)

-- | Depth (with several input and output channels) convolution 2-d
dconv2 ∷ (Distribution Normal a, Numeric a, Parametric (Vector a), Parametric a) ⇒ Unary (Matrix a) → Int → Int → (Int, Int) → RVar (Learnee (V.Vector (Matrix a)) (V.Vector (Matrix a)))
dconv2 f inputs outputs (w, h) =
	ndupWith (V.zipWith (+)) outputs ⭃
	npar outputs (npar inputs (conv2 f (w, h)) ⭃ nsum)

sigma ∷ Floating a ⇒ a → a
sigma t = 1 / (1 + exp (negate t))

relu ∷ Fractional a ⇒ a → a
relu t = 0.5 * (1 + signum t) * t

softplus ∷ Floating a ⇒ a → a
softplus t = log (1 + exp t)

summator ∷ (Distribution Normal a, Fractional a, Numeric a, Parametric (Vector a), Parametric a) ⇒ Int → Int → RVar (Net a)
summator inputs outputs = do
	ws ← replicateM (inputs * outputs) normVar
	return $ learnee matVec ((outputs >< inputs) ws)

biaser ∷ (Distribution Normal a, Numeric a, Parametric (Vector a), Parametric a) ⇒ Int → RVar (Net a)
biaser sz = do
	bs ← replicateM sz normVar
	return $ learnee odot (fromList bs)

activator ∷ Num a ⇒ Unary a → Learnee a a
activator f = computee (unary f)

convolver ∷ (Distribution Normal a, Numeric a, Parametric (Vector a), Parametric a) ⇒ Int → RVar (Net a)
convolver w = do
	ws ← replicateM w normVar
	return $ learnee corrVec (fromList ws)

convolver2 ∷ (Distribution Normal a, Fractional a, Numeric a, Parametric (Vector a), Parametric a) ⇒ Int → Int → RVar (Learnee (Matrix a) (Matrix a))
convolver2 w h = do
	ws ← replicateM (w * h) normVar
	return $ learnee corrMat ((w >< h) ws)

normVar ∷ (Distribution Normal a, Fractional a) ⇒ RVar a
normVar = normal 0.0 0.25

max_stars_repo_name: mvoidex/trainee

max_issues_repo_name: mvoidex/trainee

max_forks_repo_name: mvoidex/trainee