module European (
    European(European),
    PutCall(PUT, CALL),
    black76Call,
    black76Put) where

import Dates
import Market
import Instrument
import Statistics.Distribution
import Statistics.Distribution.Normal

-- |Enum defining a put (option to sell) or call (option to buy)
data PutCall = PUT | CALL deriving (Eq, Show, Read)

-- |The 1976 formulation of the Black-Scholes formula for pricing a European
-- |call option. Parameters discount d, forward f, variance v, strike k,
black76Call :: Double -> Double -> Double -> Double -> Double
black76Call d f v k = d * ((n d1) * f - (n d2) * k) where
    d1 = (log (f/k) + 0.5 * v) / sqrt v
    d2 = d1 - v
    n = cumulative standard

-- |Put call parity says that C - P = S - K, or that here
-- |P = C + d (k - f)
black76Put :: Double -> Double -> Double -> Double -> Double
black76Put d f v k = (black76Call d f v k) + d * (k - f)

-- |European option
data European = European {
    putOrCall :: PutCall,
    expiry :: Date,
    creditEntity :: String,      -- e.g. Currency for a risk-free option
    underlying :: String,
    underlyingEntity :: String,  -- e.g. Currency of the underlying asset
    strike :: Double } deriving (Eq, Show, Read)

-- |Price a European given a discount, forward and vol surface
priceGivenCurves :: European -> Date -> Discount -> Forward -> VolSurface -> Double
priceGivenCurves e valueDate d f v =
    let
        k = (strike e)
        date = (expiry e)
        dates = [date]   -- only one date of interest (ignoring settlement)
        discount = head (d dates)
        forward = head (f dates)
        vol = v f date k
        t = act365 valueDate date
        variance = vol^2 * t
    in
        case putOrCall e of
            PUT -> black76Put discount forward variance k
            CALL -> black76Call discount forward variance k

-- |Generic pricer for European, where it finds the data it needs in the market
instance Priceable European where
    price e m = do
        let ul = (underlying e)
        let valDate = valueDate m
        discount <- findDiscount m (creditEntity e)
        forward <- findEquityForward m ul (underlyingEntity e)
        volSurface <- findVol m ul
        return $ priceGivenCurves e valDate discount forward volSurface


