text:
{-# LANGUAGE FunctionalDependencies, TypeFamilies, ViewPatterns #-}

module Caret where

import qualified Data.Vector.Storable as VS
import Data.Vector.Storable (Vector)

import Numeric.LinearAlgebra
import Caret.BFGS
import Numeric.GSL.Minimization
import Data.List (partition)
import Debug.Trace

type family Approx a

type instance Approx Bool = Double
type instance Approx Double = Double

data Caret a b = Caret
  { train :: [(Vector Double, b)] -> a
  , predict :: a -> Vector Double -> Approx b
  }

ols :: Caret (Vector Double) Double
ols = Caret t p where
  t the_data = let x = fromRows $ map fst the_data
                   y = col $ map snd the_data
               in head $ toColumns $ inv (tr' x <> x) <> tr' x <> y
  p betas x = betas `dot` x

ridge :: Double -> Caret (Vector Double) Double
ridge alpha = Caret t p where
  t the_data = let x = fromRows $ map fst the_data
                   y = col $ map snd the_data
                   npars = VS.length $ fst $ head the_data
                   gamma = scale alpha $ ident npars
               in head $ toColumns $ inv (tr' x <> x + tr' gamma <> gamma) <> tr' x <> y
  p betas x = betas `dot` x

--http://www.stat.cmu.edu/~cshalizi/350/lectures/26/lecture-26.pdf
logistic :: Caret (Vector Double) Bool
logistic = Caret t p where
  t the_data =  doMinNM the_data
  p beta x = 1/(1+exp (negate $ beta `dot` x))
  doMinNM the_data =
     fst $ minimizeV NMSimplex 1e-2 200 (getBox the_data) (logLike the_data) (getInit the_data)
  logLike1 beta (x, y) = let dp = beta `dot` x
                             pval = p beta x
                         in ind y * log pval + (1-ind y) * log 1 - pval
                            --log 1 + exp dp + ind y * dp
  logLike the_data beta =  negate $ sum $ map (logLike1 beta) the_data
  getInit the_data = VS.map (const 0.1) $ fst $ head the_data
  getBox the_data = VS.map (const 0.2) $ fst $ head the_data

prepare :: [a->Double] -> (a -> b) -> a -> (Vector Double, b)
prepare preds out x = (predictors preds x , out x)

predictors :: [a->Double] -> a -> Vector Double
predictors preds x = VS.fromList $ map ($x) preds

polyExpand :: Int -> (Double, Double) -> (Vector Double, Double)
polyExpand ncoeffs (x,y) = (VS.fromList lst,y) where
  lst = map f [0..ncoeffs-1]
  f pw = x^pw

ind :: Bool -> Double
ind True = 1
ind False = 0

crossValidate :: (Approx b -> b -> Double) -> Int -> Caret a b -> [(Vector Double, b)] -> Double
crossValidate distMetric leaveNth caret theData  = totalDistance where
  (map fst -> testSet,
   map fst -> trainSet)
      = partition ((==0) . (`mod` leaveNth) . snd) $ zip theData [0..]
  fit = train caret trainSet
  dists = flip map testSet $ \(xs, ytrue) ->
    let yhat = predict caret fit xs
    in distMetric yhat ytrue
  totalDistance = sum dists

crossValidateRegression :: Int -> Caret a Double -> [(Vector Double, Double)] -> Double
crossValidateRegression = crossValidate sumSqr where
  sumSqr x y = let d = x-y in d*d

max_stars_repo_name: BeautifulDestinations/caret

max_issues_repo_name: BeautifulDestinations/caret

max_forks_repo_name: BeautifulDestinations/caret


text:
module AI.DemoNeuron
       ( Neuron(..)
       , L2Neuron(..)
       , ReducedNeuron(..)

       , NeuronWeights
       , Values
       , ActivationFunction
       , ActivationFunction'

       , sigmoidNeuron
       , tanhNeuron
       , recluNeuron

       , sigmoid, sigmoid'
       , tanh, tanh'
       , reclu, reclu'
       , l1Norm, l2Norm
       ) where

import Numeric.LinearAlgebra
import Numeric.LinearAlgebra.Data

type ActivationFunction = Double -> Double
type ActivationFunction' = Double -> Double

data L2Neuron = L2Neuron deriving (Show)
data ReducedNeuron = ReducedNeuron { activation :: ActivationFunction
                                   , activation' :: ActivationFunction'
                                   , description :: String
                                   }

type NeuronWeights = Vector Double
type Values = Vector Double
type Activation = Double

-- | A Neuron type has two functions -- evaluate and evaluate',
--   both of which are functions from NeuronWeights to input values
--   to doubles.
class (Show a) => Neuron a where
  evaluate :: a -> NeuronWeights -> Values -> Activation
  evaluate' :: a -> NeuronWeights -> Values -> Activation

instance Show ReducedNeuron where
  show = description

instance Neuron ReducedNeuron where
    evaluate n weights values = f $ dot weights values
        where f = activation n

    evaluate' n weights values = f' $ dot weights values
        where f' = activation' n

instance Neuron L2Neuron where
  evaluate  n = l2Norm
  evaluate' n = l1Norm

-- | Our provided neuron types: sigmoid, tanh, reclu
sigmoidNeuron :: ReducedNeuron
sigmoidNeuron = ReducedNeuron sigmoid sigmoid' "sigmoid"

tanhNeuron :: ReducedNeuron
tanhNeuron = ReducedNeuron tanh tanh' "tanh"

recluNeuron :: ReducedNeuron
recluNeuron = ReducedNeuron reclu reclu' "reclu"

-- | Compute a dot product, but ensure that the dimensions of both
--   vectors are the same size.
l1Norm :: NeuronWeights -> Values -> Double
l1Norm w v = if size w /= size v
             then error "Neuron NeuronWeights and values don't align"
             else dot w v

-- | The sigmoid activation function, a standard activation function defined
--   on the range (0, 1).
sigmoid :: Double -> Activation
sigmoid t = 1 / (1 + exp (-1 * t))

-- | The derivative of the sigmoid function conveniently can be computed in
--   terms of the sigmoid function.
sigmoid' :: Double -> Activation
sigmoid' t = s * (1 - s)
  where s = sigmoid t

-- | The hyperbolic tangent activation function is provided in Prelude. Here
--   we provide the derivative. As with the sigmoid function, the derivative
--   of tanh can be computed in terms of tanh.
tanh' :: Double -> Activation
tanh' t = 1 - s ^ 2
  where s = tanh t

-- | The rectified linear activation function. This is a more "biologically
--   accurate" activation function that still retains differentiability.
reclu :: Double -> Activation
reclu t = log (1 + exp t)

-- | The derivative of the rectified linear activation function is just the
--   sigmoid.
reclu' :: Double -> Activation
reclu' = sigmoid

-- | Calculate the distance between a SOM neuron and an input
l2Norm :: NeuronWeights -> Values -> Activation
l2Norm a b = sqrt $ sum $ map (^2) $ zipWith (-) (toList a) (toList b)

ext: hs

max_stars_repo_name: jbarrow/LambdaNet

max_issues_repo_name: jbarrow/LambdaNet

max_forks_repo_name: jbarrow/LambdaNet


text:
-- |
-- Module      : Conjure.Conjurable
-- Copyright   : (c) 2021 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- This module is part of "Conjure".
--
-- This defines the 'Conjurable' typeclass
-- and utilities involving it.
--
-- You are probably better off importing "Conjure".
module Conjure.Conjurable
  ( Reification1
  , Reification
  , Conjurable (..)
  , conjureType
  , reifyTiers
  , reifyEquality
  , reifyExpress
  , conjureApplication
  , conjureVarApplication
  , conjurePats
  , conjureHoles
  , conjureTiersFor
  , conjureAreEqual
  , conjureMkEquation
  , A, B, C, D, E, F
  , conjureIsDeconstructor
  , conjureIsDeconstruction
  , candidateDeconstructionsFrom
  , conjureIsUnbreakable
  , conjureReification
  , conjureReification1
  , conjureDynamicEq
  , cevaluate
  , ceval
  , cevl
  , Name (..)
  , Express (..)
  )
where

import Test.LeanCheck
import Test.LeanCheck.Utils
import Test.LeanCheck.Error (errorToFalse)
import Conjure.Expr hiding (application)
import Conjure.Defn
import Test.Speculate.Expr
import Data.Functor ((<$>))
import Control.Applicative ((<*>))
import Data.Dynamic
import Data.Express

import Data.Int     -- for instances
import Data.Word    -- for instances
import Data.Ratio   -- for instance
import Data.Complex -- for instance

-- | Single reification of some functions over a type as 'Expr's.
--
-- This is a sixtuple, in order:
--
-- 1. a hole encoded as an 'Expr';
-- 2. the '==' function encoded as an 'Expr' when available;
-- 3. 'tiers' of enumerated test values encoded as 'Expr's when available;
-- 4. infinite list of potential variable names;
-- 5. boolean indicating whether the type is atomic;
-- 6. the 'conjureSize' function encoded as an 'Expr'.
type Reification1  =  (Expr, Maybe Expr, Maybe [[Expr]], [String], Bool, Expr)

-- | A reification over a collection of types.
--
-- Represented as a transformation of a list to a list.
type Reification  =  [Reification1] -> [Reification1]

-- | A primtive expression (paired with instance reification).
type Prim  =  (Expr, Reification)

-- | Provides a primitive value to Conjure.
--   To be used on 'Show' instances.
--   (cf. 'prim')
pr :: (Conjurable a, Show a) => a -> Prim
pr x  =  (val x, conjureType x)

-- | Provides a primitive value to Conjure.
--   To be used on values that are not 'Show' instances
--   such as functions.
--   (cf. 'pr')
prim :: Conjurable a => String -> a -> Prim
prim s x  =  (value s x, conjureType x)

-- | Class of 'Conjurable' types.
-- Functions are 'Conjurable'
-- if all their arguments are 'Conjurable', 'Listable' and 'Show'able.
--
-- For atomic types that are 'Listable',
-- instances are defined as:
--
-- > instance Conjurable Atomic where
-- >   conjureTiers  =  reifyTiers
--
-- For atomic types that are both 'Listable' and 'Eq',
-- instances are defined as:
--
-- > instance Conjurable Atomic where
-- >   conjureTiers     =  reifyTiers
-- >   conjureEquality  =  reifyEquality
--
-- For types with subtypes,
-- instances are defined as:
--
-- > instance Conjurable Composite where
-- >   conjureTiers     =  reifyTiers
-- >   conjureEquality  =  reifyEquality
-- >   conjureSubTypes x  =  conjureType y
-- >                      .  conjureType z
-- >                      .  conjureType w
-- >     where
-- >     (Composite ... y ... z ... w ...)  =  x
--
-- Above @x@, @y@, @z@ and @w@ are just proxies.
-- The @Proxy@ type was avoided for backwards compatibility.
--
-- Please see the source code of "Conjure.Conjurable" for more examples.
--
-- (cf. 'reifyTiers', 'reifyEquality', 'conjureType')
class (Typeable a, Name a) => Conjurable a where
  conjureArgumentHoles :: a -> [Expr]
  conjureArgumentHoles _  =  []

  -- | Returns 'Just' the '==' function encoded as an 'Expr' when available
  --   or 'Nothing' otherwise.
  --
  -- Use 'reifyEquality' when defining this.
  conjureEquality :: a -> Maybe Expr
  conjureEquality _  =  Nothing

  -- | Returns 'Just' 'tiers' of values encoded as 'Expr's when possible
  --   or 'Nothing' otherwise.
  --
  -- Use 'reifyTiers' when defining this.
  conjureTiers :: a -> Maybe [[Expr]]
  conjureTiers _  =  Nothing

  conjureSubTypes :: a -> Reification
  conjureSubTypes _  =  id

  -- | Returns an if-function encoded as an 'Expr'.
  conjureIf :: a -> Expr
  conjureIf   =  ifFor

  -- | Returns a top-level case breakdown.
  conjureCases :: a -> [Expr]
  conjureCases _  =  []

  conjureArgumentCases :: a -> [[Expr]]
  conjureArgumentCases _  =  []

  -- | Returns the (recursive) size of the given value.
  conjureSize :: a -> Int
  conjureSize _  =  0

  -- | Returns a function that deeply reencodes an expression when possible.
  --   ('id' when not available.)
  --
  -- Use 'reifyExpress' when defining this.
  conjureExpress :: a -> Expr -> Expr

  conjureEvaluate :: (Expr->Expr) -> Int -> Defn -> Expr -> Maybe a
  conjureEvaluate  =  devaluate

-- | To be used in the implementation of 'conjureSubTypes'.
--
-- > instance ... => Conjurable <Type> where
-- >   ...
-- >   conjureSubTypes x  =  conjureType (field1 x)
-- >                      .  conjureType (field2 x)
-- >                      .  ...
-- >                      .  conjureType (fieldN x)
-- >   ...
conjureType :: Conjurable a => a -> Reification
conjureType x ms  =
  if hole x `elem` [h | (h,_,_,_,_,_) <- ms]
  then ms
  else conjureSubTypes x $ conjureReification1 x : ms

-- | like 'conjureType' but without type repetitions
nubConjureType :: Conjurable a => a -> Reification
nubConjureType x  =  nubOn (\(eh,_,_,_,_,_) -> eh) . conjureType x
-- The use of nubOn above is O(n^2).
-- So long as there is not a huge number of subtypes of a, so we're fine.

-- | Conjures a 'Reification1' for a 'Conjurable' type.
--
-- This is used in the implementation of 'conjureReification'.
conjureReification1 :: Conjurable a => a -> Reification1
conjureReification1 x  =  (hole x, conjureEquality x, conjureTiers x, names x, null $ conjureCases x, value "conjureSize" (conjureSize -:> x))

-- | Conjures a list of 'Reification1'
--   for a 'Conjurable' type, its subtypes and 'Bool'.
--
-- This is used in the implementation of
-- 'conjureHoles',
-- 'conjureMkEquation',
-- 'conjureAreEqual',
-- 'conjureTiersFor',
-- 'conjureIsDeconstructor',
-- 'conjureNamesFor',
-- 'conjureIsUnbreakable',
-- etc.
conjureReification :: Conjurable a => a -> [Reification1]
conjureReification x  =  nubConjureType x [conjureReification1 bool]
  where
  bool :: Bool
  bool  =  error "conjureReification: evaluated proxy boolean value (definitely a bug)"

-- | Reifies equality '==' in a 'Conjurable' type instance.
--
-- This is to be used
-- in the definition of 'conjureEquality'
-- of 'Conjurable' typeclass instances:
--
-- > instance ... => Conjurable <Type> where
-- >   ...
-- >   conjureEquality  =  reifyEquality
-- >   ...
reifyEquality :: (Eq a, Typeable a) => a -> Maybe Expr
reifyEquality  =  Just . head . reifyEq

-- | Reifies equality to be used in a conjurable type.
--
-- This is to be used
-- in the definition of 'conjureTiers'
-- of 'Conjurable' typeclass instances:
--
-- > instance ... => Conjurable <Type> where
-- >   ...
-- >   conjureTiers  =  reifyTiers
-- >   ...
reifyTiers :: (Listable a, Show a, Typeable a) => a -> Maybe [[Expr]]
reifyTiers  =  Just . mkExprTiers

-- | Reifies the 'expr' function in a 'Conjurable' type instance.
--
-- This is to be used
-- in the definition of 'conjureExpress'
-- of 'Conjurable' typeclass instances.
--
-- > instance ... => Conjurable <Type> where
-- >   ...
-- >   conjureExpress  =  reifyExpress
-- >   ...
reifyExpress :: (Express a, Show a) => a -> Expr -> Expr
reifyExpress a e  =  case value "expr" (expr -:> a) $$ e of
  Nothing -> e         -- TODO: consider throwing an error
  Just e' -> eval e e' -- TODO: consider throwing an error

mkExprTiers :: (Listable a, Show a, Typeable a) => a -> [[Expr]]
mkExprTiers a  =  mapT val (tiers -: [[a]])

-- | Computes a list of holes encoded as 'Expr's
--   from a 'Conjurable' functional value.
--
-- (cf. 'Conjure.Prim.cjHoles')
conjureHoles :: Conjurable f => f -> [Expr]
conjureHoles f  =  [eh | (eh,_,Just _,_,_,_) <- conjureReification f]

-- | Computes a function that makes an equation between two expressions.
conjureMkEquation :: Conjurable f => f -> Expr -> Expr -> Expr
conjureMkEquation f  =  mkEquation [eq | (_,Just eq,_,_,_,_) <- conjureReification f]

conjureDynamicEq :: Conjurable f => f -> Dynamic
conjureDynamicEq f  =  case conjureMkEquation f efxs efxs of
                       (Value "==" deq :$ _ :$ _) -> deq
                       _ -> error "conjureDynamicEq: expected an == but found something else.  Bug!"
  where
  efxs  =  conjureApplication "f" f

-- | Given a 'Conjurable' functional value,
--   computes a function that checks whether two 'Expr's are equal
--   up to a given number of tests.
conjureAreEqual :: Conjurable f => f -> Int -> Expr -> Expr -> Bool
conjureAreEqual f maxTests  =  (===)
  where
  (-==-)  =  conjureMkEquation f
  e1 === e2  =  isTrue $ e1 -==- e2
  isTrue  =  all (errorToFalse . eval False) . gs
  gs  =  take maxTests . grounds (conjureTiersFor f)

-- | Compute 'tiers' of values encoded as 'Expr's
--   of the type of the given 'Expr'.
conjureTiersFor :: Conjurable f => f -> Expr -> [[Expr]]
conjureTiersFor f e  =  tf allTiers
  where
  allTiers :: [ [[Expr]] ]
  allTiers  =  [etiers | (_,_,Just etiers,_,_,_) <- conjureReification f]
  tf []  =  [[e]] -- no tiers found, keep variable
  tf (etiers:etc)  =  case etiers of
                      ((e':_):_) | typ e' == typ e -> etiers
                      _                            -> tf etc

-- | Compute variable names for the given 'Expr' type.
conjureNamesFor :: Conjurable f => f -> Expr -> [String]
conjureNamesFor f e  =  head
                     $  [ns | (eh, _, _, ns, _, _) <- conjureReification f, typ e == typ eh]
                     ++ [names (undefined :: Int)] -- use [Int] on lists

conjureMostGeneralCanonicalVariation :: Conjurable f => f -> Expr -> Expr
conjureMostGeneralCanonicalVariation f  =  canonicalizeWith (conjureNamesFor f)
                                        .  fastMostGeneralVariation

-- | Checks if an unary function encoded as an 'Expr' is a deconstructor.
--
-- (cf. 'conjureIsDeconstruction')
conjureIsDeconstructor :: Conjurable f => f -> Int -> Expr -> Bool
conjureIsDeconstructor f maxTests e  =  case as of
  [] -> False
  (h:_) -> isDec h
  where
  as  =  [h | h <- hs, isWellTyped (e:$h), typ (e:$h) == typ h]
  hs  =  conjureArgumentHoles f
  isDec h  =  count is gs >= length gs `div` 2
    where
    gs  =  take maxTests $ grounds (conjureTiersFor f) h
    sz  =  head [sz | (_, _, _, _, _, sz) <- conjureReification f
                    , isWellTyped (sz :$ h)]
    esz e  =  eval (0::Int) (sz :$ e)
    is e'  =  errorToFalse $ esz (e :$ e') < esz e'

-- | Checks if an expression is a deconstruction.
--
-- There should be a single 'hole' in the expression.
--
-- 1. The result does not increase the size for at least half the time.
-- 2. The result decreases in size for at least a third of the time.
--
-- (cf. 'conjureIsDeconstructor')
conjureIsDeconstruction :: Conjurable f => f -> Int -> Expr -> Bool
conjureIsDeconstruction f maxTests ed  =  length (holes ed) == 1
                                       && typ h == typ ed
                                       && count is gs >= length gs `div` 2
                                       && count iz gs >= length gs `div` 3
  where
  gs  =  take maxTests $ grounds (conjureTiersFor f) ed
  [h]  =  holes ed
  sz  =  head [sz | (_, _, _, _, _, sz) <- conjureReification f
                  , isWellTyped (sz :$ h)]
  esz e  =  eval (0::Int) (sz :$ e)
  is e  =  errorToFalse $ esz e <= esz (holeValue e)
  iz e  =  errorToFalse $ esz e < esz (holeValue e)
  holeValue e  =  fromMaybe err
               .  lookup h
               .  fromMaybe err
               $  e `match` ed
  err  =  error "conjureIsDeconstructor: the impossible happened"

-- | Compute candidate deconstructions from an 'Expr'.
--
-- This is used in the implementation of
-- 'Conjure.Engine.candidateDefnsC' and 'Conjure.Engine.candidateExprs'
-- followed by 'conjureIsDeconstruction'.
candidateDeconstructionsFrom :: Expr -> [Expr]
candidateDeconstructionsFrom e  =
  [ e'
  | v <- vars e
  , typ v == typ e
  , let e' = e //- [(v, holeAsTypeOf v)]
  , length (holes e') == 1
  ]

-- | Checks if an 'Expr' is of an unbreakable type.
conjureIsUnbreakable :: Conjurable f => f -> Expr -> Bool
conjureIsUnbreakable f e  =  head
  [is | (h,_,_,_,is,_) <- conjureReification f, typ h == typ e]

instance Conjurable () where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureCases _   =  [val ()]

instance Conjurable Bool where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureCases _   =  [val False, val True]

instance Conjurable Int where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize      =  abs

instance Conjurable Integer where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize      =  fromIntegral . abs

instance Conjurable Char where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers

-- bind equality to the given argument type
(==:) :: (a -> a -> Bool) -> a -> (a -> a -> Bool)
(==:)  =  const

-- the reconstruction of equality functions for polymorphic types
-- such as [a], (a,b), Maybe a, Either a b
-- is only needed so we don't impose an Eq restriction on the type context.

instance (Conjurable a, Listable a, Express a, Show a) => Conjurable [a] where
  conjureExpress   =  reifyExpress
  conjureSubTypes xs  =  conjureType (head xs)
  conjureTiers     =  reifyTiers
  conjureSize      =  length
  conjureCases xs  =  [ val ([] -: xs)
                      , value ":" ((:) ->>: xs) :$ hole x :$ hole xs
                      ]  where  x  =  head xs
  conjureEquality xs  =  from <$> conjureEquality x
    where
    x  =  head xs
    from e  =  value "==" (==)
      where
      (.==.)  =  evl e ==: x
      []     == []     = True
      (x:xs) == []     = False
      []     == (y:ys) = False
      (x:xs) == (y:ys) = x .==. y && xs == ys

instance ( Conjurable a, Listable a, Show a, Express a
         , Conjurable b, Listable b, Show b, Express b
         ) => Conjurable (a,b) where
  conjureExpress   =  reifyExpress
  conjureTiers     =  reifyTiers
  conjureSubTypes xy  =  conjureType (fst xy)
                      .  conjureType (snd xy)
  conjureCases xy  =  [value "," ((,) ->>: xy) :$ hole x :$ hole y]
    where
    (x,y) = (undefined,undefined) -: xy
  conjureEquality xy  =  from <$> conjureEquality x <*> conjureEquality y
    where
    (x,y)  =  xy
    from e1 e2  =  value "==" (==)
      where
      (==.)  =  evl e1 ==: x
      (.==)  =  evl e2 ==: y
      (x1,y1) == (x2,y2)  =  x1 ==. x2 && y1 .== y2

instance ( Conjurable a, Listable a, Show a, Express a
         , Conjurable b, Listable b, Show b, Express b
         , Conjurable c, Listable c, Show c, Express c
         ) => Conjurable (a,b,c) where
  conjureExpress   =  reifyExpress
  conjureTiers     =  reifyTiers
  conjureSubTypes xyz =  conjureType x
                      .  conjureType y
                      .  conjureType z
                      where (x,y,z) = xyz
  conjureCases xyz  =  [value ",," ((,,) ->>>: xyz) :$ hole x :$ hole y :$ hole z]
    where
    (x,y,z) = (undefined,undefined,undefined) -: xyz
  conjureEquality xyz  =  from
                      <$> conjureEquality x
                      <*> conjureEquality y
                      <*> conjureEquality z
    where
    (x,y,z)  =  xyz
    from e1 e2 e3  =  value "==" (==)
      where
      (==..)  =  evl e1 ==: x
      (.==.)  =  evl e2 ==: y
      (..==)  =  evl e3 ==: z
      (x1,y1,z1) == (x2,y2,z2)  =  x1 ==.. x2
                                && y1 .==. y2
                                && z1 ..== z2

instance (Conjurable a, Listable a, Show a, Express a) => Conjurable (Maybe a) where
  conjureExpress   =  reifyExpress
  conjureTiers     =  reifyTiers
  conjureSubTypes mx  =  conjureType (fromJust mx)
  conjureCases mx  =  [ value "Nothing" (Nothing -: mx)
                      , value "Just" (Just ->: mx) :$ hole x
                      ]
    where
    x  =  Just undefined -: mx
  conjureEquality mx  =  from <$> conjureEquality x
    where
    x  =  fromJust mx
    from e  =  value "==" (==)
      where
      (.==.)  =  evl e ==: x
      Nothing  == Nothing   =  True
      Nothing  == (Just _)  =  False
      (Just _) == Nothing   =  False
      (Just x) == (Just y)  =  x .==. y

instance ( Conjurable a, Listable a, Show a, Express a
         , Conjurable b, Listable b, Show b, Express b
         ) => Conjurable (Either a b) where
  conjureExpress   =  reifyExpress
  conjureTiers     =  reifyTiers
  conjureSubTypes elr  =  conjureType l . conjureType r
    where
    Left l   =  elr
    Right r  =  elr
  conjureCases exy  =  [ value "Left" (Left ->: exy) :$ hole x
                       , value "Right" (Right ->: exy) :$ hole y
                       ]
    where
    x  =  Left undefined -: exy
    y  =  Right undefined -: exy
  conjureEquality elr  =  from <$> conjureEquality l <*> conjureEquality r
    where
    Left l   =  elr
    Right r  =  elr
    from el er  =  value "==" (==)
      where
      (==.)  =  evl el ==: l
      (.==)  =  evl er ==: r
      (Left x)  == (Left y)   =  x ==. y
      (Left _)  == (Right _)  =  False
      (Right _) == (Left _)   =  False
      (Right x) == (Right y)  =  x .== y

instance (Conjurable a, Conjurable b) => Conjurable (a -> b) where
  conjureArgumentHoles f  =  hole (argTy f) : conjureArgumentHoles (f undefined)
  conjureSubTypes f  =  conjureType (argTy f) . conjureType (resTy f)
  conjureIf f  =  conjureIf (f undefined)
  conjureArgumentCases f  =  conjureCases (argTy f) : conjureArgumentCases (f undefined)
  conjureExpress f e
    | typ e == typeOf (argTy f)  =  conjureExpress (argTy f) e
    | otherwise                  =  conjureExpress (f undefined) e
  conjureEvaluate exprExpr mx defn ef  =  mf
    where
    ce  =  conjureEvaluate exprExpr mx defn
    mf  =  case ce (holeAsTypeOf ef :$ hole x) -: Just (f x) of
           Nothing -> Nothing
           Just _  -> Just $ \x -> fromMaybe err . ce $ ef :$ exprExpr (value "" x)
    f  =  undefined -: fromJust mf
    x  =  argTy f
    err  =  error "conjureEvaluate (a->b): BUG!  This should never be evaluated as it is protected by the outer case."

argTy :: (a -> b) -> a
argTy _  =  undefined

resTy :: (a -> b) -> b
resTy _  =  undefined

-- | Evaluates a 'Defn' into a regular Haskell value
--   returning 'Nothing' when there's a type mismatch.
--
-- The integer argument indicates the limit of recursive evaluations.
cevaluate :: Conjurable f => Int -> Defn -> Maybe f
cevaluate mx defn  =  mr
  where
  mr  =  conjureEvaluate exprExpr mx defn ef'
  exprExpr  =  conjureExpress $ fromJust mr
  (ef':_)  =  unfoldApp . fst $ head defn

-- | Evaluates a 'Defn' into a regular Haskell value
--   returning the given default value when there's a type mismatch.
--
-- The integer argument indicates the limit of recursive evaluations.
ceval :: Conjurable f => Int -> f -> Defn -> f
ceval mx z  =  fromMaybe z . cevaluate mx

-- | Evaluates a 'Defn' into a regular Haskell value
--   raising an error there's a type mismatch.
--
-- The integer argument indicates the limit of recursive evaluations.
cevl :: Conjurable f => Int -> Defn -> f
cevl mx  =  ceval mx err
  where
  err  =  error "cevl: type mismatch"

-- | Computes a complete application for the given function.
--
-- > > conjureApplication "not" not
-- > not p :: Bool
--
-- > > conjureApplication "+" ((+) :: Int -> Int -> Int)
-- > x + y :: Int
--
-- (cf. 'conjureVarApplication')
conjureApplication :: Conjurable f => String -> f -> Expr
conjureApplication  =  conjureWhatApplication value

-- | Computes a complete application for a variable
--   of the same type of the given function.
--
-- > > conjureVarApplication "not" not
-- > not p :: Bool
--
-- > > conjureVarApplication "+" ((+) :: Int -> Int -> Int)
-- > x + y :: Int
--
-- (cf. 'conjureApplication')
conjureVarApplication :: Conjurable f => String -> f -> Expr
conjureVarApplication  =  conjureWhatApplication var

-- | Used in the implementation of 'conjureApplication' and 'conjureVarApplication'.
conjureWhatApplication :: Conjurable f => (String -> f -> Expr) -> String -> f -> Expr
conjureWhatApplication what nm f  =  mostGeneralCanonicalVariation . foldApp
                                  $  what nf f : zipWith varAsTypeOf nas (conjureArgumentHoles f)
  where
  (nf:nas)  =  words nm ++ repeat ""

-- | Computes tiers of sets of patterns for the given function.
--
-- > > conjurePats [zero] "f" (undefined :: Int -> Int)
-- > [[[f x :: Int]],[[f 0 :: Int,f x :: Int]]]
conjurePats :: Conjurable f => [Expr] -> String -> f -> [[ [Expr] ]]
conjurePats es nm f  =  mapT (map mkApp . prods) $ cs
  where
  mkApp  =  foldApp . (ef:)
         .  unfold
         .  conjureMostGeneralCanonicalVariation f
         .  fold
  ef  =  var (head $ words nm) f  -- TODO: take the tail into account
  cs  =  products $ zipWith mk (conjureArgumentHoles f) (conjureArgumentCases f)
  mk h []  =  mapT (++ [h]) $ setsOf [[e] | e <- es, typ e == typ h]
  mk h cs  =  [[[h]], [cs]]
  tiersFor  =  conjureTiersFor f

prods :: [[a]] -> [[a]]
prods  =  foldr (productWith (:)) [[]]
  where
  productWith (?) xs ys  =  [x ? y | x <- xs, y <- ys]

-- -- -- other Conjurable instances -- -- --

instance Conjurable Ordering where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers

instance Conjurable Float where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize      =  round

instance Conjurable Double where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize      =  round

instance Conjurable Int8 where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize      =  fromIntegral . abs

instance Conjurable Int16 where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize      =  fromIntegral . abs

instance Conjurable Int32 where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize      =  fromIntegral . abs

instance Conjurable Int64 where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize      =  fromIntegral . abs

instance Conjurable Word where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize      =  fromIntegral . abs

instance Conjurable Word8 where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize      =  fromIntegral . abs

instance Conjurable Word16 where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize      =  fromIntegral . abs

instance Conjurable Word32 where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize      =  fromIntegral . abs

instance Conjurable Word64 where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize      =  fromIntegral . abs

instance (Integral a, Conjurable a, Listable a, Show a, Eq a, Express a) => Conjurable (Ratio a) where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize q    =  conjureSize (numerator q) + conjureSize (denominator q)
  conjureSubTypes q  =  conjureType (numerator q)
  conjureCases q  =  [value "%" ((%) ->>: q) :$ hole n :$ hole d]
    where
    n  =  numerator q
    d  =  denominator q

instance (RealFloat a, Conjurable a, Listable a, Show a, Eq a, Express a) => Conjurable (Complex a) where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize x    =  conjureSize (realPart x) + conjureSize (imagPart x)
  conjureSubTypes x  =  conjureType (realPart x)

-- Conjurable helper types --
instance Conjurable A where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize      =  fromIntegral . abs

instance Conjurable B where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize      =  fromIntegral . abs

instance Conjurable C where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize      =  fromIntegral . abs

instance Conjurable D where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize      =  fromIntegral . abs

instance Conjurable E where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize      =  fromIntegral . abs

instance Conjurable F where
  conjureExpress   =  reifyExpress
  conjureEquality  =  reifyEquality
  conjureTiers     =  reifyTiers
  conjureSize      =  fromIntegral . abs

-- Conjurable tuples --

instance ( Conjurable a, Listable a, Show a, Express a
         , Conjurable b, Listable b, Show b, Express b
         , Conjurable c, Listable c, Show c, Express c
         , Conjurable d, Listable d, Show d, Express d
         ) => Conjurable (a,b,c,d) where
  conjureExpress   =  reifyExpress
  conjureTiers     =  reifyTiers
  conjureSubTypes xyzw =  conjureType x
                       .  conjureType y
                       .  conjureType z
                       .  conjureType w
                       where (x,y,z,w) = xyzw
  conjureEquality xyzw  =  from
                       <$> conjureEquality x
                       <*> conjureEquality y
                       <*> conjureEquality z
                       <*> conjureEquality w
    where
    (x,y,z,w)  =  xyzw
    from e1 e2 e3 e4  =  value "==" (==)
      where
      (==...)  =  evl e1 ==: x
      (.==..)  =  evl e2 ==: y
      (..==.)  =  evl e3 ==: z
      (...==)  =  evl e4 ==: w
      (x1,y1,z1,w1) == (x2,y2,z2,w2)  =  x1 ==... x2
                                      && y1 .==.. y2
                                      && z1 ..==. z2
                                      && w1 ...== w2

instance ( Conjurable a, Listable a, Show a, Express a
         , Conjurable b, Listable b, Show b, Express b
         , Conjurable c, Listable c, Show c, Express c
         , Conjurable d, Listable d, Show d, Express d
         , Conjurable e, Listable e, Show e, Express e
         ) => Conjurable (a,b,c,d,e) where
  conjureExpress   =  reifyExpress
  conjureTiers     =  reifyTiers
  conjureSubTypes xyzwv =  conjureType x
                        .  conjureType y
                        .  conjureType z
                        .  conjureType w
                        .  conjureType v
                        where (x,y,z,w,v) = xyzwv
  conjureEquality xyzwv  =  from
                        <$> conjureEquality x
                        <*> conjureEquality y
                        <*> conjureEquality z
                        <*> conjureEquality w
                        <*> conjureEquality v
    where
    (x,y,z,w,v)  =  xyzwv
    from e1 e2 e3 e4 e5  =  value "==" (==)
      where
      (==....)  =  evl e1 ==: x
      (.==...)  =  evl e2 ==: y
      (..==..)  =  evl e3 ==: z
      (...==.)  =  evl e4 ==: w
      (....==)  =  evl e5 ==: v
      (x1,y1,z1,w1,v1) == (x2,y2,z2,w2,v2)  =  x1 ==.... x2
                                            && y1 .==... y2
                                            && z1 ..==.. z2
                                            && w1 ...==. w2
                                            && v1 ....== v2

instance ( Conjurable a, Listable a, Show a, Express a
         , Conjurable b, Listable b, Show b, Express b
         , Conjurable c, Listable c, Show c, Express c
         , Conjurable d, Listable d, Show d, Express d
         , Conjurable e, Listable e, Show e, Express e
         , Conjurable f, Listable f, Show f, Express f
         ) => Conjurable (a,b,c,d,e,f) where
  conjureExpress   =  reifyExpress
  conjureTiers     =  reifyTiers
  conjureSubTypes xyzwvu =  conjureType x
                         .  conjureType y
                         .  conjureType z
                         .  conjureType w
                         .  conjureType v
                         .  conjureType u
                         where (x,y,z,w,v,u) = xyzwvu
  conjureEquality xyzwvu  =  from
                         <$> conjureEquality x
                         <*> conjureEquality y
                         <*> conjureEquality z
                         <*> conjureEquality w
                         <*> conjureEquality v
                         <*> conjureEquality u
    where
    (x,y,z,w,v,u)  =  xyzwvu
    from e1 e2 e3 e4 e5 e6  =  value "==" (==)
      where
      (==.....)  =  evl e1 ==: x
      (.==....)  =  evl e2 ==: y
      (..==...)  =  evl e3 ==: z
      (...==..)  =  evl e4 ==: w
      (....==.)  =  evl e5 ==: v
      (.....==)  =  evl e6 ==: u
      (x1,y1,z1,w1,v1,u1) == (x2,y2,z2,w2,v2,u2)  =  x1 ==..... x2
                                                  && y1 .==.... y2
                                                  && z1 ..==... z2
                                                  && w1 ...==.. w2
                                                  && v1 ....==. v2
                                                  && u1 .....== u2

instance ( Conjurable a, Listable a, Show a, Express a
         , Conjurable b, Listable b, Show b, Express b
         , Conjurable c, Listable c, Show c, Express c
         , Conjurable d, Listable d, Show d, Express d
         , Conjurable e, Listable e, Show e, Express e
         , Conjurable f, Listable f, Show f, Express f
         , Conjurable g, Listable g, Show g, Express g
         ) => Conjurable (a,b,c,d,e,f,g) where
  conjureExpress   =  reifyExpress
  conjureTiers     =  reifyTiers
  conjureSubTypes xyzwvut =  conjureType x
                          .  conjureType y
                          .  conjureType z
                          .  conjureType w
                          .  conjureType v
                          .  conjureType u
                          .  conjureType t
                         where (x,y,z,w,v,u,t) = xyzwvut
  conjureEquality xyzwvut  =  from
                          <$> conjureEquality x
                          <*> conjureEquality y
                          <*> conjureEquality z
                          <*> conjureEquality w
                          <*> conjureEquality v
                          <*> conjureEquality u
                          <*> conjureEquality t
    where
    (x,y,z,w,v,u,t)  =  xyzwvut
    from e1 e2 e3 e4 e5 e6 e7  =  value "==" (==)
      where
      (==......)  =  evl e1 ==: x
      (.==.....)  =  evl e2 ==: y
      (..==....)  =  evl e3 ==: z
      (...==...)  =  evl e4 ==: w
      (....==..)  =  evl e5 ==: v
      (.....==.)  =  evl e6 ==: u
      (......==)  =  evl e7 ==: t
      (x1,y1,z1,w1,v1,u1,t1) == (x2,y2,z2,w2,v2,u2,t2)  =  x1 ==...... x2
                                                        && y1 .==..... y2
                                                        && z1 ..==.... z2
                                                        && w1 ...==... w2
                                                        && v1 ....==.. v2
                                                        && u1 .....==. u2
                                                        && t1 ......== t2

-- TODO: go up to 12-tuples

instance Name A
instance Name B
instance Name C
instance Name D
instance Name E
instance Name F

max_stars_repo_name: rudymatela/conjure

max_issues_repo_name: rudymatela/conjure

max_forks_repo_name: rudymatela/conjure


text:
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric  #-}
module FokkerPlanck.Histogram where

import           Control.DeepSeq
import           Data.Array.Repa     as R
import           Data.Binary
import           Data.Complex
import           Data.List           as L
import           Data.Vector.Unboxed as VU
-- import           GHC.Generics        (Generic)
import           Text.Printf
import           Types

data Histogram a = Histogram
  { histogramSize :: ![Int]
  , histogramNum  :: !Int
  , histogramVec  :: !(Vector a)
  } -- deriving (Generic)

instance (NFData a) => NFData (Histogram a) where
  rnf (Histogram !size !n !vec) = ()

instance (Binary a, Unbox a) => Binary (Histogram a) where
  put (Histogram size n vec) = do
    put size
    put n
    put . VU.toList $ vec
  get = do
    size <- get
    n <- get
    xs <- get
    return $! Histogram size n . VU.fromList $ xs

instance Eq (Histogram a) where
  (==) (Histogram size1 _ _) (Histogram size2 _ _) = size1 == size2

instance (Show a, Unbox a ) =>  Show (Histogram a) where
  show hist@(Histogram size n vec) =
    printf
      "Histogram size: %s, normalization term = %d\n%s\n"
      (showRepaShape size)
      n
      (show $ VU.take 10 vec)

{-# INLINE showRepaShape #-}
showRepaShape :: [Int] -> String
showRepaShape xs = "(Z" L.++ go (L.reverse xs)
  where
    go [] = ")"
    go (x:xs) = printf " :. %d%s" x (go xs)

{-# INLINE addHistogram #-}
addHistogram :: (Num a, Unbox a) => Histogram a -> Histogram a -> Histogram a
addHistogram (Histogram size1 !n1 !vec1) (Histogram size2 !n2 !vec2) =
  if size1 == size2
    then Histogram size1 (n1 + n2) (VU.zipWith (+) vec1 vec2)
    else error $
         "addHistogram: sizes are not equal.\n" L.++ show size1 L.++ " /= " L.++
         show size2

{-# INLINE addHistogramUnsafe #-}
addHistogramUnsafe :: (Num a, Unbox a) => Histogram a -> Histogram a -> Histogram a
addHistogramUnsafe (Histogram size1 !n1 !vec1) (Histogram _ !n2 !vec2) =
  Histogram size1 (n1 + n2) (VU.zipWith (+) vec1 vec2)

{-# INLINE getHistogramVec #-}
getHistogramVec ::
     (Unbox a, Fractional a) => Histogram a -> VU.Vector a
getHistogramVec (Histogram size n vec)
  | n == 0 = error "getHistogramArr: n == 0."
  | (L.product size) /= (VU.length vec) =
    error $
    "getHistogramArr: size mismatch\nSize = " L.++ show size L.++ " = " L.++
    (show . L.product $ size) L.++
    "\nVector length = " L.++
    (show . VU.length $ vec)
  | otherwise = vec

{-# INLINE getNormalizedHistogramVec #-}
getNormalizedHistogramVec :: (Unbox a, Fractional a) => Histogram a -> VU.Vector a
getNormalizedHistogramVec (Histogram size n vec)
  | n == 0 = error "getNormalizedHistogramVec: n == 0."
  | (L.product size) /= (VU.length vec) =
    error $
    "getNormalizedHistogramVec: size mismatch\nSize = " L.++ show size L.++
    " = " L.++
    (show . L.product $ size) L.++
    "\nVector length = " L.++
    (show . VU.length $ vec)
  | otherwise = VU.map (/ fromIntegral n) vec

{-# INLINE getHistogramArr #-}
getHistogramArr ::
     (Unbox a, Fractional a, Shape d) => Histogram a -> R.Array U d a
getHistogramArr (Histogram size n vec)
  | n == 0 = error "getHistogramArr: n == 0."
  | (L.product size) /= (VU.length vec) =
    error $
    "getHistogramArr: size mismatch\nSize = " L.++ show size L.++ " = " L.++
    (show . L.product $ size) L.++
    "\nVector length = " L.++
    (show . VU.length $ vec)
  | otherwise = fromUnboxed (shapeOfList size) vec

{-# INLINE getNormalizedHistogramArr #-}
getNormalizedHistogramArr ::
     (Unbox a, Fractional a, Shape d) => Histogram a -> R.Array U d a
getNormalizedHistogramArr (Histogram size n vec)
  | n == 0 = error "getNormalizedHistogramArr: n == 0."
  | (L.product size) /= (VU.length vec) =
    error $
    "getNormalizedHistogramArr: size mismatch\nSize = " L.++ show size L.++
    " = " L.++
    (show . L.product $ size) L.++
    "\nVector length = " L.++
    (show . VU.length $ vec)
  | otherwise = fromUnboxed (shapeOfList size) . VU.map (/ fromIntegral n) $ vec

{-# INLINE getNormalizedHistogramArrSink #-}
getNormalizedHistogramArrSink ::
     (Shape d) => Histogram (Complex Double) -> R.Array U d (Complex Double)
getNormalizedHistogramArrSink (Histogram size n vec)
  | n == 0 = error "getNormalizedHistogramArr: n == 0."
  | (L.product size) /= (VU.length vec) =
    error $
    "getNormalizedHistogramArr: size mismatch\nSize = " L.++ show size L.++
    " = " L.++
    (show . L.product $ size) L.++
    "\nVector length = " L.++
    (show . VU.length $ vec)
  | otherwise =
    let normalizedVec =
          VU.map (\x -> (1 - (magnitude x) / fromIntegral n) :+ 0) $ vec
     in fromUnboxed (shapeOfList size) . VU.map (/ (VU.sum normalizedVec)) $
        normalizedVec

{-# INLINE getNormalizedHistogramArrSink' #-}
getNormalizedHistogramArrSink' ::
     (Shape d) => Histogram (Complex Double) -> R.Array U d (Complex Double)
getNormalizedHistogramArrSink' (Histogram size n vec)
  | n == 0 = error "getNormalizedHistogramArr: n == 0."
  | (L.product size) /= (VU.length vec) =
    error $
    "getNormalizedHistogramArr: size mismatch\nSize = " L.++ show size L.++
    " = " L.++
    (show . L.product $ size) L.++
    "\nVector length = " L.++
    (show . VU.length $ vec)
  | otherwise =
    let normalizedVec =
          VU.map
            (\x ->
               let m = magnitude x
                in if m == 0
                     then fromIntegral n :+ 0
                     else (fromIntegral n / m) :+ 0) $
          vec
     in fromUnboxed (shapeOfList size) -- . VU.map (/ (VU.sum normalizedVec)) $
        normalizedVec

{-# INLINE getNormalizedHistogramArrR2Z2T0S0 #-}
getNormalizedHistogramArrR2Z2T0S0 ::
     Histogram (Complex Double) -> R.Array U DIM5 (Complex Double)
getNormalizedHistogramArrR2Z2T0S0 (Histogram size n vec)
  | n == 0 = error "getNormalizedHistogramArr: n == 0."
  | (L.product size) /= (VU.length vec) =
    error $
    "getNormalizedHistogramArr: size mismatch\nSize = " L.++ show size L.++
    " = " L.++
    (show . L.product $ size) L.++
    "\nVector length = " L.++
    (show . VU.length $ vec)
  | otherwise =
    let arr = fromUnboxed (shapeOfList size) . VU.map (\x ->  magnitude x / fromIntegral n) $ vec
        maxArr = R.foldS max 0 arr
     in computeS . R.traverse2 arr maxArr const $ \f fMax idx@(Z :. a :. b :. c :. d :. r) ->
          (f (Z :. a :. b :. c :. d :. 1) - f idx) :+ 0

{-# INLINE emptyHistogram #-}
emptyHistogram :: (Unbox a) => [Int] -> a -> Histogram a
emptyHistogram size = Histogram size 0 . VU.replicate (L.product size)

{-# INLINE mapHistogram #-}
mapHistogram :: (Unbox a, Unbox b) => (a -> b) -> Histogram a -> Histogram b
mapHistogram f (Histogram size n vec) = Histogram size n (VU.map f vec)

max_stars_repo_name: XinhuaZhang/Stochastic-Completion-Field

max_issues_repo_name: XinhuaZhang/Stochastic-Completion-Field

max_forks_repo_name: XinhuaZhang/Stochastic-Completion-Field


text:
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
-- |
-- Module    : Statistics.Distribution
-- Copyright : (c) 2009 Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- Type classes for probability distributions

module Statistics.Distribution
    (
      -- * Type classes
      Distribution(..)
    , DiscreteDistr(..)
    , ContDistr(..)
      -- ** Distribution statistics
    , MaybeMean(..)
    , Mean(..)
    , MaybeVariance(..)
    , Variance(..)
    , MaybeEntropy(..)
    , Entropy(..)
    , FromSample(..)
      -- ** Random number generation
    , ContGen(..)
    , DiscreteGen(..)
    , genContinuous
    , genContinous
      -- * Helper functions
    , findRoot
    , sumProbabilities
    ) where

import Control.Applicative ((<$>), Applicative(..))
import Control.Monad.Primitive (PrimMonad,PrimState)
import Prelude hiding (sum)
import Statistics.Function (square)
import Statistics.Sample.Internal (sum)
import System.Random.MWC (Gen, uniform)
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Generic as G

-- | Type class common to all distributions. Only c.d.f. could be
-- defined for both discrete and continuous distributions.
class Distribution d where
    -- | Cumulative distribution function.  The probability that a
    -- random variable /X/ is less or equal than /x/,
    -- i.e. P(/X/≤/x/). Cumulative should be defined for
    -- infinities as well:
    --
    -- > cumulative d +∞ = 1
    -- > cumulative d -∞ = 0
    cumulative :: d -> Double -> Double

    -- | One's complement of cumulative distribution:
    --
    -- > complCumulative d x = 1 - cumulative d x
    --
    -- It's useful when one is interested in P(/X/>/x/) and
    -- expression on the right side begin to lose precision. This
    -- function have default implementation but implementors are
    -- encouraged to provide more precise implementation.
    complCumulative :: d -> Double -> Double
    complCumulative d x = 1 - cumulative d x

-- | Discrete probability distribution.
class Distribution  d => DiscreteDistr d where
    -- | Probability of n-th outcome.
    probability :: d -> Int -> Double
    probability d = exp . logProbability d

    -- | Logarithm of probability of n-th outcome
    logProbability :: d -> Int -> Double
    logProbability d = log . probability d

-- | Continuous probability distribution.
--
--   Minimal complete definition is 'quantile' and either 'density' or
--   'logDensity'.
class Distribution d => ContDistr d where
    -- | Probability density function. Probability that random
    -- variable /X/ lies in the infinitesimal interval
    -- [/x/,/x+/δ/x/) equal to /density(x)/⋅δ/x/
    density :: d -> Double -> Double
    density d = exp . logDensity d

    -- | Inverse of the cumulative distribution function. The value
    -- /x/ for which P(/X/≤/x/) = /p/. If probability is outside
    -- of [0,1] range function should call 'error'
    quantile :: d -> Double -> Double

    -- | 1-complement of @quantile@:
    --
    -- > complQuantile x ≡ quantile (1 - x)
    complQuantile :: d -> Double -> Double
    complQuantile d x = quantile d (1 - x)

    -- | Natural logarithm of density.
    logDensity :: d -> Double -> Double
    logDensity d = log . density d

-- | Type class for distributions with mean. 'maybeMean' should return
--   'Nothing' if it's undefined for current value of data
class Distribution d => MaybeMean d where
    maybeMean :: d -> Maybe Double

-- | Type class for distributions with mean. If a distribution has
--   finite mean for all valid values of parameters it should be
--   instance of this type class.
class MaybeMean d => Mean d where
    mean :: d -> Double

-- | Type class for distributions with variance. If variance is
--   undefined for some parameter values both 'maybeVariance' and
--   'maybeStdDev' should return Nothing.
--
--   Minimal complete definition is 'maybeVariance' or 'maybeStdDev'
class MaybeMean d => MaybeVariance d where
    maybeVariance :: d -> Maybe Double
    maybeVariance d = (*) <$> x <*> x where x = maybeStdDev d
    maybeStdDev   :: d -> Maybe Double
    maybeStdDev = fmap sqrt . maybeVariance

-- | Type class for distributions with variance. If distribution have
--   finite variance for all valid parameter values it should be
--   instance of this type class.
--
--   Minimal complete definition is 'variance' or 'stdDev'
class (Mean d, MaybeVariance d) => Variance d where
    variance :: d -> Double
    variance d = square (stdDev d)
    stdDev   :: d -> Double
    stdDev = sqrt . variance

-- | Type class for distributions with entropy, meaning Shannon entropy
--   in the case of a discrete distribution, or differential entropy in the
--   case of a continuous one.  'maybeEntropy' should return 'Nothing' if
--   entropy is undefined for the chosen parameter values.
class (Distribution d) => MaybeEntropy d where
  -- | Returns the entropy of a distribution, in nats, if such is defined.
  maybeEntropy :: d -> Maybe Double

-- | Type class for distributions with entropy, meaning Shannon
--   entropy in the case of a discrete distribution, or differential
--   entropy in the case of a continuous one.  If the distribution has
--   well-defined entropy for all valid parameter values then it
--   should be an instance of this type class.
class (MaybeEntropy d) => Entropy d where
  -- | Returns the entropy of a distribution, in nats.
  entropy :: d -> Double

-- | Generate discrete random variates which have given
--   distribution.
class Distribution d => ContGen d where
  genContVar :: PrimMonad m => d -> Gen (PrimState m) -> m Double

-- | Generate discrete random variates which have given
--   distribution. 'ContGen' is superclass because it's always possible
--   to generate real-valued variates from integer values
class (DiscreteDistr d, ContGen d) => DiscreteGen d where
  genDiscreteVar :: PrimMonad m => d -> Gen (PrimState m) -> m Int

-- | Estimate distribution from sample. First parameter in sample is
--   distribution type and second is element type.
class FromSample d a where
  -- | Estimate distribution from sample. Returns nothing is there's
  --   not enough data to estimate or sample clearly doesn't come from
  --   distribution in question. For example if there's negative
  --   samples in exponential distribution.
  fromSample :: G.Vector v a => v a -> Maybe d

-- | Generate variates from continuous distribution using inverse
--   transform rule.
genContinuous :: (ContDistr d, PrimMonad m) => d -> Gen (PrimState m) -> m Double
genContinuous d gen = do
  x <- uniform gen
  return $! quantile d x

-- | Backwards compatibility with genContinuous.
genContinous :: (ContDistr d, PrimMonad m) => d -> Gen (PrimState m) -> m Double
genContinous = genContinuous
{-# DEPRECATED genContinous "Use genContinuous" #-}

data P = P {-# UNPACK #-} !Double {-# UNPACK #-} !Double

-- | Approximate the value of /X/ for which P(/x/>/X/)=/p/.
--
-- This method uses a combination of Newton-Raphson iteration and
-- bisection with the given guess as a starting point.  The upper and
-- lower bounds specify the interval in which the probability
-- distribution reaches the value /p/.
findRoot :: ContDistr d =>
            d                   -- ^ Distribution
         -> Double              -- ^ Probability /p/
         -> Double              -- ^ Initial guess
         -> Double              -- ^ Lower bound on interval
         -> Double              -- ^ Upper bound on interval
         -> Double
findRoot d prob = loop 0 1
  where
    loop !(i::Int) !dx !x !lo !hi
      | abs dx <= accuracy || i >= maxIters = x
      | otherwise                           = loop (i+1) dx'' x'' lo' hi'
      where
        err                   = cumulative d x - prob
        P lo' hi' | err < 0   = P x hi
                  | otherwise = P lo x
        pdf                   = density d x
        P dx' x' | pdf /= 0   = P (err / pdf) (x - dx)
                 | otherwise  = P dx x
        P dx'' x''
            | x' < lo' || x' > hi' || pdf == 0 = let y = (lo' + hi') / 2
                                                 in  P (y-x) y
            | otherwise                        = P dx' x'
    accuracy = 1e-15
    maxIters = 150

-- | Sum probabilities in inclusive interval.
sumProbabilities :: DiscreteDistr d => d -> Int -> Int -> Double
sumProbabilities d low hi =
  -- Return value is forced to be less than 1 to guard against roundoff errors.
  -- ATTENTION! this check should be removed for testing or it could mask bugs.
  min 1 . sum . U.map (probability d) $ U.enumFromTo low hi


text:
{-# LANGUAGE ConstraintKinds  #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes      #-}

module Layers
  ( ForwardLayer(..)
  , OutputLayer(..)
  , ForwardNN(..)
  , BackwardLayer(..)
  , BackputLayer(..)
  , BackwardNN(..)
  , TrainBatch(..)
  , NElement(..)
  , (<~)
  , (~>)
  , forward
  , output
  , backward
  , backput
  , learnForward
  , learnBackward
  , learn
  , learnAll
  , predict
  , evaluate
  ) where

import           Control.Arrow
import           Control.Lens            hiding ((<~))
import           Data.String.Interpolate as S (i)
import           Debug.Trace
import           Numeric
import           Numeric.LinearAlgebra
import           Synapse

type Weight a = Matrix a

type Bias a = Vector a

type SignalX a = Matrix a

type SignalY a = Matrix a

type Diff a = Matrix a

type TeacherBatch a = Matrix a

type InputBatch a = Matrix a

newtype TrainBatch a =
  TrainBatch (TeacherBatch a, InputBatch a)
  deriving (Show)

data ForwardLayer a
  = AffineForward (Weight a) (Bias a)
  | SigmoidForward
  | ReLUForward
  | JoinedForwardLayer (ForwardLayer a) (ForwardLayer a)
  deriving (Show)

instance (Numeric a, Eq a) => Eq (ForwardLayer a) where
  AffineForward w b == AffineForward w' b' = w == w' && b == b'
  SigmoidForward == SigmoidForward = True
  ReLUForward == ReLUForward = True
  JoinedForwardLayer a b == JoinedForwardLayer a' b' = a == a' && b == b'
  _ == _ = False

infixl 4 ~>

(~>) :: ForwardLayer a -> ForwardLayer a -> ForwardLayer a
a ~> (JoinedForwardLayer x y) = (a ~> x) ~> y
a ~> b = JoinedForwardLayer a b

data OutputLayer a =
  SoftmaxWithCrossForward
  deriving (Show)

data ForwardNN a =
  ForwardNN (ForwardLayer a) (OutputLayer a)
  deriving (Show)

data BackwardLayer a
  = AffineBackward (Weight a) (Bias a) (SignalX a)
  | SigmoidBackward (SignalY a)
  | ReLUBackward (SignalX a)
  | JoinedBackwardLayer (BackwardLayer a) (BackwardLayer a)
  deriving (Show)

instance (Numeric a, Eq a) => Eq (BackwardLayer a) where
  AffineBackward w b d == AffineBackward w' b' d' =
    w == w' && b == b' && d == d'
  SigmoidBackward y == SigmoidBackward y' = y == y'
  ReLUBackward x == ReLUBackward x' = x == x'
  JoinedBackwardLayer a b == JoinedBackwardLayer a' b' = a == a' && b == b'
  _ == _ = False

infixr 4 <~

(<~) :: BackwardLayer a -> BackwardLayer a -> BackwardLayer a
(JoinedBackwardLayer x y) <~ b = x <~ (y <~ b)
a <~ b = JoinedBackwardLayer a b

data BackputLayer a =
  SoftmaxWithCrossBackward (TeacherBatch a) (SignalY a)

data BackwardNN a =
  BackwardNN (BackwardLayer a) (BackputLayer a)

type NElement a = (Ord a, Floating a, Numeric a, Num (Vector a), Show a)

forward ::
     NElement a => ForwardLayer a -> SignalX a -> (BackwardLayer a, SignalY a)
forward (AffineForward w b) x = (AffineBackward w b x, affinem w b x)
forward SigmoidForward x = (SigmoidBackward y, y)
  where
    y = sigmoidm x
forward ReLUForward x = (ReLUBackward x, relum x)
forward (JoinedForwardLayer a b) x0 = (a' <~ b', x2)
  where
    (a', x1) = forward a x0
    (b', x2) = forward b x1

backward ::
     NElement a => a -> BackwardLayer a -> Diff a -> (ForwardLayer a, Diff a)
backward rate (AffineBackward w b x) d =
  (AffineForward (w - scale rate w') (b - scale rate b'), x')
  where
    (x', w', b') = affinemBackward w x d
backward _ (SigmoidBackward y) d = (SigmoidForward, sigmoidBackward y d)
backward _ (ReLUBackward x) d = (ReLUForward, relumBackward x d)
backward r (JoinedBackwardLayer a b) d0 = (a' ~> b', d2)
  where
    (b', d1) = backward r b d0
    (a', d2) = backward r a d1

output ::
     NElement a
  => OutputLayer a
  -> TeacherBatch a
  -> SignalY a
  -> (BackputLayer a, a)
output SoftmaxWithCrossForward t y = (SoftmaxWithCrossBackward t y', loss)
  where
    (y', loss) = softmaxWithCross t y

backput :: NElement a => BackputLayer a -> (OutputLayer a, Diff a)
backput (SoftmaxWithCrossBackward t y) =
  (SoftmaxWithCrossForward, softmaxWithCrossBackward t y)

learnForward :: NElement a => ForwardNN a -> TrainBatch a -> (BackwardNN a, a)
learnForward (ForwardNN layers loss) (TrainBatch (t, x)) =
  result `seq` (BackwardNN layers' loss', result)
  where
    (layers', y) = forward layers x
    (loss', result) = output loss t y

learnBackward :: NElement a => a -> BackwardNN a -> ForwardNN a
learnBackward rate (BackwardNN layers loss) = ForwardNN layers' loss'
  where
    (loss', d) = backput loss
    (layers', _) = backward rate layers d

learn :: NElement a => a -> ForwardNN a -> TrainBatch a -> (ForwardNN a, a)
learn rate a = first (learnBackward rate) . learnForward a

learnAll ::
     NElement a => a -> ForwardNN a -> [TrainBatch a] -> (ForwardNN a, [a])
learnAll rate origin batches = ls `seq` (nn, ls)
  where
    (nn, ls) = foldr f (origin, []) batches
    f batch (a, ls) = ls `seq` second (~: ls) $ learn rate a batch
    x ~: xs = trace [i|[#{length xs + 1}/#{n}] #{show x}|] (x : xs)
    n = length batches

predict :: NElement a => ForwardLayer a -> Vector a -> Int
predict layers = maxIndex . flatten . snd . forward layers . asRow

evaluate :: NElement a => ForwardLayer a -> [(Int, Vector a)] -> Double
evaluate layers samples = fromIntegral nOk / fromIntegral (length samples)
  where
    nOk = length $ filter (uncurry (==)) results
    results = map (second $ predict layers) samples


text:
{-# LANGUAGE Haskell2010 #-}
{-# LINE 1 "Control/DeepSeq.hs" #-}

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE PolyKinds #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.DeepSeq
-- Copyright   :  (c) The University of Glasgow 2001-2009
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  stable
-- Portability :  portable
--
-- This module provides an overloaded function, 'deepseq', for fully
-- evaluating data structures (that is, evaluating to \"Normal Form\").
--
-- A typical use is to prevent resource leaks in lazy IO programs, by
-- forcing all characters from a file to be read. For example:
--
-- > import System.IO
-- > import Control.DeepSeq
-- >
-- > main = do
-- >     h <- openFile "f" ReadMode
-- >     s <- hGetContents h
-- >     s `deepseq` hClose h
-- >     return s
--
-- 'deepseq' differs from 'seq' as it traverses data structures deeply,
-- for example, 'seq' will evaluate only to the first constructor in
-- the list:
--
-- > > [1,2,undefined] `seq` 3
-- > 3
--
-- While 'deepseq' will force evaluation of all the list elements:
--
-- > > [1,2,undefined] `deepseq` 3
-- > *** Exception: Prelude.undefined
--
-- Another common use is to ensure any exceptions hidden within lazy
-- fields of a data structure do not leak outside the scope of the
-- exception handler, or to force evaluation of a data structure in one
-- thread, before passing to another thread (preventing work moving to
-- the wrong threads).
--
-- @since 1.1.0.0
module Control.DeepSeq (
     deepseq, ($!!), force,
     NFData(..),
  ) where

import Control.Applicative
import Control.Concurrent ( ThreadId, MVar )
import Data.IORef
import Data.STRef
import Data.Int
import Data.Word
import Data.Ratio
import Data.Complex
import Data.Array
import Data.Fixed
import Data.Version
import Data.Monoid as Mon
import Data.Unique ( Unique )
import Foreign.Ptr
import Foreign.C.Types
import System.Exit ( ExitCode(..) )
import System.Mem.StableName ( StableName )

import Data.Ord ( Down(Down) )

import Data.Proxy ( Proxy(Proxy) )

import Data.Functor.Identity ( Identity(..) )
import Data.Typeable ( TypeRep, TyCon, rnfTypeRep, rnfTyCon )
import Data.Void ( Void, absurd )
import Numeric.Natural ( Natural )

import Data.List.NonEmpty ( NonEmpty (..) )
import Data.Semigroup as Semi

import GHC.Stack.Types ( CallStack(..), SrcLoc(..) )

import GHC.Fingerprint.Type ( Fingerprint(..) )
import GHC.Generics

-- | Hidden internal type-class
class GNFData f where
  grnf :: f a -> ()

instance GNFData V1 where
  grnf = error "Control.DeepSeq.rnf: uninhabited type"

instance GNFData U1 where
  grnf U1 = ()

instance NFData a => GNFData (K1 i a) where
  grnf = rnf . unK1
  {-# INLINEABLE grnf #-}

instance GNFData a => GNFData (M1 i c a) where
  grnf = grnf . unM1
  {-# INLINEABLE grnf #-}

instance (GNFData a, GNFData b) => GNFData (a :*: b) where
  grnf (x :*: y) = grnf x `seq` grnf y
  {-# INLINEABLE grnf #-}

instance (GNFData a, GNFData b) => GNFData (a :+: b) where
  grnf (L1 x) = grnf x
  grnf (R1 x) = grnf x
  {-# INLINEABLE grnf #-}

infixr 0 $!!

-- | 'deepseq': fully evaluates the first argument, before returning the
-- second.
--
-- The name 'deepseq' is used to illustrate the relationship to 'seq':
-- where 'seq' is shallow in the sense that it only evaluates the top
-- level of its argument, 'deepseq' traverses the entire data structure
-- evaluating it completely.
--
-- 'deepseq' can be useful for forcing pending exceptions,
-- eradicating space leaks, or forcing lazy I/O to happen.  It is
-- also useful in conjunction with parallel Strategies (see the
-- @parallel@ package).
--
-- There is no guarantee about the ordering of evaluation.  The
-- implementation may evaluate the components of the structure in
-- any order or in parallel.  To impose an actual order on
-- evaluation, use 'pseq' from "Control.Parallel" in the
-- @parallel@ package.
--
-- @since 1.1.0.0
deepseq :: NFData a => a -> b -> b
deepseq a b = rnf a `seq` b

-- | the deep analogue of '$!'.  In the expression @f $!! x@, @x@ is
-- fully evaluated before the function @f@ is applied to it.
--
-- @since 1.2.0.0
($!!) :: (NFData a) => (a -> b) -> a -> b
f $!! x = x `deepseq` f x

-- | a variant of 'deepseq' that is useful in some circumstances:
--
-- > force x = x `deepseq` x
--
-- @force x@ fully evaluates @x@, and then returns it.  Note that
-- @force x@ only performs evaluation when the value of @force x@
-- itself is demanded, so essentially it turns shallow evaluation into
-- deep evaluation.
--
-- 'force' can be conveniently used in combination with @ViewPatterns@:
--
-- > {-# LANGUAGE BangPatterns, ViewPatterns #-}
-- > import Control.DeepSeq
-- >
-- > someFun :: ComplexData -> SomeResult
-- > someFun (force -> !arg) = {- 'arg' will be fully evaluated -}
--
-- Another useful application is to combine 'force' with
-- 'Control.Exception.evaluate' in order to force deep evaluation
-- relative to other 'IO' operations:
--
-- > import Control.Exception (evaluate)
-- > import Control.DeepSeq
-- >
-- > main = do
-- >   result <- evaluate $ force $ pureComputation
-- >   {- 'result' will be fully evaluated at this point -}
-- >   return ()
--
-- @since 1.2.0.0
force :: (NFData a) => a -> a
force x = x `deepseq` x

-- | A class of types that can be fully evaluated.
--
-- @since 1.1.0.0
class NFData a where
    -- | 'rnf' should reduce its argument to normal form (that is, fully
    -- evaluate all sub-components), and then return '()'.
    --
    -- === 'Generic' 'NFData' deriving
    --
    -- Starting with GHC 7.2, you can automatically derive instances
    -- for types possessing a 'Generic' instance.
    --
    -- > {-# LANGUAGE DeriveGeneric #-}
    -- >
    -- > import GHC.Generics (Generic)
    -- > import Control.DeepSeq
    -- >
    -- > data Foo a = Foo a String
    -- >              deriving (Eq, Generic)
    -- >
    -- > instance NFData a => NFData (Foo a)
    -- >
    -- > data Colour = Red | Green | Blue
    -- >               deriving Generic
    -- >
    -- > instance NFData Colour
    --
    -- Starting with GHC 7.10, the example above can be written more
    -- concisely by enabling the new @DeriveAnyClass@ extension:
    --
    -- > {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
    -- >
    -- > import GHC.Generics (Generic)
    -- > import Control.DeepSeq
    -- >
    -- > data Foo a = Foo a String
    -- >              deriving (Eq, Generic, NFData)
    -- >
    -- > data Colour = Red | Green | Blue
    -- >               deriving (Generic, NFData)
    -- >
    --
    -- === Compatibility with previous @deepseq@ versions
    --
    -- Prior to version 1.4.0.0, the default implementation of the 'rnf'
    -- method was defined as
    --
    -- @'rnf' a = 'seq' a ()@
    --
    -- However, starting with @deepseq-1.4.0.0@, the default
    -- implementation is based on @DefaultSignatures@ allowing for
    -- more accurate auto-derived 'NFData' instances. If you need the
    -- previously used exact default 'rnf' method implementation
    -- semantics, use
    --
    -- > instance NFData Colour where rnf x = seq x ()
    --
    -- or alternatively
    --
    -- > {-# LANGUAGE BangPatterns #-}
    -- > instance NFData Colour where rnf !_ = ()
    --
    rnf :: a -> ()

    default rnf :: (Generic a, GNFData (Rep a)) => a -> ()
    rnf = grnf . from

instance NFData Int      where rnf !_ = ()
instance NFData Word     where rnf !_ = ()
instance NFData Integer  where rnf !_ = ()
instance NFData Float    where rnf !_ = ()
instance NFData Double   where rnf !_ = ()

instance NFData Char     where rnf !_ = ()
instance NFData Bool     where rnf !_ = ()
instance NFData ()       where rnf !_ = ()

instance NFData Int8     where rnf !_ = ()
instance NFData Int16    where rnf !_ = ()
instance NFData Int32    where rnf !_ = ()
instance NFData Int64    where rnf !_ = ()

instance NFData Word8    where rnf !_ = ()
instance NFData Word16   where rnf !_ = ()
instance NFData Word32   where rnf !_ = ()
instance NFData Word64   where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData (Proxy a) where rnf Proxy = ()

-- |@since 1.4.0.0
instance NFData a => NFData (Identity a) where
    rnf = rnf . runIdentity

-- | Defined as @'rnf' = 'absurd'@.
--
-- @since 1.4.0.0
instance NFData Void where
    rnf = absurd

-- |@since 1.4.0.0
instance NFData Natural  where rnf !_ = ()

-- |@since 1.3.0.0
instance NFData (Fixed a) where rnf !_ = ()

-- |This instance is for convenience and consistency with 'seq'.
-- This assumes that WHNF is equivalent to NF for functions.
--
-- @since 1.3.0.0
instance NFData (a -> b) where rnf !_ = ()

--Rational and complex numbers.

instance NFData a => NFData (Ratio a) where
  rnf x = rnf (numerator x, denominator x)

instance (NFData a) => NFData (Complex a) where
  rnf (x:+y) = rnf x `seq`
               rnf y `seq`
               ()

instance NFData a => NFData (Maybe a) where
    rnf Nothing  = ()
    rnf (Just x) = rnf x

instance (NFData a, NFData b) => NFData (Either a b) where
    rnf (Left x)  = rnf x
    rnf (Right y) = rnf y

-- |@since 1.3.0.0
instance NFData Data.Version.Version where
    rnf (Data.Version.Version branch tags) = rnf branch `seq` rnf tags

instance NFData a => NFData [a] where
    rnf [] = ()
    rnf (x:xs) = rnf x `seq` rnf xs

-- |@since 1.4.0.0
instance NFData a => NFData (ZipList a) where
    rnf = rnf . getZipList

-- |@since 1.4.0.0
instance NFData a => NFData (Const a b) where
    rnf = rnf . getConst

instance (NFData a, NFData b) => NFData (Array a b) where
    rnf x = rnf (bounds x, Data.Array.elems x)

-- |@since 1.4.0.0
instance NFData a => NFData (Down a) where
    rnf (Down x) = rnf x

-- |@since 1.4.0.0
instance NFData a => NFData (Dual a) where
    rnf = rnf . getDual

-- |@since 1.4.0.0
instance NFData a => NFData (Mon.First a) where
    rnf = rnf . Mon.getFirst

-- |@since 1.4.0.0
instance NFData a => NFData (Mon.Last a) where
    rnf = rnf . Mon.getLast

-- |@since 1.4.0.0
instance NFData Any where rnf = rnf . getAny

-- |@since 1.4.0.0
instance NFData All where rnf = rnf . getAll

-- |@since 1.4.0.0
instance NFData a => NFData (Sum a) where
    rnf = rnf . getSum

-- |@since 1.4.0.0
instance NFData a => NFData (Product a) where
    rnf = rnf . getProduct

-- |@since 1.4.0.0
instance NFData (StableName a) where
    rnf !_ = () -- assumes `data StableName a = StableName (StableName# a)`

-- |@since 1.4.0.0
instance NFData ThreadId where
    rnf !_ = () -- assumes `data ThreadId = ThreadId ThreadId#`

-- |@since 1.4.0.0
instance NFData Unique where
    rnf !_ = () -- assumes `newtype Unique = Unique Integer`

-- | __NOTE__: Only defined for @base-4.8.0.0@ and later
--
-- @since 1.4.0.0
instance NFData TypeRep where
    rnf tyrep = rnfTypeRep tyrep

-- | __NOTE__: Only defined for @base-4.8.0.0@ and later
--
-- @since 1.4.0.0
instance NFData TyCon where
    rnf tycon = rnfTyCon tycon

-- | __NOTE__: Only strict in the reference and not the referenced value.
--
-- @since 1.4.2.0
instance NFData (IORef a) where
  rnf !_ = ()

-- | __NOTE__: Only strict in the reference and not the referenced value.
--
-- @since 1.4.2.0
instance NFData (STRef s a) where
  rnf !_ = ()

-- | __NOTE__: Only strict in the reference and not the referenced value.
--
-- @since 1.4.2.0
instance NFData (MVar a) where
  rnf !_ = ()

----------------------------------------------------------------------------
-- GHC Specifics

-- |@since 1.4.0.0
instance NFData Fingerprint where
    rnf (Fingerprint _ _) = ()

----------------------------------------------------------------------------
-- Foreign.Ptr

-- |@since 1.4.2.0
instance NFData (Ptr a) where rnf !_ = ()

-- |@since 1.4.2.0
instance NFData (FunPtr a) where rnf !_ = ()

----------------------------------------------------------------------------
-- Foreign.C.Types

-- |@since 1.4.0.0
instance NFData CChar where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CSChar where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CUChar where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CShort where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CUShort where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CInt where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CUInt where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CLong where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CULong where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CPtrdiff where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CSize where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CWchar where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CSigAtomic where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CLLong where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CULLong where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CIntPtr where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CUIntPtr where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CIntMax where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CUIntMax where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CClock where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CTime where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CUSeconds where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CSUSeconds where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CFloat where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CDouble where rnf !_ = ()

-- NOTE: The types `CFile`, `CFPos`, and `CJmpBuf` below are not
-- newtype wrappers rather defined as field-less single-constructor
-- types.

-- |@since 1.4.0.0
instance NFData CFile where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CFpos where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CJmpBuf where rnf !_ = ()

----------------------------------------------------------------------------
-- System.Exit

-- |@since 1.4.2.0
instance NFData ExitCode where
  rnf (ExitFailure n) = rnf n
  rnf ExitSuccess     = ()

----------------------------------------------------------------------------
-- instances previously provided by semigroups package

-- |@since 1.4.2.0
instance NFData a => NFData (NonEmpty a) where
  rnf (x :| xs) = rnf x `seq` rnf xs

-- |@since 1.4.2.0
instance NFData a => NFData (Min a) where
  rnf (Min a) = rnf a

-- |@since 1.4.2.0
instance NFData a => NFData (Max a) where
  rnf (Max a) = rnf a

-- |@since 1.4.2.0
instance (NFData a, NFData b) => NFData (Arg a b) where
  rnf (Arg a b) = rnf a `seq` rnf b `seq` ()

-- |@since 1.4.2.0
instance NFData a => NFData (Semi.First a) where
  rnf (Semi.First a) = rnf a

-- |@since 1.4.2.0
instance NFData a => NFData (Semi.Last a) where
  rnf (Semi.Last a) = rnf a

-- |@since 1.4.2.0
instance NFData m => NFData (WrappedMonoid m) where
  rnf (WrapMonoid a) = rnf a

-- |@since 1.4.2.0
instance NFData a => NFData (Option a) where
  rnf (Option a) = rnf a

----------------------------------------------------------------------------
-- GHC.Stack

-- |@since 1.4.2.0
instance NFData SrcLoc where
  rnf (SrcLoc a b c d e f g) = rnf a `seq` rnf b `seq` rnf c `seq`
                               rnf d `seq` rnf e `seq` rnf f `seq` rnf g

-- |@since 1.4.2.0
instance NFData CallStack where
  rnf EmptyCallStack = ()
  rnf (PushCallStack a b c) = rnf a `seq` rnf b `seq` rnf c
  rnf (FreezeCallStack a)   = rnf a

----------------------------------------------------------------------------
-- Tuples

instance (NFData a, NFData b) => NFData (a,b) where
  rnf (x,y) = rnf x `seq` rnf y

instance (NFData a, NFData b, NFData c) => NFData (a,b,c) where
  rnf (x,y,z) = rnf x `seq` rnf y `seq` rnf z

instance (NFData a, NFData b, NFData c, NFData d) => NFData (a,b,c,d) where
  rnf (x1,x2,x3,x4) = rnf x1 `seq`
                      rnf x2 `seq`
                      rnf x3 `seq`
                      rnf x4

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5) =>
         NFData (a1, a2, a3, a4, a5) where
  rnf (x1, x2, x3, x4, x5) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6) =>
         NFData (a1, a2, a3, a4, a5, a6) where
  rnf (x1, x2, x3, x4, x5, x6) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7) =>
         NFData (a1, a2, a3, a4, a5, a6, a7) where
  rnf (x1, x2, x3, x4, x5, x6, x7) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8) =>
         NFData (a1, a2, a3, a4, a5, a6, a7, a8) where
  rnf (x1, x2, x3, x4, x5, x6, x7, x8) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7 `seq`
                  rnf x8

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8, NFData a9) =>
         NFData (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
  rnf (x1, x2, x3, x4, x5, x6, x7, x8, x9) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7 `seq`
                  rnf x8 `seq`
                  rnf x9

max_stars_repo_name: BinderDavid/fragnix

max_issues_repo_name: BinderDavid/fragnix

max_forks_repo_name: BinderDavid/fragnix


text:
{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
{- |
Module      :  Numeric.LinearAlgebra.Util.Convolution
Copyright   :  (c) Alberto Ruiz 2012
License     :  GPL

Maintainer  :  Alberto Ruiz (aruiz at um dot es)
Stability   :  provisional

-}
-----------------------------------------------------------------------------

module Numeric.LinearAlgebra.Util.Convolution(
   corr, conv, corrMin,
   corr2, conv2, separable
) where

import Numeric.LinearAlgebra

vectSS :: Element t => Int -> Vector t -> Matrix t
vectSS n v = fromRows [ subVector k n v | k <- [0 .. dim v - n] ]

corr :: Product t => Vector t -- ^ kernel
                  -> Vector t -- ^ source
                  -> Vector t
{- ^ correlation

>>> corr (fromList[1,2,3]) (fromList [1..10])
fromList [14.0,20.0,26.0,32.0,38.0,44.0,50.0,56.0]

-}
corr ker v | dim ker <= dim v = vectSS (dim ker) v <> ker
           | otherwise = error $ "corr: dim kernel ("++show (dim ker)++") > dim vector ("++show (dim v)++")"

conv :: (Product t, Num t) => Vector t -> Vector t -> Vector t
{- ^ convolution ('corr' with reversed kernel and padded input, equivalent to polynomial product)

>>> conv (fromList[1,1]) (fromList [-1,1])
fromList [-1.0,0.0,1.0]

-}
conv ker v = corr ker' v'
  where
    ker' = (flatten.fliprl.asRow) ker
    v' | dim ker > 1 = join [z,v,z]
       | otherwise   = v
    z = constant 0 (dim ker -1)

corrMin :: (Container Vector t, RealElement t, Product t)
        => Vector t
        -> Vector t
        -> Vector t
-- ^ similar to 'corr', using 'min' instead of (*)
corrMin ker v = minEvery ss (asRow ker) <> ones
  where
    minEvery a b = cond a b a a b
    ss = vectSS (dim ker) v
    ones = konst' 1 (dim ker)

matSS :: Element t => Int -> Matrix t -> [Matrix t]
matSS dr m = map (reshape c) [ subVector (k*c) n v | k <- [0 .. r - dr] ]
  where
    v = flatten m
    c = cols m
    r = rows m
    n = dr*c

corr2 :: Product a => Matrix a -> Matrix a -> Matrix a
-- ^ 2D correlation
corr2 ker mat = dims
              . concatMap (map ((<.> ker') . flatten) . matSS c . trans)
              . matSS r $ mat
  where
    r = rows ker
    c = cols ker
    ker' = flatten (trans ker)
    rr = rows mat - r + 1
    rc = cols mat - c + 1
    dims | rr > 0 && rc > 0 = (rr >< rc)
         | otherwise = error $ "corr2: dim kernel ("++sz ker++") > dim matrix ("++sz mat++")"
    sz m = show (rows m)++"x"++show (cols m)

conv2 :: (Num a, Product a) => Matrix a -> Matrix a -> Matrix a
-- ^ 2D convolution
conv2 k m = corr2 (fliprl . flipud $ k) pm
  where
    pm | r == 0 && c == 0 = m
       | r == 0           = fromBlocks [[z3,m,z3]]
       |           c == 0 = fromBlocks [[z2],[m],[z2]]
       | otherwise        = fromBlocks [[z1,z2,z1]
                                       ,[z3, m,z3]
                                       ,[z1,z2,z1]]
    r = rows k - 1
    c = cols k - 1
    h = rows m
    w = cols m
    z1 = konst' 0 (r,c)
    z2 = konst' 0 (r,w)
    z3 = konst' 0 (h,c)

-- TODO: could be simplified using future empty arrays

separable :: Element t => (Vector t -> Vector t) -> Matrix t -> Matrix t
-- ^ matrix computation implemented as separated vector operations by rows and columns.
separable f = fromColumns . map f . toColumns . fromRows . map f . toRows

max_stars_repo_name: curiousleo/liquidhaskell

max_issues_repo_name: curiousleo/liquidhaskell

max_forks_repo_name: curiousleo/liquidhaskell


text:
{-# LANGUAGE OverloadedStrings #-}
module ML.Gym.DType where

import qualified Control.Exception        as E
import           Control.Monad            (join, liftM, void)
import qualified CPython                  as Py
import qualified CPython.Constants        as Py
import qualified CPython.Protocols.Object as Py
import qualified CPython.Types            as Py
import qualified CPython.Types.Exception  as Py
import qualified CPython.Types.Module     as Py
import qualified CPython.Types.Module     as Py
import qualified Data.ByteString          as BS
import           Data.Complex             (Complex)
import           Data.Maybe               (fromMaybe)
import qualified Data.Text                as T
import           System.Environment       (getArgs, getProgName)
import           System.Exit
import           System.IO
import           System.Random            (randomRIO)

data GymDType = GymBool | GymInteger | GymFloat | GymObject | GymByteString | GymText | GymVoid
  deriving (Show, Eq)

-------------------- Converting --------------------

pyToInteger :: Py.SomeObject -> IO (Maybe Integer)
pyToInteger = pyToA Py.fromInteger

pyToText :: Py.SomeObject -> IO (Maybe T.Text)
pyToText = pyToA Py.fromUnicode

pyToFloat :: Py.SomeObject -> IO (Maybe Double)
pyToFloat = pyToA Py.fromFloat

pyToDouble :: Py.SomeObject -> IO (Maybe Double)
pyToDouble = pyToFloat

pyToBool :: Py.SomeObject -> IO (Maybe Bool)
pyToBool obj = do
  true <- Py.isTrue obj
  if true
    then return $ Just True
    else do
    false <- Py.isFalse obj
    if false
      then return $ Just False
      else return $ Nothing

pyToVoid :: Py.SomeObject -> IO (Maybe ())
pyToVoid _ = return $ Just ()

pyToComplex :: Py.SomeObject -> IO (Maybe (Complex Double))
pyToComplex = pyToA Py.fromComplex

pyToByteString :: Py.SomeObject -> IO (Maybe BS.ByteString)
pyToByteString = pyToA Py.fromBytes

pyToTupleList :: Py.SomeObject -> IO (Maybe [Py.SomeObject])
pyToTupleList = pyToA Py.fromTuple

pyToList :: Py.SomeObject -> IO (Maybe [Py.SomeObject])
pyToList = pyToA Py.fromList

pyToListOf :: (Py.SomeObject -> IO (Maybe a)) -> Py.SomeObject -> IO (Maybe [a])
pyToListOf convert = fmap join . join . fmap (traverse (fmap sequence . mapM convert)) . pyToList

pyToListOfListOf :: (Py.SomeObject -> IO (Maybe a)) -> Py.SomeObject -> IO (Maybe [[a]])
pyToListOfListOf convert obj = do
  mList <- pyToList obj
  join . fmap sequence <$> sequence (mapM (pyToListOf convert) <$> mList)

pyToListOfListOfListOf :: (Py.SomeObject -> IO (Maybe a)) -> Py.SomeObject -> IO (Maybe [[[a]]])
pyToListOfListOfListOf convert obj = do
  mList <- pyToList obj
  join . fmap sequence <$> sequence (mapM (pyToListOfListOf convert) <$> mList)

pyToA :: (Py.Concrete b) => (b -> IO a) -> Py.SomeObject -> IO (Maybe a)
pyToA convert obj = do
  isNone <- Py.isNone obj
  if isNone
    then return Nothing
    else Py.cast obj >>= traverse convert

getGymDType :: Py.Object self => self -> IO GymDType
getGymDType dType = do
  kind <- T.unpack . fromMaybe (error "gym type 'kind' not recognized!") <$> (Py.toUnicode "kind" >>= Py.getAttribute dType >>= pyToText)
  return $
    case kind of
      "b" -> GymBool       -- boolean
      "i" -> GymInteger    -- signed integer
      "u" -> GymInteger    -- unsigned integer
      "f" -> GymFloat      -- floating-point
      "c" -> GymFloat      -- complex floating-point
      "m" -> GymInteger    -- timedelta
      "M" -> GymInteger    -- datetime
      "O" -> GymObject     -- object
      "S" -> GymByteString -- (byte-)string
      "U" -> GymText       -- Unicode
      "V" -> GymVoid       -- void
      _ -> error $ "ERROR: unknown gym (numpy) data type/kind named '" ++ show kind ++ "'!"

max_stars_repo_name: schnecki/gym-haskell

max_issues_repo_name: schnecki/gym-haskell

max_forks_repo_name: schnecki/gym-haskell


text:
module HLearn.Metrics.Mahalanobis.Normal
    where

import Control.DeepSeq
import qualified Data.Vector.Generic as VG

import Foreign.Storable
import Numeric.LinearAlgebra hiding ((<>))
import qualified Numeric.LinearAlgebra as LA

import HLearn.Algebra
import HLearn.Metrics.Mahalanobis
import HLearn.Models.Distributions.Multivariate.MultiNormalFast

-------------------------------------------------------------------------------
-- data types

newtype MahalanobisParams dp = MahalanobisParams
    { normal :: MultiNormal dp
    }

deriving instance Show (MultiNormal dp) => Show (MahalanobisParams dp)
deriving instance Read (MultiNormal dp) => Read (MahalanobisParams dp)
deriving instance Eq (MultiNormal dp) => Eq (MahalanobisParams dp)
deriving instance Ord (MultiNormal dp) => Ord (MahalanobisParams dp)
deriving instance NFData (MultiNormal dp) => NFData (MahalanobisParams dp)

-------------------------------------------------------------------------------
-- algebra

deriving instance Monoid (MultiNormal dp) => Monoid (MahalanobisParams dp)

instance HasRing dp => HasRing (MahalanobisParams dp) where
    type Ring (MahalanobisParams dp) = Ring dp

-------------------------------------------------------------------------------
-- training

instance HomTrainer (MultiNormal dp) => HomTrainer (MahalanobisParams dp) where
    type Datapoint (MahalanobisParams dp) = Datapoint (MultiNormal dp)

    train1dp dp = MahalanobisParams $ train1dp dp
    train dps = MahalanobisParams $ train dps

-------------------------------------------------------------------------------
-- metric

instance
    ( VG.Vector dp r
    , Ring (dp r) ~ r
    , LA.Product r
    , Field r
    ) =>  MkMahalanobis (MahalanobisParams (dp r))
        where
    type MetricDatapoint (MahalanobisParams (dp r)) = dp r
    mkMahalanobis (MahalanobisParams m) dp = Mahalanobis
        { rawdp = dp
        , moddp = VG.fromList $ toList $ flatten $ inv (covar m) LA.<> asColumn v
        }
        where
            v = fromList $ VG.toList dp

-- mkMahalanobis ::
--     ( VG.Vector dp r
--     , Ring (dp r) ~ r
--     , LA.Product r
--     ) => MahalanobisParams (dp r) -> dp r -> Mahalanobis (dp r)
-- mkMahalanobis (MahalanobisParams m) dp = Mahalanobis
--     { rawdp = dp
--     , moddp = VG.fromList $ toList $ flatten $ covar m LA.<> asColumn v
--     }
--     where
--         v = fromList $ VG.toList dp

max_stars_repo_name: silky/HLearn

max_issues_repo_name: silky/HLearn

max_forks_repo_name: silky/HLearn


text:
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
{-# LANGUAGE FlexibleContexts #-}
module Neural.Training
  ( TrainingExample(..)
  , TestingExample(..)
  , train
  , backpropagation
  )
where

import           Data.List.Split                ( chunksOf )
import           Foreign.Marshal.Utils          ( fromBool )
import           Control.Monad
import           Control.Monad.Writer
import           Control.Monad.State
import           Control.Monad.Random
import           System.Random
import           System.Random.Shuffle          ( shuffleM )
import           Numeric.LinearAlgebra
import           Text.Printf
import           GHC.Generics                   ( Generic )
import           Control.DeepSeq

import           Neural.Activation
import qualified Neural.Network                as N
import           Neural.Network          hiding ( weights
                                                , biases
                                                )
import           Neural.Layer                   ( Layer(..) )

-- | A training example with an input and desired output in vector form.
data TrainingExample a = TrainingExample (Vector a) (Vector a)
    deriving (Show, Generic, NFData)
-- | A training example with an input and desired output as an index.
data TestingExample a  = TestingExample (Vector a) Int
    deriving (Show, Generic, NFData)

-- | The Hadamar product, elementwise multiplication.
(⊙) :: Num (Vector a) => Vector a -> Vector a -> Vector a
u ⊙ v = u * v

-- | Train a neural network over some amount of epochs given some training
-- data and the size of the mini batches.
train
  :: (RandomGen g, Fractional a, Numeric a, Num (Vector a))
  => ActivationFunction a      -- ^ The activation function
  -> ActivationFunction' a     -- ^ The derivative of the activation function
  -> a                         -- ^ The learning rate
  -> [TrainingExample a]       -- ^ Training data
  -> Maybe [TestingExample a]  -- ^ Optional testing data
  -> Int                       -- ^ Number of ephocs
  -> Int                       -- ^ Mini batch size
  -> Network a                 -- ^ The untrained network
  -> StateT g (Writer [String]) (Network a) -- ^ The trained network
train σ σ' η trainingData testData epochs mbs net = do
  let tellProgress epoch net' = case testData of
        Nothing        -> tell ["Epoch " ++ show epoch ++ " complete"]
        Just testData' -> tell
          [printf "Epoch %d: %d / %d (%.2f%%)" epoch evaluation n p]
         where
          evaluation = evaluate σ testData' net'
          n          = length testData'
          p          = fromIntegral evaluation / fromIntegral n * 100 :: Double
  let trainEpoch net' epoch = do
        shuffledTrainingData <- state $ runRand $ shuffleM trainingData
        let miniBatches = chunksOf mbs shuffledTrainingData
        let tmb         = trainMiniBatch σ σ' η
        let trainedNet  = foldr tmb net' miniBatches
        lift $ tellProgress epoch trainedNet
        return trainedNet

  foldM trainEpoch net [1 .. epochs]

-- | Evaluate the network assuming the output is the index of the neuron with
-- the highest activation.
evaluate
  :: (Numeric a, Num (Vector a))
  => ActivationFunction a     -- ^ The activation function
  -> [TestingExample a]       -- ^ Testing data
  -> Network a                -- ^ The untrained network
  -> Int                      -- ^ The amount of tests the network passed
evaluate σ testData net =
  let eval (TestingExample x y) = maxIndex (fst $ feedforward σ x net) == y
      results = map eval testData
  in  foldl (\acc r -> acc + fromBool r) 0 results

-- | Train a neural network for a mini batch of training data.
trainMiniBatch
  :: (Fractional a, Numeric a, Num (Vector a))
  => ActivationFunction a    -- ^ The activation function
  -> ActivationFunction' a   -- ^ The derivative of the activation function
  -> a                       -- ^ The learning rate
  -> [TrainingExample a]     -- ^ A mini batch of training examples
  -> Network a               -- ^ The untrained network
  -> Network a               -- ^ The trained network
trainMiniBatch σ σ' η miniBatch net =
  let bp example = backpropagation σ σ' example net
      η'     = η / fromIntegral (length miniBatch)
      ws0    = map (konst 0 . size) (N.weights net)
      bs0    = map (konst 0 . size) (N.biases net)
      deltas = map (unzip . bp) miniBatch
      f (w, b) (dw, db) = (zipWith (+) w dw, zipWith (+) b db)
      (nabla_w, nabla_b) = foldl f (ws0, bs0) deltas
      ws = zipWith (\w nw -> w - scale η' nw) (N.weights net) nabla_w
      bs = zipWith (\b nb -> b - scale η' nb) (N.biases net) nabla_b
  in  newNetwork ws bs

-- | Find the gradient of the cost function with respects to a networks
-- weights and biases for one training example.
backpropagation
  :: (Numeric a, Num (Vector a))
  => ActivationFunction a    -- ^ The activation function
  -> ActivationFunction' a   -- ^ The derivative of the activation function
  -> TrainingExample a       -- ^ A single training example
  -> Network a               -- ^ The neural network
  -> [(Matrix a, Vector a)]  -- ^ The weight and bias gradient of the
                               -- quadratic cost function
backpropagation σ σ' (TrainingExample x y) net@(Network layers) =
  let (as, zs) = unzip $ feedforwards σ x net   -- Feed forward and save the
                                                -- results
      as_      = x : as
      nabla_aC = last as - y                    -- The gradient of the cost
                                                -- function
      calc_δ (l, z) δ = bp2 σ' (weights l) δ z  -- A function that calculates
                                                -- the error for the previous
                                                -- layer
      δ0      = bp1 σ' nabla_aC (last zs)       -- The error of the last layer
      δs      = scanr calc_δ δ0 (zip (tail layers) zs)
      nabla_b = δs                              -- The 3rd equation
      nabla_w = zipWith outer δs as_            -- The 4th equation
  in  zip nabla_w nabla_b

-- | The first equation of backpropagation.
bp1
  :: (Numeric a, Num (Vector a))
  => ActivationFunction' a    -- ^ The derivative of the activation function
  -> Vector a                 -- ^ The gradient of the cost function
                                -- with respects to the activation
  -> Vector a                 -- ^ The weighted input
  -> Vector a                 -- ^ The error in the output layer
bp1 _σ' nabla_aC z = nabla_aC ⊙ σ' z where σ' = cmap _σ'

-- | The second equation of backpropagation.
bp2
  :: (Numeric a, Num (Vector a))
  => ActivationFunction' a    -- ^ The derivative of the activation function
  -> Matrix a                 -- ^ The weights of the next layer
  -> Vector a                 -- ^ The error of the next layer
  -> Vector a                 -- ^ The weighted input of the current layer
  -> Vector a                 -- ^ The error of the current layer
bp2 _σ' w δ z = (tr' w #> δ) ⊙ σ' z where σ' = cmap _σ'

max_stars_repo_name: cornelius-sevald/nnhd

max_issues_repo_name: cornelius-sevald/nnhd

max_forks_repo_name: cornelius-sevald/nnhd