{-# LANGUAGE MultiParamTypeClasses, TypeOperators
           , TypeFamilies, UndecidableInstances, CPP
           , FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE DefaultSignatures   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}
----------------------------------------------------------------------
-- |
-- Module      :   Data.VectorSpace
-- Copyright   :  (c) Conal Elliott and Andy J Gill 2008
-- License     :  BSD3
--
-- Maintainer  :  conal@conal.net, andygill@ku.edu
-- Stability   :  experimental
--
-- Vector spaces
--
-- This version uses associated types instead of fundeps and
-- requires ghc-6.10 or later
----------------------------------------------------------------------

-- NB: I'm attempting to replace fundeps with associated types.  See
-- NewVectorSpace.hs.  Ran into trouble with type equality constraints not
-- getting propagated.  Manuel Ch is looking into it.
--
-- Blocking bug: http://hackage.haskell.org/trac/ghc/ticket/2448

module Data.VectorSpace
  ( module Data.AdditiveGroup
  , VectorSpace(..), (^/), (^*)
  , InnerSpace(..)
  , lerp, linearCombo, magnitudeSq, magnitude, normalized, project
  ) where

import Control.Applicative (liftA2)
import Data.Complex hiding (magnitude)
import Foreign.C.Types (CSChar, CInt, CShort, CLong, CLLong, CIntMax, CFloat, CDouble)
import Data.Ratio

import Data.AdditiveGroup
import Data.MemoTrie

import Data.VectorSpace.Generic
import qualified GHC.Generics as Gnrx
import GHC.Generics (Generic, (:*:)(..))

infixr 7 *^

