module Statistics.Information.Discrete.MutualInfo where

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

mi :: Eq a => Int -> Matrix a -> Matrix a -> Double
mi base xs ys = entropy base xs + entropy base ys - entropy base (xs <|> ys)

cmi :: Eq a => Int -> Matrix a -> Matrix a -> Matrix a -> Double
cmi base xs ys zs = hxz + hyz - hxyz - hz where
  hxz = entropy base (xs <|> zs)
  hyz = entropy base (ys <|> zs)
  hxyz = entropy base (xs <|> ys <|> zs)
  hz = entropy base zs


module Nnaskell ( NN(..)
                , randomNN
                , activateNN
                , cost
                , optimizeCost
                , loadNN
                , saveNN
                ) where

import Data.Function
import Data.List
import Control.Monad
import System.Random
import Numeric.LinearAlgebra.Data
import Numeric.LinearAlgebra.HMatrix

data NN = NN { nnWs :: [Matrix R]
             , nnBs :: [Vector R]
             } deriving (Show, Read)

randomVec :: Int -> IO (Vector R)
randomVec n = vector <$> (replicateM n $ randomRIO (-1.0, 1.0))

randomMatrix :: Int -> Int -> IO (Matrix R)
randomMatrix n m = matrix m <$> (replicateM ((*) n m) $ randomRIO (-1.0, 1.0))

randomLayer :: Int -> Int -> IO (Matrix R, Vector R)
randomLayer n m = liftM2 (\ws bs -> (ws, bs)) (randomMatrix m n) (randomVec m)

randomNN :: [Int] -> IO NN
randomNN ns = do (ws, bs) <- unzip <$> (sequence $ map (uncurry randomLayer) $ pairScan ns)
                 return $ NN { nnWs = ws
                             , nnBs = bs
                             }

sigmoid :: R -> R
sigmoid t = 1 / (1 + exp (-1 * t))

sigmoidVec :: Vector R -> Vector R
sigmoidVec = fromList . map sigmoid . toList

