module Mnist (
    mnistRead,
    classesToLabels
  ) where

import Numeric.LinearAlgebra

mnistRead :: Int -> Matrix R -> (Matrix R, Matrix R)
mnistRead i m = (labelsToClasses i l, cmap (/ 255) x)
  where (l, x) = separateLabelAndFeature m

separateLabelAndFeature :: Matrix R -> (Matrix R, Matrix R)
separateLabelAndFeature m = (takeColumns 1 m, dropColumns 1 m)

labelsToClasses :: Int -> Matrix R -> Matrix R
labelsToClasses i = fromLists . fmap (labelToClass i . head) . toLists

labelToClass :: Int -> R -> [R]
labelToClass i l = fmap (\j -> if j == truncate l then 1 else 0) [0..i-1]

classesToLabels :: Matrix R -> Matrix R
classesToLabels = fromLists . fmap ((:[]) . classToLabel) . toLists

classToLabel :: [R] -> R
classToLabel = fromIntegral . maxIndex . vector


module MachineLearning.Classification.OneVsAllTest
(
  tests
)

where

import Test.Framework (testGroup)
import Test.Framework.Providers.HUnit
import Test.HUnit
import Test.HUnit.Approx
import Test.HUnit.Plus

import MachineLearning.Types
import qualified Data.Vector as V
import qualified Numeric.LinearAlgebra as LA

import MachineLearning.DataSets (dataset2)

import qualified MachineLearning as ML
import MachineLearning.Classification.OneVsAll
import MachineLearning.Classification.BinaryTest (testOptPath)

(x, y) = ML.splitToXY dataset2

processX muSigma x = ML.addBiasDimension $ ML.featureNormalization muSigma $ ML.mapFeatures 6 x

muSigma = ML.meanStddev (ML.mapFeatures 6 x)
x1 = processX muSigma x
zeroTheta :: Vector
zeroTheta = LA.konst 0 (LA.cols x1)

xPredict = LA.matrix 2 [ -0.5, 0.5
                       , 0.2, -0.2
                       , 1, 1
                       , 1, 0
                       , 0, 0
                       , 0, 1]
xPredict1 = processX muSigma xPredict
yExpected = LA.vector [1, 1, 0, 0, 1, 0]

eps = 0.000001

zeroThetam = replicate 2 zeroTheta
(thetaGDm, optPathGDm) = learn (GradientDescent 0.0001) eps 50 (L2 1) 2 x1 y zeroThetam
(thetaCGFRm, optPathCGFRm) = learn (ConjugateGradientFR 0.1 0.1) eps 50 (L2 0.5) 2 x1 y zeroThetam
(thetaCGPRm, optPathCGPRm) = learn (ConjugateGradientPR 0.1 0.1) eps 50 (L2 0.5) 2 x1 y zeroThetam
(thetaBFGSm, optPathBFGSm) = learn (BFGS2 0.1 0.1) eps 50 (L2 0.5) 2 x1 y zeroThetam

tests = [
  testGroup "learn" [
      testCase "Gradient Descent" $ assertVector "" 0.01 yExpected (predict xPredict1 thetaGDm)
      , testCase "Conjugate Gradient FR" $ assertVector "" 0.01 yExpected (predict xPredict1 thetaCGFRm)
      , testCase "Conjugate Gradient PR" $ assertVector "" 0.01 yExpected (predict xPredict1 thetaCGPRm)
      , testCase "BFGS" $ assertVector "" 0.01 yExpected (predict xPredict1 thetaBFGSm)
      ]
  , testGroup "optPath" [
      testCase "Gradient Descent" $ mapM_ testOptPath optPathGDm
      , testCase "Conjugate Gradient FR" $ mapM_ testOptPath optPathCGFRm
      , testCase "Conjugate Gradient PR" $ mapM_ testOptPath optPathCGPRm
      , testCase "BFGS" $ mapM_ testOptPath optPathBFGSm
      ]
  ]


