{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
module Filter(
      FIR(..)
    , bode
    , phasePlot
    ) where

import Signal
import Math.Polynomial
import Common
import Noise
import Fixed
import GHC.TypeLits
import SpecialInt
import Data.Bits
import Plot
import Data.Complex
import Text.Printf

import Debug.Trace

debug a = trace (show a) a

data FIR p i o where
 FIR :: (SingI (nc + ni), SingI nc, SingI ni, SingI no, SingI s, SingI r, HasDoubleRepresentation (Fixed a nc s r), Num (Fixed ag (nc + ni) s r), Num (Fixed a nc s r), Eq a, Conversion ag ao, ConvertConstraint ag ao, AMulConstraint a ag)
     => Poly (Fixed a nc s r)
     -> FIR ((Fixed ag (nc + ni) s r),(Fixed a nc s r)) (Fixed a ni s r) (Fixed ao no s r)
 FIRD :: Poly Double
      -> FIR Double Double Double

polyRepresentation :: FIR p i o -> Poly Double
polyRepresentation (FIRD p) = p
polyRepresentation (FIR f) = fmap toDouble f

instance Show p => Show (FIR p i o) where
  show (FIR c) = show c
  show (FIRD d) = show d

delay :: s -> Signal s -> Signal s
delay a s = consS a s

guardType :: FIR ((Fixed ag ng s r),(Fixed a nc s r)) i (Fixed ao no s r)
          -> Fixed ag n s r
          -> Fixed ag n s r
guardType _ = id

filterDWith :: [Double]
            -> Signal Double
            -> Signal Double
filterDWith (a:l) s | null l = mapS (a*) s
                    | otherwise = zipWithS (+) (mapS (a*) s) (filterDWith l (delay 0 s))
filterDWith [] s = s

_filterWith :: (AMulConstraint a ag, SingI (na + ni), SingI s, SingI r, SingI na, SingI ni, Num (Fixed a ni s r), Num (Fixed ag (na + ni) s r))
            => FIR ((Fixed ag ng s r),(Fixed a na s r)) (Fixed a ni s r) (Fixed ao no s r)
            -> [Fixed a na s r]
            -> Signal (Fixed a ni s r)
            -> Signal (Fixed ag (na + ni) s r)
_filterWith f (a:l) s | null l = mapS (amul a) s
                      | otherwise = zipWithS (+) (mapS (amul a) s) (_filterWith f l (delay 0 s))
_filterWith _ [] s = error "Empty polynomial can't be used for filtering"

filterWith :: (Conversion ag ao, ConvertConstraint ag ao, Num (Fixed a ni s r), Num (Fixed ag (na + ni) s r), SingI r, SingI s, SingI (na + ni), SingI ni, SingI na, SingI no, AMulConstraint a ag)
           => FIR ((Fixed ag ng s r),(Fixed a na s r)) (Fixed a ni s r) (Fixed ao no s r)
           -> [Fixed a na s r]
           -> Signal (Fixed a ni s r)
           -> Signal (Fixed ao no s r)
filterWith f l = mapS convert . _filterWith f l

instance Structure FIR where
    doubleVersion (FIR p) = FIRD $ fmap toDouble p
    transferFunction f@(FIR p) s =
        let c = polyCoeffs LE $ p
        in
        filterWith f c s
    transferFunction (FIRD p) s =
        let c = polyCoeffs LE p
        in
        filterDWith c s

bode :: (Sample o,Sample i)
     => FIR p i o -> StyledSignal Double Double
bode f =
    let fd = polyRepresentation f
        log10 x = log x / log 10
        polyF = evalPoly (fmap (:+ 0) fd)
        transferFunction = \t -> 20 * log10 (magnitude . polyF . cis $ -t)
        dw = 0.01
        values = map transferFunction [0,dw..pi]
        nb = length values
        ticksWithPhase n = printf "%.2f pi" (n / fromIntegral nb :: Double)
    in
    (plotSpectrum nb [ AS $ fromListS 0 values])
                 `withNewStyle` (\s -> s { verticalLabel = Just "Filter Gain (dB)"
                                         , title = Just "Bode Plot"
                                         , horizontalTickRepresentation = ticksWithPhase
                                         })

phasePlot :: (Sample o,Sample i)
     => FIR p i o -> StyledSignal Double Double
phasePlot f =
    let fd = polyRepresentation f
        log10 x = log x / log 10
        polyF = evalPoly (fmap (:+ 0) fd)
        transferFunction = \t -> phase . polyF . cis $ -t
        dw = 0.01
        values = map transferFunction [0,dw..pi]
        nb = length values
        ticksWithPhase n = printf "%.2f pi" (n / fromIntegral nb :: Double)
    in
    (plotSpectrum nb [ AS $ fromListS 0 values])
                 `withNewStyle` (\s -> s { verticalLabel = Just "Filter Phase"
                                         , title = Just "Phase Plot"
                                         , horizontalTickRepresentation = ticksWithPhase
                                         })


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}

module QUtil where

import Data.Complex
import Data.List

import Numeric.LinearAlgebra as L

import LinAlg
import BraKet
import Operators

-- Utility functions --
takeKet :: Element c => Int -> Ket c -> Ket c
takeKet n (Ket coeffs) = Ket $ L.subVector 0 n coeffs

-- Expected value of an operator O computed as Tr(rho <> O)
expectedValue :: MatOp -> [Complex Double] -> [Ket (Complex Double)] -> Complex Double
expectedValue op ps kets = trace $ op Prelude.<> densityMatrix ps kets

-- Commutator of two operators
commutator :: MatOp -> MatOp -> MatOp
commutator a b = (a Prelude.<> b) <~> (b Prelude.<> a)

-- normalization function
normalize :: Hilbert v => v -> v
normalize v = ((1.0 :+ 0.0) / (norm v :+ 0.0)) <**> v

-- sized vacuum Fock state
vacuum :: Int -> Ket (Complex Double)
vacuum n = Ket . L.fromList $ 1.0 : replicate (n-1) 0.0

