{-# LANGUAGE Rank2Types #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Numeric.LinearAlgebra.Packed.Tri
-- Copyright  : Copyright (c) 2010, Patrick Perry <patperry@gmail.com>
-- License    : BSD3
-- Maintainer : Patrick Perry <patperry@gmail.com>
-- Stability  : experimental
--
-- Triangular views of packed matrices.
--

module Numeric.LinearAlgebra.Packed.Tri (
    -- * Immutable interface

    -- ** Vector multiplication
    triMulVector,

    -- ** Vector solving
    triSolvVector,

    -- * Mutable interface
    triCreate,

    -- ** Vector multiplication
    triMulVectorM_,

    -- ** Vector solving
    triSolvVectorM_,

    ) where

import Control.Monad( when )
import Control.Monad.ST( ST, runST, unsafeIOToST )
import Text.Printf( printf )

import Numeric.LinearAlgebra.Vector( Vector, STVector )
import qualified Numeric.LinearAlgebra.Vector as V
import Numeric.LinearAlgebra.Packed.Base( Packed, RPacked, STPacked )
import qualified Numeric.LinearAlgebra.Packed.Base as P
import Numeric.LinearAlgebra.Types
import qualified Foreign.BLAS as BLAS

-- | A safe way to create and work with a mutable Tri Packed before returning
-- an immutable one for later perusal.
triCreate :: (Storable e)
          => (forall s. ST s (Tri (STPacked s) e))
          -> Tri Packed e
triCreate mt = runST $ do
    (Tri u d ma) <- mt
    a <- P.unsafeFreeze ma
    return $ Tri u d a

-- | @triMulVector trans a x@ returns @op(a) * x@, where @op(a)@ is
-- determined by @trans@.
triMulVector :: (BLAS2 e)
             => Trans
             -> Tri Packed e
             -> Vector e
             -> Vector e
triMulVector trans a x =
    V.create $ do
        x' <- V.newCopy x
        triMulVectorM_ trans a x'
        return x'

-- | @triMulVectorM_ a x@ sets @x := op(a) * x@, where @op(a)@ is determined
-- by @trans@.
triMulVectorM_ :: (RPacked p, BLAS2 e)
               => Trans -> Tri p e
               -> STVector s e
               -> ST s ()
triMulVectorM_ trans (Tri uplo diag a) x = do
    na <- P.getDim a
    nx <- V.getDim x
    let n = nx

    when (nx /= n) $ error $
        printf ("triMulVectorM_"
                ++ " _"
                ++ " (Tri _ _ <packed matrix with dim %d>)"
                ++ " <vector with dim %d>"
                ++ ": dimension mismatch")
               na
               nx

    unsafeIOToST $
        P.unsafeWith a $ \pa ->
        V.unsafeWith x $ \px ->
            BLAS.tpmv uplo trans diag n pa px 1

-- | @triSolvVector trans a x@ returns @op(a) \\ x@, where @op(a)@ is
-- determined by @trans@.
triSolvVector :: (BLAS2 e)
             => Trans
             -> Tri Packed e
             -> Vector e
             -> Vector e
triSolvVector trans a x =
    V.create $ do
        x' <- V.newCopy x
        triSolvVectorM_ trans a x'
        return x'

-- | @triSolvVectorM_ a x@ sets @x := op(a) \\ x@, where @op(a)@ is determined
-- by @trans@.
triSolvVectorM_ :: (RPacked p, BLAS2 e)
               => Trans -> Tri p e
               -> STVector s e
               -> ST s ()
triSolvVectorM_ trans (Tri uplo diag a) x = do
    na <- P.getDim a
    nx <- V.getDim x
    let n = nx

    when (nx /= n) $ error $
        printf ("triMulVectorM_"
                ++ " _"
                ++ " (Tri _ _ <packed matrix with dim %d>)"
                ++ " <vector with dim %d>"
                ++ ": dimension mismatch")
               na
               nx

    unsafeIOToST $
        P.unsafeWith a $ \pa ->
        V.unsafeWith x $ \px ->
            BLAS.tpsv uplo trans diag n pa px 1


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Statistics.BBVI.Distribution.Dirichlet
  ( alphas
  , dirichlet
  , Dirichlet(..)
  )
where

import qualified Data.Vector                   as V
import           Numeric.SpecFunctions          ( logGamma
                                                , digamma
                                                )
import           Statistics.BBVI.Class
import           Statistics.BBVI.Propagator     ( SampleVector )
import qualified System.Random.MWC.Distributions
                                               as MWCD

-- | data type for a dirichlet distribution
newtype Dirichlet = Diri (V.Vector Double) deriving (Show, Eq, Ord, Read)

-- | build a dirichlet
dirichlet
  :: V.Vector Double -- ^ vector of parameters
  -> Dirichlet
dirichlet xs = Diri $ V.map (max 1e-10) xs

-- | get dirichlet parameters
alphas :: Dirichlet -> V.Vector Double -- ^ dirichlet parameters
alphas (Diri xs) = xs

logB :: Dirichlet -> Double
logB d = V.sum (V.map logGamma as) - logGamma (V.sum as) where as = alphas d

instance DistUtil Dirichlet where
  nParams         = V.length . alphas
  fromParamVector = dirichlet
  toParamVector   = alphas

instance Dist Dirichlet SampleVector where
  resample d gen = MWCD.dirichlet (alphas d) gen
  logProb d cat = V.sum (V.zipWith (\alpha x -> (alpha - 1) * log x) as cat)
    - logB d
    where as = alphas d
  paramGradOfLogQ d cat = V.zipWith (\a x -> summed - digamma a + log x) as cat
   where
    as     = alphas d
    summed = digamma (V.sum as)


{-# LANGUAGE FlexibleInstances,
             DeriveDataTypeable #-}

module XAlg.Languages.Arithmetic.Number where

import XAlg.Foundation.Core

import Prelude hiding               (Float, Int)
import qualified  Data.Complex as C (Complex)
import Data.Complex          hiding (Complex)
import Data.Data

type Z = Integer
type R = Double
type C = C.Complex Double

deriving instance Ord (C.Complex Double)

data Number = Real R
            | Int Z
            | Complex C
            deriving (Eq, Ord, Data)

instance Show Number where
  show (Real r) = show r
  show (Int z) = show z
  show (Complex c) = show c

instance Z <: R where
  incl = fromInteger

instance Z <: C where
  incl = fromInteger

instance R <: C where
  incl = (0 :+)

compat :: (Number,Number) -> (Number,Number)
compat p@(Int n,Int m)          = p
compat   (Int n,r@(Real _))     = (Real (incl n),r)
compat   (Int n,c@(Complex _))  = (Complex (incl n),c)
compat   (Real n,Int m)         = (Real n, Real (incl m))
compat p@(Real _,Real _)        = p
compat   (Real n,c@(Complex _)) = (Complex (incl n),c)
compat p@(Complex _,Complex _)  = p
compat   (Complex n, Int m)     = (Complex n, Complex (incl m))
compat   (Complex n, Real m)    = (Complex n, Complex (incl m))

caseFun :: (Z -> Z) -> (R -> R) -> (C -> C) -> Number -> Number
caseFun zf rf cf (Real n)    = Real $ rf n
caseFun zf rf cf (Int n)     = Int $ zf n
caseFun zf rf cf (Complex n) = Complex $ cf n

caseFun2 :: (Z -> Z -> Z) -> (R -> R -> R) -> (C -> C -> C) -> Number -> Number -> Number
caseFun2 zf rf cf (Real n)    (Real m)    = Real $ rf n m
caseFun2 zf rf cf (Real n)    (Int m)     = Real $ rf n (incl m)
caseFun2 zf rf cf (Real n)    (Complex m) = Complex $ cf (incl n) m
caseFun2 zf rf cf (Int n)     (Real m)    = Real $ rf (incl n) m
caseFun2 zf rf cf (Int n)     (Int m)     = Int $ zf n m
caseFun2 zf rf cf (Int n)     (Complex m) = Complex $ cf (incl n) m
caseFun2 zf rf cf (Complex n) (Real m)    = Complex $ cf n (incl m)
caseFun2 zf rf cf (Complex n) (Int m)     = Complex $ cf n (incl m)
caseFun2 zf rf cf (Complex n) (Complex m) = Complex $ cf n m

instance Num Number where
  fromInteger = Int
  (+) = caseFun2 (+) (+) (+)
  (-) = caseFun2 (-) (-) (-)
  (*) = caseFun2 (*) (*) (*)
  abs = caseFun abs abs abs
  signum = caseFun signum signum signum

instance Fractional Number where
  (/) (Int x) (Int y) = Real $ fromInteger x / fromInteger y
  (/) x y = uncurry (/) . compat $ (x,y)
  recip (Int x) = Real . recip . fromInteger $ x
  recip x = caseFun undefined recip recip x
  fromRational = Real . fromRational

instance Floating Number where
  pi = Real pi
  exp (Int z) = Real $ exp $ fromInteger z
  exp (Real r) = Real $ exp r
  exp (Complex c) = Complex $ exp c
  log (Int z) = Real $ log $ fromInteger z
  log (Real r) = Real $ log r
  log (Complex c) = Complex $ log c
  sin (Int z) = Real $ sin $ fromInteger z
  sin (Real r) = Real $ sin r
  sin (Complex c) = Complex $ sin c
  cos (Int z) = Real $ cos $ fromInteger z
  cos (Real r) = Real $ cos r
  cos (Complex c) = Complex $ cos c
  asin (Int z) = Real $ asin $ fromInteger z
  asin (Real r) = Real $ asin r
  asin (Complex c) = Complex $ asin c
  acos (Int z) = Real $ acos $ fromInteger z
  acos (Real r) = Real $ acos r
  acos (Complex c) = Complex $ acos c
  atan (Int z) = Real $ atan $ fromInteger z
  atan (Real r) = Real $ atan r
  atan (Complex c) = Complex $ atan c
  sinh (Int z) = Real $ sinh $ fromInteger z
  sinh (Real r) = Real $ sinh r
  sinh (Complex c) = Complex $ sinh c
  cosh (Int z) = Real $ cosh $ fromInteger z
  cosh (Real r) = Real $ cosh r
  cosh (Complex c) = Complex $ cosh c
  asinh (Int z) = Real $ asinh $ fromInteger z
  asinh (Real r) = Real $ asinh r
  asinh (Complex c) = Complex $ asinh c
  acosh (Int z) = Real $ acosh $ fromInteger z
  acosh (Real r) = Real $ acosh r
  acosh (Complex c) = Complex $ acosh c
  atanh (Int z) = Real $ atanh $ fromInteger z
  atanh (Real r) = Real $ atanh r
  atanh (Complex c) = Complex $ atanh c


module Permutation where

import Rotation (MatrixRotation, identity)
import qualified Rotation as Rotation

import qualified Numeric.LinearAlgebra as LA

type N = Integer

toNumbers :: MatrixRotation -> [N]
toNumbers = map (go 0 . LA.toList) . LA.toColumns
  where
    go n [] = n
    go n (f:fs)
      | f /= 0 = n
      | otherwise = go (n + 1) fs

facs :: [N]
facs =
  let n = 9 * 6
  in map fac [n - 1, n - 2 .. 0]
  where
    fac 0 = 1
    fac n = n * fac (n - 1)

multiplierMappings :: [N -> N]
multiplierMappings = map mappingFor [0..]
  where
    mappingFor :: Integer -> Integer -> Integer
    mappingFor n m
      | n == m = 0
      | n < m = m
      | otherwise = m + 1

fromRotation :: MatrixRotation -> N
fromRotation = sum . zipWith3 go facs multiplierMappings . toNumbers
  where
    go fac multiplierMapping n = fac * multiplierMapping n

-- toRotation :: N -> MatrixRotation
toRotation = go facs
  where
    go [] _ = []
    go (f:fs) n
      | n >= f =
        let (d, r) = n `divMod` f
        in d : go fs r
      | otherwise = 0 : go fs n


-----------------------------------------------------------------------------
-- |
-- Module     : Numeric.LinearAlgebra.Vector.ST
-- Copyright  : Copyright (c) , Patrick Perry <patperry@gmail.com>
-- License    : BSD3
-- Maintainer : Patrick Perry <patperry@gmail.com>
-- Stability  : experimental
--
-- Mutable vectors in the ST monad.

module Numeric.LinearAlgebra.Vector.ST (
    -- * Mutable vectors
    STVector,
    IOVector,
    create,

    -- * Read-only vectors
    RVector(..),

    -- * Creating new vectors
    new_,
    new,

    -- * Copying vectors
    newCopy,
    copyTo,
    swap,

    -- * Reading and writing vector elements
    read,
    write,
    modify,
    getIndices,
    getElems,
    getElems',
    getAssocs,
    getAssocs',
    setElems,
    setAssocs,
    clear,

    -- * List-like operations
    mapTo,
    zipWithTo,

    -- * Vector linear algebra
    getSumAbs,
    getNorm2,
    getWhichMaxAbs,
    getDot,
    scaleM_,
    addWithScaleM_,
    kroneckerTo,

    -- * Vector views
    withSlice,
    withDrop,
    withTake,
    withSplitAt,

    withSliceM,
    withDropM,
    withTakeM,
    withSplitAtM,

    -- * Vector math operations
    -- ** Num
    addTo,
    subTo,
    mulTo,
    negateTo,
    conjugateTo,
    absTo,
    signumTo,

    -- ** Fractional
    divTo,
    recipTo,

    -- ** Floating
    sqrtTo,
    expTo,
    logTo,
    powTo,
    sinTo,
    cosTo,
    tanTo,
    asinTo,
    acosTo,
    atanTo,
    sinhTo,
    coshTo,
    tanhTo,
    asinhTo,
    acoshTo,
    atanhTo,

    -- * Conversions between mutable and immutable vectors
    freeze,

    -- * Unsafe operations
    unsafeCopyTo,
    unsafeSwap,
    unsafeRead,
    unsafeWrite,
    unsafeModify,
    unsafeMapTo,
    unsafeZipWithTo,
    unsafeAddWithScaleM_,
    unsafeGetDot,

    ) where

import Prelude()
import Numeric.LinearAlgebra.Vector.STBase


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module HLearn.Models.Distributions.Univariate.Binomial
    where

import HLearn.Algebra
import HLearn.Models.Distributions.Common
import HLearn.Models.Distributions.Univariate.Internal.Moments
import HLearn.Models.Distributions.Visualization.Gnuplot

import qualified Statistics.Distribution as S
import Statistics.Distribution.Binomial

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

newtype Binomial sample prob = Binomial {  bmoments :: (Moments3 sample) }
    deriving (Read,Show,Eq,Ord,Monoid,Group)

-------------------------------------------------------------------------------
-- Training

instance (Num sample) => HomTrainer (Binomial sample prob) where
    type Datapoint (Binomial sample prob) = sample
    train1dp dp = Binomial $ train1dp dp

-------------------------------------------------------------------------------
-- distribution

instance (Num sample) => Probabilistic (Binomial sample prob) where
    type Probability (Binomial sample prob) = prob

instance (Floating prob) => PDF (Binomial Int Double) where
    pdf (Binomial dist) dp = S.probability (binomial n p) dp
        where
            n = bin_n $ Binomial dist
            p = bin_p $ Binomial dist

bin_n :: Binomial Int Double -> Int
bin_n (Binomial dist) = round $ ((fromIntegral $ m1 dist :: Double) / (fromIntegral $ m0 dist)) / (bin_p $ Binomial dist)

bin_p :: Binomial Int Double -> Double
bin_p (Binomial dist) = ((fromIntegral $ m1 dist) / (fromIntegral $ m0 dist)) + 1 - (fromIntegral $ m2 dist)/(fromIntegral $ m1 dist)

instance
    ( PDF (Binomial sample prob)
--     , PlottableDataPoint sample
    , Show prob
    , Show sample
    , Ord sample
    , Ord prob
    , Num prob
    , Integral sample
    ) => PlottableDistribution (Binomial sample prob)
-- instance PlottableDistribution (Poisson Int Double)
        where

    plotType _ = Points

    samplePoints dist = [min..max]
        where
            min = 0
            max = maximum [20,floor $ 3*mu]
            mu = 5

-- instance (Fractional prob) => Mean (Binomial prob) where
--     mean (Binomial dist) =
--
-- instance (Fractional prob) => Variance (Binomiral prob) where
--     variance dist = mean dist


import Data.Word
import Data.List(elemIndex)
import Data.Maybe
import Data.Complex
import qualified Data.Array.Repa as R
import Data.Array.Repa.IO.BMP
import System.Environment

type Number = Double
type ComplexNumber = Complex Number
type IterationCount = Integer
type PointData = (ComplexNumber, IterationCount)
type RootData = (Int, IterationCount)
type Bounds = (Number, Number, Number, Number)
type Step = Number
type Color = (Word8, Word8, Word8)

e :: ComplexNumber
e = (exp 1) :+ 0

data Function = Constant ComplexNumber
              | Z
              | Sum Function Function
              | Product Function Function
              | Quotient Function Function
              | Power ComplexNumber Function
              | Sin Function
              | Cos Function
              | Exponential ComplexNumber Function
              | Log ComplexNumber Function
              | Undefined
              | Indeterminate
              deriving (Show)

realConstant :: Number -> Function
realConstant n = Constant (n :+ 0)

derivative :: Function -> Function
derivative (Constant _) = realConstant 0
derivative Z = realConstant 1
derivative (Sum u v) = Sum (derivative u) (derivative v)
derivative (Product u v) = Sum (Product (derivative u) v) (Product u (derivative v))
derivative (Quotient u v) = (Quotient (Sum (Product v (derivative u)) (Product (Product (realConstant (-1)) u) (derivative v))) (Power 2 v))
derivative (Power p f) = Product (Product (Constant p) (Power (p - 1) f)) (derivative f)
derivative (Sin f) = Product (Cos f) (derivative f)
derivative (Cos f) = Product (Product (realConstant (-1)) (Sin f)) (derivative f)
derivative (Exponential b f) = Product (Product (Exponential b f) (Log e (Constant b))) (derivative f)
derivative (Log b f) = Quotient (derivative f) (Product f (Log e (Constant b)))
derivative Undefined = Undefined
derivative Indeterminate = Indeterminate

evaluate :: Function -> ComplexNumber -> ComplexNumber
evaluate (Constant a) z = a
evaluate Z z = z
evaluate (Sum u v) z = (evaluate u z) + (evaluate v z)
evaluate (Product u v) z = (evaluate u z) * (evaluate v z)
evaluate (Quotient u v) z = (evaluate u z) / (evaluate v z)
evaluate (Power p f) z = (evaluate f z) ** p
evaluate (Sin f) z = sin (evaluate f z)
evaluate (Cos f) z = cos (evaluate f z)
evaluate (Exponential b f) z = b ** (evaluate f z)
evaluate (Log b f) z = logBase b (evaluate f z)
evaluate Undefined z = undefined
evaluate Indeterminate z = undefined

maxIterations :: IterationCount
maxIterations = 100

epsilon :: Number
epsilon = 1e-12

newton :: Function -> Function -> ComplexNumber -> PointData
newton f f' z0 = newton' z1 z0 0
    where approximate z = z - (evaluate f z) / (evaluate f' z)
          z1 = approximate z0
          newton' current previous n
              | n > maxIterations = (current, n)
              | magnitude (current - previous) < epsilon = (current, n)
              | otherwise = newton' (approximate current) current (n + 1)

windowApply :: (ComplexNumber -> PointData) -> Bounds -> Step -> [PointData]
windowApply f (top, left, bottom, right) step = [f (x :+ y ) | y <- ys, x <- xs]
    where xs = [left, left + step .. right]
          ys = [top, top + step .. bottom]

approximateIndex :: ComplexNumber -> [ComplexNumber] -> Maybe Int
approximateIndex z zs = elemIndex True [magnitude (z - zi) < epsilon * 2 | zi <- zs]

closestIndex :: ComplexNumber -> [ComplexNumber] -> Int
closestIndex z zs = snd . minimum $ zip [magnitude (z - zi) | zi <- zs] [0..]

closeEnough :: ComplexNumber -> [ComplexNumber] -> Bool
closeEnough z zs = case approximateIndex z zs of
    Just _ -> True
    Nothing ->  False

roots :: [PointData] -> [ComplexNumber]
roots ps = foldr checkRoot [] zs
    where checkRoot z roots
              | z `closeEnough` roots = roots
              | otherwise = z:roots
          zs = fst . unzip $ ps

assignRoot :: [ComplexNumber] -> PointData -> RootData
assignRoot rs p@(z, i) = (closestIndex z rs, i)

colorRoot :: RootData -> Color
colorRoot (n, i) = (ra, ga, ba)
    where colors = [ (0, 0, 0)
                   , (255, 0, 0)
                   , (0, 255, 0)
                   , (0, 0, 255)
                   , (255, 255, 0)
                   , (255, 0, 255)
                   , (0, 255, 255)
                   , (255, 255, 255)
                   ]
          (r, g, b) = colors !! n
          ii = max i 1
          ra = fromIntegral . min 255  $ 4 * r `div` ii
          ga = fromIntegral . min 255  $ 4 * g `div` ii
          ba = fromIntegral . min 255  $ 4 * b `div` ii

colorRoots :: Function -> Bounds -> Step -> [Color]
colorRoots f bounds step = map colorRoot rds
    where ps = windowApply (newton f (derivative f)) bounds step
          rs = roots ps
          rds = map (assignRoot rs) ps

arrayify :: Int -> Int -> [Color] -> R.Array R.U R.DIM2 Color
arrayify width height =
    R.fromListUnboxed (R.Z R.:. height R.:. width :: R.DIM2)

f = Sum (Power 3 Z) (realConstant (-1))

main = do
    args <- getArgs
    let [fileName, stringTop, stringLeft, stringBottom, stringRight, stringStep] = args
        top = read stringTop
        left = read stringLeft
        bottom = read stringBottom
        right = read stringRight
        step = read stringStep
        width = floor ((right - left) / step) + 1
        height = floor ((bottom - top) / step) + 1
        colorList = colorRoots f (top, left, bottom, right) step
        colorArray = arrayify width height colorList
    writeImageToBMP fileName colorArray


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (c) Edward Kmett 2010-2014
-- License     :  BSD3
-- Maintainer  :  ekmett@gmail.com
-- Stability   :  experimental
-- Portability :  GHC only
--
-----------------------------------------------------------------------------

module Numeric.AD.Rank1.Newton
  (
  -- * Newton's Method (Forward)
    findZero
  , inverse
  , fixedPoint
  , extremum
  -- * Gradient Ascent/Descent (Kahn)
  , gradientDescent
  , gradientAscent
  ) where

import Prelude hiding (all, mapM)
import Data.Foldable (all)
import Data.Traversable
import Numeric.AD.Mode
import Numeric.AD.Rank1.Forward (Forward, diff, diff')
import Numeric.AD.Rank1.Kahn as Kahn (Kahn, gradWith')
import Numeric.AD.Internal.On

-- $setup
-- >>> import Data.Complex

-- | The 'findZero' function finds a zero of a scalar function using
-- Newton's method; its output is a stream of increasingly accurate
-- results.  (Modulo the usual caveats.) If the stream becomes constant
-- ("it converges"), no further elements are returned.
--
-- Examples:
--
-- >>> take 10 $ findZero (\x->x^2-4) 1
-- [1.0,2.5,2.05,2.000609756097561,2.0000000929222947,2.000000000000002,2.0]
--
-- >>> last $ take 10 $ findZero ((+1).(^2)) (1 :+ 1)
-- 0.0 :+ 1.0
findZero :: (Fractional a, Eq a) => (Forward a -> Forward a) -> a -> [a]
findZero f = go where
  go x = x : if x == xn then [] else go xn where
    (y,y') = diff' f x
    xn = x - y/y'
{-# INLINE findZero #-}

-- | The 'inverse' function inverts a scalar function using
-- Newton's method; its output is a stream of increasingly accurate
-- results.  (Modulo the usual caveats.) If the stream becomes
-- constant ("it converges"), no further elements are returned.
--
-- Example:
--
-- >>> last $ take 10 $ inverse sqrt 1 (sqrt 10)
-- 10.0
inverse :: (Fractional a, Eq a) => (Forward a -> Forward a) -> a -> a -> [a]
inverse f x0 y = findZero (\x -> f x - auto y) x0
{-# INLINE inverse  #-}

-- | The 'fixedPoint' function find a fixedpoint of a scalar
-- function using Newton's method; its output is a stream of
-- increasingly accurate results.  (Modulo the usual caveats.)
--
-- If the stream becomes constant ("it converges"), no further
-- elements are returned.
--
-- >>> last $ take 10 $ fixedPoint cos 1
-- 0.7390851332151607
fixedPoint :: (Fractional a, Eq a) => (Forward a -> Forward a) -> a -> [a]
fixedPoint f = findZero (\x -> f x - x)
{-# INLINE fixedPoint #-}

-- | The 'extremum' function finds an extremum of a scalar
-- function using Newton's method; produces a stream of increasingly
-- accurate results.  (Modulo the usual caveats.) If the stream
-- becomes constant ("it converges"), no further elements are returned.
--
-- >>> last $ take 10 $ extremum cos 1
-- 0.0
extremum :: (Fractional a, Eq a) => (On (Forward (Forward a)) -> On (Forward (Forward a))) -> a -> [a]
extremum f = findZero (diff (off . f . On))
{-# INLINE extremum #-}

-- | The 'gradientDescent' function performs a multivariate
-- optimization, based on the naive-gradient-descent in the file
-- @stalingrad\/examples\/flow-tests\/pre-saddle-1a.vlad@ from the
-- VLAD compiler Stalingrad sources.  Its output is a stream of
-- increasingly accurate results.  (Modulo the usual caveats.)
--
-- It uses reverse mode automatic differentiation to compute the gradient.
gradientDescent :: (Traversable f, Fractional a, Ord a) => (f (Kahn a) -> Kahn a) -> f a -> [f a]
gradientDescent f x0 = go x0 fx0 xgx0 0.1 (0 :: Int)
  where
    (fx0, xgx0) = Kahn.gradWith' (,) f x0
    go x fx xgx !eta !i
      | eta == 0     = [] -- step size is 0
      | fx1 > fx     = go x fx xgx (eta/2) 0 -- we stepped too far
      | zeroGrad xgx = [] -- gradient is 0
      | otherwise    = x1 : if i == 10
                            then go x1 fx1 xgx1 (eta*2) 0
                            else go x1 fx1 xgx1 eta (i+1)
      where
        zeroGrad = all (\(_,g) -> g == 0)
        x1 = fmap (\(xi,gxi) -> xi - eta * gxi) xgx
        (fx1, xgx1) = Kahn.gradWith' (,) f x1
{-# INLINE gradientDescent #-}

-- | Perform a gradient descent using reverse mode automatic differentiation to compute the gradient.
gradientAscent :: (Traversable f, Fractional a, Ord a) => (f (Kahn a) -> Kahn a) -> f a -> [f a]
gradientAscent f = gradientDescent (negate . f)
{-# INLINE gradientAscent #-}


{-# LANGUAGE ScopedTypeVariables #-}

module Isumi.Math.FFT.SpecUtil where

import Test.QuickCheck
import Data.Complex
import qualified Data.Vector.Unboxed as UV

newtype VectorOf2ExpSize = VectorOf2ExpSize (UV.Vector Double)

instance Show VectorOf2ExpSize where
  show (VectorOf2ExpSize v) = show v

instance Arbitrary VectorOf2ExpSize where
  arbitrary = do
    e :: Int <- choose (0, 10)
    let n = 2^e
    xs <- sequenceA (replicate n arbitrary)
    pure . VectorOf2ExpSize . UV.fromList $ xs

realVToComplexV :: UV.Vector Double -> UV.Vector (Complex Double)
realVToComplexV = UV.map (\x -> x :+ 0)


{-# LANGUAGE ScopedTypeVariables, TypeFamilies, TupleSections #-}

module Fuml.Supervised.Accuracy where

import Fuml.Core
import Numeric.LinearAlgebra
import Data.List (partition, transpose)

accuracy :: (Eq o) => [(Vector Double, o)] -> Predict p o -> Double
accuracy theData model =
  let isCorrect (v,y) = predict model v == y
      corrects = map isCorrect theData
  in realToFrac (length $ filter id corrects) / realToFrac (length corrects)

rmse :: [(Vector Double, Double)] -> Predict p Double -> Double
rmse theData model =
  let getDev (v,y) = let d = y - predict model v in d*d
      devs = map getDev theData
  in sqrt $ sum devs / realToFrac (length devs)

splitData :: Int -> Int -> [a] -> ([a], [a])
splitData nfolds fold xs
  = let xfs = zip xs (cycle $ [0..(nfolds-1)])
        (zins, zouts) = partition ((==fold) . snd) xfs
    in (map fst zins,map fst zouts)

crossValidate :: Monad m
               => Int
               -> [(Vector Double, o)]
               -> ( [(Vector Double, o)] -> Predict p o1 -> Double )
               -> Supervisor m o p o1
               -> Maybe Int
               -> m Double
crossValidate nfolds theData metric super (Just fold) =
  let (testD, trainD) = splitData nfolds fold theData
      fit = runSupervisor super Nothing trainD
  in fmap (metric testD) fit
crossValidate nfolds theData metric super Nothing =
  let folds = [0..(nfolds-1)]
      accs = mapM (crossValidate nfolds theData metric super . Just) folds
  in fmap avg accs

gridSearch  ::  Monad m
               => Int
               -> [(Vector Double, o)]
               -> ( [(Vector Double, o)] -> Predict p o1 -> Double )
               -> (hyper -> Supervisor m o p o1)
               -> [hyper]
               -> Maybe Int
               -> m [(hyper,Double)]
gridSearch nfolds theData metric hsuper hypers (Just fold) =
  let (testD, trainD) = splitData nfolds fold theData
      getAcc h = fmap ((h,) . metric testD) $ runSupervisor (hsuper h) Nothing $ trainD
  in mapM getAcc hypers
gridSearch nfolds theData metric hsuper hypers Nothing = do
  let folds = [0..(nfolds-1)]
  accs <- mapM (gridSearch nfolds theData metric hsuper hypers . Just) folds
  let f accs = (fst $ head accs, avg $ map snd accs)
  return $ map f $ transpose accs

avg xs = sum xs / realToFrac (length xs)


module HankelTransform where

import           Control.Parallel.Strategies
import           Data.Array.Repa                        as R
import           Data.Complex                           as C
import           Data.List                              as L
import           Data.Vector.Storable                   as VS
import           Data.Vector.Unboxed                    as VU
import           Graphics.Rendering.Chart.Backend.Cairo
import           Graphics.Rendering.Chart.Easy
import           Numeric.GSL.Special.Bessel
import           System.Directory
import           System.Environment
import           System.FilePath
import           Text.Printf
import           Utils.BLAS
import           Utils.List
import           Utils.Parallel

main = do
  args@(nStr:deltaXStr:deltaRStr:radiusXStr:radiusRStr:_) <- getArgs
  let n = read nStr :: Int
      deltaX = read deltaXStr :: Double
      deltaR = read deltaRStr :: Double
      radiusX = read radiusXStr :: Double
      radiusR = read radiusRStr :: Double
      folderPath = "output/test/HankelTransform"
  createDirectoryIfMissing True folderPath
  let numR = round $ radiusR / deltaR :: Int
      numX = round $ radiusX / deltaX :: Int
      func r =
        if r >= 1
          then 1 / r
          else 1 / r
      fr =
        parMap
          rdeepseq
          (\r -> func r * r)
          [fromIntegral r * deltaR | r <- [1 .. numR]]
      besselArrayR =
        fromFunction (Z :. numX :. numR) $ \(Z :. x :. r) ->
          deltaR *
          bessel_Jn
            (fromIntegral n)
            ((fromIntegral x + 1) * deltaX * (fromIntegral r + 1) * deltaR)
  besselArray <- computeUnboxedP besselArrayR
  let besselVec = VU.convert . toUnboxed $ besselArray
      frVec = VS.fromList fr
  xs <- VS.toList <$> gemmBLAS numX 1 numR besselVec frVec
  toFile def (folderPath </> "HankelTransform.png") $ do
    layout_title .=
      printf "N = %d RadiusR = %.2f RadiusX = %.2f" n radiusR radiusX
    plot (line "" [L.zip [fromIntegral i * deltaX | i <- [1 .. numX]] xs])


import           Control.DeepSeq
import           Data.Graph.Inductive
import           Data.Graph.Inductive.PatriciaTree as GP
import           GraphBuilder
import           InterpolationAlgorithms
import           Numeric.LinearAlgebra             (size)
import           Plots
import           System.Environment
import           System.Random                     (randomRIO)
import           Utils

main :: IO ()
main = do
  args <- getArgs
  file <- checkFile args
  let nbds = checkArgs args

  matrix' <- getReqMatrix file

  let (rsize,dims) = size matrix'

{-
The purpose of this algorithm is to find the Riemann normal
coordinates (a coordinate system permissible on Riemann manifolds) of
the tangent space at this point. This is built up by first finding the
K-nearest neighbors to this point, and then applying some linear
dimensionality reduction step to this collection of points (also
called a neighborhood). We perform principal component analysis,
however, other linear dimensionality reduction alogrithms are
permissible. The variable *BASEPOINT* is a randomly chosen point from
the dataset.
-}
  basePoint <- randomRIO (0,rsize-1)

  print $ "The base point is point " ++ show basePoint

{-
Find the M-nearest neighbors about each point (hereby referred to as
the "representative point" with respect to its neighbors) in the
dataset and determine the edges (their necessary existence and weight)
between each member of a neighorhood set and their shared
"representative" point as the Euclidean distance between the
representative point and every point in the neighborhood set.
-}

{-The variable *GCTX*, is a list of contexts for the graph. Essentially,
each context contains the nodes leaving and entering a given node. You
may wish to consult the FGL (Functional Graph Library) documentation
for more information. The variable *POINTS* is a list of the K nearest
neighbors from *BASEPOINT*, a randomnly chosen point in the
dataset. The variable *INDS* is a list of the indices of the points
contained in *POINTS*.
-}
  let (gctx,points,inds) = theContextsAndDists nbds basePoint matrix'

      -- Build the graph from the contexts *GCTX*!
      graph = force . foldr (joinContext . force) (empty :: GP.Gr Double Double) $ gctx

      -- Deterimne the sets of shortest distances from points *POINTS*
      graphShortDists = shortDistMat rsize $ shortestDists inds graph

      {- This matrix is used in the interpolation step for finding the Riemann
          normal coordinates. Please refer to the paper in the repository for
          more information.
          -}
      res = estimateGrad (snd nbds) (dims-1) points
      -- The Riemann normal coordinates.
      res' = riemannNormCoord res graphShortDists

  -- If the graph is connected, then perform and save the results of the analysis.
  if isConnected graph
     then plotAndSave2D' file rsize basePoint nbds res'
     else error "The graph is not connected."


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}

{-|
Module      : Numeric.Proximal.Static
Description : Solve proximal problems using FISTA
Copyright   : (c) Ryan Orendorff, 2020
License     : BSD3
Stability   : experimental
-}
module Numeric.Proximal.Static
    ( fista
    , fistaCost
    , indicatorBox
    , l1Cost
    , l1Prox
    , lsqLipschitz
    , proxIndicatorBox
    , quadraticLipschitz
    , residuals
    )
where

import           GHC.TypeLits
import           Numeric.LinearAlgebra.Static
import           Numeric.LinearAlgebra.Static.Util
import           Data.Maybe
import           Data.Tuple.HT                  ( fst3 )

------------------------------------------------------------------
--  Lipschitz calculations on actual matrixes by max eigenvalue --
------------------------------------------------------------------

-- TODO: Implement solution for extracting k largest eigenvalues directly.

-- Note that these are not particularly efficient as each eigenvalue must be extracted and then searched through to find the maximum.
-- | Find the Lipschitz constant for a least squares problem.
lsqLipschitz :: (KnownNat m, KnownNat n) => L m n -> Double
lsqLipschitz a = foldR1 max . eigenvalues $ mTm a

-- | Find the Lipschitz constant for a quadratic program.
quadraticLipschitz :: (KnownNat n) => Sym n -> Double
quadraticLipschitz = foldR1 max . eigenvalues

---------------------------------------------------------
--                  Proximal Functions                 --
---------------------------------------------------------

-- | Returns the cost function for the box indicator function.
-- I(l, u) = {0 if l < xᵢ < u ∀ xᵢ ∈ x
--            ∞ otherwise}
indicatorBox :: Double -> Double -> (forall n . KnownNat n => R n -> Double)
indicatorBox l u =
    foldR (\a b -> a + (if (b > u) || (b < l) then 1 / 0 else 0)) 0

-- | Proximal operator for the box indicator function
proxIndicatorBox :: Double -> Double -> (forall n . KnownNat n => R n -> R n)
proxIndicatorBox l u = dvmap bound
  where
    bound x = case (x < l, x > u) of
        (True, _   ) -> l
        (_   , True) -> u
        _            -> x

-- | Fast Iterative Soft Thresholding Algorithm
-- Used to solve problems of the form F(x) = f(x) + g(x), where
-- f is a smooth convex function with grad F being L-Lipschitz continuous and
-- g is a (potentially non-smooth) convex function. Common problems solved
-- with FISTA include min ||Ax - b|| st. x \in C or min ||Ax - b|| + ||x||_1
fista
    :: (KnownNat n)
    => (R n -> R n)    -- ^ gradient of f
    -> (R n -> R n)    -- ^ proximal operator of g
    -> Double          -- ^ Lipschitz constant
    -> Maybe (R n)     -- ^ Initial guess at a solution
    -> [R n]           -- ^ Output cost function and optimal solution over time
fista grad_f prox_g lipschitz (fromMaybe (konst 0) -> x0) = map fst3
    $ iterate go (x0, x0, 1)
  where
        -- Sometimes update is called p_L
    gradient_step = \x -> x - konst (1 / lipschitz) * grad_f x
    prox_step     = prox_g
    update        = prox_step . gradient_step

    -- Algorithm here
    go (x, y, t) =
        let
            x_update = update y
            t_update = (1 + sqrt (1 + 4 * t ^^ (2 :: Int))) / 2
            y_update =
                x_update + konst ((t - 1) / t_update) * (x_update - x)
        in
            (x_update, y_update, t_update)

-- | Residuals for a list of vectors.
residuals :: forall n . KnownNat n => [R n] -> [Double]
residuals x = zipWith (\y yn -> norm_2 (y - yn)) x (tail x)

-----------------------------------------------------------------
--                        Cost Functions                       --
-----------------------------------------------------------------

-- | Takes the most smooth convex function \(f\) and the convex (potentially
-- non-smooth) function \(g\) and calculates the cost of a given input.
fistaCost :: (R n -> Double) -> (R n -> Double) -> R n -> Double
fistaCost f g x = f x + g x

-- | Cost function for an ℓ₁ term
l1Cost :: (KnownNat n) => Double -> R n -> Double
l1Cost lambda = (lambda *) . norm_1

-- | Proximal equation a the ℓ₁ term
l1Prox :: (KnownNat n) => Double -> R n -> R n
l1Prox lambda = dvmap f where f xi = signum xi * max (abs xi - lambda) 0


-- |
-- Module    : Statistics.Resampling.Bootstrap
-- Copyright : (c) 2009, 2011 Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- The bootstrap method for statistical inference.

module Statistics.Resampling.Bootstrap
    ( bootstrapBCA
    -- * References
    -- $references
    ) where

import           Data.Vector.Generic ((!))
import qualified Data.Vector.Unboxed as U

import Statistics.Distribution (cumulative, quantile)
import Statistics.Distribution.Normal
import Statistics.Resampling (Bootstrap(..), jackknife)
import Statistics.Sample (mean)
import Statistics.Types (Sample, CL, Estimate, ConfInt, estimateFromInterval,
                         estimateFromErr, CL, significanceLevel)
import qualified Statistics.Resampling as R

data T = {-# UNPACK #-} !Double :< {-# UNPACK #-} !Double
infixl 2 :<

-- | Bias-corrected accelerated (BCA) bootstrap. This adjusts for both
--   bias and skewness in the resampled distribution.
--
--   BCA algorithm is described in ch. 5 of Davison, Hinkley "Confidence
--   intervals" in section 5.3 "Percentile method"
bootstrapBCA
  :: CL Double       -- ^ Confidence level
  -> Sample          -- ^ Full data sample
  -> [(R.Estimator, Bootstrap U.Vector Double)]
  -- ^ Estimates obtained from resampled data and estimator used for
  --   this.
  -> [Estimate ConfInt Double]
bootstrapBCA confidenceLevel sample resampledData
  = map e resampledData
  where
    e (est, Bootstrap pt resample)
      | U.length sample == 1 || isInfinite bias =
          estimateFromErr      pt (0,0) confidenceLevel
      | otherwise =
          estimateFromInterval pt (resample ! lo, resample ! hi) confidenceLevel
      where
        -- Quantile estimates for given CL
        lo    = max (cumn a1) 0
          where a1 = bias + b1 / (1 - accel * b1)
                b1 = bias + z1
        hi    = min (cumn a2) (ni - 1)
          where a2 = bias + b2 / (1 - accel * b2)
                b2 = bias - z1
        -- Number of resamples
        ni    = U.length resample
        n     = fromIntegral ni
        -- Corrections
        z1    = quantile standard (significanceLevel confidenceLevel / 2)
        cumn  = round . (*n) . cumulative standard
        bias  = quantile standard (probN / n)
          where probN = fromIntegral . U.length . U.filter (<pt) $ resample
        accel = sumCubes / (6 * (sumSquares ** 1.5))
          where (sumSquares :< sumCubes) = U.foldl' f (0 :< 0) jack
                f (s :< c) j = s + d2 :< c + d2 * d
                    where d  = jackMean - j
                          d2 = d * d
                jackMean     = mean jack
        jack  = jackknife est sample

-- $references
--
-- * Davison, A.C; Hinkley, D.V. (1997) Bootstrap methods and their
--   application. <http://statwww.epfl.ch/davison/BMA/>


{-# LANGUAGE Rank2Types          #-}
{-# LANGUAGE TypeOperators       #-}

import Numeric.FAD
import Data.Complex
import Test.QuickCheck
import Data.Function (on)
import List.Util (zipWithDefaults, indexDefault)

-- Test only once, useful for properties with no parameters (could use
-- HUnit for such tests instead.)
onceCheck = quickCheckWith stdArgs { maxSuccess = 1 }

-- | Comparison allowing for inaccuracy.  Not transitive.

nearbyAbsolute accuracy x1 x2 = abs (x1 - x2) < accuracy
nearbyRelative accuracy x1 x2 = abs (x1 - x2) < accuracy * maximum (map abs [x1,x2])
nearbyHybrid   accuracy x1 x2 = abs (x1 - x2) < accuracy * maximum (map abs [x1,x2,1])

(~=) :: (Fractional t, Ord t) => t -> t -> Bool
(~=) = nearbyHybrid 1.0e-10
infix 4 ~=

(~~=) :: (Fractional t, Ord t) => [t] -> [t] -> Bool
(~~=) = ((.).(.)) and $ zipWithDefaults (~=) notNumber notNumber
    where notNumber = 0/0
infix 4 ~~=

-- Type signatures are supplied when QuickCheck is otherwise unable to
-- infer the type of the property's arguments.  An alternative way of
-- providing the type information would be, e.g.:
--
--   prop_constant_one x y = diffUU (\y -> lift x + y) y == (1 :: Double)
--

-- Nesting with @lift@ and @diffUU@ test cases.
prop_is1, prop_is2 :: Double -> Bool
prop_is1 x = diffUU (\x ->    diffUU ((lift x)*) 2)  x == 1
prop_is2 x = diffUU (\x -> x*(diffUU ((lift x)*) 2)) x == 2 * x

prop_constant_one :: Double -> Double -> Bool
prop_constant_one x y = diffUU (\y -> lift x + y) y == 1

-- @jacobian@ test cases.
prop_jacobian = jacobian (\xs -> [sum xs,
                                  product xs,
                                  log $ product $ map (sqrt . (^2) . exp) xs])
                [1..5] == [[1,1,1,1,1],
                           [120,60,40,30,24],
                           [1,1,1,1,1]]

-- @zeroNewton@ test cases.
prop_zeroNewton_1 = zeroNewton (\x->x^2-4) 1 !! 10 ~= 2
prop_zeroNewton_2 = zeroNewton ((+1).(^2)) (1 :+ 1) !! 10 == 0 :+ 1

-- @inverseNewton@ test case.
prop_inverseNewton = inverseNewton sqrt 1 (sqrt 10) !! 10 == 10

-- @atan2@ test cases.
prop_atan2_shouldBeOne :: Double -> Bool
prop_atan2_shouldBeOne a = diff (\a->atan2 (sin a) (cos a)) a ~= 1

-- @diffMF@ test cases.
prop_diffMF_1 = diffMF (\xs -> [sum (zipWith (*) xs [1..5])])
                [1,1,1,1,1] (map (10^) [0..4])
                == [54321]

prop_diffMF_2 = diffMF id [10..14] [0..4] == [0..4]

-- @diffMU@ test cases.
prop_diffMU_1 = diffMU (\xs -> sum (zipWith (*) xs [1..5]))
                [1,1,1,1,1] (map (10^) [0..4])
                == 54321

-- @diffsUU@ test cases.
prop_diffs_1 = (diffsUU (^5) 1) == [1,5,20,60,120,120]

prop_diffs_5 n =
    on (~~=) (take n)
           (map (2^) [0..])
           (diffsUU (exp . (2*)) 0)

-- @diffs0UU@ test cases:
prop_diffs_2 =
    on (==) (take 20)
           (diffs0UU (^5) 1)
           ([1,5,20,60,120,120] ++ repeat 0)

-- @diffsUF@ test cases:
prop_diffs_3 = (diffsUF ((:[]) . (^5)) 1) == [[1],[5],[20],[60],[120],[120]]

-- @diffs0UF@ test cases:
prop_diffs_4 =
    on (==) (take 20)
           (diffs0UF ((:[]) . (^5)) 1)
           ([[1],[5],[20],[60],[120],[120]] ++ repeat [0])

-- General routines for testing Taylor series accuracy

taylor_accurate :: (Ord a, Fractional a) =>
                   (forall tag. Tower tag a -> Tower tag a)
                       -> Int -> a -> a -> Bool

taylor_accurate f n x dx = s !!~ 0 ~= f0 x &&
                           s !!~ n ~= f0 (x+dx)
    where s = taylor f x dx
          f0 = primalUU f
          (!!~) = indexDefault Nothing

taylor_accurate_p :: (forall tag. Tower tag Double -> Tower tag Double) ->
                 Int -> Double -> Double -> Double -> Double -> Property

taylor_accurate_p f n dLo dHi x d =
    dLo <= d && d <= dHi ==> taylor_accurate f n x d

taylor2_accurate  :: (Ord a, Fractional a) =>
                  (forall tag0 tag.
                          Tower tag0 (Tower tag a)
                              -> Tower tag0 (Tower tag a)
                              -> Tower tag0 (Tower tag a))
                      -> Int -> Int -> a -> a -> a -> a -> Bool

taylor2_accurate f nx ny x y dx dy =
    let
        s2 = taylor2 f x y dx dy
        f2 x y = primal $ primal $ on f (lift . lift) x y
    in
      f2 x y ~= s2 !! 0 !! 0
            &&
      f2 (x+dx) (y+dy) ~= s2 !! nx !! ny

id_c c x = if x==c then c else x

-- Test all properties.
main = do
  quickCheck prop_is1
  quickCheck prop_is2
  quickCheck prop_constant_one
  onceCheck  prop_diffMF_1
  onceCheck  prop_diffMF_2
  onceCheck  prop_diffMU_1
  onceCheck  prop_jacobian
  onceCheck  prop_zeroNewton_1
  onceCheck  prop_zeroNewton_2
  onceCheck  prop_inverseNewton
  onceCheck prop_diffs_1
  onceCheck prop_diffs_2
  onceCheck prop_diffs_3
  onceCheck prop_diffs_4
  onceCheck  $ prop_diffs_5 1024
  -- (+)
  quickCheck $ \x -> taylor_accurate_p (+(lift x))         1 (-1e9) 1e9
  quickCheck $ \x -> taylor_accurate_p ((lift x)+)         1 (-1e9) 1e9
  -- (-)
  quickCheck $ \x -> taylor_accurate_p (flip (-) (lift x)) 1 (-1e9) 1e9
  quickCheck $ \x -> taylor_accurate_p ((lift x)-)         1 (-1e9) 1e9
  -- (*)
  quickCheck $ \x -> taylor_accurate_p (*(lift x))         1 (-1e9) 1e9
  quickCheck $ \x -> taylor_accurate_p ((lift x)*)         1 (-1e9) 1e9
  -- abs
  quickCheck $ taylor_accurate_p abs 1 (-1) 1e9 1
  quickCheck $ taylor_accurate_p abs 1 (-1e9) 1 (-1)
  -- recip
  quickCheck $ taylor_accurate_p recip 12 (-50) 50 200
  quickCheck $ taylor_accurate_p recip 12 (-50) 50 (-200)
  -- negate
  quickCheck $ taylor_accurate_p negate 1 (-1e9) 1e9
  -- pi
  onceCheck  $ diffs (const pi) 17 == [pi]
  -- exp
  quickCheck $ taylor_accurate_p exp 40 (-4) 4
  -- sqrt
  quickCheck $ taylor_accurate_p sqrt 10 (-1) 1 10
  -- log
  quickCheck $ taylor_accurate_p log 10 (-1) 1 (exp 2)
  -- (**)
  quickCheck $ taylor_accurate_p (**2.5) 12 (-0.5) 1 3
  quickCheck $ taylor_accurate_p (2.5**) 12 (-0.5) 1 3
  -- sin
  onceCheck  $ taylor_accurate   sin 40 0 (2*pi)
  quickCheck $ taylor_accurate_p sin 40 (-2.5*pi) (2.5*pi)
  -- cos
  onceCheck  $ taylor_accurate   cos 40 0 (2*pi)
  quickCheck $ taylor_accurate_p cos 40 (-2.5*pi) (2.5*pi)
  -- tan
  onceCheck  $ taylor_accurate tan 15 0 (pi/8)
  -- trig identity
  quickCheck $ taylor_accurate_p (\x -> sin x * cos x - sin (2*x) / 2) 10 (-5) 5
  -- asin
  quickCheck $ taylor_accurate_p (asin . sin) 10 (-0.9) (0.9) 0.1
  -- acos
  quickCheck $ taylor_accurate_p (acos . cos) 10 (-1) 1 (pi/3)
  -- atan
  quickCheck $ taylor_accurate_p (atan . tan) 10 (-1) 1 0.1
  -- sinh
  quickCheck $ taylor_accurate_p sinh 40 (-5) 5 0.1
  -- cosh
  quickCheck $ taylor_accurate_p cosh 40 (-5) 5 0.1
  -- tanh ?
  -- asinh
  onceCheck  $ taylor_accurate asinh 15 0.1 0.3
  -- acosh
  onceCheck  $ taylor_accurate acosh 15 2 0.2
  -- atanh
  onceCheck  $ taylor_accurate atanh 15 0.1 0.2
  -- atan2
  quickCheck $ prop_atan2_shouldBeOne
  onceCheck  $ prop_atan2_shouldBeOne (pi/2)
  -- (==)
  onceCheck  $ diffs (id_c 7) 3 == [3,1]
  onceCheck  $ diffs (id_c 7) 7 == [7]
  -- succ
  onceCheck  $ diffs succ 17 == [18,1]
  -- pred
  onceCheck  $ diffs pred 17 == [16,1]
  -- The [x..] construct
  onceCheck  $ diff (\x->[x]   !! 0) 7 == 1
  onceCheck  $ diff (\x->[x..] !! 0) 7 == 1
  onceCheck  $ diff (\x->[0,x..] !! 2) 7 == 2
  -- onceCheck  $ diffsUF (\x->[1,x..4.5]) 2 !! 0 == (\x->[1,x..4.5]) 2 -- BUG?


{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module CircSpec where

import Prelude hiding ((.))
import Test.QuickCheck.Classes
import Test.QuickCheck hiding (output)
import Test.Hspec
import Test.QuickCheck.Checkers

import ConCat.Circ

import ConCat.Category hiding (it)
import ConCat.Rep
import ConCat.Free.VectorSpace hiding (it)
import ConCat.Circuit
import ConCat.Misc
import Data.Complex

instance (Arbitrary a) => Arbitrary (RLC a) where
  arbitrary = oneof [Res <$> arbitrary, Cap <$> arbitrary, Ind <$> arbitrary]

spec = do
  describe "LCirc built out of the Circuit Category" $ do
    it "Rep is coherent" $ {--do
      a <- (arbs @RLC ) 10
      let
        vcheck :: RLC -> IO ()
        vcheck r = do
          print $ "actual: " <> (show r)
          print $ "repr: " <> (show $ repr r)
          print $ "abst . repr " <> (show $ (abst @ RLC) . repr $ r)
      mapM (vcheck) a--}
      property $ ((\(x :: (RLC (Complex R))) -> (abst . repr $ x) == x))
    it "Vectorspace instance is coherent" $ {--do
      a <- (arbs @RLC ) 10
      let
        vcheck :: RLC -> IO ()
        vcheck r = do
          print $ "actual: " <> (show $ r)
          print $ "toVec: " <> (show $ (toV @Double @RLC) r)
          print $ "unVec . toVec " <> (show $ ((unV @Double @RLC) . (toV @Double @RLC) $ r))
      mapM vcheck a--}
      property $ ((\(x :: RLC (Complex R)) -> ((unV @Double @(RLC (Complex R))) . (toV @Double @(RLC (Complex R))) $ x) == x))
    it "can generate a simple resistor component" $ do
      let
        --r = namedC "r" @(RLC :> RLC)
        r0 :: CR
        r0 = (Res 0)
        r2 :: CR
        r2 = (Res 2)
        rn = addV r2 r0
        --brc = (fmapC @(:>) @Blackbox) r0
      --print r
      --print r0
      --print brc
      rn `shouldBe` r2

type CR = RLC (Complex R)


{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, OverloadedStrings #-}
-- |
-- Module    : Statistics.Distribution.DiscreteUniform
-- Copyright : (c) 2016 André Szabolcs Szelp
-- License   : BSD3
--
-- Maintainer  : a.sz.szelp@gmail.com
-- Stability   : experimental
-- Portability : portable
--
-- The discrete uniform distribution. There are two parametrizations of
-- this distribution. First is the probability distribution on an
-- inclusive interval {1, ..., n}. This is parametrized with n only,
-- where p_1, ..., p_n = 1/n. ('discreteUniform').
--
-- The second parametrization is the uniform distribution on {a, ..., b} with
-- probabilities p_a, ..., p_b = 1/(a-b+1). This is parametrized with
-- /a/ and /b/. ('discreteUniformAB')

module Statistics.Distribution.DiscreteUniform
    (
      DiscreteUniform
    -- * Constructors
    , discreteUniform
    , discreteUniformAB
    -- * Accessors
    , rangeFrom
    , rangeTo
    ) where

import Control.Applicative (empty)
import Data.Aeson   (FromJSON(..), ToJSON, Value(..), (.:))
import Data.Binary  (Binary(..))
import Data.Data    (Data, Typeable)
import System.Random.Stateful (uniformRM)
import GHC.Generics (Generic)

import qualified Statistics.Distribution as D
import Statistics.Internal

-- | The discrete uniform distribution.
data DiscreteUniform = U {
      rangeFrom  :: {-# UNPACK #-} !Int
    -- ^ /a/, the lower bound of the support {a, ..., b}
    , rangeTo    :: {-# UNPACK #-} !Int
    -- ^ /b/, the upper bound of the support {a, ..., b}
    } deriving (Eq, Typeable, Data, Generic)

instance Show DiscreteUniform where
  showsPrec i (U a b) = defaultShow2 "discreteUniformAB" a b i
instance Read DiscreteUniform where
  readPrec = defaultReadPrecM2 "discreteUniformAB" (\a b -> Just (discreteUniformAB a b))

instance ToJSON   DiscreteUniform
instance FromJSON DiscreteUniform where
  parseJSON (Object v) = do
    a <- v .: "uniformA"
    b <- v .: "uniformB"
    return $ discreteUniformAB a b
  parseJSON _ = empty

instance Binary DiscreteUniform where
  put (U a b) = put a >> put b
  get         = discreteUniformAB <$> get <*> get

instance D.Distribution DiscreteUniform where
  cumulative (U a b) x
    | x < fromIntegral a = 0
    | x > fromIntegral b = 1
    | otherwise = fromIntegral (floor x - a + 1) / fromIntegral (b - a + 1)

instance D.DiscreteDistr DiscreteUniform where
  probability (U a b) k
    | k >= a && k <= b = 1 / fromIntegral (b - a + 1)
    | otherwise        = 0

instance D.Mean DiscreteUniform where
  mean (U a b) = fromIntegral (a+b)/2

instance D.Variance DiscreteUniform where
  variance (U a b) = (fromIntegral (b - a + 1)^(2::Int) - 1) / 12

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

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

instance D.Entropy DiscreteUniform where
  entropy (U a b) = log $ fromIntegral $ b - a + 1

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

instance D.ContGen DiscreteUniform where
  genContVar d = fmap fromIntegral . D.genDiscreteVar d

instance D.DiscreteGen DiscreteUniform where
  genDiscreteVar (U a b) = uniformRM (a,b)

-- | Construct discrete uniform distribution on support {1, ..., n}.
--   Range /n/ must be >0.
discreteUniform :: Int             -- ^ Range
                -> DiscreteUniform
discreteUniform n
  | n < 1     = error $ msg ++ "range must be > 0. Got " ++ show n
  | otherwise = U 1 n
  where msg = "Statistics.Distribution.DiscreteUniform.discreteUniform: "

-- | Construct discrete uniform distribution on support {a, ..., b}.
discreteUniformAB :: Int             -- ^ Lower boundary (inclusive)
                  -> Int             -- ^ Upper boundary (inclusive)
                  -> DiscreteUniform
discreteUniformAB a b
  | b < a     = U b a
  | otherwise = U a b


{- |
Raw, unnormalized multi-dimensional versions of the transforms in @fftw@.

Note that the forwards and backwards transforms of this module are not actually
inverses.  For example, @run idft (run dft v) /= v@ in general.

For more information on the individual transforms, see
<http://www.fftw.org/fftw3_doc/What-FFTW-Really-Computes.html>.

@since 0.2
-}

module Numeric.FFT.Vector.Unnormalized.Multi
  (
        -- * Creating and executing 'Plan's
        run,
        plan,
        execute,
        -- * Complex-to-complex transforms
        dft,
        idft,
        -- * Real-to-complex transforms
        dftR2C,
        dftC2R,
  ) where

import Numeric.FFT.Vector.Base
import Foreign
import Foreign.C
import Data.Complex

#include <fftw3.h>

-- | Whether the complex fft is forwards or backwards.
type CDirection = CInt

foreign import ccall unsafe fftw_plan_dft
    :: CInt -> Ptr CInt -> Ptr (Complex Double) -> Ptr (Complex Double)
        -> CDirection -> CFlags -> IO (Ptr CPlan)

foreign import ccall unsafe fftw_plan_dft_r2c
    :: CInt -> Ptr CInt -> Ptr Double -> Ptr (Complex Double) -> CFlags
        -> IO (Ptr CPlan)

foreign import ccall unsafe fftw_plan_dft_c2r
    :: CInt -> Ptr CInt -> Ptr (Complex Double) -> Ptr Double -> CFlags
        -> IO (Ptr CPlan)

dftND :: CDirection -> TransformND (Complex Double) (Complex Double)
dftND d = TransformND
  { inputSizeND = id
  , outputSizeND = id
  , creationSizeFromInputND = id
  , makePlanND = \rk dims a b -> withPlanner . fftw_plan_dft rk dims a b d
  , normalizationND = const id
  }

-- | A forward discrete Fourier transform.  The output and input sizes are the same (@n@).
dft :: TransformND (Complex Double) (Complex Double)
dft = dftND (#const FFTW_FORWARD)

-- | A backward discrete Fourier transform.  The output and input sizes are the same (@n@).
idft :: TransformND (Complex Double) (Complex Double)
idft = dftND (#const FFTW_BACKWARD)

-- | A forward discrete Fourier transform with real data.  If the input size is @n0 * ... * nk@,
-- the output size will be @n0 * ... * nk \`div\` 2 + 1@.
dftR2C :: TransformND Double (Complex Double)
dftR2C = TransformND {
              inputSizeND = id,
              outputSizeND = \n -> n `div` 2 + 1,
              creationSizeFromInputND = id,
              makePlanND = \rk dims a b -> withPlanner . fftw_plan_dft_r2c rk dims a b,
              normalizationND = const id
          }

-- | A backward discrete Fourier transform which produces real data.
--
-- This 'Transform' behaves differently than the others:
--
--  - Calling @plan dftC2R n@ creates a 'Plan' whose /output/ size is @n@, and whose
--    /input/ size is @n \`div\` 2 + 1@.
--
--  - If @length v == n@, then @length (run dftC2R v) == 2*(n-1)@.
dftC2R :: TransformND (Complex Double) Double
dftC2R = TransformND {
            inputSizeND = \n -> n `div` 2 + 1,
            outputSizeND = id,
            creationSizeFromInputND = \n -> 2 * (n-1),
            makePlanND = \rk dims a b -> withPlanner . fftw_plan_dft_c2r rk dims a b,
            normalizationND = const id
        }


{-# LANGUAGE ForeignFunctionInterface #-}
{-# CFILES cbits/vmath-zomplex.c #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Foreign.VMath.Zomplex
-- Copyright  : Copyright (c) 2010, Patrick Perry <patperry@gmail.com>
-- License    : BSD3
-- Maintainer : Patrick Perry <patperry@gmail.com>
-- Stability  : experimental
--

module Foreign.VMath.Zomplex
    where

import Data.Complex ( Complex )
import Foreign.Ptr  ( Ptr )

foreign import ccall unsafe "vzConj"
    vzConj :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzShift"
    vzShift :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzAdd"
    vzAdd :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzSub"
    vzSub :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzAxpby"
    vzAxpby :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzScale"
    vzScale :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzMul"
    vzMul :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzNeg"
    vzNeg :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzAbs"
    vzAbs :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzSgn"
    vzSgn :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzInv"
    vzInv :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzDiv"
    vzDiv :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzExp"
    vzExp :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzSqrt"
    vzSqrt :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzLog"
    vzLog :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzPow"
    vzPow :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzSin"
    vzSin :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzCos"
    vzCos :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzTan"
    vzTan :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzASin"
    vzASin :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzACos"
    vzACos :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzATan"
    vzATan :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzSinh"
    vzSinh :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzCosh"
    vzCosh :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzTanh"
    vzTanh :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzASinh"
    vzASinh :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzACosh"
    vzACosh :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe "vzATanh"
    vzATanh :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()


{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE TypeOperators              #-}

module DFT
  ( testSuite
  ) where

import Data.Complex
import Data.Mod.Word
import Data.Poly.Semiring (UPoly, unPoly, toPoly, dft, inverseDft, dftMult)
import qualified Data.Vector.Unboxed as U
import GHC.TypeNats (KnownNat, natVal, type (+), type (^))
import Test.Tasty
import Test.Tasty.QuickCheck hiding (scale, numTests)

import Dense ()

testSuite :: TestTree
testSuite = testGroup "DFT"
  [ testGroup "dft matches reference"
    [ dftMatchesRef (0 :: Mod (2 ^ 0 + 1))
    , dftMatchesRef (2 :: Mod (2 ^ 1 + 1))
    , dftMatchesRef (2 :: Mod (2 ^ 2 + 1))
    , dftMatchesRef (3 :: Mod (2 ^ 4 + 1))
    , dftMatchesRef (3 :: Mod (2 ^ 8 + 1))
    ]
  , testGroup "dft is invertible"
    [ dftIsInvertible (0 :: Mod (2 ^ 0 + 1))
    , dftIsInvertible (2 :: Mod (2 ^ 1 + 1))
    , dftIsInvertible (2 :: Mod (2 ^ 2 + 1))
    , dftIsInvertible (3 :: Mod (2 ^ 4 + 1))
    , dftIsInvertible (3 :: Mod (2 ^ 8 + 1))
    ]
  , testProperty "dftMult matches reference" dftMultMatchesRef
  ]

dftMatchesRef :: KnownNat n1 => Mod n1 -> TestTree
dftMatchesRef primRoot = testProperty (show n) $ do
  xs <- U.replicateM n arbitrary
  pure $ dft primRoot xs === dftRef primRoot xs
  where
    n = fromIntegral (natVal primRoot - 1)

dftRef :: (Num a, U.Unbox a) => a -> U.Vector a -> U.Vector a
dftRef primRoot xs = U.generate (U.length xs) $
  \k -> sum (map (\j -> xs U.! j * primRoot ^ (j * k)) [0..n-1])
  where
    n = U.length xs

dftIsInvertible :: KnownNat n1 => Mod n1 -> TestTree
dftIsInvertible primRoot = testProperty (show n) $ do
  xs <- U.replicateM n arbitrary
  let ys = dft primRoot xs
      zs = inverseDft primRoot ys
  pure $ xs === zs
  where
    n = fromIntegral (natVal primRoot - 1)

dftMultMatchesRef :: UPoly Int -> UPoly Int -> Property
dftMultMatchesRef xs ys = zs === dftZs
  where
    xs', ys', dftZs' :: UPoly (Complex Double)
    xs' = toPoly $ U.map fromIntegral $ unPoly xs
    ys' = toPoly $ U.map fromIntegral $ unPoly ys
    dftZs' = dftMult (\k -> cis (2 * pi / fromIntegral k)) xs' ys'

    zs, dftZs :: UPoly (Complex Int)
    zs  = toPoly $ U.map (:+ 0) $ unPoly $ xs * ys
    dftZs  = toPoly $ U.map (\(x :+ y) -> round x :+ round y) $ unPoly dftZs'


{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where

import Data.Monoid

import qualified Pipes.Prelude as P

import Statistics.Quantile.Util
import Statistics.Quantile.Exact
import Statistics.Quantile.Approximate.Sampling
import Statistics.Quantile.Bench
import Statistics.Quantile.Bench.Accuracy
import Statistics.Quantile.Types

import System.IO

data SelectorAccuracy = SelectorAccuracy String Deviation
  deriving (Eq, Show)

renderAccuracy :: SelectorAccuracy -> String
renderAccuracy (SelectorAccuracy s d) = s <> "," <> renderDeviation d

main :: IO ()
main = do
  hSetBuffering stdin LineBuffering
  hSetBuffering stdout LineBuffering
  (fp, fh) <- openTempFile tmpDir "accuracy.txt"
  n <- countOut fh (streamHandle stdin)
  hClose fh
  inh <- openFile fp ReadMode
  tv <- selectFromHandle median external inh
  hClose inh
  mapM (score fp tv) (estimators n sqrtN)
    >>= mapM_ (putStrLn . renderAccuracy)
  where estimators n f = [ ("exact", external)
                         , ("sampling", sampling (f n) n)
                         , ("jackknife-sampling", samplingJackknife (f n) n)
                         ]

        score fp tv (name, candidate) = do
          a <- benchAccuracy 10 fp median tv candidate
          pure (SelectorAccuracy name a)


module Polynomial (multiply, multiplyWithIntCoeffs, Poly(Poly), Coefficients) where

import Data.Complex
import DFT (dft, idft)
import Data.List (take, zip, repeat)

type Coefficients = [Complex Float]
data Poly = Poly Coefficients deriving (Eq)

instance Show Poly where
  show (Poly p) = show' p 0
    where show' [] degree = ""
          show' (x:xs) 0 = "(" ++ show (round (realPart x)) ++ " + " ++ ("(" ++ show (round (imagPart x)) ++ ")") ++ "i" ++ ")" ++ " + " ++ show' xs 1
          show' [x] degree = "(" ++ show (round (realPart x)) ++ " + " ++ ("(" ++ show (round (imagPart x)) ++ ")") ++ "i" ++ ")" ++ "x^" ++ show degree
          show' (x:xs) degree = "(" ++ show (round (realPart x)) ++ " + " ++ ("(" ++ show (round (imagPart x)) ++ ")") ++ "i" ++ ")" ++ "x^" ++ show degree ++ " + " ++ show' xs (degree + 1)

multiplyWithIntCoeffs :: Poly -> Poly -> [Int]
multiplyWithIntCoeffs p q = map round $ map (realPart) $ coeffs
  where (Poly coeffs) = multiply p q

multiply :: Poly -> Poly -> Poly
multiply (Poly p) (Poly q) = Poly (trimPoly $ idft (dft p' |*| dft q'))
  where (p', q') = pad p q
        trimPoly = take (length p + length q - 1)

pad :: Coefficients -> Coefficients -> (Coefficients, Coefficients)
pad p q = (p', q')
  where maxDegree = closestPowerOfTwo (length p + length q + 2)
        p' = p ++ (take (maxDegree - (length p)) (repeat 0))
        q' = q ++ (take (maxDegree - (length q)) (repeat 0))

(|*|) :: Coefficients -> Coefficients -> Coefficients
(|*|) = hadamard

hadamard :: Coefficients -> Coefficients -> Coefficients
hadamard p q = [ a * b | (a, b) <- zip p q ]

closestPowerOfTwo :: Int -> Int
closestPowerOfTwo x = 2 ^ ceiling (log (fromIntegral x) / log 2)


module Vector (module Data.Complex, module Vector) where

import Data.Complex

type Vector = Complex Float
j, zero :: Vector
j = 0:+1
zero = 0:+0
normalize a = a / (sqrt $ a * conjugate a)


{-|
Module      : HABQTlib.RandomStates

Generation of random pure (from Haar measure) and mixed states (from measure
induced by partial tracing of purified states).
-}
module HABQTlib.RandomStates
  ( genPureSV
  , genDM
  ) where

import HABQTlib.Data
import Numeric.LinearAlgebra
  ( norm_2
  , randn
  , scalar
  , sumElements
  , takeDiag
  , toComplex
  , tr
  )
import qualified Numeric.LinearAlgebra as LA

-- | Generate a random mixed state of specified rank.
genDM :: Dim -> Rank -> IO DensityMatrix
genDM dim r = do
  r1 <- randn dim r
  r2 <- randn dim r
  let a = toComplex (r1, r2)
  let h = a LA.<> tr a
  let hTr = sumElements $ takeDiag h
  return . DensityMatrix $ h / scalar hTr

-- | Generate a random pure state from Hilbert space of given dimension.
genPureSV :: Dim -> IO PureStateVector
genPureSV dim = do
  r1 <- randn dim 1
  r2 <- randn dim 1
  let sv = toComplex (r1, r2)
  return . PureStateVector $ sv / toComplex (scalar (norm_2 sv), 0)


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

-- TODO: This module is in the wrong module (these are not linear programs)
{-|
Module      : Numeric.LinearProgramming.L1.Static
Description : Solve l1 programs with static vectors/matrices.
Copyright   : (c) Ryan Orendorff, 2020
License     : BSD3
Stability   : experimental
-}
module Numeric.LinearProgramming.L1.Static (
  l1Solve,
  l1SolveGT,
  l1SolveO,
  lInfSolveO,
  l1SolveU
)

where

import           Data.Maybe (fromJust)
import           GHC.TypeLits
import           Numeric.LinearAlgebra.Static
import qualified Numeric.LinearAlgebra as LA
import qualified Numeric.LinearProgramming.L1 as L1

-- Internal only. Could lead to runtime exceptions except in this case we trust
-- the output from the solvers is the correct dimensions.
mkL :: KnownNat n => LA.Vector ℝ -> R n
mkL = fromJust . create

-- | Solution in the L_1 norm, with L_1 regularization, of a linear system @Ax=b@.
--
-- @argmin_x  λ||x||_1 + ||Ax-b||_1@
l1Solve :: (KnownNat m, KnownNat n) =>
           Double -- ^ λ
        -> L m n  -- ^ A
        -> R m    -- ^ b
        -> R n    -- ^ x
l1Solve λ (extract -> a) (extract -> b) = mkL $ L1.l1Solve λ a b

-- | Solution in the L_1 norm, with L_1 regularization, of a system of linear inequalities @Ax>=b@.
--
-- @argmin_x  λ||x||_1 + ||step(b-Ax)||_1@
l1SolveGT :: (KnownNat m, KnownNat n) =>
             Double -- ^ λ
          -> L m n  -- ^ A
          -> R m    -- ^ b
          -> R n    -- ^ x
l1SolveGT λ (extract -> a) (extract -> b) = mkL $ L1.l1SolveGT λ a b

-- | L_1 solution of overconstrained system Ax=b.
--
-- @argmin_x ||Ax-b||_1@
l1SolveO :: (KnownNat m, KnownNat n) =>
            L m n -- ^ A
         -> R m   -- ^ b
         -> R n   -- ^ x
l1SolveO (extract -> a) (extract -> b) = mkL $ L1.l1SolveO a b

-- | L_inf solution of overconstrained system Ax=b.
--
-- @argmin_x ||Ax-b||_inf@
lInfSolveO :: (KnownNat m, KnownNat n) =>
              L m n -- ^ A
           -> R m   -- ^ b
           -> R n   -- ^ x
lInfSolveO (extract -> a) (extract -> b) = mkL $ L1.lInfSolveO a b

-- | L1 solution of underconstrained linear system Ax=b.
--
-- @argmin_x ||x||_1 such that Ax=b@
l1SolveU :: (KnownNat m, KnownNat n) =>
            L m n -- ^ A
         -> R m   -- ^ b
         -> R n   -- ^ x
l1SolveU (extract -> a) (extract -> b) = mkL $ L1.l1SolveU a b


{-# LANGUAGE RecordWildCards #-}

module Trade.Algorithm.Drawdown where

import qualified Data.List as List
import qualified Data.Vector as Vec

import qualified Statistics.Sample as Sample

{-

dds :: [Double] -> [(Int, Double)]
dds xs =
  let go n a [] = [(n, a)]
      go n 0 (x:xs) = go n x xs
      go n a (0:xs) = go (n+1) a xs
      go n a (x:xs) =
        case a*x > 0 of
          True -> go (n+1) (a+x) xs
          False -> let ys = go 1 x xs in (n, a):ys
  in go 1 0 (zipWith (-) (tail xs) xs)

drawdownSeries :: [Double] -> [(Double, Double)]
drawdownSeries us@(u:_) =
  let go acc [] = [acc]
      go (a, b) ((x, y):us) =
        let vs = go (a+fromIntegral x, b+y) us
        in (a, b) : vs
  in go (0, u) (dds us)

drawdowns :: [Double] -> [(Int, Double)]
drawdowns = filter ((<0) . snd) . dds

numberOfDrawdowns :: [Double] -> Int
numberOfDrawdowns = length . drawdowns

maximumDrawdown :: [Double] -> Double
maximumDrawdown = minimum . map snd . dds

wins :: [Double] -> [(Int, Double)]
wins = filter ((>0) . snd) . dds

numberOfWins :: [Double] -> Int
numberOfWins = length . wins

maximumWin :: [Double] -> Double
maximumWin = maximum . map snd . dds

data DrawdownStatistics = DrawdownStatistics {
  numOfWins :: !Int
  , maxWin :: !Double
  , meanWin :: !Double
  , stdDevWin :: !Double
  , numOfDrawdowns :: !Int
  , maxDrawdown :: !Double
  , meanDrawdown :: !Double
  , stdDevDrawdown :: !Double
  } deriving (Show)

drawdownStats :: [Double] -> DrawdownStatistics
drawdownStats xs =
  let ds = map snd (dds xs)
      wins = filter (>0) ds
      vwins = Vec.fromList wins
      losses = filter (<0) ds
      vlosses = Vec.fromList losses
  in DrawdownStatistics {
    numOfWins = length wins
    , maxWin = maximum wins
    , meanWin = Sample.mean vwins
    , stdDevWin = Sample.stdDev vwins
    , numOfDrawdowns = length losses
    , maxDrawdown = minimum losses
    , meanDrawdown = Sample.mean vlosses
    , stdDevDrawdown = Sample.stdDev vlosses
    }

reportDrawdownStats :: [Double] -> HtmlIO
reportDrawdownStats xs =
  let DrawdownStatistics{..} = drawdownStats xs
  in Rep.vtable $
     ["Number of wins", show numOfWins]
     : ["Win max", show maxWin]
     : ["Win mean", show meanWin]
     : ["Win stddev", show stdDevWin]
     : ["----------"]
     : ["Number of drawdowns", show numOfDrawdowns]
     : ["Drawdown max", show maxDrawdown]
     : ["Drawdown mean", show meanDrawdown]
     : ["Drawdown stddev", show stdDevDrawdown]
     : []

-}


#!/usr/bin/env stack
-- stack runghc --package reanimate
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where

import           Data.Complex
import qualified Data.Text           as T
import           Graphics.SvgTree
import           Linear.V2
import           Reanimate

main :: IO ()
main = reanimate $ pauseAtEnd 2
  fourierAnimation_

sWidth :: Double
sWidth = 0.02

piFourier :: Fourier
piFourier = mkFourier piPoints

piPoints :: [RPoint]
piPoints = lineToPoints 500 $
  toLineCommands $ extractPath $ scale 10 $ center $ latexAlign "\\pi"

fourierAnimation_ :: Animation
fourierAnimation_ = mkAnimation 50 $ \t ->
    let fLength = t
        circles = setFourierLength (fLength*maxLength) piFourier
        maxLength = sum $ map magnitude $ take 499 $ drop 1 $ fourierCoefficients piFourier
        phi = fromToS 0 15 t
    in mkGroup
    [ mkBackground "black"
    , drawCircles $ fourierCoefficients $ rotateFourier phi circles
    , withStrokeColor "green" $
      withFillOpacity 0 $
      mkLinePath $ mkFourierOutline circles
    , withFillColor "white" $
      translate (-screenWidth/16*7) (screenHeight/16*7) $
      latex $ T.pack $ "Circles: " ++ show (length $ fourierCoefficients circles)
    ]

newtype Fourier = Fourier {fourierCoefficients :: [Complex Double]}

pointAtFourier :: Fourier -> Complex Double
pointAtFourier = sum . fourierCoefficients

mkFourier :: [RPoint] -> Fourier
mkFourier points = Fourier $ findCoefficient 0 :
    concat [ [findCoefficient n, findCoefficient (-n)] | n <- [1..] ]
  where
    findCoefficient :: Int -> Complex Double
    findCoefficient n =
        sum [ toComplex point * exp (negate (fromIntegral n) * 2 *pi * i*t) * deltaT
            | (idx, point) <- zip [0::Int ..] points, let t = fromIntegral idx/nPoints ]
    i = 0 :+ 1
    toComplex (V2 x y) = x :+ y
    deltaT = recip nPoints
    nPoints = fromIntegral (length points)

-- setFourierCircles :: Double -> Fourier -> Fourier
-- setFourierCircles n _ | n < 1 = error "Invalid argument. Need at least one circle."
-- setFourierCircles n (Fourier coeffs) =
--     Fourier $ take iCircles coeffs ++ [coeffs!!iCircles * realToFrac fCircle]
--   where
--     (iCircles, fCircle) = divMod' n 1

setFourierLength :: Double -> Fourier -> Fourier
setFourierLength _ (Fourier []) = Fourier []
setFourierLength len0 (Fourier (first:lst)) = Fourier $ first : worker len0 lst
  where
    worker _len [] = []
    worker len (c:cs) =
      if magnitude c < len
        then c : worker (len - magnitude c) cs
        else [c * realToFrac (len / magnitude c)]

rotateFourier :: Double -> Fourier -> Fourier
rotateFourier phi (Fourier coeffs) =
    Fourier $ worker coeffs (0::Integer)
  where
    worker [] _ = []
    worker (x:rest) 0 = x : worker rest 1
    worker [left] n = worker [left,0] n
    worker (left:right:rest) n =
      let n' = fromIntegral n in
      left * exp (negate n' * 2 * pi * i * phi') :
      right * exp (n' * 2 * pi * i * phi') :
      worker rest (n+1)
    i = 0 :+ 1
    -- n = length coeffs `div` 2
    phi' = realToFrac phi

drawCircles :: [Complex Double] -> SVG
drawCircles circles = mkGroup
    [ worker circles
    , withStrokeWidth sWidth $
      withStrokeColor "white" $
      withStrokeLineJoin JoinRound $
      withFillOpacity 0 $
      mkLinePath [ (x, y) | x :+ y <- scanl (+) 0 circles ] ]
  where
    worker [] = None
    worker (x :+ y : rest) =
      let radius = sqrt(x*x+y*y) in
      mkGroup
      [ withStrokeWidth sWidth $
        withStrokeColor "dimgrey" $
        withFillOpacity 0 $
        mkCircle radius
      , translate x y $ worker rest ]

mkFourierOutline :: Fourier -> [(Double, Double)]
mkFourierOutline fourier =
    [ (x, y)
    | idx <- [0 .. granularity]
    , let x :+ y = pointAtFourier $ rotateFourier (idx/granularity) fourier
    ]
  where
    granularity = 500


module ISRES where

import Numeric.LinearAlgebra
import Numeric.NLOPT

isres01 :: Int -> Either Result Solution
isres01 n =
  let objf x = x `dot` x + 22 -- define objective
      stop = ObjectiveRelativeTolerance 1e-12 :| [] -- define stopping criterion
      algorithm = ISRES objf [] [] (SeedValue 22) -- specify algorithm
      lowerbounds = fromList $ replicate n (-10) -- specify bounds
      upperbounds = fromList $ replicate n (10) -- specify bounds
      problem = GlobalProblem lowerbounds upperbounds stop algorithm
      x0 = fromList $ replicate n 5 -- specify initial guess
   in minimizeGlobal problem x0

isres02 :: Int -> Either Result Solution
isres02 n =
  let objf x = - norm_1 x
      stop = ObjectiveRelativeTolerance 1e-12 :| [] -- define stopping criterion
      algorithm = ISRES objf [] [eqCon] (SeedValue 22) -- specify algorithm
      lowerbounds = fromList $ replicate n 0 -- specify bounds
      upperbounds = fromList $ replicate n 10 -- specify bounds
      eqCon =
        EqualityConstraint
          { eqConstraintFunctions = Scalar (\x -> x ! 1 * (x ! 0 - 5)),
            {-               Scalar
                            ( \x ->
                                let x1 = subVector 0 (n `div` 2) x
                                    x2 = subVector ((n `div` 2) + 1) n x
                                 in x1 `dot` (x2 - upperbounds)
                            ),
             -}
            eqConstraintTolerance = 1e-12
          }

      problem = GlobalProblem lowerbounds upperbounds stop algorithm
      x0 = fromList $ replicate n 5 -- specify initial guess
   in minimizeGlobal problem x0

isres03 :: Int -> Either Result Solution
isres03 n =
  if n < 3
    then error "n must be at least 3"
    else
      let objf x = - norm_1 x
          stop = ObjectiveRelativeTolerance 1e-12 :| [] -- define stopping criterion
          algorithm = ISRES objf [] [eqCon] (SeedValue 22) -- specify algorithm
          lowerbounds = fromList $ replicate n 0 -- specify bounds
          upperbounds = fromList $ replicate n 10 -- specify bounds
          eqCon =
            EqualityConstraint
              { eqConstraintFunctions =
                  Vector
                    2
                    ( \x _ ->
                        fromList
                          [ x ! 1 * (x ! 0 - 10),
                            x ! 2 * (x ! 1 - (10 - x ! 0))
                          ]
                    ),
                eqConstraintTolerance = 1e-12
              }

          problem = GlobalProblem lowerbounds upperbounds stop algorithm
          x0 = fromList $ replicate n 0 -- specify initial guess
       in minimizeGlobal problem x0

{-
See https://www.mat.univie.ac.at/~neum/glopt/coconut/Benchmark/Library1_new_v1.html

Alkyl problem in AMPL format:
var x2 := 1.745, >= 0, <= 2;
var x3 := 1.2, >= 0, <= 1.6;
var x4 := 1.1, >= 0, <= 1.2;
var x5 := 3.048, >= 0, <= 5;
var x6 := 1.974, >= 0, <= 2;
var x7 := 0.893, >= 0.85, <= 0.93;
var x8 := 0.928, >= 0.9, <= 0.95;
var x9 := 8, >= 3, <= 12;
var x10 := 3.6, >= 1.2, <= 4;
var x11 := 1.45, >= 1.45, <= 1.62;
var x12 := 1, >= 0.99, <= 1.01010101010101;
var x13 := 1, >= 0.99, <= 1.01010101010101;
var x14 := 1, >= 0.9, <= 1.11111111111111;
var x15 := 1, >= 0.99, <= 1.01010101010101;

minimize obj:  - 6.3*x5*x8 + 5.04*x2 + 0.35*x3 + x4 + 3.36*x6;

subject to
e2:  - 0.819672131147541*x2 + x5 - 0.819672131147541*x6 = 0;
e3: 0.98*x4 - x7*(0.01*x5*x10 + x4) = 0;
e4:  - x2*x9 + 10*x3 + x6 = 0;
e5: x5*x12 - x2*(1.12 + 0.13167*x9 - 0.0067*x9*x9) = 0;
e6: x8*x13 - 0.01*(1.098*x9 - 0.038*x9*x9) - 0.325*x7 - 0.57425 = 0;
e7: x10*x14 + 22.2*x11 - 35.82 = 0;
e8: x11*x15 - 3*x8 + 1.33 = 0;
-}
alkyl :: [Double] -> Either Result Solution
alkyl x0 =
  let lb = fromList [0, 0, 0, 0, 0, 0.85, 0.9, 3, 1.2, 1.45, 0.99, 0.99, 0.9, 0.99]
      ub = fromList [2, 1.6, 1.2, 5, 2, 0.93, 0.95, 12, 4, 1.62, 1.01010101010101, 1.01010101010101, 1.11111111111111, 1.01010101010101]
      objf x = - 6.3 * x ! 3 * x ! 6 + 5.04 * x ! 0 + 0.35 * x ! 1 + x ! 2 + 3.36 * x ! 4
      stop = ObjectiveRelativeTolerance 1e-12 :| []
      eqCons =
        [ EqualityConstraint
            { eqConstraintFunctions = Scalar (\x -> -0.819672131147541 * x ! 0 + x ! 3 - 0.819672131147541 * x ! 4),
              eqConstraintTolerance = 1e-10
            },
          EqualityConstraint
            { eqConstraintFunctions = Scalar (\x -> 0.98 * x ! 2 - x ! 5 * (0.01 * x ! 3 * x ! 8 + x ! 2)),
              eqConstraintTolerance = 1e-10
            },
          EqualityConstraint
            { eqConstraintFunctions = Scalar (\x -> - x ! 0 * x ! 7 + 10 * x ! 1 + x ! 4),
              eqConstraintTolerance = 1e-10
            },
          EqualityConstraint
            { eqConstraintFunctions = Scalar (\x -> x ! 3 * x ! 10 - x ! 0 * (1.12 + 0.13167 * x ! 7 - 0.0067 * x ! 7 * x ! 7)),
              eqConstraintTolerance = 1e-10
            },
          EqualityConstraint
            { eqConstraintFunctions = Scalar (\x -> x ! 6 * x ! 11 - 0.01 * (1.098 * x ! 7 - 0.038 * x ! 7 * x ! 7) - 0.325 * x ! 5 - 0.57425),
              eqConstraintTolerance = 1e-10
            },
          EqualityConstraint
            { eqConstraintFunctions = Scalar (\x -> x ! 8 * x ! 12 + 22.2 * x ! 9 - 35.82),
              eqConstraintTolerance = 1e-10
            },
          EqualityConstraint
            { eqConstraintFunctions = Scalar (\x -> x ! 9 * x ! 13 - 3 * x ! 6 + 1.33),
              eqConstraintTolerance = 1e-10
            }
        ]
      algorithm = ISRES objf [] eqCons (SeedValue 22)
      problem = GlobalProblem lb ub stop algorithm
   in minimizeGlobal problem (fromList x0)


{-# LANGUAGE Rank2Types #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Numeric.LinearAlgebra.Matrix
-- Copyright  : Copyright (c) 2010, Patrick Perry <patperry@gmail.com>
-- License    : BSD3
-- Maintainer : Patrick Perry <patperry@gmail.com>
-- Stability  : experimental
--
-- Immutable dense matrices.

module Numeric.LinearAlgebra.Matrix (
    -- * Immutable matrices
    Matrix,
    dim,

    -- * Matrix construction
    fromList,
    fromCols,
    fromRows,
    constant,
    zero,

    -- * Accessing matrices
    at,
    indices,
    elems,
    assocs,

    -- * Incremental matrix updates
    update,
    unsafeUpdate,
    accum,
    unsafeAccum,

    -- * Derived matrices
    map,
    zipWith,

    -- * Matrix views
    slice,
    takeRows,
    dropRows,
    splitRowsAt,
    takeCols,
    dropCols,
    splitColsAt,

    -- * Matrix rows and columns
    col,
    cols,
    row,
    rows,

    -- * Matrix diagonals
    diag,

    -- * Conversions to vectors
    toVector,

    -- * Conversions from vectors
    fromVector,
    fromCol,
    fromRow,

    -- * Matrix math operations
    shiftDiag,
    shiftDiagWithScale,
    add,
    addWithScale,
    sub,
    scale,
    scaleRows,
    scaleCols,
    negate,
    conjugate,

    -- * Linear algebra
    trans,
    conjTrans,
    rank1Update,

    -- ** Matrix-Vector multiplication
    mulVector,
    mulVectorWithScale,
    addMulVectorWithScales,

    -- ** Matrix-Matrix multiplication
    mulMatrix,
    mulMatrixWithScale,
    addMulMatrixWithScales,

    -- * Conversions between foreign pointers
    unsafeFromForeignPtr,
    unsafeToForeignPtr,

    -- * Mutable interface
    module Numeric.LinearAlgebra.Matrix.ST,

    -- * Hermitian views
    module Numeric.LinearAlgebra.Matrix.Herm,

    -- * Triangular views
    module Numeric.LinearAlgebra.Matrix.Tri,

    -- * Cholesky factorizations
    module Numeric.LinearAlgebra.Matrix.Cholesky,

    -- * Eigenvalues and eigenvectors
    module Numeric.LinearAlgebra.Matrix.Eigen,

    -- * Basic multivariate statistics
    module Numeric.LinearAlgebra.Matrix.Statistics,

    ) where

import Prelude hiding ( map, zipWith, negate, )
import Control.Monad( zipWithM_ )
import Control.Monad.ST( ST )
import Foreign( Storable )
import Text.Printf( printf )

import Foreign.BLAS( BLAS1, BLAS2, BLAS3, Trans(..) )
import Foreign.VMath( VNum )

import Numeric.LinearAlgebra.Matrix.Base
import Numeric.LinearAlgebra.Matrix.Herm
import Numeric.LinearAlgebra.Matrix.Tri
import Numeric.LinearAlgebra.Matrix.ST
import Numeric.LinearAlgebra.Matrix.Cholesky
import Numeric.LinearAlgebra.Matrix.Eigen
import Numeric.LinearAlgebra.Matrix.Statistics
import Numeric.LinearAlgebra.Vector( Vector )
import qualified Numeric.LinearAlgebra.Vector as V

infixl 7 `scale`, `scaleRows`, `scaleCols`
infixl 6 `add`, `shiftDiag`, `sub`

-- | Create a matrix of the given dimension with the given vectors as
-- columns.
fromCols :: (Storable e) => (Int,Int) -> [Vector e] -> Matrix e
fromCols mn cs = create $ do
    a <- new_ mn
    withColsM a $ \cs' -> zipWithM_ V.copyTo cs' cs
    return a

-- | Create a matrix of the given dimension with the given vectors as
-- rows.
fromRows :: (Storable e) => (Int,Int) -> [Vector e] -> Matrix e
fromRows (m,n) rs = create $ do
    a <- new_ (m,n)
    sequence_ [ setRow a i r | (i,r) <- zip [ 0..m-1 ] rs ]
    return a

-- | Get the given row of the matrix.
row :: (BLAS1 e) => Matrix e -> Int -> Vector e
row a i
    | i < 0 || i >= m = error $
        printf ("row <matrix with dim (%d,%d)> %d:"
                ++ " index out of range") m n i
    | otherwise =
        unsafeRow a i
  where
    (m,n) = dim a
{-# INLINE row #-}

-- | Version of 'row' that doesn't range-check indices.
unsafeRow :: (BLAS1 e) => Matrix e -> Int -> Vector e
unsafeRow a@(Matrix v _ n lda) i
    | lda == 1 = v
    | otherwise = V.create $ do
        r <- V.new_ n
        unsafeRowTo r a i
        return r

-- | Get a list of the rows in a matrix
rows :: (BLAS1 e) => Matrix e -> [Vector e]
rows a = [ unsafeRow a i | i <- [ 0..m-1 ] ]
  where
    (m,_) = dim a

-- | Get the diagonal of the matrix.
diag :: (Storable e) => Matrix e -> Vector e
diag a = V.create $ do
    x <- V.new_ mn
    diagTo x a
    return x
  where
    (m,n) = dim a
    mn = min m n

-- | @shiftDiag d a@ returns @diag(d) + a@.
shiftDiag :: (BLAS1 e) => Vector e -> Matrix e -> Matrix e
shiftDiag s a = create $ do
    a' <- newCopy a
    shiftDiagM_ s a'
    return a'

-- | @shiftDiagWithScale alpha d a@ returns @alpha * diag(d) + a@.
shiftDiagWithScale :: (BLAS1 e) => e -> Vector e -> Matrix e -> Matrix e
shiftDiagWithScale e s a = create $ do
    a' <- newCopy a
    shiftDiagWithScaleM_ e s a'
    return a'

-- | @add a b@ returns @a + b@.
add :: (VNum e) => Matrix e -> Matrix e -> Matrix e
add = result2 addTo

-- | @sub a b@ returns @a - b@.
sub :: (VNum e) => Matrix e -> Matrix e -> Matrix e
sub = result2 subTo

-- | @scale k a@ returns @k * a@.
scale :: (BLAS1 e) => e -> Matrix e -> Matrix e
scale k a = create $ do
    a' <- newCopy a
    scaleM_ k a'
    return a'

-- | @addWithScale alpha x y@ returns @alpha * x + y@.
addWithScale :: (BLAS1 e) => e -> Matrix e -> Matrix e -> Matrix e
addWithScale alpha x y = create $ do
    y' <- newCopy y
    addWithScaleM_ alpha x y'
    return y'

-- | @scaleRows s a@ returns @diag(s) * a@.
scaleRows :: (BLAS1 e) => Vector e -> Matrix e -> Matrix e
scaleRows s a = create $ do
    a' <- newCopy a
    scaleRowsM_ s a'
    return a'

-- | @scaleCols s a@ returns @a * diag(s)@.
scaleCols :: (BLAS1 e) => Vector e -> Matrix e -> Matrix e
scaleCols s a = create $ do
    a' <- newCopy a
    scaleColsM_ s a'
    return a'

-- | @negate a@ returns @-a@.
negate :: (VNum e) => Matrix e -> Matrix e
negate = result negateTo

-- | @conjugate a@ returns @conjugate(a)@.
conjugate :: (VNum e) => Matrix e -> Matrix e
conjugate = result conjugateTo

-- | @trans a@ retunrs @trans(a)@.
trans :: (BLAS1 e)
      => Matrix e
      -> Matrix e
trans a = let
    (m,n) = dim a
    in create $ do
        a' <- new_ (n,m)
        transTo a' a
        return a'

-- | @conjTrans a@ retunrs @conj(trans(a))@.
conjTrans :: (BLAS1 e)
          => Matrix e
          -> Matrix e
conjTrans a = let
    (m,n) = dim a
    in create $ do
        a' <- new_ (n,m)
        conjTransTo a' a
        return a'

-- | @rank1Update alpha x y a@ returns @alpha * x * y^H + a@.
rank1Update :: (BLAS2 e)
            => e
            -> Vector e
            -> Vector e
            -> Matrix e
            -> Matrix e
rank1Update alpha x y a =
    create $ do
        a' <- newCopy a
        rank1UpdateM_ alpha x y a'
        return a'

-- | @mulVector transa a x@
-- returns @op(a) * x@, where @op(a)@ is determined by @transa@.
mulVector :: (BLAS2 e)
          => Trans -> Matrix e
          -> Vector e
          -> Vector e
mulVector transa a x = let
    m = case transa of NoTrans -> (fst . dim) a
                       _       -> (snd . dim) a
    in V.create $ do
        y <- V.new_ m
        mulVectorTo y transa a x
        return y

-- | @mulVectorWithScale alpha transa a x@
-- retunrs @alpha * op(a) * x@, where @op(a)@ is determined by @transa@.
mulVectorWithScale :: (BLAS2 e)
                   => e
                   -> Trans -> Matrix e
                   -> Vector e
                   -> Vector e
mulVectorWithScale alpha transa a x = let
    m = case transa of NoTrans -> (fst . dim) a
                       _       -> (snd . dim) a
    in V.create $ do
        y <- V.new_ m
        mulVectorWithScaleTo y alpha transa a x
        return y

-- | @addMulVectorWithScales alpha transa a x beta y@
-- returns @alpha * op(a) * x + beta * y@, where @op(a)@ is
-- determined by @transa@.
addMulVectorWithScales :: (BLAS2 e)
                       => e
                       -> Trans -> Matrix e
                       -> Vector e
                       -> e
                       -> Vector e
                       -> Vector e
addMulVectorWithScales alpha transa a x beta y =
    V.create $ do
        y' <- V.newCopy y
        addMulVectorWithScalesM_ alpha transa a x beta y'
        return y'

-- | @mulMatrix transa a transb b@
-- returns @op(a) * op(b)@, where @op(a)@ and @op(b)@ are determined
-- by @transa@ and @transb@.
mulMatrix :: (BLAS3 e)
          => Trans -> Matrix e
          -> Trans -> Matrix e
          -> Matrix e
mulMatrix transa a transb b = let
    m = case transa of NoTrans -> (fst . dim) a
                       _       -> (snd . dim) a
    n = case transb of NoTrans -> (snd . dim) b
                       _       -> (fst . dim) b
    in create $ do
        c <- new_ (m,n)
        mulMatrixTo c transa a transb b
        return c

-- | @mulMatrixWithScale alpha transa a transb b@
-- returns @alpha * op(a) * op(b)@, where @op(a)@ and @op(b)@ are determined
-- by @transa@ and @transb@.
mulMatrixWithScale :: (BLAS3 e)
                   => e
                   -> Trans -> Matrix e
                   -> Trans -> Matrix e
                   -> Matrix e
mulMatrixWithScale alpha transa a transb b = let
    m = case transa of NoTrans -> (fst . dim) a
                       _       -> (snd . dim) a
    n = case transb of NoTrans -> (snd . dim) b
                       _       -> (fst . dim) b
    in create $ do
        c <- new_ (m,n)
        mulMatrixWithScaleTo c alpha transa a transb b
        return c

-- | @addMulMatrixWithScales alpha transa a transb b beta c@
-- returns @alpha * op(a) * op(b) + beta * c@, where @op(a)@ and
-- @op(b)@ are determined by @transa@ and @transb@.
addMulMatrixWithScales :: (BLAS3 e)
                       => e
                       -> Trans -> Matrix e
                       -> Trans -> Matrix e
                       -> e
                       -> Matrix e
                       -> Matrix e
addMulMatrixWithScales alpha transa a transb b beta c =
    create $ do
        c' <- newCopy c
        addMulMatrixWithScalesM_ alpha transa a transb b beta c'
        return c'

result :: (Storable e, Storable f)
       => (forall s . STMatrix s f -> Matrix e -> ST s a)
       -> Matrix e
       -> Matrix f
result f a = create $ newResult f a
{-# INLINE result #-}

result2 :: (Storable e, Storable f, Storable g)
        => (forall s . STMatrix s g -> Matrix e -> Matrix f -> ST s a)
        -> Matrix e
        -> Matrix f
        -> Matrix g
result2 f a1 a2 = create $ newResult2 f a1 a2
{-# INLINE result2 #-}

newResult :: (RMatrix m, Storable e, Storable f)
          => (STMatrix s f -> m e -> ST s a)
          -> m e
          -> ST s (STMatrix s f)
newResult f a = do
    mn <- getDim a
    c <- new_ mn
    _ <- f c a
    return c
{-# INLINE newResult #-}

newResult2 :: (RMatrix m1, RMatrix m2, Storable e, Storable f, Storable g)
           => (STMatrix s g -> m1 e -> m2 f -> ST s a)
           -> m1 e
           -> m2 f
           -> ST s (STMatrix s g)
newResult2 f a1 a2 = do
    mn <- getDim a1
    c <- new_ mn
    _ <- f c a1 a2
    return c
{-# INLINE newResult2 #-}


module Statistics.Information.Discrete.TotalCorrelation where

import Data.Matrix
import Statistics.Information.Discrete.Entropy
import Statistics.Information.Discrete.MutualInfo
import Statistics.Information.Utils.Matrix

tc :: Eq a => Int -> Matrix a -> Double
tc base xs = sum hxs - hx where
  hxs = [entropy base col | col <- map colVector (columns xs)]
  hx = entropy base xs

ctc :: Eq a => Int -> Matrix a -> Matrix a -> Double
ctc base xs ys = sum hxs - hx where
  hxs = [centropy base col ys | col <- map colVector (columns xs)]
  hx = centropy base xs ys

corex_tcs :: Eq a => Int -> Matrix a -> Matrix a -> Double
corex_tcs base xs ys = tc base xs - ctc base xs ys

corex_mis :: Eq a => Int -> Matrix a -> Matrix a -> Double
corex_mis base xs ys = sum mixs - mi_all where
  mixs = [mi base col ys | col <- map colVector (columns xs)]
  mi_all = mi base xs ys

residual :: Eq a => Int -> Matrix a -> Double
residual base xs = sum $ [hlessxi i | i <- [1..(ncols xs)]] where
  hlessxi i = centropy base (colVector $ getCol i xs) $ residualMatrix xs i

dtc :: Eq a => Int -> Matrix a -> Double
dtc base xs = entropy base xs - residual base xs


{-# LANGUAGE BangPatterns #-}
{- |
Module      : ML.NN
Description : Simple neural network implementation, for education purposes only.
-}
module ML.NN
       (
           -- * Data types
           ActivationFunction  -- Re-export from NN.ActivationFunction.
       ,   Layer(..)
       ,   Network(..)

           -- * Network initialization
       ,   randLayer
       ,   randNetwork

           -- * Running networks
       ,   feedForward
       ,   runNetwork
       ,   feedForwardSet
       ,   runNetworkSet
       ) where

import           ML.NN.ActivationFunction (ActivationFunction)

import           Control.Monad (forM, replicateM)
import           Control.Monad.Random (Rand, liftRand)
import           Data.Foldable (foldl')
import           Data.Random.Normal (normal)
import           Numeric.LinearAlgebra (Matrix, R, Vector, (><), (<>), (#>), cmap,
                                        fromColumns, vector)
import           System.Random (RandomGen)

-- ==================================================
-- Types.
-- ==================================================

-- | A layer in a neural network is a bias vector and weight matrix.
--
-- Let /n/ be the number of neurons in the layer and /m/ be the number
-- of inputs to the layer. Then 'layerBiases' is a vector in Rⁿ and
-- 'layerWeights' is an /nxm/ real matrix.
data Layer = Layer
             { layerBiases  :: {-# UNPACK #-} !(Vector R)
                                              -- ^ A vector in Rⁿ representing the neuron biases.
             , layerWeights :: {-# UNPACK #-} !(Matrix R)
                                              -- ^ An /nxm/ real matrix of the neuron weights.
             } deriving (Show, Read)

-- | A network is a list of layers.
data Network = Network
               { networkLayers :: [Layer]
               } deriving (Show, Read)

-- ==================================================
-- Network initialization.
-- ==================================================

-- | Generate a random neural network given the size of each layer.
--
-- For example, @[3,2,4]@ will generate a neural network with 3 input
-- neurons, 1 hidden layer with 2 neurons and 4 output neurons.
randNetwork :: RandomGen g => [Int] -> Rand g Network
randNetwork sizes = Network <$> forM dims (uncurry randLayer)
    where dims = adjacentPairs sizes

-- | Return a list of pairs of adjacent elements in a list.
--
-- Example: adjacentPairs [1,2,3] ==> [(1,2), (2,3)]
adjacentPairs :: [a] -> [(a,a)]
adjacentPairs xs = zip (init xs) (tail xs)

-- | Generate a randomly initialized layer in a neural network.
randLayer :: RandomGen g
             => Int           -- ^ Number of inputs into the layer.
             -> Int           -- ^ Number of neurons in the layer.
             -> Rand g Layer  -- ^ Randomly generated layer.
randLayer numInputs numNeurons = do
    bias <- vector <$> replicateM numNeurons (liftRand normal)
    weights <- (numNeurons><numInputs) <$> replicateM (numNeurons*numInputs) (liftRand normal)
    return $ Layer bias weights

-- ==================================================
-- Running networks.
-- ==================================================

-- | Feed the output from a previous layer to the next layer.
feedForward :: ActivationFunction  -- ^ Neuron activation function.
            -> Vector R            -- ^ Input to the layer.
            -> Layer               -- ^ Layer to run.
            -> Vector R            -- ^ Output from the layer.
feedForward act x (Layer biases weights) = cmap act z
    where z = (weights #> x) + biases

-- | Run a neural network.
runNetwork :: Network             -- ^ Network to run.
           -> ActivationFunction  -- ^ Neuron activation function.
           -> Vector R            -- ^ Network input.
           -> Vector R            -- ^ Network output.
runNetwork (Network layers) act input = foldl' (feedForward act) input layers

feedForwardSet :: ActivationFunction -> Matrix R -> Layer -> Matrix R
feedForwardSet act xM (Layer biases weights) = cmap act z
    where z = (weights <> xM) + fromColumns [biases]

runNetworkSet :: Network -> ActivationFunction -> Matrix R -> Matrix R
runNetworkSet (Network layers) act input = foldl' (feedForwardSet act) input layers


{-# LANGUAGE CPP, ForeignFunctionInterface #-}
-----------------------------------------------------------------------------
{- |
Module      :  Numeric.GSL.Polynomials
Copyright   :  (c) Alberto Ruiz 2006
License     :  GPL-style

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

Polynomials.

<http://www.gnu.org/software/gsl/manual/html_node/General-Polynomial-Equations.html#General-Polynomial-Equations>

-}
-----------------------------------------------------------------------------
module Numeric.GSL.Polynomials (
    polySolve
) where

import Data.Packed.Internal
import Data.Complex
import System.IO.Unsafe (unsafePerformIO)

#if __GLASGOW_HASKELL__ >= 704
import Foreign.C.Types (CInt(..))
#endif

{- | Solution of general polynomial equations, using /gsl_poly_complex_solve/. For example,
     the three solutions of x^3 + 8 = 0

@\> polySolve [8,0,0,1]
[(-1.9999999999999998) :+ 0.0,
 1.0 :+ 1.732050807568877,
 1.0 :+ (-1.732050807568877)]@

The example in the GSL manual: To find the roots of x^5 -1 = 0:

@\> polySolve [-1, 0, 0, 0, 0, 1]
[(-0.8090169943749475) :+ 0.5877852522924731,
(-0.8090169943749475) :+ (-0.5877852522924731),
0.30901699437494734 :+ 0.9510565162951536,
0.30901699437494734 :+ (-0.9510565162951536),
1.0 :+ 0.0]@

-}
polySolve :: [Double] -> [Complex Double]
polySolve = toList . polySolve' . fromList

polySolve' :: Vector Double -> Vector (Complex Double)
polySolve' v | dim v > 1 = unsafePerformIO $ do
    r <- createVector (dim v-1)
    app2 c_polySolve vec v vec r "polySolve"
    return r
             | otherwise = error "polySolve on a polynomial of degree zero"

foreign import ccall unsafe "gsl-aux.h polySolve" c_polySolve:: TVCV


module FourierPinwheel.Hypergeo1F1 where

import           Data.Complex
import           Data.List              as L
import           Math.Sequence.Converge

{-# INLINE hypergeom #-}
hypergeom ::
     (Eq a, RealFloat a, Enum a)
  => Complex a
  -> Complex a
  -> Complex a
  -> Complex a
hypergeom a b z =
  converge .
  scanl (+) 0 .
  scanl (*) 1 .
  L.map (\i -> (a + ((i - 1) :+ 0)) / (b + ((i - 1) :+ 0)) * z / (i :+ 0)) $
  [1 ..]