-- | Vector space @v@.
class AdditiveGroup v => VectorSpace v where
  type Scalar v :: *
  type Scalar v = Scalar (VRep v)
  -- | Scale a vector
  (*^) :: Scalar v -> v -> v
  default (*^) :: (Generic v, VectorSpace (VRep v), Scalar (VRep v) ~ Scalar v)
                    => Scalar v -> v -> v
  μ *^ v = Gnrx.to (μ *^ Gnrx.from v :: VRep v)
  {-# INLINE (*^) #-}

infixr 7 <.>

-- | Adds inner (dot) products.
class (VectorSpace v, AdditiveGroup (Scalar v)) => InnerSpace v where
  -- | Inner/dot product
  (<.>) :: v -> v -> Scalar v
  default (<.>) :: (Generic v, InnerSpace (VRep v), Scalar (VRep v) ~ Scalar v)
                    => v -> v -> Scalar v
  v<.>w = (Gnrx.from v :: VRep v) <.> Gnrx.from w
  {-# INLINE (<.>) #-}

infixr 7 ^/
infixl 7 ^*

-- | Vector divided by scalar
(^/) :: (VectorSpace v, s ~ Scalar v, Fractional s) => v -> s -> v
v ^/ s = recip s *^ v
{-# INLINE (^/) #-}

-- | Vector multiplied by scalar
(^*) :: (VectorSpace v, s ~ Scalar v) => v -> s -> v
(^*) = flip (*^)
{-# INLINE (^*) #-}

-- | Linear interpolation between @a@ (when @t==0@) and @b@ (when @t==1@).

-- lerp :: (VectorSpace v, s ~ Scalar v, Num s) => v -> v -> s -> v
lerp :: VectorSpace v => v -> v -> Scalar v -> v
lerp a b t = a ^+^ t *^ (b ^-^ a)
{-# INLINE lerp #-}

-- | Linear combination of vectors
linearCombo :: VectorSpace v => [(v,Scalar v)] -> v
linearCombo ps = sumV [v ^* s | (v,s) <- ps]
{-# INLINE linearCombo #-}

-- | Square of the length of a vector.  Sometimes useful for efficiency.
-- See also 'magnitude'.
magnitudeSq :: (InnerSpace v, s ~ Scalar v) => v -> s
magnitudeSq v = v <.> v
{-# INLINE magnitudeSq #-}

-- | Length of a vector.   See also 'magnitudeSq'.
magnitude :: (InnerSpace v, s ~ Scalar v, Floating s) =>  v -> s
magnitude = sqrt . magnitudeSq
{-# INLINE magnitude #-}

-- | Vector in same direction as given one but with length of one.
-- Divides by zero for the zero vector.
normalized :: (InnerSpace v, s ~ Scalar v, Floating s) =>  v -> v
normalized v = v ^/ magnitude v
{-# INLINE normalized #-}

-- | @project u v@ computes the projection of @v@ onto @u@.
project :: (InnerSpace v, s ~ Scalar v, Fractional s) => v -> v -> v
project u v = ((v <.> u) / magnitudeSq u) *^ u
{-# INLINE project #-}

#define ScalarType(t) \
  instance VectorSpace (t) where \
    { type Scalar (t) = (t) \
    ; (*^) = (*) } ; \
  instance InnerSpace  (t) where (<.>) = (*)

ScalarType(Int)
ScalarType(Integer)
ScalarType(Double)
ScalarType(Float)
ScalarType(CSChar)
ScalarType(CInt)
ScalarType(CShort)
ScalarType(CLong)
ScalarType(CLLong)
ScalarType(CIntMax)
ScalarType(CDouble)
ScalarType(CFloat)

instance Integral a => VectorSpace (Ratio a) where
  type Scalar (Ratio a) = Ratio a
  (*^) = (*)
instance Integral a => InnerSpace  (Ratio a) where (<.>) = (*)

instance (RealFloat v, VectorSpace v) => VectorSpace (Complex v) where
  type Scalar (Complex v) = Scalar v
  s*^(u :+ v) = s*^u :+ s*^v

instance (RealFloat v, InnerSpace v)
     => InnerSpace (Complex v) where
  (u :+ v) <.> (u' :+ v') = (u <.> u') ^+^ (v <.> v')

-- Hm.  The 'RealFloat' constraint is unfortunate here.  It's due to a
-- questionable decision to place 'RealFloat' into the definition of the
-- 'Complex' /type/, rather than in functions and instances as needed.

-- instance (VectorSpace u,VectorSpace v, s ~ Scalar u, s ~ Scalar v)
--          => VectorSpace (u,v) where
--   type Scalar (u,v) = Scalar u
--   s *^ (u,v) = (s*^u,s*^v)

instance ( VectorSpace u, s ~ Scalar u
         , VectorSpace v, s ~ Scalar v )
      => VectorSpace (u,v) where
  type Scalar (u,v) = Scalar u
  s *^ (u,v) = (s*^u,s*^v)

instance ( InnerSpace u, s ~ Scalar u
         , InnerSpace v, s ~ Scalar v )
    => InnerSpace (u,v) where
  (u,v) <.> (u',v') = (u <.> u') ^+^ (v <.> v')

instance ( VectorSpace u, s ~ Scalar u
         , VectorSpace v, s ~ Scalar v
         , VectorSpace w, s ~ Scalar w )
    => VectorSpace (u,v,w) where
  type Scalar (u,v,w) = Scalar u
  s *^ (u,v,w) = (s*^u,s*^v,s*^w)

instance ( InnerSpace u, s ~ Scalar u
         , InnerSpace v, s ~ Scalar v
         , InnerSpace w, s ~ Scalar w )
    => InnerSpace (u,v,w) where
  (u,v,w) <.> (u',v',w') = u<.>u' ^+^ v<.>v' ^+^ w<.>w'

instance ( VectorSpace u, s ~ Scalar u
         , VectorSpace v, s ~ Scalar v
         , VectorSpace w, s ~ Scalar w
         , VectorSpace x, s ~ Scalar x )
    => VectorSpace (u,v,w,x) where
  type Scalar (u,v,w,x) = Scalar u
  s *^ (u,v,w,x) = (s*^u,s*^v,s*^w,s*^x)

instance ( InnerSpace u, s ~ Scalar u
         , InnerSpace v, s ~ Scalar v
         , InnerSpace w, s ~ Scalar w
         , InnerSpace x, s ~ Scalar x )
    => InnerSpace (u,v,w,x) where
  (u,v,w,x) <.> (u',v',w',x') = u<.>u' ^+^ v<.>v' ^+^ w<.>w' ^+^ x<.>x'

-- Standard instances for a functor applied to a vector space.

-- For 'Maybe', Nothing represents 'zeroV'.  Useful for optimization, since
-- we might not be able to test for 'zeroV', e.g., functions and infinite
-- derivative towers.
instance VectorSpace v => VectorSpace (Maybe v) where
  type Scalar (Maybe v) = Scalar v
  (*^) s = fmap (s *^)

-- instance VectorSpace v => VectorSpace (a -> v) where
--   type Scalar (a -> v) = Scalar v
--   (*^) s = fmap (s *^)

-- No 'InnerSpace' instance for @a -> v@.

-- Or the following definition, which is useful for the higher-order
-- shading dsel in Shady (borrowed from Vertigo).

instance VectorSpace v => VectorSpace (a -> v) where
  type Scalar (a -> v) = a -> Scalar v
  (*^) = liftA2 (*^)

instance InnerSpace v => InnerSpace (a -> v) where
  (<.>) = liftA2 (<.>)

instance (HasTrie a, VectorSpace v) => VectorSpace (a :->: v) where
  type Scalar (a :->: v) = Scalar v
  (*^) s = fmap (s *^)

instance InnerSpace a => InnerSpace (Maybe a) where
  -- dotting with zero (vector) yields zero (scalar)
  Nothing <.> _     = zeroV
  _ <.> Nothing     = zeroV
  Just u <.> Just v = u <.> v

--   mu <.> mv = fromMaybe zeroV (liftA2 (<.>) mu mv)

--   (<.>) = (fmap.fmap) (fromMaybe zeroV) (liftA2 (<.>))

instance VectorSpace a => VectorSpace (Gnrx.Rec0 a s) where
  type Scalar (Gnrx.Rec0 a s) = Scalar a
  μ *^ Gnrx.K1 v = Gnrx.K1 $ μ*^v
  {-# INLINE (*^) #-}
instance VectorSpace (f p) => VectorSpace (Gnrx.M1 i c f p) where
  type Scalar (Gnrx.M1 i c f p) = Scalar (f p)
  μ *^ Gnrx.M1 v = Gnrx.M1 $ μ*^v
  {-# INLINE (*^) #-}
instance (VectorSpace (f p), VectorSpace (g p), Scalar (f p) ~ Scalar (g p))
         => VectorSpace ((f :*: g) p) where
  type Scalar ((f:*:g) p) = Scalar (f p)
  μ *^ (x:*:y) = μ*^x :*: μ*^y
  {-# INLINE (*^) #-}

instance InnerSpace a => InnerSpace (Gnrx.Rec0 a s) where
  Gnrx.K1 v <.> Gnrx.K1 w = v<.>w
  {-# INLINE (<.>) #-}
instance InnerSpace (f p) => InnerSpace (Gnrx.M1 i c f p) where
  Gnrx.M1 v <.> Gnrx.M1 w = v<.>w
  {-# INLINE (<.>) #-}
instance ( InnerSpace (f p), InnerSpace (g p)
         , Scalar (f p) ~ Scalar (g p), Num (Scalar (f p)) )
         => InnerSpace ((f :*: g) p) where
  (x:*:y) <.> (ξ:*:υ) = x<.>ξ + y<.>υ
  {-# INLINE (<.>) #-}


{-# LANGUAGE FlexibleContexts #-}

module GT.Algebra.Matrix
  ( adjacencyMatrix,
    degreeMatrix,
    laplacianMatrix,
  )
where

import Data.Maybe (fromJust)
import Data.Sequence as Q (Seq, elemIndexL)
import Data.Tuple (swap)
import Data.Witherable (Witherable, mapMaybe)
import GT.Graph.Class
  ( Direction (Directed, Undirected),
    Graph (degree, direction, edgeMap, nodeCount, nodeIds, nodeMap),
    Unwrap (unwrap),
  )
import Numeric.LinearAlgebra.Data as LA
  ( Konst (konst),
    Matrix,
    R,
    accum,
    diagl,
  )

adjacencyMatrix :: Graph g n n' e e' d => g -> Matrix R
adjacencyMatrix g = LA.accum (konst 0 (n, n)) (+) as'
  where
    n = nodeCount g
    as' = case direction g of
      Directed -> as
      Undirected -> as ++ fmap (\(rc, a) -> (swap rc, a)) as
    is = nodeIds g
    as =
      edgeMap
        ( \e' ->
            let (i, j) = unwrap e'
                r = fromJust $ elemIndexL i is
                c = fromJust $ elemIndexL j is
             in ((r, c), 1)
        )
        g

degreeMatrix :: Graph g n n' e e' d => g -> Matrix R
degreeMatrix g = diagl $ nodeMap (\n' -> fromIntegral (fromJust $ degree (unwrap n') g)) g

laplacianMatrix :: Graph g n n' e e' d => g -> Matrix R
laplacianMatrix g = degreeMatrix g - adjacencyMatrix g


module AutomatedReviewAnalyzer where

import Numeric.LinearAlgebra as LA
import Data.List.Split (splitOn)
import qualified Data.Map.Strict as M
import System.IO
import Data.Char (isAlpha, toLower)
import SentimentAnalysis

classify :: Matrix R -> Vector R -> R -> Vector R
classify x theta thata0 = cmap check (theta LA.<# LA.tr' x + theta0s)
    where
        theta0s = rows x LA.|> repeat 0
        check z = if z > 0 then 1.0 else -1.0

accuracy :: Vector R -> Vector R -> R
accuracy pred target = sum xs / fromIntegral (length xs)
    where
        xs = zipWith check (toList pred) (toList target)
        check a b = if a == b then 1 else 0

classifierAccuracy :: (Matrix R -> Vector R -> Int -> [Int] -> (Vector R, R))
                            -> Matrix R -> Matrix R -> Vector R -> Vector R -> Int -> [Int] -> (R, R)
classifierAccuracy classifier x x' y y' t zs =
    (accuracy (classify x theta theta0) y, accuracy (classify x' theta theta0) y')
    where
        (theta, theta0) = classifier x y t zs

classifierAccuracy' :: (Matrix R -> Vector R -> Int -> R -> [Int] -> (Vector R, R))
                            -> Matrix R -> Matrix R -> Vector R -> Vector R -> Int -> R -> [Int] -> (R, R)
classifierAccuracy' classifier x x' y y' t lambda zs =
    (accuracy (classify x theta theta0) y, accuracy (classify x' theta theta0) y')
    where
        (theta, theta0) = classifier x y t lambda zs

separate :: String -> String
separate = concatMap separate'
    where
        separate' c = if isAlpha c then [toLower c] else [' ', c, ' ']

addWord :: String -> M.Map String R -> M.Map String R
addWord w map = if M.member w map then map else M.insert w 1.0 map

countWord :: String -> M.Map String R -> M.Map String R
countWord w = M.insertWith (+) w 1

extractFeatures :: [String] -> M.Map String R -> Matrix R
extractFeatures xs d = (length xss >< M.size d) ys
    where
        xss = map (words . separate) xs
        ds = map (foldl (flip countWord) M.empty) xss
        ys = concatMap f $ zip ds (repeat d)
        f (d'', d') = map (g . flip M.lookup d'') (M.keys d')
        g Nothing = 0
        g (Just a) = a

main :: IO ()
main = do

    h1 <- openFile "reviews_train.tsv" ReadMode
    hSetEncoding h1 latin1
    trainDta <- hGetContents h1
    h2 <- openFile "reviews_val.tsv" ReadMode
    hSetEncoding h2 latin1
    valDta <- hGetContents h2
--    testDta <- readFile "reviews_test.tsv"
    orderDta <- readFile "4000.txt"

    let t = 20
    let lambda = 0.005
    let (labels, text) = unzip $ map ((\ i -> ((read . head) i, i !! 4)) . splitOn "\t") (drop 1 $ lines trainDta)
    let bagOfWords =  foldr addWord M.empty $ concatMap (words . separate) text
    let features = extractFeatures text bagOfWords
    let (labels', text') = unzip $ map ((\ i -> ((read . head) i, i !! 4)) . splitOn "\t") (drop 1 $ lines valDta)
    let features' = extractFeatures text' bagOfWords

    let indices = map read $ splitOn "," orderDta

    let (trainAccuracy, validationAccuracy) = classifierAccuracy perceptron features features' (vector labels) (vector labels') t indices
    let (trainAccuracy', validationAccuracy') = classifierAccuracy averagePerceptron features features' (vector labels) (vector labels') t indices
    let (trainAccuracy'', validationAccuracy'') = classifierAccuracy' pegasos features features' (vector labels) (vector labels') t lambda indices

    putStrLn "Classifier accuracy:"
--    print $ (takeColumns 10 . takeRows 4) features
    print $ "Training accuracy for perceptron: " ++ show trainAccuracy
    print $ "Validation accuracy for perceptron: " ++ show validationAccuracy
    print $ "Training accuracy for average perceptron: " ++ show trainAccuracy'
    print $ "Validation accuracy for average perceptron: " ++ show validationAccuracy'
    print $ "Training accuracy for pegasos: " ++ show trainAccuracy''
    print $ "Validation accuracy for pegasos: " ++ show validationAccuracy''


module IFS.Base
  ( IFS(..)
  , Transformation(..)
  , iter
  , chaosIter
  , sierpinskiTIFS
  , crossFrac
  , cantorSetIFS
  , squareLeafIFS
  , infTriangles
  , infTriangles2
  , infTriangles3
  , kochSnowFlakeIFS
  , differentFlakeIFS
  , differentFlake2IFS
  )
  where

import Numeric.LinearAlgebra.Data
import Numeric.LinearAlgebra.HMatrix
import System.Random
import Control.Applicative

type Transformation a = Vector a -> Vector a

type IFS = [Transformation R]

iter :: IFS -> Vector R -> [Vector R]
iter ifs vec = ifs <*> pure vec

chaosIter :: IFS -> StdGen -> Vector R -> (Vector R, StdGen)
chaosIter ifs g v = (randSim v, g')
  where
    (index, g') = randomR (0, length ifs - 1) g
    randSim = ifs !! index

rotate2D :: Double -> Matrix R
rotate2D theta = (2><2) [cos theta', -sin theta',
                         sin theta', cos theta']
  where theta' = theta * pi / 180

sierpinskiTIFS :: IFS
sierpinskiTIFS =
  [ \v -> 1/2 * v
  , \v -> 1/2 * v + vector [1/2, 0]
  , \v -> 1/2 * v + vector [1/4, sqrt 3 / 4]
  ]

cantorSetIFS :: IFS
cantorSetIFS =
  [ \v -> 1/3 * v
  , \v -> 1/3 * v + vector [2/3, 0]
  ]

squareLeafIFS :: IFS
squareLeafIFS =
  [ \v -> 2/3 * v
  , \v -> 1/3 * v + vector [0, 2/3]
  , \v -> 1/3 * v + vector [2/3, 0]
  , \v -> 1/3 * v + vector [2/3, 2/3]
  ]

infTriangles :: IFS
infTriangles =
  [ \v -> 1/2 - 1/2 * v
  , \v -> 1/2 * v + vector [1/2, 0]
  , \v -> 1/2 * v + vector [0, 1/2]
  ]

infTriangles2 :: IFS
infTriangles2 =
  [ \v -> 1/2 + vector [-1/2, 1/2] * v
  , \v -> 1/2 * v + vector [1/2, 0]
  , \v -> 1/2 * v + vector [0, 1/2]
  ]

infTriangles3 :: IFS
infTriangles3 =
  [ \v -> vector [1/2, 0] + vector [-1/2, 1/2] * v
  , \v -> 1/2 * v + vector [1/2, 0]
  , \v -> 1/2 * v + vector [0, 1/2]
  ]

crossFrac :: IFS
crossFrac =
  [ \v -> 1/4 * v
  , \v -> 1/4 * v + vector [3/4, 0]
  , \v -> 1/4 * v + vector [0, 3/4]
  , \v -> 1/4 * v + vector [3/4, 3/4]
  , \v -> 1/2 * v + vector [1/4, 1/4]
  ]

kochSnowFlakeIFS :: IFS
kochSnowFlakeIFS =
  [ \v -> 1/3 * v
  , \v -> 1/3 * v + vector [2/3, 0]
  , \v -> rotate2D (60) `app` (1/3 * v) + vector [1/3, 0]
  , \v -> rotate2D (-60) `app` (1/3 * v) + vector [1/2, sqrt 3 / 6]
  ]

differentFlakeIFS :: IFS
differentFlakeIFS =
  [ \v -> 1/3 * v + vector [1 / 6, sqrt 3]
  , \v -> 1/3 * v + vector [1 / 6, sqrt 3 / 9]
  , \v -> 1/3 * v + vector [8 / 6, sqrt 3 / 9]
  , \v -> 1/3 * v + vector [8 / 6, sqrt 3]
  , \v -> 2/3 * v + vector [1 / 3, 1/3 * sqrt 3]
  ]

differentFlake2IFS :: IFS
differentFlake2IFS =
  [ \v -> 1/2 * v + vector [1/2, 0]
  , \v -> 1/4 * v + vector [3/4, - sqrt 3 / 4]
  , \v -> 1/4 * v + vector [3/4, sqrt 3 / 2]
  , \v -> 1/4 * v + vector [1/3 - sqrt 3 / 4, - sqrt 3 / 24]
  , \v -> 1/4 * v + vector [1/3 - sqrt 3 / 4, sqrt 3 / 3 - sqrt 3 / 24]
  , \v -> 1/4 * v + vector [13/12, - sqrt 3 / 24]
  , \v -> 1/4 * v + vector [13/12, sqrt 3 / 3 - sqrt 3 / 24]
  ]


{-|
Module: MachineLearning.Classification.MultiClass
Description: MultiClass Classification.
Copyright: (c) Alexander Ignatyev, 2016-2017
License: BSD-3
Stability: experimental
Portability: POSIX

MultiClass Classification.
-}

module MachineLearning.Classification.MultiClass
(
  Classifier(..)
  , MultiClassModel(..)
  , processOutput
  , Regularization(..)
  , ccostReg
  , cgradientReg
)

where

import MachineLearning.Types
import MachineLearning.Model
import MachineLearning.Regularization (Regularization(..))
import qualified MachineLearning as ML
import qualified Data.Vector.Storable as V
import qualified Numeric.LinearAlgebra as LA

-- | Classifier type class represents Multi-class classification models.
class Classifier a where
  -- | Score function
  cscore :: a -> Matrix -> Matrix -> Matrix

  -- | Hypothesis function
  -- Takes X (m x n) and theta (n x k), returns y (m x k).
  chypothesis :: a -> Matrix -> Matrix -> Vector

  -- | Cost function J(Theta), a.k.a. loss function.
  -- It takes regularizarion parameter lambda, matrix X (m x n), vector y (m x 1) and vector theta (n x 1).
  ccost :: a -> Regularization -> Matrix -> Vector -> Matrix -> R

  -- | Gradient function.
  -- It takes regularizarion parameter lambda, X (m x n), y (m x 1) and theta (n x 1).
  -- Returns vector of gradients (n x 1).
  cgradient :: a -> Regularization -> Matrix -> Vector -> Matrix -> Matrix

  -- | Returns Number of Classes
  cnumClasses :: a -> Int

-- | MultiClassModel is Model wrapper class around Classifier
data MultiClassModel m = MultiClass m

instance (Classifier a) => Model (MultiClassModel a) where
  hypothesis (MultiClass m) x theta = chypothesis m x theta'
    where theta' = unflatten (cnumClasses m) theta

  cost (MultiClass m) lambda x y theta = ccost m lambda x y theta'
    where theta' = unflatten (cnumClasses m) theta

  gradient (MultiClass m) lambda x y theta = LA.flatten $ cgradient m lambda x y theta'
    where theta' = unflatten (cnumClasses m) theta

unflatten :: Int -> Vector -> Matrix
unflatten nLabels v = LA.reshape cols v
  where cols = (V.length v) `div` nLabels

-- | Process outputs for MultiClass Classification.
-- Takes Classifier and output vector y.
-- Returns matrix of binary outputs.
-- It is supposed that labels are integerets start at 0.
processOutput :: (Classifier c) => c -> Vector -> Matrix
processOutput c y = LA.fromColumns $ map f [0 .. (cnumClasses c)-1]
  where f sample = V.map (\a -> if round a == sample then 1 else 0) y

-- | Calculates regularization for Classifier.ccost.
-- It takes regularization parameter and theta.
ccostReg :: Regularization -> Matrix -> R
ccostReg RegNone _ = 0
ccostReg (L2 lambda) theta = (LA.norm_2 thetaReg) * 0.5 * lambda
  where thetaReg = ML.removeBiasDimension theta

-- | Calculates regularization for Classifier.cgradient.
-- It takes regularization parameter and theta.
cgradientReg :: Regularization -> Matrix -> Matrix
cgradientReg RegNone _ = 0
cgradientReg (L2 lambda) theta = ((LA.scalar lambda) * thetaReg)
  where thetaReg = 0 LA.||| (ML.removeBiasDimension theta)


module PowerMethod where

import           Control.Monad         as M
import           Data.Complex
import           Data.List             as L
import           Numeric.LinearAlgebra as NL
import           System.Environment
import           System.Random
import           Text.Printf

{-# INLINE iterateM #-}
iterateM :: Int -> (b -> a -> IO a) -> b -> a -> IO a
iterateM 0 _ _ x = return x
iterateM n f x y = do
  z <- f x y
  iterateM (n - 1) f x $! z

{-# INLINE getComplexStr #-}
getComplexStr :: (Complex Double) -> String
getComplexStr (a :+ b) = printf "%.2f :+ %.2f" a b

{-# INLINE getComplexStr' #-}
getComplexStr' :: (Complex Double) -> String
getComplexStr' x =
  let (a, b) = polar x
   in printf "(%.2f, %.2f)" a b

{-# INLINE getListStr #-}
getListStr :: (a -> String) -> [a] -> String
getListStr f (x:xs) =
  printf "[%s%s]" (f x) . L.concatMap (\x -> " ," L.++ f x) $ xs

main = do
  (nStr:_) <- getArgs
  let range = (-1, 1)
  matInit1 <- M.replicateM 4 (randomRIO range) :: IO [Double]
  matInit2 <- M.replicateM 4 (randomRIO range) :: IO [Double]
  vecInit1 <- M.replicateM 2 (randomRIO range) :: IO [Double]
  vecInit2 <- M.replicateM 2 (randomRIO range) :: IO [Double]
  let n = read nStr :: Int
      mat' = (2 >< 2) $ L.zipWith (:+) matInit1 matInit2
      vec' = NL.fromList $ L.zipWith (:+) vecInit1 vecInit2
      (eigVal, eigVec) = eig mat'
      eigVecs = toColumns eigVec
  print mat'
  out <-
    iterateM
      n
      (\mat vec -> do
         let newVec = mat #> vec
             maxMag = L.maximum . L.map magnitude . NL.toList $ newVec
             (a:b:_) = NL.toList newVec
             phaseNorm x =
               let (m, p) = polar x
                in mkPolar 1 p
             norm =
               if magnitude a > magnitude b
                 then a
                 else b
             normalizedNewVec = newVec / (scalar norm)
         printf
           "Maximum magnitude: %.2f %s\n"
           maxMag
           (getListStr getComplexStr' . NL.toList $ normalizedNewVec)
         return normalizedNewVec)
      mat'
      vec'
  let s = sqrt . L.sum . L.map (\x -> (magnitude x) ^ 2) . NL.toList $ out
  printf
    "%s\n"
    (getListStr getComplexStr' . L.map (/ (s :+ 0)) . NL.toList $ out)
  M.zipWithM_
    (\val vec ->
       printf
         "%.2f %s\n"
         (magnitude val)
         (getListStr getComplexStr' . NL.toList $ vec))
    (NL.toList eigVal)
    eigVecs
  print eigVal
  print eigVecs


module Utils where

import Data.Matrix
import qualified Data.Complex as C

type ComplexMatrix a = Matrix (C.Complex a)

-- Complex conjugate of a matrix
conjugate :: (Num a) => ComplexMatrix a -> ComplexMatrix a
conjugate = fmap C.conjugate

-- Similar to numpy.vdot. Takes complex conjugate of the first matrix
-- and computes matrix product.
vdot :: (RealFloat a) => ComplexMatrix a -> ComplexMatrix a -> ComplexMatrix a
vdot m n = (conjugate m) * n


{-# LANGUAGE LambdaCase #-}
module Lib
( main
) where

import Prelude hiding (lex)
import Control.Applicative (Alternative((<|>)))
import Numeric.LinearAlgebra
    (realPart, Complex(..), eigenvalues, (><), toList, Matrix)
import Data.Attoparsec.Text
    (many', endOfInput, double, skipSpace, parseOnly, Parser)
import Data.Text (pack)

main :: IO ()
main = do
  input <- fmap (\case {';' -> ' '; ch -> ch}) <$> getContents
  let result = parseOnly (matrixParser <* endOfInput) $ pack input
  putStrLn $ case result of
    Left  err -> err
    Right m   -> definiteness m

matrixParser :: Parser (Matrix (Complex Double))
matrixParser = loadMatrix =<< (skipSpace *> many' (double <* skipSpace))
  where
    loadMatrix xs = do
      let n = floor . sqrt . fromIntegral . length $ xs
      if n * n /= length xs
      then fail "The provided matrix has to be square"
      else pure $ (n><n) $ (:+ 0) <$> xs

definiteness :: Matrix (Complex Double) -> String
definiteness m = flip orElse "indefinite" $
  foldl ((. uncurry classify) <$> (<|>)) Nothing classes

  where
    eValues = realPart <$> toList (eigenvalues m)
    classify f c = if all f eValues then Just c else Nothing

    orElse Nothing  x = x
    orElse (Just x) _ = x

    classes = [ ((>  0), "positive definite")
              , ((<  0), "negative definite")
              , ((>= 0), "positive semidefinite")
              , ((<= 0), "negative semidefinite")
              ]


module Util where

import Data.List
import Data.Ord

import Numeric.Container
import Numeric.LinearAlgebra ()

-- | Short function for logarithmus dualis
ld :: Floating a => a -> a
ld = logBase 2

-- | Returns a subsequnce of length k starting at index i.
cut :: Int -> Int -> [a] -> [a]
cut k i = take k . drop (i - 1)

-- | Returns all subsequences of length k.
cuts :: Int -> [a] -> [[a]]
cuts k s = map (take k) . zipWith const (iterate tail s) $ drop (k-1) s

-- | Checks two consecutive for convergence. If a convergence is found, the list
-- will be truncated.
convergenceOn :: (a -> a -> Double) -> Double -> [a] -> [a]
convergenceOn f c ls = map fst . takeWhile snd $ zip ls bs
  where
    bs = True : True : zipWith condition ls (tail ls)
    condition x y = f x y > c

-- | Returns the column indices for the biggest element in each row.
maxCols :: Matrix Double -> [Int]
maxCols = map row . toRows
  where
    row = fst . maximumBy (comparing snd) . zip [1 :: Int ..] . toList

-- | Normalizes the elements of a vector so that they sum up to 1.
normalizeVector :: Vector Double -> Vector Double
normalizeVector v = scale (recip $ sumElements v) v

-- | Normalizes the columns, so that each of column sums is 1.
normalizeColumns :: Matrix Double -> Matrix Double
normalizeColumns = fromColumns . map normalizeVector . toColumns

-- | Normalizes the row, so that each of row sums is 1.
normalizeRows :: Matrix Double -> Matrix Double
normalizeRows = fromRows . map normalizeVector . toRows

-- | Calculates the mean squared error for two matrices (elementwise + summing up).
meanSquaredError :: Matrix Double -> Matrix Double -> Double
meanSquaredError m m' = (/ n) . sumElements $ (m' - m)^^(2 :: Int)
  where
    n = fromIntegral $ rows m * cols m

-- vim: set ts=4 sts=4 sw=4 tw=80 et:


module Julia where

import Data.Complex
import System.Random
import Data.List

-- JULIA MATH-----
-- A generalized Julia Function
superJulia :: (RealFloat a, Fractional a) =>  [Complex a] -- parameters
  -> Complex a -- starting point.
  -> Complex a
superJulia [c] z = c
superJulia (c:cs) z = c * z^(length cs) + superJulia cs z

-- Some functions that look cool.

{--
snowflake :: (RealFloat a, Fractional a) => a -> Complex a -> Complex a -> Complex a
    -> Complex a -> Complex a
    --}
snowflake p a b c z = (abs (a * (z ^ p))) * b + c

flake :: (RealFloat a, Fractional a) => Complex a -> Complex a
flake z = z^6 + (0.883 * (cis(pi/4)))

flake2 :: (RealFloat a, Fractional a) => Complex a -> Complex a
flake2 z = (0.91:+0.8) * z^3 + (mkPolar 0.8 1)

newton :: (Floating a, Fractional a) => a -> a -> a
newton n z = (1 + (n - 1) * z**n) / (n * (z**(n-1)))

glynn :: (RealFloat a, Fractional a) => Complex a -> Complex a
glynn z = z**1.5 - 0.2

julia7 :: (RealFloat a, Fractional a) => Complex a -> Complex a
julia7 z = z^3 + 0.400

dragon :: (RealFloat a, Fractional a) =>  Complex a -> Complex a
dragon z = z^2 + ((-0.835) :+ 0.2321)

sshaped :: (RealFloat a, Fractional a) =>  Complex a -> Complex a
sshaped z = z^2 + (0.32:+0.043)

pierced :: (RealFloat a, Fractional a) =>  Complex a -> Complex a
pierced z = z^2 + ((-0.74543):+0.11301)

liquidSpirals :: (RealFloat a, Fractional a) =>  Complex a -> Complex a
liquidSpirals z = z^2 + ((-0.1):+0.651)

julia1 :: (RealFloat a, Fractional a) => Complex a -> Complex a
julia1 z = z^2 + ((-0.156844471694257101941):+(-0.649707745759247905171))

julia2 :: (RealFloat a, Fractional a) => Complex a -> Complex a
julia2 z = z^2 + ((-0.4):+0.6)

julia3 :: (RealFloat a, Fractional a) => Complex a -> Complex a
julia3 z = 1 - (z^2) + (z^5) / (2 + 4 * z) + (0.4:+0.6)

julia4 :: (RealFloat a, Fractional a) => Complex a -> Complex a
julia4 z = z^2 + ((-0.742):+0.1)

impossible :: (RealFloat a, Fractional a) => Complex a -> Complex a
impossible z = (sinh(z^2)**0.5) + (0.065:+0.122)

impossible2 :: (RealFloat a, Fractional a) => Complex a -> Complex a
impossible2 z = ((z^2+z)/log(z))+(0.268:+0.060)

superPattern :: (RealFloat a, Fractional a) =>  Complex a -> Complex a
superPattern z = (exp (z^3)) - 0.59


-- |
-- Module    : Statistics.Test.KruskalWallis
-- Copyright : (c) 2014 Danny Navarro
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
module Statistics.Test.KruskalWallis
  ( -- * Kruskal-Wallis test
    kruskalWallisTest
    -- ** Building blocks
  , kruskalWallisRank
  , kruskalWallis
  , module Statistics.Test.Types
  ) where

import Data.Ord (comparing)
import qualified Data.Vector.Unboxed as U
import Statistics.Function (sort, sortBy, square)
import Statistics.Distribution (complCumulative)
import Statistics.Distribution.ChiSquared (chiSquared)
import Statistics.Types
import Statistics.Test.Types
import Statistics.Test.Internal (rank)
import Statistics.Sample
import qualified Statistics.Sample.Internal as Sample(sum)

-- | Kruskal-Wallis ranking.
--
-- All values are replaced by the absolute rank in the combined samples.
--
-- The samples and values need not to be ordered but the values in the result
-- are ordered. Assigned ranks (ties are given their average rank).
kruskalWallisRank :: (U.Unbox a, Ord a) => [U.Vector a] -> [U.Vector Double]
kruskalWallisRank samples = groupByTags
                          . sortBy (comparing fst)
                          . U.zip tags
                          $ rank (==) joinSample
  where
    (tags,joinSample) = U.unzip
                      . sortBy (comparing snd)
                      $ foldMap (uncurry tagSample) $ zip [(1::Int)..] samples
    tagSample t = U.map (\x -> (t,x))

    groupByTags xs
        | U.null xs = []
        | otherwise = sort (U.map snd ys) : groupByTags zs
      where
        (ys,zs) = U.span ((==) (fst $ U.head xs) . fst) xs

-- | The Kruskal-Wallis Test.
--
-- In textbooks the output value is usually represented by 'K' or 'H'. This
-- function already does the ranking.
kruskalWallis :: (U.Unbox a, Ord a) => [U.Vector a] -> Double
kruskalWallis samples = (nTot - 1) * numerator / denominator
  where
    -- Total number of elements in all samples
    nTot    = fromIntegral $ sumWith rsamples U.length
    -- Average rank of all samples
    avgRank = (nTot + 1) / 2
    --
    numerator = sumWith rsamples $ \sample ->
        let n = fromIntegral $ U.length sample
        in  n * square (mean sample - avgRank)
    denominator = sumWith rsamples $ \sample ->
        Sample.sum $ U.map (\r -> square (r - avgRank)) sample

    rsamples = kruskalWallisRank samples

-- | Perform Kruskal-Wallis Test for the given samples and required
-- significance. For additional information check 'kruskalWallis'. This is just
-- a helper function.
--
-- It uses /Chi-Squared/ distribution for approximation as long as the sizes are
-- larger than 5. Otherwise the test returns 'Nothing'.
kruskalWallisTest :: (Ord a, U.Unbox a) => [U.Vector a] -> Maybe (Test ())
kruskalWallisTest []      = Nothing
kruskalWallisTest samples
  -- We use chi-squared approximation here
  | all (>4) ns = Just Test { testSignificance = mkPValue $ complCumulative d k
                            , testStatistics   = k
                            , testDistribution = ()
                            }
  | otherwise   = Nothing
  where
    k  = kruskalWallis samples
    ns = map U.length samples
    d  = chiSquared (length ns - 1)

-- * Helper functions

sumWith :: Num a => [Sample] -> (Sample -> a) -> a
sumWith samples f = Prelude.sum $ fmap f samples
{-# INLINE sumWith #-}


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}

module Trade.Statistics.TradeStatistics where

import qualified Data.Vector as Vec

import Data.Time.Clock (NominalDiffTime)

import qualified Data.List as List

import Data.Ord (comparing)

import qualified Statistics.Sample as Sample

import Trade.Type.DeltaSignal (DeltaSignal(..))
import qualified Trade.Type.DeltaSignal.Algorithm as DSA

import Trade.Type.Yield (LogYield(..), logYield2yield)

import Trade.Report.ToReport (ToReport, toReport)

import qualified Trade.Report.Table as Table

import Trade.Statistics.Statistics (Statistics(..), formatYield, formatStat)

import Trade.Statistics.Algorithm (mean, stdDev)

data TradeStatistics ohlc = TradeStatistics {
  maxPeak :: LogYield ohlc
  , meanPeak :: Statistics NominalDiffTime Double
  , stdDevPeak :: Statistics NominalDiffTime Double
  , maxDrawdown :: LogYield ohlc
  , meanDrawdown :: Statistics NominalDiffTime Double
  , stdDevDrawdown :: Statistics NominalDiffTime Double
  }

tradeStatistics :: [DeltaSignal ohlc] -> TradeStatistics ohlc
tradeStatistics dts =
  let maxs = map DSA.maximum dts
      mins = map DSA.minimum dts
      (maxDts, maxZs) = unzip (map (\(LogYield dt y) -> (dt, y)) maxs)
      maxDtsVec = Vec.map realToFrac (Vec.fromList maxDts)
      maxZsVec = Vec.fromList maxZs
      (minDts, minZs) = unzip (map (\(LogYield dt y) -> (dt, y)) mins)
      minDtsVec = Vec.map realToFrac (Vec.fromList minDts)
      minZsVec = Vec.fromList minZs
  in TradeStatistics {
    maxPeak = List.maximumBy (comparing logYield) maxs
    , meanPeak = Statistics (mean maxDtsVec) (exp (Sample.mean maxZsVec))
    , stdDevPeak = Statistics (stdDev maxDtsVec) (exp (Sample.stdDev maxZsVec))
    , maxDrawdown = List.minimumBy (comparing logYield) mins
    , meanDrawdown =  Statistics (mean minDtsVec) (exp (Sample.mean minZsVec))
    , stdDevDrawdown = Statistics (stdDev minDtsVec) (exp (Sample.stdDev minZsVec))
    }

tradeStatistics2table :: TradeStatistics ohlc -> [[String]]
tradeStatistics2table ts =
  [ ["Trade Statistics", "Yield", "Dur. from trade start"]
  , []
  , "Max. peak" : formatYield (logYield2yield (maxPeak ts))
  , "Mean peak" : formatStat (meanPeak ts)
  , "StdDev peak" : formatStat (stdDevPeak ts)
  , []
  , "Max. drawdown" : formatYield (logYield2yield (maxDrawdown ts))
  , "Mean drawdown" : formatStat (meanDrawdown ts)
  , "StdDev drawdown" : formatStat (stdDevDrawdown ts)
  ]

instance ToReport (TradeStatistics ohlc) where
  toReport = Table.table . tradeStatistics2table

toTradeStatistics ::
  (Functor f) =>
  f [DeltaSignal ohlc] -> f (TradeStatistics ohlc)
toTradeStatistics = fmap tradeStatistics


module Operators where

import Data.Complex
import Data.List (foldl1')

import BraKet
import LinAlg

import qualified Numeric.LinearAlgebra as L

-- Creation and annihilation operator definitions --

-- Creation operator in Fock basis
create :: Int -> MatOp
create n = Operator $ (L.><) n n elements
  where
    elements = [if i `elem` nonzeros then (sqrt .fromIntegral) (i `mod` n + 1) else 0 | i <- [0..n^2-1]]
    nonzeros = [i * n + i - 1 | i <- [0..n^2]]

-- Annihilation operator is just conjugate of creation
annihilate :: Int -> MatOp
annihilate n = L.tr <$> create n

-- Number operator definition: n = conj(a) <> a
number :: Int -> MatOp
number n = create n <> annihilate n

-- Density matrix operator
densityMatrix :: [Complex Double] -> [Ket (Complex Double)] -> MatOp
densityMatrix ps kets = foldl1 (<+>) $ zipWith (<**>) ps projectors
    where
      projectors = (\state -> outerProduct state state) <$> kets :: [MatOp]

-- Displacement operator
displacement :: Int -> Complex Double -> MatOp
displacement n alpha = L.expm <$> (conjugate alpha <**> create n
                                        <~> (alpha <**> annihilate n))

squeeze :: Int -> Complex Double -> MatOp
squeeze n z = L.expm <$> ((0.5 :+ 0.0) <**> (conjugate z <**> (annihilate n <> annihilate n)
                                                  <~> (z <**> (create n <> create n))))


{-# LANGUAGE BangPatterns #-}

module FFT where

import Prelude hiding ((++))
import qualified Data.ByteString.Lazy.Char8      as BS
import qualified Data.ByteString.Lex.Lazy.Double as BS
import qualified Data.Vector as V
import Data.Vector ((!),(++),Vector)
import Data.List hiding ((++))
import Data.Complex
import System.Environment

headerSize bs = (+) 4 (BS.length . BS.concat . Prelude.take 4 . BS.lines $ bs)

dropHeader bs = BS.drop (headerSize bs) $ bs

main = do
   [f] <- getArgs
   s   <- BS.readFile f
   print . V.map (round. realPart) . ifft_CT. fft_CT . parse $ (dropHeader s)

dft :: Vector (Double) -> Vector (Complex Double)
dft xr = V.map (\k -> V.sum (V.imap (arg k) xr)) (numvec n)
 where
   n = V.length xr
   nf = fromIntegral n
   numvec n = V.enumFromStepN 0 1 n
   arg k i x = (x:+0) * exp (-2 * pi * kf * ifl * (0:+1)/nf)
             where
               kf = fromIntegral k
               ifl = fromIntegral i

idft :: Vector (Complex Double) -> Vector (Complex Double)
idft xs = V.map (\k ->(/) (V.sum (V.imap (arg k) xs)) nf) (numvec n)
 where
   n = V.length xs
   nf = fromIntegral n
   numvec n = V.enumFromStepN 0 1 n
   arg k i x = x * exp (2 * pi * kf * ifl * (0:+1)/nf)
             where
               kf = fromIntegral k
               ifl = fromIntegral i

fft_CT xs = if V.length xs == 1 then
             dft xs
           else
             let xtop = V.zipWith3 fft_top (fft_CT xse) (fft_CT xso) (V.enumFromStepN 0 1 m)

                 xbottom = V.zipWith3 fft_bottom (fft_CT xse) (fft_CT xso) (V.enumFromStepN 0 1 m)
                 xse = V.map (xs !) (V.enumFromStepN 0 2 m)
                 xso = V.map (xs !) (V.enumFromStepN 1 2 m)
                 n = V.length xs
                 nf = fromIntegral n
                 m = n `div` 2
                 fft_top xe xo k = xe + xo * exp (-2 * (0:+1) * pi * k / nf)
                 fft_bottom xe xo k = xe - xo * exp (-2 * (0:+1) * pi * k / nf)
             in
                 xtop ++ xbottom

ifft_CT xs = if V.length xs == 1 then
              idft xs
           else
              let xtop = V.zipWith3 fft_top (ifft_CT xse) (ifft_CT xso) (V.enumFromStepN 0 1 m)
                  xtop_scaled = V.map (/2) xtop
                  xbottom = V.zipWith3 fft_bottom (ifft_CT xse) (ifft_CT xso) (V.enumFromStepN 0 1 m)
                  xbottom_scaled = V.map (/2) xbottom
                  xse = V.map (xs !) (V.enumFromStepN 0 2 m)
                  xso = V.map (xs !) (V.enumFromStepN 1 2 m)
                  n = V.length xs
                  nf = fromIntegral n
                  m = n `div` 2
                  fft_top xe xo k = xe + xo * exp (2 * (0:+1) * pi * k / nf)
                  fft_bottom xe xo k = xe - xo * exp (2 * (0:+1) * pi * k / nf)
             in
                xtop_scaled ++ xbottom_scaled

-- Fill a new vector from a file containing a list of numbers.
parse = V.unfoldr step
 where
   step !s = case BS.readDouble s of
     Nothing       -> Nothing
     Just (!k, !t) -> Just (k, BS.tail t)


{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}
import           Control.Monad
import           Control.Monad.Random
import           GHC.TypeLits

import qualified Numeric.LinearAlgebra.Static as SA

import           Grenade

{--
  Learning circles
  ================
    This simple example shows how to create a
    network which learns the shape of a circle.
--}

{--
  The Network type
  ================
    For this simple example, we will use a network consisting of
    fully connected layers. There are two hidden layers with 40 neurons
    and 10 neurons respectively. We use the tanh, relu and logit
    activation functions.
    Given an (x, y) coordinate, the output is the probability the
    coordinate is inside the circle.
--}
type FFNet
  = Network
    '[ FullyConnected 2 40, Tanh,
       FullyConnected 40 10, Relu,
       FullyConnected 10 1, Logit
     ]
    '[ 'D1 2,          -- Input
       'D1 40, 'D1 40, -- Tanh fully connected
       'D1 10, 'D1 10, -- Relu fully connected
       'D1 1, 'D1 1    -- Logit fully connected
     ]

{--
  A helper function for displaying the circles.
--}
drawCircle :: FFNet -> IO ()
drawCircle network = do
    let testIns = [ [ (x,y)  | x <- [0..50] ] | y <- [0..20] ]
        outMat  = (map . map) renderCoord testIns
    putStrLn $ unlines outMat

  where
    render n'  | n' <= 0.2  = ' '
               | n' <= 0.4  = '.'
               | n' <= 0.6  = '-'
               | n' <= 0.8  = '='
               | otherwise = '#'

    normx :: S ('D1 1) -> RealNum
    normx (S1D r) = SA.mean r

    renderCoord (x, y) = (render . normx) $ runNet network (S1D $ SA.vector [x / 25 - 1, y / 10 - 1])

{--
  This is the function we are attempting to learn.
  Given a vector (x, y), we check if the distance from the origin
  is less than a radius of 0.5, and return 1 if the coordinate is
  inside the circle and 0 otherwise.
--}
circle :: S ('D1 2) -> S ('D1 1)
circle (S1D v) =
  if v `inCircle` (fromRational 0, 0.5)
     then S1D $ fromRational 1
     else S1D $ fromRational 0
  where
    inCircle :: KnownNat n => SA.R n -> (SA.R n, RealNum) -> Bool
    u `inCircle` (o, r) = SA.norm_2 (u - o) <= r

{--
  Training and Execution
  ================
    Now we train our network and run it.
--}
main :: IO ()
main = do
    -- Train on 100000 examples, randomly generated with a uniform
    -- distribution.
    let n = 100000
    inps <- replicateM n $ do
      s  <- getRandom
      return $ S1D $ SA.randomVector s SA.Uniform * 2 - 1
    -- For our network, we will use stochastic gradient descent with a batch
    -- size of 1.
    let options = TrainingOptions { optimizer      = OptSGD 0.01 0.9 0.0001
                                  , batchSize      = 1
                                  , validationFreq = 1
                                  , verbose        = Full
                                  , metrics        = [Quadratic]
                                  }
    -- Now we train the network with the fit function.
    -- We pass in a list of tuples of inputs and expected outputs,
    -- and use the quadratic loss function. We train for one epoch.
    -- There is no validation data, hence we pass in an empty list.
    net <- fit (zip inps (map circle inps)) [] options 1 quadratic'

    -- Now we visualise what our network has learned.
    drawCircle net


module Main where

import qualified  Statistics.Matrix as M
-- import            Data.Vector
import            System.Random
import            Control.Monad.Random

import NeuralNetwork

inputX :: M.Matrix
inputX = M.fromList 3 2 [ 3 , 5
                        , 5 , 1
                        , 10, 2
                        ]

inputY :: M.Matrix
inputY = M.fromList 3 1 [ 75
                        , 82
                        , 93
                        ]

inputXN :: M.Matrix
inputXN = M.map (\x -> x / 24) inputX

inputYN :: M.Matrix
inputYN = M.map (\x -> x / 100) inputY

main :: IO ()
main = do
    let g  = mkStdGen 123123123123
        nn = flip evalRand g $ initNetwork 2 1 3
    print $ costFunction nn inputXN inputYN

main' :: IO ()
main' = do
    let g  = mkStdGen 123123123123123
        nn = flip evalRand g $ initNetwork 2 1 3
        (dJdW1, dJdW2) = costFunctionPrime nn inputX inputY

        scalarW1 = M.fromList 2 3 (replicate 6 3)
        scalarW2 = M.fromList 3 1 (replicate 3 3)

        nn' = nn { weight1Matrix = weight1Matrix nn + (scalarW1 `pointMultiply` dJdW1)
                 , weight2Matrix = weight2Matrix nn + (scalarW2 `pointMultiply` dJdW2) }

    print $ costFunctionPrime nn' inputXN inputYN

g  = mkStdGen 123123123123123
nn = flip evalRand g $ initNetwork 2 1 3
(dJdW1, dJdW2) = costFunctionPrime nn inputXN inputYN

scalarW1 = M.fromList 2 3 (replicate 6 3)
scalarW2 = M.fromList 3 1 (replicate 3 3)

nn' = nn { weight1Matrix = weight1Matrix nn + (scalarW1 `pointMultiply` dJdW1)
         , weight2Matrix = weight2Matrix nn + (scalarW2 `pointMultiply` dJdW2)
         }


module Runner where

import NeuralNet
import Mnist
import Backprop

import Numeric.LinearAlgebra
import Data.List
import Data.Maybe
import System.Random
import Debug.Trace

targets :: [[Double]]
targets =
    [
        [0.9, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1]
      , [0.1, 0.9, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1]
      , [0.1, 0.1, 0.9, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1]
      , [0.1, 0.1, 0.1, 0.9, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1]
      , [0.1, 0.1, 0.1, 0.1, 0.9, 0.1, 0.1, 0.1, 0.1, 0.1]
      , [0.1, 0.1, 0.1, 0.1, 0.1, 0.9, 0.1, 0.1, 0.1, 0.1]
      , [0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.9, 0.1, 0.1, 0.1]
      , [0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.9, 0.1, 0.1]
      , [0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.9, 0.1]
      , [0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.9]
    ]

{-
targets :: [[Double]]
targets =
    [
        [1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0]
      , [0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0]
      , [0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0]
      , [0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0]
      , [0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0]
      , [0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0]
      , [0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0]
      , [0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0]
      , [0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0]
      , [0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0]
    ]
-}

interpret :: [Double] -> Int
interpret v = fromJust (elemIndex (maximum v) v)

isMatch :: (Eq a) => a -> a -> Int
isMatch x y =
  if x == y
  then 1
  else 0

type LabelledImage = ([Double], Int)
-- ^ The training set, an array of input/target pairs

trainOnePattern
  :: (NeuralNet n)
  => LabelledImage
  -> n
  -> n
trainOnePattern trainingData net = train net input target
  where input = fst trainingData
        digit = snd trainingData
        target = targets !! digit

trainWithAllPatterns
  :: (NeuralNet n)
  => n
  -> [LabelledImage]
  -> n
trainWithAllPatterns = foldr trainOnePattern

evalOnePattern
  :: (NeuralNet n)
  => n
  -> LabelledImage
  -> Int
evalOnePattern net trainingData = isMatch result target
  where input = fst trainingData
        target = snd trainingData
        rawResult = evaluate net input
        result = interpret rawResult

evalAllPatterns
  :: (NeuralNet n)
  => n
  -> [LabelledImage]
  -> [Int]
evalAllPatterns = map . evalOnePattern

readTrainingData :: IO [LabelledImage]
readTrainingData = do
--  putStrLn "Reading training labels..."
  trainingLabels <- readLabels "train-labels-idx1-ubyte"
--  putStrLn $ "Read " ++ show (length trainingLabels) ++ " labels"
--  putStrLn "Reading training images..."
  trainingImages <- readImages "train-images-idx3-ubyte"
--  putStrLn $ "Read " ++ show (length trainingImages) ++ " images"
  return (zip (map normalisedData trainingImages) trainingLabels)

readTestData :: IO [LabelledImage]
readTestData = do
--  putStrLn "Reading test labels..."
  testLabels <- readLabels "t10k-labels-idx1-ubyte"
--  putStrLn $ "Read " ++ show (length testLabels) ++ " labels"
--  putStrLn "Reading test images..."
  testImages <- readImages "t10k-images-idx3-ubyte"
--  putStrLn $ "Read " ++ show (length testImages) ++ " images"
--  putStrLn "Testing..."
  return (zip (map normalisedData testImages) testLabels)


import Numeric.LinearAlgebra
import Numeric.LinearAlgebra.Util (ones,zeros)
import HVX

n = 4
a = EConst $ (n><n) ([0, 2, 0, 0,
                      -3, 0, 0, 0,
                       0, 0, 1, 0,
                       0, 0, 0, 4] :: [Double])
b = EConst $ (n><n) ([4, 8, -1, 0,
                      0, -2, 1, 0,
                      9, -3, 0, 3,
                      0, 0,  2, 0] :: [Double])
c = EConst $ (n><1) [1..]

x = EVar "x"
y = EVar "y"
constNeg3 = EConst $ scale (-3.0) $ ones n 1
constTwos = EConst $ scale 2.0 $ ones n 1

ans = subgradMinimize
  (norm 2 (a *~ x) +~ norm 2 (b *~ y) +~ norm 2 (c +~ x +~ neg y))
  [y <=~ constTwos, x <=~ constNeg3]
  (decNonSumStep 10.0) 5000
  [("x",zeros n 1), ("y", zeros n 1)]

main :: IO ()
main = do
  putStrLn $ show ans


module Vec (module Vec, module L) where

import Foreign
import qualified Data.Vector as V
import qualified Data.Vector.Storable as S
import qualified Data.Vector.Unboxed as U
import Numeric.LinearAlgebra as L hiding ((<>))

type UVec = U.Vector
type SVec = S.Vector
type BVec = V.Vector

type Vec2 = L.Vector R
type Vec3 = L.Vector R
type Vec4 = L.Vector R

type Lin2 = (Vec2, Vec2)
type Tgl2 = (Vec2, Vec2, Vec2)

type Lin3 = (Vec3, Vec3)
type Tgl3 = (Vec3, Vec3, Vec3)

type Mat2 = L.Matrix R
type Mat3 = L.Matrix R
type Mat4 = L.Matrix R

{-# INLINE vec #-}
vec :: Storable a => [a] -> L.Vector a
vec = L.fromList

{-# INLINE lis #-}
lis :: Storable a => L.Vector a -> [a]
lis = L.toList

rx :: (Storable a, Floating a) => a -> Matrix a
rx a = let
  s = sin a
  c = cos a
  in (3><3) [ 1, 0 , 0,
              0, c, -s,
              0, s,  c ]

ry :: (Storable a, Floating a) => a -> Matrix a
ry a = let
  s = sin a
  c = cos a
  in (3><3) [  c, 0, s,
               0, 1, 0,
              -s, 0, c ]

rz :: (Storable a, Floating a) => a -> Matrix a
rz a = let
  s = sin a
  c = cos a
  in (3><3) [ c, -s, 0,
              s,  c, 0,
              0,  0, 1 ]


{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

module SSSFN
  ( -- * Domain
    np,

    -- * Grid
    Grid (..),
    gunit,
    (!),
    gcoerce,

    -- * Operators
    Op (..),
    ounit,
    ocoerce,

    -- * Grids are functors etc.
    gmap,
    gpure,
    gzipWith,
    gfoldMap,
    gcount,
    gmaxabs,
    gsum,

    -- * Operators are functors etc.
    omap,
    opure,
    ozipWith,
    ofoldMap,
    ocount,
    omaxabs,
    osum,

    -- * Operators
    (#>),
    transpose,
    inv,

    -- * Coordinates
    isOrigin,
    coordU,
    coordV,
    coordT,
    coordR,
    coordR1, -- remove?

    -- * Sampling functions
    gsample,

    -- * Evaluating functions
    geval,
    gevalCoeffs,

    -- * Derivatives
    vandermonde,
    expfilter,
    delta,
    symmetrizeU,
    symmetrizeV,
    symmetrizeR,
    derivU,
    derivV,
    derivUU,
    derivUV,
    derivVV,
    derivT,
    derivR,
    derivTT,
    derivRR,
    r1derivR,
    r1derivU,
    r1derivV,
    r2project,
    zproject,
    bndU,
    bndV,
    metric,

    -- * Systems of equations
    solve,
    solveLS,

    -- * MaxAbs
    maxabs,
    getMaxAbs,
  )
where

import Control.Exception (assert)
import Data.Maybe
import Data.Poly hiding (scale)
import Data.Semigroup hiding ((<>))
import qualified Data.Vector.Unboxed as U
import Data.VectorSpace
import Foreign
import qualified GHC.Exts as GHC
import Numeric.LinearAlgebra hiding ((!), (#>), inv)
import qualified Numeric.LinearAlgebra as L
import Numeric.LinearAlgebra.Devel
import qualified Test.QuickCheck as QC
import Prelude hiding ((<>))
import qualified Prelude as P

default (Int)

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

-- | Grid size
np :: Int
np = 33

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

-- | Grid datatype
newtype Grid a = Grid {getGrid :: Vector a}
  deriving (Eq, Ord, Read, Show)

instance (QC.Arbitrary a, Storable a) => QC.Arbitrary (Grid a) where

  arbitrary = Grid . fromList <$> QC.vector (np ^ 2)

  shrink = map (Grid . fromList) . traverse QC.shrink . toList . getGrid

instance (Storable a) => GHC.IsList (Grid a) where

  type Item (Grid a) = a

  fromList = Grid . fromList

  toList = toList . getGrid

(!) :: (Container Vector a) => Grid a -> (Int, Int) -> a
(!) (Grid x) (i, j) = x `atIndex` (i * np + j)

gunit :: (Num a, Storable a) => (Int, Int) -> Grid a
gunit (i, j) =
  let ij = i * np + j
   in Grid $ fromList [if k == ij then 1 else 0 | k <- [0 .. np ^ 2 -1]]

gcoerce :: forall a b. (Storable a, Storable b) => Grid a -> Grid b
gcoerce (Grid xss) =
  assert (na * sa `mod` sb == 0) $
    (Grid $ fromByteString $ toByteString xss)
  where
    na = cols (asRow xss)
    sa = sizeOf @a undefined
    sb = sizeOf @b undefined

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

-- | Operator datatype
newtype Op a = Op {getOp :: Matrix a}
  deriving (Read, Show)

instance (QC.Arbitrary a, Element a) => QC.Arbitrary (Op a) where

  arbitrary = Op . reshape (np ^ 2) . fromList <$> QC.vector (np ^ 4)

  shrink =
    map (Op . reshape (np ^ 2) . fromList)
      . traverse QC.shrink
      . (toList . flatten . getOp)

instance Element a => GHC.IsList (Op a) where

  type Item (Op a) = a

  fromList = Op . reshape (np ^ 2) . fromList

  toList = toList . flatten . getOp

ounit :: (Element a, Num a) => Op a
ounit = Op $ ident (np ^ 2)

ocoerce :: forall a b. (Container Vector a, Num a, Storable b) => Op a -> Op b
ocoerce (Op x) =
  assert (ma * sa `mod` sb == 0 && na * sa `mod` sb == 0) $
    (Op $ reshape nb $ getGrid $ gcoerce $ Grid $ flatten x)
  where
    (ma, na) = size x
    sa = sizeOf @a undefined
    sb = sizeOf @b undefined
    nb = na * sa `div` sb

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

-- | Grids are functors etc.
-- gmap :: (Container Vector a, Element b) => (a -> b) -> Grid a -> Grid b
-- gmap f (Grid x) = Grid (cmap f x)
gmap :: (Storable a, Storable b) => (a -> b) -> Grid a -> Grid b
gmap f (Grid x) = Grid (mapVectorWithIndex (\i a -> f a) x)

gpure :: Container Vector a => a -> Grid a
gpure a = Grid $ konst a (np ^ 2)

gzipWith ::
  (Storable a, Storable b, Storable c) =>
  (a -> b -> c) ->
  Grid a ->
  Grid b ->
  Grid c
gzipWith f (Grid x) (Grid y) = Grid (zipVectorWith f x y)

gfoldMap :: (Storable a, Monoid b) => (a -> b) -> Grid a -> b
gfoldMap f (Grid x) = foldVector (\a b -> f a P.<> b) mempty x

gcount :: Container Vector a => Grid a -> Int
gcount (Grid x) = size x

gmaxabs :: (Container Vector a, Num a, Ord a) => Grid a -> a
gmaxabs = getMaxAbs . gfoldMap maxabs

gsum :: (Container Vector a) => Grid a -> a
gsum (Grid x) = sumElements x

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

-- | Operators are functors etc.
-- omap :: (Container Vector a, Num a, Element b) => (a -> b) -> Op a -> Op b
-- omap f (Op x) = Op (cmap f x)
omap :: (L.Element a, Storable b) => (a -> b) -> Op a -> Op b
omap f (Op x) = Op $ reshape n $ getGrid $ gmap f $ Grid $ flatten x
  where
    n = cols x

opure :: (Container Vector a, Num a) => a -> Op a
opure a = Op (konst a (np ^ 2, np ^ 2))

ozipWith ::
  (Element a, Element b, Storable c) =>
  (a -> b -> c) ->
  Op a ->
  Op b ->
  Op c
ozipWith f (Op x) (Op y) =
  Op $ reshape (np ^ 2) $ zipVectorWith f (flatten x) (flatten y)

ofoldMap :: (Element a, Monoid b) => (a -> b) -> Op a -> b
ofoldMap f (Op x) = foldVector (\a b -> f a P.<> b) mempty (flatten x)

ocount :: (Container Vector a, Num a) => Op a -> Int
ocount (Op x) = let (ni, nj) = size x in ni * nj

omaxabs :: (Container Vector a, Num a, Ord a) => Op a -> a
omaxabs = getMaxAbs . ofoldMap maxabs

osum :: (Container Vector a, Num a) => Op a -> a
osum (Op x) = sumElements x

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

-- | Grids are an additive group
instance
  (Container Vector a, Num a) =>
  AdditiveGroup (Grid a)
  where

  zeroV = gpure 0

  (^+^) = gzipWith (+)

  negateV = gmap negate

-- | Grids are a vector space
instance
  (Container Vector a, Num a) =>
  VectorSpace (Grid a)
  where

  type Scalar (Grid a) = a

  (*^) a = gmap (a *)

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

-- | Operators form an additive group
instance (Container Vector a, Num a) => AdditiveGroup (Op a) where

  zeroV = opure 0

  (^+^) = ozipWith (+)

  negateV = omap negate

-- | Operators form a vector space
instance (Container Vector a, Num a) => VectorSpace (Op a) where

  type Scalar (Op a) = a

  (*^) a = omap (a *)

-- | Operators form a ring
instance (Container Vector a, Num a, Numeric a) => Num (Op a) where

  (+) = (^+^)

  negate = negateV

  (-) = (^-^)

  Op x * Op y = Op (x <> y)

  abs = omap abs

  signum = omap signum

  fromInteger i = fromInteger i *^ ounit

-- | Matrix-vector multiplication
infixr 8 #>

(#>) :: Numeric a => Op a -> Grid a -> Grid a
Op x #> Grid y = Grid (x L.#> y)

-- | Matrix transpose
transpose :: Transposable (Matrix a) (Matrix a) => Op a -> Op a
transpose (Op x) = Op (tr x)

-- | Matrix inverse
inv :: Field a => Op a -> Op a
inv (Op x) = Op (L.inv x)

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

-- | Coordinate of a grid point
coord :: Floating a => Int -> a
coord i =
  let imin = 0
      imax = np - 1
      umin = -1
      umax = 1
      u =
        fromIntegral (i - imax) / fromIntegral (imin - imax) * umin
          + fromIntegral (i - imin) / fromIntegral (imax - imin) * umax
   in sin (pi / 2 * u)

-- | Coordinates of all grid points
coords :: (Floating a, Storable a) => Vector a
coords = fromList [coord i | i <- [0 .. np -1]]

poly2vector :: (Num a, Storable a, U.Unbox a) => UPoly a -> Vector a
poly2vector p =
  let v = unPoly p
      n = U.length v
   in fromList [if i < n then v U.! i else 0 | i <- [0 .. np -1]]

-- | Evalute a polynomial at a grid point
evalcoeffs :: (Eq a, Num a, Storable a, U.Unbox a) => a -> Vector a
evalcoeffs u = fromList [eval (mon i) u | i <- [0 .. np -1]]
  where
    mon :: (Eq a, Num a, U.Unbox a) => Int -> UPoly a
    mon i = monomial (fromIntegral i) 1

-- | Evaluate a polynomial at all grid points
gvandermonde :: (Element a, Eq a, Floating a, U.Unbox a) => Matrix a
gvandermonde = fromRows [evalcoeffs u | u <- toList coords]

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

-- Note: hmatrix is row-major by default
mkGrid :: (Num a, Storable a) => (Int -> a) -> (Int -> a) -> Grid a
mkGrid fx fy =
  Grid $ fromList [fx i * fy j | i <- [0 .. np -1], j <- [0 .. np -1]]

isOrigin :: Grid Bool
isOrigin =
  Grid $
    fromList
      [ i == j
        | i <- [0 .. np -1],
          j <- [0 .. np -1]
      ]

-- | Coordinates of all grid points
coordU :: (Container Vector a, Floating a) => Grid a
coordU = mkGrid (coords `atIndex`) (const 1)

-- | Coordinates of all grid points
coordV :: (Container Vector a, Floating a) => Grid a
coordV = mkGrid (const 1) (coords `atIndex`)

-- | Combined coordinates
coordT :: (Container Vector a, Floating a) => Grid a
coordT = coordV ^+^ coordU

coordR :: (Container Vector a, Floating a) => Grid a
coordR = coordV ^-^ coordU

coordR1 :: (Container Vector a, RealFloat a) => Grid a
coordR1 = gzipWith (\isOrig r -> if isOrig then 0 else recip r) isOrigin coordR

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

-- | Sample a function at grid points
gsample ::
  (Container Vector a, Floating a, Storable b) =>
  ((a, a) -> b) ->
  Grid b
gsample f = gzipWith (curry f) (coordU) (coordV)

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

-- | Evaluate a grid at a point
-- f / Identity
geval ::
  ( Container Vector a,
    Eq a,
    Field a,
    U.Unbox a,
    Container Vector b,
    VectorSpace b,
    Scalar b ~ a
  ) =>
  Grid b ->
  (a, a) ->
  b
geval g (u, v) =
  let ucoeffs = tr (L.inv gvandermonde) L.#> evalcoeffs u
      vcoeffs = tr (L.inv gvandermonde) L.#> evalcoeffs v
   in sumV
        [ ((ucoeffs `atIndex` i) * (vcoeffs `atIndex` j)) *^ (g ! (i, j))
          | i <- [0 .. np - 1],
            j <- [0 .. np - 1]
        ]

gevalCoeffs ::
  ( Container Vector a,
    Eq a,
    Field a,
    U.Unbox a
  ) =>
  (a, a) ->
  Grid a
gevalCoeffs (u, v) =
  let ucoeffs = tr (L.inv gvandermonde) L.#> evalcoeffs u
      vcoeffs = tr (L.inv gvandermonde) L.#> evalcoeffs v
   in Grid $
        fromList
          [ (ucoeffs `atIndex` i) * (vcoeffs `atIndex` j)
            | i <- [0 .. np - 1],
              j <- [0 .. np - 1]
          ]

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

-- | Derivative of a basis function
deriv1 :: (Eq a, Num a, Storable a, U.Unbox a) => Int -> Vector a
deriv1 i = poly2vector $ deriv $ monomial (fromIntegral i) 1

-- | Derivatives of all basis functions
derivs1 :: (Element a, Eq a, Num a, U.Unbox a) => Matrix a
derivs1 = fromColumns [deriv1 i | i <- [0 .. np -1]]

derivs :: (Eq a, Field a, U.Unbox a) => Matrix a
derivs = gvandermonde <> derivs1 <> L.inv gvandermonde

-- derivs2 :: (Eq a, Field a, U.Unbox a) => Matrix a
-- derivs2 = derivs <> derivs

expfilter1 :: (Container Vector a, RealFloat a) => Matrix a
expfilter1 =
  diag $
    fromList
      [ let n0 = np `div` 2
         in if i <= n0
              then 1
              else peps ** (fromIntegral (i - n0) / fromIntegral (np - n0))
        | i <- [0 .. np -1]
      ]

expfilters :: (Container Vector a, Field a, RealFloat a, U.Unbox a) => Matrix a
expfilters = gvandermonde <> expfilter1 <> L.inv gvandermonde

bnd :: (Element a, Fractional a) => Matrix a
bnd =
  diag $
    fromList
      [ if i == 0
          then -1 / fromIntegral (np - 1)
          else if i == np - 1 then 1 / fromIntegral (np - 1) else 0
        | i <- [0 .. np - 1]
      ]

weights :: (Element a, Fractional a) => Matrix a
weights =
  diag $
    fromList
      [ if i == 0 || i == np - 1
          then 1 / fromIntegral (np - 1)
          else 2 / fromIntegral (np - 1)
        | i <- [0 .. np - 1]
      ]

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

mkOp :: (Element a, Num a) => ((Int, Int) -> a) -> ((Int, Int) -> a) -> Op a
mkOp fx fy =
  Op $
    fromLists
      [ [ fx (ir, ic) * fy (jr, jc)
          | ic <- [0 .. np - 1],
            jc <- [0 .. np - 1]
        ]
        | ir <- [0 .. np - 1],
          jr <- [0 .. np - 1]
      ]

vandermonde :: (Container Vector a, Eq a, Floating a, U.Unbox a) => Op a
vandermonde = mkOp (gvandermonde `atIndex`) (gvandermonde `atIndex`)

expfilter :: (Container Vector a, Field a, RealFloat a, U.Unbox a) => Op a
expfilter = mkOp (expfilters `atIndex`) (expfilters `atIndex`)

delta :: Field a => Op a
delta = mkOp delta1 delta1
  where
    delta1 (i, j) = if i == j then 1 else 0

diagonal :: (Element a, Num a) => Grid a -> Op a
diagonal (Grid xs) = Op $ diag xs

originR :: Field a => Op a
originR =
  Op $
    fromLists
      [ [ if ic == ir && jc == jr && ic == jc then 1 else 0
          | ic <- [0 .. np - 1],
            jc <- [0 .. np - 1]
        ]
        | ir <- [0 .. np - 1],
          jr <- [0 .. np - 1]
      ]

valueAtOriginR :: (Eq a, Field a, U.Unbox a) => Op a
valueAtOriginR =
  Op $
    fromRows
      [ let t = coordT ! (ir, jr)
            r = 0
            v = (t + r) / 2
            u = (t - r) / 2
         in getGrid (gevalCoeffs (u, v))
        | ir <- [0 .. np - 1],
          jr <- [0 .. np - 1]
      ]

reverseU :: (Element a, Num a) => Op a
reverseU = mkOp reverse1 delta1
  where
    reverse1 (i, j) = if i == np -1 - j then 1 else 0
    delta1 (i, j) = if i == j then 1 else 0

reverseV :: (Element a, Num a) => Op a
reverseV = mkOp delta1 reverse1
  where
    reverse1 (i, j) = if i == np -1 - j then 1 else 0
    delta1 (i, j) = if i == j then 1 else 0

-- change (t,r) -> (t,-r); (u,v) -> (v,u)
reverseR :: (Element a, Num a) => Op a
reverseR =
  Op $
    fromLists
      [ [ if ic == jr && jc == ir then 1 else 0
          | ic <- [0 .. np - 1],
            jc <- [0 .. np - 1]
        ]
        | ir <- [0 .. np - 1],
          jr <- [0 .. np - 1]
      ]

symmetrizeU :: Field a => Op a
symmetrizeU = (1 / 2) *^ (delta ^+^ reverseU)

symmetrizeV :: Field a => Op a
symmetrizeV = (1 / 2) *^ (delta ^+^ reverseV)

symmetrizeR :: Field a => Op a
symmetrizeR = (1 / 2) *^ (delta ^+^ reverseR)

-- | Derivatives of a grid
derivU :: (Eq a, Field a, U.Unbox a) => Op a
derivU = mkOp (derivs `atIndex`) delta1
  where
    delta1 (i, j) = if i == j then 1 else 0

derivV :: (Eq a, Field a, U.Unbox a) => Op a
derivV = mkOp delta1 (derivs `atIndex`)
  where
    delta1 (i, j) = if i == j then 1 else 0

derivUU :: (Eq a, Field a, U.Unbox a) => Op a
derivUU = derivU * derivU

derivUV :: (Eq a, Field a, U.Unbox a) => Op a
derivUV = derivU * derivV

derivVV :: (Eq a, Field a, U.Unbox a) => Op a
derivVV = derivV * derivV

-- | Combined derivatives
-- > t = v + u
-- > r = v - u
-- > t^2 = v^2 + 2 v u + u^2
-- > r^2 = v^2 - 2 v u + u^2
derivT :: (Eq a, Field a, U.Unbox a) => Op a
derivT = (derivV ^+^ derivU) ^/ 2

derivR :: (Eq a, Field a, U.Unbox a) => Op a
derivR = (derivV ^-^ derivU) ^/ 2

derivTT :: (Eq a, Field a, U.Unbox a) => Op a
derivTT = derivT * derivT

derivRR :: (Eq a, Field a, U.Unbox a) => Op a
derivRR = derivR * derivR

-- | 1/r dr
r1derivR :: (Field a, RealFloat a, U.Unbox a) => Op a
r1derivR =
  ((delta - originR) * diagonal coordR1 * derivR + originR * derivRR)
    * symmetrizeR

-- t = v + u   v = (t + r) / 2
-- r = v - u   u = (t - r) / 2

-- | 1/r du
r1derivU :: (Field a, RealFloat a, U.Unbox a) => Op a
r1derivU =
  ((delta - originR) * diagonal coordR1 * derivU - originR * derivUU)
    * symmetrizeR

-- | 1/r dv
r1derivV :: (Field a, RealFloat a, U.Unbox a) => Op a
r1derivV =
  ((delta - originR) * diagonal coordR1 * derivV + originR * derivVV)
    * symmetrizeR

-- | 1/r^2
r2project :: (Field a, RealFloat a, U.Unbox a) => Op a
r2project =
  ( (delta - originR) * diagonal (gmap (^ 2) coordR1)
      + originR * ((1 / 2) *^ derivRR)
  )
    * (delta - valueAtOriginR)
    * symmetrizeR

-- | zero at origin
zproject :: (Eq a, Field a, U.Unbox a) => Op a
zproject = (delta - valueAtOriginR) * symmetrizeR

-- | Boundary locations
bndU :: (Container Vector a, Fractional a) => Op a
bndU = mkOp (bnd `atIndex`) delta1
  where
    delta1 (i, j) = if i == j then 1 else 0

bndV :: (Container Vector a, Fractional a) => Op a
bndV = mkOp delta1 (bnd `atIndex`)
  where
    delta1 (i, j) = if i == j then 1 else 0

metric :: (Container Vector a, Fractional a) => Op a
metric = mkOp (weights `atIndex`) (weights `atIndex`)

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

solve :: Field a => Op a -> Grid a -> Grid a
solve (Op a) (Grid x) =
  Grid $ head $ toColumns $ fromJust $ linearSolve a (asColumn x)

solveLS :: Field a => Op a -> Grid a -> Grid a
solveLS (Op a) (Grid x) =
  Grid $ head $ toColumns $ linearSolveLS a (asColumn x)

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

newtype MaxAbs a = MaxAbsInternal a
  deriving (Eq, Ord, Read, Show)

maxabs :: Num a => a -> MaxAbs a
maxabs x = MaxAbsInternal (abs x)

getMaxAbs :: MaxAbs a -> a
getMaxAbs (MaxAbsInternal x) = x

instance Ord a => Semigroup (MaxAbs a) where
  MaxAbsInternal x <> MaxAbsInternal y = MaxAbsInternal $ max x y

instance (Num a, Ord a) => Monoid (MaxAbs a) where
  mempty = MaxAbsInternal 0


{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Numeric.Statistics.ICA
-- Copyright   :  (c) A. V. H. McPhail 2010, 2014
-- License     :  BSD3
--
-- Maintainer  :  haskell.vivian.mcphail <at> gmail <dot> com
-- Stability   :  provisional
-- Portability :  portable
--
-- Independent Components Analysis
--
--  implements the FastICA algorithm found in:
--
-- * Aapo Hyvärinen and Erkki Oja,
--   Independent Component Analysis: Algorithms and Applications,
--   /Neural Networks/, 13(4-5):411-430, 2000
--
--   <http://www.google.com/url?sa=t&source=web&cd=2&ved=0CBgQFjAB&url=http%3A%2F%2Fciteseerx.ist.psu.edu%2Fviewdoc%2Fdownload%3Fdoi%3D10.1.1.79.7003%26rep%3Drep1%26type%3Dpdf&ei=RQozTJb6L4_fcbCV6cMD&usg=AFQjCNGClLIB9MAvbrEj45SyUx9cYubLyA&sig2=hg5Wnfy3dLPkoIc1hqSfjg>
--
-----------------------------------------------------------------------------

module Numeric.Statistics.ICA (
                               sigmoid, sigmoid',
                               demean, whiten,
                               ica, icaDefaults,
                               --
                               NormType(..)
                          ) where

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

import qualified Data.Array.IArray as I

import Prelude hiding ((<>))

import Numeric.LinearAlgebra

import qualified Data.Vector.Generic as GV

import Numeric.GSL.Statistics

import Numeric.Statistics

import System.Random

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

data NormType = NormZero | NormOne | NormTwo | NormInf

pnorm :: Normed (Vector a) => NormType -> Vector a -> R
pnorm NormZero = norm_0
pnorm NormOne  = norm_1
pnorm NormTwo  = norm_2
pnorm NormInf  = norm_Inf

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

-- | sigmoid transfer function
sigmoid :: Double -> Double
sigmoid u = u * exp((-u**2)/2)

-- | derivative of sigmoid transfer function
sigmoid' :: Double -> Double
sigmoid' u = -u**2 * exp((-u**2)/2)

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

-- preprocessing:
--   demean
--   whiten
--        eigenvalue decomposition of covariance matrix E{xx^T} = EDE^T
--                   E orthogonal matrix of eigenvectors
--                   D diagonal matrix of eigenvalues, D = diag(d_1,...,d_n)
--                   x_white = ED^{-1/2}E^Tx
--                   D^{-1/2} = diag{d_1^{-1/2},...}
--

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

-- | remove the mean from data
demean :: I.Array Int (Vector Double)                  -- ^ the data
       -> (I.Array Int (Vector Double),Vector Double)  -- ^ (demeaned data,mean)
demean d = let u = I.elems $ fmap mean d
               d' = I.listArray (I.bounds d) (zipWith (-) (I.elems d) (map scalar u))
               u' = fromList u
               in (d',u')

-- | whiten data
whiten :: I.Array Int (Vector Double)                 -- ^ the data
       -> Double                                      -- ^ eigenvalue threshold
       -> (I.Array Int (Vector Double),Matrix Double) -- ^ (whitened data,transform)
whiten d q = let cv = covarianceMatrix d
                 (val',vec') = eigSH $ trustSym cv  -- the covariance matrix is real symmetric
                 val = toList val'
                 vec = toColumns vec'
                 v' = zip val vec
                 v = filter ((> q) . fst) v'        -- keep only eigens > than parameter
                 (dd',e') = unzip v
                 dd = diag $ (** (-0.5)) $ fromList dd'  -- square root of eigenvalues diagonalised
                 e = fromColumns e'
                 x = fromRows $ I.elems d
                 t = e <> dd <> tr' e          -- the actual mathematics
                 x' = t <> x                     -- the actual mathematics
                 d' = I.listArray (I.bounds d) (toRows x')
             in (d',t)

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

-- assuming that a weight vector is a row

-- algorithm:
-- 1  initial random weight vectors w_i
-- 2  w_i^+ = E{xg(w^Tx)} - E{g'(w^Tx)}w     (newton phase)
-- 3  W = W = (WW^T)^{-1/2)W                 (decorrelation) W = ( ..., w_i, ...)^T
--                                           WW^T = FDF^T (eigenvalue decomposition)
-- 4  w_i = w^+/norm(w^+)                    (normalisation) (almost any norm but not Frobenius)
-- 5  if not converged (dot w w^+ ~ 1 implies convergence) go to step 2
--
-- in matrix form, 2 becomes:
--    W^+ = W + (diag a_i)[(diag b_i) + E{g(y)y^T}]W
--
--      where
--            y = Wx
--            b_i = -E{y_ig(y_i)}
--            a_i = -1/(b_i-E{g'(y_i)})
--
--    g(u) = tanh(au) 0<=a<=2, often a = 1
--    g(u) = u exp(-u^2/2)

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

unconcat 0 _ _  = []
unconcat r c xs = [take c xs] ++ unconcat (r-1) c (drop c xs)

random_vector :: Int -> (Int,Int) -> Matrix Double
random_vector s (r,c) = fromLists $ unconcat r c $ randomRs (-1,1) (mkStdGen s)

-- g g' w x -> w'
update :: (Double -> Double) -> (Double -> Double) -> Matrix Double -> Matrix Double -> Matrix Double
update g g' w x = let y = w <> x
                      ys = toRows y
                      bis = map (\y' -> - mean (y' * (GV.map g y'))) ys
                      ais = zipWith (\b y' -> -1 / (b - mean (GV.map g y'))) bis ys
                      r = rows y
                      ix = ((1,1),(r,r))
                      cov = fromArray2D $ I.listArray ix $ map (\(m,n) -> covariance (GV.map g' (ys!!(m-1))) (ys!!(n-1))) $ I.range ix
                  in w + (diag $ fromList ais) <> ((diag $ fromList bis) + cov) <> w

decorrelate :: Matrix Double -> Matrix Double
decorrelate m = let (d',v') = eig m
                    d = fst $ fromComplex d'
                    v = fst $ fromComplex v'
                in v <> (diag (d ** (-0.5))) <> tr' v <> m
{-decorrelate n t w = let w' = w / (scalar $ sqrt $ pnorm n (w <> tr' w))
                    in decorrelate' t w w'
    where decorrelate' t' m m'
              | converged t' m m' = m'
              | otherwise         = decorrelate' t' m' ((scale 1.5 m') - (scale 0.5 (m' <> tr' m' <> m')))
-}

normalise :: NormType -> Matrix Double -> Matrix Double
normalise t m = fromRows $ map (\v -> v / (scalar $ pnorm t v)) (toRows m)

converged :: Double -> Matrix Double -> Matrix Double -> Bool
converged t m m' = let d' = map ((-) 1) $ zipWith dot (toRows m) (toRows m')
                   in maximum d' <= t

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

ica' :: (Double -> Double)          -- ^ transfer function (tanh,u exp(u^2/2), etc...)
     -> (Double -> Double)          -- ^ derivative of transfer function
     -> NormType                    -- ^ type of normalisation: Infinity, PNorm1, PNorm2
     -> Double                      -- ^ convergence tolerance for feature vectors
     -> Matrix Double               -- ^ weight matrix
     -> [Matrix Double]             -- ^ input data in chunks
     -> Matrix Double               -- ^ ica transform (weight matrix)
ica' _ _  _ _ _ []     = error "no sample data"
ica' g g' n t w (x:xs) = let w' = normalise n $ decorrelate $ update g g' w x
                             in if converged t w w'
                                then w'
                                else ica' g g' n t w' (xs ++ [x])

-- | perform an ICA transform
ica :: Int                         -- ^ random seed
    -> (Double -> Double)          -- ^ transfer function (tanh,u exp(u^2/2), etc...)
    -> (Double -> Double)          -- ^ derivative of transfer function
    -> NormType                    -- ^ type of normalisation: Infinity, PNorm1, PNorm2
    -> Double                      -- ^ convergence tolerance for feature vectors
--    -> Int                         -- ^ output dimensions
    -> Int                         -- ^ sampling size (must be smaller than length of data)
    -> I.Array Int (Vector Double) -- ^ data
    -> (I.Array Int (Vector Double),Matrix Double) -- ^ transformed data, ica transform
ica r g g' n t s a = let j = I.rangeSize $ I.bounds a
                         w = random_vector r (j,j)
                         x' = fromRows $ I.elems a
                         -- next line is BAD if distribution not stationary
                         x = concat $ toBlocksEvery j s x'
                         w' = ica' g g' n t w x
                         y = w' <> x'
                     in (I.listArray (1,1) $ toRows y,w')

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

-- | ICA with default values: no dimension reduction, euclidean norms, 16 sample groups, sigmoid
icaDefaults :: Int                         -- ^ random seed
            -> I.Array Int (Vector Double) -- ^ data
            -> (I.Array Int (Vector Double),Matrix Double) -- ^ transformed data, ica transform
icaDefaults r a = let c = I.rangeSize $ I.bounds a
                      s = (GV.length $ (a I.! 1)) `div` 16
                  in ica r sigmoid sigmoid' NormInf 0.0000001 s a

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


-- |
-- Module    : Numeric.ApproxEq
-- Copyright : (c) 2011 Aleksey Khudyakov, Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : Aleksey Khudyakov <alexey.skladnoy@gmail.com>
-- Stability   : experimental
-- Portability : portable
--
-- Different implementations of approximate equality for floating
-- point values. There are multiple ways to implement approximate
-- equality. They have different semantics and it's up to programmer
-- to choose right one.
module Numeric.ApproxEq (
    eqRelative
  , eqRelCompl
  , eqAbsolute
  , within
  ) where

import Control.Monad.ST         (runST)

import Data.Complex             (Complex(..))
import Data.Primitive.ByteArray (newByteArray, readByteArray, writeByteArray)
import Data.Int                 (Int64)

-- | Relative difference between two numbers are less than predefined
--   value.  For example 1 is approximately equal to 1.0001 with 1e-4
--   precision. Same is true for 10000 and 10001.
--
--   This method of camparison doesn't work for numbers which are
--   approximately 0. 'eqAbsolute' should be used instead.
eqRelative :: (Fractional a, Ord a)
           => a            -- ^ Relative precision
           -> a -> a -> Bool
eqRelative eps a b = abs (a - b) <= abs (eps * a)
{-# INLINE eqRelative #-}

-- | Relative equality for comlex numbers.
eqRelCompl :: (RealFloat a, Ord a)
           => a                 -- ^ Relative precision
           -> Complex a -> Complex a -> Bool
eqRelCompl eps a b = d <= eps * r
  where
    (d :+ _) = abs (a - b)
    (r :+ _) = abs a
{-# INLINE eqRelCompl #-}

-- | Difference between values is less than specified precision.
eqAbsolute :: (Num a, Ord a)
           => a                 -- ^ Absolute precision
           -> a -> a -> Bool
eqAbsolute eps a b = abs (a - b) <= eps
{-# INLINE eqAbsolute #-}

-- | Compare two 'Double' values for approximate equality, using
-- Dawson's method.
--
-- The required accuracy is specified in ULPs (units of least
-- precision).  If the two numbers differ by the given number of ULPs
-- or less, this function returns @True@.
--
-- Algorithm is based on Bruce Dawson's \"Comparing floating point
-- numbers\":
-- <http://www.cygnus-software.com/papers/comparingfloats/comparingfloats.htm>
within :: Int                   -- ^ Number of ULPs of accuracy desired.
       -> Double -> Double -> Bool
within ulps a b = runST $ do
  buf <- newByteArray 8
  ai0 <- writeByteArray buf 0 a >> readByteArray buf 0
  bi0 <- writeByteArray buf 0 b >> readByteArray buf 0
  let big  = 0x8000000000000000 :: Int64
      ai | ai0 < 0   = big - ai0
         | otherwise = ai0
      bi | bi0 < 0   = big - bi0
         | otherwise = bi0
  return $! abs (ai - bi) <= fromIntegral ulps


{-# LANGUAGE FlexibleContexts #-}
-- |
-- Module    : Statistics.Test.KolmogorovSmirnov
-- Copyright : (c) 2011 Aleksey Khudyakov
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- Kolmogov-Smirnov tests are non-parametric tests for assessing
-- whether given sample could be described by distribution or whether
-- two samples have the same distribution. It's only applicable to
-- continuous distributions.
module Statistics.Test.KolmogorovSmirnov (
    -- * Kolmogorov-Smirnov test
    kolmogorovSmirnovTest
  , kolmogorovSmirnovTestCdf
  , kolmogorovSmirnovTest2
    -- * Evaluate statistics
  , kolmogorovSmirnovCdfD
  , kolmogorovSmirnovD
  , kolmogorovSmirnov2D
    -- * Probablities
  , kolmogorovSmirnovProbability
    -- * References
    -- $references
  , module Statistics.Test.Types
  ) where

import Control.Monad (when)
import Prelude hiding (exponent, sum)
import Statistics.Distribution (Distribution(..))
import Statistics.Function (gsort, unsafeModify)
import Statistics.Matrix (center, for, fromVector)
import qualified Statistics.Matrix as Mat
import Statistics.Test.Types
import Statistics.Types (mkPValue)
import qualified Data.Vector          as V
import qualified Data.Vector.Storable as S
import qualified Data.Vector.Unboxed  as U
import qualified Data.Vector.Generic  as G
import           Data.Vector.Generic    ((!))
import qualified Data.Vector.Unboxed.Mutable as M

----------------------------------------------------------------
-- Test
----------------------------------------------------------------

-- | Check that sample could be described by distribution. Returns
--   @Nothing@ is sample is empty
--
--   This test uses Marsaglia-Tsang-Wang exact algorithm for
--   calculation of p-value.
kolmogorovSmirnovTest :: (Distribution d, G.Vector v Double)
                      => d        -- ^ Distribution
                      -> v Double -- ^ Data sample
                      -> Maybe (Test ())
{-# INLINE kolmogorovSmirnovTest #-}
kolmogorovSmirnovTest d
  = kolmogorovSmirnovTestCdf (cumulative d)

-- | Variant of 'kolmogorovSmirnovTest' which uses CDF in form of
--   function.
kolmogorovSmirnovTestCdf :: (G.Vector v Double)
                         => (Double -> Double) -- ^ CDF of distribution
                         -> v Double           -- ^ Data sample
                         -> Maybe (Test ())
{-# INLINE kolmogorovSmirnovTestCdf #-}
kolmogorovSmirnovTestCdf cdf sample
  | G.null sample = Nothing
  | otherwise     = Just Test
      { testSignificance = mkPValue $ 1 - prob
      , testStatistics   = d
      , testDistribution = ()
      }
  where
    d    = kolmogorovSmirnovCdfD cdf sample
    prob = kolmogorovSmirnovProbability (G.length sample) d

-- | Two sample Kolmogorov-Smirnov test. It tests whether two data
--   samples could be described by the same distribution without
--   making any assumptions about it. If either of samples is empty
--   returns Nothing.
--
--   This test uses approximate formula for computing p-value.
kolmogorovSmirnovTest2 :: (G.Vector v Double)
                       => v Double -- ^ Sample 1
                       -> v Double -- ^ Sample 2
                       -> Maybe (Test ())
kolmogorovSmirnovTest2 xs1 xs2
  | G.null xs1 || G.null xs2 = Nothing
  | otherwise                = Just Test
      { testSignificance = mkPValue $ 1 - prob d
      , testStatistics   = d
      , testDistribution = ()
      }
  where
    d    = kolmogorovSmirnov2D xs1 xs2
         * (en + 0.12 + 0.11/en)
    -- Effective number of data points
    n1   = fromIntegral (G.length xs1)
    n2   = fromIntegral (G.length xs2)
    en   = sqrt $ n1 * n2 / (n1 + n2)
    --
    prob z
      | z <  0    = error "kolmogorovSmirnov2D: internal error"
      | z == 0    = 0
      | z <  1.18 = let y = exp( -1.23370055013616983 / (z*z) )
                    in  2.25675833419102515 * sqrt( -log y ) * (y + y**9 + y**25 + y**49)
      | otherwise = let x = exp(-2 * z * z)
                    in  1 - 2*(x - x**4 + x**9)
{-# INLINABLE  kolmogorovSmirnovTest2 #-}
{-# SPECIALIZE kolmogorovSmirnovTest2 :: U.Vector Double -> U.Vector Double -> Maybe (Test ()) #-}
{-# SPECIALIZE kolmogorovSmirnovTest2 :: V.Vector Double -> V.Vector Double -> Maybe (Test ()) #-}
{-# SPECIALIZE kolmogorovSmirnovTest2 :: S.Vector Double -> S.Vector Double -> Maybe (Test ()) #-}
-- FIXME: Find source for approximation for D

----------------------------------------------------------------
-- Kolmogorov's statistic
----------------------------------------------------------------

-- | Calculate Kolmogorov's statistic /D/ for given cumulative
--   distribution function (CDF) and data sample. If sample is empty
--   returns 0.
kolmogorovSmirnovCdfD :: G.Vector v Double
                      => (Double -> Double) -- ^ CDF function
                      -> v Double           -- ^ Sample
                      -> Double
kolmogorovSmirnovCdfD cdf sample
  | G.null sample = 0
  | otherwise     = G.maximum
                  $ G.zipWith3 (\p a b -> abs (p-a) `max` abs (p-b))
                    ps steps (G.tail steps)
  where
    xs = gsort sample
    n  = G.length xs
    --
    ps    = G.map cdf xs
    steps = G.map (/ fromIntegral n)
          $ G.generate (n+1) fromIntegral
{-# INLINABLE  kolmogorovSmirnovCdfD #-}
{-# SPECIALIZE kolmogorovSmirnovCdfD :: (Double -> Double) -> U.Vector Double -> Double #-}
{-# SPECIALIZE kolmogorovSmirnovCdfD :: (Double -> Double) -> V.Vector Double -> Double #-}
{-# SPECIALIZE kolmogorovSmirnovCdfD :: (Double -> Double) -> S.Vector Double -> Double #-}

-- | Calculate Kolmogorov's statistic /D/ for given cumulative
--   distribution function (CDF) and data sample. If sample is empty
--   returns 0.
kolmogorovSmirnovD :: (Distribution d, G.Vector v Double)
                   => d         -- ^ Distribution
                   -> v Double  -- ^ Sample
                   -> Double
kolmogorovSmirnovD d = kolmogorovSmirnovCdfD (cumulative d)
{-# INLINE kolmogorovSmirnovD #-}

-- | Calculate Kolmogorov's statistic /D/ for two data samples. If
--   either of samples is empty returns 0.
kolmogorovSmirnov2D :: (G.Vector v Double)
                    => v Double   -- ^ First sample
                    -> v Double   -- ^ Second sample
                    -> Double
kolmogorovSmirnov2D sample1 sample2
  | G.null sample1 || G.null sample2 = 0
  | otherwise                        = worker 0 0 0
  where
    xs1 = gsort sample1
    xs2 = gsort sample2
    n1  = G.length xs1
    n2  = G.length xs2
    en1 = fromIntegral n1
    en2 = fromIntegral n2
    -- Find new index
    skip x i xs = go (i+1)
      where go n | n >= G.length xs = n
                 | xs ! n == x      = go (n+1)
                 | otherwise        = n
    -- Main loop
    worker d i1 i2
      | i1 >= n1 || i2 >= n2 = d
      | otherwise            = worker d' i1' i2'
      where
        d1  = xs1 ! i1
        d2  = xs2 ! i2
        i1' | d1 <= d2  = skip d1 i1 xs1
            | otherwise = i1
        i2' | d2 <= d1  = skip d2 i2 xs2
            | otherwise = i2
        d'  = max d (abs $ fromIntegral i1' / en1 - fromIntegral i2' / en2)
{-# INLINABLE  kolmogorovSmirnov2D #-}
{-# SPECIALIZE kolmogorovSmirnov2D :: U.Vector Double -> U.Vector Double -> Double #-}
{-# SPECIALIZE kolmogorovSmirnov2D :: V.Vector Double -> V.Vector Double -> Double #-}
{-# SPECIALIZE kolmogorovSmirnov2D :: S.Vector Double -> S.Vector Double -> Double #-}

-- | Calculate cumulative probability function for Kolmogorov's
--   distribution with /n/ parameters or probability of getting value
--   smaller than /d/ with n-elements sample.
--
--   It uses algorithm by Marsgalia et. al. and provide at least
--   7-digit accuracy.
kolmogorovSmirnovProbability :: Int    -- ^ Size of the sample
                             -> Double -- ^ D value
                             -> Double
kolmogorovSmirnovProbability n d
  -- Avoid potentially lengthy calculations for large N and D > 0.999
  | s > 7.24 || (s > 3.76 && n > 99) = 1 - 2 * exp( -(2.000071 + 0.331 / sqrt n' + 1.409 / n') * s)
  -- Exact computation
  | otherwise = fini $ KSMatrix 0 matrix `power` n
  where
    s  = n' * d * d
    n' = fromIntegral n

    size = 2*k - 1
    k    = floor (n' * d) + 1
    h    = fromIntegral k - n' * d
    -- Calculate initial matrix
    matrix =
      let m = U.create $ do
            mat <- M.new (size*size)
            -- Fill matrix with 0 and 1s
            for 0 size $ \row ->
              for 0 size $ \col -> do
                let val | row + 1 >= col = 1
                        | otherwise      = 0 :: Double
                M.write mat (row * size + col) val
            -- Correct left column/bottom row
            for 0 size $ \i -> do
              let delta = h ^^ (i + 1)
              unsafeModify mat (i    * size)         (subtract delta)
              unsafeModify mat (size * size - 1 - i) (subtract delta)
            -- Correct corner element if needed
            when (2*h > 1) $ do
              unsafeModify mat ((size - 1) * size) (+ ((2*h - 1) ^ size))
            -- Divide diagonals by factorial
            let divide g num
                  | num == size = return ()
                  | otherwise   = do for num size $ \i ->
                                       unsafeModify mat (i * (size + 1) - num) (/ g)
                                     divide (g * fromIntegral (num+2)) (num+1)
            divide 2 1
            return mat
      in fromVector size size m
    -- Last calculation
    fini (KSMatrix e m) = loop 1 (center m) e
      where
        loop i ss eQ
          | i  > n       = ss * 10 ^^ eQ
          | ss' < 1e-140 = loop (i+1) (ss' * 1e140) (eQ - 140)
          | otherwise    = loop (i+1)  ss'           eQ
          where ss' = ss * fromIntegral i / fromIntegral n

data KSMatrix = KSMatrix Int Mat.Matrix

multiply :: KSMatrix -> KSMatrix -> KSMatrix
multiply (KSMatrix e1 m1) (KSMatrix e2 m2) = KSMatrix (e1+e2) (Mat.multiply m1 m2)

power :: KSMatrix -> Int -> KSMatrix
power mat 1 = mat
power mat n = avoidOverflow res
  where
    mat2 = power mat (n `quot` 2)
    pow  = multiply mat2 mat2
    res | odd n     = multiply pow mat
        | otherwise = pow

avoidOverflow :: KSMatrix -> KSMatrix
avoidOverflow ksm@(KSMatrix e m)
  | center m > 1e140 = KSMatrix (e + 140) (Mat.map (* 1e-140) m)
  | otherwise        = ksm

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

-- $references
--
-- * G. Marsaglia, W. W. Tsang, J. Wang (2003) Evaluating Kolmogorov's
--   distribution, Journal of Statistical Software, American
--   Statistical Association, vol. 8(i18).


{-|
Module      : Distributions
Description : Definition of the Distributions used in Models and associated functions.
Copyright   : (c) Julian Kopka Larsen, 2015
Stability   : experimental
-}
module Distributions (
    lnormalInvWishart,
    lnormalInvWishartSS,
    lMixNormWish,
    delta,
    Expr,
    dlNormW,
    lNormW
) where

import Math (X,
             mlgamma,
             scatterMatrix,
             meanv,
             lnDeterminant)

import Numeric.LinearAlgebra (Matrix,
                              Vector,
                              (<>),
                              ident,
                              dim,
                              scale,
                              trans,
                              takeDiag,
                              outer)

import Numeric.LinearAlgebra.Data (konst, size)

import Partition (Partition, Component, groups, group)

import LikSpecLang

-- | Delta log Normal-Wishard likelihood for a mixture of components.
dlNormW :: X -> (Partition -> Partition -> Double)
dlNormW x = delta (lMixNormWish x)

-- | Log Normal-Wishard likelihood for a mixture of components.
lNormW :: X -> (Partition -> Double)
lNormW x = compile (lMixNormWish x)

-- | Log Normal-Wishard likelihood for a mixture of components. Same as 'lNormW' but defined without the "LikSpecLang" (LSL)
lMixNormWish ::X -> Expr Partition Double
lMixNormWish x = Mixture (Fun lnormalInvWishart) % selection x -- The '%' operator "pipes" expressions together

selection :: X -> Expr Partition [X]
selection x = Fun (groups x)

-- | Log Normal-Wishard likelihood for a single component
lnormalInvWishartSS :: Int -> Matrix Double -> Vector Double-> Double
lnormalInvWishartSS n s mu = - fromIntegral n * d * 2 * log pi
                      + mlgamma d (vn/2)
                      - mlgamma d (v0/2)
                      + (v0/2) * ldalpha0
                      - (vn/2) * ldalphaN
                      + (d/2) * ((log k0)-(log kn))
                    where   d = fromIntegral $ fst $ size s :: Double
                            v0 = 100 -- hyperparameter must be (v0 > d)
                            vn = v0 + fromIntegral n
                            alpha0 = ident $ fst $ size s -- hyperparameter for the shape of the covariance matrix
                            alphaN = alpha0 + s + scale ((k0*fromIntegral n)/(k0+kn)) ((mu-mu0) `outer` (mu-mu0))
                            ldalpha0 = lnDeterminant alpha0
                            ldalphaN = lnDeterminant alphaN
                            k0 = 0.2 -- hyperparameter
                            kn = k0 + fromIntegral n
                            mu0 = (konst 0.0 $ fst $ size s ):: Vector Double -- hyperparameter

-- | Log Normal-Wishard likelihood for a single component
lnormalInvWishart :: X -> Double
lnormalInvWishart x = - n * d * 2 * log pi
                      + mlgamma d (vn/2)
                      - mlgamma d (v0/2)
                      + (v0/2) * ldalpha0
                      - (vn/2) * ldalphaN
                      + (d/2) * ((log k0)-(log kn))
                    where   n = fromIntegral $ length x
                            d = fromIntegral $ dim $ head x
                            v0 = 100 -- hyperparameter must be (v0 > d)
                            vn = v0 + n
                            alpha0 = ident $ dim $ head x -- hyperparameter for the shape of the covariance matrix
                            alphaN = alpha0 + s + scale ((k0*n)/(k0+kn)) ((xm-mu0) `outer` (xm-mu0))
                            ldalpha0 = lnDeterminant alpha0
                            ldalphaN = lnDeterminant alphaN
                            k0 = 0.2 -- hyperparameter
                            kn = k0 + n
                            s = scatterMatrix x
                            mu0 = (konst 0.0 $ dim $ head x ):: Vector Double -- hyperparameter
                            xm = meanv x


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

Cluster Analysis a.k.a. Clustering - grouping data into coherent subsets.
-}

module MachineLearning.Clustering
(
  Cluster(..)
  , kmeans

  -- * Exported for testing purposes only.
  , kmeansIterM
)

where

import MachineLearning.Types (R, Vector, Matrix)
import Data.List (sortOn, groupBy, minimumBy)
import Control.Applicative ((<$>))
import Control.Monad (forM)
import qualified Control.Monad.Random as RndM
import qualified Data.Vector as V
import qualified Numeric.LinearAlgebra as LA
import MachineLearning.Random (sampleM)

-- | Cluster type (list of samples associtaed with the cluster).
type Cluster = V.Vector Vector

-- | Gets list if the nearest centroid to the sample.
nearestCentroidIndex :: V.Vector Vector  -- ^ list of cluster cetroids;
                     -> Vector            -- ^ sample;
                     -> Int               -- ^ index of the nearest centroid.
nearestCentroidIndex centroids v =
  let distances = V.map (\centroid -> LA.norm_2 (v-centroid)) centroids
  in V.minIndex distances

-- | Calculates cost associated with one claster.
calcClusterCost :: Cluster  -- ^ cluster;
                -> Vector   -- ^ cluster centroid;
                -> R        -- ^ cost value.
calcClusterCost cluster centroid = sum $ fmap (\sample -> LA.norm_2 $ sample-centroid) cluster

-- | Calculates cost value for all clusters.
calcCost :: V.Vector Cluster  -- ^ cluster list;
         -> V.Vector Vector   -- ^ list of cluster centroids;
         -> R                  -- ^ cost value.
calcCost clusters centroids = sum $ V.zipWith calcClusterCost clusters centroids

-- | Calculates centroid (middle point) of the given cluster.
getNewCentroid :: Cluster      -- ^ cluster;
               -> Vector       -- ^ centroid.
getNewCentroid cluster =
  let n = length cluster
      centroid = (sum cluster) / (fromIntegral n)
  in centroid

-- | Calculates new cluster centroids for each cluster.
moveCentroids :: V.Vector Cluster    -- ^ list of clusters;
              -> V.Vector Vector     -- ^ list of cluster centroids.
moveCentroids clusters = fmap getNewCentroid clusters

-- | Build cluster list from list of clusters indices.
buildClusterList :: V.Vector Vector   -- ^ list of samples;
                 -> V.Vector Int      -- ^ list of cluster indices (associated cluster index for each sample);
                 -> V.Vector Cluster  -- ^ list of clusters.
buildClusterList samples clusterIndicesList = V.fromList $ fmap getClusterSamples clusters''
  where clusters' = groupBy (\l r -> snd l == snd r) $ sortOn snd $ zip [0..] $ V.toList clusterIndicesList
        clusters'' = map (map fst) clusters'
        getClusterSamples clusterIndices = V.fromList $ fmap (samples V.!) clusterIndices

-- -- | Run K-Means algorithm once.
kmeansIter :: V.Vector Vector           -- ^ list of samples;
              -> Int                    -- ^ number of clusters (`K`);
              -> V.Vector Vector        -- ^ list of initial centroids;
              -> (V.Vector Cluster, [R])  -- ^ (list of clusters, cost values).
kmeansIter samples k initialCentroids =
  let iter centroids js =
        let clusterIndicesList = fmap (nearestCentroidIndex centroids) samples
            clusters = buildClusterList samples clusterIndicesList
            centroids' = moveCentroids clusters
            j = calcCost clusters centroids'
            diff = sum . fmap LA.norm_2 $ V.zipWith (-) centroids centroids'
        in if diff < 0.001 then (clusters, j:js)
           else iter centroids' (j:js)
  in iter initialCentroids []

-- | Run K-Means algorithm once inside Random Monad.
kmeansIterM :: RndM.RandomGen g =>
               V.Vector Vector  -- ^ list of samples;
               -> Int           -- ^ number of clusters (`K`);
               -> Int           -- ^ iteration number;
               -> RndM.Rand g (V.Vector Cluster, [R])  -- ^ (list of clusters, cost values) inside Random Monad.
kmeansIterM samples k _ = do
  centroids <- sampleM k samples
  return (kmeansIter samples k centroids)

-- | Clusters data using K-Means Algorithm inside Random Monad.
-- Runs K-Means algorithm `N` times, returns the clustering with smaller cost.
kmeans :: RndM.RandomGen g =>
           Int                     -- ^ number of K-Means Algorithm runs (`N`);
           -> Matrix                  -- ^ data to cluster;
           -> Int                     -- ^ desired number of clusters (`K`);
           -> RndM.Rand g (V.Vector Cluster)  -- ^ list of clusters inside Random Monad.
kmeans nIters x k = fst <$>
    (minimumBy (\(_, js1) (_, js2) -> compare (head js1) (head js2))) <$>
    forM [1..nIters] (kmeansIterM samples k)
  where samples = V.fromList $ LA.toRows x