{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
-- |
-- Module    : Statistics.Distribution.FDistribution
-- Copyright : (c) 2011 Aleksey Khudyakov
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- Fisher F distribution
module Statistics.Distribution.FDistribution (
    FDistribution
  , fDistribution
  , fDistributionNDF1
  , fDistributionNDF2
  ) where

import Data.Aeson (FromJSON, ToJSON)
import Data.Binary (Binary)
import Data.Data (Data, Typeable)
import Numeric.MathFunctions.Constants (m_neg_inf)
import GHC.Generics (Generic)
import qualified Statistics.Distribution as D
import Statistics.Function (square)
import Numeric.SpecFunctions (
  logBeta, incompleteBeta, invIncompleteBeta, digamma)
import Data.Binary (put, get)
import Control.Applicative ((<$>), (<*>))

-- | F distribution
data FDistribution = F { fDistributionNDF1 :: {-# UNPACK #-} !Double
                       , fDistributionNDF2 :: {-# UNPACK #-} !Double
                       , _pdfFactor        :: {-# UNPACK #-} !Double
                       }
                   deriving (Eq, Show, Read, Typeable, Data, Generic)

instance FromJSON FDistribution
instance ToJSON FDistribution

instance Binary FDistribution where
    get = F <$> get <*> get <*> get
    put (F x y z) = put x >> put y >> put z

fDistribution :: Int -> Int -> FDistribution
fDistribution n m
  | n > 0 && m > 0 =
    let n' = fromIntegral n
        m' = fromIntegral m
        f' = 0.5 * (log m' * m' + log n' * n') - logBeta (0.5*n') (0.5*m')
    in F n' m' f'
  | otherwise =
    error "Statistics.Distribution.FDistribution.fDistribution: non-positive number of degrees of freedom"

instance D.Distribution FDistribution where
  cumulative = cumulative

instance D.ContDistr FDistribution where
  density d x
    | x <= 0    = 0
    | otherwise = exp $ logDensity d x
  logDensity d x
    | x <= 0    = m_neg_inf
    | otherwise = logDensity d x
  quantile = quantile

cumulative :: FDistribution -> Double -> Double
cumulative (F n m _) x
  | x <= 0       = 0
  | isInfinite x = 1            -- Only matches +∞
  | otherwise    = let y = n*x in incompleteBeta (0.5 * n) (0.5 * m) (y / (m + y))

logDensity :: FDistribution -> Double -> Double
logDensity (F n m fac) x
  = fac + log x * (0.5 * n - 1) - log(m + n*x) * 0.5 * (n + m)

quantile :: FDistribution -> Double -> Double
quantile (F n m _) p
  | p >= 0 && p <= 1 =
    let x = invIncompleteBeta (0.5 * n) (0.5 * m) p
    in m * x / (n * (1 - x))
  | otherwise =
    error $ "Statistics.Distribution.Uniform.quantile: p must be in [0,1] range. Got: "++show p

instance D.MaybeMean FDistribution where
  maybeMean (F _ m _) | m > 2     = Just $ m / (m - 2)
                      | otherwise = Nothing

instance D.MaybeVariance FDistribution where
  maybeStdDev (F n m _)
    | m > 4     = Just $ 2 * square m * (m + n - 2) / (n * square (m - 2) * (m - 4))
    | otherwise = Nothing

instance D.Entropy FDistribution where
  entropy (F n m _) =
    let nHalf = 0.5 * n
        mHalf = 0.5 * m in
    log (n/m)
    + logBeta nHalf mHalf
    + (1 - nHalf) * digamma nHalf
    - (1 + mHalf) * digamma mHalf
    + (nHalf + mHalf) * digamma (nHalf + mHalf)

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

instance D.ContGen FDistribution where
  genContVar = D.genContinous


{-# OPTIONS_GHC -Wall #-}

-- | A magma heirarchy for addition. The basic magma structure is repeated and prefixed with 'Additive-'.
module Plankton.Additive
  ( AdditiveMagma(..)
  , AdditiveUnital(..)
  , AdditiveAssociative
  , AdditiveCommutative
  , AdditiveInvertible(..)
  , AdditiveIdempotent
  , sum
  , Additive(..)
  , AdditiveRightCancellative(..)
  , AdditiveLeftCancellative(..)
  , AdditiveGroup(..)
  ) where

import Data.Complex (Complex(..))
import qualified Protolude as P
import Protolude (Bool(..), Double, Float, Int, Integer)

-- | 'plus' is used as the operator for the additive magma to distinguish from '+' which, by convention, implies commutativity
--
-- > ∀ a,b ∈ A: a `plus` b ∈ A
--
-- law is true by construction in Haskell
class AdditiveMagma a where
  plus :: a -> a -> a

instance AdditiveMagma Double where
  plus = (P.+)

instance AdditiveMagma Float where
  plus = (P.+)

instance AdditiveMagma Int where
  plus = (P.+)

instance AdditiveMagma Integer where
  plus = (P.+)

instance AdditiveMagma Bool where
  plus = (P.||)

instance (AdditiveMagma a) => AdditiveMagma (Complex a) where
  (rx :+ ix) `plus` (ry :+ iy) = (rx `plus` ry) :+ (ix `plus` iy)

-- | Unital magma for addition.
--
-- > zero `plus` a == a
-- > a `plus` zero == a
class AdditiveMagma a =>
      AdditiveUnital a where
  zero :: a

instance AdditiveUnital Double where
  zero = 0

instance AdditiveUnital Float where
  zero = 0

instance AdditiveUnital Int where
  zero = 0

instance AdditiveUnital Integer where
  zero = 0

instance AdditiveUnital Bool where
  zero = False

instance (AdditiveUnital a) => AdditiveUnital (Complex a) where
  zero = zero :+ zero

-- | Associative magma for addition.
--
-- > (a `plus` b) `plus` c == a `plus` (b `plus` c)
class AdditiveMagma a =>
      AdditiveAssociative a

instance AdditiveAssociative Double

instance AdditiveAssociative Float

instance AdditiveAssociative Int

instance AdditiveAssociative Integer

instance AdditiveAssociative Bool

instance (AdditiveAssociative a) => AdditiveAssociative (Complex a)

-- | Commutative magma for addition.
--
-- > a `plus` b == b `plus` a
class AdditiveMagma a =>
      AdditiveCommutative a

instance AdditiveCommutative Double

instance AdditiveCommutative Float

instance AdditiveCommutative Int

instance AdditiveCommutative Integer

instance AdditiveCommutative Bool

instance (AdditiveCommutative a) => AdditiveCommutative (Complex a)

-- | Invertible magma for addition.
--
-- > ∀ a ∈ A: negate a ∈ A
--
-- law is true by construction in Haskell
class AdditiveMagma a =>
      AdditiveInvertible a where
  negate :: a -> a

instance AdditiveInvertible Double where
  negate = P.negate

instance AdditiveInvertible Float where
  negate = P.negate

instance AdditiveInvertible Int where
  negate = P.negate

instance AdditiveInvertible Integer where
  negate = P.negate

instance AdditiveInvertible Bool where
  negate = P.not

instance (AdditiveInvertible a) => AdditiveInvertible (Complex a) where
  negate (rx :+ ix) = negate rx :+ negate ix

-- | Idempotent magma for addition.
--
-- > a `plus` a == a
class AdditiveMagma a =>
      AdditiveIdempotent a

instance AdditiveIdempotent Bool

-- | sum definition avoiding a clash with the Sum monoid in base
--
sum :: (Additive a, P.Foldable f) => f a -> a
sum = P.foldr (+) zero

-- | Additive is commutative, unital and associative under addition
--
-- > zero + a == a
-- > a + zero == a
-- > (a + b) + c == a + (b + c)
-- > a + b == b + a
class (AdditiveCommutative a, AdditiveUnital a, AdditiveAssociative a) =>
      Additive a where
  infixl 6 +
  (+) :: a -> a -> a
  a + b = plus a b

instance Additive Double

instance Additive Float

instance Additive Int

instance Additive Integer

instance Additive Bool

instance (Additive a) => Additive (Complex a)

-- | Non-commutative left minus
--
-- > negate a `plus` a = zero
class (AdditiveUnital a, AdditiveAssociative a, AdditiveInvertible a) =>
      AdditiveLeftCancellative a where
  infixl 6 ~-
  (~-) :: a -> a -> a
  (~-) a b = negate b `plus` a

-- | Non-commutative right minus
--
-- > a `plus` negate a = zero
class (AdditiveUnital a, AdditiveAssociative a, AdditiveInvertible a) =>
      AdditiveRightCancellative a where
  infixl 6 -~
  (-~) :: a -> a -> a
  (-~) a b = a `plus` negate b

-- | Minus ('-') is reserved for where both the left and right cancellative laws hold.  This then implies that the AdditiveGroup is also Abelian.
--
-- Syntactic unary negation - substituting "negate a" for "-a" in code - is hard-coded in the language to assume a Num instance.  So, for example, using ''-a = zero - a' for the second rule below doesn't work.
--
-- > a - a = zero
-- > negate a = zero - a
-- > negate a + a = zero
-- > a + negate a = zero
class (Additive a, AdditiveInvertible a) =>
      AdditiveGroup a where
  infixl 6 -
  (-) :: a -> a -> a
  (-) a b = a `plus` negate b

instance AdditiveGroup Double

instance AdditiveGroup Float

instance AdditiveGroup Int

instance AdditiveGroup Integer

instance (AdditiveGroup a) => AdditiveGroup (Complex a)


import ActivationFunction
import Numeric.LinearAlgebra

main = do
    let x = (1><2) [1.0, 0.5] :: Matrix R
        y = forward x
    print y

forward x =
    let w1 = (2><3) [0.1, 0.3, 0.5, 0.2, 0.4, 0.6] :: Matrix R
        w2 = (3><2) [0.1, 0.4, 0.2, 0.5, 0.3, 0.6] :: Matrix R
        w3 = (2><2) [0.1, 0.3, 0.2, 0.4] :: Matrix R
        b1 = (1><3) [0.1, 0.2, 0.3] :: Matrix R
        b2 = (1><2) [0.1, 0.2] :: Matrix R
        b3 = (1><2) [0.1, 0,2] :: Matrix R
        a1 = (x <> w1) + b1
        z1 = sigmoid a1
        a2 = (z1 <> w2) + b2
        z2 = sigmoid a2
        a3 = (z2 <> w3) + b3
    in id a3


-----------------------------------------------------------------------------
-- |
-- Module      : Berp.Base.StdTypes.Complex
-- Copyright   : (c) 2010 Bernie Pope
-- License     : BSD-style
-- Maintainer  : florbitous@gmail.com
-- Stability   : experimental
-- Portability : ghc
--
-- The standard floating point type.
--
-----------------------------------------------------------------------------

module Berp.Base.StdTypes.Complex (complex, complexClass) where

import Data.Complex (Complex (..), realPart, imagPart)
import Berp.Base.Monad (constantIO)
import Berp.Base.Prims (primitive, raise)
import Berp.Base.SemanticTypes (Object (..), Eval)
import Berp.Base.Identity (newIdentity)
import Berp.Base.Attributes (mkAttributesList)
import Berp.Base.StdNames
import Berp.Base.Builtins (notImplementedError)
import Berp.Base.Operators
   ( addComplexComplexComplex
   , addComplexIntComplex
   , addComplexFloatComplex
   , subComplexComplexComplex
   , subComplexIntComplex
   , subComplexFloatComplex
   , mulComplexComplexComplex
   , mulComplexIntComplex
   , mulComplexFloatComplex
   , divComplexComplexComplex
   , divComplexIntComplex
   , divComplexFloatComplex
   , eqComplexComplexBool
   , eqComplexIntBool
   , eqComplexFloatBool )
import {-# SOURCE #-} Berp.Base.StdTypes.Type (newType)
import Berp.Base.StdTypes.ObjectBase (objectBase)
import Berp.Base.StdTypes.String (string)

{-# NOINLINE complex #-}
complex :: Complex Double -> Object
complex c = constantIO $ do
   identity <- newIdentity
   return $ Complex { object_identity = identity, object_complex = c }

{-# NOINLINE complexClass #-}
complexClass :: Object
complexClass = constantIO $ do
   dict <- attributes
   newType [string "complex", objectBase, dict]

attributes :: IO Object
attributes = mkAttributesList
   [ (specialAddName, add)
   , (specialSubName, sub)
   , (specialMulName, mul)
   , (specialDivName, divide)
   , (specialEqName, eq)
   , (specialStrName, str)
   ]

mkOp :: (Object -> Object -> Eval Object) ->
        (Object -> Object -> Eval Object) ->
        (Object -> Object -> Eval Object) ->
        Object
mkOp opComplex opFloat opInt = primitive 2 fun
   where
   fun (x:y:_) =
      case y of
         Complex {} -> opComplex x y
         Float {} -> opFloat x y
         Integer {} -> opInt x y
         _other -> raise notImplementedError
   fun _other = error "operator on Complex applied to wrong number of arguments"

add :: Object
add = mkOp addComplexComplexComplex addComplexFloatComplex addComplexIntComplex

sub :: Object
sub = mkOp subComplexComplexComplex subComplexFloatComplex subComplexIntComplex

mul :: Object
mul = mkOp mulComplexComplexComplex mulComplexFloatComplex mulComplexIntComplex

divide :: Object
divide = mkOp divComplexComplexComplex divComplexFloatComplex divComplexIntComplex

eq :: Object
eq = mkOp eqComplexComplexBool eqComplexFloatBool eqComplexIntBool

str :: Object
str = primitive 1 fun
   where
   fun (x:_) = return $ string $ showComplex x
   fun _other = error "str method on Complex applied to wrong number of arguments"

showComplex :: Object -> String
showComplex obj
   | r == 0 = if i < 0 then "-" ++ showImg else showImg
   | i < 0 = "(" ++ showR ++ "-" ++ showImg ++ ")"
   | otherwise = "(" ++ showR ++ "+" ++ showImg ++ ")"
   where
   showImg = showI ++ "j"
   showI = showNum $ abs i
   showR = showNum r
   c = object_complex obj
   i = imagPart c
   r = realPart c
   showNum :: Double -> String
   showNum n
      | fracPart == 0 = show intPart
      | otherwise = show n
      where
      (intPart, fracPart) = properFraction n :: (Integer, Double)


{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving  #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeOperators       #-}

module Lib where

import           Control.Monad.Random
import           Data.Binary                  as B
import           Data.Singletons
import           Data.Singletons.Prelude
import           Data.Singletons.TypeLits
import           GHC.Generics                 (Generic)
import           GHC.Natural
import           Numeric.LinearAlgebra.Static
import           Prelude

{-# ANN module ("HLint: ignore Eta reduce" :: Prelude.String) #-}
{-# ANN module ("HLint: ignore Redundant lambda" :: Prelude.String) #-}

------------------------------------------------------------------------------
--import           Test.Hspec
------------------------------------------------------------------------------
{-
https://blog.jle.im/entry/practical-dependent-types-in-haskell-2.html

Practical Dependent Types in Haskell 2: Existential Neural Networks and Types at Runtime
by Justin Le ♦ Thursday June 30, 2016

using dependent types to write type-safe neural networks!

Part 1 dealt with types that are fixed at compile-time.

Part 2 types that depend runtime info
-}
randomWeights
  :: (MonadRandom m, KnownNat i, KnownNat o)
  => m (Weights i o)
randomWeights = do
  s1 :: Int <- getRandom
  s2 :: Int <- getRandom
  let wB = randomVector  s1 Uniform * 2 - 1
      wN = uniformSample s2 (-1) 1
  return $ W wB wN

runLayer
  :: (KnownNat i, KnownNat o)
  => Weights i o
  -> R i
  -> R o
runLayer (W wB wN) v = wB + wN #> v

-- * Network
--

data Network :: Nat -> [Nat] -> Nat -> * where
  O     :: !(Weights i o)
        -> Network i '[] o
  (:&~) :: KnownNat h
        => !(Weights i h)
        -> !(Network h hs o)
        -> Network i (h ': hs) o
infixr 5 :&~

deriving instance (KnownNat i, KnownNat o) => Show (Network i hs o)

logistic :: Floating a => a -> a
logistic x = 1 / (1 + exp (-x))

runNet
  :: (KnownNat i, KnownNat o)
  => Network i hs o
  -> R i
  -> R o
runNet (O w)      !v = logistic (runLayer w v)
runNet (w :&~ n') !v = let v' = logistic (runLayer w v)
                       in  runNet n' v'
{-
------------------------------------------------------------------------------
Types at Runtime

type for neural networks:

:k Network
Network :: Nat -> [Nat] -> Nat -> *
           ^      ^        ^
           |      |        size of the output vector
           |      list of hidden layer sizes
           size of input vector

above requires knowing entire structure of the network at compile-time

------------------------------------------------------------------------------
An Existential Crisis

two main ways to solve this issue : actually just two styles of doing the same thing.

------------------------------------------------------------------------------
Types hiding behind constructors

a user only needs to know input and output vectors, so Neural Network is R i -> R o

downside of having the structure in the type
- can’t store them in the same list or data structure
  Network 10 '[5,3] 1  and Network 10 '[5,2] 1

If written without the internal structure in the type then could:

data OpaqueNet i o

OpaqueNet a useful type for users
- only exposes types relevant to usage/API
- can store in list or MVar : [OpaqueNet 10 3] and MVar (OpaqueNet 10 3)
- serialize/deserialize

OpaqueNet as an "existential" wrapper over Network ('hs' is existential)
-}
data OpaqueNet :: Nat -> Nat -> * where
  ONet :: Network i hs o -> OpaqueNet i o
{-
Given        Network 6 '[10,6,3] 2
can create OpaqueNet 6           2
When using ONet constructor, the structure of the hidden layers disappears from the type.

Use the Network inside by pattern matching on ONet:
-}
runOpaqueNet
  :: (KnownNat i, KnownNat o)
  => OpaqueNet i o
  -> R i
  -> R o
runOpaqueNet (ONet n) x = runNet n x

numHiddens :: OpaqueNet i o -> Int
numHiddens (ONet n) = go n
 where
  go :: Network i hs o -> Int
  go  = \case
    O     _  -> 0
    _ :&~ n' -> 1 + go n'
{-
ScopedTypeVariables
- enables bringing hs back into scope:

case oN of
  ONet (n :: Network i hs o) -> ...

Above pattern is sometimes called dependent pair:
- pattern matching on ONet yields the hidden existentially quantified type : hs
  and also a value whose type is based on it (Network i hs o)
- like hs “paired” with Network i hs o

Pattern match on the results to give both the type 'hs' and the data structure.

(could have implemented it as ONet :: Sing hs -> Network i hs o -> OpaqueNet i o)

key to making this work
- after pattern matching on ONet, must handle 'hs' in a completely polymorphic way
- cannot assume anything about 'hs'

e.g., not ok:

bad :: OpaqueNet i o -> Network i hs o
bad (ONet n) = n

because the type signature means the caller can decide what 'hs' can be.
but the function has a specific 'hs' : the network that ONet hides.
The caller must accommodate whatever is inside ONet.

------------------------------------------------------------------------------
The Universal and the Existential

central to using existential types
- who has the power to decide what the types will be instantiated as

Most polymorphic functions in Haskell are "universally qualified", e.g.,

    map :: (a -> b) -> [a] -> [b]

the caller of map decides what a and b are

map is defined such that it will work for any a and b that the caller chooses

But for

foo :: [Int] -> OpaqueNet i o

caller of 'foo' chooses i and o
'foo' implementation chooses 'hs'
To use what 'foo' returns, must being able to handle anything 'foo'returns.

summary:

universal   : caller chooses
              function’s implementation must accommodate any choice

existential : function’s implementation chooses
              caller must accommodate any choice

earlier showed to Network i hs o inside the OpaqueNet i o
must deal with it in a parametrically polymorphic way (i.e., handle any 'hs')

------------------------------------------------------------------------------
A familiar friend

OpaqueNet i o  is a "dependent pair"
- pairs 'hs' with 'Network i hs o'

another common term : DEPENDENT SUM

"sum types" are Either-like types that can be one thing or another.

Dependent pairs/existential types actually are similar to Either/sum types

working with existential types is no different than working with Either

Given:

foo :: String -> Either Int Bool

then must handle the result for both cases.
- the function gets to pick which

(can view OpaqueNet i o as being an infinite Either over '[], '[1], '[1,2], ...)

handle Either via pattern matching
OpaqueNet i o is the same
- do not know the type of Network i hs o until pattern matching (a "dependent pattern match")

------------------------------------------------------------------------------
REIFICATION

re-write randomNet with explicit singleton input style
-}
randomNet'
  :: forall m i hs o. (MonadRandom m, KnownNat i, KnownNat o)
  => Sing hs -> m (Network i hs o)
randomNet' = \case
  SNil            ->     O <$> randomWeights
  SNat `SCons` ss -> (:&~) <$> randomWeights <*> randomNet' ss

randomNet
  :: forall m i hs o. (MonadRandom m, KnownNat i, SingI hs, KnownNat o)
  => m (Network i hs o)
randomNet = randomNet' sing
{-
use sing :: SingI hs => Sing hs to call the Sing hs ->-style function
from the SingI hs => one

still need to get the list of integers to the type level
- to create a Network i hs o
- to put into ONet

Use 'SomeSing' (a lot like OpaqueNet)
- wrapping the Sing a inside an existential data constructor
- toSing
  - takes term-level value (here [Integer])
  - returns 'SomeSing' wrapping the type-level value (here [Nat])
- pattern match on SomeSing constructor brings 'a' into scope

SomeSing implementation:

data SomeSing :: * -> * where
    SomeSing :: Sing (a :: k) -> SomeSing k

so,

foo :: SomeSing Bool
foo  = SomeSing STrue

bar :: SomeSing Nat
bar  = SomeSing (SNat :: Sing 10)
-}

mSing :: IO ()
mSing  = do
  putStrLn "How many cats do you own?"
  c <- readLn :: IO Natural
  case toSing c of SomeSing sc -> print (fromSing sc + 2)

xIn :: Int -> SomeSing Nat
xIn  = toSing . intToNatural

xOut :: SomeSing Nat -> Int
xOut  = \case SomeSing n -> naturalToInt (fromSing n)

xio :: Int -> Int
xio  = xOut . xIn
{-
inside the case statement branch the type n :: Nat is in scope.
pattern matching on the SNat constructor gives a KnownNat n instance

toSing can convert value x of type a to a singleton representing type x with kind a

Can use this to write randomONet:
-}
randomONet
  :: (MonadRandom m, KnownNat i, KnownNat o)
  => [Natural]
  -> m (OpaqueNet i o)
randomONet hs = case toSing hs of
  SomeSing ss -> ONet <$> randomNet' ss
{-
converting term-level value to type level type known as reification

original goal is now within reach:
-}
main :: IO ()
main  = do
  putStrLn "What hidden layer structure do you want?"
  hs <- readLn
  n  <- randomONet hs
  case n of
    ONet (net :: Network 10 hs 3) ->
      print net
      -- more stuff with dynamically generated net
{-
------------------------------------------------------------------------------
The Boundary

existentially quantified types (e.g., SomeSing),
enables ability to work with types that depend on runtime results

toSing and SomeSing is a BOUNDARY between untyped world and typed world
reification : cleanly separates the two

Reification boundary similar to boundary between pure code and impure (IO, etc.) code.

working with typed/untyped worlds as the same thing
- write as as possible in typed world
- write only what absolutely must be in untyped world
  (e.g., values from runtime environment)

------------------------------------------------------------------------------
Continuation-Based Existentials

another way to work with existentials that can be more natural to use

when pattern matching on existential, must work with ANY values in constructor

oNetToFoo :: OpaqueNet i o -> Foo
oNetToFoo (ONet n) = f n

f take 'Network i hs o' and work for all 'hs'

could skip the constructor and represent an existential type
as something taking the continuation f and giving it what it needs
-}

type OpaqueNet' i o r = (forall hs. Network i hs o -> r) -> r

{-
"Tell me how you would make an r
- given a 'Network i hs o' that works for any 'hs'
- then I will make it for you”

Uses Rank-N types

Using above is similar to using constructor-style:
-}
runOpaqueNet'
  :: (KnownNat i, KnownNat o)
  => OpaqueNet' i o (R o)
  -> R i
  -> R o
runOpaqueNet' oN x = oN (`runNet` x)
--            :: ((forall hs. Network i hs o -> R o) -> R o)
--            -> R i
--            -> R o

numHiddens' :: OpaqueNet' i o Int -> Int
numHiddens' oN = oN go
 where
  go :: Network i hs o -> Int
  go  = \case
    O     _  -> 0
    _ :&~ n' -> 1 + go n'
--          :: ((forall hs. Network i hs o -> Int) -> Int)
--          -> Int
{-
Above "continuation transformation" formally known as skolemization

wrap
-}

oNet' :: Network i hs o -> OpaqueNet' i o r
oNet' n = \f -> f n

-- randomONet that returns a continuation-style existential:

withRandomONet'0
  :: (MonadRandom m, KnownNat i, KnownNat o)
  => [Natural]
  -> (forall hs. Network i hs o -> m r)
  -> m r
-- aka
-- => [Integer]
-- -> OpaqueNet' i o (m r)
withRandomONet'0 hs f = case toSing hs of
  SomeSing ss -> do
    net <- randomNet' ss
    f net
{-
-- version of `toSing` that returns a skolemized `SomeSing`
withSomeSing :: [Integer]
             -> (forall (hs :: [Nat]). Sing hs -> r)
             -> r
-}

withRandomONet'
  :: (MonadRandom m, KnownNat i, KnownNat o)
  => [Natural]
  -> (forall hs. Network i hs o -> m r)
  -> m r
--aka,
-- => [Integer]
-- -> OpaqueNet' i o (m r)
withRandomONet' hs f = withSomeSing hs $ \ss -> do
  net <- randomNet' ss
  f net

main' :: IO ()
main' = do
  putStrLn "What hidden layer structure do you want?"
  hs <- readLn
  withRandomONet' hs $ \(net :: Network 10 hs 3) ->
    print net
    -- blah blah stuff with our dynamically generated net
{-
Just like the case statement pattern match represented the lexical boundary
between the untyped and typed world when using constructor-style existentials,
the ... $ \net -> ... is also a BOUNDARY for continuation-style existentials.

------------------------------------------------------------------------------
A Tale of Two Styles

two equivalent ways representing/working with existential types
can always convert between them

which one to use or offer can make a difference in code clarity

PROS/CONS

continuation-style
- does not require a data type/constructor
  - can use newtypes, but they force users to learn those types/constructors
    for each existential type returned
  - if there are many existentials, then that means a lot of un/wrapping
- easier to use when functions return existentials
  - especially if intended to immediately use them
    - saves an extraneous pattern match
- when using several existentials at once, continuation-style is better
  because each nested existential doesn’t force another level of indentation:

foo = withSomeSing x $ \sx ->
      withSomeSing y $ \sy ->
      withSomeSing z $ \sz ->
        -- ...
vs.

foo = case toSing x of
        SomeSing sx ->
          case toSing y of
            SomeSing sy ->
              case toSing z of
                SomeSing sz ->
                  -- ...
In monadic context, use do notation and ScopedTypeVariables for a non-nested style

main = do
  ONet n1 <- randomONet [7,5,3] :: IO (OpaqueNet 10 1)
  ONet n2 <- randomONet [5,5,5] :: IO (OpaqueNet 10 1)
  ONet n3 <- randomONet [5,4,3] :: IO (OpaqueNet 10 1)
  hs <- readLn
  ONet (n4 :: Network 10 hs 1) <- randomONet hs
    -- ...

nicer than

main = withRandomONet' [7,5,3] $ \n1 ->
       withRandomONet' [5,5,5] $ \n2 ->
       withRandomONet' [5,4,3] $ \n3 -> do
         hs <- readLn
         withRandomONet' hs $ \(n4 :: Network 10 hs 1) -> do
           -- ...
trick less useful for functions like toSing where things are not returned in a monad
You could wrap it in Identity, but that’s kind of silly:

foo = runIdentity $ do
        SomeSing sx <- Identity $ toSing x
        SomeSing sy <- Identity $ toSing y
        SomeSing sz <- Identity $ toSing z
        return $ -- ...

Constructor-style
- necessary for writing typeclass instances
  - i.e., cannowrite a Show instance for (forall hs. Network i hs o -> r) -> r
    but can write one for OpaqueNet i o
  - i.e., Binary de/serialization instances

Haskell does not support using Rank-N types as arguments to type constructors,
so [OpaqueNet i o] is possible,
but not [OpaqueNet' i o r] or [(forall hs. Network i hs o -> r) -> r]

MVar (OpaqueNet i o) is OK
but not MVar ((forall hs. Network i hs o -> r) -> r)

(latter are known as impredicative types)

If the type constructor is a Monad, you can use ContT-style skolemization,
like (forall hs. Network i hs o -> [r]) -> [r] and (forall hs. Network i hs o -> IO r) -> IO r.
But doesn’t work for MVar and other useful type constructors.

When writing functions that take existentials as inputs,
the constructor-style is arguably more natural. But barely.

For example, we wrote a function to find the number of hidden layers in a network earlier:

numHiddens :: OpaqueNet i o -> Int

But the continuation-style version has a slightly messier type:

numHiddens' :: ((forall hs. Network i hs o -> Int) -> Int)
            -> Int

Even with with the type synonym, it’s still a little awkward:

numHiddens' :: OpaqueNet' i o Int -> Int

This is why you’ll encounter many more functions returning continuation-style existentials
in libraries than taking them, for the most part.

------------------------------------------------------------------------------
Serializing Networks

apply existential types and reification to serialization

------------------------------------------------------------------------------
Recap on the Binary Library

Serializing networks whose sizes are statically in
their types — is straightforward --- an advantages of having sizes in types

binary library : typeclass-based de/serializing

monads (Get, Put) for describing serialization schemes and also a
typeclass used to provide serialization instructions for different
types.

usually do not write instances
use GHC generics:
-}
data Weights i o = W
  { wBiases :: !(R o)
  , wNodes  :: !(L o i)
  } deriving (Show, Generic)

instance (KnownNat i, KnownNat o) => Binary (Weights i o)
{-
gives get and put:

get :: (KnownNat i, KnownNat o) => Get (Weights i o)
put :: (KnownNat i, KnownNat o) => Weights i o -> Put
However, for GADTs like Network, we have to things manually.

------------------------------------------------------------------------------
Serializing Network
-}
putNet :: (KnownNat i, KnownNat o) => Network i hs o -> Put
putNet  = \case
  O w     -> put w
  w :&~ n -> put w *> putNet n
{-
Usually a flag is needed  to tell what constructor is being serialized,
so the deserializer can know what constructor to deserialize.
But need needed for Network because it is known know how many :&~ layers to expect
via the type: deserializing Network 5 '[10,6,3] 2 means three (:&~)’s and one O.
-}
getNet :: forall i hs o. (KnownNat i, KnownNat o) => Sing hs -> Get (Network i hs o)
getNet  = \case
  SNil            ->     O <$> get
  SNat `SCons` ss -> (:&~) <$> get <*> getNet ss
{-
getNet similar to randomNet': pattern match on 'hs' to get constructors
and ollow what the singleton’s structure says.

a Network Binary instance : cannot have get take a Sing hs input
- change the arity/type of the function
- switch to SingI-style and have their Binary instances require a SingI hs constraint.
-}
instance (KnownNat i, SingI hs, KnownNat o) => Binary (Network i hs o) where
  put = putNet
  get = getNet sing
{-
------------------------------------------------------------------------------
Serializating OpaqueNet

to de/serialize, must know complete structure

the complete structure is not in the type
- need to encode it as a flag so deserializer will which constructors
-}
hiddenStruct :: Network i hs o -> [Natural]
hiddenStruct = \case
    O _                           -> []
    _ :&~ (n' :: Network h hs' o) -> natVal (Proxy @h) : hiddenStruct n'

{-
natVal :: KnownNat n => Proxy n -> Natural
returns the value-level Natural corresponding to type-level n :: Nat

natVal and hiddenStruct : turn type-level infor ('n', 'hs') into term-level values

inverse of reification functions (like toSing)

REFECTION: type level to the value level
-}
putONet :: (KnownNat i, KnownNat o) => OpaqueNet i o -> Put
putONet (ONet net) = do
  put (hiddenStruct net) -- put the structure (as a binary flag)
  putNet net             -- then put the network itself

-- deserialize: load the list of Integers and reify it
getONet :: (KnownNat i, KnownNat o) => Get (OpaqueNet i o)
getONet = do
  hs <- get              -- load flag
  withSomeSing hs        -- reify it
    (fmap ONet . getNet) -- create it

instance (KnownNat i, KnownNat o) => Binary (OpaqueNet i o) where
  put = putONet
  get = getONet
{-
used constructor-style existential (instead of continuation-style)
because typeclass instances for the latter are not possible

------------------------------------------------------------------------------
An Existence For All

learned
- reification : untyped world to typed world to create tyypes depend on runtime values
- reflection : de/serialization shows type safety in dynamic context

------------------------------------------------------------------------------
Exercises

1. Implement putONet' and getONet' using continuation-style existentials
https://github.com/mstksg/inCode/tree/master/code-samples/dependent-haskell/NetworkTyped2.hs#L188-L193
https://github.com/mstksg/inCode/tree/master/code-samples/dependent-haskell/NetworkTyped2.hs#L195-L203

2. Work with an existential wrapper over the entire network structure (inputs and outputs, too):

data SomeNet where
  SNet :: (KnownNat i, KnownNat o)
       => Network i hs o
       -> SomeNet

(Need KnownNat because of type erasure, to recover original input/output dimensions
back on pattern matching)

And write:

- A function to convert SomeNets to OpaqueNets.
  Return OpaqueNet with existentially quantified i and o in continuation-style.
  (Also try a data type to return it in constructor-style)
https://github.com/mstksg/inCode/tree/master/code-samples/dependent-haskell/NetworkTyped2.hs#L231-L234

- randomSNet, returning m SomeNet.
https://github.com/mstksg/inCode/tree/master/code-samples/dependent-haskell/NetworkTyped2.hs#L236-L245

While you’re at it, write it to return a random continuation-style SomeNet, too! (See the type of withRandomONet' for reference on how to write the type)

The binary instance for SomeNet.

Hint: Remember natVal :: KnownNat n => Proxy n -> Integer!

Hint: Remember that toSomeSing also works for Integers, to get Sings for Nats, too!

A bit of a stretch, because the set of all [Nat]s is non-enumerable and uncountable, but hopefully you get the picture!↩

Recall that I recommend (personally, and subjectively) a style where your external API functions and typeclass instances are implemented in SingI a => style, and your internal ones in Sing a -> style. This lets all of your internal functions fit together more nicely (Sing a -> style tends to be easier to write in, especially if you stay in it the entire time, because Sings are normal first-class values, unlike those global and magical typeclasses) while at the same time removing the burden of calling with explicit singletons from people using the functionality externally.↩

In older versions of singletons, before GHC 8 and TypeInType, we had to implement it using “kind proxies”. Don’t worry if you’re following along in 7.10; the basic usage of SomeSing is essentially identical either way.↩

Skolemization is probably one of the coolest words you’ll encounter when learning/using Haskell, and sometimes just knowing that you’re “skolemizing” something makes you feel cooler. Thank you Thoralf Skolem. If you ever see a “rigid, skolem” error in GHC, you can thank him for that too! He is also the inspiration behind my decision to name my first-born son Thoralf. (My second son’s name will be Curry)↩

It even lets you write Storable instances!↩
-}


{-# LANGUAGE FlexibleInstances #-}
{-|
Module      : Math
Description : Auxiliary math functions
Copyright   : (c) Julian Kopka Larsen, 2015
Stability   : experimental

Definition of math functions like 'scatterMatrix' and the multivariate log Gamma function 'mlgamma'
-}
{-# LANGUAGE TypeSynonymInstances #-}
module Math (
    X,
    dimension,
    Sstat,
    add_means,
    sub_means,
    add_scatter,
    sub_scatter,
    fromX,
    AbelianGroup((<+>), (<->)),
    mlgamma,
    scatterMatrix,
    scatterMatrixAlt,
    mean,
    meanv,
    lnDeterminant
) where

import Numeric.LinearAlgebra (Matrix, Vector, trans, (<>), fromRows, dim, meanCov, invlndet, outer, konst, scale)
import Numeric.LinearAlgebra.Data (size)
import Debug.Trace
import Data.List ((\\))
import Partition (group)

qtr x = trace ("value: " ++ show x) x

-- | Class for the
class AbelianGroup a where
    (<+>) :: a -> a -> a
    (<->) :: a -> a -> a

-- | Type synonym for data objects that can be anything as long as it is compatible with the likelihood
--   could be extended to a type class with sufficient statistics member functions.
type X = [Vector Double]

-- | Computes the scatter matrix defined as:
scatterMatrixAlt :: X -> Matrix Double
scatterMatrixAlt x = sum $ map (\v -> outer (v-xm) (v-xm)) x
                where xm = meanv x

scatterMatrix :: X -> Matrix Double
scatterMatrix x = sum (map (\ v -> outer v v) x) - scale n (outer xm xm)
                    where xm = meanv x
                          n = fromIntegral $ length x

-- | Mean of a dataset
mean :: [Vector Double] -> Matrix Double
mean x = fromRows [meanv x]

meanv :: [Vector Double] -> Vector Double
meanv x = scale (1/(fromIntegral $ length x))(sum x)

dimension :: [Vector Double] -> Int
dimension = dim . head

type Sstat = (Int, Matrix Double, Vector Double)

fromX :: X -> Sstat
fromX x = (length x, scatterMatrix x, meanv x)

instance AbelianGroup Sstat where
    s <+> (0,_,_) = s
    (n1, s1, m1) <+> (n2, s2, m2) = (n1+n2, add_scatter n1 s1 m1 n2 s2 m2 , add_means n1 m1 n2 m2)
    s <-> (0,_,_) = s
    (n1, s1, m1) <-> (n2, s2, m2) = (n1-n2, sub_scatter n1 s1 m1 n2 s2 m2, sub_means n1 m1 n2 m2)

instance (AbelianGroup a) => AbelianGroup [a] where
    x <+> y = map (\(a,b) -> a <+> b) $ zip x y
    x <-> y = map (\(a,b) -> a <-> b) $ zip x y

add_means :: Int -> Vector Double -> Int -> Vector Double -> Vector Double
add_means _ m1 0 _ = m1
add_means 0 _ _ m2 = m2
add_means i1 m1 i2 m2 = scale w1 m1 + scale w2 m2
        where n1 = fromIntegral i1
              n2 = fromIntegral i2
              w1 = (n1/(n1+n2))
              w2 = (n2/(n1+n2))

sub_means :: Int -> Vector Double -> Int -> Vector Double -> Vector Double
sub_means _ m1 0 _ = m1
sub_means i1 _ i2 _ | i1==i2 = meanv []
sub_means i1 m1 i2 m2 = scale w1 m1 - scale w2 m2
        where n1 = fromIntegral i1
              n2 = fromIntegral i2
              w1 = (n1/(n1-n2))
              w2 = (n2/(n1-n2))

add_scatter :: Int -> Matrix Double -> Vector Double -> Int -> Matrix Double -> Vector Double -> Matrix Double
add_scatter _ sa _ 0 _ _ = sa
add_scatter 0 _ _ _ sb _ = sb
add_scatter ia sa ma ib sb mb = sa + sb + (scale na xaa) + (scale nb xbb) - (scale n xx)
        where na = fromIntegral ia
              nb = fromIntegral ib
              xaa = outer ma ma
              xbb = outer mb mb
              mx = add_means ia ma ib mb
              xx = outer mx mx
              n = na + nb

sub_scatter :: Int -> Matrix Double -> Vector Double -> Int -> Matrix Double -> Vector Double -> Matrix Double
sub_scatter 0 _ _ n _ _ = error "Nothing to subtract from."
sub_scatter _ sa _ 0 _ _ = sa
sub_scatter ia sa ma ib sb mb | ia==ib = scatterMatrix [ma]
sub_scatter ia sa ma ib sb mb | ia-ib==1 = konst 0 (size sa)
sub_scatter ia sa ma ib sb mb = sa - sb + (scale na xaa) - (scale nb xbb) - (scale n xx)
        where na = fromIntegral ia
              nb = fromIntegral ib
              xaa = outer ma ma
              xbb = outer mb mb
              mx = sub_means ia ma ib mb
              xx = outer mx mx
              n = na - nb

lnDeterminant :: Matrix Double -> Double
lnDeterminant x = absLnDet * signDet
        where (_,(absLnDet,signDet)) = invlndet x

cofG :: [Double]
cofG = [76.18009172947146,-86.50532032941677,24.01409824083091,-1.231739572450155,0.001208650973866179,-0.000005395239384953]

serG :: Double
serG = 1.000000000190015

lgamma :: Double -> Double
lgamma xx = let tmp' = (xx+5.5) - (xx+0.5)*log(xx+5.5)
                ser' = serG + (sum $ zipWith (/) cofG [xx+1..])
            in -tmp' + log(2.5066282746310005 * ser' / xx)

mlgamma :: Double -> Double -> Double
mlgamma p a = (log pi)*(p*(p-1)/4) + sum (map (\j -> lgamma (a + ((1-j)/2))) [1..p])


{-# LANGUAGE Strict #-}
module Pinwheel.Asterisk where

import Data.Complex

{-# INLINE asteriskGaussianFunc #-}
asteriskGaussianFunc ::
     (RealFloat e) => e -> e -> Int -> e -> e -> e -> Complex e
asteriskGaussianFunc phi rho n a b period =
  (0 :+ (-1)) ^ n *
  exp
    ((-1) *
     (((fromIntegral n ^ 2) / (4 * b) + (pi * rho) ^ 2 / (a * period ^ 2)) :+
      (fromIntegral n * phi)))


module Raycast (intersect, findHits, raycast) where

import           Control.Monad (guard)
import           Data.Maybe (isJust, fromJust, listToMaybe)
import Types
import Ray (createHit)
import Numeric.Vector
import Numeric.Scalar

-- https://courses.cs.washington.edu/courses/csep557/10au/lectures/triangle_intersection.pdf
intersect :: Ray -> Object -> Tri -> Maybe RayHit
intersect ray@(Ray pos dir) obj tri = do
  let a = v_getPos $ t_getP0 tri
      b = v_getPos $ t_getP1 tri
      c = v_getPos $ t_getP2 tri
      n = normalized $ (b - a) × (c - a)
      d = n · a
      t = (d - n · pos) / (n · dir)
      q = pos + dir * (fromScalar t)

      areaQAB = ((b - a) × (q - a)) · n
      areaQBC = ((c - b) × (q - b)) · n
      areaQCA = ((a - c) × (q - c)) · n
      areaABC = ((b - a) × (c - a)) · n

  guard $ areaQAB >= 0
  guard $ areaQBC >= 0
  guard $ areaQCA >= 0
  guard $ t > 0
  -- Only counts as a hit if the ray is traveling towards the front of the triangle
  -- (when direction and normal are closer to antiparallel)
  guard $ (dir · n) < 0

  let alpha = unScalar $ areaQBC / areaABC
      beta = unScalar $ areaQCA / areaABC
      gamma = unScalar $ areaQAB / areaABC

  let hitPos = pos + dir * (fromScalar t)

  return $ createHit obj tri ray (unScalar t) (alpha, beta, gamma) hitPos

findHits :: Scene -> Ray -> [RayHit]
findHits s ray = let objs = s_getObjects s
                     intersections = concatMap (\o -> map (intersect ray o) $ o_getTris o) objs
                 -- It's safe to use `fromJust` here because the filter guarantees all values are `Just`
                 in  map fromJust $ filter isJust intersections

minimumBy :: (Ord b) => (a -> b) -> [a] -> a
minimumBy f xs = foldr1 (\m x -> if f x < f m then x else m) xs

raycast :: Scene -> Ray -> Maybe RayHit
raycast s ray@(Ray origin _) = let hs = findHits s ray
                               in  if   length hs == 0 then Nothing
                                   else Just $ minimumBy rh_getDistance hs


module Square where

import Genetics
import qualified Neural
import Utilities
import qualified Numeric.LinearAlgebra
    ( cmap )
import Numeric.LinearAlgebra
    ( (<>)
    , (><)
    )
import System.Random

newtype Phenotype = Network Double

trainingSet :: TrainingSet
trainingSet = [ ((1><3)[1, 1, 1], (6><1)[1, 1, 1, 0, 1, 1])
              , ((1><3)[0, 0, 1], (6><1)[0, 0, 0, 0, 0, 1])
              , ((1><3)[0, 1, 0], (6><1)[0, 0, 0, 1, 0, 0])
              , ((1><3)[0, 1, 1], (6><1)[0, 0, 1, 0, 0, 1])
              , ((1><3)[1, 0, 0], (6><1)[0, 1, 0, 0, 0, 0])
              ]

randompopulation :: IO [Genotype]
randompopulation = do
    g <- getStdGen
    return $ map Neural.flatten $ take 10 $ randomNetworks g [3, 6]

morphogenesis :: Genotype -> Phenotype
morphogenesis g = Neural.fromList [3, 6]

fit :: Genotype -> Double
fit = (fitness trainingSet) . morphogenesis

-- Iterates fitness and selection on a population, where the
-- selection function uses randomness.
iterations :: RandomGen g => g -> Population -> [Population]
iterations g population =
    map fst $ iterate (mySelection fit) (population, g)

maximums :: [Population] -> [Double]
maximums populations = map maximum $ (map.map) fit $ populations

-- example to see how well we are doing
example :: IO [Double]
example = do
    g <- newStdGen
    population <- randompopulation
    return $ maximums (iterations g population)

fitness :: Neural.TrainingSet -> Neural.Network -> Double
fitness training network =
    let xs = map fst training
        ys = concat (map (Neural.toList . Neural.flatten . snd) training)
        actual = concat (map (Neural.toList . Neural.flatten . (Neural.forward network)) xs)
        differences = zipWith (-) ys actual
    in (-1) * sqrt (sum (map (^2) differences))


module Main where

import           Control.Monad.Par
import           Data.Monoid                              ( (<>) )
import           Types
import qualified Text.Printf                   as Printf
import           Graphics.Gloss
import           Graphics.Gloss.Data.Color
import           Graphics.Gloss.Data.ViewPort
import qualified Numeric.LinearAlgebra         as LinAlg

windowSize :: (Int, Int)
windowSize = (1200, 800)

fps :: Int
fps = 10

data Model = Model
  { earth :: Point
  , earthSpeed :: LinAlg.Vector Float
  , jupiter :: Point
  , jupiterSpeed :: LinAlg.Vector Float
  } deriving (Show, Eq)

earthPosString :: Model -> String
earthPosString m =
  Printf.printf "earth (%.1f, %.1f)" (fst . earth $ m) (snd . earth $ m)

jupiterPosString :: Model -> String
jupiterPosString m =
  Printf.printf "jupiter (%.1f, %.1f)" (fst . jupiter $ m) (snd . jupiter $ m)

initialModel = Model
  { earth        = (-200, 0)
  , earthSpeed   = LinAlg.fromList [0, 20]
  , jupiter      = (0, 0)
  , jupiterSpeed = LinAlg.fromList [0, 0]
  }

main :: IO ()
main = simulate (InWindow "Newtons Planets" windowSize (200, 500))
                black
                fps
                initialModel
                drawModel
                stepFunction

radiusScaleFactor :: Integer -> Float
radiusScaleFactor diameter = fromIntegral diameter / distanceScale

earthRadius :: Float
earthRadius = radiusScaleFactor . diameter $ Earth

jupiterRadius :: Float
jupiterRadius = radiusScaleFactor . diameter $ Jupiter

drawModel :: Model -> Picture
drawModel model =
  let earth'               = color blue (circle earthRadius)
      jupiter'             = color cyan (circle jupiterRadius)
      (earthX  , earthY  ) = earth model
      (jupiterX, jupiterY) = jupiter model
      earthPos             = translate earthX earthY earth'
      jupiterPos           = translate jupiterX jupiterY jupiter'
  in  earthPos <> jupiterPos <> modelInfo (earthPosString model) (-580) (-350) <>
        modelInfo (jupiterPosString model) (-580) (-300)

modelInfo :: String -> Integer -> Integer -> Picture
modelInfo text a b =
  let text'  = Text text
      scaled = scale 0.1 0.1 text'
      moved  = translate (fromIntegral a) (fromIntegral b) scaled
  in  color red moved

stepFunction :: ViewPort -> Float -> Model -> Model
stepFunction vp secs model =
  let earthPoint    = earth model
      jupiterPoint  = jupiter model
      earthSpeed'   = earthSpeed model
      jupiterSpeed' = jupiterSpeed model
      (earthPulled, jupiterPulled)  = runPar $ do
        p1 <- spawnP $ pullOn Earth earthPoint Jupiter jupiterPoint
        p2 <- spawnP $ pullOn Jupiter jupiterPoint Earth earthPoint
        p1' <- get p1
        p2' <- get p2
        return (p1', p2')

  in  Model
        { earth        = newPoint earthPoint earthSpeed'
        , earthSpeed   = alterSpeed earthSpeed' earthPulled
        , jupiter      = newPoint jupiterPoint jupiterSpeed'
        , jupiterSpeed = alterSpeed jupiterSpeed' jupiterPulled
        }


module Isumi.Math.FFT.Internal.Utils
  ( realToComplex
  , virtToComplex
  , vecFromValues
  , compI
  , findM
  , isSorted
  ) where

import           Data.Complex
import           Data.Foldable               (traverse_)
import qualified Data.Vector.Generic         as GV
import qualified Data.Vector.Generic.Mutable as MGV

realToComplex :: (Real a, Fractional b) => a -> Complex b
realToComplex x = realToFrac x :+ 0

virtToComplex :: (Real a, Fractional b) => a -> Complex b
virtToComplex y = 0 :+ realToFrac y

vecFromValues :: (Traversable t, GV.Vector v a)
              => t (Int, a) -> v a
vecFromValues xs = GV.create $ do
  v <- MGV.new ((1+) . maximum . fmap fst $ xs)
  traverse_ (uncurry (MGV.write v)) xs
  pure v

compI :: Fractional b => Complex b
compI = virtToComplex (1 :: Int)

findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
findM _ [] = pure Nothing
findM p (x:xs) = do
  b <- p x
  if b then pure $ Just x
       else findM p xs

-- |Determine whether a list is sorted strictly.
isSorted :: Ord a
         => Bool -- ^ ascending if True, descending if False
         -> [a]
         -> Bool
isSorted _ [] = True
isSorted _ [_] = True
isSorted asc (x:y:zs) =
  (if asc then x < y else x > y) && isSorted asc zs


{-# LANGUAGE TemplateHaskell #-}

module School.Unit.Test.WeightDecay
( weightDecayTest ) where

import Conduit(Identity, liftIO)
import Numeric.LinearAlgebra ((><))
import School.TestUtils (diffCost, randomMatrix)
import School.Types.FloatEq ((~=))
import School.Types.Slinky (Slinky(..))
import School.Unit.CostFunction (CostFunction(..))
import School.Unit.UnitActivation (UnitActivation(..))
import School.Unit.UnitGradient (UnitGradient(..))
import School.Unit.WeightDecay
import School.Utils.LinearAlgebra (compareDoubleMatrix)
import Test.Tasty (TestTree)
import Test.Tasty.QuickCheck hiding ((><))
import Test.Tasty.TH
import Test.QuickCheck.Monadic (monadicIO, assert, pre)

eps :: Double
eps = 1e-5

prec :: Double
prec = 5e-2

weight :: Double -> CostFunction Double Identity
weight coeff = weightDecay coeff

prop_coeff_zero :: (Positive Int) -> (Positive Int) -> Property
prop_coeff_zero (Positive bSize) (Positive fSize) = monadicIO $ do
  inputMat <- liftIO $ randomMatrix bSize fSize
  let input = BatchActivation inputMat
  let cost = computeCost (weight 0) input SNil
  either (const (assert False))
         (\result -> assert $ result ~= 0)
         cost

prop_numerical_deriv :: (Positive Int) -> (Positive Int) -> Double -> Property
prop_numerical_deriv (Positive bSize) (Positive fSize) coeff = monadicIO $ do
  pre $ bSize < 23 && fSize < 23
  inputMat <- liftIO $ randomMatrix bSize fSize
  let input = BatchActivation inputMat
  let costFunc = weight coeff
  let deriv = derivCost costFunc input SNil
  let check = (bSize >< fSize) [ diffCost costFunc
                                          input
                                          eps
                                          (j, k)
                                          SNil
                               | j <- [0..bSize-1], k <- [0..fSize-1] ]
  either (const (assert False))
         (\(BatchGradient g) -> assert $ compareDoubleMatrix prec g check)
         deriv

weightDecayTest :: TestTree
weightDecayTest = $(testGroupGenerator)


module Types
(Data (..),
 plus,
 divide,
 multiply,
 generateBasedOf,
 isEmpty,
 hadamardV,
 hadamardM,
 sigV,
 sigV'
) where

import Numeric.LinearAlgebra.HMatrix

-- Construtor do Data
data Data = Data {
                wHidden :: Matrix R,
                bHidden :: Vector Double,
                aHidden :: Vector Double,
                zetaHidden :: Vector Double,
                wOutput :: Matrix R,
                bOutput :: Vector Double,
                aOutput :: Vector Double,
                zetaOutput :: Vector Double
                } deriving (Eq, Show)

-- Efetua soma entre os respectivos vetores e matrizes de ambos os Datas
plus :: Data -> Data -> Data
plus (Data wH1 bH1 aH1 zH1 wO1 bO1 aO1 zO1) (Data wH2 bH2 aH2 zH2 wO2 bO2 a02 z02) =
    (Data (add wH1 wH2) (add bH1 bH2) aH1 zH1 (add wO1 wO2) (add bO1 bO2) aO1 zO1)

-- Efetua divisao por esacalar entre os respectivos vetores e matrizes do Data
divide :: Data -> Double -> Data
divide (Data wH bH aH zH wO bO aO zO) constant = (Data (scale (1/constant) wH) (scale (1/constant) bH) aH zH (scale (1/constant) wO) (scale (1/constant) bO) aO zO)

-- Efetua multiplicacao por scalar entre os respectivos vetores e matrizes do Data
multiply :: Data -> Double -> Data
multiply (Data wH bH aH zH wO bO aO zO) constant = (Data (scale constant wH) (scale constant bH) aH zH (scale constant wO) (scale constant bO) aO zO)

-- Efetua hadamard entre dois vetores
hadamardV :: (Num a) => [a] -> [a] -> [a]
hadamardV list1 list2 = zipWith (*) list1 list2

-- Efetua hadamard entre duas matrizes
hadamardM :: (Num a) => [[a]] -> [[a]] -> [[a]]
hadamardM matrix1 matrix2 = zipWith hadamardV matrix1 matrix2

-- Computa a funcao sigmoid daquele valor
sig :: Double -> Double
sig x = 1.0 - (1.0 + exp(-x))

-- Computa a derivada da funcao sigmoid daquele valor
sig' :: Double -> Double
sig' x = sig x * (1 - sig x)

-- Computa a funcao sigmoid para cada elemento de uma lista
sigV :: [Double] -> [Double]
sigV l = [sig x | x <- l]

-- Computa a derivada da funcao sigmoid para cada elemento de uma lista
sigV' :: [Double] -> [Double]
sigV' l = [sig' x | x <- l]

-- Cria um data repleto de valores 0.0 com as mesmas dimensoes do modelo passado por parametro
generateBasedOf :: Data -> Data
generateBasedOf (Data wH bH aH zH wO bO aO zO) = let whRows = fst $ size wH
                                                     whColumns = snd $ size wH
                                                     bhLen = size bH
                                                     ahLen = size aH
                                                     zhLen = size zH
                                                     woRows = fst $ size wO
                                                     woColumns = snd $ size wO
                                                     boLen = size bO
                                                     aoLen = size aH
                                                     zoLen = size zH

                                                     newWH = (whRows><whColumns)(replicate (whRows * whColumns) 0.0) :: Matrix R
                                                     newBH = fromList $ replicate bhLen 0.0
                                                     newAH = fromList $ replicate ahLen 0.0
                                                     newZH = fromList $ replicate zhLen 0.0
                                                     newWO = (woRows><woColumns)(replicate (woRows * woColumns) 0.0) :: Matrix R
                                                     newBO = fromList $ replicate boLen 0.0
                                                     newAO = fromList $ replicate aoLen 0.0
                                                     newZO = fromList $ replicate zoLen 0.0
                                                 in (Data newWH newBH newAH newZH newWO newBO newAO newZO)

-- Checa se um Data tem algum elemento nulo
isEmpty :: Data -> Bool
isEmpty (Data wH bH aH zH wO bO aO zO) =
    (null (toList $ flatten wH)) || (null $ toList bH) || (null (toList $ flatten wO)) || (null $ toList bO)


{-# LANGUAGE NoMonomorphismRestriction,
             ScopedTypeVariables
             #-}

module PFP where

import Debug.Trace

import Data.Traversable
import Control.Applicative
import Control.Monad

import Control.Monad.Random
import Control.Monad.State
import Control.Monad.Fix

import Numeric.SpecFunctions -- From cabal install spec-functions

--import Rec
import SplitEval
import Mem

bernoulli :: (Functor m, MonadRandom m) => Double -> m Bool
bernoulli p = (< p) <$> getRandom

-- From Alexey Radul's HSVenture
beta :: (MonadRandom m) => Double -> Double -> m Double
beta alpha beta = do
  -- Adapted from Statistics.Distribution.Beta; not reused because of
  -- funny randomness management convention.
  x <- getRandomR (0.0,1.0)
  return $ quantile x
    where
      quantile x | x == 0 = 0
                 | x == 1 = 1
                 | 0 < x && x < 1 = invIncompleteBeta alpha beta x
                 | otherwise = error $ "x must be in the range [0,1], got: " ++ show x

-- Makes a CRP sampler given the concentration parameter alpha via stick breaking.
makeCRP ::
  (RandomGen g, Functor m, MonadSplit g m, Functor f, MonadRandom f) =>
  Double -> m (f Int)
makeCRP alpha = do
  -- This is probably our only choice for this type
  -- without adding Proxy arguments. Oh well.
  let breakStick :: (RandomGen g) => Rand g Double
      breakStick = beta 1 alpha

  sticks <- repeatS breakStick

  let choose (p:ps) = do
        b <- bernoulli p
        if b
          then return 0
          else (1 +) <$> choose ps

  return $ choose sticks

-- This type was inferred by ghc, so should be the most general.
dpmem ::
  (MonadEval g n, MonadRandom f, MonadSplit g m, RandomGen g,
      Applicative n, Functor f, Functor m) =>
  Double -> n a -> m (f a)
dpmem alpha sampler = do
  crp <- makeCRP alpha
  tables <- memIntS (const sampler)
  return $ tables <$> crp

dpMemInt :: forall a g n m f.
  (MonadEval g n, MonadRandom f, MonadSplit g m, RandomGen g,
      Applicative n, Functor f, Functor m) =>
  Double -> (Int -> n a) -> m (Int -> f a)
dpMemInt alpha f = memIntS f'
  where -- This type needs to have both (MonadSplit g m) for dpmem
        -- and (MonadEval g n) for memIntS
        f' :: Int -> Rand g (f a)
        f' = (dpmem alpha) . f

dpBernoulli = dpmem 1.0 $ (bernoulli 0.5 :: (RandomGen g) => Rand g Bool)

randomWalkRec ::
  (Functor m, MonadRandom m) => Double -> (Int -> m Int) -> Int -> m Int
randomWalkRec _ _ 0 = return 0
randomWalkRec p f n = do
  x <- f (n-1)
  b <- bernoulli p
  let dx = if b then 1 else -1
  return $ x + dx

randomWalk
  :: (MonadSplit g m, RandomGen g, MonadFix m, Functor m) =>
     Double -> m (Int -> Int)
randomWalk p = mfix $ memIntS . f
  where f :: RandomGen g => (Int -> Int) -> (Int -> Rand g Int)
        f = (randomWalkRec p) . (return .)

dpRandomWalk :: forall g n m f.
  (MonadEval g n, MonadRandom n, MonadSplit g m, RandomGen g,
    Applicative n, MonadFix m, Functor m) =>
   Double -> Double -> m (Int -> n Int)
dpRandomWalk alpha p = mfix $ (dpMemInt alpha) . (randomWalkRec p)

dpRandomWalkIO alpha p = (evalRandIO .) <$> dpRandomWalk alpha p


{-# LANGUAGE TemplateHaskell #-}

import Test.QuickCheck
import System.Exit
import Data.Complex as C
import FFT

-- Helpers

allClose :: (Ord a, Fractional a) => [a] -> [a] -> Bool
allClose xs ys = and $ fmap (\diff -> diff < 1e-4) diffs
  where
    diffs = [abs $ x - y | (x,y) <- zip xs ys]

allCloseComplex :: (RealFloat a) => [Complex a] -> [Complex a] -> Bool
allCloseComplex xs ys = and $ fmap (\diff -> diff < 1e-4) diffs
  where
    diffs = [C.magnitude $ x - y | (x,y) <- zip xs ys]

-- Properties

prop_dftInverse :: [Complex Double] -> Bool
prop_dftInverse xs = allCloseComplex xs $ idft (dft xs)

prop_rdftInverse :: [Double] -> Bool
prop_rdftInverse xs = allClose xs $ irdft (rdft xs)

prop_fftInverse :: [Complex Double] -> Bool
prop_fftInverse xs = allCloseComplex xs $ ifft (fft xs)

prop_rfftInverse :: [Double] -> Bool
prop_rfftInverse xs = allClose xs $ irfft (rfft xs)

prop_fft :: [Complex Double] -> Bool
prop_fft xs = allCloseComplex (fft xs) (dft xs)

prop_rfft :: [Double] -> Bool
prop_rfft xs = allCloseComplex (rfft xs) (rdft xs)

-- https://hackage.haskell.org/package/QuickCheck-2.13.2/docs/Test-QuickCheck-All.html
return []
runTests :: IO Bool
runTests = $quickCheckAll

main :: IO ()
main = do
  success <- and <$> sequence [runTests]
  if success then exitSuccess else exitFailure


{-|
Module: MachineLearning.Optimization.MinibatchGradientDescent
Description: Gradient Descent
Copyright: (c) Alexander Ignatyev, 2017
License: BSD-3
Stability: experimental
Portability: POSIX

Minibatch Gradient Descent
-}

module MachineLearning.Optimization.MinibatchGradientDescent
(
  minibatchGradientDescent
)

where

import MachineLearning.Types (R, Vector, Matrix)
import MachineLearning.Regularization (Regularization)
import qualified Data.Vector.Storable as V
import qualified Numeric.LinearAlgebra as LA
import Numeric.LinearAlgebra ((?))
import qualified Control.Monad.Random as RndM

import qualified MachineLearning.Model as Model

-- | Minibatch Gradient Descent method implementation. See "MachineLearning.Regression" for usage details.
minibatchGradientDescent :: Model.Model a
                            => Int              -- ^ seed
                            -> Int              -- ^ batch size
                            -> R                -- ^ learning rate, alpha
                            -> a                -- ^ model to learn
                            -> R                -- ^ epsilon
                            -> Int              -- ^ max number of iters
                            -> Regularization   -- ^ regularization parameter, lambda
                            -> Matrix           -- ^ matrix of features, X
                            -> Vector           -- ^ output vector, y
                            -> Vector           -- ^ vector of initial weights, theta or w
                            -> (Vector, Matrix) -- ^ vector of weights and learning path
minibatchGradientDescent seed batchSize alpha model eps maxIters lambda x y theta =
  RndM.evalRand (minibatchGradientDescentM batchSize alpha model eps maxIters lambda x y theta) gen
  where gen = RndM.mkStdGen seed

-- | Minibatch Gradient Descent method implementation. See "MachineLearning.Regression" for usage details.
minibatchGradientDescentM :: (Model.Model a, RndM.RandomGen g)
                             => Int              -- ^ batch size
                             -> R                -- ^ learning rate, alpha
                             -> a                -- ^ model to learn
                             -> R                -- ^ epsilon
                             -> Int              -- ^ max number of iters
                             -> Regularization   -- ^ regularization parameter, lambda
                             -> Matrix           -- ^ matrix of features, X
                             -> Vector           -- ^ output vector, y
                             -> Vector           -- ^ vector of initial weights, theta or w
                             -> RndM.Rand g (Vector, Matrix) -- ^ vector of weights and learning path
minibatchGradientDescentM batchSize alpha model eps maxIters lambda x y theta = do
  idxList <- RndM.getRandomRs (0, (LA.rows x) - 1)
  let gradient = Model.gradient model lambda
      cost = Model.cost model lambda
      helper theta nIters optPath =
          let idx = take batchSize idxList
              x' = x ? idx
              y' = LA.flatten $ (LA.asColumn y) ? idx
              theta' = theta - (LA.scale alpha (gradient x' y' theta))
              j = cost x' y' theta'
              gradientTest = LA.norm_2 (theta' - theta) < eps
              optPathRow = V.concat [LA.vector [(fromIntegral $ maxIters - nIters), j], theta']
              optPath' = optPathRow : optPath
          in if gradientTest || nIters <= 1
             then (theta, LA.fromRows $ reverse optPath')
             else helper theta' (nIters - 1) optPath'
  return $ helper theta maxIters []


module KAB where

import Control.Applicative
import Control.Monad
import Statistics.Distribution (genContVar)
import Statistics.Distribution.Normal (normalDistr)
import Statistics.Distribution.Uniform (uniformDistr)
import System.Random.MWC (withSystemRandom, GenIO)

testComp = "."

normalDist = normalDistr 0 1
uniformDist = uniformDistr 0 1

numActions = 10

runLength = 10000

alpha = 0.1
epsilon = 0.1

valueBias = 0.0

type ActionMeans = [Double]

sampleNormal :: IO Double
sampleNormal = withSystemRandom (genContVar normalDist :: (GenIO -> IO Double))

actionMeans :: IO ActionMeans
actionMeans = replicateM numActions sampleNormal

sampleValue :: Double -> IO Double
sampleValue v = fmap (+ v) sampleNormal

sampleNonstationaryStep :: IO Double
sampleNonstationaryStep = fmap (/ 100) sampleNormal

stepValues :: [Double] -> IO [Double]
stepValues values = sequenceA $ fmap takeStep values
  where
    takeStep val = do
      step <- sampleNonstationaryStep
      return $ val + step

--progress :: [Double] -> Int -> IO (Double, [Double])
--progress values move = (,) <$> (sampleValue $ values !! move) <*> (stepActions values <$> (replicateM numActions sampleNonstationaryStep))

type SampleAverageStats = [(Double, Int)]

type AlphaValEstimates = [Double]

getReward :: ActionMeans -> Int -> IO Double
getReward means actionNum =
  if (length means <= actionNum)
    then error $ "getReward: index " ++ (show actionNum) ++" is too large for list of length " ++ (show $ length means)
    else ((+) (means !! actionNum)) <$> sampleNormal

observeSA :: SampleAverageStats -> Int -> Double -> SampleAverageStats
observeSA oldStats actionNum latestSample =
  if (length oldStats <= actionNum)
    then error $ "action number " ++ (show actionNum) ++ " does not exist in the list " ++ (show oldStats)
    else let (avg, count) = (oldStats !! actionNum) in take actionNum oldStats ++ ((avg + ((latestSample - avg) / (fromIntegral $ count + 1)), count + 1) : (drop (actionNum + 1) oldStats))

observeAlp :: AlphaValEstimates -> Int -> Double -> AlphaValEstimates
observeAlp oldStats actionNum latestSample =
  if (length oldStats <= actionNum)
    then error $ "observeAlp does not contain index " ++ (show actionNum)
    else let oldAvg = (oldStats !! actionNum) in take actionNum oldStats ++ (oldAvg + (alpha * (latestSample - oldAvg)) : (drop (actionNum + 1) oldStats))

argmax :: Ord b => (a -> b) -> [a] -> a
argmax f (a:as) = go a (f a) as
  where
    go amx _ [] = amx
    go amx maxSoFar (b:bs) = if (f b > maxSoFar)
      then go b (f b) bs
      else go amx maxSoFar bs

actGreedySA :: SampleAverageStats -> Int
actGreedySA stats = argmax (saValue stats) [0 .. (length stats - 1)]

actGreedyAlpha :: AlphaValEstimates -> Int
actGreedyAlpha stats = argmax ((!!) stats) [0 .. (length stats - 1)]

actEpsilonGreedy :: Int -> IO Int
actEpsilonGreedy greedyChoice = do
  randomSample <- withSystemRandom (genContVar uniformDist :: (GenIO -> IO Double))
  if (randomSample <= epsilon)
    then randomAction
    else return greedyChoice

randomAction :: IO Int
randomAction = do
  randomSample <- withSystemRandom (genContVar uniformDist :: (GenIO -> IO Double))
  return $ floor $ randomSample * (fromIntegral numActions)

saValue :: SampleAverageStats -> Int -> Double
saValue stats actionNum =
  if (length stats <= actionNum)
    then error "saValue index too large"
    else fst $ stats !! actionNum

initialValsAlp :: AlphaValEstimates
initialValsAlp = take numActions $ repeat valueBias

initialValsSA :: SampleAverageStats
initialValsSA = take numActions $ repeat (valueBias, 0)

initializeScenario :: IO (AlphaValEstimates, SampleAverageStats, ActionMeans)
initializeScenario = (,,) initialValsAlp initialValsSA <$> actionMeans

runScenario :: IO [[Double]]
runScenario = go runLength initialValsAlp initialValsSA =<< actionMeans
  where
    go :: Int -> AlphaValEstimates -> SampleAverageStats -> ActionMeans -> IO [[Double]]
    go 0 _ _ _ = return []
    go n alphaEsts averageEsts means = do
      --putStrLn $ "Time Remaining: " ++ (show n)

      alphaAction <- actEpsilonGreedy $ actGreedyAlpha alphaEsts
      alphaReward <- getReward means alphaAction

      saAction <- actEpsilonGreedy $ actGreedySA averageEsts
      saReward <- getReward means saAction

      newMeans <- stepValues means

      ((:) [alphaReward, saReward]) <$> (go (n - 1) (observeAlp alphaEsts alphaAction alphaReward) (observeSA averageEsts saAction saReward) newMeans)

average :: [[Double]] -> [Double]
average nums = fmap (flip (/) (fromIntegral $ length nums)) $ foldr (zipWith (+)) (head nums) (tail nums)

reportPerformance :: IO [Double]
reportPerformance = fmap average runScenario

f 0 = 0
f n = nextDown + alpha * (1 - nextDown)
  where
    nextDown = f (n - 1)


{-# LANGUAGE ViewPatterns, NoMonomorphismRestriction, FlexibleInstances #-}
module Math.Probably.LinearPDF where

import qualified Math.Probably.Student as S
import Numeric.LinearAlgebra

type PDF a = a->Double

instance Show (a->Double) where
    show f = error "Math.Prob.PDF: showing function"

instance Eq (a->Double) where
    f == g = error "Math.Prob.PDF: comparing functions!"

instance Num a => Num (a->Double) where
    f + g = \x-> f x + g x
    f * g = \x-> f x * g x
    f - g = \x-> f x - g x
    abs f = \x -> abs (f x)
    signum f = \x-> signum $ f x
    fromInteger = error $ "Math.Prob.PDF: frominteger on function"

uniform :: (Real a, Fractional a) => a-> a-> PDF a
uniform from to = \x-> if x>=from && x <=to
                               then realToFrac $ 1/(to-from )
                               else 0

--http://en.wikipedia.org/wiki/Normal_distribution
gauss :: (Real a, Floating a) => a-> a-> PDF a
gauss mean sd = \x->realToFrac $ recip(sd*sqrt(2*pi))*exp(-(x-mean)**2/(2*sd*sd))

gaussD :: Double -> Double-> PDF Double
gaussD mean sd = \x->recip(sd*sqrt(2*pi))*exp(-(x-mean)**2/(2*sd*sd))

gammafun = exp . S.gammaln

--http://en.wikipedia.org/wiki/Gamma_distribution
gammaD :: Double -> Double -> PDF Double
gammaD k theta x = x**(k-1)*(exp(-x/theta)/(theta**k*(exp (S.gammaln k))))

invGammaD :: Double -> Double -> PDF Double
invGammaD a b x =(b**a/gammafun a)*(1/x)**(a+1)*exp(-b/x)

logNormal m sd x = recip (x*sd*sqrt(2*pi)) * exp (negate $ square (log x - m) / (2*square sd))
    where square x = x*x

beta a b x = (recip $ S.beta a b) * x ** (a-1) * (1-x) ** (b-1)
{-# SPECIALIZE gauss :: Double -> Double-> PDF Double #-}

--this is a Prob. Mass function, not density.
binomial :: Int -> Double -> PDF Int
binomial n p k = realToFrac (choose  (toInteger n) (toInteger k)) * p^^k * (1-p)^^(n-k)

zipPdfs :: Num a => PDF a -> PDF b -> PDF (a,b)
zipPdfs fx fy (x,y) = fx x * fy y

mulPdf :: Num a => PDF a -> PDF a -> PDF a
mulPdf d1 d2 = \x -> (d1 x * d2 x)

--instance Num a => Num (PDF a) where

--http://blog.plover.com/math/choose.html
choose :: Integer -> Integer -> Integer
choose n 0 = 1
choose 0 k = 0
choose (n) (k) |  k > n `div` 2 = choose n (n-k)
               |  otherwise = (choose (n-1) (k-1)) * (n) `div` (k)

multiNormal :: Vector Double -> Matrix Double -> PDF (Vector Double)
multiNormal mu sigma =
  let k = realToFrac $ dim mu
      invSigma = inv sigma
      mat1 = head . head . toLists
  in \x-> recip ((2*pi)**(k/2) * sqrt(det sigma)) * exp (mat1 $ negate $ 0.5*(asRow $ x-mu) `multiply` invSigma `multiply` (asColumn $ x-mu) )

mu1 = 2 |> [0, 0::Double]
sig1 = (2><2)[1::Double, 0,
              0, 1]

tst = multiNormal mu1 sig1 mu1
tsta = inv sig1
tstb = det sig1
tstc = let mu = mu1
           sigma = sig1
           x = mu1
           invSigma = inv sigma
       in (asRow $ x-mu) `multiply` invSigma `multiply` (asColumn $ x-mu)