-- n-photon Fock basis state
fockN :: Int -> Int -> Ket (Complex Double)
fockN m n = QUtil.normalize $ act (foldl1' (Prelude.<>) $ replicate n (create m)) (vacuum m)

-- Coherent state
coherent :: Int -> Complex Double -> Ket (Complex Double)
coherent m alpha = act (displacement m alpha) $ vacuum m


{-# LANGUAGE ConstraintKinds #-}

module Projection
( projectL2
)
where

import           Basis
import           Element
import           Node
import qualified Numeric.LinearAlgebra as LinAl
import           Quadrature
import           ShapeFcns

-- Synonym for numeric/fractional constraints
type FrElNuFi a = (Fractional a,LinAl.Element a,LinAl.Numeric a,LinAl.Field a)

-- Element mass integrand
elemMassIntegrand :: (Element e,ShapeFcn s,Basis b,FrElNuFi a) => e a -> s b -> [a] -> LinAl.Matrix a
elemMassIntegrand elem shpFcn xi = LinAl.fromLists [[
  ShapeFcns.n shpFcn xi i [0] * ShapeFcns.n shpFcn xi j [0] * Element.computeJacobianDet elem shpFcn xi
  | i <- idxRange] | j <- idxRange]
  where
    idxRange = [0..(ShapeFcns.getShapeFcnOrder shpFcn)]

-- This function computes the element load integrand when given a function
-- to integrate over an element.
elemLoadIntegrand :: (Element e,ShapeFcn s,Basis b,FrElNuFi a) => e a -> s b -> ([a] -> a) -> [a] -> LinAl.Matrix a
elemLoadIntegrand elem shpFcn f xi = LinAl.scale (computeJacobianDet elem shpFcn xi) (LinAl.fromLists $ map (:[]) [f physCoords * n shpFcn xi i [0] | i <- [0..(getShapeFcnOrder shpFcn)]])
  where
    physCoords = [sum $ zipWith (*) (map (head . nodeCoordinates) (getElementNodes elem)) (map (\j -> n shpFcn xi j [0]) [0..(getShapeFcnOrder shpFcn)])]

-- Function for projecting a function onto a basis over a single element.
projectL2 :: (Element e,ShapeFcn s,Basis b,FrElNuFi a) => e a -> s b -> Int -> ([a] -> a) -> Maybe (LinAl.Matrix a)
projectL2 elem shpFcn ngpts f = LinAl.linearSolve (integrate 1 ngpts (elemMassIntegrand elem shpFcn)) (integrate 1 ngpts (elemLoadIntegrand elem shpFcn f))


import Data.Complex

main :: IO ()
main = do let res = dft $ enumerate $ map (\x -> x :+ 0) [1..100]
       	  putStrLn $ show res

enumerate :: Integral b => [a] -> [(a, b)]
enumerate l = zip l [0..]

dft :: (RealFloat a, Integral b) => [(Complex a, b)] -> [Complex a]
dft x = map (\(_, k) -> singleDFT k x) x

singleDFT :: (RealFloat a, Integral b) => b -> [(Complex a, b)] -> Complex a
singleDFT k x = sum $ map (\(e, n) -> (e *) $ fCoeff k n $ length x) $ x

fCoeff :: (RealFloat a, Integral b) => b -> b -> b -> Complex a
fCoeff k n n_tot = exp (0.0 :+ ((-2.0) * pi * (fromIntegral $ k * n) /
       	   	       	       	       	      (fromIntegral n_tot)))


module Statistics.Dispersion where

import Statistics.Center

variance :: (Fractional a) => [a] -> a
variance vals = (sum $ zipWith (*) deviations deviations)/n
    where n = (fromIntegral $ length vals)
          mu = arithmeticMean vals
          deviations = map (\x -> x-mu) vals

stdev :: (Floating a) => [a] -> a
stdev vals = sqrt $ variance vals


module Main where

import Options.Applicative

import Pipes
import qualified Pipes.Prelude as P

import System.Random.MWC

import Statistics.Quantile.Bench.Gen (sampleGamma)

data Params = Params Int Double Double
  deriving (Eq, Show)

params = Params <$> argument auto (metavar "COUNT")
                <*> argument auto (metavar "ALPHA")
                <*> argument auto (metavar "BETA")

args = info (helper <*> params)
            (   fullDesc
             <> progDesc "Write COUNT real numbers drawn from a gamma distribution."
            )

main :: IO ()
main = do
    ps <- execParser args
    gen <- createSystemRandom
    runEffect $ gamma gen ps >-> P.map show >-> P.stdoutLn
  where
    gamma gen (Params n alpha beta) = P.replicateM n $ sampleGamma gen alpha beta


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
-- | Goodness of fit runs tests.
module Statistics.Test.Runs (
    runsTest
  , module Statistics.Test.Types
  ) where

import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U
import Numeric.SpecFunctions (choose)
import Prelude hiding (sum)

import Statistics.Sample.Internal (sum)
import Statistics.Test.Types
import Statistics.Types

-- | Goodness of fit test for binned data. It uses only sign of
--   deviations of observations from their expectations. Null
--   hypothesis is that all possible patterns of sign occurrences are
--   equiprobable.
--
--   It's asymptotically independent from chi-square test. So their
--   results could be directly combined
runsTest :: (G.Vector v Bool) => v Bool -> Test ()
{-# INLINE runsTest #-}
runsTest v
  = Test { testSignificance = mkPValue $ cumulativeProb n m r
         , testStatistics   = fromIntegral r
         , testDistribution = ()
         }
  where
    (n,m,r) = computeRuns v

-- Compute number of positive elements, negative elements and runs
computeRuns :: (G.Vector v Bool) => v Bool -> (Int,Int,Int)
{-# INLINE computeRuns #-}
computeRuns v
  = fini $ G.foldl' step (0,0,0,Nothing) v
  where
    step (!nP,!nM,!nR,!old) f =
      ( if f then nP+1 else nP
      , if f then nM   else nM+1
      , if old == Just f then nR else nR+1
      , Just f
      )
    fini (nP,nM,nR,_) = (nP,nM,nR)

-- Compute denormalized probability of getting R runs given N positive
-- and M positive elements
denormProbability :: Int -> Int -> Int -> Double
denormProbability n m r
  | even r    = 2 * ((m-1) `choose` (s-1)) * ((n-1) `choose` (s-1))
  | otherwise = ((m-1) `choose` (s-1)) * ((n-1) `choose` (s-2))
              + ((m-1) `choose` (s-2)) * ((n-1) `choose` (s-1))
  where
    s = r `quot` 2

-- Probability of getting R<=R[observed]
cumulativeProb :: Int -> Int -> Int -> Double
cumulativeProb n m r
  = min 1
  $ sum (U.map (denormProbability n m) $ U.enumFromTo 1 r)
  / ((n+m) `choose` m)


{-# 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 NeuralNet.Matrix (
  sumRows,
  dims,
  dimsEq,
  zero
) where

import Numeric.LinearAlgebra

zero :: Int -> Int -> Matrix Double
zero r c = (r><c) (repeat 0)

-- TODO: Check if a function available for this
sumRows :: Matrix Double -> Matrix Double
sumRows m = col (map sum (toLists m))

-- TODO: Have a look at size
dims :: Matrix a -> (Int, Int)
dims m = (rows m, cols m)

dimsEq :: Matrix a -> Matrix b -> Bool
dimsEq x y = dims x == dims y


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)


{-# LANGUAGE DeriveDataTypeable #-}

module Statistics.Distribution.Combo
       (ComboDistribution(..), combo, combo', rs, create, comboStandard,
        getComboRandoms)
       where

import Control.Monad (replicateM)
import Control.Monad.Primitive
import Data.Typeable (Typeable)
import qualified Statistics.Distribution as D
import qualified Statistics.Distribution.Laplace as L
import qualified Statistics.Distribution.Normal as N
import System.Random.MWC
import qualified System.Random.MWC.Distributions as MWC

data ComboDistribution =
  CD {cdSplit :: Double -- probability of normal distribution
     ,cdMean :: Double -- (both normal mean and glue point)
     ,cdStd :: Double -- normal std
     ,cdLaplaceR :: Double -- exponetial deviation right-side
     ,cdLaplaceL :: Double -- exponential deviation left-side
     ,cdSplitLaplace :: Double   -- probability of right-side
     }
  deriving (Eq,Read,Show,Typeable)

instance D.Distribution ComboDistribution where
  cumulative = cumulative
  complCumulative = complCumulative

instance D.ContDistr ComboDistribution where
  density = density
  quantile = quantile

instance D.Mean ComboDistribution where
  mean (CD split m _ r l sl) =
    (split * m) +
    (1 - split) *
    (sl * r +
     (1 - sl) *
     l +
     m)
  {-# INLINE mean #-}

instance D.Variance ComboDistribution where
  variance (CD split _ s r l sl) =
    split * s +
    (1 - split) *
    (sl /
     ((1 / l) *
      (1 / l)) +
     (1 - sl) /
     ((1 / r) *
      (1 / r)))
  {-# INLINE variance #-}

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

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

instance D.ContGen ComboDistribution where
  -- genContVar :: (PrimMonad m) => ComboDistribution -> Gen (PrimState m) -> m Double
  genContVar (CD split m s r l sl) g =
    do split' <- uniform g
       sl' <- uniform g
       n <- MWC.normal m s g
       e <- MWC.exponential 1 g
       return $
         if split' < split
            then n
            else if sl' < sl
                    then m + e / r
                    else m - e / l

density :: ComboDistribution -> Double -> Double
density (CD split m s r l sl) x =
  split *
  D.density (N.normalDistr m s) x +
  (1 - split) *
  D.density (L.laplace (1 / r)
                       (1 / l)
                       sl
                       m)
            x

cumulative :: ComboDistribution -> Double -> Double
cumulative (CD split m s r l sl) x =
  split *
  D.cumulative (N.normalDistr m s)
               x +
  (1 - split) *
  D.cumulative
    (L.laplace (1 / r)
               (1 / l)
               sl
               m)
    x

complCumulative :: ComboDistribution -> Double -> Double
complCumulative (CD split m s r l sl) x =
  split *
  D.complCumulative (N.normalDistr m s)
                    x +
  (1 - split) *
  D.complCumulative
    (L.laplace (1 / r)
               (1 / l)
               sl
               m)
    x

quantile :: ComboDistribution -> Double -> Double
quantile d p
  | p == 0 = -inf
  | p == 1 = inf
  | p == 0.5 = cdMean d
  | p > 0 && p < 1 = x
  | otherwise = error $
                 "Statistics.Distribution.Combo.quantile: p must be in [0,1] range. Got: " ++
                 show p
  where x =
          D.findRoot d
                     p
                     0
                     (-inf)
                     inf
        inf = 1 / 0

comboStandard :: ComboDistribution
comboStandard = CD 0.5 0.0 1.0 1.0 1.0 0.5

-- | Create the combo distribution.
combo :: Double             -- probability of normal
      -> Double             -- ^ mean
      -> Double             -- ^ stdev
      -> Double             -- ^ right-side lambda
      -> Double            -- ^ left-side lambda
      -> Double            -- ^ probability of right-side
      -> ComboDistribution
combo = CD

{-# INLINE combo #-}

-- | Create the combo distribution from a paramter list.
combo' :: [Double] -> ComboDistribution
combo' (split:m:s:r:l:sl:_) = CD split m s r l sl
combo' _ = comboStandard

{-# INLINE combo' #-}

rs :: PrimMonad m
   => Gen (PrimState m) -> [Double] -> Int -> m [Double]
rs g d n =
  replicateM n $
  D.genContVar (combo' d)
               g

getComboRandoms :: Int -> IO [Double]
getComboRandoms n =
  do g <- create
     let d = combo 0.5 0.0 1.2 1.2 1.2 0.5
     replicateM n $
       D.genContVar d g


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 FlexibleContexts    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where

import qualified Data.List                    as List
import qualified Data.Text                    as T
import qualified Data.Vector.Storable         as V
import qualified Data.Vinyl                   as V
import qualified Frames                       as F

import           Numeric.LinearAlgebra        (( #> ), (<#), (<.>), (<\>))
import qualified Numeric.LinearAlgebra        as LA
import           Numeric.LinearAlgebra.Data   (Matrix, R, Vector)
import qualified Numeric.LinearAlgebra.Data   as LA

import           Control.Applicative
import           Control.Monad
import           EasyTest

import qualified Math.Regression.LeastSquares as LS
import qualified System.PipesLogger           as SL

main = runOnly "all" suite

suite :: Test ()
suite = tests
  [
    scope "all.Regression" $ do
      testOLS
      testTLS
  ]

logged = SL.runLoggerIO SL.logAll
-- regression tests

-- build some data for testing
-- uniformly distributed measurements, normally distributed noise.  Separate noise amplitudes for xs and ys
-- also allow building heteroscedastic data
buildRegressable :: [Double] -> Double -> LA.Vector R -> Double -> IO (LA.Vector R, LA.Matrix R)
buildRegressable variances noiseObs coeffs noiseMeas = do
  -- generate random measurements
  let d = LA.size coeffs
      nObs = List.length variances
  xs0 <- LA.rand nObs d
  xNoise <- LA.randn nObs d
  let xs = xs0 + LA.scale noiseMeas xNoise
  let ys0 = xs LA.<> LA.asColumn coeffs
  yNoise <- fmap (List.head . LA.toColumns) (LA.randn nObs 1)
  let ys = ys0 + LA.asColumn (LA.scale noiseObs (V.zipWith (*) yNoise (LA.cmap sqrt (LA.fromList variances))))
  return (List.head (LA.toColumns ys), xs)

unweighted :: Int -> [Double] = flip List.replicate 1

showText = T.pack . show

testOLS :: Test ()
testOLS =  scope "OLS" $ do
  let errR2 res = let r2 = LS.rSquared res in (r2 <= 1 && r2 > 0.8)
      coeffs :: LA.Vector R = LA.fromList [1.0, 2.2, 0.3]
  scope "No noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0 coeffs 0
    result <- LS.ordinaryLS False xs ys
    SL.log SL.Info $ "OLS (0 noise)\n" <> T.pack (show result)
    SL.liftLog $ expect $ errR2 result
  scope "(0.01,0) (obs,meas) Noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0.01 coeffs 0
    result <- LS.ordinaryLS False xs ys
    SL.log SL.Info $ "OLS (1% noise in ys)\n" <> T.pack (show result)
    SL.liftLog $ expect $ errR2 result
  scope "(0.1,0) (obs,meas) Noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0.1 coeffs 0
    result <- LS.ordinaryLS False xs ys
    SL.log SL.Info $ "OLS (10% noise in ys)\n" <> T.pack (show result)
    SL.liftLog $ expect $ errR2 result
  scope "(0.01,0.01) (obs,meas) Noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0.01 coeffs 0.01
    result <- LS.ordinaryLS False xs ys
    SL.log SL.Info $ "OLS (1% noise in ys, 1% noise in xs)\n" <> (T.pack $ show result)
    SL.liftLog $ expect $ errR2 result
  scope "(0.1,0.1) (obs,meas) Noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0.1 coeffs 0.1
    result <- LS.ordinaryLS False xs ys
    SL.log SL.Info $ "OLS (10% noise in ys, 10% noise in xs)\n" <> (T.pack $ show result)
    SL.liftLog $ expect $ errR2 result
  scope "(0.3,0.3) (obs,meas) Noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0.3 coeffs 0.3
    result <- LS.ordinaryLS False xs ys
    SL.log SL.Info $ "OLS (30% noise in ys, 30% noise in xs)\n" <> (T.pack $ show result)
    SL.liftLog $ expect $ errR2 result

testTLS :: Test ()
testTLS = scope "TLS" $ do
  let errR2 res = let r2 = LS.rSquared res in (r2 <= 1 && r2 > 0.8)
      coeffs :: LA.Vector R = LA.fromList [1.0, 2.2, 0.3]
  scope "No noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0 coeffs 0
    result <- LS.totalLeastSquares False xs ys
    SL.log SL.Info $ "TLS (0 noise)\n" <> (T.pack $ show result)
    SL.liftLog $ expect $ errR2 result
  scope "0.01 Noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0.01 coeffs 0
    result <- LS.totalLeastSquares False xs ys
    SL.log SL.Info $ "TLS (1% noise in ys)\n" <> (T.pack $ show result)
    SL.liftLog $ expect $ errR2 result
  scope "0.1 Noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0.1 coeffs 0
    result <- LS.totalLeastSquares False xs ys
    SL.log SL.Info $ "TLS (10% noise in ys)\n" <> (T.pack $ show result)
    SL.liftLog $ expect $ errR2 result
  scope "(0.01,0.01) (obs,meas) Noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0.01 coeffs 0.01
    result <- LS.totalLeastSquares False xs ys
    SL.log SL.Info $ "TLS (1% noise in ys, 1% noise in xs)\n" <> (T.pack $ show result)
    SL.liftLog $ expect $ errR2 result
  scope "(0.1,0.1) (obs,meas) Noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0.1 coeffs 0.1
    result <- LS.totalLeastSquares False xs ys
    SL.log SL.Info $ "TLS (10% noise in ys, 10% noise in xs)\n" <> (T.pack $ show result)
    SL.liftLog $ expect $ errR2 result
  scope "(0.3,0.3) (obs,meas) Noise" $ logged $ do
    (ys, xs) <- SL.liftLog $  io $ buildRegressable (unweighted 100) 0.3 coeffs 0.3
    result <- LS.totalLeastSquares False xs ys
    SL.log SL.Info $ "TLS (30% noise in ys, 30% noise in xs)\n" <> (T.pack $ show result)
    SL.liftLog $ expect $ errR2 result


{-# 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:       Math.NumberTheory.DirichletCharactersTests
-- Copyright:    (c) 2018 Bhavik Mehta
-- License:      MIT
-- Maintainer:   Andrew Lelechenko <andrew.lelechenko@gmail.com>
--
-- Tests for Math.NumberTheory.DirichletCharacters
--

{-# LANGUAGE GADTs #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

module Math.NumberTheory.DirichletCharactersTests where

import Test.Tasty

import Data.Complex
import Data.List (genericLength)
import Data.Maybe (isJust, mapMaybe)
import Data.Proxy
import Data.Semigroup
import qualified Data.Vector as V
import Numeric.Natural

import GHC.TypeNats (SomeNat(..), someNatVal, KnownNat, natVal, sameNat)
import Data.Type.Equality

import Math.NumberTheory.ArithmeticFunctions (totient, divisorsList)
import Math.NumberTheory.DirichletCharacters
import qualified Math.NumberTheory.Moduli.Sqrt as J
import Math.NumberTheory.Moduli.Class (SomeMod(..), modulo)
import Math.NumberTheory.TestUtils (testSmallAndQuick, Positive(..))

-- | This tests property 6 from https://en.wikipedia.org/wiki/Dirichlet_character#Axiomatic_definition
dirCharOrder :: forall n. KnownNat n => DirichletCharacter n -> Bool
dirCharOrder chi = isPrincipal (totient n `stimes` chi)
  where n = natVal @n Proxy

-- | Tests wikipedia's property 3 (note 1,2,5 are essentially enforced by the type system).
testMultiplicative :: KnownNat n => DirichletCharacter n -> Natural -> Natural -> Bool
testMultiplicative chi (fromIntegral -> a) (fromIntegral -> b) = chiAB == chiAchiB
  where chi' = evalGeneral chi
        chiAB = chi' (a*b)
        chiAchiB = (<>) <$> chi' a <*> chi' b

-- | Test property 4 from wikipedia
testAtOne :: KnownNat n => DirichletCharacter n -> Bool
testAtOne chi = eval chi mempty == mempty

dirCharProperty :: (forall n. KnownNat n => DirichletCharacter n -> a) -> Positive Natural -> Natural -> a
dirCharProperty test (Positive n) i =
  case someNatVal n of
    SomeNat (Proxy :: Proxy n) -> test chi
      where chi = indexToChar @n (i `mod` totient n)

realCharProperty :: (forall n. KnownNat n => RealCharacter n -> a) -> Positive Natural -> Int -> a
realCharProperty test (Positive n) i =
  case someNatVal n of
    SomeNat (Proxy :: Proxy n) -> test chi
      where chi = chars !! (i `mod` length chars)
            chars = mapMaybe isRealCharacter [principalChar @n .. maxBound]

-- | There should be totient(n) characters
countCharacters :: Positive Natural -> Bool
countCharacters (Positive n) =
  case someNatVal n of
    SomeNat (Proxy :: Proxy n) ->
      genericLength (allChars @n) == totient n

-- | The principal character should be 1 if gcd k n is 1 and 0 otherwise
principalCase :: Positive Natural -> Positive Integer -> Bool
principalCase (Positive n) (Positive k) =
  case k `modulo` n of
    SomeMod a -> evalGeneral chi a == if gcd k (fromIntegral n) > 1
                                         then Zero
                                         else mempty
      where chi = principalChar
    InfMod{} -> False

-- | Test the orthogonality relations https://en.wikipedia.org/wiki/Dirichlet_character#Character_orthogonality
orthogonality1 :: forall n. KnownNat n => DirichletCharacter n -> Bool
orthogonality1 chi = magnitude (total - correct) < (1e-13 :: Double)
  where n = natVal @n Proxy
        total = sum [orZeroToNum toComplex (evalGeneral chi a) | a <- [0 .. maxBound]]
        correct = if isPrincipal chi
                     then fromIntegral $ totient n
                     else 0

orthogonality2 :: Positive Natural -> Integer -> Bool
orthogonality2 (Positive n) a =
  case a `modulo` n of
    SomeMod a' -> magnitude (total - correct) < (1e-13 :: Double)
      where total = sum [orZeroToNum toComplex (evalGeneral chi a') | chi <- allChars]
            correct = if a' == 1
                         then fromIntegral $ totient n
                         else 0
    InfMod {} -> False

-- | Manually confirm isRealCharacter is correct (in both directions)
realityCheck :: KnownNat n => DirichletCharacter n -> Bool
realityCheck chi = isJust (isRealCharacter chi) == isReal'
  where isReal' = and [real (evalGeneral chi t) | t <- [minBound..maxBound]]
        real Zero = True
        real (NonZero t) = t <> t == mempty

-- | Check real character evaluation matches normal evaluation
realEvalCheck :: KnownNat n => RealCharacter n -> Int -> Bool
realEvalCheck chi i' = fromIntegral (toRealFunction chi i) == (orZeroToNum toComplex (evalGeneral (getRealChar chi) i) :: Complex Double)
  where i = fromIntegral i'

-- | The jacobi character agrees with the jacobi symbol
jacobiCheck :: Positive Natural -> Bool
jacobiCheck (Positive n) =
  case someNatVal (2*n+1) of
    SomeNat (Proxy :: Proxy n) ->
      case jacobiCharacter @n of
        Just chi -> and [toRealFunction chi (fromIntegral j) == J.symbolToNum (J.jacobi j (2*n+1)) | j <- [0..2*n]]
        _ -> False

-- | Bulk evaluation agrees with pointwise evaluation
evalAllCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool
evalAllCheck chi = V.generate (fromIntegral $ natVal @n Proxy) (evalGeneral chi . fromIntegral) == evalAll chi

-- | Induced characters agree with the original character.
-- (Except for when d=1, where chi(0) = 1, which is true for no other d)
inducedCheck :: forall d. KnownNat d => DirichletCharacter d -> Positive Natural -> Bool
inducedCheck chi (Positive k) =
  case someNatVal (d*k) of
    SomeNat (Proxy :: Proxy n) ->
      case induced @n chi of
        Just chi2 -> and (V.izipWith matchedValue (V.concat (replicate (fromIntegral k) (evalAll chi))) (evalAll chi2))
        Nothing -> False
  where d = natVal @d Proxy
        matchedValue i x1 x2 = if gcd (fromIntegral i) (d*k) > 1
                                  then x2 == Zero
                                  else x2 == x1

-- | Primitive checker is correct (in both directions)
primitiveCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool
primitiveCheck chi = isJust (isPrimitive chi) == isPrimitive'
  where isPrimitive' = all testModulus possibleModuli
        n = fromIntegral (natVal @n Proxy) :: Int
        possibleModuli = init (divisorsList n)
        table = evalAll chi
        testModulus d = not $ null [a | a <- [1..n-1], gcd a n == 1, a `mod` d == 1 `mod` d, table V.! a /= mempty]

-- | Ensure that makePrimitive gives primitive characters
makePrimitiveCheck :: DirichletCharacter n -> Bool
makePrimitiveCheck chi = case makePrimitive chi of
                            WithNat chi' -> isJust (isPrimitive (getPrimitiveChar chi'))

-- | sameNat also ensures the two new moduli are the same
makePrimitiveIdem :: DirichletCharacter n -> Bool
makePrimitiveIdem chi = case makePrimitive chi of
                          WithNat (chi' :: PrimitiveCharacter n') ->
                            case makePrimitive (getPrimitiveChar chi') of
                              WithNat (chi'' :: PrimitiveCharacter n'') ->
                                case sameNat (Proxy :: Proxy n') (Proxy :: Proxy n'') of
                                  Just Refl -> chi' == chi''
                                  Nothing -> False

orderCheck :: DirichletCharacter n -> Bool
orderCheck chi = isPrincipal (n `stimes` chi) && and [not (isPrincipal (i `stimes` chi)) | i <- [1..n-1]]
  where n = orderChar chi

fromTableCheck :: forall n. KnownNat n => DirichletCharacter n -> Bool
fromTableCheck chi = isJust (fromTable @n (evalAll chi))

-- A bunch of functions making sure that every function which can produce a character (in
-- particular by fiddling internal representation) produces a valid character
indexToCharValid :: KnownNat n => DirichletCharacter n -> Bool
indexToCharValid = validChar

principalCharValid :: Positive Natural -> Bool
principalCharValid (Positive n) =
  case someNatVal n of
    SomeNat (Proxy :: Proxy n) -> validChar (principalChar @n)

mulCharsValid :: KnownNat n => DirichletCharacter n -> DirichletCharacter n -> Bool
mulCharsValid chi1 chi2 = validChar (chi1 <> chi2)

mulCharsValid' :: Positive Natural -> Natural -> Natural -> Bool
mulCharsValid' (Positive n) i j =
  case someNatVal n of
    SomeNat (Proxy :: Proxy n) ->
      mulCharsValid (indexToChar @n (i `mod` totient n)) (indexToChar @n (j `mod` totient n))

stimesCharValid :: KnownNat n => DirichletCharacter n -> Int -> Bool
stimesCharValid chi n = validChar (n `stimes` chi)

succValid :: KnownNat n => DirichletCharacter n -> Bool
succValid = validChar . succ

inducedValid :: forall d. KnownNat d => DirichletCharacter d -> Positive Natural -> Bool
inducedValid chi (Positive k) = case someNatVal (natVal @d Proxy * k) of
  SomeNat (Proxy :: Proxy n) -> maybe False validChar (induced @n chi)

jacobiValid :: Positive Natural -> Bool
jacobiValid (Positive n) =
  case someNatVal (2*n+1) of
    SomeNat (Proxy :: Proxy n) ->
      case jacobiCharacter @n of
        Just chi -> validChar (getRealChar chi)
        _ -> False

makePrimitiveValid :: DirichletCharacter n -> Bool
makePrimitiveValid chi = case makePrimitive chi of
                            WithNat chi' -> validChar (getPrimitiveChar chi')

testSuite :: TestTree
testSuite = testGroup "DirichletCharacters"
  [ testSmallAndQuick "Dirichlet characters divide the right order" (dirCharProperty dirCharOrder)
  , testSmallAndQuick "Dirichlet characters are multiplicative" (dirCharProperty testMultiplicative)
  , testSmallAndQuick "Dirichlet characters are 1 at 1" (dirCharProperty testAtOne)
  , testSmallAndQuick "Right number of Dirichlet characters" countCharacters
  , testSmallAndQuick "Principal character behaves as expected" principalCase
  , testSmallAndQuick "Orthogonality relation 1" (dirCharProperty orthogonality1)
  , testSmallAndQuick "Orthogonality relation 2" orthogonality2
  , testSmallAndQuick "Real character checking is correct" (dirCharProperty realityCheck)
  , testSmallAndQuick "Real character evaluation is accurate" (realCharProperty realEvalCheck)
  , testSmallAndQuick "Jacobi character matches symbol" jacobiCheck
  , testSmallAndQuick "Bulk evaluation matches pointwise" (dirCharProperty evalAllCheck)
  , testSmallAndQuick "Induced character is correct" (dirCharProperty inducedCheck)
  , testSmallAndQuick "Primitive character checking is correct" (dirCharProperty primitiveCheck)
  , testSmallAndQuick "makePrimitive produces primitive character" (dirCharProperty makePrimitiveCheck)
  , testSmallAndQuick "makePrimitive is idempotent" (dirCharProperty makePrimitiveIdem)
  , testSmallAndQuick "Calculates correct order" (dirCharProperty orderCheck)
  , testSmallAndQuick "Can construct from table" (dirCharProperty fromTableCheck)
  , testGroup "Creates valid characters"
    [ testSmallAndQuick "indexToChar" (dirCharProperty indexToCharValid)
    , testSmallAndQuick "principalChar" principalCharValid
    , testSmallAndQuick "mulChars" mulCharsValid'
    , testSmallAndQuick "stimesChar" (dirCharProperty stimesCharValid)
    , testSmallAndQuick "succ" (dirCharProperty succValid)
    , testSmallAndQuick "induced" (dirCharProperty inducedValid)
    , testSmallAndQuick "jacobi" jacobiValid
    , testSmallAndQuick "makePrimitive" (dirCharProperty makePrimitiveValid)
    ]
  ]


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 MachineLearning.Optimization.GradientDescentTest
(
  tests
)

where

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

import qualified Data.Vector.Storable as V
import qualified Numeric.LinearAlgebra as LA

import qualified MachineLearning as ML
import MachineLearning.Regularization (Regularization(..))
import MachineLearning.LeastSquaresModel (LeastSquaresModel(..))
import MachineLearning.Optimization.GradientDescent

import MachineLearning.DataSets (dataset1)

(x, y) = ML.splitToXY dataset1

muSigma = ML.meanStddev x
xNorm = ML.featureNormalization muSigma x
x1 = ML.addBiasDimension xNorm
initialTheta = LA.konst 0 (LA.cols x1)
-- Normal Equation's Result: 340412.660,110631.050,-6649.474
lsExpectedTheta = LA.vector [340412.660, 110630.886, -6649.310]
eps = 1e-3

isInDescendingOrder :: [Double] -> Bool
isInDescendingOrder lst = and . snd . unzip $ scanl (\(prev, _) current -> (current, prev >= current)) (1/0, True) lst

testGradientDescent model expectedTheta = do
  let (theta, optPath) = gradientDescent 0.01 model eps 5000 RegNone x1 y initialTheta
      js = V.toList $ (LA.toColumns optPath) !! 1
  assertVector "theta" 0.01 expectedTheta theta
  assertBool "non-increasing errors" $ isInDescendingOrder js

tests = [testGroup "gradientDescent" [
            testCase "leastSquares" $ testGradientDescent LeastSquares lsExpectedTheta
            ]
        ]


module Main where

import qualified Control.Monad.Random as RndM
import qualified Numeric.LinearAlgebra as LA
import MachineLearning.Clustering
import qualified Data.Vector as V

main = do
  putStrLn "\n=== K-Means Sample Application ===\n"
  -- Step 1. Data loading.
  -- Step 1.1 Training Data loading.
  x <- LA.loadMatrix "linear_regression/data.txt"
  -- Step 2. Learning
  let numIters = 25
      numClusters = 3
  clusterList <- RndM.evalRandIO $ kmeans numIters x numClusters

  -- Step 3. Display results
  print $ "Successfully groupped into " ++ show (V.length clusterList) ++ " clusters"


{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE TemplateHaskell    #-}

-----------------------------------------------------------------------------
-- |
-- Module      :
-- Copyright   :  (C) 2012 Soostone Inc
-- License     :  All Rights Reserved
--
-- Maintainer  :  Ozgun Ataman <oz@soostone.com>
-- Stability   :  experimental
--
-- Defines a standard set of statistics computed for collections of
-- data. For theory around combining cells monoidally, see:
--
-- http://stackoverflow.com/questions/7753002/adding-combining-standard-deviations
-- http://en.wikipedia.org/wiki/Algorithms_for_calculating_variance#On-line_algorithm
----------------------------------------------------------------------------

module Data.StatVar
    ( StatVar (..)
    , svStdDev
    , svVariance

    -- * Operating on StatVars
    , newStatVar
    , updateSV
    , updateSVRemExt
    , trimExt
    , isExtremeVal
    , listToStatVar
    , expandStatVar
    ) where

-------------------------------------------------------------------------------
import           Control.Applicative
import           Control.DeepSeq
import           Data.Aeson
import           Data.DeriveTH
import           Data.Generics
import           Data.List           (foldl')
import           Data.Monoid
import           Data.SafeCopy
import           Data.Serialize
import           Data.Text           (Text)
import qualified Data.Vector         as V
import           Statistics.Sample
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- | A set of standard stats over a collection of numbers
data StatVar = StatVar {
      svMax   :: !Double
    , svMin   :: !Double
    , svSum   :: !Double
    , svCount :: !Int
    , svMean  :: !Double
    , svSOS   :: !Double
    -- ^ sum of squares of differences from the (current) mean. Needed
    -- for Welford's method of variance estimation.
    } deriving (Eq,Show,Read,Ord,Typeable,Data)

-------------------------------------------------------------------------------
$(deriveSafeCopy 0 'base ''StatVar)
$(derives [makeSerialize] [''StatVar])
$(derives [makeNFData] [''StatVar])

-------------------------------------------------------------------------------
instance FromJSON StatVar where
    parseJSON (Object v) = StatVar
      <$> v .: "mx"
      <*> v .: "mn"
      <*> v .: "sm"
      <*> v .: "cnt"
      <*> v .: "avg"
      <*> v .: "sos"

-------------------------------------------------------------------------------
instance ToJSON StatVar where
    toJSON StatVar{..} = object
      [ "mx" .= svMax
      , "mn" .= svMin
      , "sm" .= svSum
      , "cnt" .= svCount
      , "avg" .= svMean
      , "sos" .= svSOS
      ]

-------------------------------------------------------------------------------
-- | Extract components out of a 'StatVar' for convenience in human
-- readable contexts.
expandStatVar :: StatVar -> [(String, Double)]
expandStatVar st =
    [ ("max", svMax st)
    , ("min", svMin st)
    , ("mean", svMean st)
    , ("count", fromIntegral $ svCount st)
    , ("sum", svSum st)
    , ("stdDev", svStdDev st)
    , ("var", svVariance st)
    ]

-------------------------------------------------------------------------------
-- | Convert a list of numerical data into a 'StatVar'
listToStatVar [] = Nothing
listToStatVar (x:xs) = Just $ foldl' updateSV (newStatVar x) xs

-------------------------------------------------------------------------------
newStatVar :: Double -> StatVar
newStatVar x = StatVar { svMax = x
                       , svMin = x
                       , svSum = x
                       , svCount = 1
                       , svMean = x
                       , svSOS = 0 }

-------------------------------------------------------------------------------
-- | Update the stats variable with a new datapoint
updateSV :: StatVar -> Double -> StatVar
updateSV StatVar{..} x =
    StatVar { svMax = mx
            , svMin = mn
            , svSum = sm
            , svCount = cnt
            , svMean = mean
            , svSOS = sos }
    where
      mx = max svMax x
      mn = min svMin x
      sm = svSum + x
      cnt = svCount + 1
      delta = x - svMean
      mean = sm / fromIntegral cnt
      sos = svSOS + delta * (x - mean)

-- | Add new value while trimming extreme cases.
--
-- Require that at least n samples have been collected so far. If new
-- value is outside of the 3-sigma range, it will be replaced by the
-- mean value so far observed.
updateSVRemExt n sv x = updateSV sv $ trimExt n sv x

-- | Maybe trim the value based on given StatVar with historical
-- stats.
trimExt :: Int
        -- ^ Min # of samples required for trim
        -> StatVar
        -- ^ Historical stats
        -> Double
        -- ^ New observed value
        -> Double
        -- ^ (Possibly) trimmed value
trimExt n sv x = if isExtremeVal n sv x
                 then svMean sv
                 else x

-- | Is the value extreme (+- 3 sigmas)?
isExtremeVal :: Int -> StatVar -> Double -> Bool
isExtremeVal n sv x =
    svCount sv >= n && (x > ulimit || x < llimit)
    where
      sdev = svStdDev sv
      mean = svMean sv
      ulimit = mean + 3 * sdev
      llimit = mean - 3 * sdev

-------------------------------------------------------------------------------
svStdDev :: StatVar -> Double
svStdDev = sqrt . svVariance

-------------------------------------------------------------------------------
svVariance :: StatVar -> Double
svVariance st
    | svCount st >= 2 = svSOS st / (fromIntegral $ svCount st - 1)
    | otherwise = 0

-------------------------------------------------------------------------------
instance Monoid StatVar where
    mempty = StatVar 0 0 0 0 0 0

    mappend a b = StatVar {
                        svMax = max (svMax a) (svMax b)
                      , svMin = min (svMin a) (svMin b)
                      , svSum = sum'
                      , svCount = cnt
                      , svMean = mean'
                      , svSOS = sos
                      }
        where
          mean' = sum' / cnt'
          cnt = svCount a + svCount b
          cnt' = fromIntegral cnt
          sum' = svSum a + svSum b

          -- variance calculation; back-compute sos from combined variance
          sos = s1 + s2
          var = (s1 + s2) / (cnt' - 1)
          s1 = (fromIntegral $ svCount a - 1) * svVariance a +
               (fromIntegral $ svCount b - 1) * svVariance b
          s2 = fromIntegral (svCount a) * ((svMean a - mean') ** 2) +
               fromIntegral (svCount b) * ((svMean b - mean') ** 2)

                                 -------------
                                 -- Testing --
                                 -------------

va = V.fromList [3.0,7,2,4,5,7,8]

vb = V.fromList [1.0,6,9,5,3,11,24]

v = V.concat [va, vb]

varVa = varianceUnbiased va
varVb = varianceUnbiased vb
varV = varianceUnbiased v

stA = mkStat va
stB = mkStat vb

-------------------------------------------------------------------------------
-- | stAll should be equal to stComb if the method to merge variances is right.
stAll = mkStat v

-------------------------------------------------------------------------------
stComb = stA `mappend` stB

-------------------------------------------------------------------------------
mkStat va = StatVar mx mn sm (floor cnt) avg sos
    where
      sos = var * (cnt - 1)
      [mx, mn, sm, cnt, avg, var] = map ($ va)
          [V.maximum, V.minimum, V.sum, fromIntegral . V.length, mean, varianceUnbiased]

buildSV = foldl updateSV (newStatVar 175) (replicate 32 133)


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))))


module UnitTests
  ( unitTests
  ) where

import Test.Tasty
import Test.Tasty.HUnit
import Numeric.LinearAlgebra

unitTests =
  testGroup
    "Unit tests"
    [checkTransposition, checkSubtraction]

matrix1 = (2><2) [1,2,3,4] :: Matrix Double
matrix2 = (2><2) [1,1,1,1] :: Matrix Double
trMatrix1 = (2><2) [1,3,2,4] :: Matrix Double
subMatrix1 = (2><2) [0,1,2,3] :: Matrix Double
checkTranspositionMsg = "                        |1 2|    |1 3|" ++ "\n    " ++
                        "Transposition of Matrix |3 4| is |2 4|"

checkSubtractionMsg = "|1 2|   |1 1|    |0 1|" ++ "\n    " ++
                      "|3 4| - |1 1| is |2 3|"

checkTransposition =
  testCase checkTranspositionMsg $ assertEqual [] trMatrix1 (tr matrix1)

checkSubtraction =
  testCase checkSubtractionMsg $ assertEqual [] subMatrix1 (matrix1 - matrix2)


{-# 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


{-# LANGUAGE ConstraintKinds #-}
module Spectrogram(
     spectrogram
    ) where

import Signal
import Windows
import qualified Data.Vector.Unboxed as U
import Data.Vector.Unboxed((!))
import Data.Complex
import Data.Bits
import Common
import Transform
import Graphics.PDF
import Plot
import Control.Applicative((<$>))
import Data.List(foldl1')

import Debug.Trace

debug a = trace (show a) a

_spectrum :: (Sample a, Num a)
          => Int
          -> Double
          -> U.Vector a
          -> U.Vector Double
_spectrum n t d =
    let l = 1 `shiftL` n :: Int
        complexd = U.map (:+ 0) . U.map toDouble $ d
        m (x :+ y) =
            let x' = toDouble x
                y' = toDouble y
            in
            t*(x'*x' + y'*y') / fromIntegral l
    in
    U.map m . fft  $ complexd

prologSpect l b wi hi Nothing _ = return ()
prologSpect l b wi hi (Just r) _ = do
    withNewContext $ do
        applyMatrix $ translate (l :+ b)
        drawXObject r

genPicture :: ((Double, Double) -> Double)
           -> Int
           -> Int
           -> CoordinateMapping Double Double
           -> PDF (Maybe (PDFReference RawImage))
genPicture value w h (plotToPixel, pixelToPlot) = Just <$> do
    runPixmap w h $ do
        let drawValue p = do
            let pl = pixelToPlot p
                v = log (1 + value pl) / log 2.0
                col = Rgb v 0 0
            setColor col 1.0
            pixel p

        mapM_ drawValue ( [ fromIntegral col :+ fromIntegral row | col <- [0..w-1], row <- [0..h-1]])

-- We display only up to sampling frequency / 2 because the spectrum is even.
-- So, it allow a zooming a the frequency that matters instead of displaying redudant information
spectrogram :: (Sample a, Show a)
            => Sampled Time a -- ^ Signal
            -> Time -- ^ Duration
            -> (Int -> Int -> a -> a) -- ^ Window
            -> Int -- ^ Overlap
            -> StyledSignal Double Double
spectrogram signal duration window overlap =
    let samplingF = rate signal
        winSize :: Int
        winExp = 8
        winSize = 1 `shiftL` winExp
        freqResolution = (getF samplingF) / fromIntegral winSize
        frames = frameWithWinAndOverlap winSize overlap window signal
        nbFrames :: Int
        nbFrames = (floor (getT duration * getF (rate frames)))
        listOfSpectra = map (U.slice 0 (winSize `shiftR` 1)) .
                        map (_spectrum winExp (1.0 / getF samplingF)) . takeS nbFrames $ (getSignal frames)
        theSpectrum = U.concat listOfSpectra

        thePeak = U.maximum theSpectrum
        energyLocation = foldl1' (U.zipWith max)  listOfSpectra
        (lowest,_) = U.span (<= thePeak * 0.1) energyLocation
        (highest,_) = U.span (<= thePeak * 0.1) (U.reverse energyLocation)
        startFrequency = fromIntegral (U.length lowest) / fromIntegral winSize * getF samplingF
        stopFrequency = fromIntegral (U.length energyLocation - U.length highest) / fromIntegral winSize * getF samplingF
        normalizedSpectrum = U.map (/ thePeak) theSpectrum
        totalElements = U.length normalizedSpectrum
        value (i,j) =
            let pos = floor i*(winSize `shiftR` 1) + floor (j / freqResolution)
            in
            if pos >= totalElements
                then
                    normalizedSpectrum ! (totalElements - 1)
                else
                    normalizedSpectrum ! pos
        left = leftMargin (defaultPlotStyle)
        bottom = bottomMargin (defaultPlotStyle)
        style = defaultPlotStyle { title = Just "Spectrogram"
                                 , horizontalBounds = Just (0, fromIntegral nbFrames)
                                 , verticalBounds = Just (startFrequency,stopFrequency)
                                 , prolog = prologSpect left bottom
                                 , prologRsrc = genPicture value
                                 , horizontalLabel = Just "frame"
                                 , verticalLabel = Just "Hz"
                                 }
        l=[] :: [[Double]]
        theFrames = [] :: [Double]
    in
    signalsWithStyle False theFrames l style


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 FlexibleInstances #-}
module Marvin.Test.Metric where

import Marvin.API.Table.Internal
import Numeric.LinearAlgebra.HMatrix
import Numeric.LinearAlgebra.Data
import qualified Data.Vector as Vec
import qualified Data.Vector.Unboxed as UVec
import Data.Array

class Metric a where
    dist :: a -> a -> Double

instance Metric R where
    dist a b = abs $ a - b

instance Metric (Vector R) where
    dist a b = norm_Inf $ a - b

instance Metric (Matrix R) where
    dist a b = norm_Inf $ a - b

instance Metric (Vec.Vector R) where
    dist a b = Vec.foldl1 max $ Vec.zipWith (\x y -> abs (x - y)) a b

instance Metric (UVec.Vector R) where
    dist a b = UVec.foldl1 max $ UVec.zipWith (\x y -> abs (x - y)) a b

instance Metric NumericColumn where
    dist a b = dist (values a) (values b)

instance Metric NumericTable where
    dist a b = Vec.maximum $ Vec.zipWith dist (columnsVec a) (columnsVec b)

instance Metric [Double] where
    dist a b = maximum $ zipWith dist a b

instance Metric [[Double]] where
    dist a b = maximum $ zipWith dist a b

-- infinite norm
instance (Ix i, Metric a) => Metric (Array i a) where
    dist a b = maximum $ zipWith dist (elems a) (elems b)