{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE BlockArguments #-}
module AmpOp where

import Control.Monad.Fix

import Signal
import Circuit
import Data.Complex

type Input = Complex Double
type Output = Complex Double
type Value = Double
type Impedance = Signal (Complex Double)

dc12 :: Signal Input
dc12 = Signal $ const 12

dc14 :: Signal Input
dc14 = Signal $ const 14

dc100 :: Signal Input
dc100 = Signal $ const 100

sen :: Signal Input
sen = Signal $ \time -> 12 * sin ((pi / 2) * time)

outlet :: Signal Input
outlet = Signal $ \time -> 220 * sqrt 2 * sin (2 * pi * 60 * time)

ground :: Signal Input
ground = Signal $ const 0

data AmpOp = AmpOp { name :: String,
                     openLoopGain :: Signal (Complex Double),
                     manufacturer :: String
                }

data State =
  OneNode (Complex Double) |
  TwoNodes (Complex Double, Complex Double) |
  ThreeNodes (Complex Double, Complex Double, Complex Double) |
  FourNodes (Complex Double, Complex Double, Complex Double, Complex Double)

getOutput :: State -> Output
getOutput (OneNode x) = x
getOutput (TwoNodes (_,x)) = x
getOutput (ThreeNodes (_,_,x)) = x
getOutput (FourNodes (_,_,_,x)) = x

data SignalState =
  SignalOneNode (Signal (Complex Double)) |
  SignalTwoNodes (Signal (Complex Double), Signal (Complex Double)) |
  SignalThreeNodes (Signal (Complex Double), Signal (Complex Double), Signal (Complex Double)) |
  SignalFourNodes (Signal (Complex Double), Signal (Complex Double), Signal (Complex Double), Signal (Complex Double))
  deriving (Show)

getSignalOutput :: SignalState -> Signal Output
getSignalOutput (SignalOneNode x) = x
getSignalOutput (SignalTwoNodes (_,x)) = x
getSignalOutput (SignalThreeNodes (_,_,x)) = x
getSignalOutput (SignalFourNodes (_,_,_,x)) = x

instance Show AmpOp where
    show ap = Prelude.show "AmpOp => Name: " ++ Prelude.show (name ap)

lm741 :: AmpOp
lm741 = AmpOp "LM741" 200000 "Texas. Instruments"

r1 :: Impedance
r1 = 10000

r2 :: Impedance
r2 = 50000

r3 :: Impedance
r3 = 20000

r4 :: Impedance
r4 = 30000

eps = 0.000001

ampOpBuffer :: AmpOp -> SignalState -> Either String (Circuit Input SignalState)
ampOpBuffer model (SignalOneNode initial) =
    Right $ ($ initial) <$> mfix
    (\f -> Circuit $ \vIn -> Signal $ \time vOutOld ->
        let vOut = (vIn * openLoopGain model) / (1 + openLoopGain model)
        in if abs((realPart <$> vOut) - (realPart <$> vOutOld)) <= eps
            then SignalOneNode vOut
            else f vOut)
ampOpBuffer _ _ = Left "Wrong type for initial state!"

ampOpNonInverting :: AmpOp -> Impedance -> Impedance -> SignalState -> Either String (Circuit Input SignalState)
ampOpNonInverting model r1 r2 (SignalTwoNodes initial) =
    Right $ ($ initial) <$> mfix
    (\f -> Circuit $ \vIn -> Signal $ \time (vXOld, vOutOld) ->
        let vX = ((vIn * openLoopGain model) - vOutOld) / openLoopGain model
            vOut = (vXOld * (r1 + r2)) / r1
        in if abs((realPart <$> vOut) - (realPart <$> vOutOld)) <= eps && abs((realPart <$> vX) - (realPart <$> vXOld)) <= eps
            then SignalTwoNodes (vX, vOut)
            else f (vX, vOut))
ampOpNonInverting _ _ _ _ = Left "Wrong type for initial state!"

ampOpInverting :: AmpOp -> Impedance -> Impedance -> SignalState -> Either String (Circuit Input SignalState)
ampOpInverting model r1 r2 (SignalTwoNodes initial) =
    Right $ ($ initial) <$> mfix
    (\f -> Circuit $ \vIn -> Signal $ \time (vXOld, vOutOld) ->
        let vX = (- vOutOld) / openLoopGain model
            vOut = ((vXOld * (r1 + r2)) - (vIn * r2)) / r1
        in if abs((realPart <$> vOutOld) - (realPart <$> vOut)) <= eps && abs((realPart <$> vXOld) - (realPart <$> vX)) <= eps
            then SignalTwoNodes (vX, vOut)
            else f (vX, vOut))
ampOpInverting _ _ _ _ = Left "Wrong type for initial state!"

-- ampOpSpecial :: AmpOp -> Impedance -> Impedance -> Impedance -> Impedance -> SignalState -> Either String (Circuit Input SignalState)
-- ampOpSpecial model z1 z2 z3 z4 (SignalThreeNodes initial) =
--   Right $ ($ initial) <$> mfix
--   (\f -> Circuit $ \vIn -> Signal $ \time (vXOld, vKOld, vOutOld) ->
--       let vK = vOutOld + (vOutOld / openLoopGain model)
--           vX = ((z2 + z3) * vKOld) / z3
--           vOut = (((z2 * z4 + z1 * z4 + z1 * z2) * vXOld) - z1 * z4 * vKOld - z2 * z4 * vIn) / (z1 * z2)
--       in if abs((realPart <$> vOutOld) - (realPart <$> vOut)) <= eps
--           && abs((realPart <$> vKOld) - (realPart <$> vK)) <= eps
--           && abs((realPart <$> vXOld) - (realPart <$> vX)) <= eps
--           then SignalThreeNodes (vX, vK, vOut)
--           else f (vX, vK, vOut))

ampOpInvertingTest :: AmpOp -> Impedance -> Impedance -> SignalState -> Circuit Input SignalState
ampOpInvertingTest model r1 r2 (SignalTwoNodes initial) =
    ($ initial) <$> mfix
    (\f -> Circuit $ \vIn -> Signal $ \time (vXOld, vOutOld) ->
        let vX = (- vOutOld) / openLoopGain model
            vOut = ((vXOld * (r1 + r2)) - (vIn * r2)) / r1
        in if abs((realPart <$> vOutOld) - (realPart <$> vOut)) <= eps && abs((realPart <$> vXOld) - (realPart <$> vX)) <= eps
            then SignalTwoNodes (vX, vOut)
            else f (vX, vOut))

-- Calculating the output given a fixed input, to demonstrate the fix point only across the iteration axis
ampOpInverting' :: AmpOp -> Impedance -> Impedance -> Input -> State -> Either String Output
ampOpInverting' _ _ _ _ (OneNode _) = Left "Wrong type for initial state!"
ampOpInverting' model r1 r2 input (TwoNodes initial) = Right $ fix calculate initial
    where calculate f (vXOld, vOutOld) = if abs(realPart vOutOld - realPart vOut) <= 0.000001 && abs(realPart vXOld - realPart vX) <= 0.000001 then vOut else f (vX, vOut)
            where vX = (- vOutOld) / (openLoopGain model `at` 0)
                  vOut = (vXOld * (r1 + r2) `at` 0 - (input * r2 `at` 0)) / r1 `at` 0


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

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

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

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

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

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

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

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

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

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

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


-- | The method of moments can be used to estimate a number of commonly used distributions.  This module is still under construction as I work out the best way to handle morphisms from the Moments3 type to types of other distributions.  For more information, see the wikipedia entry: <https://en.wikipedia.org/wiki/Method_of_moments_(statistics)>

module HLearn.Models.Distributions.Univariate.Poisson
    ( Poisson
    )
    where

import Control.DeepSeq
import GHC.TypeLits
import qualified Data.Vector.Unboxed as U
import Data.Vector.Unboxed.Deriving

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

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

-------------------------------------------------------------------------------
-- Poisson

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

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

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

-- instance (Integral sample, Floating prob) => PDF (Poisson sample prob) where
--     pdf (Poisson dist) dp
--         | dp < 0    = 0
--         | dp > 100  = pdf (Normal $ Moments3 (fromIntegral $ m0 dist) (fromIntegral $ m1 dist) (fromIntegral $ m2 dist)) $ fromIntegral dp
--         | otherwise = (lambda^^dp)*(exp $ (-1)*lambda)/(fromIntegral $ factorial dp)
--         where
--             lambda = (fromIntegral $ m1 dist) / (fromIntegral $ m0 dist)
-- factorial :: (Integral a) => a -> a
-- factorial 0 = 1
-- factorial n = n*(factorial $ n-1)

instance (Integral sample, Floating prob) => PDF (Poisson sample Double) where
    pdf (Poisson dist) dp = S.probability (poisson lambda) $ fromIntegral dp
        where
            lambda = (fromIntegral $ m1 dist) / (fromIntegral $ m0 dist)

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

    plotType _ = Points

    samplePoints dist = [min..max]
        where
            min = 0
            max = maximum [20,floor $ 3*lambda]
            lambda = (fromIntegral $ m1 $ pmoments dist) / (fromIntegral $ m0 $ pmoments dist)

-- instance (Fractional prob) => Mean (Poisson sample prob) where
--     mean (Poisson dist) = (fromIntegral $ m1 $ pmoments dist) / (fromIntegral $ m0 $ pmoments dist)
--
-- instance (Fractional prob) => Variance (Poisson sample prob) where
--     variance dist = mean dist


{-# language TemplateHaskell #-}

{-# options_ghc -O0 #-}

module Main (main) where

import Data.Complex (Complex(..))

import Data.Primitive.PrimArray (PrimArray)
import qualified Data.Primitive.PrimArray as PA

import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

import Data.Primitive.Instances ()

import qualified Data.Primitive.Contiguous.FFT as CF
import qualified Numeric.MathFunctions.Comparison as MF

epsilon :: Double
epsilon = 0.0000000003

main :: IO Bool
main = checkParallel $$(discover)

prop_close :: Property
prop_close = property $ do
  x <- forAll genPrimArray
  let fft' = fft x
      {-# noinline fft' #-}
  let ifft' = ifft fft'
      {-# noinline ifft' #-}
  pwithin ifft' x === True

fft,ifft :: PrimArray (Complex Double) -> PrimArray (Complex Double)
fft = CF.fft
ifft = CF.ifft

pwithin :: PrimArray (Complex Double) -> PrimArray (Complex Double) -> Bool
pwithin xs ys = all (== True)
  $ zipWith within (PA.primArrayToList xs) (PA.primArrayToList ys)

within :: Complex Double -> Complex Double -> Bool
within (x :+ y) (x' :+ y') = abs (x - x') <= epsilon
  && abs (y - y') <= epsilon

genDouble :: Gen Double
genDouble = Gen.double (Range.linearFrac 5 200)

genComplex :: Gen (Complex Double)
genComplex = (:+) <$> genDouble <*> genDouble

genPrimArray :: Gen (PrimArray (Complex Double))
genPrimArray = PA.primArrayFromList <$> Gen.list (Range.singleton 8) genComplex


{-# LANGUAGE TypeOperators #-}

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

{-|
Module      : Numeric.LinearAlgebra.Combinators
Description : Compose matrices
Copyright   : (c) Ryan Orendorff, 2020
License     : BSD3
Stability   : experimental
-}
module Numeric.LinearAlgebra.Combinators
    ( blockMatrix
    )
where

import           GHC.TypeLits
import           Numeric.LinearAlgebra.Static

-- | Generate a block matrix from static matrices.
blockMatrix
    :: (KnownNat m, KnownNat n, KnownNat p, KnownNat q)
    => L m n             -- ^ Upper left matrix
    -> L m p             -- ^ Upper right matrix
    -> L q n             -- ^ Lower left matrix
    -> L q p             -- ^ Lower right matrix
    -> L (m + q) (n + p) -- ^ Resulting block matrix
blockMatrix a b c d = a ||| b === c ||| d


module Main where

import Control.Applicative
import Graphics.Rendering.Chart.Backend.Diagrams (toFile)
import qualified Graphics.Rendering.Chart.Easy as Plt
import Kalman
import Numeric.LinearAlgebra
import Sim

vanderPol = toFile Plt.def "VanderPol.svg" $ do
  let x0 = [1.4, 0]
  let q = diagl (replicate 2 0.0001)
  let r = diagl (replicate 2 0.5)
  let s0 = Estimate (vector [0, 5]) (diagl (replicate 2 5))

  let plant = Plant fA2 id fH2 id
  let sim = take 500 $ simulate plant (vector x0) 0
  let measurements = map snd sim
  let trajectory = map fst sim

  let sys = System fA2 fH2 q r
  let ekfs = scanl (ekf sys) s0 measurements
  let ukfs = scanl (ukf sys) s0 measurements

  let t1 = linspace 500 (0, 50 :: Double)
  let toPoints v = oneList (toList t1) $ map ((\[x] -> x) . toList . subVector 1 1) v

  Plt.plot (Plt.line "Plant" [toPoints trajectory])
  Plt.plot (Plt.line "UKF" [toPoints $ map sX ukfs])
  Plt.plot (Plt.line "EKF" [toPoints $ map sX ekfs])
  Plt.plot (Plt.line "Measurements" [toPoints measurements])

-- Plt.plot (Plt.line "LPF" [toPoints (movingAverage measurements)])

fA2 :: (Floating a) => [a] -> [a]
fA2 [x1, x2] = [x1 - x2 * dt, x2 + (- u * (1 - x1 ** 2) * x2 + x1) * dt]
  where
    u = 0.2
    dt = 0.1

fH2 :: (Floating a) => [a] -> [a]
fH2 [x1, x2] = [x1, x2]

oneList :: [a] -> [b] -> [(a, b)]
oneList [] _ = []
oneList (x : xs) (y : ys) = (x, y) : oneList xs ys

main = vanderPol


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

import Criterion.Config
import Criterion.Main
import Statistics.Distribution.Normal

import Statistics.Distribution.Normal
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as VU
import qualified Data.Vector.Generic as G

import Data.Array.Unboxed

import HLearn.Algebra
import HLearn.Models.Distributions
import HLearn.Models.Distributions.Moments
import HLearn.Models.Distributions.MultiNormal
-- import qualified HLearn.Models.Distributions.GaussianOld as GO
-- import qualified HLearn.Models.Distributions.GaussianOld2 as GO2

import qualified Control.ConstraintKinds as CK

-- comparing different types

{-size = 10^6
main = defaultMain
    [ bench "Moments Double" $ nf (train :: [Double] -> Moments Double) [(0::Double)..size]
    ]-}

myConfig = defaultConfig
    { cfgPerformGC = ljust True
    , cfgSamples = ljust 5
    }

size = 10^6
main = defaultMainWith myConfig (return ())
-- main = defaultMain
    [ bench "HLearn-MultiNormalVec 1" $ whnf (train :: [VU.Vector Double] -> MultiNormalVec 1 Double) $ map VU.fromList [ [l] | l <- [(0::Double)..fromIntegral size]]
    , bench "HLearn-MultiNormalVec 2" $ whnf (train :: [VU.Vector Double] -> MultiNormalVec 2 Double) $ map VU.fromList [ [l..l+1] | l <- [(0::Double)..fromIntegral size]]
    , bench "HLearn-MultiNormalVec 3" $ whnf (train :: [VU.Vector Double] -> MultiNormalVec 3 Double) $ map VU.fromList [ [l..l+2] | l <- [(0::Double)..fromIntegral size]]
    , bench "HLearn-MultiNormalVec 4" $ whnf (train :: [VU.Vector Double] -> MultiNormalVec 4 Double) $ map VU.fromList [ [l..l+3] | l <- [(0::Double)..fromIntegral size]]
    , bench "HLearn-MultiNormalVec 5" $ whnf (train :: [VU.Vector Double] -> MultiNormalVec 5 Double) $ map VU.fromList [ [l..l+4] | l <- [(0::Double)..fromIntegral size]]
    , bench "HLearn-MultiNormalVec 10" $ whnf (train :: [VU.Vector Double] -> MultiNormalVec 10 Double) $ map VU.fromList [ [l..l+9] | l <- [(0::Double)..fromIntegral size]]
    , bench "HLearn-MultiNormalVec 100" $ whnf (train :: [VU.Vector Double] -> MultiNormalVec 100 Double) $ map VU.fromList [ [l..l+99] | l <- [(0::Double)..fromIntegral size]]
    ]
-- [ bench "HLearn-MultiNormal-Vector" $ whnf
--         ((train :: [VU.Vector Double] -> MultiNormalVec 1 Double))
--         $ map VU.singleton [(0::Double)..fromIntegral size]
--     , bench "HLearn-MultiNormal" $ whnf
--         ((train :: [UArray Int Double] -> MultiNormal Double 1))
--         $ map (\x -> listArray (0,0) [x]) [(0::Double)..fromIntegral size]
--     ]

{-main = defaultMain
    [ bench "HLearn-GaussianCK" $ whnf
        (trainCK :: V.Vector Double -> Gaussian Double)
--         [(0::Double)..fromIntegral size]
        (V.enumFromN (0::Double) size)
    , bench "HLearn-Gaussian" $ whnf
        (train :: V.Vector Double -> Gaussian Double)
--         [(0::Double)..fromIntegral size]
        (V.enumFromN (0::Double) size)
    , bench "HLearn-Moments" $ whnf
        ((train :: V.Vector Double -> Moments Double))
        (V.enumFromN (0::Double) size)
    , bench "HLearn-MomentsSingleton" $ whnf
        ((train :: [VU.Vector Double] -> NormSingle Double))
        $ map VU.singleton [(0::Double)..fromIntegral size]
    , bench "HLearn-MultiNormal-Vector" $ whnf
        ((train :: [VU.Vector Double] -> MultiNormal2 1 Double))
        $ map VU.singleton [(0::Double)..fromIntegral size]
    , bench "HLearn-MultiNormal" $ whnf
        ((train :: [UArray Int Double] -> MultiNormal Double 1))
        $ map (\x -> listArray (0,0) [x]) [(0::Double)..fromIntegral size]
    ]

newtype NormSingle a = NormSingle (Moments a)
    deriving (Read,Show,Eq,Ord,Semigroup,Monoid)

instance Model (NoParams (NormSingle a)) (NormSingle a) where
    getparams _ = NoParams

instance DefaultModel (NoParams (NormSingle a)) (NormSingle a) where
    defparams = NoParams

instance (Num a, VU.Unbox a) => HomTrainer (NoParams (NormSingle a)) (VU.Vector a) (NormSingle a) where
    train1dp' params dp = NormSingle $ train1dp (dp VU.! 0)-}

-- size = 10^6
-- main = defaultMain
--     [ bench "Moments 2 Double" $ nf (train :: V.Vector Double -> Moments Double) (V.enumFromN (0::Double) size)
--     , bench "Moments 2 Float" $ nf (train :: V.Vector Float -> Moments Float) (V.enumFromN (0::Float) size)
--     , bench "Moments 2 Rational" $ nf (train :: V.Vector Rational -> Moments Rational) (V.enumFromN (0::Rational) size)
--     ]

{-main = defaultMain
    [ bench "HLearn-Gaussian" $ nf ((train :: VU.Vector Double -> Gaussian Double)) (VU.enumFromN (0::Double) size)
    , bench "HLearn-Gaussian-Parallel" $ whnf (parallel $ (train :: VU.Vector Double -> Gaussian Double)) (VU.enumFromN (0::Double) size)
--     , bench "HLearn-Gaussian-List" $ nf (train :: [Double] -> Gaussian Double) [0..fromIntegral size]
    , bench "statistics-Gaussian" $ whnf (normalFromSample . VU.enumFromN 0) (size)
    ]-}

    {-bench "batch train [] 1e6" $ nf ((batch train) GaussianParams) [0..1e6::Double]
--     , bench "batch train V 1e6"  $ nf ((batch train) GaussianParams) (V.enumFromN (0::Double) (10^6))
--     , bench "batch train VU 1e6" $ nf ((batch train) GaussianParams) (VU.enumFromN (0::Double) [0..1e6::Double])
--     , bench "parallel2 batch train [] 1e6" $ nf ((parallel $ batch train) GaussianParams) (V.enumFromN (0::Double) (10^7))
    ,-}
--     bench "Parallel GaussianOld2" $ nf (parallel $ batch (train GO2.GaussianParams)) (VU.enumFromN (0::Double) (10^8))
--     , bench "GaussianOld2" $ nf (batch (train GO2.GaussianParams)) (VU.enumFromN (0::Double) (10^8))
--     bench "Parallel GaussianOld" $ nf (parallel $ batch (train GO.GaussianParams)) (VU.enumFromN (0::Double) (10^8))
--     , bench "GaussianOld" $ nf (batch (train GO.GaussianParams)) (VU.enumFromN (0::Double) (10^8))
--      bench "Parallel Gaussian2" $ nf (parallel $ batch (train GaussianParams)) (VU.enumFromN (0::Double) (10^8))
--     , bench "Gaussian2" $ nf (batch (train GaussianParams)) (VU.enumFromN (0::Double) (10^8))

    {-bench "Parallel Gaussian" $ nf (parallel $ batch (trainSG)) (VU.enumFromN (0::Double) (10^8))
    , bench "Gaussian" $ nf (batch (trainSG)) (VU.enumFromN (0::Double) (10^8))
    ,-} -- bench "Categorical" $ nf (train :: [String] -> Categorical String Double) (concat $ replicate (10^4) ["a","b"])
--     , bench "normalFromSample - 1e5" $ whnf (normalFromSample . VU.enumFromN 1) (10^8)

-- instance NFData NormalDistribution where
--     rnf (NormalDistribution a b c d) = deepseq a $ deepseq b $ deepseq c $ rnf d

-- parallel3 strat train = \modelparams datapoint ->
--     foldl1 (<>) $ map (CK.foldl1 (<>) . CK.fmap (train modelparams . CK.pure)) (CK.partition 2 datapoint)

-- test (ds1,ds2) = m1 <> m2
--     where
--         [m1,m2] = parMap rdeepseq ((batch train) GaussianParams) [ds1,ds2]
-- --        [m1,m2] = parMap rdeepseq ((batch train) GaussianParams) [ds1,ds2]
--
-- -- test (ds1,ds2) = runEval $ do
-- --     let [m1,m2] = {-parMap rdeepseq-} map (batch train GaussianParams) [ds1,ds2]
-- -- --     m1 <- rparWith rseq $ batch train GaussianParams ds1
-- -- --     m2 <- rparWith rseq $ batch train GaussianParams ds2
-- -- {-    let m1 = batch train GaussianParams ds1
-- --     let m2 = batch train GaussianParams ds2-}
-- --     return $ m1 <> m2
--
-- dsL = replicate 4 ds
-- -- dsL = [ds1,ds2]
-- ds = [0..1000000::Double]
-- ds1 = V.enumFromN (0::Double) (10^7)
-- ds2 = V.enumFromN (0.5::Double) (10^7)


module Duck.Statistics where

import Duck.Types

import Data.Ord (comparing)
import Data.List (maximumBy, sortBy)
import qualified Data.Vector.Unboxed as UVec
import Statistics.Regression
import Test.QuickCheck (generate)

-- |Generates a list of instance sizes to be benchmarked.
genSizeList :: (Int, Int) -> Int -> [Int]
genSizeList (lo, hi) iter = take iter [lo, lo + step .. hi]
  where step = (hi - lo) `div` iter

-- |Generates multiple instance of given sizes to be benchmarked.
genInstances :: (Cased a) => [Int] -> IO [a]
genInstances [] = return []
genInstances (x:xs) = (:) <$>
                      (generate $ genCase x) <*>
                      (genInstances xs)

-- |Packs and unpacks lists to perform a linear regression
-- on data and return a error value and a proportionality constant.
regress :: [Double] -> [Double] -> (Double, Double)
regress ana exp = (const UVec.! 0, conf)
  where (const, conf) = olsRegress [UVec.fromList (ana)] (UVec.fromList exp)

-- |A grouping function to be used with 'testGroup'. It
-- filters out the statistically unrelevant results.
relevant :: [(Double, a)] -> [(Double, a)]
relevant = filter ((>= 0.98) . fst)

-- |A grouping function to be used with 'testGroup'. It
-- keeps only the maximum confidence result.
maxConf :: [(Double, a)] -> [(Double, a)]
maxConf ls = [maximumBy (comparing fst) ls]

-- |A grouping function to be used with 'testGroup'. It
-- keeps only the top 'sz' maximum confidence results.
topConf :: Int -> [(Double, a)] -> [(Double, a)]
topConf sz ls = take sz $ reverse $ sortBy (comparing fst) ls

-- |A grouping function to be used with 'testGroup'. It
-- keeps all results.
allConf :: [(Double, a)] -> [(Double, a)]
allConf = id


-----------------------------------------------------------------------------
-- |
-- Module      :  ForSyDe.Atom.Skel.Vector.DSP
-- Copyright   :  (c) George Ungureanu, KTH/EECS/ESY 2019-2020
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  ugeorge@kth.se
-- Stability   :  experimental
-- Portability :  portable
--
-- This module exports a set of 'Vector' patterns commonly used in signal processing
-- designs.
-----------------------------------------------------------------------------
module ForSyDe.Atom.Skel.Vector.DSP where

import Data.Complex
import qualified Data.Number.FixedFunctions as F
import ForSyDe.Atom.MoC as MoC
import ForSyDe.Atom.Skel.Vector as V hiding (duals, unduals)
import ForSyDe.Atom.Skel.Vector.Matrix as M
import ForSyDe.Atom ((><))

-- | Return the Taylor window. The Taylor window allows for a selectable sidelobe
-- suppression with a minimum broadening. This window is commonly used in radar
-- processing [1].  Code inspired from a <https://github.com/scipy/scipy/pull/8032 pull request for SciPy>.
--
-- Reference:
--
-- #ref1# [1] W. Carrara, R. Goodman, and R. Majewski "Spotlight Synthetic Aperture
-- Radar: Signal Processing Algorithms" Pages 512-513, July 1995.
taylor :: (Eq a, Floating a)
       => Int
       -- ^ number of points in the output window.
       -> Int
       -- ^ Number of nearly constant level sidelobes adjacent to the mainlobe
       -> a
       -- ^ Desired peak sidelobe level in decibels (db) relative to the mainlobe
       -> Vector a
       -- ^ The window, with the center value normalized to one (the value one appears
       -- only if the number of samples is odd).
taylor n nbar level = V.farm11 (*scale) w
  where
    -- explicit conversions to floating
    bN   = fromIntegral n
    nBar = fromIntegral nbar
    ma   = map fromIntegral [1 .. nbar-1]
    -- calculate intermediate values
    b  = 10**((-level) / 20)
    a  = log(b + sqrt(b**2 - 1)) / pi
    s2 = nBar ** 2 / (a**2 + (nBar - 0.5)**2)
    -- functions for calculating coefficients
    fmcalc m  = let numer = (-1)**(m+1) * product[1.0 - m**2/s2/(a**2 + (j - 0.5)**2) | j <- ma]
                    denom = 2 * product[1 - m**2/j**2 | j <- ma, j /= m]
                in numer / denom
    ccalc m x = cos(2 * pi * x * (m - bN/2 + 1/2) / bN)
    wcalc m   = 2 * dotvv (vector $ map fmcalc ma) (vector $ map (ccalc m) ma) + 1
    -- calculate window coefficients
    w  = vector $ map (wcalc . fromIntegral) [0..n-1]
    -- normalize (Note that this is not described in the original text [1])
    scale = 1 / wcalc (bN - 1) / 2

-- (*^*) :: (RealFrac a, RealFrac b) => a -> b -> a
-- x *^* y = realToFrac $ realToFrac x ** realToFrac y

-- | Returns a Taylor window with default arguments: 4 sidelobes, and peak sidelobe level of -30dB
taylor' n = taylor 4 (-30)

-- | Calculates the dot product between two vectors.
dotvv :: Num a => Vector a -> Vector a -> a
dotvv a b
  | V.length a == V.length b = V.reduce (+) (V.farm21 (*) a b)
  | otherwise                = error "Vector sizes must match"

-- | Calculates the dot product between a vector and a matrix
dotvm :: Num a => Vector a -> Vector (Vector a) -> Vector a
dotvm = dotvm' (+) (*)

-- | Higher order version of 'dotvv'. Applies dot product on vectors of /structured/
-- /types/, e.g. 'Signal's. See 'dotvv'.
dotvv' :: Num a
     => ((a -> a -> a) -> f a -> f a -> f a)
     -- ^ higher-order function that can wrap the (*) operation.
     -> Vector (f a) -> Vector (f a) -> f a
dotvv' wrap a b
  | V.length a == V.length b = V.reduce (wrap (+)) $ V.farm21 (wrap (*)) a b
  | otherwise                = error "Vector sizes must match"

-- | Higher order version of 'dotvm'. Implements the template for a dot operation
-- between a vector and a matrix.
--
-- >>> let mA = vector [vector[1,-1,1],  vector[1,-1,-1],  vector[1,1,-1],  vector[1,1,1]]
-- >>> let y  = vector[1,0,0,0]
-- >>> dotVecMat (+) (*) mA y
-- <1,1,1,1>
dotvm' :: (b -> b -> b)     -- ^ kernel function for a row/column reduction, e.g. @(+)@ for dot product
       -> (a -> b -> b)     -- ^ binary operation for pair-wise elements, e.g. @(*)@ for dot product
       -> Vector a          -- ^ /length/ = @xa@
       -> Vector (Vector b) -- ^ /size/ = @(xa,ya)@
       -> Vector b          -- ^ /length/ = @ya@
dotvm' f g vs = V.reduce (V.farm21 f) . V.farm21 (\x -> V.farm11 (g x)) vs

-- | Higher order pattern implementing the template for a dot operation between a
-- vector and a matrix.
--
-- >>> let mA = vector [vector[1,-1,1],  vector[1,-1,-1],  vector[1,1,-1],  vector[1,1,1]]
-- >>> let y  = vector[1,0,0,0]
-- >>> dotVecMat (+) (*) mA y
-- <1,1,1,1>
dotmv' :: (a -> a -> a)
       -- ^ kernel function for a row/column reduction, e.g. @(+)@ for dot product
       -> (b -> a -> a)
       -- ^ binary operation for pair-wise elements, e.g. @(*)@ for dot product
       -> Vector (Vector b) -- ^ /size/ = @(xa,ya)@
       -> Vector a      -- ^ /length/ = @xa@
       -> Vector a      -- ^ /length/ = @xa@
dotmv' f g mA y = V.farm11 (\x -> V.reduce f $ V.farm21 g x y) mA

-- | Compute a Hanning window.
--
-- Inspired from <https://hackage.haskell.org/package/sdr-0.1.0.6/src/hs_sources/SDR/FilterDesign.hs>
hanning :: (Floating n)
        => Int -- ^ The length of the window
        -> Vector n
hanning size = V.farm11 func $ V.vector [0..size-1]
  where
    func idx = let i = fromIntegral idx
                   n = fromIntegral size
               in 0.5 * (1 - cos((2 * pi * i) / (n - 1)))

-- | Compute a Hamming window.
--
-- Inspired from <https://hackage.haskell.org/package/sdr-0.1.0.6/src/hs_sources/SDR/FilterDesign.hs>
hamming :: (Floating n)
        => Int -- ^ The length of the window
        -> Vector n
hamming size = V.farm11 func $ V.vector [0..size-1]
  where
    func idx = let i = fromIntegral idx
                   n = fromIntegral size
               in 0.54 - 0.46 * cos((2 * pi * i) / (n - 1))

-- | Compute a Blackman window.
--
-- Inspired from <https://hackage.haskell.org/package/sdr-0.1.0.6/src/hs_sources/SDR/FilterDesign.hs>
blackman :: (Floating n)
        => Int -- ^ The length of the window
        -> Vector n
blackman size = V.farm11 func $ V.vector [0..size-1]
  where
    func idx = let i = fromIntegral idx
                   n = fromIntegral size
               in 0.42 - 0.5 * cos((2 * pi * i) / (n - 1)) + 0.08 * cos((4 * pi * i) / (n - 1))

-- | Moving average filter (FIR) on numbers, applied in reverse order (more
-- optimized).
--
-- >>> let v = vector [0,0,0,0,0,1]
-- >>> let c = vector [1,2,3]
-- >>> fir c
-- <0,0,0,3,2,1>
fir :: Num a
    => Vector a  -- ^ vector of coefficients
    -> Vector a  -- ^ input vector of numbers; /size/ = @n@
    -> Vector a  -- ^ output vector of numbers; /size/ = @n@
fir coefs = V.reverse . V.farm11 applyFilter . tails . V.reverse
  where
    applyFilter = V.reduce (+) . V.farm21 (*) coefs

-- | Higher order version of 'fir'. Can create a systolic FIR process network. See
-- <ForSyDe-Atom.html#ungureanu20a [Ungureanu20a]> for a discussion on the relation
-- between 'fir' and 'fir''.
--
-- >>> let c = vector [1,2,3]
-- >>> let s = SY.signal [1,0,0,0,0,0,0,0]
-- >>> fir' (SY.comb21 (+)) (\c -> SY.comb11 (*c)) (SY.delay 0) c s
-- {3,2,1,0,0,0,0,0}
fir' :: (a -> a -> a)  -- ^ process/operation replacing '+'
     -> (c -> a -> a)  -- ^ process/operation replacing '*'
     -> (a -> a)       -- ^ delay process
     -> Vector c       -- ^ vector of coefficients
     -> a              -- ^ input signal/structure
     -> a              -- ^ output signal/structure
fir' plus times delay coefs =
  -- V.reduce plus . V.farm21 (\c -> times c) coefs . V.recur (V.fanoutn n delay <: id)
  V.reduce plus . V.farm21 times coefs . V.recuri (V.fanoutn n delay)
  where n = V.length coefs - 1

-- | generates the "twiddle" coefficients for a FFT network.
twiddles :: Floating a => Int -> V.Vector (Complex a)
twiddles bN = (bitrev . V.take (bN `div` 2)) (V.farm11 bW $ vector [0..])
  where bW x = (cis . negate) (-2 * pi * fromIntegral x / fromIntegral bN)

-- | Radix-2 decimation-in-frequecy Fast Fourier Transform, applied on numbers.  For
-- the difference between DIT- and DIF-FFT, see
-- <https://www.slideshare.net/chappidi_saritha/decimation-in-time-and-frequency>
fft :: RealFloat a
    => Int -- ^ number of FFT stages (@== log_2@ of /length/ of input vector)
    -> V.Vector (Complex a) -> V.Vector (Complex a)
fft k vs | n == 2^k = V.reverse $ bitrev $ (stage `V.pipe1` V.iterate k (*2) 2) vs
         | otherwise = error $ "n=" ++ show n ++ "; k=" ++ show k
  where
    stage   w = V.concat . V.farm21 segment (twiddles n) . V.group w
    segment t = (><) unduals . (><) (V.farm22 (butterfly t)) . duals
    n         = V.length vs        -- length of input
    -------------------------------------------------
    butterfly w x0 x1 = let t = w * x1 in (x0 + t, x0 - t) -- kernel function

-- | Higher order version of 'fft'. Takes the "butterfly" function as argument.
--
-- > butterfly w x0 x1 = let t = w * x1 in (x0 + t, x0 - t)
-- > fft' butterfly === fft
fft' :: Floating a
     => (Complex a -> a -> a -> (a, a)) -- ^ "butterfly" function.
     -> Int  -- ^ number of FFT stages (@== log_2@ of /length/ of input vector)
     -> V.Vector a -> V.Vector a
fft' butterfly k vs | n == 2^k = bitrev $ (stage `V.pipe1` (V.iterate k (*2) 2)) vs
  where
    stage   w = V.concat . V.farm21 segment (twiddles n) . V.group w
    segment t = (><) unduals . (><) (V.farm22 (butterfly t)) . duals
    n         = V.length vs        -- length of input

-- | splits a vector in two equal parts.
--
-- >>> duals $ vector [1,2,3,4,5,6,7]
-- (<1,2,3>,<4,5,6>)
duals    :: Vector a -> (Vector a, Vector a)
duals v  = (V.take k v, V.drop k v)
  where k = V.length v `div` 2

-- | concatenates a previously split vector. See also 'duals'
unduals  :: Vector a -> Vector a -> Vector a
unduals x y =  x <++> y

-- | performs a bit-reverse permutation.
--
-- <<fig/skel-vector-comm-bitrev.png>>
-- <<fig/skel-vector-comm-bitrev-net.png>>
--
-- >>> bitrev $ vector ["000","001","010","011","100","101","110","111"]
-- <"111","011","101","001","110","010","100","000">
bitrev (x:>Null) = V.unit x
bitrev xs        = bitrev (evens xs) <++> bitrev (odds xs)

-- duals   v = let k = length v `div` 2
--             in  S.farm22 (,) (take k v) (drop k v)

-- unduals = (<++>)

-- fft n = V.vector . map (fmap realToFrac) . Sh.fromVector . ShDSP.fft (2^n) . Sh.vector . map (fmap realToFrac) . V.fromVector


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeOperators #-}

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

{-|
Module      : Numeric.LinearAlgebra.MatrixFree.Static
Description : Compose matrix-free linear maps
Copyright   : (c) Ryan Orendorff, 2020
License     : BSD3
Stability   : experimental

Enables the user to compose matrix-free `LinearMap` objects in the same way
that one would compose regular matrices.
-}
module Numeric.LinearAlgebra.MatrixFree.Combinators
    ( (===)
    , (|||)
    , blockMatrix
    , blockDiag
    , LinearMapList(..)
    , applyLinearMapList
    )
where

import           GHC.TypeLits
import           Numeric.LinearAlgebra          ( Transposable(..) )
import           Numeric.LinearAlgebra.Static   ( (#)
                                                , split
                                                , R
                                                )
import           Numeric.LinearAlgebra.MatrixFree
                                                ( LinearMap(..), (##>))
import           Numeric.LinearAlgebra.Static.RList (Sum, RList(..))

-- Stacking matrices either horizontally or vertically are linked through a
-- transpose, so the underlying functions are shared between the two
-- stacking cases. Only in a switched order.
stackLinearMaps :: (KnownNat m, KnownNat n)
                => LinearMap m p -> LinearMap n p -> R p -> R (m + n)
stackLinearMaps la lb v = la ##> v # lb ##> v

addLinearMaps :: (KnownNat n, KnownNat p)
              => LinearMap m n -> LinearMap m p -> R (n + p) -> R m
addLinearMaps la lb v = let (v1, v2) = split v in la ##> v1 + lb ##> v2

-- | Vertically concatenate two `LinearMap`s \(\begin{bmatrix}A\\B\end{bmatrix}\)
(===) :: (KnownNat m, KnownNat n, KnownNat p)
      => LinearMap m n -> LinearMap p n -> LinearMap (m + p) n
(===) la lb = LinearMap (stackLinearMaps la lb) (addLinearMaps (tr la) (tr lb))

infixl 2 ===

-- | Horizontally concatenate two `LinearMap`s \(\begin{bmatrix}A&B\end{bmatrix}\)
(|||) :: (KnownNat m, KnownNat n, KnownNat p)
      => LinearMap m n -> LinearMap m p -> LinearMap m (n + p)
(|||) la lb = tr (tr la === tr lb)

infixl 3 |||

-- | Generate a block matrix from four `LinearMap`s
-- \[
-- \begin{bmatrix}
--   A & B \\
--   C & D
-- \end{bmatrix}
-- \]
blockMatrix
    :: (KnownNat m, KnownNat n, KnownNat p, KnownNat q)
    => LinearMap m n             -- ^ Upper left matrix
    -> LinearMap m p             -- ^ Upper right matrix
    -> LinearMap q n             -- ^ Lower left matrix
    -> LinearMap q p             -- ^ Lower right matrix
    -> LinearMap (m + q) (n + p) -- ^ Resulting block matrix
blockMatrix a b c d = a ||| b === c ||| d

-- | A non-empty list of "LinearMap" matrices of different sizes.
data LinearMapList (ms :: [Nat]) (ns :: [Nat]) where
    LOne :: (KnownNat m, KnownNat n) => LinearMap m n -> LinearMapList '[m] '[n]
    (:-:) :: (KnownNat m, KnownNat n) => LinearMap m n -> LinearMapList ms ns
                                      -> LinearMapList (m ': ms) (n ': ns)

-- | Concatenate a "LinearMapList" of "LinearMap"s as a block diagonal.
-- Note that this has poor performance; it runs `split` on the
-- input vector O(n) times, where n is the number of entries in the list.
blockDiag :: LinearMapList ms ns -> LinearMap (Sum ms) (Sum ns)
blockDiag ls = case blockDiagWorker ls of
  LWorker lsW -> lsW

data LWorker m n where
  LWorker :: (KnownNat m, KnownNat n) => LinearMap m n -> LWorker m n

blockDiagWorker :: LinearMapList ms ns -> LWorker (Sum ms) (Sum ns)
blockDiagWorker (LOne l) = LWorker l
blockDiagWorker (l :-: ls) = case blockDiagWorker ls of
  LWorker lsW -> LWorker (diag2 l lsW)

-- Combine two `LinearMap`s on a diagonal without having to use
-- konst 0, which would just be a waste of processing time (sum a list and
-- multiply it by zero)
diag2 :: (KnownNat m, KnownNat n, KnownNat p, KnownNat q)
      => LinearMap m n
      -> LinearMap p q
      -> LinearMap (m + p) (n + q)
diag2 la lb = LinearMap (f la lb) (f (tr la) (tr lb))
  where
    f :: (KnownNat m', KnownNat n', KnownNat p', KnownNat q')
      => LinearMap m' n' -> LinearMap p' q' -> R (n' + q') -> R (m' + p')
    f l1 l2 v = let (v1, v2) = split v in
      (l1 ##> v1) # (l2 ##> v2)

-- | Apply a list of "LinearMap"s over a list of static vectors
applyLinearMapList :: LinearMapList ms ns -> RList ns -> RList ms
applyLinearMapList (LOne _) (_ ::: _) = error "This case is impossible"
applyLinearMapList (_ :-: _) (ROne _) = error "This case is impossible"
applyLinearMapList (LOne l) (ROne r) = ROne (l ##> r)
applyLinearMapList (l :-: ls) (r ::: rs) = (l ##> r) ::: applyLinearMapList ls rs


module Statistics.Information.Continuous.MutualInfo where

import Data.Matrix
import Numeric.SpecFunctions
import Statistics.Information.Utils.KNN
import Statistics.Information.Utils.Random
import System.Random

mi :: RandomGen g => g -> Int -> Int -> Matrix Double -> Matrix Double -> Double
mi g k base xs ys | (k < nrows xs) && (nrows xs == nrows ys) =
  (-a - b + c + d) / (log $ fromIntegral base)
  where
    (g1, g2) = split g
    noisyxs = noisy g1 xs
    noisyys = noisy g2 ys
    joint = noisyxs <|> noisyys
    distances = knnDistances chebyshevDistance (toLists joint) k
    a = avgdigamma chebyshevDistance noisyxs distances
    b = avgdigamma chebyshevDistance noisyys distances
    c = digamma (fromIntegral k)
    d = digamma . fromIntegral . nrows $ xs

cmi :: RandomGen g => g -> Int -> Int -> Matrix Double -> Matrix Double ->
       Matrix Double -> Double
cmi g k base xs ys zs | (k < nrows xs) && (nrows xs == nrows ys) =
  (-a - b + c + d) / (log $ fromIntegral base)
  where
    [g1, g2, g3] = splitN 3 g
    noisyxs = noisy g1 xs
    noisyys = noisy g2 ys
    noisyzs = noisy g3 zs
    joint = noisyxs <|> noisyys <|> noisyzs
    distances = knnDistances chebyshevDistance (toLists joint) k
    a = avgdigamma chebyshevDistance (noisyxs <|> noisyzs) distances
    b = avgdigamma chebyshevDistance (noisyys <|> noisyzs) distances
    c = avgdigamma chebyshevDistance noisyzs distances
    d = digamma (fromIntegral k)


{-# LANGUAGE StandaloneDeriving #-}
module Examples.Quantum where

import LAoP.Utils
import LAoP.Matrix.Type
import Data.Complex
import Prelude hiding (id, (.))

deriving instance Ord a => Ord (Complex a)

xor :: (Bool, Bool) -> Bool
xor (False, b) = b
xor (True, b) = not b

ker :: Num e => Matrix e a b -> Matrix e a a
ker m = tr m . m

cnot :: Matrix (Complex Double) (Bool, Bool) (Bool, Bool)
cnot = kr fstM (fromF xor)

ccnot :: (Num e, Ord e) => Matrix e ((Bool, Bool), Bool) ((Bool, Bool), Bool)
ccnot = kr fstM (fromF f)
  where
    f = xor . tp (uncurry (&&)) id
    tp f g (a,b) = (f a, g b)

had :: Matrix (Complex Double) Bool Bool
had = (1/sqrt 2) .| fromLists [[1, 1], [1, -1]]

bell :: Matrix (Complex Double) (Bool, Bool) (Bool, Bool)
bell = cnot . (had >< iden)


module Main where

import qualified Numeric.LinearAlgebra as LA
import qualified MachineLearning.Types as T
import qualified MachineLearning as ML
import qualified MachineLearning.Classification.Binary as CB
import qualified MachineLearning.Classification.OneVsAll as OVA
import qualified MachineLearning.TerminalProgress as TP
import qualified MachineLearning.Optimization as Opt
import MachineLearning.MultiSvmClassifier
import MachineLearning.SoftmaxClassifier

featuresMapParameter = 2

-- processFeatures :: T.Matrix -> T.Matrix
processFeatures muSigma = ML.addBiasDimension . ML.featureNormalization muSigma . ML.mapFeatures featuresMapParameter

calcAccuracy :: (Model a) => a -> T.Matrix -> T.Vector -> T.Vector -> Double
calcAccuracy m x y theta = OVA.calcAccuracy y yPredicted
  where yPredicted = hypothesis m x theta

main = do
  putStrLn "\n=== Optical Recognition of Handwritten Digits Data Set ===\n"
  -- Step 1. Data loading.
  -- Step 1.1 Training Data loading.
  (x, y) <- pure ML.splitToXY <*> LA.loadMatrix "digits_classification/optdigits.tra"
  -- Step 1.1 Testing Data loading.
  (xTest, yTest) <- pure ML.splitToXY <*> LA.loadMatrix "digits_classification/optdigits.tes"

  -- Step 2. Outputs and features preprocessing.
  let numLabels = 10
      svm = MultiClass $ MultiSvm 1 numLabels
      softmax = MultiClass $ Softmax numLabels
      muSigma = ML.meanStddev (ML.mapFeatures featuresMapParameter x)
      x1 = processFeatures muSigma x
      xTest1 = processFeatures muSigma xTest
      initialTheta = LA.konst 0.1 (numLabels*(LA.cols x1))
  print $ LA.size x1
  print $ LA.size $ x1 LA.? [1..10]
  -- Step 3. Learning.
  putStrLn "Learning Multi SVM model..."
  (thetaSvm, optPathSvm) <- TP.learnWithProgressBar (Opt.minimize (Opt.BFGS2 0.01 0.7) svm 0.0001 5 (CB.L2 2) x1 y) initialTheta 20

  putStrLn "\nLearning MGD Softmax model"
  --(thetaSm, optPathSm) <- TP.learnWithProgressBar (Opt.minimize (Opt.BFGS2 0.01 0.7) softmax 0.000001 5 1 x1 y) initialTheta 20
  (thetaSm, optPathSm) <- TP.learnWithProgressBar (Opt.minimize (Opt.MinibatchGradientDescent 0 1024 0.01) svm 0.000001 200 (CB.L2 1) x1 y) initialTheta 20

  putStrLn "\nLearning GD Softmax model"
  (thetaSmGD, optPathSmGD) <- TP.learnWithProgressBar (Opt.minimize (Opt.GradientDescent 0.01) softmax 0.000001 50 (CB.L2 1) x1 y) initialTheta 20

  -- Step 4. Prediction and checking accuracy
  let accuracyTrainSvm = calcAccuracy svm x1 y thetaSvm
      accuracyTestSvm = calcAccuracy svm xTest1 yTest thetaSvm

  -- Step 5. Printing results.
  putStrLn $ "\nSVM: Number of iterations to learn: " ++ show (LA.rows optPathSvm)

  putStrLn $ "SVM: Accuracy on train set (%): " ++ show (accuracyTrainSvm*100)
  putStrLn $ "SVM: Accuracy on test set (%): " ++ show (accuracyTestSvm*100)

  let accuracyTrainSm = calcAccuracy softmax x1 y thetaSm
      accuracyTestSm = calcAccuracy softmax xTest1 yTest thetaSm

  -- Step 5. Printing results.
  putStrLn $ "\nSoftmax: Number of iterations to learn: " ++ show (LA.rows optPathSm)

  putStrLn $ "Softmax: Accuracy on train set (%): " ++ show (accuracyTrainSm*100)
  putStrLn $ "Softmax: Accuracy on test set (%): " ++ show (accuracyTestSm*100)

  let accuracyTrainSmGD = calcAccuracy softmax x1 y thetaSmGD
      accuracyTestSmGD = calcAccuracy softmax xTest1 yTest thetaSmGD

  -- Step 5. Printing results.
  putStrLn $ "\nGD Softmax: Number of iterations to learn: " ++ show (LA.rows optPathSmGD)

  putStrLn $ "GD Softmax: Accuracy on train set (%): " ++ show (accuracyTrainSmGD*100)
  putStrLn $ "GD Softmax: Accuracy on test set (%): " ++ show (accuracyTestSmGD*100)


{-# LANGUAGE ScopedTypeVariables #-}

module Jakway.Blackjack.Random.Checks
(
testDeckEvenDistribution,
testRNGDistribution
)
where

import qualified Statistics.Test.Types as Stats
import qualified Statistics.Test.ChiSquared as Stats
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Unboxed.Mutable as UM
import System.Random
import Jakway.Blackjack.AI
import Jakway.Blackjack.CardOps
import Jakway.Blackjack.Game
import Data.Hashable
import Control.Monad (foldM)
import Data.List (genericReplicate, genericTake)

deck_value_range :: Int
deck_value_range = 104 -- ^ 52 cards plus the visibility flag

-- |record a new observation, updating the U.Vector in place
deckToObservation :: U.Vector Int -> Deck -> U.Vector Int
deckToObservation vec deck = U.modify (\v -> UM.write v index newCount) vec
        where vecRange = U.length vec
              index = (`mod` vecRange) . hash $ (deck !! 13) -- ^ we've arbitrarily chosen the position to take a card from
              newCount = (vec U.! index) + 1

vecIncrement :: U.Vector Int -> Int -> U.Vector Int
vecIncrement v pos = U.modify (\mv -> UM.write mv pos newCount) v
        where newCount = (v U.! pos) + 1

newDeckIO :: IO Deck
newDeckIO = getStdGen >>= return . infiniteShuffledDeck

observeDeck :: Integer -> AI -> [AI] -> IO (U.Vector Int)
observeDeck numSamples dealerAI playerAIs =
        foldM (\vec _ -> newDeckIO >>= (\d -> (return $ evalGameKeepDeck dealerAI playerAIs d) >>= (\maybeDeck ->
                                case maybeDeck of Nothing -> return vec
                                                  -- | modify the list of observations and return it
                                                  (Just (resDeck,_)) -> return $ deckToObservation vec resDeck))) samplesVec [1..numSamples]

        where samplesVec = (U.fromList (replicate deck_value_range 0)) :: U.Vector Int

testDeckEvenDistribution :: Double -> Integer -> AI -> [AI] -> IO Stats.TestResult
testDeckEvenDistribution pvalue numSamples dealerAI playerAIs = do
        observations <- observeDeck numSamples dealerAI playerAIs
        return $ Stats.chi2test pvalue additionalDF (evenDistribution observations)
        where additionalDF = 0

testRNGDistribution :: Double -> Integer -> Integer -> Integer -> AI -> [AI] -> IO Stats.TestResult
testRNGDistribution pvalue numSamples numRNGSamples rngMaxRange dealerAI playerAIs = getStdGen >>= (\gen -> observeDeck numSamples dealerAI playerAIs >>= \samples -> return $ Stats.chi2test pvalue 0 $ rngDistribution numRNGSamples rngMaxRange gen samples)

--instead of testing against an even distribution, test against the
--distribution of the default StdGen

rngDistribution :: (RandomGen g) => Integer -> Integer -> g -> U.Vector Int -> U.Vector (Int, Double)
rngDistribution numRngObservations maxr gen observed = U.zip observed percents
        where -- how many observations to get the standard RNG
              -- distribution?
              startingVec = (U.fromList (genericReplicate maxr 0)) :: U.Vector Int
              rngObservations = genericTake numRngObservations $ randomRs (0, maxr) gen -- ^ lower bound on random numbers is 0
              -- |increment the count for this observation
              rngObservationCounts = foldr (\thisObservation vec -> vecIncrement vec thisObservation) startingVec $ map fromIntegral rngObservations
              -- |the distribution as a percent for each bin (i.e. a list
              -- of doubles)
              percents :: U.Vector Double
              percents = U.map (\o -> (fromIntegral o) / (fromIntegral numRngObservations)) rngObservationCounts

-- |Takes as input a set of bins with the number of observations in each
-- returns the set of bins you would expect given an even distribution
-- across all bins zipped with the observed values
evenDistribution :: U.Vector Int -> U.Vector (Int, Double)
evenDistribution observed = U.zip observed expectedObservations
        where numBins = U.length observed
              totalObservations = fromIntegral . U.sum $ observed
              expectedObservations = U.fromList $ replicate numBins (totalObservations / (fromIntegral numBins))


{-# LANGUAGE CPP                       #-}
{-# LANGUAGE ConstraintKinds           #-}
{-# LANGUAGE FlexibleContexts          #-}

module TSA

where

import Control.Monad.IO.Class
import Data.Attoparsec.ByteString.Char8
import Data.CSV.Conduit
import Data.Maybe
#if MIN_VERSION_base(4,11,0)
#else
import Data.Monoid
#endif

import qualified Data.Vector.Unboxed as V
import qualified Data.Vector as VB
import qualified Statistics.Regression as S
import qualified Statistics.Sample as S

#ifdef WITH_IHASKELL
import Control.Lens
import Graphics.Rendering.Chart.Easy as Chart

import qualified Statistics.Autocorrelation as S
import qualified Statistics.Sample.Histogram as S
#endif

type Series e = V.Vector e

loadSeries :: MonadIO m
           => FilePath
           -- ^ CSV file name.
           -> Int
           -- ^ Index of column to use (1-based).
           -> m (Series Double)
loadSeries fname col = do
  r <- readCSVFile defCSVSettings fname
  return $ V.convert $ flip VB.mapMaybe r $
    \row -> (either (const Nothing) Just . parseOnly double) =<< row VB.!? col

diff :: (Num e, V.Unbox e)
     => Int
     -- ^ Differencing period.
     -> Series e
     -> Series e
diff n series = V.zipWith (-) (V.drop n series) series

-- | Model is a forecasting function.
--
-- If the argument is Nothing, predict existing values.
type Model e = Maybe Int -> Series e -> Series e
{-@ type Model' e = Maybe Nat -> Series e -> Series e @-}

-- | Predict N next points for a time series.
{-@ forecast :: Nat -> Model' e -> Series e -> Series e @-}
forecast :: Int -> Model e -> Series e -> Series e
forecast periods f = f $ Just periods

{-@ extendBy :: Nat -> Model' e -> Series e -> Series e @-}
extendBy :: V.Unbox e => Int -> Model e -> Series e -> Series e
extendBy periods f s = s <> forecast periods f s

{-@ mean :: Model' Double @-}
mean :: Model Double
mean n s = V.replicate n' $ S.mean s
  where
    n' = fromMaybe (V.length s) n

{-@ linearTrend :: Model' Double @-}
linearTrend :: Model Double
linearTrend n s = V.iterateN n' (+ slope) start
  where
    n' = fromMaybe len n
    len = V.length s
    (coeffs, _) = S.olsRegress [V.generate len fromIntegral] s
    (slope, bias) = (coeffs V.! 0, coeffs V.! 1)
    start = fromIntegral (maybe 0 (const len) n) * slope + bias

residuals :: (Num e, V.Unbox e) => Model e -> Series e -> Series e
residuals f s = V.zipWith (-) s (f Nothing s)

#ifdef WITH_IHASKELL
plotResiduals :: Model Double -> Series Double -> Renderable ()
plotResiduals f s = toRenderable $ do
  layout_title .= "Residuals"
  layout_legend .= Nothing
  Chart.plot $ plotBars <$> do
    b <- bars (map show $ V.toList sizes) (map (\(x, y) -> (x, [y :: Int])) barData)
    return $ b & plot_bars_spacing .~ BarsFixGap 0 5
  where
    barData = V.toList $ V.zip bins sizes
    -- TODO Customize bin count?
    (bins, sizes) = S.histogram 20 $ residuals f s

plotACF :: Int -> Series Double -> Renderable ()
plotACF maxLag s = toRenderable $ do
  layout_title .= "Autocorrelation"
  layout_legend .= Nothing
  layout_x_axis . laxis_title .= "Lag"
  -- Do not skip X values
  layout_x_axis . laxis_override .= (axis_labels .~ [[ (lag, show lag) | lag <- lags ]])
  Chart.plot $ plotBars <$>
    bars (map show lags) (map (\lag -> (lag, [acf V.! lag])) lags)
  where
    (acf, _, _) = S.autocorrelation s
    lags = [1 .. maxLag]

plotPredictions :: (PlotValue e, V.Unbox e)
                => Int
                -- ^ Forecast that many future points.
                -> Model e
                -> Series e
                -> Renderable ()
plotPredictions periods f s = toRenderable $ do
  Chart.setColors [opaque blue, red `withOpacity` 50, opaque red]
  Chart.plot $ line "Series" [zip [(0::Int)..] (V.toList s)]
  mapM_ (plotWithRadius 5)
    [ points "Predictions" $ zip [(0::Int)..] (V.toList $ f Nothing s)
    , points "Forecast" $ zip [V.length s..] (V.toList $ forecast periods f s)
    ]
  where
    plotWithRadius radius p = Chart.plot $ do
      p' <- p
      return (p' & plot_points_style . point_radius .~ radius)
#endif


{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}

module Test.Grenade.Loss where

import           Hedgehog
import qualified Hedgehog.Gen                 as Gen
import qualified Hedgehog.Range               as Range

import qualified Numeric.LinearAlgebra.Static as NLA

import           Grenade
import           Test.Hedgehog.Hmatrix
import           Test.Hedgehog.Compat

genShapes :: Gen [S ('D1 10)]
genShapes =
  let len = Range.linear 0 10
  in  Gen.list len (S1D <$> randomVectorNormalised)

prop_quadratic :: Property
prop_quadratic = property $ do
  xs <- forAll genShapes
  ys <- forAll genShapes
  let zs = zip xs ys
  let costs  = map (uncurry quadratic) zs
  let xs'    = map extractVec xs
  let ys'    = map extractVec ys
  let f      = \x y -> 0.5 * (sum $ zipWith (\a b -> (a - b) ^ (2 :: Int)) x y)
  let costs' = zipWith f xs' ys'
  costs `isSimilarListTo` costs'

prop_quadratic' :: Property
prop_quadratic' = property $ do
  xs <- forAll genShapes
  ys <- forAll genShapes
  let zs = zip xs ys
  let (LossFunction (l :: (S ('D1 10) -> S ('D1 10) -> S ('D1 10)))) = quadratic'
  let costs  = map (extractVec . (uncurry l)) zs
  let xs'    = map extractVec xs
  let ys'    = map extractVec ys
  let f      = zipWith (-)
  let costs' = zipWith f xs' ys'
  costs `isSimilarListOfListsTo` costs'

prop_crossEntropy :: Property
prop_crossEntropy = property $ do
  xs <- forAll genShapes
  ys <- forAll genShapes
  let zs = zip xs ys
  let costs  = map (uncurry crossEntropy) zs
  let xs'    = map extractVec xs
  let ys'    = map extractVec ys
  let f      = \x y -> -1 * (sum $ zipWith (\a b -> b * (log a) + (1 - b) * (log (1 - a))) x y)
  let costs' = zipWith f xs' ys'
  costs `isSimilarListTo` costs'

prop_crossEntropy' :: Property
prop_crossEntropy' = property $ do
  xs <- forAll genShapes
  ys <- forAll genShapes
  let zs = zip xs ys
  let (LossFunction (l :: (S ('D1 10) -> S ('D1 10) -> S ('D1 10)))) = crossEntropy'
  let costs  = map (extractVec . (uncurry l)) zs
  let xs'    = map extractVec xs
  let ys'    = map extractVec ys
  let f      = (zipWith (\a b -> (a - b) / ((1 - a) * a)))
  let costs' = zipWith f xs' ys'
  costs `isSimilarListOfListsTo` costs'

prop_exponential :: Property
prop_exponential = property $ do
  xs <- forAll genShapes
  ys <- forAll genShapes
  let zs = zip xs ys
  let t  = 0.1
  let costs  = map (uncurry (exponential t)) zs
  let xs'    = map extractVec xs
  let ys'    = map extractVec ys
  let f      = \x y -> t * (exp (1/t * sum (zipWith (\a b -> (a - b) ^ (2 :: Int)) x y)))
  let costs' = zipWith f xs' ys'
  costs `isSimilarListTo` costs'

prop_exponential' :: Property
prop_exponential' = property $ do
  xs <- forAll genShapes
  ys <- forAll genShapes
  let zs = zip xs ys
  let t = 0.1
  let (LossFunction (l :: (S ('D1 10) -> S ('D1 10) -> S ('D1 10)))) = exponential' t
  let costs  = map (extractVec . (uncurry l)) zs
  let xs'    = map extractVec xs
  let ys'    = map extractVec ys
  let g      = \x y -> map ((t * (exp (1/t * sum (zipWith (\a b -> (a - b) ^ (2 :: Int)) x y)))) *)
  let f      = \x y -> map ((2 / t) *) $ zipWith (-) x y
  let costs' = zipWith (\x y -> g x y (f x y)) xs' ys'
  costs `isSimilarListOfListsTo` costs'

prop_hellinger :: Property
prop_hellinger = property $ do
  xs <- forAll genShapes
  ys <- forAll genShapes
  let zs = zip xs ys
  let costs  = map (uncurry hellinger) zs
  let xs'    = map extractVec xs
  let ys'    = map extractVec ys
  let f      = \x y -> (1 / (sqrt 2)) * (sum $ zipWith (\a b -> (sqrt a - sqrt b) ^ (2 :: Int)) x y)
  let costs' = zipWith f xs' ys'
  costs `isSimilarListTo` costs'

prop_hellinger' :: Property
prop_hellinger' = property $ do
  xs <- forAll genShapes
  ys <- forAll genShapes
  let zs = zip xs ys
  let (LossFunction (l :: (S ('D1 10) -> S ('D1 10) -> S ('D1 10)))) = hellinger'
  let costs  = map (extractVec . (uncurry l)) zs
  let xs'    = map extractVec xs
  let ys'    = map extractVec ys
  let f      = zipWith (\a b -> ((sqrt a) - (sqrt b)) / ((sqrt 2) * (sqrt a)))
  let costs' = zipWith f xs' ys'
  costs `isSimilarListOfListsTo` costs'

prop_kullbackLeibler :: Property
prop_kullbackLeibler = property $ do
  xs <- forAll genShapes
  ys <- forAll genShapes
  let zs = zip xs ys
  let costs  = map (uncurry kullbackLeibler) zs
  let xs'    = map extractVec xs
  let ys'    = map extractVec ys
  let f      = \x y -> sum $ zipWith (\a b -> b * log (b / a)) x y
  let costs' = zipWith f xs' ys'
  costs `isSimilarListTo` costs'

prop_kullbackLeibler' :: Property
prop_kullbackLeibler' = property $ do
  xs <- forAll genShapes
  ys <- forAll genShapes
  let zs = zip xs ys
  let (LossFunction (l :: (S ('D1 10) -> S ('D1 10) -> S ('D1 10)))) = kullbackLeibler'
  let costs  = map (extractVec . (uncurry l)) zs
  let xs'    = map extractVec xs
  let ys'    = map extractVec ys
  let f      = zipWith (\a b -> -(b / a))
  let costs' = zipWith f xs' ys'
  costs `isSimilarListOfListsTo` costs'

prop_genKullbackLeibler :: Property
prop_genKullbackLeibler = property $ do
  xs <- forAll genShapes
  ys <- forAll genShapes
  let zs = zip xs ys
  let costs  = map (uncurry genKullbackLeibler) zs
  let xs'    = map extractVec xs
  let ys'    = map extractVec ys
  let f      = \x y -> (sum $ zipWith (\a b -> b * log (b / a)) x y) - (sum y) + (sum x)
  let costs' = zipWith f xs' ys'
  costs `isSimilarListTo` costs'

prop_genKullbackLeibler' :: Property
prop_genKullbackLeibler' = property $ do
  xs <- forAll genShapes
  ys <- forAll genShapes
  let zs = zip xs ys
  let (LossFunction (l :: (S ('D1 10) -> S ('D1 10) -> S ('D1 10)))) = genKullbackLeibler'
  let costs  = map (extractVec . (uncurry l)) zs
  let xs'    = map extractVec xs
  let ys'    = map extractVec ys
  let f      = zipWith (\a b -> ((a - b) / a))
  let costs' = zipWith f xs' ys'
  costs `isSimilarListOfListsTo` costs'

prop_itakuraSaito :: Property
prop_itakuraSaito = property $ do
  xs <- forAll genShapes
  ys <- forAll genShapes
  let zs = zip xs ys
  let costs  = map (uncurry itakuraSaito) zs
  let xs'    = map extractVec xs
  let ys'    = map extractVec ys
  let f      = \x y -> sum $ zipWith (\a b -> (b/a) - (log (b/a)) - 1) x y
  let costs' = zipWith f xs' ys'
  costs `isSimilarListTo` costs'

prop_itakuraSaito' :: Property
prop_itakuraSaito' = property $ do
  xs <- forAll genShapes
  ys <- forAll genShapes
  let zs = zip xs ys
  let (LossFunction (l :: (S ('D1 10) -> S ('D1 10) -> S ('D1 10)))) = itakuraSaito'
  let costs  = map (extractVec . (uncurry l)) zs
  let xs'    = map extractVec xs
  let ys'    = map extractVec ys
  let f      = zipWith (\a b -> ((a - b) / (a * a)))
  let costs' = zipWith f xs' ys'
  costs `isSimilarListOfListsTo` costs'

prop_categoricalCrossEntropy :: Property
prop_categoricalCrossEntropy = property $ do
  xs <- forAll genShapes
  ys <- forAll genShapes
  let zs = zip xs ys
  let costs  = map (uncurry categoricalCrossEntropy) zs
  let xs'    = map extractVec xs
  let ys'    = map extractVec ys
  let f      = \x y -> -1 * (sum $ zipWith (\a b -> b * log a) x y)
  let costs' = zipWith f xs' ys'
  costs `isSimilarListTo` costs'

prop_categoricalCrossEntropy' :: Property
prop_categoricalCrossEntropy' = property $ do
  xs <- forAll genShapes
  ys <- forAll genShapes
  let zs = zip xs ys
  let (LossFunction (l :: (S ('D1 10) -> S ('D1 10) -> S ('D1 10)))) = categoricalCrossEntropy'
  let costs  = map (extractVec . (uncurry l)) zs
  let xs'    = map extractVec xs
  let ys'    = map extractVec ys
  let f      = zipWith (\a b -> -b / a)
  let costs' = zipWith f xs' ys'
  costs `isSimilarListOfListsTo` costs'

exampleShape :: (S ('D1 3), S ('D1 3))
exampleShape = (gen predicted, gen true)
    where
      gen       = S1D . NLA.vector
      predicted = [0.1, 0.8, 0.1]
      true      = [0, 0, 1]

prop_categoricalCrossEntropy_matchesActualValues :: Property
prop_categoricalCrossEntropy_matchesActualValues = property $ do
    let calculated = (uncurry categoricalCrossEntropy) exampleShape :: RealNum
    diff (abs (calculated - expectedResult)) (<) 0.01
    where
      expectedResult = 2.303

tests :: IO Bool
tests = checkParallel $$(discover)


module NeuralNet.ActivationSpec (activationSpec) where

import Test.Hspec
import NeuralNet.Activation
import Numeric.LinearAlgebra
import NeuralNet.Matrix

activationSpec :: SpecWith ()
activationSpec =
  describe "NeuralNet.Activation" $ do
    describe "forward" $ do
      it "should correctly work with ReLU" $
        let
          source = fromLists [ [1, 0, 0, 0]
                             , [0, 1, -1, 0]
                             , [0, 0, 1, 0]
                             , [0, 0, 0, 1]]
          expected = fromLists [ [1, 0, 0, 0]
                             , [0, 1, 0, 0]
                             , [0, 0, 1, 0]
                             , [0, 0, 0, 1]]
        in forward ReLU source `shouldBe` expected

      it "should correctly work with Sigmoid" $
        let
          source = zero 4 4
          expected = (4><4) (repeat 0.5)
        in forward Sigmoid source `shouldBe` expected

      it "should correctly work with Tanh" $
        let
          source = zero 4 4
          expected = (4><4) (repeat 0)
        in forward Tanh source `shouldBe` expected

    describe "backward" $ do
      it "should correctly work with ReLU eg 1" $
        let
          dA = fromLists [[-0.41675785, -0.05626683]]
          z = fromLists [[0.04153939, -1.11792545]]
          expected = fromLists [[-0.41675785, 0]]
        in backward ReLU dA z `shouldBe` expected

      it "should correctly work with ReLU eg 2" $
        let
          dA = fromLists [[0.12913162, -0.44014127], [-0.14175655, 0.48317296], [0.01663708, -0.05670698]]
          z = fromLists [[-0.7129932, 0.62524497], [-0.16051336, -0.76883635], [-0.23003072, 0.74505627]]
          expected = fromLists [[0, -0.44014127], [0, 0], [0, -0.05670698]]
        in backward ReLU dA z `shouldBe` expected

--      it "should correctly work with Tanh" $
--        let
--          source = diagonalList 3 0 [1..]
--          expected = fromLists [[1, 0, 0], [0, 4, 0], [0, 0, 9]]
--        in backward Tanh source `shouldBe` expected

      it "should correctly work with Sigmoid eg 1" $
        let
          dA = fromLists [[-0.41675785, -0.05626683]]
          z = fromLists [[0.04153939, -1.11792545]]
          expected = fromLists [[-0.1041445301481718, -1.0447915348382566e-2]]
        in backward Sigmoid dA z `shouldBe` expected

      it "should correctly work with Sigmoid eg 2" $
        let
          dA = fromLists [[-0.5590876, 1.77465392]]
          z = fromLists [[0.64667545, -0.35627076]]
          expected = fromLists [[-0.1261203972684239, 0.4298776138385045]]
        in backward Sigmoid dA z `shouldBe` expected


--
-- Spec file for luSolve.hs
--
-- Tests the exposed LU decomposition and linear system solver.
--
--
module Numeric.LinearAlgebra.LUSolveSpec where

import           Test.Hspec

import           Data.Matrix.Generic           as M hiding (zipWith)
import qualified Data.Vector.Unboxed           as V
import           Numeric.LinearAlgebra.LUSolve
import           System.Random

-- A useful, but strangely non-standard function: given an integer n
-- and a list, break the input list up into lists of length n and
-- return the list of those lists.
--
-- The name reflects that it "bundles" a list into lists of length n.
--
-- If the length of the input list is not a multiple of n, the final
-- sublist will be shorter than n elements.
--
-- The definition here is works for infinite lists, which is perhaps
-- the most common use-case for this function.
--
bundle :: Int -> [ a ] -> [[ a ]]
bundle _ [] = []
bundle n xs = take n xs : bundle n (drop n xs)

mVals :: [ Double ]
mVals = randoms (mkStdGen 1)

-- Make an infinite list of random n * n matrices.
--
randomSquareMatrices :: Int -> [ M.Matrix V.Vector Double ]
randomSquareMatrices n = Prelude.map (\vs -> M.fromLists (bundle n vs)) (bundle (n * n) mVals)

vVals :: [ Double ]
vVals = randoms (mkStdGen 2)

-- Make an infinite list of random n-vectors.
--
randomColumnVectors :: Int -> [ M.Matrix V.Vector Double ]
randomColumnVectors n = Prelude.map (\vs -> M.fromLists (bundle 1 vs )) (bundle n vVals)

-- Solve the linear system Ax = b for x, then compute the maximum
-- absolute value of the vector of differences Ax - b.  The later
-- is the value of the function.
--
checkLinearSystemSolution :: M.Matrix V.Vector Double  -- matrix A
                          -> M.Matrix V.Vector Double  -- right hand vector b
                          -> Double                    -- max (abs (Ax - b))
checkLinearSystemSolution a b = let
    x  = luSolve (luFactor a) b
    b' = matrixMultiply a x
    in
      maxAbsDiff b b'

-- Multiply two matrices
--
matrixMultiply :: M.Matrix V.Vector Double
               -> M.Matrix V.Vector Double
               -> M.Matrix V.Vector Double
matrixMultiply a b = let
    (ra, ca) = dim a
    (rb, cb) = dim b
    in
      if ca /= rb
      then error "incompatible dimensions in matrixMultiply"
      else fromLists [[ sum [ a ! (i, k) * b ! (k, j) | k <- [0 .. (ca - 1)]]
                                                      | j <- [0 .. (cb - 1)]]
                                                      | i <- [0 .. (ra - 1)]]

-- Return the largest difference (by absolute value) between
-- two matrices.
--
maxAbsDiff :: M.Matrix V.Vector Double
           -> M.Matrix V.Vector Double
           -> Double
maxAbsDiff (M.Matrix m n _ _ v) (M.Matrix m' n' _ _ v') =
    if m == m' && n == n'
    then V.maximum $ V.zipWith (\y y' -> abs (y - y')) v v'
    else error "unequal matrix dimensions in maxAbsDiff"

-- Return the largest difference (by relative value) between
-- two matrices.
--
maxRelDiff :: M.Matrix V.Vector Double
           -> M.Matrix V.Vector Double
           -> Double
maxRelDiff (Matrix m n _ _ v) (Matrix m' n' _ _ v') =
    if m == m' && n == n'
    then V.maximum $ V.zipWith (\y y' -> abs (2 * (y - y') / (abs y + abs y'))) v v'
    else error "unequal matrix dimensions in maxRelDiff"

-- Threshold for accepting max (abs (Ax - b)) as correct.
--
matrixSpecAbsDiff :: Double
matrixSpecAbsDiff = 1.0e-9

-- Generate n linear systems of size 'size' and solve them by luSolve.
-- Return a list of the maximum absolute value of the error (max (abs (Ax - b)))
-- for each case.
--
runCheck :: Int         -- number of cases to run
         -> Int         -- number of equations in each linear system
         -> [ Double ]  -- list of maximum absolute values of the errors
runCheck n size = take n $ zipWith checkLinearSystemSolution (randomSquareMatrices size)
                                                             (randomColumnVectors  size)

-- The tests themselves
--
spec :: Spec
spec = do
    -- describe "Numeric.LinearAlgebra.LUSolve.luSolve" $ do
    --     it "Solve 1000 random 10 * 10 systems" $ do
    --         (maximum $ runCheck 1000 10)
    --             `shouldSatisfy` (< matrixSpecAbsDiff)

    -- describe "Numeric.LinearAlgebra.LUSolve.luSolve" $ do
    --     it "Solve 100 random 50 * 50 systems" $ do
    --         (maximum $ runCheck 100 50)
    --             `shouldSatisfy` (< matrixSpecAbsDiff)

    -- describe "Numeric.LinearAlgebra.LUSolve.luSolve" $ do
    --     it "Solve 100 random 100 * 100 systems" $ do
    --         (maximum $ runCheck 100 100)
    --             `shouldSatisfy` (< matrixSpecAbsDiff)

    -- describe "Numeric.LinearAlgebra.LUSolve.luSolve" $ do
    --     it "Solve 100 random 500 * 500 systems" $ do
    --         (maximum $ runCheck 100 500)
    --             `shouldSatisfy` (< matrixSpecAbsDiff)

    describe "Numeric.LinearAlgebra.LUSolve.luSolve" $ do
        it "Solve 100 random 1000 * 1000 systems" $ do
            (maximum $ runCheck 100 1000)
                `shouldSatisfy` (< matrixSpecAbsDiff)

main :: IO ()
main = hspec spec


{-# LANGUAGE ExistentialQuantification , DeriveFunctor,FlexibleContexts,ImpredicativeTypes,TypeFamilies #-}

module Exponential.SO3 where

import Exponential.Class
import Data.Complex

import Control.Lens

import Linear.Vector
import Linear.V3
import Linear.Affine
import Linear.Matrix
import Linear.Metric
import Local
import Linear.V4

import Rotation.SO3
import Space.Class
import qualified Debug.Trace as T

instance Exponential SO3 where
    logM = logM3 . unSO3
    expM = SO3 . expM3

data CSO3 a = CSO3 { unCSO3 :: V3 (V3 a)} deriving(Show,Read,Functor)

mkLorentz :: Num a => M33 a -> V3 a -> M44 a
mkLorentz (V3 r1 r2 r3) (V3 tx ty tz) =
  V4 (snoc3 r1 tx) (snoc3 r2 ty) (snoc3 r3 tz) (V4 tx ty tz 0)
  where snoc3 (V3 x y z) = V4 x y z

expM31 v1@(V3 ox oy oz) v2@(V3 dx dy dz)  = foldr1 (!+!) $ zipWith (*!!) (fmap realPart [l1,l2,l3,l4]) [eye4,a , a!*!a , a!*!a !*!a]
    where
        alpha = v1 `dot` v1  - v2 `dot` v2
        beta = v1 `dot` v2
        delta = sqrt $  alpha^2 + 4*beta
        lambda1 = 0 :+ sqrt (abs((alpha - delta )/2))
        lambda2 =  sqrt ((alpha + delta )/2) :+  0
        l1 = (-cosh(lambda1)*lambda2^2 + lambda1^2*cosh(lambda2))/(lambda1^2 - lambda2^2)
        l2 = (-sinh(lambda1)*lambda2^3 + lambda1^3*sinh(lambda2))/(lambda1^2 - lambda2^2)/lambda1/lambda2
        l3 = (cosh lambda1  + cosh lambda2 )/(lambda1^2 - lambda2^2)
        l4 = (lambda2^2 * sinh lambda1 - lambda1* sinh lambda2)/(lambda1^2 - lambda2^2)/lambda1/lambda2
        a = mkLorentz (skewV3 v1) v2

expM3 v@(V3 x y z)
    = V3
        (V3 (cos t + c*x^2) (-s*z +c*x*y) (s*y+c*x*z))
        (V3 (s*z+c*x*y) (cos t + c*y^2) (-s*x+c*y*z))
        (V3 (-s*y+c*x*z ) (s*x+c*y*z) (cos t + c*z^2))
    where
        t = norm v
        c =  (1 - cos t)/(t^2 + 1.24e-16)
        s = sinc t

logM3 :: (Floating a, Ord a) => (V3 (V3 a)) -> V3 a
logM3 v = (t /( 2*sin t + 1.24e-16)) *^ (V3 (v^._z._y - v^._y._z) (v^._x._z - v^._z._x) (v^._y._x - v^._x._y))
    where
        t = acosc $ (trace v - 1)/2

acosc x
 | x > 1 = acos 1
 | x < -1 = acos(-1)
 | otherwise = acos x

sinc x
 | x == 0 = 1
 | otherwise = sin x / x


{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
module Geometry.Line
  ( Linear (..)
  , Line (..), trivialLine, mkLine, lineIntersection
  , Ray (..), mkRay
  , Segment (..), mkSegment, end, midPerpendicular
  ) where

import Data.Complex
import Data.List
import Data.Maybe
import Control.Monad

import Geometry.Base

------------------------------------------------------------

-- | Class representing a linear object: line, ray or segment.
class (Curve l, Affine l, Figure l) => Linear l where
  {-# MINIMAL refPoints #-}
  refPoints :: l -> (Cmp, Cmp)

  asLine :: l -> Line
  asLine = Line . refPoints

  asRay :: l -> Ray
  asRay = Ray . refPoints

  asSegment :: l -> Segment
  asSegment = Segment . refPoints

instance Linear l => Linear (Maybe l) where
  refPoints = maybe (0,0) refPoints

------------------------------------------------------------

-- | The straight line, passing through two given points.
-- The first point sets the `Figure`'s refference point and a starting point of a line.
-- The distance between refference points @p1@ and @p2@ sets the `unit` and internal scale,
-- so that @p1 == l \@<- 0@ and @p2 == l \@<- 1@.
newtype Line = Line (Cmp, Cmp)
  deriving Show

instance Linear Line where
  refPoints (Line ps) = ps

-- | The trivial line with coinsiding refference points.
trivialLine = Line (0, 0)

-- | The basic line constructor.
mkLine :: (Affine p1, Affine p2) => (p1, p2) -> Line
mkLine (p1, p2) = Line (cmp p1, cmp p2)

instance Eq Line where
  l1 == l2 = refPoints l1 ~= refPoints l2

instance Figure Line where
  isTrivial = isZero
  refPoint = fst . refPoints
  box l = pointBox (p1 - p2) <> pointBox p2
    where (p1, p2) = refPoints l

instance Affine Line where
  cmp l =  let (p1, p2) = refPoints l
           in cmp p2 - cmp p1
  asCmp p = mkLine (0 :: Cmp, p)

instance Trans Line where
  transform t (Line (p1, p2)) = Line (p1', p2')
    where p1' = transformCmp t p1
          p2' = transformCmp t p2

instance Manifold Line where
  type Domain Line = Cmp
  bounds l | isTrivial l = Bound
           | otherwise = Unbound
  param l t = let (p1, p2) = refPoints l
              in scaleAt' p1 t p2
  project l p = let v = cmp p - cmp (refPoint l)
                in (v `dot` angle l) / unit l
  isContaining l p = cmp p ~= refPoint l
                     || l `isCollinear` azimuth (refPoint l) p
  unit = norm

  distanceTo p l = abs ((y2-y1)*x - (x2-x1)*y + x2*y1 - y2*x1)/ unit l
    where (x1:+y1, x2:+y2) = refPoints l
          x:+y = cmp p

instance Curve Line where
  tangent l _ = angle l

intersectionLL (x1 :+ y1) (v1x :+ v1y) (x2 :+ y2) (v2x :+ v2y) =
  [ (v1x*d2 - v2x*d1) :+ (v1y*d2 - v2y*d1) | d0 /= 0 ]
  where
    d0 = v1y*v2x - v1x*v2y
    d1 = (v1x*y1 - v1y*x1) / d0
    d2 = (v2x*y2 - v2y*x2) / d0

lineIntersection l1 l2 =
  intersectionLL (refPoint l1) (cmp l1) (refPoint l2) (cmp l2)

------------------------------------------------------------

-- | The ray, passing through two given points.
-- The first point sets the `Figure`'s refference point and a starting point of a ray.
-- The distance between refference points @p1@ and @p2@ sets the `unit` and internal scale,
-- so that @p1 == l \@<- 0@ and @p2 == l \@<- 1@.
newtype Ray = Ray (Cmp, Cmp)
  deriving Show
  deriving ( Eq
           , Affine
           , Trans
           , Curve
           , Linear
           ) via Line

-- | The basic ray constructor.
mkRay :: (Affine p1, Affine p2) => (p1, p2) -> Ray
mkRay = asRay . mkLine

instance Manifold Ray where
  type Domain Ray = Cmp
  bounds r | isTrivial r = Bound
           | otherwise = Semibound
  param = param . asLine
  project = project . asLine
  isContaining r p = isContaining (asLine r) p
                     && project r (cmp p) >= 0
  unit = norm

instance Figure Ray where
  isTrivial = isZero
  refPoint = fst . refPoints
  box l = pointBox p1 <> pointBox p2
    where (p1, p2) = refPoints l

------------------------------------------------------------

{- | The line segment, joining two given points.
The first point sets the `Figure`'s refference point and a starting point of a ray.
The distance between refference points @p1@ and @p2@ sets the `unit` and internal scale,
so that @p1 == l \@<- 0@ and @p2 == l \@<- 1@.
-}
newtype Segment = Segment (Cmp, Cmp)
  deriving Show
  deriving ( Eq
           , Affine
           , Trans
           , Curve
           , Linear
           ) via Line

-- | The basic segment constructor.
mkSegment :: (Affine p1, Affine p2) => (p1, p2) -> Segment
mkSegment = asSegment . mkLine

instance Manifold Segment where
  type Domain Segment = Cmp
  bounds = const Bound
  param = param . asLine
  project = project . asLine
  isContaining r p = isContaining (asRay r) p
                     && project r (cmp p) <= 1
  unit = norm

instance Figure Segment where
  isTrivial = isZero
  refPoint = fst . refPoints
  box l = pointBox p1 <> pointBox p2
    where (p1, p2) = refPoints l

{- | Returns a perpendicular passing through the middle of the given segment.

<< figs/midPerpendicular.svg >>
-}
midPerpendicular :: Segment -> Line
midPerpendicular s = mkLine (p1, p2)
  where p1 = s @-> 0.5
        p2 = p1 + cmp (normal s 0.5)


{-# LANGUAGE BangPatterns , RankNTypes, GADTs, DataKinds #-}

{- | The 'Numerical.HBLAS.BLAS.Level1' module provides a fully general
yet type safe Level1 BLAS API.

When in doubt about the semantics of an operation,
consult your system's BLAS api documentation, or just read the documentation
for
<https://software.intel.com/sites/products/documentation/hpc/mkl/mklman/index.htm the Intel MKL BLAS distribution>

A few basic notes about how to invoke BLAS routines.

Many BLAS operations take one or more arguments of type 'Transpose'.
'Tranpose' has the following different constructors, which tell BLAS
routines what transformation to implicitly apply to an input matrix @mat@ with dimension @n x m@.

*  'NoTranspose' leaves the matrix @mat@ as is.

* 'Transpose' treats the @mat@ as being implicitly transposed, with dimension
    @m x n@. Entry @mat(i,j)@ being treated as actually being the entry
    @mat(j,i)@. For Real matrices this is also the matrix adjoint operation.
    ie @Tranpose(mat)(i,j)=mat(j,i)@

*  'ConjNoTranspose' will implicitly conjugate @mat@, which is a no op for Real ('Float' or 'Double') matrices, but for
'Complex Float' and 'Complex Double' matrices, a given matrix entry @mat(i,j)==x':+'y@
will be treated as actually being  @conjugate(mat)(i,j)=y':+'x@.

* 'ConjTranpose' will implicitly transpose and conjugate the input matrix.
ConjugateTranpose acts as matrix adjoint for both real and complex matrices.

The *gemm operations  work as follows (using 'sgemm' as an example):

* @'sgemm trLeft trRight alpha beta left right result'@, where @trLeft@ and @trRight@
are values of type 'Transpose' that respectively act on the matrices @left@ and @right@.

* the generalized matrix computation thusly formed can be viewed as being
@result = alpha * trLeft(left) * trRight(right) + beta * result@

the *gemv operations are akin to the *gemm operations, but with @right@ and @result@
being vectors rather than matrices.

the *trsv operations solve for @x@ in the equation @A x = y@ given @A@ and @y@.
The 'MatUpLo' argument determines if the matrix should be treated as upper or
lower triangular and 'MatDiag' determines if the triangular solver should treat
the diagonal of the matrix as being all 1's or not.  A general pattern of invocation
would be @'strsv' matuplo  tranposeMatA  matdiag  matrixA  xVector@.
A key detail to note is that the input vector is ALSO the result vector,
ie 'strsv' and friends updates the vector place.

-}

module Numerical.HBLAS.BLAS.Level1(
        sasum
        ,dasum
        ,scasum
        ,dzasum

        ,saxpy
        ,daxpy
        ,caxpy
        ,zaxpy

        ,scopy
        ,dcopy
        ,ccopy
        ,zcopy

        ,sdot
        ,ddot
        --,sdsdot
        ,dsdot

        ,cdotu
        ,cdotc
        ,zdotu
        ,zdotc

        ,snrm2
        ,dnrm2
        ,scnrm2
        ,dznrm2

        ,srot
        ,drot

        --,srotg
        --,drotg

        ,srotm
        ,drotm

        --,srotmg
        --,drotmg

        ,sscal
        ,dscal
        ,cscal
        ,zscal
        ,csscal
        ,zdscal

        ,sswap
        ,dswap
        ,cswap
        ,zswap

        ,isamax
        ,idamax
        ,icamax
        ,izamax

            ) where

import Numerical.HBLAS.UtilsFFI
import Numerical.HBLAS.BLAS.FFI.Level1
import Numerical.HBLAS.BLAS.Internal.Level1
import Control.Monad.Primitive
import Data.Complex

sasum :: PrimMonad m => AsumFun Float (PrimState m) m Float
sasum = asumAbstraction "sasum" cblas_sasum_safe cblas_sasum_unsafe

dasum :: PrimMonad m => AsumFun Double (PrimState m) m Double
dasum = asumAbstraction "dasum" cblas_dasum_safe cblas_dasum_unsafe

scasum :: PrimMonad m => AsumFun (Complex Float) (PrimState m) m Float
scasum = asumAbstraction "scasum" cblas_scasum_safe cblas_scasum_unsafe

dzasum :: PrimMonad m => AsumFun (Complex Double) (PrimState m) m Double
dzasum = asumAbstraction "dzasum" cblas_dzasum_safe cblas_dzasum_unsafe

saxpy :: PrimMonad m => AxpyFun Float (PrimState m) m
saxpy = axpyAbstraction "saxpy" cblas_saxpy_safe cblas_saxpy_unsafe (\x f -> f x)

daxpy :: PrimMonad m => AxpyFun Double (PrimState m) m
daxpy = axpyAbstraction "daxpy" cblas_daxpy_safe cblas_daxpy_unsafe (\x f -> f x)

caxpy :: PrimMonad m => AxpyFun (Complex Float) (PrimState m) m
caxpy = axpyAbstraction "caxpy" cblas_caxpy_safe cblas_caxpy_unsafe withRStorable_

zaxpy :: PrimMonad m => AxpyFun (Complex Double) (PrimState m) m
zaxpy = axpyAbstraction "zaxpy" cblas_zaxpy_safe cblas_zaxpy_unsafe withRStorable_

scopy :: PrimMonad m => CopyFun Float (PrimState m) m
scopy = copyAbstraction "scopy" cblas_scopy_safe cblas_scopy_unsafe

dcopy :: PrimMonad m => CopyFun Double (PrimState m) m
dcopy = copyAbstraction "dcopy" cblas_dcopy_safe cblas_dcopy_unsafe

ccopy :: PrimMonad m => CopyFun (Complex Float) (PrimState m) m
ccopy = copyAbstraction "ccopy" cblas_ccopy_safe cblas_ccopy_unsafe

zcopy :: PrimMonad m => CopyFun (Complex Double) (PrimState m) m
zcopy = copyAbstraction "zcopy" cblas_zcopy_safe cblas_zcopy_unsafe

sdot :: PrimMonad m => NoScalarDotFun Float (PrimState m) m Float
sdot = noScalarDotAbstraction "sdot" cblas_sdot_safe cblas_sdot_unsafe

ddot :: PrimMonad m => NoScalarDotFun Double (PrimState m) m Double
ddot = noScalarDotAbstraction "ddot" cblas_ddot_safe cblas_ddot_unsafe

--sdsdot :: PrimMonad m => ScalarDotFun Float (PrimState m) m Float
--sdsdot = scalarDotAbstraction "sdsdot" cblas_sdsdot_safe cblas_sdsdot_unsafe withRStorable withRStorable

dsdot :: PrimMonad m => NoScalarDotFun Float (PrimState m) m Double
dsdot = noScalarDotAbstraction "dsdot" cblas_dsdot_safe cblas_dsdot_unsafe

cdotu :: PrimMonad m => ComplexDotFun (Complex Float) (PrimState m) m
cdotu = complexDotAbstraction "cdotu" cblas_cdotu_safe cblas_cdotu_unsafe

cdotc :: PrimMonad m => ComplexDotFun (Complex Float) (PrimState m) m
cdotc = complexDotAbstraction "cdotc" cblas_cdotc_safe cblas_cdotc_unsafe

zdotu :: PrimMonad m => ComplexDotFun (Complex Double) (PrimState m) m
zdotu = complexDotAbstraction "zdotu" cblas_zdotu_safe cblas_zdotu_unsafe

zdotc :: PrimMonad m => ComplexDotFun (Complex Double) (PrimState m) m
zdotc = complexDotAbstraction "zdotc" cblas_zdotc_safe cblas_zdotc_unsafe

snrm2 :: PrimMonad m => Nrm2Fun Float (PrimState m) m Float
snrm2 = norm2Abstraction "snrm2" cblas_snrm2_safe cblas_snrm2_unsafe

dnrm2 :: PrimMonad m => Nrm2Fun Double (PrimState m) m Double
dnrm2 = norm2Abstraction "dnrm2" cblas_dnrm2_safe cblas_dnrm2_unsafe

scnrm2 :: PrimMonad m => Nrm2Fun (Complex Float) (PrimState m) m Float
scnrm2 = norm2Abstraction "scnrm2" cblas_scnrm2_safe cblas_scnrm2_unsafe

dznrm2 :: PrimMonad m => Nrm2Fun (Complex Double) (PrimState m) m Double
dznrm2 = norm2Abstraction "dznrm2" cblas_dznrm2_safe cblas_dznrm2_unsafe

srot :: PrimMonad m => RotFun Float (PrimState m) m
srot = rotAbstraction "srot" cblas_srot_safe cblas_srot_unsafe

drot :: PrimMonad m => RotFun Double (PrimState m) m
drot = rotAbstraction "drot" cblas_drot_safe cblas_drot_unsafe

--srotg :: PrimMonad m => RotgFun Float (PrimState m) m
--srotg = rotgAbstraction "srotg" cblas_srotg_safe cblas_srotg_unsafe

--drotg :: PrimMonad m => RotgFun Double (PrimState m) m
--drotg = rotgAbstraction "drotg" cblas_drotg_safe cblas_drotg_unsafe

srotm :: PrimMonad m => RotmFun Float (PrimState m) m
srotm = rotmAbstraction "srotm" cblas_srotm_safe cblas_srotm_unsafe

drotm :: PrimMonad m => RotmFun Double (PrimState m) m
drotm = rotmAbstraction "drotm" cblas_drotm_safe cblas_drotm_unsafe

--srotmg :: PrimMonad m => RotmgFun Float (PrimState m) m
--srotmg = rotmgAbstraction "srotmg" cblas_srotmg_safe cblas_srotmg_unsafe

--drotmg :: PrimMonad m => RotmgFun Double (PrimState m) m
--drotmg = rotmgAbstraction "drotmg" cblas_drotmg_safe cblas_drotmg_unsafe

sscal :: PrimMonad m => ScalFun Float Float (PrimState m) m
sscal = scalAbstraction "sscal" cblas_sscal_safe cblas_sscal_unsafe (\x f -> f x )

dscal :: PrimMonad m => ScalFun Double Double (PrimState m) m
dscal = scalAbstraction "dscal" cblas_dscal_safe cblas_dscal_unsafe (\x f -> f x )

cscal :: PrimMonad m => ScalFun (Complex Float) (Complex Float) (PrimState m) m
cscal = scalAbstraction "cscal" cblas_cscal_safe cblas_cscal_unsafe withRStorable_

zscal :: PrimMonad m => ScalFun (Complex Double) (Complex Double) (PrimState m) m
zscal = scalAbstraction "zscal" cblas_zscal_safe cblas_zscal_unsafe withRStorable_

csscal :: PrimMonad m => ScalFun Float (Complex Float) (PrimState m) m
csscal = scalAbstraction "csscal" cblas_csscal_safe cblas_csscal_unsafe (\x f -> f x )

zdscal :: PrimMonad m => ScalFun Double (Complex Double) (PrimState m) m
zdscal = scalAbstraction "zdscal" cblas_zdscal_safe cblas_zdscal_unsafe (\x f -> f x )

sswap :: PrimMonad m => SwapFun Float (PrimState m) m
sswap = swapAbstraction "sswap" cblas_sswap_safe cblas_sswap_unsafe

dswap :: PrimMonad m => SwapFun Double (PrimState m) m
dswap = swapAbstraction "dswap" cblas_dswap_safe cblas_dswap_unsafe

cswap :: PrimMonad m => SwapFun (Complex Float) (PrimState m) m
cswap = swapAbstraction "cswap" cblas_cswap_safe cblas_cswap_unsafe

zswap :: PrimMonad m => SwapFun (Complex Double) (PrimState m) m
zswap = swapAbstraction "zswap" cblas_zswap_safe cblas_zswap_unsafe

isamax :: PrimMonad m => IamaxFun Float (PrimState m) m
isamax = iamaxAbstraction "isamax" cblas_isamax_safe cblas_isamax_unsafe

idamax :: PrimMonad m => IamaxFun Double (PrimState m) m
idamax = iamaxAbstraction "idamax" cblas_idamax_safe cblas_idamax_unsafe

icamax :: PrimMonad m => IamaxFun (Complex Float) (PrimState m) m
icamax = iamaxAbstraction "icamax" cblas_icamax_safe cblas_icamax_unsafe

izamax :: PrimMonad m => IamaxFun (Complex Double)(PrimState m) m
izamax = iamaxAbstraction "izamax" cblas_izamax_safe cblas_izamax_unsafe

{-
isamin :: PrimMonad m => IaminFun Float (PrimState m) m
isamin = iaminAbstraction "isamin" cblas_isamin_safe cblas_isamin_unsafe

idamin :: PrimMonad m => IaminFun Double (PrimState m) m
idamin = iaminAbstraction "idamin" cblas_idamin_safe cblas_idamin_unsafe

icamin :: PrimMonad m => IaminFun (Complex Float) (PrimState m) m
icamin = iaminAbstraction "icamin" cblas_icamin_safe cblas_icamin_unsafe

izamin :: PrimMonad m => IaminFun (Complex Double)(PrimState m) m
izamin = iaminAbstraction "izamin" cblas_izamin_safe cblas_izamin_unsafe
-}


module Naive
(
  reduceByRowsV
  , reduceByColumnsV
)

where

import qualified Numeric.LinearAlgebra as LA

type Matrix = LA.Matrix LA.R
type Vector = LA.Vector LA.R
type R = LA.R

reduceByRowsV :: (Vector -> R) -> Matrix -> Vector
reduceByRowsV f = LA.vector . map f . LA.toRows

reduceByColumnsV :: (Vector -> R) -> Matrix -> Vector
reduceByColumnsV f = LA.vector . map f . LA.toColumns


-- |
-- Module     : Data.Monoid.Statistics
-- Copyright  : Copyright (c) 2010, Alexey Khudyakov <alexey.skladnoy@gmail.com>
-- License    : BSD3
-- Maintainer : Alexey Khudyakov <alexey.skladnoy@gmail.com>
-- Stability  : experimental
--
module Statistics.Monoid (
    module Statistics.Monoid.Class
  , module Statistics.Monoid.Numeric
  ) where

import Statistics.Monoid.Class
import Statistics.Monoid.Numeric


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

module DPmixture (
                  stick,
                  dp,
                  dpMixture,
                  dpClusters,
--                  dpMem,
--                  dpMemClusters,
                  posteriorClustersDist
                 ) where

-- Dirichlet Process mixture of Gaussians

import Prelude hiding (sum)

import Data.List hiding (sum)
import Data.Maybe
import Data.Ix (range)
import Numeric.SpecFunctions (logGamma, factorial)
-- import Control.Monad.Memo (memo, startEvalMemoT)
-- import Control.Monad.Trans.Memo.StateCache

import Control.Monad.Bayes.Simple

type NormalInvGamma = (Double,Double,Double,Double)

-- | Prior over cluster parameters used in 'dpMixture'
params :: NormalInvGamma
params = (0,1/10,1,10)
(m,k,a,b) = params

obs :: [Double]
obs = [1.0,1.1,1.2,-1.0,-1.5,-2.0,0.001,0.01,0.005,0.0]

-- | Stick-breaking function.
stick :: MonadDist m => [CustomReal m] -> [a] -> m a
stick (b:breaks) (a:atoms) = do
  stop <- bernoulli b
  if stop then return a else stick breaks atoms

-- | A Dirichlet Process generates a random probability distribution
-- using the stick-breaking representation.
dp :: MonadDist m => CustomReal m -> m a -> m (m a)
dp concentration base = do
  breaks <- sequence $ repeat $ beta 1 concentration
  atoms  <- sequence $ repeat base
  return $ stick breaks atoms

-- | DP mixture example from http://dl.acm.org/citation.cfm?id=2804317
dpMixture :: (MonadBayes m, CustomReal m ~ Double) => m [Int]
dpMixture =
  let
    --lazily generate clusters
    clusters = do
      let atoms = [1..]
      breaks <- sequence $ repeat $ beta 1 1
      let classgen = stick breaks atoms
      vars <- sequence $ repeat $ fmap ((1/) . (*k)) $ gamma a b
      means <- mapM (normal m) vars
      return (classgen, vars, means)
    n = length obs
    --start with no data points
    start = fmap (,[]) clusters

    --add points one by one
    points = foldl build start obs
    build d y = do
      (clusters, rest) <- d
      let (classgen, vars, means) = clusters
      cluster <- classgen
      let mean = means !! cluster
      let var  = vars  !! cluster
      let point = (cluster, var, mean)
      observe (normalDist mean (sqrt var)) y
      return (clusters, point : rest)

  in
   --exctract cluster assignments
   fmap (reverse . map (\(x,_,_) -> x) . snd) points

-- | 'dpMixture' restricted to the number of clusters only
dpClusters :: (MonadBayes m, CustomReal m ~ Double) => m Int
dpClusters = fmap (maximum . normalizePartition) dpMixture

-- | Renames identifiers so that they range from 1 to n
normalizePartition :: [Int] -> [Int]
normalizePartition xs = mapMaybe (`lookup` trans) xs where
  trans = zip unique [1..]
  unique = nub xs

-------------------------------------------------------
-- Strict version using memoization

-- cluster_param :: (MonadDist m, CustomReal m ~ Double) => Int -> m (Double, Double, Double)
-- cluster_param _ = do
--   b <- beta 1 1
--   var <- do
--     t <- gamma a b
--     return (1 / (k*t))
--   mean <- normal m var
--   return (b, mean, var)
--
-- dpMem :: (MonadBayes m, CustomReal m ~ Double) => m [Int]
-- dpMem = startEvalMemoT $ mapM process_point obs where
--   process_point x = do
--     (c, mean, var) <- get_cluster
--     observe (Continuous (Normal mean (sqrt var))) x
--     return c
--   get_cluster = stick 0 where
--     stick c = do
--       (b, mean, var) <- memo cluster_param c
--       stop <- bernoulli b
--       if stop then return (c, mean, var) else stick (c+1)
--
-- dpMemClusters :: (MonadBayes m, CustomReal m ~ Double) => m Int
-- dpMemClusters = fmap (maximum . normalizePartition) dpMem

----------------------------------------------------------
-- Exact posterior

-- | Posterior for parameters of a cluster
posterior :: NormalInvGamma -> [Double] -> NormalInvGamma
posterior (m,k,a,b) xs = (m',k',a',b') where
    m' = (k * m + n * x) / k'
    k' = k + n
    a' = a + n / 2
    b' = b + (m * m * k + x2 - m' * m' * k') / 2 --s / 2 + (k * n * (x - m) ^ 2) / (2 * (k + n))
    n  = fromIntegral $ length xs
    x  = sum xs / n  -- mean xs
    x2 = sum $ zipWith (*) xs xs  -- sum xs^2
    s  = sum $ zipWith (*) d d where  -- pvar xs
            d = map (+ (- x)) xs

-- | Model evidence for a cluster
evidence :: NormalInvGamma -> [Double] -> Double
evidence prior xs = exp (logGamma a' - logGamma a) * (b ** a / b' ** a') * sqrt (k / k') * c ^ n where
    (m,k,a,b)     = prior
    (m',k',a',b') = posterior prior xs
    c             = 1 / (2 * (sqrt pi))
    n             = length xs

-- | CRP prior over partitions
crp :: [Int] -> Double
crp labels = (product $ map factor counts) / factorial n where
    factor x = factorial (x - 1)
    n = length labels
    counts = map (\x -> length (filter (== x) labels)) clusters
    clusters = nub labels

-- | DP mixture likelihood of a partition
mixture :: NormalInvGamma -> [Double] -> [Int] -> Double
mixture prior xs ks = (product $ map (evidence prior) clusters) * crp ks where
  n = length xs
  clusters = map extract labels
  labels = nub ks
  extract n = map fst $ filter ((== n) . snd) points
  points = zip xs ks

-- | Exact posterior for a partition
exact :: NormalInvGamma -> [Double] -> [Int] -> Double
exact prior xs = let
  z = sum $ map (mixture prior xs) (partitions n)
  n = length xs
  f partition = mixture prior xs partition / z
  in
   f

-- | Exact posterior over the number of clusters
exactClusters :: NormalInvGamma -> [Double] -> Int -> Double
exactClusters prior xs = let
  partitionScore = exact prior xs
  results = map score [1..n]
  score k = sum $ map partitionScore $ filter ((== k) . maximum) $ partitions n
  n = length xs
  lookup i = results !! (i - 1)
  in
   lookup

-- | All possible partitions
partitions :: Int -> [[Int]]
partitions n = generate n 1 where
  generate 0 _ = [[]]
  generate n k = do
    x <- range (1,k)          -- range is inclusive on both ends
    let k' = max k (x+1)      -- next empty cluster
    xs <- generate (n-1) k'
    return (x:xs)

-- | Posterior over the number of clusters
posteriorClustersDist :: (MonadDist m, CustomReal m ~ Double) => m Int
posteriorClustersDist = categorical $ zip ns $ map lookup ns where
    ns = [1 .. length obs]
    lookup = exactClusters params obs

--------------------------------------
-- Instances for memoization
-- type instance CustomReal (StateCache c m) = CustomReal m
--
-- instance MonadDist m => MonadDist (StateCache c m) where
--   primitive = lift . primitive
--
-- instance MonadBayes m => MonadBayes (StateCache c m) where
--   factor = lift . factor