activateLayer :: Vector R -> (Matrix R, Vector R) -> Vector R
activateLayer as (ws, bs) = sigmoidVec (ws #> as + bs)

activateNN :: NN -> Vector R -> Vector R
activateNN nn as = foldl activateLayer as $ zip ws bs
    where ws = nnWs nn
          bs = nnBs nn

pairScan :: [a] -> [(a, a)]
pairScan (x:y:rest) = (x, y) : pairScan (y:rest)
pairScan _ = []

cost :: [(Vector R, Vector R)] -> NN -> R
cost td nn = (sum $ map inputCost td) / n
    where inputCost (input, output) = sumElements $ cmap (** 2) (activateNN nn input - output)
          n = fromIntegral $ length td

stepBias :: NN -> Int -> R -> NN
stepBias nn updateIdx s = nn { nnBs = map (\(v, idx) -> if idx <= updateIdx && updateIdx < idx + size v
                                                        then accum v (+) [(updateIdx - idx, s)]
                                                        else v)
                                      $ zip bs
                                      $ scanl (\idx v -> idx + size v) 0 bs
                             }
    where bs = nnBs nn

stepWeight :: NN -> Int -> R -> NN
stepWeight nn updateIdx s = nn { nnWs = map (\(mx, idx) -> let (n, m) = size mx
                                                               effIdx = updateIdx - idx
                                                           in if idx <= updateIdx && updateIdx < idx + (n * m)
                                                              then accum mx (+) [((effIdx `div` m, effIdx `mod` m), s)]
                                                              else mx)
                                        $ zip ws
                                        $ scanl (\idx m -> idx + uncurry (*) (size m)) 0 ws
                               }
    where ws = nnWs nn

class Domain d where
    countArgs :: d -> Int
    stepArg :: d -> Int -> R -> d

instance Domain NN where
    countArgs nn = bsCount + wsCount
        where bsCount = sum $ map (length . toList) $ nnBs nn
              wsCount = sum $ map length $ concatMap toLists $ nnWs nn
    stepArg nn idx s = if idx < bsCount
                       then stepBias nn idx s
                       else stepWeight nn (idx - bsCount) s
        where bsCount = sum $ map (length . toList) $ nnBs nn

optimizeCost :: Domain d => (d -> R) -> d -> [d]
optimizeCost cost d = scanl optimizeStep d $ cycle [0 .. n - 1]
    where n = countArgs d
          optimizeStep d idx = minimumBy (compare `on` cost) $ map (stepArg d idx) [-step, 0, step]
          step = 0.1

loadNN :: FilePath -> IO NN
loadNN filePath = read <$> readFile filePath

saveNN :: FilePath -> NN -> IO ()
saveNN filePath nn = writeFile filePath $ show nn


{- |
Description :  Some handy (mathematical, string manipulation, and so on) tools
Copyright   :  (c) Dominik Schrempf 2017
License     :  GPLv3

Maintainer  :  dominik.schrempf@gmail.com
Stability   :  unstable
Portability :  non-portable (not tested)

Please see function definitions and documentations.

* Changelog

-}

module Tools
  ( allValues
  , harmonic
  , matrixSeparateSymSkew
  , matrixSetDiagToZero
  , nearlyEq
  , left
  , right
  ) where

import Numeric.LinearAlgebra

-- | Get all values of a bounded enumerated type.
allValues :: (Bounded a, Enum a) => [a]
allValues = [minBound..]

-- | Calculate the nth harmonic number.
harmonic :: Int -> Double
harmonic 1 = 1.0
harmonic n = 1.0 / fromIntegral n + harmonic (n-1)

-- | Separate a square matrix into a symmetric and a skew-symmetric matrix.
matrixSeparateSymSkew :: Matrix R -> (Matrix R, Matrix R)
matrixSeparateSymSkew m = (mSym, mSkew)
  where trM = tr m
        mSym  = scale 0.5 $ m + trM
        mSkew = scale 0.5 $ m - trM

-- | Set the diagonal entries of a matrix to zero.
matrixSetDiagToZero :: Matrix R -> Matrix R
matrixSetDiagToZero m = m - diag (takeDiag m)

-- | Test for equality with tolerance (needed because of machine precision).
nearlyEq :: Double -> Double -> Double -> Bool
nearlyEq tol a b = tol > abs (a-b)

-- Functions that fill a string 's' to a given width 'n' by adding a pad
-- character 'c' (c) to align right.
fillDiff :: Int -> String -> Int
fillDiff width entry =
  if l >= width then 0 else width - l
  where l = length entry

fillLeft :: Char -> Int -> String -> String
fillLeft c n s = s ++ replicate (fillDiff n s) c

fillRight :: Char -> Int -> String -> String
fillRight c n s = replicate (fillDiff n s) c ++ s

-- | Fill a string to a given width by adding spaces. Align left.
left :: Int -> String -> String
left = fillLeft ' '

-- | Fill a string to a given width by adding spaces. Align right.
right :: Int -> String -> String
right = fillRight ' '


module Lib.Utility.Differentiation (
    numericalGradient
 ) where

import Numeric.LinearAlgebra
import Numeric.LinearAlgebra.Devel

h = 1e-4

type F = X -> Double
type X = Matrix Double
numericalGradient :: F -> X -> X
numericalGradient f xs = runSTMatrix $ do
    xs' <- thawMatrix xs
    let (rows, columns) = size xs
    let grad = newMatrix 0 rows columns
    let allIndex = [(r,c) | r <- [0..rows-1], c <- [0..columns-1]]
    foldr (\(r, c) grad -> do
        x <- readMatrix xs' r c
        grad' <- grad
        writeMatrix xs' r c $ x+h
        xs'' <- freezeMatrix xs'
        let fxHPlus = f xs''
        writeMatrix xs' r c $ x-h
        xs'' <- freezeMatrix xs'
        let fxHMinus = f xs''
        let delta = (fxHPlus - fxHMinus) / (2 * h)
        writeMatrix xs' r c x
        writeMatrix grad' r c delta
        return grad'
        ) grad allIndex


-- | A module that shows some simple examples demonstrating how to use the package.
module System.Console.Ansigraph.Examples (

    demo
  , legend
  , showColors

-- * Horizontal graphs
  , waveDemoComplex
  , waveDemoReal
  , waveDemoPositive
  , wave

-- * Matrix graphs

  , matDemoReal
  , matDemoComplex
  , unitary

) where

import System.Console.Ansigraph

import System.Console.ANSI
import Control.Monad      (forM_)
import Data.Complex       (Complex (..), cis, realPart)
-- for GHC <= 7.8
import Control.Applicative

---- Wave Demo ----

-- | A complex wave vector, part of the graph of /z(x,t) = exp(ix - it)/ in some units.
wave :: [Complex Double]
wave = cis . (*) (pi/20) <$> [0..79]

deltas :: [Double]
deltas = (*) (-pi/10) <$> [0..80]

waves :: [[Complex Double]]
waves = zipWith (\z -> map (* z)) (cis <$> deltas) $ repeat wave

rwaves :: [[Double]]
rwaves = map (map realPart) waves

pwaves :: [PosGraph]
pwaves = PosGraph . map (+1) <$> rwaves

-- | Display an animation of the positive real function /p(x,t) = cos(x-t) + 1/ in some units.
waveDemoPositive :: IO ()
waveDemoPositive = animate pwaves

-- | Display an animation of the real function /r(x,t) = cos(x-t)/ in the standard style, i.e. with both
--   positive and negative regions.
waveDemoReal :: IO ()
waveDemoReal = animate rwaves

-- | Display an animation of the complex wave /z(x,t) = exp(ix - it)/ in some units.
waveDemoComplex :: IO ()
waveDemoComplex = animate waves

---- Matrix Demos ----

vscale :: Num a => a -> [a] -> [a]
vscale x = map (* x)

mscale :: Num a => a -> [[a]] -> [[a]]
mscale x = map $ map (* x)

-- The following is a quick implementation of the matrix tensor product ('mox').
-- The details are not relevant to the library, but are only used for this example.

fromRealVs :: [Double] -> [Double] -> [Complex Double]
fromRealVs = zipWith (:+)

fromRealMs :: [[Double]] -> [[Double]] -> [[Complex Double]]
fromRealMs = zipWith fromRealVs

vox :: Num a => [a] -> [a] -> [a]
vox v w = concatMap (`vscale` w) v

-- matrix tensor product
mox :: Num a => [[a]] -> [[a]] -> [[a]]
mox m1 m2 = zipWith vox (stepOne m1 m2) (stepTwo m1 m2)
  where stepOne, stepTwo :: [[a]] -> [[a]] -> [[a]]
        stepOne x y = concatMap (replicate (length y)) x
        stepTwo x y = concat $ replicate (length x) y

---- Complex matrix example ----

sx, sz, sI :: [[Double]]
sz  = [[1,0],[0,-1]]
sx  = [[0,1],[1,0]]
sI  = [[1,0],[0,1]]

-- Time-exponentials of pauli matrices
-- exp(itσ) = cos(t)I + i sin(t)σ
sinSX, sinSZ :: Double -> [[Complex Double]]
sinSX t = fromRealMs (mscale (cos t) sI) (mscale (sin t) sx)
sinSZ t = fromRealMs (mscale (cos t) sI) (mscale (sin t) sz)

-- | An example of a time-dependent complex matrix.
unitary :: Double -> [[Complex Double]]
unitary t = sinSZ t `mox` sinSX (2*t)

slowDeltas :: [Double]
slowDeltas = (*) (pi/50) <$> [0..100]

-- | Shows an animation of an example time-dependent matrix formed from Pauli matrices, called
--   'unitary'. Specifically, it is the tensor product of σz and σx exponentiated with different
--   frequencies.
matDemoComplex :: IO ()
matDemoComplex = animate $ unitary <$> slowDeltas

---- Real matrix example ----

ry :: Double -> [[Double]]
ry t = [[cos t, 0, sin t]
       ,[0, 1, 0]
       ,[-(sin t),0,cos t]]

-- | An example real matrix animation.
matDemoReal :: IO ()
matDemoReal = animate $ (\t -> ry t `mox` ry (2*t)) <$> slowDeltas

---- Show ANSI Colors ----

colors = [Black,Red,Green,Yellow,Blue,Magenta,Cyan,White]
intensities = [Dull,Vivid]

ansicolors :: [AnsiColor]
ansicolors = [ AnsiColor i c | c <- colors, i <- intensities ]

-- | Show all of the available 'AnsiColor's with corresponding 'ColorIntensity', 'Color' pairs.
showColors = do
  boldStrLn noColoring "Available colors"
  newline
  forM_ ansicolors $ \c -> do
    let clr = Coloring Nothing (Just c)
    colorStr clr $ replicate 20 ' '
    putStrLn $ "  " ++ show (intensity c) ++ " " ++ show (color c)
  setSGR [Reset]

cb, bc :: Coloring
cb = mkColoring (AnsiColor Dull Black) (AnsiColor Vivid Cyan)
bc = invert cb

newline = putStrLn ""

verticalPad io = do
  newline
  io
  newline
  newline

-- | Displays a legend showing color conventions for supported graph types.
legend = do
  boldStrLn cb "       Legend       "
  newline

  boldStrLn noColoring "Horizontal Graphs"
  newline
  colorStr (fromBG blue) "  "
  putStrLn " Real component (positive and negative)"
  newline
  colorStr (fromBG pink) "  "
  putStrLn " Imag component (positive and negative)"
  newline

  boldStrLn noColoring "Matrix Graphs"
  newline
  putStr "  "
  colorStr (mkColoring white pink) "+i"
  putStrLn "  "
  colorStr (mkColoring white red) "-r"
  putStr "  "
  colorStrLn (mkColoring white blue) "+r"
  putStr "  "
  colorStr (mkColoring white green) "-i"
  putStrLn "  "

-- | Run all of the demos in sequence.
demo = do

  verticalPad $ boldStrLn cb "       Ansigraph demo       "

  putStr "Positive function graph  "
  colorStrLn bc " cos (x - t) + 1 "
  verticalPad waveDemoPositive

  putStr "Real function graph  "
  colorStrLn bc "  cos (x - t)  "
  verticalPad waveDemoReal

  putStr "Complex function graph  "
  colorStrLn bc "  exp (ix - it)  "
  verticalPad waveDemoComplex

  putStr "Real matrix graph  "
  colorStrLn bc "  rotate_Y(t) ⊗ rotate_Y(2t)  "
  verticalPad matDemoReal

  putStr "Complex matrix graph  "
  colorStrLn bc "  exp (it σz) ⊗ exp (2it σx)  "
  verticalPad matDemoComplex

  verticalPad showColors

  verticalPad legend


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
module Transform(
      --spectrum
      spectrum
    , testFFT
    , testFFT1
    , FFT(..)
    --, testBitReverse
    -- , bitReverse
    ) where

import Data.Complex
import qualified Numeric.GSL.Fourier as F
import qualified Data.Vector.Unboxed as U
import Data.Vector.Unboxed((!))
import qualified Data.Vector.Unboxed.Mutable as M
import Control.Monad.ST
import Data.Bits(shiftL,shiftR)
import Data.Int
import Data.Bits
import Control.Monad.Primitive
import Control.Monad(forM_,foldM_,when)
import Data.Word
import Data.Int
import Data.Bits
import Fixed
import Common(Time(..),Frequency(..))
import Windows
import Signal
import GHC.TypeLits
import Foreign.C.Types
import TypeAddition

--import Debug.Trace

isPowerOfTwo :: Word32 -> Bool
isPowerOfTwo a = (a /= 0) && ((a .&. (a-1)) == 0)

--debug a = trace (show a) a

restrictVectorToPOT :: U.Unbox a => U.Vector a -> (Int,U.Vector a)
restrictVectorToPOT v' | isPowerOfTwo (fromIntegral $ U.length v') = (n,v')
                       | otherwise = (n,U.generate (1 `shiftL` n) (v' !))
  where log2 x = log x / log 2
        n = floor (log2 (fromIntegral $ U.length v'))

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

spectrum :: (FFT a, Sample a)
         => (Int -> Int -> a -> a)  -- ^ Window
         -> Int -- ^ Duration of signal
         -> Sampled Time a -- ^ Sampling period
         -> Sampled Frequency Double -- ^ (frequency resolution, Output spectrum)
spectrum window nbPoints signal =
    let f = (rate signal)
        s = _spectrum window . takeVectorS nbPoints $ (getSignal signal)
        nbSamples = U.length s
        freqResolution = f / fromIntegral nbSamples
        freqSignal = fromVectorS 0 s
    in
    Sampled freqResolution freqSignal

bitReverse :: Int -> Int -> Int
bitReverse bitSize a = fromIntegral $ br (bitSize - 1) 0 (fromIntegral a)
 where
  br :: Int -> Word64 -> Word64 -> Word64
  br i !r !a | i < 0 = r
             | a .&. 1 == 1 = br (i-1) (r .|. (1 `shiftL` i)) (a `shiftR` 1)
             | otherwise = br (i-1) (r) (a `shiftR` 1)

bitReverseA :: (M.Unbox a) => Int -> M.MVector s a -> ST s ()
bitReverseA nb m = do
    let l = 1 `shiftL` nb
    forM_ [0..l-1] $ \i -> do
      let j = fromIntegral $ bitReverse nb (fromIntegral i)
      when (j > i) $ M.swap m i j

--testBitReverse :: Int -> U.Vector Int
--testBitReverse n =
--    let v = U.fromList ([0..((1 `shiftL` n)-1)] :: [Int])
--        r = do
--               vect <- U.thaw v
--               bitReverseA n vect
--               U.freeze vect
--    in
--    runST r

instance Functor Complex where
    fmap f (a :+ b) = f a :+ f b

type FFTCore a = forall s . Int -> Int -> M.MVector s (Complex a) -> ST s ()

_fft :: Sample a
     => Int -- ^ Power of 2
     -> Int
     -> M.MVector s (Complex a)
     -> ST s ()
_fft n sign vect = do
    bitReverseA n vect
    let l = 1 `shiftL` n
    -- For all stages
    forM_ [0..n-1] $ \s -> do
        let step = 1 `shiftL` s -- Step for the stage
            w1 = fmap fromDouble . cis $ -pi*fromIntegral sign / fromIntegral step
            forAllBlocks w b = do
                forM_ (filter (<l) [b,(b + 2*step)..l]) $ \d -> do
                    let u = d + step
                    x <- M.read vect d
                    y <- M.read vect u
                    let x' = x + w * y
                        y' = x - w * y
                    M.write vect d x'
                    M.write vect u y'
                return (w*w1)
        -- Iterate butterflies. Compute butterfly nb for all blocks
        -- For instance : butterfly 1 for allb blocks
        -- Then butterfly 2 for all blocks
        foldM_ forAllBlocks (1 :+ 0) (filter (< step) [0,1..step])

mac ::  (SingI n, SingI r, SingI (15 + n))
    => Complex (Fixed Int16 15 Sat r)
    -> Complex (Fixed Int16 n Sat r)
    -> Complex (Fixed Int16 n Sat r)
    -> Complex (Fixed Int32 (15 + n) Sat r)
mac w y x = fmap convert x + amulc w y

msb ::  (SingI n, SingI r, SingI (15 + n))
    => Complex (Fixed Int16 15 Sat r)
    -> Complex (Fixed Int16 n Sat r)
    -> Complex (Fixed Int16 n Sat r)
    -> Complex (Fixed Int32 (15 + n) Sat r)
msb w y x = fmap convert x - amulc w y

_fftFixed :: (SingI n, SingI r, SingI (15 + n))
          => Int -- ^ Power of 2
          -> Int
          -> M.MVector s (Complex (Fixed Int16 n Sat r))
          -> ST s ()
_fftFixed n sign vect = do
    bitReverseA n vect
    let l = 1 `shiftL` n
    -- For all stages
    forM_ [0..n-1] $ \s -> do
        let step = 1 `shiftL` s -- Step for the stage
            w1 = fmap fromDouble . cis $ -pi*fromIntegral sign / fromIntegral step :: Complex (Fixed Int16 15 Sat r)
            forAllBlocks (w :: Complex (Fixed Int16 15 Sat r) ) b = do
                forM_ (filter (<l) [b,(b + 2*step)..l]) $ \d -> do
                    let u = d + step
                    x <- M.read vect d
                    y <- M.read vect u
                    let x' = mac w y x
                        y' = msb w y x
                    M.write vect d (fmap convert x')
                    M.write vect u (fmap convert y')
                return (w*w1)
        -- Iterate butterflies. Compute butterfly nb for all blocks
        -- For instance : butterfly 1 for allb blocks
        -- Then butterfly 2 for all blocks
        foldM_ forAllBlocks (1 :+ 0) (filter (< step) [0,1..step])

genericfft :: Sample a
           => Bool
           -> FFTCore a
           -> U.Vector (Complex a)
           -> U.Vector (Complex a)
genericfft inverse fftCore v' =
    let (n,v) = restrictVectorToPOT v'
        sign | inverse = -1
             | otherwise = 1
        r = do
              vect <- U.thaw v
              fftCore n sign vect
              when inverse $ do
                let l = 1 `shiftL` n
                    scale = (fromDouble $ (1.0 / fromIntegral l)) :+ 0
                forM_ [0..l-1] $ \i -> do
                    x <- M.read vect i
                    M.write vect i (x*scale)
              U.freeze vect
    in
    runST r

class FFT a where
    fft :: Sample a
        => U.Vector (Complex a)
        -> U.Vector (Complex a)
    fft = genericfft False _fft

    ifft :: Sample a
         => U.Vector (Complex a)
         -> U.Vector (Complex a)
    ifft = genericfft True _fft

instance FFT Double

instance (SingI n, SingI r, SingI (15 + n)) => FFT (Fixed Int16 n Sat r) where
    fft = genericfft False _fftFixed
    ifft = genericfft True _fftFixed

testFFT :: (FFT a,Sample a) => Int -> Signal a -> U.Vector (Complex Double)
testFFT n s = U.map (fmap toDouble) . fft . toVectorBS . mapBS (:+ 0) . takeVectorS n $ s

testFFT1 :: Sample a => Int -> Signal a -> U.Vector (Complex Double)
testFFT1 n s = U.convert . F.fft . U.convert . toVectorBS . mapBS ((:+ 0) . toDouble) . takeVectorS n $ s


module Instruction where

import           Protolude

import           Data.Complex (Complex (..))
import qualified Data.Matrix  as M

-- NOTE: could be newtyped for more safety
type Qubit = Int

type Qubits = [Qubit]

type Operation = M.Matrix (Complex Double)

data Instruction
  = Gate Operation Qubits
  | Measure
  | Halt
  deriving (Show)


module NeuralNet.CostSpec (costSpec) where

import Test.Hspec
import Numeric.LinearAlgebra
import NeuralNet.Cost

costSpec :: SpecWith ()
costSpec =
  describe "NeuralNet.Cost" $
    describe "computeCost" $ do
      it "calculates correctly for example" $
        let
          al = fromLists [[0.8, 0.9, 0.4]]
          y = fromLists [[1, 1, 1]]
        in computeCost al y `shouldBe` 0.41493159961539694


module Main where

import Numeric.LinearAlgebra
import Common
import Forward
import BackProp
import AutoEncoder
import ActivFunc
import Other

main :: IO ()
main = do
  regression
  classification

regression :: IO ()
regression = do
  ws <- genWeights [2, 4, 8, 1]
  let x = matrix 4 [0, 0, 1, 1,
                    0, 1, 0, 1]
  let y = matrix 4 [0, 1, 1, 0]
  let i = matrix 4 [0, 0, 1, 1,
                    0, 1, 0, 1] -- example
  -- let nws = last . take 500 $ iterate (backPropRegression sigmoids (x, y)) ws
  nws <- last . take 500 $ iterateM (sgdMethod 2 (x, y) $ backPropRegression 0.1 sigmoids) ws
  let pws = preTrains 0.1 500 sigmoids x ws
  npws <- last . take 500 $ iterateM (sgdMethod 2 (x, y) $ backPropRegression 0.1 sigmoids) pws
  putStrLn "training inputs"
  print x
  putStrLn "training outputs"
  print y
  putStrLn "inputs"
  print i
  putStrLn "not trained outputs"
  print $ forwardRegression sigmoidC ws i
  putStrLn "trainined outputs"
  print $ forwardRegression sigmoidC nws i
  putStrLn "pretrainined outputs"
  print $ forwardRegression sigmoidC npws i

classification :: IO ()
classification = do
  ws <- genWeights [2, 4, 8, 3]
  let x = matrix 4 [0, 0, 1, 1,
                    0, 1, 0, 1]
  let y = matrix 4 [1, 0, 0, 0,
                    0, 1, 1, 0,
                    0, 0, 0, 1]
  let i = matrix 4 [0, 0, 1, 1,
                    0, 1, 0, 1] -- example
  -- let nws = last . take 500 $ iterate (backPropClassification sigmoids (x, y)) ws
  nws <- last . take 500 $ iterateM (sgdMethod 2 (x, y) $ backPropClassification 0.1 sigmoids) ws
  let pws = preTrains 0.1 500 sigmoids x ws
  npws <- last . take 500 $ iterateM (sgdMethod 2 (x, y) $ backPropClassification 0.1 sigmoids) pws
  putStrLn "training inputs"
  print x
  putStrLn "training outputs"
  print y
  putStrLn "inputs"
  print i
  putStrLn "not trained outputs"
  print $ forwardClassification sigmoidC ws i
  putStrLn "trainined outputs"
  print $ forwardClassification sigmoidC nws i
  putStrLn "pretrainined outputs"
  print $ forwardClassification sigmoidC npws i


module Perceptron where

import Numeric.LinearAlgebra

v00 = vector [0.0,0.0]
v01 = vector [0.0,1.0]
v10 = vector [1.0,0.0]
v11 = vector [1.0,1.0]

p_and :: Vector Double -> Double
p_and x
  | tmp <= 0.0 = 0.0
  | otherwise = 1.0
  where
    tmp = w <.> x + b
    b = -0.7
    w = vector [0.5,0.5]

p_nand :: Vector Double -> Double
p_nand x
  | tmp <= 0.0 = 0.0
  | otherwise = 1.0
  where
    tmp = w <.> x + b
    b = 0.7
    w = vector [-0.5,-0.5]

p_or :: Vector Double -> Double
p_or x
  | tmp <= 0.0 = 0.0
  | otherwise = 1.0
  where
    tmp = w <.> x + b
    b = -0.2
    w = vector [0.5,0.5]

p_xor :: Vector Double -> Double
p_xor x = p_and $ vector [s1,s2]
  where
    s1 = p_nand x
    s2 = p_or x


import Statistics.Distribution
import Statistics.Distribution.Beta

bt :: BetaDistribution
bt = betaDistr a b
       where
         a = 4.0
         b = 2.0

main = do
  putStrLn $ "at least 90 percent: " ++ show (complCumulative bt 0.9)


{-# LANGUAGE CPP #-}
-- |
-- Module    : Numeric.SpecFunctions
-- Copyright : (c) 2009, 2011, 2012 Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- Special functions and factorials.
module Numeric.SpecFunctions (
    -- * Error function
    erf
  , erfc
  , invErf
  , invErfc
    -- * Gamma function
  , logGamma
  , logGammaL
  , incompleteGamma
  , invIncompleteGamma
  , digamma
    -- * Beta function
  , logBeta
  , incompleteBeta
  , incompleteBeta_
  , invIncompleteBeta
    -- * Sinc
  , sinc
    -- * Logarithm
    -- $log1p
  , log1p
  , log1pmx
  , log2
    -- * Exponent
  , expm1
    -- * Factorial
  , factorial
  , logFactorial
  , stirlingError
    -- * Combinatorics
  , choose
  , logChoose
    -- * References
    -- $references
  ) where

import Numeric.SpecFunctions.Internal

-- $log1p
--
-- Base starting from @4.9.0@ (GHC 8.0) provides 'log1p' and 'expm1'
-- as method of class 'Floating'. In this case we simply reexport
-- these function. Otherwise we provide our own with more restrictive
-- signature @Double → Double@.

-- $references
--
-- * Bernardo, J. (1976) Algorithm AS 103: Psi (digamma)
--   function. /Journal of the Royal Statistical Society. Series C
--   (Applied Statistics)/ 25(3):315-317.
--   <http://www.jstor.org/stable/2347257>
--
-- * Cran, G.W., Martin, K.J., Thomas, G.E. (1977) Remark AS R19
--   and Algorithm AS 109: A Remark on Algorithms: AS 63: The
--   Incomplete Beta Integral AS 64: Inverse of the Incomplete Beta
--   Function Ratio. /Journal of the Royal Statistical Society. Series
--   C (Applied Statistics)/ Vol. 26, No. 1 (1977), pp. 111-114
--   <http://www.jstor.org/pss/2346887>
--
-- * Lanczos, C. (1964) A precision approximation of the gamma
--   function.  /SIAM Journal on Numerical Analysis B/
--   1:86–96. <http://www.jstor.org/stable/2949767>
--
-- * Loader, C. (2000) Fast and Accurate Computation of Binomial
--   Probabilities. <http://projects.scipy.org/scipy/raw-attachment/ticket/620/loader2000Fast.pdf>
--
-- * Macleod, A.J. (1989) Algorithm AS 245: A robust and reliable
--   algorithm for the logarithm of the gamma function.
--   /Journal of the Royal Statistical Society, Series C (Applied Statistics)/
--   38(2):397–402. <http://www.jstor.org/stable/2348078>
--
-- * Majumder, K.L., Bhattacharjee, G.P. (1973) Algorithm AS 63: The
--   Incomplete Beta Integral. /Journal of the Royal Statistical
--   Society. Series C (Applied Statistics)/ Vol. 22, No. 3 (1973),
--   pp. 409-411. <http://www.jstor.org/pss/2346797>
--
-- * Majumder, K.L., Bhattacharjee, G.P. (1973) Algorithm AS 64:
--   Inverse of the Incomplete Beta Function Ratio. /Journal of the
--   Royal Statistical Society. Series C (Applied Statistics)/
--   Vol. 22, No. 3 (1973), pp. 411-414
--   <http://www.jstor.org/pss/2346798>
--
-- * Temme, N.M. (1992) Asymptotic inversion of the incomplete beta
--   function. /Journal of Computational and Applied Mathematics
--   41(1992) 145-157.
--
-- * Temme, N.M. (1994) A set of algorithms for the incomplete gamma
--   functions. /Probability in the Engineering and Informational
--   Sciences/, 8, 1994, 291-307. Printed in the U.S.A.


module Main where

import           BuckinghamPi
import           FileOperations
import           Numeric.LinearAlgebra.HMatrix

rho = DimensionalVariable "rho" [(Mass   , 1.0)  , (Length , -3.0)]
vel = DimensionalVariable "v"   [(Length , 1.0)  , (Time   , -1.0)]
l   = DimensionalVariable "l"   [(Length , 1.0)]
mu  = DimensionalVariable "mu"  [(Mass   , 1.0)  , (Length , -1.0)  , (Time , -1.0)]
a   = DimensionalVariable "a"   [(Length , 1.0)  , (Time   , -1.0)]

dimVars = [rho, vel, l, mu, a]
funUnits = [Mass, Length, Time]

--writeDimensionlessGroups :: [DimensionlessVariable] -> FilePath -> IO ()
main :: IO ()
main = fmap (\d -> generatePiGroups d [0..(numFundamentalUnits dimVars - 1)]) (readVariablesFromFile "./app/dimensional_variables") >>= (\v -> writeDimensionlessGroups v "dimensionless_groups")


module Lib where

import           Constants    (pitchStandard, sampleRate, volume)
import           Data.Complex
import           Envelope
import           Types

-- Frequency decrease magic number. Frequency of note starts at 200% and quickly decreases
-- to 100% to simulate the initial hit. Increasing `kFreq` increases the rate
-- of decrease.
kFreq = 0.0015

-- https://pages.mtu.edu/~suits/NoteFreqCalcs.html
frequency :: HalfNotes -> Frequency
frequency n = pitchStandard * (2 ** (1.0 / 12.0)) ** n

-- https://dsp.stackexchange.com/questions/2051/why-does-a-wave-continuously-decreasing-in-frequency-start-increasing-its-freque
--
--
-- TODO Smoothly go between two frequencies
--
-- https://dsp.stackexchange.com/questions/971/how-to-create-a-sine-wave-generator-that-can-smoothly-transition-between-frequen?noredirect=1&lq=1
--
-- https://github.com/rmichela/Acoustico/blob/194945595e78d1e0d1a46d9ffde03fc8a7212d38/phasor.go
--
--

data TrigGenerator
  = TrigGenerator
      { _time          :: Double
      , _stabilityTime :: Double
      , phasor         :: Complex Double
      , sampleRate     :: Double
      }

wave :: Double -> Frequency -> TimeStamp -> Double
wave amp hz t = volume * sin (2 * pi * t * hz / sampleRate)

signal :: Frequency -> [Pulse]
signal hz =
  map
    (\t ->
      wave volume hz t
      * attack t
      * decay t
      * sustain t
      * release t)
     timestamps
  where
    Envelope attack decay sustain release = makeEnvelope
    timestamps = [1.0..sampleRate]

pulses :: HalfNotes -> Beats -> [Pulse]
pulses n beats = signal (frequency n)


{-|
Module      : Marvin.API.Algorithms.Internal.GradientDescent
Description : Optimization algorithm.
-}
module Marvin.API.Algorithms.Internal.GradientDescent where

import Marvin.API.Table.Internal as Table
import Marvin.API.Fallible

import Numeric.LinearAlgebra.HMatrix
import Numeric.LinearAlgebra.Data as LA

import qualified Data.Vector as Vec
import qualified Data.Vector.Unboxed as UVec

import Control.Arrow
import Control.Monad.Except
import Data.List (intercalate)

-- | Resulting model
data LinearModel = LM {
  featureColumnNames :: [Fallible ColumnName]
  , targetVariableName :: Fallible ColumnName
  , coefs :: LA.Vector Double
  , intercept_ :: Double
} deriving Eq

instance Show LinearModel where
  show model = intercalate " +\n" $ map ((++) "\t") $ show (intercept_ model) : columnStrings
    where
      columnStrings = map (\(idx, (coef, fallibleName)) ->
        let name = case fallibleName of
              Right n -> n
              Left _ -> "column #" ++ show idx
        in show coef ++ " * " ++ name) $
        zip [0..] $ zip (LA.toList (coefs model)) (featureColumnNames model)

fit' :: GradientDescent -> (NumericTable, NumericColumn) -> LinearModel
fit' gradDesc (nt, nc) = LM {
    featureColumnNames = columnNames nt
    , targetVariableName = columnName nc
    , intercept_ = intercept'
    , coefs = theta'
  }
  where
    featureMtx = tableToMatrix nt
    targetVar = columnToVector nc
    modelParams = gradientDescent gradDesc featureMtx targetVar
    theta = modelParams
    (intercept', theta') = if (addIntercept gradDesc)
      then (theta ! 0, LA.subVector 1 (LA.size theta - 1) theta)
      else (0, theta)

predict' :: LinearModel -> NumericTable -> Fallible NumericColumn
predict' model test = do
      dimCheck
      return $ unsafePredict model test
    where
      modelDim = LA.size $ coefs model
      testDim = numberOfColumns test
      dimCheck = if modelDim == testDim
          then return ()
          else throwError $
            RowLengthMismatch $
              "When attempting to make predictions based on a linear model. " ++
              "coefficients: " ++ (show modelDim) ++
              ", columns: " ++ (show testDim) ++ "."

-- | Predicts without checks.
unsafePredict :: LinearModel -> NumericTable -> NumericColumn
unsafePredict model nt = pred
  where
    pred = unsafeFromVector $ fromLinAlgVector $ batchPredict theta c x
    x = tableToMatrix nt
    theta = coefs model
    c = intercept_ model

-- | Predicts with hmatrix types.
batchPredict :: LA.Vector R -> R -> FeatureMatrix -> TargetVariable
batchPredict theta intercept x = cmap (+ intercept) (x #> theta)

-- * Type aliases
type TargetVariable   = Vector R
type FeatureVector    = Vector R

type FeatureMatrix    = Matrix R
type ModelParameters  = Vector R

type CostFunction = FeatureMatrix -> TargetVariable -> ModelParameters -> (R, Vector R)
type Regularization = R -> ModelParameters -> (R, Vector R)

-- * Parameters
data GradientDescent = GradientDescent {
  learningRate :: Double
  , addIntercept :: Bool
  , lambda :: Double
  , cost :: CostFunction
  , initModelParams :: FeatureMatrix -> TargetVariable -> ModelParameters
  , numIter :: Int
}

defaultGradientDescent = GradientDescent {
  learningRate = 0.1
  , initModelParams = \x y -> cols x |> [1,1..]
  , numIter = 10
  , lambda = 0.1
  , addIntercept = True
  , cost = linearRegressionCost
}
-- * Cost functions

logisticRegressionCost :: FeatureMatrix -> TargetVariable -> ModelParameters
                                                     -> (R, Vector R)
logisticRegressionCost x@features y@targetVariable theta@modelParameters =
  (cost, gradient)
  where
    cost            = (1 / m) * sumElements (-y * log h - (1-y) * log(1-h))
    gradient        = scale (1 / m) $ tr x #> error
    m               = fromIntegral (rows x) :: R
    error           = h - y
    h@hypothesis    = cmap sigmoid $ x #> theta

linearRegressionCost :: FeatureMatrix -> TargetVariable -> ModelParameters -> (R, Vector R)
linearRegressionCost x@features y@targetVariable theta@modelParameters =
  (cost, gradient)
  where
    cost            = (1 / (2 * m)) * sumElements (error ^ 2)
    gradient        = scale (1 / m) $ tr x #> error
    m               = fromIntegral (rows x) :: R
    error           = h - y
    h@hypothesis    = x #> theta

addRegularization :: R -> CostFunction -> Regularization -> CostFunction
addRegularization lambda costFunction regularization x y theta =
  (cost + regCost, gradient + regGradient)
  where
    (cost, gradient) = costFunction x y theta
    (regCost, regGradient) = regularization lambda theta

l2 :: R -> ModelParameters -> (R, Vector R)
l2 lambda@regularizationCoefficient theta@modelParameters =
  (cost, gradient)
  where
    cost = lambda * (norm_2 modelParameters)^2
    gradient = scale (2 * lambda) modelParameters

-- * Algorithm

gradientDescent :: GradientDescent -> FeatureMatrix -> TargetVariable ->
  ModelParameters
gradientDescent params featureMtx targetVariable =
  runIteration (numIter params) modelUpdater initModel
    where
      features = if addIntercept params
        then addInterceptFeature featureMtx
        else featureMtx
      lambda' = lambda params
      cost' = cost params
      costFunction = if lambda' /= 0
        then addRegularization lambda' cost' l2
        else cost'
      alpha                       = learningRate params
      initModel                   = initModelParams params features targetVariable
      gradient model              = snd $ costFunction features targetVariable model
      modelUpdater theta          = theta - scale alpha (gradient theta)

-- * Helpers

addInterceptFeature :: FeatureMatrix -> FeatureMatrix
addInterceptFeature features = LA.fromColumns $ constantFeature:toColumns x
  where
    x                   = features
    (m,_)               = size x
    constantFeature     = m |> repeat 1

sigmoid :: R -> R
sigmoid z = 1 / (1 + exp(-z))

runIteration :: Int -> (a -> a) -> a -> a
runIteration n f init = iterate f init !! n

-- * Conversions

columnToVector :: NumericColumn -> LA.Vector R
columnToVector = LA.fromList . UVec.toList . values

tableToMatrix :: NumericTable -> LA.Matrix R
tableToMatrix =
  columnsVec >>>
  Vec.toList >>>
  map columnToVector >>>
  LA.fromColumns

fromLinAlgVector :: LA.Vector R -> UVec.Vector R
fromLinAlgVector = LA.toList >>> UVec.fromList

toLinAlgVector :: Vec.Vector R -> LA.Vector R
toLinAlgVector = Vec.toList >>> LA.fromList


-- Gaussian primes
-- http://www.codewars.com/kata/54d6abf84a35017d30000b26/

module Data.Complex.Gaussian.Prime where

import Control.Arrow ((&&&))
import Data.Complex.Gaussian (Gaussian (..), norm)

isGaussianPrime :: Gaussian -> Bool
isGaussianPrime g@(Gaussian a b) | a == 0 = f b
                                 | b == 0 = f a
                                 | otherwise = isPrime . norm $ g
                                 where f = uncurry (&&) . ((==3) . (`mod` 4) &&& isPrime) . abs
                                       isPrime n | n `elem` [2, 3, 5] = True
                                                 | n `mod` 2 == 0 || n `mod` 3 == 0 = False
                                                 | otherwise = notElem 0 . map (n `mod`) $ [5, 7 .. floor . sqrt . fromIntegral $ n]


-----------------------------------------------------------------------------
{- |
This module defines the monad of sampling functions. See Park, Pfenning and Thrun:
A probabilistic language based upon sampling functions, Principles of programming languages 2005

Sampling functions allow the composition of both discrete and continuous
probability distributions.

The implementation and interface are similar to those in the random-fu, monte-carlo
and monad-mersenne-random packages.

Example -- a biased coin:

@
data Throw = Head | Tail

throw bias = do
  b <- bernoulli bias
  return $ if b then Head else Tail

tenThrowsCrooked = replicateM 10 $ throw 0.3

countHeads = do
   throws <- tenThrowsCrooked
   return $ length [ () | Head <- throws]

main = do
 print =<< sampleIO tenThrowsCrooked
 print =<< eval ((\<4) \`fmap\` countHeads)
@

-}

{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}

module Math.Probably.Sampler where

import Control.Monad
import Control.Applicative
import qualified Math.Probably.PDF as PDF
import Numeric.LinearAlgebra hiding (find)
import System.Random.Mersenne.Pure64
import System.Environment
import Data.List
import Data.Maybe
import Data.Ord
import Control.Spoon

--import Debug.Trace

type Seed = PureMT

data Sampler a = Sam {unSam :: Seed -> (a, Seed) }
               | Samples [a]

instance Functor Sampler where
    fmap f (Sam sf) = Sam $ \rs -> let (x,rs') = sf rs in
                                   (f x, rs')
    fmap f (Samples xs) = Samples $ map f xs

instance Applicative Sampler where
    pure x = Sam (\rs-> (x, rs))
    (Sam sff) <*> (Sam sfx) = Sam $ \rs-> let (f ,rs') = sff rs
                                              (x, rs'') = sfx rs' in
                                          (f x, rs'')

instance Monad Sampler where
    return = pure
    (Sam sf) >>= f = Sam $ \rs-> let (x, rs'::Seed) = sf rs
                                     nextProb = f x
                                 in case nextProb of
                                      Sam g -> g rs'
                                      Samples xs -> primOneOf xs rs'
    (Samples xs) >>= f = Sam $ \rs-> let (x, rs'::Seed) = primOneOf xs rs
                                         nextProb = f x
                                     in case nextProb of
                                          Sam g -> g rs'
                                          Samples ys -> primOneOf ys rs'

-- | given a seed, return an infinite list of draws from sampling function
runSampler :: Seed -> Sampler a -> [a]
runSampler pmt s@(Sam sf)
   = let (x, pmt') = sf pmt
     in x : runSampler pmt' s
runSampler _ (Samples xs) = xs

-- | Get a seed
getSeedIO :: IO Seed
getSeedIO = do
   args <- getArgs
   case mapMaybe (stripPrefix "--seed=") args of
      [] ->  newPureMT
      sdStr:_ -> return $ pureMT $ read sdStr

-- | Return an infinite list of draws from sampling function in the IO monad
runSamplerIO :: Sampler a -> IO [a]
runSamplerIO s =
   fmap (`runSampler` s) $ getSeedIO

-- | Return a singe draw from sampling function
sampleIO :: Sampler a -> IO a
sampleIO s = head `fmap` runSamplerIO s

-- | Return a list of n draws from sampling function
sampleNIO :: Int -> Sampler a -> IO [a]
sampleNIO n s = take n `fmap` runSamplerIO s

-- | Estimate the probability that a hypothesis is true (in the IO monad)
eval :: Sampler Bool -> Sampler Double
eval s = do
  bs <- replicateM 1000 s
  return $ realToFrac (length (filter id bs)) / 1000

{-mu :: Vector Double
sigma :: Matrix Double

mystery = -1
mu = fromList [0,0,0]
sigma =  (3><3) [ 1,    1,       0,
                  1,    1,     mystery,
                  0,  mystery,   1]

samIt = sampleNIO 2 $ multiNormal mu sigma
 -}
-- | The joint distribution of two independent distributions
joint :: Sampler a -> Sampler b -> Sampler (a,b)
joint sf1 sf2 = liftM2 (,) sf1 sf2

-- | The joint distribution of two distributions where one depends on the other
jointConditional :: Sampler a -> (a-> Sampler b) -> Sampler (a,b)
jointConditional sf1 condsf
    = do x <- sf1
         y <- condsf x
         return (x,y)

--replicateM :: Monad m => Int -> m a -> m [a]
--replicateM n ma = forM [1..n] $ const ma

-- * Uniform distributions

-- | The unit interval U(0,1)
unitSample :: Sampler Double
unitSample = Sam randomDouble

-- | for x and y, the uniform distribution between x and y
uniform :: (Fractional a) => a -> a -> Sampler a
uniform a b = (\x->(realToFrac x)*(b-a)+a) `fmap` unitSample

-- * Normally distributed sampling function

--http://en.wikipedia.org/wiki/Box-Muller_transform
-- | The univariate gaussian (normal) distribution defined by mean and standard deviation
gauss :: (Floating b) => b -> b -> Sampler b
gauss m sd =
    do (u1,u2) <- (mapPair realToFrac) `fmap` joint unitSample unitSample
       return $ sqrt(-2*log(u1))*cos(2*pi*u2)*sd+m
  where mapPair f (x,y) = (f x, f y)

-- | Gaussians specialised for doubles
gaussD :: Double -> Double -> Sampler Double
gaussD m sd =
    do (u1,u2) <- joint unitSample unitSample
       return $ sqrt(-2*log(u1))*cos(2*pi*u2)*sd+m

gaussMany :: Floating b => [(b,b)] -> Sampler [b]
gaussMany means_sds = do gus <- gaussManyUnit (length means_sds)
                         return $ map f $ zip gus means_sds
    where f (gu, (mean, sd)) = gu*sd+mean

gaussManyD :: [(Double,Double)] -> Sampler [Double]
gaussManyD means_sds = do gus <- gaussManyUnitD (length means_sds)
                          return $ zipWith f gus means_sds
    where f gu (mean, sd) = gu*sd+mean

gaussManyUnit :: Floating b => Int -> Sampler [b]
gaussManyUnit 0 = return []
gaussManyUnit n | odd n = liftM2 (:) (gauss 0 1) (gaussManyUnit (n-1))
                | otherwise = do us <- forM [1..n] $ const $ unitSample
                                 return $ gaussTwoAtATime $ map realToFrac us
  where
    gaussTwoAtATime :: Floating a =>  [a] -> [a]
    gaussTwoAtATime (u1:u2:rest) = sqrt(-2*log(u1))*cos(2*pi*u2) : sqrt(-2*log(u1))*sin(2*pi*u2) : gaussTwoAtATime rest
    gaussTwoAtATime _ = []

gaussManyUnitD :: Int -> Sampler [Double]
gaussManyUnitD 0 = return []
gaussManyUnitD n | odd n = liftM2 (:) (gauss 0 1) (gaussManyUnit (n-1))
                | otherwise = do us <- forM [1..n] $ const $ unitSample
                                 return $ gaussTwoAtATimeD us
 where
   gaussTwoAtATimeD :: [Double] -> [Double]
   gaussTwoAtATimeD (u1:u2:rest) = sqrt(-2*log(u1))*cos(2*pi*u2) : sqrt(-2*log(u1))*sin(2*pi*u2) : gaussTwoAtATimeD rest
   gaussTwoAtATimeD _ = []

-- | Multivariate normal distribution
multiNormal :: Vector Double -> Matrix Double -> Sampler (Vector Double)
multiNormal mu sigma =
  let c =   cholSH sigma
      a = trans c
      k = dim mu
  in do z <- fromList `fmap` gaussManyUnitD k
--        return $ mu + (head $ toColumns $ a*asRow z)
        let c = asColumn z
        let r = asRow z
        return $ (mu + (head $ toColumns $ a `multiply` asColumn z))

multiNormalByChol :: Vector Double -> Matrix Double -> Sampler (Vector Double)
multiNormalByChol mu cholSigma =
  let a = trans $ cholSigma
      k = dim mu
  in do z <- fromList `fmap` gaussManyUnitD k
--        return $ mu + (head $ toColumns $ a*asRow z)
        let c = asColumn z
        let r = asRow z
        return $ (mu + (head $ toColumns $ a `multiply` asColumn z))

multiNormalIndep  :: Vector Double -> Vector Double -> Sampler (Vector Double)
multiNormalIndep vars mus = do
   let k = dim mus
   gs <- gaussManyUnitD k
   return $ fromList $ zipWith3 (\var mu g -> g*sqrt(var) + mu) (toList vars) (toList mus) gs

--http://en.wikipedia.org/wiki/Log-normal_distribution#Generating_log-normally-distributed_random_variates

-- | log-normal distribution <http://en.wikipedia.org/wiki/Log-normal_distribution>
logNormal :: (Floating b) => b -> b -> Sampler b
logNormal m sd =
    do n <- gauss 0 1
       return $ exp $ m + sd * n

-- * Other distribution

-- | Bernoulli distribution. Returns a Boolean that is 'True' with probability 'p'
bernoulli :: Double -> Sampler Bool
bernoulli p = (<p) `fmap` unitSample

discrete :: [(Double,a)] -> Sampler a
discrete weightedSamples =
   let sumWeights = sum $ map fst weightedSamples
       cummWeightedSamples = scanl (\(csum,_) (w,x) -> (csum+w,x)) (0,undefined) $ sortBy (comparing fst) weightedSamples
   in do u <- unitSample
         return . snd . fromJust $ find ((>=u*sumWeights) . fst) cummWeightedSamples

primOneOf :: [a] -> Seed -> (a, Seed)
primOneOf xs seed
   = let (u, nextSeed) = randomDouble seed
         idx = floor $ (realToFrac u)*(realToFrac $ length xs )
     in (xs !! idx, nextSeed)

oneOf :: [a] -> Sampler a
oneOf xs = do idx <- floor `fmap` uniform (0::Double) (realToFrac $ length xs )
              return $ xs !! idx

nOf :: Int -> [a] -> Sampler [a]
nOf n xs = sequence $ replicate n $ oneOf xs

{-main = do
  rnds <- take 1000 `fmap` runSamplerSysRan (oneOf [1,2,3])
  let diff = sort $ nub rnds
  print $ map (\x->(x, length $ filter (==x) rnds )) $ diff -}

-- | Bayesian inference from likelihood and prior using rejection sampling.
bayesRejection :: (PDF.PDF a) -> Double -> Sampler a -> Sampler a
bayesRejection p c q = bayes
    where bayes = do x <- q
                     u <- unitSample
                     if u < p x / c
                        then return x
                        else bayes

{-
expectation :: Fractional a =>  Int -> Sampler a -> IO a
expectation n sf =
    (mean . take n) `fmap` runSamplerIO sf

expectSD :: Floating a =>  Int -> Sampler a -> IO (a,a)
expectSD n sf =
    (meanSD . take n) `fmap` runSamplerIO sf
-}

--mapPair :: (a->b) -> (a,a) -> (b,b)

{-
--http://cgi.cse.unsw.edu.au/~dons/blog/2008/05/16#fast
mean :: Fractional a =>  [a] -> a
mean = go 0 0
        where
            -- go ::  -> Int -> [Double] -> Double
            go s n []     = s / fromIntegral n
            go !s !n (x:xs) = go (s+x) (n+1) xs

meanSD :: Floating a => [a] -> (a,a)
meanSD = go 0 0 0
    where go sq s n [] = let len = fromIntegral n in
                         (s/len, (recip len)*sqrt (len*sq-s*s))
          go !sq !s !n (x:xs) = go (sq+x*x) (s+x) (n+1) xs

test_mean = mean [0..1e8]
test_meanVar = meanSD [0..1e8]

main = do u <- expectSD 1000000 $ gauss 0 1
          print u

-}

--poisson ::  ::  Double -> [Double] -> IO Double
-- | Exponential distribution
expDist rate =  (\u-> negate $ (log(1-u))/rate) `fmap` unitSample

-- | Homogeneous poisson process defined by rate and duration
poissonMany :: Double -> Double -> Sampler [Double]
poissonMany rate tmax = aux 0
    where aux last = do
            next <- (+last) `fmap` expDist rate
            if next > tmax
               then return []
               else liftM2 (:) (return next) $ aux next

-- | binomial distribution
binomial :: Int -> Double -> Sampler Int
binomial n p = do
  bools <- forM [1..n] $ const $ fmap (<p) unitSample
  return $ length $ [t | t@True <- bools]

-- from random-fu
-- | Gamma distribution
gamma :: Double -> Double -> Sampler Double
gamma a b
     | a < 1
    = do
        u <- unitSample
        x <- gamma (1 + a) b
        return (x * u ** recip a)
    | otherwise
    = go
        where
            d = a - (1 / 3)
            c = recip (3 * sqrt d) -- (1 / 3) / sqrt d

            go = do
                x <- gaussD 0 1

                let cx = c * x
                    v = (1 + cx) ^ 3

                    x_2 = x * x
                    x_4 = x_2 * x_2

                if cx <= (-1)
                    then go
                    else do
                        u <- unitSample

                        if         u < 1 - 0.0331 * x_4
                            || log u < 0.5 * x_2  + d * (1 - v + log v)
                            then return (b * d * v)
                            else go

-- | inverse gamma distribution
invGamma :: Double -> Double -> Sampler Double
invGamma a b = recip `fmap` gamma a b

--http://en.wikipedia.org/wiki/Multivariate_normal_distribution#Drawing_values_from_the_distribution
--multiNormal :: Vector Double -> Matrix Double -> Sampler (Vector Double)

--http://www.xycoon.com/beta_randomnumbers.htm
-- | beta distribution
beta :: Int -> Int -> Sampler Double
beta a b =
    let gam n = do us <- forM [1..n] $ const unitSample
                   return $ log $ product us
    in do gama1 <- gamma (realToFrac a) 1
--          gama2 <- gamma (realToFrac a) 1

          gamb <- gamma (realToFrac b) 1
          return $ gama1/(gama1+gamb)

tbeta = sampleNIO 100 $ beta 1 1


{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
-- |
-- Module    : Statistics.Distribution.Uniform
-- Copyright : (c) 2011 Aleksey Khudyakov
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- Variate distributed uniformly in the interval.
module Statistics.Distribution.Uniform
    (
      UniformDistribution
    -- * Constructors
    , uniformDistr
    -- ** Accessors
    , uniformA
    , uniformB
    ) where

import Data.Aeson (FromJSON, ToJSON)
import Data.Binary (Binary)
import Data.Data (Data, Typeable)
import GHC.Generics (Generic)
import qualified Statistics.Distribution as D
import qualified System.Random.MWC       as MWC
import Data.Binary (put, get)
import Control.Applicative ((<$>), (<*>))

-- | Uniform distribution from A to B
data UniformDistribution = UniformDistribution {
      uniformA :: {-# UNPACK #-} !Double -- ^ Low boundary of distribution
    , uniformB :: {-# UNPACK #-} !Double -- ^ Upper boundary of distribution
    } deriving (Eq, Read, Show, Typeable, Data, Generic)

instance FromJSON UniformDistribution
instance ToJSON UniformDistribution

instance Binary UniformDistribution where
    put (UniformDistribution x y) = put x >> put y
    get = UniformDistribution <$> get <*> get

-- | Create uniform distribution.
uniformDistr :: Double -> Double -> UniformDistribution
uniformDistr a b
  | b < a     = uniformDistr b a
  | a < b     = UniformDistribution a b
  | otherwise = error "Statistics.Distribution.Uniform.uniform: wrong parameters"
-- NOTE: failure is in default branch to guard againist NaNs.

instance D.Distribution UniformDistribution where
  cumulative (UniformDistribution a b) x
    | x < a     = 0
    | x > b     = 1
    | otherwise = (x - a) / (b - a)

instance D.ContDistr UniformDistribution where
  density (UniformDistribution a b) x
    | x < a     = 0
    | x > b     = 0
    | otherwise = 1 / (b - a)
  quantile (UniformDistribution a b) p
    | p >= 0 && p <= 1 = a + (b - a) * p
    | otherwise        =
      error $ "Statistics.Distribution.Uniform.quantile: p must be in [0,1] range. Got: "++show p

instance D.Mean UniformDistribution where
  mean (UniformDistribution a b) = 0.5 * (a + b)

instance D.Variance UniformDistribution where
  -- NOTE: 1/sqrt 12 is not constant folded (#4101) so it's written as
  --       numerical constant. (Also FIXME!)
  stdDev   (UniformDistribution a b) = 0.2886751345948129 * (b - a)
  variance (UniformDistribution a b) = d * d / 12 where d = b - a

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

instance D.MaybeVariance UniformDistribution where
    maybeStdDev   = Just . D.stdDev

instance D.Entropy UniformDistribution where
  entropy (UniformDistribution a b) = log (b - a)

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

instance D.ContGen UniformDistribution where
    genContVar (UniformDistribution a b) gen = MWC.uniformR (a,b) gen


module MachineLearning.UtilsTest
(
  tests
)

where

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

import MachineLearning.Types (Vector, Matrix)
import qualified Numeric.LinearAlgebra as LA
import qualified Data.Vector.Storable as V
import Numeric.LinearAlgebra ((><))

import MachineLearning.Utils

a :: Matrix
a = (4><5) [ 1, 7, 9, 11, 2
           , 77, 4, 6, 9, 0
           , -11, -55, 3, 11, 55
           , 7, 9, 11, 13, 15
           ]

sumRows :: Matrix
sumRows = (4><1) [ 30
                 , 96
                 , 3
                 , 55
                 ]

sumCols :: Matrix
sumCols = (1><5) [74, -35, 29, 44, 72]

maxRows :: Matrix
maxRows = (4><1) [ 11
                 , 77
                 , 55
                 , 15
                 ]

minCols :: Matrix
minCols = (1><5) [-11, -55, 3, 9, 0]

sumRowsV = LA.flatten sumRows
sumColsV = LA.flatten sumCols
maxRowsV = LA.flatten maxRows
minColsV = LA.flatten minCols

tests = [ testGroup "reduceV" [
            testCase "reduceByRowsV: sum" $ assertVector "" 1e-10 sumRowsV (reduceByRowsV V.sum a)
            , testCase "reduceByColumnsV: sum" $ assertVector "" 1e-10 sumColsV (reduceByColumnsV V.sum a)
            , testCase "reduceByRowsV: max" $ assertVector "" 1e-10 maxRowsV (reduceByRowsV V.maximum a)
            , testCase "reduceByColumnsV: min" $ assertVector "" 1e-10 minColsV (reduceByColumnsV V.minimum a)
            ]
          , testGroup "reduce" [
              testCase "reduceByRows: sum" $ assertMatrix "" 1e-10 sumRows (reduceByRows V.sum a)
              , testCase "reduceByColumns: sum" $ assertMatrix "" 1e-10 sumCols (reduceByColumns V.sum a)
              , testCase "reduceByRows: max" $ assertMatrix "" 1e-10 maxRows (reduceByRows V.maximum a)
              , testCase "reduceByColumns: min" $ assertMatrix "" 1e-10 minCols (reduceByColumns V.minimum a)
            ]
          , testGroup "sum" [
              testCase "sumByRows" $ assertMatrix "" 1e-10 sumRows (sumByRows a)
              , testCase "sumColumns" $ assertMatrix "" 1e-10 sumCols (sumByColumns a)
              ]
          , testCase "listOfTuplesToList" $ assertEqual "" [11, 9, 27, 3, 43, 11] (listOfTuplesToList [(11, 9), (27, 3), (43, 11)])
        ]


module NumberParser
  ( parseNumber
  , parseFloat
  , parseComplex
  ) where

import Data.Complex
import LispVal
import Numeric
import Text.ParserCombinators.Parsec

parseNumber :: Parser LispVal
parseNumber = parseDecimal1 <|> parseDecimal2 <|> parseHex <|> parseOct <|> parseBin

parseDecimal1 :: Parser LispVal
parseDecimal1 = Number . read <$> many1 digit

parseDecimal2 :: Parser LispVal
parseDecimal2 = do
  try $ string "#d"
  x <- many1 digit
  (return . Number . read) x

parseHex :: Parser LispVal
parseHex = do
  try $ string "#x"
  x <- many1 hexDigit
  return $ Number (hex2dig x)

parseOct :: Parser LispVal
parseOct = do
  try $ string "#o"
  x <- many1 octDigit
  return $ Number (oct2dig x)

parseBin :: Parser LispVal
parseBin = do
  try $ string "#b"
  x <- many1 (oneOf "10")
  return $ Number (bin2dig x)

oct2dig x = fst $ head (readOct x)

hex2dig x = fst $ head (readHex x)

bin2dig = bin2dig' 0

bin2dig' digint "" = digint
bin2dig' digint (x:xs) =
  let old =
        2 * digint +
        (if x == '0'
           then 0
           else 1)
   in bin2dig' old xs

toDouble :: LispVal -> Double
toDouble (Float f) = realToFrac f
toDouble (Number n) = fromIntegral n

parseFloat :: Parser LispVal
parseFloat = do
  x <- many1 digit
  char '.'
  y <- many1 digit
  return $ Float (fst . head $readFloat (x ++ "." ++ y))

parseComplex :: Parser LispVal
parseComplex = do
  x <- try parseFloat <|> parseDecimal1 <|> parseDecimal2
  char '+'
  y <- try parseFloat <|> parseDecimal1 <|> parseDecimal2
  char 'i'
  return $ Complex (toDouble x :+ toDouble y)


module Main where

import Numeric.LinearAlgebra
import LeastSquares

main :: IO ()
main = do
  let a = Mat $ (3><2) [1.0, 1.0, 1.0, 4.0, 2.0, -1.0]
  let b = Vec $ vector [13, 27, 1]
  let x = Var "x" 2
  print $ minimize (SumSquares (a * x - b)) []
  -- let a1 = Mat $ (3><1) [1.0, 1.0, 1.0]
  -- let a2 = Mat $ (3><1) [2.0, 4.0, -1.0]
  -- let x1 = Var "x1" 1
  -- let x2 = Var "x2" 1
  print $ minimize (SumSquares (a * x - b) + 2 * SumSquares x) []
  let c = Mat $ (1><2) [1.0, -1]
  let d = Vec $ vector [2]
  print $ minimize (SumSquares (a * x - b)) [c * x :==: d]


module V02 where

import Data.Complex
import Data.List (genericLength)

-- |compute x to the n-th power
power :: Complex Double -> Integer -> Complex Double
power x 0 = 1
power x n | n > 0 = x * power x (n - 1)

examplePair :: (Double, Bool)
examplePair = (3.14, True)

exampleTriple :: (Bool, Integer, String)
exampleTriple = (False, 42, "hello, world")

exampleFunction :: (Bool, Integer, String ) -> Bool
exampleFunction (b, i, s) = b || fromInteger i > length s
-- alternative: ... = b || i > genericLength s

exampleTriple' :: (Bool, Int, String)
exampleTriple' = (False, 42, "hello, world")

exampleFunction' :: (Bool, Int, String ) -> Bool
exampleFunction' (b, i, s) = b || i > length s

summerize :: [String] -> String
summerize [] = "None"
summerize [x] = "Only " ++ x
summerize [x,y] = "Two things: " ++ x ++ " and " ++ y
summerize [_ ,_ ,_ ] = "Three things: ???"
summerize _ = "Several things."

-- |doubles every element of a list of numbers
doubles :: [Integer] -> [Integer]
doubles [] = []
doubles (x:xs) = (2 * x) : doubles xs

-- |map a function on all elements of a list
mymap :: (a -> b) -> [a] -> [b]
mymap f [] = []
mymap f (x:xs) = f x : mymap f xs

double x = 2 * x

doubles' xs = mymap double xs

-- task: use quickcheck to compare doubles and doubles'


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

module DerivProps where

import Data.VectorSpace
import qualified GHC.Exts as GHC
import Numeric.LinearAlgebra hiding ((#>), (===), inv)
import SSSFN
import Test.QuickCheck

default (Int)

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

infix 4 ~~~

(~~~) ::
  (GHC.IsList as, Show as, a ~ GHC.Item as, RealFloat a, Show a) =>
  as ->
  as ->
  Property
xs ~~~ ys =
  let xs' = GHC.toList xs
      ys' = GHC.toList ys
      sc = 1 `max` maximum (map abs xs') `max` maximum (map abs ys')
      di = maximum (zipWith absdiff xs' ys')
   in counterexample
        ( show xs
            ++ " ~~~ "
            ++ show ys
            ++ " (difference "
            ++ show di
            ++ ", scale "
            ++ show sc
            ++ ")"
        )
        (length xs' == length ys' && di <= eps * sc)
  where
    absdiff x y = abs (x - y)
    eps = 100 * peps

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

prop_derivU_coordU :: Property
prop_derivU_coordU = derivU #> coordU @Double ~~~ gpure 1

prop_derivV_coordV :: Property
prop_derivV_coordV = derivV #> coordV @Double ~~~ gpure 1

prop_derivU_coordV :: Property
prop_derivU_coordV = derivU #> coordV @Double ~~~ gpure 0

prop_derivV_coordU :: Property
prop_derivV_coordU = derivV #> coordU @Double ~~~ gpure 0

prop_derivT_coordT :: Property
prop_derivT_coordT = derivT #> coordT @Double ~~~ gpure 1

prop_derivR_coordR :: Property
prop_derivR_coordR = derivR #> coordR @Double ~~~ gpure 1

prop_derivT_coordR :: Property
prop_derivT_coordR = derivT #> coordR @Double ~~~ gpure 0

prop_derivR_coordT :: Property
prop_derivR_coordT = derivR #> coordT @Double ~~~ gpure 0

prop_derivU_coordR :: Property
prop_derivU_coordR = derivU #> coordR @Double ~~~ gpure (-1)

prop_derivV_coordR :: Property
prop_derivV_coordR = derivV #> coordR @Double ~~~ gpure 1

prop_symmetrizeR_coordT :: Property
prop_symmetrizeR_coordT = symmetrizeR #> coordT @Double ~~~ coordT

prop_symmetrizeR_coordR :: Property
prop_symmetrizeR_coordR = symmetrizeR #> coordR @Double ~~~ gpure 0

prop_zproject_const :: Property
prop_zproject_const = zproject #> gpure 1 ~~~ gpure (0 :: Double)

prop_zproject_coordR :: Property
prop_zproject_coordR = zproject #> (coordR :: Grid Double) ~~~ gpure 0

prop_zproject_coordR2 :: Property
prop_zproject_coordR2 = zproject #> (coordR2 :: Grid Double) ~~~ coordR2
  where
    coordR2 = gmap (^ 2) coordR

prop_zproject_coordR2T :: Property
prop_zproject_coordR2T = zproject #> (coordR2T :: Grid Double) ~~~ coordR2T
  where
    coordR2T = gzipWith (\t r -> t * r ^ 2) coordT coordR

prop_zproject_coordR4 :: Property
prop_zproject_coordR4 = zproject #> (coordR4 :: Grid Double) ~~~ coordR4
  where
    coordR4 = gmap (^ 4) coordR

prop_r2project_const :: Property
prop_r2project_const = r2project #> (gpure 1 :: Grid Double) ~~~ gpure 0

prop_r2project_coordR :: Property
prop_r2project_coordR = r2project #> (coordR :: Grid Double) ~~~ gpure 0

prop_r2project_coordR2 :: Property
prop_r2project_coordR2 = r2project #> (coordR2 :: Grid Double) ~~~ gpure 1
  where
    coordR2 = gmap (^ 2) coordR

prop_r2project_coordR2T :: Property
prop_r2project_coordR2T = r2project #> (coordR2T :: Grid Double) ~~~ coordT
  where
    coordR2T = gzipWith (\t r -> t * r ^ 2) coordT coordR

prop_r2project_coordR4 :: Property
prop_r2project_coordR4 = r2project #> (coordR4 :: Grid Double) ~~~ coordR2
  where
    coordR2 = gmap (^ 2) coordR
    coordR4 = gmap (^ 4) coordR

prop_r1derivR_coordR :: Property
prop_r1derivR_coordR = r1derivR #> (coordR :: Grid Double) ~~~ gpure 0

prop_r1derivR_coordR2 :: Property
prop_r1derivR_coordR2 = r1derivR #> (coordR2 :: Grid Double) ~~~ gpure 2
  where
    coordR2 = gmap (^ 2) coordR

prop_r1derivR_coordR2T :: Property
prop_r1derivR_coordR2T = r1derivR #> (coordR2T :: Grid Double) ~~~ 2 *^ coordT
  where
    coordR2T = gzipWith (\t r -> t * r ^ 2) coordT coordR

prop_r1derivR_coordR4 :: Property
prop_r1derivR_coordR4 = r1derivR #> (coordR4 :: Grid Double) ~~~ 4 *^ coordR2
  where
    coordR2 = gmap (^ 2) coordR
    coordR4 = gmap (^ 4) coordR

prop_r1derivU_coordR :: Property
prop_r1derivU_coordR = r1derivU #> (coordR :: Grid Double) ~~~ gpure 0

prop_r1derivU_coordR2 :: Property
prop_r1derivU_coordR2 = r1derivU #> (coordR2 :: Grid Double) ~~~ gpure (-2)
  where
    coordR2 = gmap (^ 2) coordR

prop_r1derivU_coordR4 :: Property
prop_r1derivU_coordR4 = r1derivU #> (coordR4 :: Grid Double) ~~~ (-4) *^ coordR2
  where
    coordR2 = gmap (^ 2) coordR
    coordR4 = gmap (^ 4) coordR

prop_r1derivV_coordR :: Property
prop_r1derivV_coordR = r1derivV #> (coordR :: Grid Double) ~~~ gpure 0

prop_r1derivV_coordR2 :: Property
prop_r1derivV_coordR2 = r1derivV #> (coordR2 :: Grid Double) ~~~ gpure 2
  where
    coordR2 = gmap (^ 2) coordR

prop_r1derivV_coordR4 :: Property
prop_r1derivV_coordR4 = r1derivV #> (coordR4 :: Grid Double) ~~~ 4 *^ coordR2
  where
    coordR2 = gmap (^ 2) coordR
    coordR4 = gmap (^ 4) coordR


module FFTSpec where

import qualified Clash.Prelude as Clash
import Clash.Prelude (Signal, Vec(..), BitVector, Index, Signed, Unsigned, SFixed, Bit, SNat(..),
                      simulate, simulate_lazy, listToVecTH, KnownNat, pack, unpack, (++#), mealy, mux, bundle, unbundle,
                      HiddenClockResetEnable)
import Test.Hspec
import Test.QuickCheck

import qualified Numeric.FFT as FFT
import qualified Data.Complex as C
import Clash.DSP.Complex (Complex, fromComplex, toComplex)
import Clash.DSP.FFT.Parallel

--FFT
spec = describe "Parallel FFTs" $ do
    specify "Recursive decimation in time equals known good implementation"      $ property prop_fftDITRec
    specify "Recursive decimation in frequency equals known good implementation" $ property prop_fftDIFRec
    specify "Iterative decimation in time equals known good implementation"      $ property prop_fftDITIter
    specify "Iterative decimtaion in frequency equals known good implementation" $ property prop_fftDIFIter

approxEqual :: Double -> Double -> Bool
approxEqual x y = abs (x - y) < 0.0001

approxEqualComplex (a C.:+ b) (c C.:+ d) = approxEqual a c && approxEqual b d

twiddles :: Vec 8 (Complex Double)
twiddles = $(listToVecTH (twiddleFactors 8))

prop_fftDITRec :: Vec 16 (C.Complex Double) -> Bool
prop_fftDITRec vec = and $ zipWith approxEqualComplex (map toComplex (Clash.toList (fftDITRec twiddles (Clash.map fromComplex vec)))) (FFT.fft (Clash.toList vec))

prop_fftDIFRec :: Vec 16 (C.Complex Double) -> Bool
prop_fftDIFRec vec = and $ zipWith approxEqualComplex (map toComplex (Clash.toList (fftDIFRec twiddles (Clash.map fromComplex vec)))) (FFT.fft (Clash.toList vec))

prop_fftDITIter :: Vec 16 (C.Complex Double) -> Bool
prop_fftDITIter vec = and $ zipWith approxEqualComplex (map toComplex (Clash.toList (fftDITIter twiddles (Clash.map fromComplex vec)))) (FFT.fft (Clash.toList vec))

prop_fftDIFIter :: Vec 16 (C.Complex Double) -> Bool
prop_fftDIFIter vec = and $ zipWith approxEqualComplex (map toComplex (Clash.toList (fftDIFIter twiddles (Clash.map fromComplex vec)))) (FFT.fft (Clash.toList vec))


module RankReductionTests
  ( testRankReduction
  ) where

import Data.List (sort)
import HABQTlib.Data
import HABQTlib.Data.Particle
import qualified Numeric.LinearAlgebra as LA
import StateGenTests (arbPropDensityMatrix)
import qualified System.Random.MWC as MWC
import qualified Test.QuickCheck as QC
import Test.QuickCheck
  ( Args(..)
  , Positive(..)
  , Property
  , (.&&.)
  , (===)
  , ioProperty
  , quickCheckWith
  , stdArgs
  )
import TestHelpers

sortSVDprop :: Positive Int -> Positive Int -> Property
sortSVDprop (Positive r) (Positive c) =
  ioProperty $ do
    r1 <- LA.randn r c
    r2 <- LA.randn r c
    let rm = LA.toComplex (r1, r2)
        (u, s) = LA.leftSV rm
        sorted = sort (LA.toList s) == (reverse . LA.toList) s
        normU = (LA.norm_2 . head . LA.toColumns) u
    return $ sorted && abs (normU - 1) < 1e-6

truncateProp' :: Rank -> WeighedDensityMatrix -> Property
truncateProp' rank wdm@(WeighedDensityMatrix (w, _)) =
  let WeighedDensityMatrix (wt, dmt) = truncateRank rank wdm
      preservesWeight = abs (2 * (w - wt) / (w + wt)) <= 1e-12
      (_, s, _) = LA.compactSVD . getDensityMatrix $ dmt
      setsRank = rank === LA.size s
      validDM = arbPropDensityMatrix dmt
   in preservesWeight .&&. setsRank .&&. validDM

truncateProp :: Property
truncateProp =
  let gen = do
        (dim, rank) <- arbDimRank
        wdm <- arbWDM dim rank
        newRank <- QC.suchThat QC.arbitrary (\x -> x > 0 && x <= rank)
        return (newRank, wdm)
   in QC.forAll gen (uncurry truncateProp')

testTruncation :: IO ()
testTruncation = do
  putStrLn "Testing density matrix rank reduction:"
  quickCheckWith stdArgs {maxSuccess = 1000} truncateProp

particleReductionProp :: MWC.GenIO -> Positive Int -> Positive Int -> Property
particleReductionProp gen (Positive dim) (Positive num) =
  ioProperty $ do
    r <- MWC.uniformR (1, dim) gen
    particles <- genParticles dim r num
    let WeighedDensityMatrix (w, dm) = reduceParticlesToMean particles
        dimProp = dim === LA.rows (getDensityMatrix dm)
        rankProp = r === getRank dm
        validProp = arbPropDensityMatrix dm
        weightProp = abs (w - 1) < 1e-12
    return $ dimProp .&&. rankProp .&&. validProp .&&. weightProp

testSVDsort :: IO ()
testSVDsort = do
  putStrLn "Testing singular value sort:"
  quickCheckWith stdArgs {maxSuccess = 1000} sortSVDprop
  putStrLn "Testing particle vector reduction:"
  gen <- MWC.createSystemRandom
  quickCheckWith stdArgs {maxSuccess = 1000} (particleReductionProp gen)

testRankReduction :: IO ()
testRankReduction = do
  testSVDsort
  testTruncation


import Statistics.Distribution
import Statistics.Distribution.Normal
import Statistics.Matrix
import Statistics.MLE
import System.Random.MWC
import Control.Applicative
import Control.Monad
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U

main :: IO ()
main = do
	let n = 1000 :: Int
	let k = 3 :: Int
	let b0 = 0.0
	let b1 = U.fromList $ take k (enumFrom 1.0)
	let ratio b = G.map (\bk -> bk / (b G.! 0)) b

	gen <- create
	e <- fromList n 1 <$> replicateM n (genContinous (normalDistr 0 1) gen)
	x <- fromList n k <$> replicateM (n * k) (genContinous (normalDistr 0 1) gen)
	let y = G.zipWith3 (\x y z -> if x+y+z > 0 then 1.0 else 0.0 :: Double ) (G.replicate n b0) (x `multiplyV` b1) (toVector e)
	putStrLn $ "True values: " ++ show (ratio b1) ++ " Estimated values: " ++ show (ratio (probit x y))


{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Fields (C, Field (..), Fp, Prime (..), Q, R, Val (..), modInv) where

import Data.Complex (Complex (..))
import Data.Ratio (denominator, numerator)

------------------------------------------------------------------------------
-- Fields

-- Value information
data Val = None | NumDen Integer Integer | ReIm Double Double

-- Field type class
class (Eq f, Fractional f, Show f) => Field f where
  {-# MINIMAL char, val #-}
  char :: f -> Integer
  val :: f -> Val

------------------------------------------------------------------------------
-- Characteristic zero

-- Rational numbers Q
newtype Q = Q Rational deriving (Eq, Fractional, Num, Ord)
instance Show Q where
  show q = show n ++ if d == 1 then "" else "/" ++ show d
    where
      NumDen n d = val q
instance Field Q where
  char = const 0
  val (Q q) = NumDen (numerator q) (denominator q)

-- Real numbers R
newtype R = R Double deriving (Eq, Fractional, Num, Ord)
instance Show R where
  show (R r) = if r == fromIntegral r' then show r' else show r
    where
      r' = floor r
instance Field R where
  char = const 0
  val = const None

-- Complex numbers C
newtype C = C (Complex Double) deriving (Eq, Fractional, Num)
instance Show C where
  show (C (r :+ i))
    | signum i == -1 = "(" ++ show (R r) ++ "-" ++ show (R (abs i)) ++ "i)"
    | signum i == 1 = "(" ++ show (R r) ++ "+" ++ show (R i) ++ "i)"
    | otherwise = show (R r)
instance Field C where
  char = const 0
  val (C (r :+ i)) = ReIm r i

------------------------------------------------------------------------------
-- Characteristic prime

-- Prime numbers
class (Enum p, Show p) => Prime p where
  prime :: p -> Integer
  prime _ = read . tail . show $ (toEnum 0 :: p)

-- Prime subfields Fp
newtype Fp p = Fp Integer

-- Fp field instance
instance Prime p => Field (Fp p) where
  char = const $ prime (undefined :: p)
  val = const None

-- Fp standard instances
instance Prime p => Bounded (Fp p) where
  minBound = 0
  maxBound = -1
instance Prime p => Enum (Fp p) where
  toEnum = fromIntegral
  fromEnum (Fp n) = fromInteger n
instance Eq (Fp p) where
  Fp n == Fp n' = fromInteger n == fromInteger n'
instance Prime p => Fractional (Fp p) where
  fromRational n = fromInteger (numerator n) / fromInteger (denominator n)
  recip (Fp n) = case modInv n $ prime (undefined :: p) of
    Right m -> fromIntegral m
    Left m -> error $ show m
instance Prime p => Integral (Fp p) where
  quotRem (Fp n) (Fp n') = (fromInteger q, fromInteger r)
    where
      (q, r) = quotRem n n'
  toInteger (Fp n) = fromInteger n
instance Prime p => Num (Fp p) where
  Fp n + Fp n' = fromInteger $ n + n'
  Fp n * Fp n' = fromInteger $ n * n'
  abs n = n
  signum n = if n == 0 then 0 else 1
  fromInteger n = Fp . mod n $ prime (undefined :: p)
  negate (Fp n) = fromInteger $ (-n)
instance Ord (Fp p) where
  Fp n <= Fp n' = n <= n'
instance Prime p => Real (Fp p) where
  toRational (Fp n) = fromInteger n
instance Show (Fp p) where
  show (Fp n) = show n

-- Extended Euclidean algorithm
extGCD :: Integral a => a -> a -> ((a, a), a)
extGCD 0 y = ((0, 1), y)
extGCD x y = ((t - s * q, s), g)
  where
    (q, r) = quotRem y x
    ((s, t), g) = extGCD r x

-- Modular inverse
modInv :: Integral a => a -> a -> Either a a
modInv x p = if g == 1 then return (mod y p) else Left g
  where
    ((y, _), g) = extGCD x p


module Main where

import Graphics.Rendering.Chart.Easy
import Graphics.Rendering.Chart.Backend.Cairo

import Statistics.Distribution.Normal
import Statistics.Distribution

-- pOak = class1
-- pBeech = class2

stdDevOak :: NormalDistribution
stdDevOak = normalDistr (- 2.25) 1

stdDevBeech :: NormalDistribution
stdDevBeech = normalDistr 1.596 1

type Priori = Double

pOak :: Priori
pOak = 0.25

pBeech :: Priori
pBeech = 0.75

oak :: [Double] -> [(Double,Double)]
oak xs = [ (x,(density stdDevOak x) * pOak) | x <- xs ]

beech :: [Double] -> [(Double, Double)]
beech xs = [ (x,(density stdDevBeech x) * pBeech) | x <- xs ]

identit :: [Double] -> [(Double, Double)]
identit xs = [(x, x) | x <- xs]

increments :: Double -> Double -> Double -> [Double]
increments from to inc
    | from > to = []
    | otherwise = (from):(increments (from + inc) to inc)

--main = print $ (increments (-5) 5 0.1)

main = toFile def "output.png" $ do
    layout_title .= "KMeans"
    setShapes [PointShapeCircle, PointShapePlus, PointShapeStar]
    setColors [opaque blue, opaque red]
    plot (points "class2" $ beech (increments (-5) 5 0.1))
    plot (line "class1" [oak (increments (-5) 5 0.1)])


{-# OPTIONS_GHC -Wall #-}

module Numeric.FFT.HMatrix.Vector (
  -- * Complex-to-complex transforms
  dft
  , idft
    -- * Real-to-complex transforms
  , dftR2C
  , dftC2R
    -- * Real-to-real transforms
    -- ** Discrete cosine transforms
  , dct1
  , dct2
  , dct3
  , dct4
    -- ** Discrete sine transforms
  , dst1
  , dst2
  , dst3
  , dst4
  ) where

import Foreign.Storable ( Storable )
import Numeric.LinearAlgebra.Data ( Vector, Complex )
import Numeric.LinearAlgebra ( Element )
import qualified Numeric.LinearAlgebra.Data as M
import qualified Numeric.FFT.Vector.Unnormalized as FFT

dft :: Vector (Complex Double) -> Vector (Complex Double)
dft = FFT.run FFT.dft

idft :: Vector (Complex Double) -> Vector (Complex Double)
idft = FFT.run FFT.idft

dftR2C :: Vector Double -> Vector (Complex Double)
dftR2C = FFT.run FFT.dftR2C

dftC2R :: Vector (Complex Double) -> Vector Double
dftC2R = FFT.run FFT.dftC2R

dct1 :: Vector Double -> Vector Double
dct1 = FFT.run FFT.dct1

dct2 :: Vector Double -> Vector Double
dct2 = FFT.run FFT.dct2

dct3 :: Vector Double -> Vector Double
dct3 = FFT.run FFT.dct3

dct4 :: Vector Double -> Vector Double
dct4 = FFT.run FFT.dct4

dst1 :: Vector Double -> Vector Double
dst1 = FFT.run FFT.dst1

dst2 :: Vector Double -> Vector Double
dst2 = FFT.run FFT.dst2

dst3 :: Vector Double -> Vector Double
dst3 = FFT.run FFT.dst3

dst4 :: Vector Double -> Vector Double
dst4 = FFT.run FFT.dst4


module FFT.Samples where

import System.Random
import FFT.Normal
import Data.Complex

generate2DSamplesList ::
                     Int           -- random number seed
                  -> Int           -- number of samples to generate
                  -> Float -> Float    -- X and Y mean
                  -> Float -> Float    -- X and Y standard deviations
                  -> [Complex Float]
generate2DSamplesList seed n mx my sdx sdy  = do
  let gen = mkStdGen seed in
    let (genx, geny) = split gen
        xsamples = normals' (mx,sdx) genx
        ysamples = normals' (my,sdy) geny
    in
      zipWith (:+) (take n xsamples) ysamples

-- generating input for FFT or DFT.
mX, mY, sdX, sdY :: Float
mX = 0
mY = 0
sdX = 0.5
sdY = 1.5

-- Produce a number of samples
samples seed n = generate2DSamplesList seed n mX mY sdX sdY

samplesi seed max n =
    let g = mkStdGen seed in
        take n (map (floor . (*) max) (normals g :: [Double]))


-- | authors: Connor Ford, Jake Hauser

module Persistence where

import Data.List (intercalate)
import Numeric.LinearAlgebra
import Data.List.HT (mapAdjacent)
import ExplicitSimplexStream

-- Betti Vector
-- This data type is equivalent to a list of Ints. It represents the betti vector.
-- For a betti vector of length n, all betti numbers b_i such that i >= n are assumed to be 0.
data BettiVector = BettiVector [Int] deriving (Eq)

instance Show BettiVector where
    show (BettiVector []) = "()"
    show (BettiVector vs) = "(" ++ intercalate ", " (map show vs) ++ ")"

-- getBoundaryMapHelper (see: getBoundaryMap)
-- First argument is SimplexListByDegree representing C_k
-- Second argument is SimplexListByDegree representing C_k+1
-- Third argument should initially be the length of the x in (x:xs) for C_k+1. It it a counter for removing elements from x.
-- Fourth argument should initially be zero. It is a counter for the index of x in (x:xs).
-- Fifth argument should be the zero matrix for _correct_ boundary map calculations.
getBoundaryMapHelper :: (Ord a) => SimplexListByDegree a -> SimplexListByDegree a -> Int -> Int -> Matrix Double -> Matrix Double
getBoundaryMapHelper _     (SimplexListByDegree _ [])     _ _ mat = mat
getBoundaryMapHelper list1 (SimplexListByDegree n (_:xs)) 0 k mat = getBoundaryMapHelper list1 (SimplexListByDegree n (xs)) n (k+1) mat
getBoundaryMapHelper list1 (SimplexListByDegree n (x:xs)) m k mat =
    let
        x_dim = indexOfSimplex (Simplex (removeSimplexElement x (m-1))) list1
        y_dim = k
        val = (-1)^(m-1)
        updatedMatrix = accum mat (\a _ -> a) [((x_dim,y_dim), val)] -- use accumulator to change values of matrix
    in
        getBoundaryMapHelper list1 (SimplexListByDegree n (x:xs)) (m-1) k updatedMatrix

-- getBoundaryMap
-- First argument C_k
-- Second argument C_k+1
-- return matrix dimensions: len(C_k) = num rows, len(C_k+1) = num cols
-- algorithm:
-- Given element of C_k+1, y, remove i'th element from y (starting with index zero) to get element in C_k called x.
-- Then the value in the matrix at row idxOf(x) and column idxOf(y) is (-1)^i.
getBoundaryMap :: (Ord a) => SimplexListByDegree a -> SimplexListByDegree a -> Matrix Double
getBoundaryMap list1@(SimplexListByDegree _ simps1) list2@(SimplexListByDegree n simps2) =
    let
        zero_matrix = matrix (length simps2) (replicate ((length simps1)*(length simps2)) 0)
    in
        getBoundaryMapHelper list1 list2 n 0 zero_matrix

-- getHomologyDimension
-- first arg is D_i+1
-- second arg is D_i
-- third argument k (or i in the below illustration)
-- want to find: dim ker D_i - dim im D_i+1
-- algorithm to find ker and im:
-- (i) rref matrix
-- (ii) # of non-zero rows correspond to rnk of original matrix.
-- (iii) # of columns with leading 1’s correspond to the columns of original matrix that span image.
-- (iv) dim ker = (ii) - (iii)
getHomologyDimension :: Matrix Double -> Matrix Double -> Int -> Int
getHomologyDimension m1 m2 k =
    let
        m1_rank = rank m1
        m2_columns = cols m2
        m2_rank = rank m2
        m2_nullity = m2_columns - m2_rank
    in
        if k > 0 then
            m2_nullity - m1_rank
        else
            m2_columns - m1_rank

-- persistenceHelper (see: persistence)
-- First argument is a list of matrices representing a sequence of boundary maps.
-- Second argument is k representing the k'th homology.
persistenceHelper :: [Matrix Double] -> Int -> [Int]
persistenceHelper []       _ = []
persistenceHelper [x]      k = [getHomologyDimension ((ident 1) - (ident 1)) x k] -- base case for last boundary map
persistenceHelper (x:y:xs) k = (getHomologyDimension y x k):(persistenceHelper (y:xs) (k+1))

-- persistence
-- The persistence algorithm computes the BettiVector for s simplex stream. The algorithm is as follows:
-- Given a simplex stream, and a field coefficient p corresponding to Z/pZ we will return betti numbers (b_0, b_1, ..., b_n) where n+1 equals the degree of the highest order simplex in the stream.
-- (1) Get simplex lists ordered by the degree of simplices
-- (2) Get boundary maps D_0, ..., D_{n-1} such that:
-- 0 <-- C_0 <-- C_1 <-- ... <-- C_{n-1} <-- C_n <-- 0
--  D_{-1}   D_0     D_1                D_{n-1}
-- (3) Compute dimensions of the Homologies:
-- dim H_0 = dim Ker 0 - dim Im D_0
-- dim H_1 = dim Ker D_0 - dim Im D_1
-- ...
-- dim H_n = dim Ker D_{n-1} - dim Im 0
-- (4) return betti profile (dim H_0, dim H_1, ..., dim H_n)
-- TODO: implement with rref mod p where Field = Z/pZ.
persistence :: (Ord a) => Stream a -> Int -> BettiVector
persistence stream field =
    let
        (OrderedSimplexList l) = streamToOrderedSimplexList stream
    in
        BettiVector $ persistenceHelper (mapAdjacent getBoundaryMap l) 0


{-|
Module      : ControlSystems.DynamicSystems.Conversion
Description : Converts continuous time systems to discrete time
Copyright   : (c) Ryan Orendorff, 2020
License     : BSD3
Stability   : experimental
-}
module ControlSystems.DynamicSystems.Conversions (
  c2d
)

where

import Numeric.LinearAlgebra

-- | Convert a continuous time linear differential system to a discrete form,
-- using state space models.
c2d :: Double                         -- ^ The sampling time
    -> Matrix Double                  -- ^ The state transition matrix, aka A
    -> Matrix Double                  -- ^ The state input matrix, aka B
    -> (Matrix Double, Matrix Double) -- ^ The discretized A & B system
c2d t a b = (a_d, b_d)
  where
    -- First we have to extract the sizes of all the matrices at run time.
    (m_a, n_a) = (rows a, cols a)
    (_  , n_b) = (rows b, cols b)

    -- Then manually make the correct block. This must be a square matrix
    -- because the matrix exponential function (`expm`) expects to only have
    -- square inputs (given that it is a series expansion of matrix to higher
    -- powers). We need to form this matrix
    -- ⌈ A B ⌉
    -- ⌊ 0 0 ⌋
    block = a ||| b
              ===
              konst 0 (m_a, n_a + n_b) -- I left in a bug here! ;-D

    -- Calculate the discrete time block matrix, which is the following
    -- ⌈ A_d B_d ⌉
    -- ⌊  0   I  ⌋
    exp_block = expm (scale t block)

    -- Finally we can extract the correct submatrices assuming we pull out the
    -- right pieces.
    a_d = subMatrix (0, 0) (m_a, n_a) exp_block
    b_d = subMatrix (0, n_a) (m_a, n_b) exp_block


-- | RVM regression model
module Numeric.BMML.RVMR
    ( fit
    , predict
    ) where

import Numeric.LinearAlgebra.Data (Matrix, Vector)
import qualified Numeric.LinearAlgebra.HMatrix as H

data RVMRModel = RVMRModel
    { mean :: Vector Double
    , covariance :: Matrix Double
    , optbeta :: Double
    }

initAlpha :: Int -> Vector Double
initAlpha m = H.konst 1.0e-3 m

initBeta :: Double
initBeta = 1.0e-3

fit :: Matrix Double -> Vector Double -> RVMRModel
fit x t =
    let (_,d) = H.size x
        alpha = initAlpha d
        beta = initBeta
        sigma = calcSigma alpha beta x
        m = calcMean beta sigma x t
    in go 10000 alpha beta sigma m
  where
    go 0 _ beta sigma m =
        RVMRModel
        { mean = m
        , covariance = sigma
        , optbeta = beta
        }
    go k alpha beta sigma m = if sNorm alpha na < 0.01
                                 then go 0 na nb ns nm
                                else go (k - 1) na nb ns nm
      where
        (n,d) = H.size x
        gamma :: Vector Double
        gamma = (H.konst 1 d) - (alpha * (H.takeDiag sigma))
        na :: Vector Double
        na =
            H.fromList
                (zipWith
                     (\gi mi ->
                           gi / (mi * mi))
                     (H.toList gamma)
                     (H.toList m))
        nb :: Double
        nb = normSq (t - x H.#> m) / (fromIntegral n - H.sumElements gamma)
        ns = calcSigma na nb x
        nm = calcMean nb ns x t

sNorm :: Vector Double -> Vector Double -> Double
sNorm x y =
    sqrt
        (foldr
             (\(xi,yi) res ->
                   res + (yi - xi) * (yi - xi))
             0
             (filter
                  (\(xi,yi) ->
                        xi < 10000 && yi < 10000)
                  (zip (H.toList x) (H.toList y))))
{-# INLINE sNorm #-}

calcSigma :: Vector Double -> Double -> Matrix Double -> Matrix Double
calcSigma a b x = H.inv (H.diag a + b `H.scale` (H.tr x H.<> x))
{-# INLINE calcSigma #-}

calcMean :: Double
         -> Matrix Double
         -> Matrix Double
         -> Vector Double
         -> Vector Double
calcMean b s x t = b `H.scale` ((s H.<> H.tr x) H.#> t)
{-# INLINE calcMean #-}

normSq :: Vector Double -> Double
normSq v = v `H.dot` v
{-# INLINE normSq #-}

predict :: RVMRModel -> Vector Double -> (Double, Double)
predict (RVMRModel m sigma ob) v =
    (m `H.dot` v, 1 / ob + v `H.dot` (sigma H.#> v))


{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
-- |
-- Module    : Statistics.Distribution.Exponential
-- Copyright : (c) 2009 Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- The exponential distribution.  This is the continuous probability
-- distribution of the times between events in a poisson process, in
-- which events occur continuously and independently at a constant
-- average rate.

module Statistics.Distribution.Exponential
    (
      ExponentialDistribution
    -- * Constructors
    , exponential
    , exponentialE
    -- * Accessors
    , edLambda
    ) where

import Control.Applicative
import Data.Aeson                      (FromJSON(..),ToJSON,Value(..),(.:))
import Data.Binary                     (Binary, put, get)
import Data.Data                       (Data, Typeable)
import GHC.Generics                    (Generic)
import Numeric.SpecFunctions           (log1p)
import Numeric.MathFunctions.Constants (m_neg_inf)
import qualified System.Random.MWC.Distributions as MWC
import qualified Data.Vector.Generic as G

import qualified Statistics.Distribution         as D
import qualified Statistics.Sample               as S
import Statistics.Internal

newtype ExponentialDistribution = ED {
      edLambda :: Double
    } deriving (Eq, Typeable, Data, Generic)

instance Show ExponentialDistribution where
  showsPrec n (ED l) = defaultShow1 "exponential" l n
instance Read ExponentialDistribution where
  readPrec = defaultReadPrecM1 "exponential" exponentialE

instance ToJSON ExponentialDistribution
instance FromJSON ExponentialDistribution where
  parseJSON (Object v) = do
    l <- v .: "edLambda"
    maybe (fail $ errMsg l) return $ exponentialE l
  parseJSON _ = empty

instance Binary ExponentialDistribution where
  put = put . edLambda
  get = do
    l <- get
    maybe (fail $ errMsg l) return $ exponentialE l

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

instance D.ContDistr ExponentialDistribution where
    density (ED l) x
      | x < 0     = 0
      | otherwise = l * exp (-l * x)
    logDensity (ED l) x
      | x < 0     = m_neg_inf
      | otherwise = log l + (-l * x)
    quantile      = quantile
    complQuantile = complQuantile

instance D.Mean ExponentialDistribution where
    mean (ED l) = 1 / l

instance D.Variance ExponentialDistribution where
    variance (ED l) = 1 / (l * l)

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

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

instance D.Entropy ExponentialDistribution where
  entropy (ED l) = 1 - log l

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

instance D.ContGen ExponentialDistribution where
  genContVar = MWC.exponential . edLambda

cumulative :: ExponentialDistribution -> Double -> Double
cumulative (ED l) x | x <= 0    = 0
                    | otherwise = 1 - exp (-l * x)

complCumulative :: ExponentialDistribution -> Double -> Double
complCumulative (ED l) x | x <= 0    = 1
                         | otherwise = exp (-l * x)

quantile :: ExponentialDistribution -> Double -> Double
quantile (ED l) p
  | p >= 0 && p <= 1 = - log1p(-p) / l
  | otherwise        =
    error $ "Statistics.Distribution.Exponential.quantile: p must be in [0,1] range. Got: "++show p

complQuantile :: ExponentialDistribution -> Double -> Double
complQuantile (ED l) p
  | p == 0          = 0
  | p >= 0 && p < 1 = -log p / l
  | otherwise       =
    error $ "Statistics.Distribution.Exponential.quantile: p must be in [0,1] range. Got: "++show p

-- | Create an exponential distribution.
exponential :: Double            -- ^ Rate parameter.
            -> ExponentialDistribution
exponential l = maybe (error $ errMsg l) id $ exponentialE l

-- | Create an exponential distribution.
exponentialE :: Double            -- ^ Rate parameter.
             -> Maybe ExponentialDistribution
exponentialE l
  | l > 0     = Just (ED l)
  | otherwise = Nothing

errMsg :: Double -> String
errMsg l = "Statistics.Distribution.Exponential.exponential: scale parameter must be positive. Got " ++ show l

-- | Create exponential distribution from sample. Returns @Nothing@ if
--   sample is empty or contains negative elements. No other tests are
--   made to check whether it truly is exponential.
instance D.FromSample ExponentialDistribution Double where
  fromSample xs
    | G.null xs       = Nothing
    | G.all (>= 0) xs = Nothing
    | otherwise       = Just $! ED (S.mean xs)


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

-}

module MachineLearning.Optimization.GradientDescent
(
  gradientDescent
)

where

import MachineLearning.Types (R, Vector, Matrix)
import MachineLearning.Regularization (Regularization)
import qualified Data.Vector.Storable as V
import qualified Numeric.LinearAlgebra as LA

import qualified MachineLearning.Model as Model

-- | Gradient Descent method implementation. See "MachineLearning.Regression" for usage details.
gradientDescent :: Model.Model a => R-> a -> R -> Int -> Regularization -> Matrix -> Vector -> Vector -> (Vector, Matrix)
gradientDescent alpha model eps maxIters lambda x y theta = helper theta maxIters []
  where gradient = Model.gradient model lambda
        cost = Model.cost model lambda
        helper theta nIters optPath =
          let theta' = theta - (LA.scale alpha (gradient x y theta))
              j = cost x y theta'
              gradientTest = LA.norm_2 (theta' - theta) < eps
              optPathRow = V.concat [LA.vector [(fromIntegral $ maxIters - nIters), j], theta']
              optPath' = optPathRow : optPath
          in if gradientTest || nIters <= 1
             then (theta, LA.fromRows $ reverse optPath')
             else helper theta' (nIters - 1) optPath'


module Main where

import           Isumi.Math.FFT.Bruun

import           Control.DeepSeq            (NFData)
import           Control.Monad.Random.Class
import           Criterion.Main
import           Criterion.Types
import           Data.Complex
import qualified Data.Vector.Unboxed        as UV

main :: IO ()
main = do
  realInputs <- sampleInput
  complexInputs <- sampleInputC
  defaultMainWith config [
      bgroup "real input" [
        bgroup "fftDirect" $
          genBenchs (\xs -> fftDirect $ UV.map (:+0) xs) realInputs
        ,
        bgroup "fftBruun" $
          genBenchs fftBruun realInputs
      ],
      bgroup "complex input" [
        bgroup "fftDirect" $
          genBenchs fftDirect complexInputs
        ,
        bgroup "fftBruun" $
          genBenchs fftBruunC complexInputs
      ]
    ]

config = defaultConfig
  { reportFile = Just "dist/bench_report.html"
  }

genBenchs :: (UV.Unbox a, NFData b)
          => (UV.Vector a -> b) -> [UV.Vector a] -> [Benchmark]
genBenchs f = fmap (\xs -> bench (show . UV.length $ xs) $ nf f xs)

sampleInputC :: MonadRandom m => m [UV.Vector (Complex Double)]
sampleInputC = do
  reals <- sampleInput
  comps <- sampleInput
  pure $ zipWith (UV.zipWith (:+)) reals comps

sampleInput :: MonadRandom m => m [UV.Vector Double]
sampleInput = do
  flip traverse [0..11] $ \e -> do
    xs <- take (2^e) <$> getRandoms
    pure $ UV.fromList xs


module Lib.Practice.P3 where

import Control.Monad
import Numeric.LinearAlgebra

f3 = do
    let gates = [("AND", gAnd), ("NAND", gNand), ("OR", gOr)]
    mapM_ showOutput gates

gAnd = Neuron { weight = vector [0.5, 0.5], bias = -0.7 }
gNand = Neuron { weight = vector [-0.5, -0.5], bias = 0.7 }
gOr = Neuron { weight = vector [0.5, 0.5], bias = -0.2 }

inputs = replicateM 2 [NotFire, Fire]
showOutput (name, gate) = do
    putStrLn $ name ++ "ゲート"
    mapM_ (showOutput' gate) inputs
    putStrLn ""
    where
        showOutput' gate input = do
            let result = input --> gate
            putStrLn $ show input ++ " -> " ++ show result

data Neuron = Neuron {
    weight :: Vector R,
    bias :: R
} deriving Show

data Input = Fire | NotFire deriving Show
input2Int Fire = 1
input2Int NotFire = 0

(-->) = output
output :: [Input] -> Neuron -> Input
output inputs Neuron { weight = w, bias = b } = result
    where inputV    = fromList $ map input2Int inputs
          sum'      = sumElements $ inputV * w
          result'   = b + sum'
          result    = case () of
            _ | result' >= 0    -> Fire
            otherwise           -> NotFire


module HaskellWorks.Playground.Linear where

import Numeric.LinearAlgebra
import Prelude               hiding ((<>))

variance :: Matrix Double -> Matrix Double
variance m = x <> ((m - asRow rdMean) ** 2)
  where (rdMean, _) = meanCov m
        r = rows m
        x = konst (1 / fromIntegral r) (1, r)