module Quadratic_Formula (csqrt, quadratic) where

import Data.Complex

csqrt z@(a :+ b) = let (mag, ph) = polar z in mkPolar (sqrt mag) (ph/2)

quadratic a b c = (
    quad (conjugate a) (conjugate b) (conjugate c) (+),
    quad (conjugate a) (conjugate b) (conjugate c) (-)
    ) where quad a b c op = (-b `op` csqrt ( b^2 - 4 * a * c))/(2 * a)


import Control.Exception (evaluate)
import Data.Complex
import Test.Hspec
import Test.QuickCheck

import CommonFunctions
import JuliaSet

main :: IO ()
main = hspec $ do
  -- test CommonFunctions
  describe "CommonFunctions.f1" $ do
    it "should work with only real numbers" $
      f1 1 2 `shouldBe` 5

    it "should work with complex constant and real variable" $
      f1 (1 :+ 1) 2 `shouldBe` (5 :+ 1)

    it "should work with real constant and complex variable" $
      f1 2 (2 :+ 3) `shouldBe` ((-3) :+ 12)

    it "should work with only complex numbers" $
      f1 (7 :+ 9.25) (3 :+ 2) `shouldBe` (12 :+ 21.25)

    it "should use partial application to create function with constant c" $ do
      let f2 = f1 (16 :+ 4)
      f2 5 `shouldBe` (41 :+ 4)
      f2 5.5 `shouldBe` (46.25 :+ 4)
      f2 6 `shouldBe` (52 :+ 4)

  -- test JuliaSet
  describe "JuliaSet.julia" $ do
    let f = f1 ((-0.4) :+ 0.65)
    it "should produce 1 for z = -1.5 + 1.0i where f = z^2 -0.4 + 0.65i" $
      julia f ((-1.5) :+ (1.0)) 2 1000 `shouldBe` 1
    it "should be > 1 for z = -0.4 + 0.4i where f = z^2 -0.4 + 0.65i" $
      julia f ((-0.4) :+ 0.4) 2 1000 `shouldSatisfy` (> 1)


{-# LANGUAGE OverloadedLists #-}

module Isumi.Math.FFT.PolynomialSpec
  ( spec
  )
where

import           Isumi.Hspec
import           Test.Hspec

import           Data.Complex
import           Isumi.Math.FFT.Internal.Polynomial

spec :: Spec
spec = do
  describe "modPoly" $ do
    it "returns 5 for (x^3 - 2x^2 - 4) `modPoly` (x - 3)" $ do
      let p = PolyVecRep [1, -2, 0, -4] :: Polynomial Double
      let actual = p `modPoly` PolyExpCoefRep [(1, 1), (0, -3)]
      (actual >>= polyToVecRep) `shouldBeAppx` Just [5]
    it "returns 0 for 1 `modPoly` 1" $ do
      let actual = (PolyVecRep [1] :: Polynomial Double)
            `modPoly` PolyExpCoefRep [(0, 1)]
      (actual >>= polyToVecRep) `shouldBeAppx` Just [1]
    it "returns -2+2i for 4x^3+3x^2+2x+1 `modPoly` x+i" $ do
      let p = PolyVecRep [4, 3, 2, 1] :: Polynomial (Complex Double)
          d = PolyExpCoefRep [(1, 1), (0, 0 :+ 1)]
      (p `modPoly` d) `shouldBeAppx` Just (PolyVecRep [(-2) :+ 2])
  describe "polyMultiply'" $
    it "returns (x^3 + x) for x and (x^2 + 1)" $ do
      let expected = [(3, 1), (1, 1)] :: [(Int, Double)]
      let actual = (1, 1) `polyMultiply'` [(2, 1), (0, 1)]
      expected `shouldBeAppx` actual
  describe "factorDivisor" $ do
    it "factors x^2 - 1 into (x - 1)(x + 1)" $
      factorDivisor (BruunDivisorMinus 2) `shouldBeAppx`
        Just (BruunDivisorMinus 1, BruunDivisorPlus 1 (0 :: Double))
    it "factors x + 1 into Nothing" $
      factorDivisor (BruunDivisorComplex (1 :: Complex Double)) `shouldBeAppx`
        Nothing
    it "factors x^4+1.5x^2+1 into (x^2+(sqrt 0.5)x+1)(x^2-(sqrt 0.5)x+1)" $ do
      let c = sqrt 0.5 :: Double
      factorDivisor (BruunDivisorPlus 4 1.5) `shouldBeAppx`
        Just (BruunDivisorPlus 2 c, BruunDivisorPlus 2 (-c))


module Numeric.MixtureModel.Beta ( -- * General data types
                                   Sample
                                 , SampleIdx
                                 , Samples
                                 , ComponentIdx
                                 , Assignments
                                 , Weight
                                 -- * Beta parameters
                                 , BetaParam (..)
                                 , BetaParams
                                 , ComponentParams
                                 , paramFromMoments
                                 , paramToMoments
                                 , paramsFromAssignments
                                 , paramToMode
                                 -- * Beta distribution
                                 , Prob
                                 , betaProb
                                 -- * Gibbs sampling
                                 , estimateWeights
                                 , updateAssignments
                                 , updateAssignments'
                                 -- * Likelihood
                                 , likelihood
                                 -- * Classification
                                 , classify
                                 ) where

import           Data.Function (on)
import qualified Data.Vector as VB
import qualified Data.Vector.Generic as V
import qualified Data.Vector.Unboxed as VU
import qualified Data.Vector.Unboxed.Mutable as MV
import           Control.Monad.ST

import           Numeric.Log hiding (sum)
import           Numeric.SpecFunctions (logBeta)
import           Statistics.Sample (meanVarianceUnb)

import           Data.Random
import           Data.Random.Distribution.Categorical

type Prob = Log Double
type Sample = Double
type SampleIdx = Int
type ComponentIdx = Int
type Weight = Double
data BetaParam = BetaParam { bpAlpha :: !Double -- ^ Alpha
                           , bpBeta  :: !Double -- ^ Beta
                           }
               deriving (Show, Eq, Ord)

-- k refers to number of components
-- N refers to number of samples
type Samples = VU.Vector Sample                         -- length == N
type Assignments = VU.Vector ComponentIdx               -- length == N
type BetaParams = VB.Vector BetaParam                   -- length == K
type ComponentParams = VB.Vector (Weight, BetaParam)    -- length == K

beta :: Double -> Double -> Log Double
beta a b = Exp $ logBeta a b

-- | `betaProb (a,b) x` is the probability of `x` under Beta
-- distribution defined by parameters `a` and `b`
betaProb :: BetaParam -> Sample -> Prob
betaProb (BetaParam a b) x =
    1/beta a b * realToFrac (x**(a-1)) * realToFrac ((1-x)**(b-1))

-- | Beta parameter from sample mean and variance
paramFromMoments :: Double            -- ^ mean
                 -> Double            -- ^ variance
                 -> Maybe BetaParam
paramFromMoments xbar v
  | c < 0      = Nothing
  | otherwise  = Just $ BetaParam (xbar * c) ((1 - xbar) * c)
  where c = xbar * (1 - xbar) / v - 1

-- | Mean and variance of the given beta parameter
paramToMoments :: BetaParam -> (Double, Double)
paramToMoments (BetaParam a b) =
  let mean = a / (a+b)
      var  = a*b / (a+b)^2 / (a+b+1)
  in (mean, var)

-- | The mode of the given beta parameter
paramToMode :: BetaParam -> Double
paramToMode (BetaParam a b) = (a - 1) / (a + b - 2)

-- | Beta parameter from samples
paramFromSamples :: VU.Vector Sample -> BetaParam
paramFromSamples v | V.null v = error "Numeric.MixtureModel.Beta: Can't estimate priors from no samples"
paramFromSamples v =
    case uncurry paramFromMoments $ meanVarianceUnb v of
      Just a  -> a
      Nothing -> error "Numeric.MixtureModel.Beta: Somehow we have a negative variance"

-- | Beta parameter for component given samples and their component assignments
paramFromAssignments :: Samples -> Assignments -> ComponentIdx -> BetaParam
paramFromAssignments samples assignments k =
  paramFromSamples $ V.map snd $ V.filter (\(k',_)->k==k') $ V.zip assignments samples

-- | Beta parameters for all components given samples and their component assignments
paramsFromAssignments :: Samples -> Int -> Assignments -> BetaParams
paramsFromAssignments samples ncomps assignments =
  V.fromList $ map (paramFromAssignments samples assignments) [0..ncomps-1]

-- | Draw a new assignment for a sample given beta parameters
drawAssignment :: ComponentParams -> Sample -> RVar ComponentIdx
drawAssignment params x =
  let probs = map (\(w,p)->realToFrac w * betaProb p x) $ V.toList params
  in case filter (isInfinite . ln . fst) $ zip probs [0..] of
        (x:_)     -> return $ snd x
        otherwise -> categorical
                     $ map (\(p,k)->(realToFrac $ p / sum probs :: Double, k))
                     $ zip probs [0..]

countIndices :: Int -> VU.Vector Int -> VU.Vector Int
countIndices n v = runST $ do
    accum <- V.thaw $ VU.replicate n 0
    V.forM_ v $ \k -> do n' <- MV.read accum k
                         MV.write accum k $! n'+1
    V.freeze accum

-- | Estimate the component weights of a given set of parameters
estimateWeights :: Assignments -> BetaParams -> ComponentParams
estimateWeights assignments params =
  let counts = countIndices (V.length params) assignments
      norm = realToFrac $ V.length assignments
      weights = V.map (\n->realToFrac n / norm) counts
  in V.zip (V.convert weights) params

-- | Sample assignments for samples under given parameters
updateAssignments' :: Samples -> ComponentParams -> RVar Assignments
updateAssignments' samples params =
  V.mapM (drawAssignment params) samples

-- | Gibbs update of sample assignments
updateAssignments :: Samples -> Int -> Assignments -> RVar Assignments
updateAssignments samples ncomps assignments =
  updateAssignments' samples
  $ estimateWeights assignments
  $ paramsFromAssignments samples ncomps assignments

-- | Likelihood of samples assignments under given model parameters
likelihood :: Samples -> ComponentParams -> Assignments -> Prob
likelihood samples params assignments =
    V.product ( V.map (\(k,x)->betaProb (snd $ params V.! k) x)
              $ V.zip assignments samples
              )
  * V.product (V.map (\k->realToFrac $ fst $ params V.! k) assignments)

-- | Maximum likelihood classification
classify :: ComponentParams -> Sample -> ComponentIdx
classify params x =
  fst
  $ V.maximumBy (compare `on` \(_,(w,p))->realToFrac w * betaProb p x)
  $ V.indexed params


{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Main where

import           Control.Applicative     ((<$>))
import           Data.Complex
import           Data.Vector
import           Prelude                 hiding (length, map, maximum, sum,
                                          zipWith, (++))
import           Test.QuickCheck.Monadic
import           Test.Tasty
import           Test.Tasty.QuickCheck   hiding (generate)

import           Numeric.FFT

main :: IO ()
main = defaultMain tests

tests :: TestTree
tests = testGroup "Tests"
        [ testProperty "FFT vs. DFT" prop_dft_vs_fft
        , testProperty "FFT/IFFT round-trip" prop_ifft
        ]

-- Clean up number display.
defuzz :: Vector (Complex Double) -> Vector (Complex Double)
defuzz = map (\(r :+ i) -> df r :+ df i)
  where df x = if abs x < 1.0E-6 then 0 else x

-- Check FFT against DFT.
check :: Vector (Complex Double) -> IO (Double, Vector (Complex Double))
check v = do
  tst <- fft v
  let diff = defuzz $ zipWith (-) tst (basicDFT v)
  return (maximum $ map magnitude diff, diff)

-- QuickCheck property for FFT vs. DFT testing.
prop_dft_vs_fft :: Property
prop_dft_vs_fft = monadicIO $ do
  v <- pick arbitrary
  chk <- run $ check v
  assert $ fst chk < 1.0E-6

-- QuickCheck property for inverse FFT round-trip testing.
prop_ifft :: Property
prop_ifft = monadicIO $ do
  v <- pick arbitrary
  fwd <- run $ fft v
  bwd <- run $ ifft fwd
  let diff = zipWith (-) v bwd
  assert $ maximum (map magnitude diff) < 1.0E-6

-- Non-zero length arbitrary vectors.
instance Arbitrary (Vector (Complex Double)) where
  arbitrary = fromList <$> listOf1 arbitrary

-- Roots of unity.
omega :: Int -> Complex Double
omega n = cis (2 * pi / fromIntegral n)

-- Naïve DFT.
basicDFT :: Vector (Complex Double) -> Vector (Complex Double)
basicDFT h = generate n doone
  where n = length h
        w = omega n
        doone i = sum $ zipWith (*) h $ generate n (\k -> w^^(i*k))


module HaskfemInternal
    ( basisFuncs
    , rhs
    , sysMatFreeFree
    , slope
    , hatFunc
    ) where

import Numeric.LinearAlgebra

import Grid

-- $setup
-- >>> import Test.QuickCheck
-- >>> import Numeric.LinearAlgebra

-- | The part of the right-hand side corresponding to the free dofs
--
-- Takes a real number as constant right-hand side.
rhs :: Grid
    -> R        -- ^ @f@
    -> Vector R
rhs g f = fromList . replicate n $ f * h
  where n = nElements g - 1
        h = elementSize g

-- | The part of the system matrix corresponding to the free dofs
sysMatFreeFree :: Grid
               -> R        -- ^ the constant parameter @c@ of the left-hand side
               -> Matrix R
sysMatFreeFree g c = subMatrix (1, 1) (n-1, n-1) sysMat
  where sysMat = (scalar c) * hinv * (conv2 ((2><2) [1.0, -1.0, -1.0, 1.0]) (ident n))
        n = nElements g
        hinv = scalar $ 1.0 / elementSize g

-- | List of basis functions for fe-space
basisFuncs :: Grid
           -> [R -> R]
basisFuncs g = fmap (hatFunc h)  . toList $ subVector 1 (nElements g - 1) grid
  where grid = linspace (nElements g + 1) (startOfInterval g, endOfInterval g) :: Vector R
        h = elementSize g

-- | Return a linear hat function around @midpoint@ with @run@
--
-- >>> hatFunc 0.1 2.0 1.0
-- 0.0
--
-- >>> hatFunc 0.1 2.0 2.0
-- 1.0
--
-- >>> hatFunc 0.1 2.0 2.1
-- 0.0
hatFunc :: R        -- ^ @run@
        -> R        -- ^ @midpoint@
        -> (R -> R) -- ^ resulting hat function
hatFunc run midpoint x = (slope (midpoint - run) run x) - (slope midpoint run x)

-- | Return a linear slope from 0.0 to 1.0 on the length of @run@ with left point @start@
--
-- ____/----
--
-- prop> slope (start :: R) (run :: R) start == 0.0
-- /prop> slope (start :: R) (run :: R) (start + run / 2.0) > 0.0
-- /prop> slope (start :: R) (run :: R) (start + run / 2.0) < 1.0
-- prop> slope (start :: R) (run :: R) (start + run) == 1.0
slope :: R        -- ^ @start@
      -> R        -- ^ @run@
      -> (R -> R) -- ^ resulting slope function
slope start run x
  | x <= start = 0.0
  | x >= start + run = 1.0
  | otherwise  = (x - start) * 1.0 / run


import Data.Complex

import Lib

func c z = z^2 + c

diverge maxIters f x0 = (any (\x -> magnitude x > 4) . take maxIters) (iterate f x0)

points = [a :+ b | a <- [-2.5,-2.495..1], b <- [-1,-0.995..1]]

mset = filter (\x -> not (diverge 1000 (func x) 0)) points

main = plotPoints' "mandelbrot.svg" "Mandelbrot Set" 1.4 (map c2t mset)


module Main where
import Layer
import Models
import Numeric.LinearAlgebra
import ImageProcess
import Optimization
import Trainer
import Data.Vector.Storable (Vector, length, toList)

main :: IO()
main =
  do
    let inputLayer = linearLayerInit 2 2
    let sigmoidLayer = sigmoidLayerInit 2 2
    let outputLayer = linearLayerInit 2 1 in
      let model = Model [inputLayer, sigmoidLayer, outputLayer] in
      let input = (1><2)[1.0, 2.0]::Matrix R in
      let output = forward input model in
      print output

testImageRegression :: FilePath -> IO()
testImageRegression filepath = do
  imageM <- getImageInfo filepath
  case imageM of
    Nothing -> putStrLn "Nohthing ! Guess what happened ? :) " >> return ()
    Just imagePixel8 ->
      let rgbs = getImageRGBs imagePixel8
          w = getImageWidth imagePixel8
          h =  getImageHeight imagePixel8
          rgbsList = Data.Vector.Storable.toList rgbs
          (rlist, glist, blist) = genRGBList rgbsList
          Just rMat = genMatrixFromList rlist w h
          Just gMat = genMatrixFromList glist w h
          Just bMat = genMatrixFromList blist w h in
          --- test
          print "prepare the model!" >>
          let rinputLayer = linearLayerInit w h
              rreluLayer1 = reluLayerInit w h
              rreluLayer2 = reluLayerInit w h
              rreluLayer3 = reluLayerInit w h
              routputLayer=  linearLayerInit w h
              rmodel = Model [rinputLayer, rreluLayer1, rreluLayer2, rreluLayer3, routputLayer]
              ginputLayer = linearLayerInit w h
              greluLayer1 = reluLayerInit w h
              greluLayer2 = reluLayerInit w h
              greluLayer3 = reluLayerInit w h
              goutputLayer=  linearLayerInit w h
              gmodel = Model [ginputLayer, greluLayer1, greluLayer2, greluLayer3, goutputLayer]
              binputLayer = linearLayerInit w h
              breluLayer1 = reluLayerInit w h
              breluLayer2 = reluLayerInit w h
              breluLayer3 = reluLayerInit w h
              boutputLayer=  linearLayerInit w h
              bmodel = Model [binputLayer, breluLayer1, breluLayer2, breluLayer3, boutputLayer] in
              print "begin to train the model" >>
              let trainConfig = TrainConfig {
                    trainConfigRowNum=w,
                    trainConfigColNum=h,
                    trainConfigLearningRate=0.95,
                    trainConfigMomentum=1.0,
                    trainConfigDecay=0.95,
                    trainConfigEpsilon=0.00001,
                    trainConfigBatchSize=100,
                    trainConfigOptimization="adadelta"
                    } in
              trainSingleData rmodel trainConfig rMat


import Statistics.Distribution.Uniform
import Statistics.Distribution

ud :: UniformDistribution
ud = uniformDistr 0.0 30.0

main = do
  putStrLn $ "the probability that the customer arrived within the very last 5 min:"
          ++ show (cumulative ud 30 - cumulative ud 25)
  putStrLn $ "this is 1/6: " ++ show (1/6)


{-# LANGUAGE ViewPatterns #-}
-- | Tests for Statistics.Math
module Tests.SpecFunctions (
  tests
  ) where

import qualified Data.Vector as V
import           Data.Vector   ((!))

import Test.QuickCheck  hiding (choose)
import Test.Framework
import Test.Framework.Providers.QuickCheck2

import Tests.Helpers
import Tests.SpecFunctions.Tables
import Numeric.SpecFunctions

tests :: Test
tests = testGroup "Special functions"
  [ testProperty "Gamma(x+1) = x*Gamma(x) [logGamma]"  $ gammaReccurence logGamma  3e-8
  , testProperty "Gamma(x+1) = x*Gamma(x) [logGammaL]" $ gammaReccurence logGammaL 2e-13
  , testProperty "gamma(1,x) = 1 - exp(-x)"      $ incompleteGammaAt1Check
  , testProperty "0 <= gamma <= 1"               $ incompleteGammaInRange
  , testProperty "gamma - increases"             $
      \s x y -> s > 0 && x > 0 && y > 0 ==> monotonicallyIncreases (incompleteGamma s) x y
  , testProperty "invIncompleteGamma = gamma^-1" $ invIGammaIsInverse
  , testProperty "0 <= I[B] <= 1"            $ incompleteBetaInRange
  , testProperty "invIncompleteBeta  = B^-1" $ invIBetaIsInverse
  , testProperty "invErfc = erfc^-1"         $ invErfcIsInverse
  , testProperty "invErf  = erf^-1"          $ invErfIsInverse
    -- Unit tests
  , testAssertion "Factorial is expected to be precise at 1e-15 level"
      $ and [ eq 1e-15 (factorial (fromIntegral n))
                       (fromIntegral (factorial' n))
            |n <- [0..170]]
  , testAssertion "Log factorial is expected to be precise at 1e-15 level"
      $ and [ eq 1e-15 (logFactorial (fromIntegral n))
                       (log $ fromIntegral $ factorial' n)
            | n <- [2..170]]
  , testAssertion "logGamma is expected to be precise at 1e-9 level [integer points]"
      $ and [ eq 1e-9 (logGamma (fromIntegral n))
                      (logFactorial (n-1))
            | n <- [3..10000]]
  , testAssertion "logGamma is expected to be precise at 1e-9 level [fractional points]"
      $ and [ eq 1e-9 (logGamma x) lg | (x,lg) <- tableLogGamma ]
  , testAssertion "logGammaL is expected to be precise at 1e-15 level"
      $ and [ eq 1e-15 (logGammaL (fromIntegral n))
                       (logFactorial (n-1))
            | n <- [3..10000]]
    -- FIXME: Too low!
  , testAssertion "logGammaL is expected to be precise at 1e-10 level [fractional points]"
      $ and [ eq 1e-10 (logGammaL x) lg | (x,lg) <- tableLogGamma ]
    -- FIXME: loss of precision when logBeta p q ≈ 0.
    --        Relative error doesn't work properly in this case.
  , testAssertion "logBeta is expected to be precise at 1e-6 level"
      $ and [ eq 1e-6 (logBeta p q)
                      (logGammaL p + logGammaL q - logGammaL (p+q))
            | p <- [0.1,0.2 .. 0.9] ++ [2 .. 20]
            , q <- [0.1,0.2 .. 0.9] ++ [2 .. 20]
            ]
  , testAssertion "digamma is expected to be precise at 1e-14 [integers]"
      $ digammaTestIntegers 1e-14
    -- Relative precision is lost when digamma(x) ≈ 0
  , testAssertion "digamma is expected to be precise at 1e-12"
      $ and [ eq 1e-12 r (digamma x) | (x,r) <- tableDigamma ]
    -- FIXME: Why 1e-8? Is it due to poor precision of logBeta?
  , testAssertion "incompleteBeta is expected to be precise at 1e-8 level"
      $ and [ eq 1e-8 (incompleteBeta p q x) ib | (p,q,x,ib) <- tableIncompleteBeta ]
  , testAssertion "incompleteBeta with p > 3000 and q > 3000"
      $ and [ eq 1e-11 (incompleteBeta p q x) ib | (x,p,q,ib) <-
                 [ (0.495,  3001,  3001, 0.2192546757957825068677527085659175689142653854877723)
                 , (0.501,  3001,  3001, 0.5615652382981522803424365187631195161665429270531389)
                 , (0.531,  3500,  3200, 0.9209758089734407825580172472327758548870610822321278)
                 , (0.501, 13500, 13200, 0.0656209987264794057358373443387716674955276089622780)
                 ]
            ]
  , testAssertion "choose is expected to precise at 1e-12 level"
      $ and [ eq 1e-12 (choose (fromIntegral n) (fromIntegral k)) (fromIntegral $ choose' n k)
            | n <- [0..300], k <- [0..n]]
    ----------------------------------------------------------------
    -- Self tests
  , testProperty "Self-test: 0 <= range01 <= 1" $ \x -> let f = range01 x in f <= 1 && f >= 0
  ]

----------------------------------------------------------------
-- QC tests
----------------------------------------------------------------

-- Γ(x+1) = x·Γ(x)
gammaReccurence :: (Double -> Double) -> Double -> Double -> Property
gammaReccurence logG ε x =
  (x > 0 && x < 100)  ==>  (abs (g2 - g1 - log x) < ε)
    where
      g1 = logG x
      g2 = logG (x+1)

-- γ(s,x) is in [0,1] range
incompleteGammaInRange :: Double -> Double -> Property
incompleteGammaInRange (abs -> s) (abs -> x) =
  x >= 0 && s > 0  ==> let i = incompleteGamma s x in i >= 0 && i <= 1

-- γ(1,x) = 1 - exp(-x)
-- Since Γ(1) = 1 normalization doesn't make any difference
incompleteGammaAt1Check :: Double -> Property
incompleteGammaAt1Check (abs -> x) =
  x > 0 ==> (incompleteGamma 1 x + exp(-x)) ≈ 1
  where
    (≈) = eq 1e-13

-- invIncompleteGamma is inverse of incompleteGamma
invIGammaIsInverse :: Double -> Double -> Property
invIGammaIsInverse (abs -> a) (range01 -> p) =
  a > 0 && p > 0 && p < 1  ==> ( printTestCase ("a  = " ++ show a )
                               $ printTestCase ("p  = " ++ show p )
                               $ printTestCase ("x  = " ++ show x )
                               $ printTestCase ("p' = " ++ show p')
                               $ printTestCase ("Δp = " ++ show (p - p'))
                               $ abs (p - p') <= 1e-12
                               )
  where
    x  = invIncompleteGamma a p
    p' = incompleteGamma    a x

-- invErfc is inverse of erfc
invErfcIsInverse :: Double -> Property
invErfcIsInverse ((*2) . range01 -> p)
  = printTestCase ("p  = " ++ show p )
  $ printTestCase ("x  = " ++ show x )
  $ printTestCase ("p' = " ++ show p')
  $ abs (p - p') <= 1e-14
  where
    x  = invErfc p
    p' = erfc x

-- invErf is inverse of erf
invErfIsInverse :: Double -> Property
invErfIsInverse a
  = printTestCase ("p  = " ++ show p )
  $ printTestCase ("x  = " ++ show x )
  $ printTestCase ("p' = " ++ show p')
  $ abs (p - p') <= 1e-14
  where
    x  = invErf p
    p' = erf x
    p  | a < 0     = - range01 a
       | otherwise =   range01 a

-- B(s,x) is in [0,1] range
incompleteBetaInRange :: Double -> Double -> Double -> Property
incompleteBetaInRange (abs -> p) (abs -> q) (range01 -> x) =
  p > 0 && q > 0  ==> let i = incompleteBeta p q x in i >= 0 && i <= 1

-- invIncompleteBeta is inverse of incompleteBeta
invIBetaIsInverse :: Double -> Double -> Double -> Property
invIBetaIsInverse (abs -> p) (abs -> q) (abs . snd . properFraction -> x) =
  p > 0 && q > 0  ==> ( printTestCase ("p   = " ++ show p )
                      $ printTestCase ("q   = " ++ show q )
                      $ printTestCase ("x   = " ++ show x )
                      $ printTestCase ("x'  = " ++ show x')
                      $ printTestCase ("a   = " ++ show a)
                      $ printTestCase ("err = " ++ (show $ abs $ (x - x') / x))
                      $ abs (x - x') <= 1e-12
                      )
  where
    x' = incompleteBeta    p q a
    a  = invIncompleteBeta p q x

-- Table for digamma function:
--
-- Uses equality ψ(n) = H_{n-1} - γ where
--   H_{n} = Σ 1/k, k = [1 .. n]     - harmonic number
--   γ     = 0.57721566490153286060  - Euler-Mascheroni number
digammaTestIntegers :: Double -> Bool
digammaTestIntegers eps
  = all (uncurry $ eq eps) $ take 3000 digammaInt
  where
    ok approx exact = approx
    -- Harmonic numbers starting from 0
    harmN = scanl (\a n -> a + 1/n) 0 [1::Rational .. ]
    gam   = 0.57721566490153286060
    -- Digamma values
    digammaInt = zipWith (\i h -> (digamma i, realToFrac h - gam)) [1..] harmN

----------------------------------------------------------------
-- Unit tests
----------------------------------------------------------------

-- Lookup table for fact factorial calculation. It has fixed size
-- which is bad but it's OK for this particular case
factorial_table :: V.Vector Integer
factorial_table = V.generate 2000 (\n -> product [1..fromIntegral n])

-- Exact implementation of factorial
factorial' :: Integer -> Integer
factorial' n = factorial_table ! fromIntegral n

-- Exact albeit slow implementation of choose
choose' :: Integer -> Integer -> Integer
choose' n k = factorial' n `div` (factorial' k * factorial' (n-k))

-- Truncate double to [0,1]
range01 :: Double -> Double
range01 = abs . snd . properFraction


{-# LANGUAGE FlexibleContexts #-}

-- |
-- Module    : Statistics.Sample.Normalize
-- Copyright : (c) 2017 Gregory W. Schwartz
-- License   : BSD3
--
-- Maintainer  : gsch@mail.med.upenn.edu
-- Stability   : experimental
-- Portability : portable
--
-- Functions for normalizing samples.

module Statistics.Sample.Normalize
    (
      standardize
    ) where

import Statistics.Sample
import qualified Data.Vector.Generic  as G
import qualified Data.Vector          as V
import qualified Data.Vector.Unboxed  as U
import qualified Data.Vector.Storable as S

-- | /O(n)/ Normalize a sample using standard scores:
--
--   \[ z = \frac{x - \mu}{\sigma} \]
--
--   Where μ is sample mean and σ is standard deviation computed from
--   unbiased variance estimation. If sample to small to compute σ or
--   it's equal to 0 @Nothing@ is returned.
standardize :: (G.Vector v Double) => v Double -> Maybe (v Double)
standardize xs
  | G.length xs < 2 = Nothing
  | sigma == 0      = Nothing
  | otherwise       = Just $ G.map (\x -> (x - mu) / sigma) xs
  where
    mu    = mean   xs
    sigma = stdDev xs
{-# INLINABLE  standardize #-}
{-# SPECIALIZE standardize :: V.Vector Double -> Maybe (V.Vector Double) #-}
{-# SPECIALIZE standardize :: U.Vector Double -> Maybe (U.Vector Double) #-}
{-# SPECIALIZE standardize :: S.Vector Double -> Maybe (S.Vector Double) #-}


-----------------------------------------------------------------------------
-- |
-- Module      :  Numeric.Statistics.PCA
-- Copyright   :  (c) A. V. H. McPhail 2010, 2014, 2017
-- License     :  BSD3
--
-- Maintainer  :  haskell.vivian.mcphail <at> gmail <dot> com
-- Stability   :  provisional
-- Portability :  portable
--
-- Principal Components Analysis
--
-----------------------------------------------------------------------------

module Numeric.Statistics.PCA (
                               pca, pcaN, pcaTransform, pcaReduce, pcaReduceN
                          ) where

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

import qualified Data.Array.IArray as I

import Prelude hiding ((<>))
import Data.List(sortBy)
import Data.Ord(comparing)
import Numeric.LinearAlgebra
import Numeric.GSL.Statistics

--import Numeric.Statistics

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

-- | find the principal components of multidimensional data greater than
--    the threshhold
pca :: I.Array Int (Vector Double)     -- the data
    -> Double                         -- eigenvalue threshold
    -> (Vector Double, Matrix Double) -- Eignevalues, Principal components
pca d q = let d' = fmap (\x -> x - (scalar $ mean x)) d -- remove the mean from each dimension
              d'' = fromColumns $ I.elems d'
              (_,vec',uni') = svd d''
              vec = toList vec'
              uni = toColumns uni'
              v' = zip vec uni
              v = filter (\(x,_) -> x > q) v'  -- keep only eigens > than parameter
              (eigs,vs) = unzip v
          in (fromList eigs,fromColumns vs)

-- | find N greatest principal components of multidimensional data
--    according to size of the eigenvalue
pcaN :: I.Array Int (Vector Double)    -- the data
     -> Int                            -- number of components to return
     -> (Vector Double, Matrix Double) -- Eignevalues, Principal components
pcaN d n = let d' = fmap (\x -> x - (scalar $ mean x)) d -- remove the mean from each dimension
               d'' = fromColumns $ I.elems d'
               (_,vec',uni') = svd d''
               vec = toList vec'
               uni = toColumns uni'
               v' = zip vec uni
               v = take n $ reverse $ sortBy (comparing fst) v'
               (eigs,vs) = unzip v
           in (fromList eigs,fromColumns vs)

v1 = fromList [1,2,3,4,5,6::Double]
v2 = fromList [2,3,4,5,6,7::Double]
v3 = fromList [3,4,5,6,7,8::Double]

a = fromColumns [v1,v2,v3]
b = I.listArray (1,3::Int) [v1,v2,v3] :: I.Array Int (Vector Double)

-- | perform a PCA transform of the original data (remove mean)
-- |     Final = M^T Data^T
pcaTransform :: I.Array Int (Vector Double)    -- ^ the data
             -> Matrix Double                  -- ^ the principal components
             -> I.Array Int (Vector Double)    -- ^ the transformed data
pcaTransform d m = let d' = fmap (\x -> x - (scalar $ mean x)) d -- remove the mean from each dimension
                   in I.listArray (1,cols m) $ toRows $ (tr' m) <> (fromRows $ I.elems d')

-- | perform a dimension-reducing PCA modification,
--     using an eigenvalue threshhold
pcaReduce :: I.Array Int (Vector Double)      -- ^ the data
          -> Double                           -- ^ eigenvalue threshold
          -> I.Array Int (Vector Double)      -- ^ the reduced data
pcaReduce d q = let u = fmap (scalar . mean) d
                    d' = zipWith (-) (I.elems d) (I.elems u)
                    d'' = fromColumns d'
                    (_,vec',uni') = svd d''
                    vec = toList vec'
                    uni = toColumns uni'
                    v' = zip vec uni
                    v = filter (\(x,_) -> x > q) v'  -- keep only eigens > than parameter
                    m = fromColumns $ snd $ unzip v
                 in I.listArray (I.bounds d) $ zipWith (+) (toRows $ m <> (tr' m) <> fromRows d') (I.elems u)

-- | perform a dimension-reducing PCA modification, using N components
pcaReduceN :: I.Array Int (Vector Double)      -- ^ the data
           -> Int                              -- ^ N, the number of components
           -> I.Array Int (Vector Double)      -- ^ the reduced data, with n principal components
pcaReduceN d n = let u = fmap (scalar . mean) d
                     d' = zipWith (-) (I.elems d) (I.elems u)
                     d'' = fromColumns d'
                     (_,vec',uni') = svd d''
                     vec = toList vec'
                     uni = toColumns uni'
                     v' = zip vec uni
                     v = take n $ reverse $ sortBy (comparing fst) v'
                     m = fromColumns $ snd $ unzip v
                  in I.listArray (I.bounds d) $ zipWith (+) (toRows $ m <> (tr' m) <> fromRows d') (I.elems u)

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


import Data.Complex
import System.Environment
import System.Process

import Lib

func c z = z^2 + c

phi = (1 + sqrt 5) / 2

main = do
    args <- getArgs

    let real:imag:_ = if null args then [1 - phi, 0] else read <$> args

        points = (:+) <$> [-1.5,-1.495..1.5] <*>  [-1.2,-1.195..1.2]
        jset = c2t <$> filter (not . diverges 50 (func (real :+ imag))) points

        fileName = "julia" ++ show real ++ "-" ++ show imag ++ ".svg"
        title = "Julia Set for z^2 + " ++ show real ++ " + " ++ show imag ++ "i"

    plotPoints fileName title 1.7 jset
    callCommand $ "inkview " ++ fileName


{-
 - Module containing a few functions about rendering the fractals.
-}
module Rendering where

import Data.Complex
import Data.List

-- RENDERING ----
escape :: (RealFloat a, Fractional a) => [Complex a] -- list of samples
    -> (a -> a) -- Intensity mapping function
    -> a -- pixel brightness
escape samples mapFunc = sum $ zipWith (\x y -> mapFunc (magnitude (y - x)))
     samples (tail samples)

follow :: (RealFloat a, Fractional a) => [Complex a] -- list of samples
    -> (Complex a -> a) -- itensity function
    -> a
follow [] func = 0
follow samples func = func $ last samples

smooth :: (RealFloat a, Fractional a) => [Complex a]
    -> a
smooth samples = foldl' (+) 0 (map (exp . ((-1)*) . magnitude) samples)

-- to get all values from iterating Julia
sample :: (RealFloat a, Fractional a) => Int  -- nbSamples
    -> (Complex a -> Bool) -- stopping condition
    -> (Complex a -> Complex a) -- how to get next point in serie
    -> Complex a -- starting point of serie (z0)
    -> [Complex a] -- list of samples
sample nbsamples isValid funct start = ((takeWhile isValid).(take nbsamples).(iterate (funct))) start

sampleIFS :: (RealFloat a, Fractional a) => Int -- nbSamples
    -> (Complex a -> Bool) -- stop condition
    -> [(Complex a -> Complex a)] -- list of functions to apply
    -> Complex a -- starting point
    -> [Complex a]
sampleIFS nbSamples isValid functions start = (takeWhile isValid).(take nbSamples).
    (iterateList functions) $ start

iterateList :: [(a -> a)] -> a -> [a]
iterateList functions x = x : iterateList fs (f x)
    where (f:fs) = cycle functions


-- vectorized boolean operations defined in terms of step or cond

import Numeric.LinearAlgebra

infix  4  .==., ./=., .<., .<=., .>=., .>.
infixr 3  .&&.
infixr 2  .||.

a .<.  b = step (b-a)
a .<=. b = cond a b 1 1 0
a .==. b = cond a b 0 1 0
a ./=. b = cond a b 1 0 1
a .>=. b = cond a b 0 1 1
a .>.  b = step (a-b)

a .&&. b  = step (a*b)
a .||. b  = step (a+b)
no a      = 1-a
xor a b   = a ./=. b
equiv a b = a .==. b
imp a b   = no a .||. b

taut x = minElement x == 1

minEvery a b = cond a b a a b
maxEvery a b = cond a b b b a

-- examples

clip a b x = cond y b y y b where y = cond x a a x x

disp = putStr . dispf 3

eye n = ident n :: Matrix Double
row = asRow . fromList    :: [Double] -> Matrix Double
col = asColumn . fromList :: [Double] -> Matrix Double

m = (3><4) [1..] :: Matrix Double

p = row [0,0,1,1]
q = row [0,1,0,1]

main = do
    print $ find (>6) m
    disp $ assoc (6,8) 7 $ zip (find (/=0) (eye 5)) [10..]
    disp $ accum (eye 5) (+) [((0,2),3), ((3,1),7), ((1,1),1)]
    disp $ m .>=. 10  .||.  m .<. 4
    (disp . fromColumns . map flatten) [p, q, p.&&.q, p .||.q, p `xor` q, p `equiv` q, p `imp` q]
    print $ taut $ (p `imp` q ) `equiv` (no q `imp` no p)
    print $ taut $ (xor p q) `equiv` (p .&&. no q .||. no p .&&. q)
    disp $ clip 3 8 m
    disp $ col [1..7] .<=. row [1..5]
    disp $ cond (col [1..3]) (row [1..4]) m 50 (3*m)


-- example 3.22

import Statistics.Distribution
import Statistics.Distribution.Poisson

-- three accidents per month means six accidents per two-months:
pd :: PoissonDistribution
pd = poisson 6.0

p :: Int -> Double
p = probability pd

main = do
  putStrLn $ "the mean =   " ++ show (mean pd)
  putStrLn $ "the stdDev = " ++ show (stdDev pd)
  putStrLn $ "the probability of ten accidents in two months: " ++ show (p 10)


{-# LANGUAGE NamedFieldPuns #-}

module School.Unit.Affine
( affine ) where

import Numeric.LinearAlgebra ((<>), R, add, tr')
import School.Unit.Unit (Unit(..))
import School.Unit.UnitActivation (UnitActivation(..))
import School.Unit.UnitParams (UnitParams(..))
import School.Unit.UnitGradient (UnitGradient(..))
import School.Utils.LinearAlgebra (mapRows, sumRows)

affine :: Unit Double
affine = Unit
  { apply = affineApply
  , deriv = affineDeriv
  }

affineApply :: UnitParams R
            -> UnitActivation R
            -> UnitActivation R
affineApply AffineParams { affineBias, affineWeights }
            (BatchActivation inMatrix) =
  BatchActivation $ mapRows (add affineBias) (inMatrix <> tr' affineWeights)
affineApply _ (ApplyFail msg) = ApplyFail msg
affineApply _ _ = ApplyFail "Failure when applying affine unit"

failure :: String
        -> ( UnitGradient R
           , UnitParams R
           )
failure msg = (GradientFail msg, EmptyParams)

affineDeriv :: UnitParams R
            -> UnitGradient R
            -> UnitActivation R
            -> ( UnitGradient R
               , UnitParams R
               )
affineDeriv AffineParams { affineWeights }
            (BatchGradient inGrad)
            (BatchActivation input) =
  (outGrad, paramDerivs) where
    outGrad = BatchGradient $ inGrad <> affineWeights
    bias = sumRows inGrad
    weights = tr' inGrad <> input
    paramDerivs = AffineParams { affineBias = bias
                               , affineWeights = weights
                               }
affineDeriv _ (GradientFail msg) _ = failure msg
affineDeriv _ _ (ApplyFail msg) = failure msg
affineDeriv _ _ _ = failure "Failure when differentiating affine unit"


{- |

This module defines the monad of sampling functions. See

Park, Pfenning and Thrun (2005) 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)
@

-}

{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}

module Math.Probably.Sampler where

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

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

-- | given a seed, return an infinite list of draws from sampling function
runProbOne :: Seed -> Prob a -> (a,Seed)
runProbOne pmt (Sampler sf)
   = sf pmt
runProbOne pmt (Samples xs) = primOneOf xs pmt

-- | 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
runProbIO :: Prob a -> IO [a]
runProbIO s =
   fmap (`runProb` s) $ getSeedIO

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

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

-- | Estimate the probability that a hypothesis is true (in the IO monad)
eval :: Prob Bool -> Prob 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 :: Prob a -> Prob b -> Prob (a,b)
joint sf1 sf2 = liftM2 (,) sf1 sf2

-- | The joint distribution of two distributions where one depends on the other
jointConditional :: Prob a -> (a-> Prob b) -> Prob (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)
unit :: Prob Double
unit = Sampler randomDouble

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

-- | useful for data display
jitter :: Double -> [Int] -> Prob [Double]
jitter j = mapM $ \i-> let x = realToFrac i in uniform (x-j) (x+j)

-- * Normally distributed sampling function

--http://en.wikipedia.org/wiki/Box-Muller_transform
-- | The univariate gaussian (normal) distribution defined by mean and standard deviation

unormal ::  Prob Double
unormal = do
   u1 <- unit
   u2 <- unit
   return (sqrt ((0.0-2.0) * log u1) * cos(2.0 * pi * u2))

normal :: Double -> Double -> Prob Double
normal mean variance = do
   u <- unormal
   return (u * (sqrt variance) + mean)

normalMany :: [(Double,Double)] -> Prob [Double]
normalMany means_vars = do gus <- normalManyUnit (length means_vars)
                           return $ map f $ zip gus means_vars
    where f (gu, (mean, var)) = gu*(sqrt var)+mean

normalManyUnit :: Int -> Prob [Double]
normalManyUnit 0 = return []
normalManyUnit n | odd n = liftM2 (:) unormal (normalManyUnit (n-1))
                 | otherwise = do us <- forM [1..n] $ const $ unit
                                  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 _ = []

-- | Multivariate normal distribution
multiNormal :: Vector Double -> Matrix Double -> Prob (Vector Double)
multiNormal mu sigma =
  let c =   cholSH sigma
      a = trans c
      k = dim mu
  in do z <- fromList `fmap` normalManyUnit 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 -> Prob (Vector Double)
multiNormalByChol mu cholSigma =
  let a = trans $ cholSigma
      k = dim mu
  in do z <- fromList `fmap` normalManyUnit 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 -> Prob (Vector Double)
multiNormalIndep vars mus = do
   let k = dim mus
   gs <- normalManyUnit 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 :: Double -> Double -> Prob Double
logNormal m var =
    fmap exp $  normal m var

-- * Other distribution

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

discrete :: [(Double,a)] -> Prob 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 <- unit
         case find ((>=u*sumWeights) . fst) cummWeightedSamples of
           Just (_,x) -> return x
           Nothing -> error $ "discrete error u*sumweigts="++show (u*sumWeights)++"wsams="++show (map 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)

shuffle :: [a] -> Prob [a]
shuffle xs = do
  uxs <- forM xs $ \x -> do
    u <- unit
    return (u,x)
  return $ map snd $ sortBy (comparing fst) uxs

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

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

--sampling without replacement. Terrible performance
nDistinctOf :: Int ->  [a] -> Prob [a]
nDistinctOf wantN xs = do
  let haveN = length xs
      select ys | length ys == wantN = return ys
                | otherwise = do
                    y <- floor `fmap` uniform (0::Double) (realToFrac $ length xs )
                    if y `elem` ys
                       then select ys
                       else select (y:ys)
  ixs <- select []
  return $ map (xs!!) ixs

withoutReplacementFrom :: Eq a => Int -> Prob a -> Prob [a]
withoutReplacementFrom wantN p = select [] where
  select ys | length ys == wantN = return ys
            | otherwise = do
                y <- p
                if y `elem` ys
                  then select ys
                  else select (y:ys)

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

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

poissonAux :: Double -> Int -> Double -> Prob Int
poissonAux bigl k p = if p>bigl
                         then do
                           u<- unit
                           poissonAux bigl (k+1) (p*u)
                         else return (k-1)

poisson :: Double -> (Prob Int)
poisson lam =  poissonAux (exp (-lam)) 0 1

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

-- from random-fu
-- | Gamma distribution
gamma :: Double -> Double -> Prob Double
gamma a b
     | a < 1
    = do
        u <- unit
        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 <- unormal

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

                        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 -> Prob Double
invGamma a b = recip `fmap` gamma a b

-- | beta distribution
beta :: Int -> Int -> Prob Double
beta a b =
    let gam n = do us <- forM [1..n] $ const unit
                   return $ log $ product us
    in do gama1 <- gamma (realToFrac a) 1

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


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

{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators       #-}

module Grenade.Utils.LinearAlgebra
    ( bmean
    , bvar
    , bvar'
    , vsqrt
    , msqrt
    , sreshape
    , sflatten
    , vscale
    , vadd
    , vflatten
    , nsum
    , sumV
    , sumM
    , squareV
    , squareM
    , extractV
    , extractM2D
    , batchNormMean
    , batchNormVariance
    , vectorToList
    , listToVector
    ) where

import           Data.List                    (foldl')
import           Data.Maybe                   (fromJust)
import           Data.Proxy
import           Data.Singletons

import           GHC.TypeLits

import           Numeric.LinearAlgebra        hiding (R)
import           Numeric.LinearAlgebra.Static (L, R)
import qualified Numeric.LinearAlgebra.Static as H

import           Grenade.Core.Shape
import           Grenade.Types

sumV :: (KnownNat n) => R n -> RealNum
sumV v = v H.<.> 1

sumM :: (KnownNat m, KnownNat n) => L m n -> RealNum
sumM m = (m H.#> 1) H.<.> 1

squareV :: (KnownNat n) => R n -> R n
squareV = H.dvmap (^ (2 :: Int))

squareM :: (KnownNat m, KnownNat n) => L m n ->  L m n
squareM = H.dmmap (^ (2 :: Int))

-- | Helper function that sums the elements of a matrix
nsum :: S s -> RealNum
nsum (S1D x) = sumElements $ H.extract x
nsum (S2D x) = sumElements $ H.extract x
nsum (S3D x) = sumElements $ H.extract x
nsum (S4D x) = sumElements $ H.extract x

-- | Calculate elementwise mean of list of matrices
bmean :: forall s. SingI s => [S s] -> S s
bmean xs
  = let (!m, !l) = foldl' (\(m, l) x -> (m + x, l + 1)) (0 :: S s, 0) xs :: (S s, Int)
    in  case (m, l) of
          (S1D x, _) -> S1D $ H.dvmap (/ fromIntegral l) x
          (S2D x, _) -> S2D $ H.dmmap (/ fromIntegral l) x
          (S3D x, _) -> S3D $ H.dmmap (/ fromIntegral l) x
          (S4D x, _) -> S4D $ H.dmmap (/ fromIntegral l) x

-- | Calculate element wise variance
bvar :: forall s. SingI s => [S s] -> S s
bvar xs
  = let !m       = bmean xs
        (!v, !l) = foldl' (\(v, l) x -> (v + (x - m)**2, l + 1)) (0 :: S s, 0) xs :: (S s, Int)
    in  case (v, l) of
          (S1D x, _) -> S1D $ H.dvmap (/ fromIntegral l) x
          (S2D x, _) -> S2D $ H.dmmap (/ fromIntegral l) x
          (S3D x, _) -> S3D $ H.dmmap (/ fromIntegral l) x
          (S4D x, _) -> S4D $ H.dmmap (/ fromIntegral l) x

-- | Calculate element wise variance, with the mean precalculated
bvar' :: forall s. SingI s => S s -> [S s] -> S s
bvar' m xs
  = let (!v, !l) = foldl' (\(v, l) x -> (v + (x - m)**2, l + 1)) (0 :: S s, 0) xs :: (S s, Int)
    in  case (v, l) of
          (S1D x, _) -> S1D $ H.dvmap (/ fromIntegral l) x
          (S2D x, _) -> S2D $ H.dmmap (/ fromIntegral l) x
          (S3D x, _) -> S3D $ H.dmmap (/ fromIntegral l) x
          (S4D x, _) -> S4D $ H.dmmap (/ fromIntegral l) x

batchNormMean :: forall n. KnownNat n => [R n] -> RealNum
batchNormMean vs
  = let hw  = fromIntegral $ natVal (Proxy :: Proxy n)
        vs' = map (sumElements . H.extract) vs :: [RealNum]
        n   = fromIntegral $ length vs
    in  sum vs' / (hw * n)

batchNormVariance :: forall n. KnownNat n => [R n] -> RealNum
batchNormVariance vs
  = let mu  = batchNormMean vs
        hw  = fromIntegral $ natVal (Proxy :: Proxy n)
        vs' = map (sumElements . H.extract . H.dvmap (\a -> (a - mu) ^ (2 :: Int))) vs :: [RealNum]
        n   = fromIntegral $ length vs
    in  sum vs' / (hw * n)

extractV :: S ('D1 x) -> R x
extractV (S1D v) = v

extractM2D :: S ('D2 x y) -> L x y
extractM2D (S2D m) = m

vscale :: KnownNat n => RealNum -> R n -> R n
vscale = H.dvmap . (*)

vadd :: KnownNat n => RealNum -> R n -> R n
vadd = H.dvmap . (+)

vsqrt :: KnownNat n => R n -> R n
vsqrt = H.dvmap sqrt

msqrt :: (KnownNat n, KnownNat m) => L m n -> L m n
msqrt = H.dmmap sqrt

vflatten :: (KnownNat m, KnownNat n) => [R n] -> R m
vflatten xs = fromJust . H.create . flatten . fromRows $ map H.extract xs

sflatten :: (KnownNat m, KnownNat n) => L m n -> R (m * n)
sflatten = fromJust . H.create . flatten . H.extract

sreshape :: forall m n. (KnownNat m, KnownNat n) => R (m * n) -> L m n
sreshape v
  = let rows = fromIntegral $ natVal (Proxy :: Proxy m)
    in  fromJust . H.create . reshape rows . H.extract $ v

vectorToList :: KnownNat n => R n -> [RealNum]
vectorToList = toList . H.extract

listToVector :: KnownNat n => [RealNum] -> R n
listToVector = fromJust . H.create . fromList

-- bsqrt :: SingI s => [S s] -> [S s]
-- bsqrt xs = map msqrt xs

-- msqrt :: SingI s => S s -> S s
-- msqrt (S1D x) = S1D $ dvmap sqrt x
-- msqrt (S2D x) = S2D $ dmmap sqrt x
-- msqrt (S3D x) = S3D $ dmmap sqrt x

-- mscale :: SingI s => RealNum -> S s -> S s
-- mscale r (S1D x) = S1D $ dvmap (* r) x
-- mscale r (S2D x) = S2D $ dmmap (* r) x
-- mscale r (S3D x) = S3D $ dmmap (* r) x

-- madd :: SingI s => RealNum -> S s -> S s
-- madd r (S1D x) = S1D $ dvmap (+ r) x
-- madd r (S2D x) = S2D $ dmmap (+ r) x
-- madd r (S3D x) = S3D $ dmmap (+ r) x


module Math.Probably.Student where

import Numeric.LinearAlgebra
import Math.Probably.FoldingStats
import Text.Printf

--http://www.haskell.org/haskellwiki/Gamma_and_Beta_function
--cof :: [Double]
cof = [76.18009172947146,-86.50532032941677,24.01409824083091,
       -1.231739572450155,0.001208650973866179,-0.000005395239384953]

--ser :: Double
ser = 1.000000000190015

--gammaln :: Double -> Double
gammaln xx = let tmp' = (xx+5.5) - (xx+0.5)*log(xx+5.5)
                 ser' = foldl (+) ser $ map (\(y,c) -> c/(xx+y)) $ zip [1..] cof
             in -tmp' + log(2.5066282746310005 * ser' / xx)

beta z w = exp (gammaln z + gammaln w - gammaln (z+w))

fac :: (Enum a, Num a) => a -> a
fac n = product [1..n]

ixbeta :: (Enum a, Floating a) => a -> a -> a -> a
ixbeta x a b = let top = fac $ a+b-1
                   down j = fac j * fac (a+b-1-j)
               in sum $ map (\j->(top/down j)*(x**j)*(1-x)**(a+b-1-j)) [a..a+b-1]

studentIntegral :: (Enum a, Floating a) => a -> a -> a
studentIntegral t v = 1-ixbeta (v/(v+t*t)) (v/2) (1/2)

tTerms :: Vector Double
tTerms = fromList $ map tTermUnmemo [1..100]

tTermUnmemo :: Int -> Double
tTermUnmemo nu = gammaln ((realToFrac nu+1)/2) - log(realToFrac nu*pi)/2 - gammaln (realToFrac nu/2)

tTerm1 :: Int -> Double
tTerm1 df | df <= 100 = tTerms@>df
          | otherwise = tTermUnmemo df

tDist :: Int -> Double -> Double
tDist df t = tTerm1 df - (realToFrac df +1/2) * log (1+(t*t)/(realToFrac df))

tDist3 :: Double -> Double -> Int -> Double -> Double
tDist3 mean prec df x
    =   tTerm1 df
      + log(prec)/2
      - (realToFrac df +1/2) * log (1+(prec*xMinusMu*xMinusMu)/(realToFrac df))
 where xMinusMu = x-mean

oneSampleT :: Floating b => b -> Fold b b
oneSampleT v0 = fmap (\(mean,sd,n)-> (mean - v0)/(sd/(sqrt n))) meanSDNF

pairedSampleT :: Fold (Double, Double) Double
pairedSampleT  = before (fmap (\(mean,sd,n)-> (mean)/(sd/(sqrt n))) meanSDNF)
                        (uncurry (-))

data TTestResult = TTestResult { degFreedom :: Int,
                                 tValue :: Double,
                                 pValue :: Double }

ppTTestRes :: TTestResult -> String
ppTTestRes (TTestResult df tval pval) = printf "paired t(%d)=%.3g, p=%.3g" df tval pval

pairedTTest :: [(Double,Double)] -> TTestResult
pairedTTest vls =
    let tval = runStat pairedSampleT vls
        df =  length vls - 1
        pval =  (1-) $ studentIntegral (tval) (realToFrac df)
    in TTestResult df tval pval

oneSampleTTest :: [Double] -> TTestResult
oneSampleTTest vls =
  let tval = runStat (oneSampleT 0) vls
      df =  length vls - 1
      pval =  (1-) $ studentIntegral (tval) (realToFrac df)
  in TTestResult df tval pval


{-# LANGUAGE BangPatterns, TypeFamilies #-}

module Fractal2D ( mandelbrot
                 , juliaAnimated
                 ) where

import Control.Loop
import Control.Monad
import Data.Complex
import Data.Word
import Data.Bits
import qualified Data.Vector.Storable.Mutable as VSM

import ConcurrentSegments

-- A few simple 2D fractals, just for testing

magnitudeSq :: RealFloat a => Complex a -> a
magnitudeSq c = realPart c * realPart c + imagPart c * imagPart c

-- http://linas.org/art-gallery/escape/escape.html
-- http://en.wikipedia.org/wiki/Mandelbrot_set#Continuous_.28smooth.29_coloring
fractionalIterCnt :: Int -> Complex Float -> Float
fractionalIterCnt iter escZ = max 0 $ fromIntegral iter - (log (log $ magnitudeSq escZ)) / log 2

-- Mandelbrot Set
--
-- http://en.wikipedia.org/wiki/Mandelbrot_set#Computer_drawings
mandelbrot :: Int -> Int -> VSM.IOVector Word32 -> Bool -> IO ()
mandelbrot w h fb smooth =
  forLoop 0 (< h) (+ 1) $ \py -> forLoop 0 (< w) (+ 1) $ \px ->
    let idx          = px + py * w
        fpx          = fromIntegral px :: Float
        fpy          = fromIntegral py :: Float
        fw           = fromIntegral w  :: Float
        fh           = fromIntegral h  :: Float
        ratio        = fw / fh
        y            = (fpy / fh) * 2 - 1 -- Y axis is [-1, +1]
        xshift       = (- 2) - ((2 * ratio - 2.5) * 0.5)
        x            = (fpx / fw) * 2 * ratio + xshift -- Keep aspect and center [-1, +0.5]
        c            = x :+ y
        maxIter      = 40
        (iCnt, escZ) = go (0 :: Int) (0 :+ 0)
        go iter z | (iter == maxIter) || -- Iteration limit?
                    magnitudeSq z > 4 * 4 = (iter, z) -- Hit escape radius?
                  | otherwise = let newZ = z * z + c
                                 in if   newZ == z -- Simple 1-cycle detection
                                    then (maxIter, z)
                                    else go (iter + 1) newZ
        icCont | iCnt == maxIter = fromIntegral maxIter -- Interior in case of limit
               | otherwise       = fractionalIterCnt iCnt escZ
        toGreen v = v `unsafeShiftL` 8
     in VSM.unsafeWrite fb idx . toGreen . truncate $
          if   smooth
          then icCont            / fromIntegral maxIter * 255 :: Float
          else fromIntegral iCnt / fromIntegral maxIter * 255 :: Float

-- Julia Set, computed in parallel
--
-- http://en.wikipedia.org/wiki/Julia_set
-- http://www.relativitybook.com/CoolStuff/julia_set.html
juliaAnimated :: Int -> Int -> VSM.IOVector Word32 -> Bool -> Double -> IO ()
juliaAnimated w h fb smooth tick =
  let !fTick       = realToFrac tick :: Float
      !scaledTick  = snd (properFraction $ fTick / 17 :: (Int, Float))
      !scaledTick2 = snd (properFraction $ fTick / 61 :: (Int, Float))
      !scaledTick3 = snd (properFraction $ fTick / 71 :: (Int, Float))
      !twoPi       = scaledTick * 2 * pi
      !juliaR      = sin twoPi * max 0.7 scaledTick2
      !juliaI      = cos twoPi * max 0.7 scaledTick3
      !fw          = fromIntegral w  :: Float
      !fh          = fromIntegral h  :: Float
      !ratio       = fw / fh
      !xshift      = 1.45 * ratio
      !maxIter     = 40
      doSeg lo hi  = forLoop lo (< hi) (+ 1) $ \py -> forLoop 0 (< w) (+ 1) $ \px ->
        let idx          = px + py * w
            fpx          = fromIntegral px :: Float
            fpy          = fromIntegral py :: Float
            y            = (fpy / fh) * 2.9 - 1.45 -- Y axis is [-1.45, +1.45]
            x            = (fpx / fw) * 2.9 * ratio - xshift -- Keep aspect and center
            c            = x :+ y
            (iCnt, escZ) = go (0 :: Int) c
            go iter z | (iter == maxIter) || -- Iteration limit?
                        magnitudeSq z > 4 * 4 = (iter, z) -- Hit escape radius?
                      | otherwise = let newZ = z * z + (juliaR :+ juliaI)
                                     in if   newZ == z -- Simple 1-cycle detection
                                        then (maxIter, z)
                                        else go (iter + 1) newZ
            icCont | iCnt == maxIter = fromIntegral maxIter -- Interior in case of limit
                   | otherwise       = fractionalIterCnt iCnt escZ
            toGreen v = v `unsafeShiftL` 8
         in VSM.unsafeWrite fb idx . toGreen . truncate $
              if   smooth
              then icCont            / fromIntegral maxIter * 255 :: Float
              else fromIntegral iCnt / fromIntegral maxIter * 255 :: Float
   in void $ forSegmentsConcurrently Nothing 0 h doSeg


-- nonlinear least-squares fitting

import Spinell.Fitting
import Spinell.Graphing
import Numeric.LinearAlgebra

model [a,lambda,b] t = a * exp (-lambda * t)+b --the function we will be fitting

jac [a,lambda,b] [t] = [[exp (-lambda * t), -t * a * exp(-lambda*t) , 1]]

xs = [0..100]

sigma = replicate (length xs) 0.1 -- will create an array of repeating '0.1': [0.1,0.1...]

noise = toList $ scalar 0.1 * (randomVector 0 Gaussian (length xs)) --a list of random small values, that will play the role of the noise in the data

ys = map (model [5,0.1,1]) xs --we plainly apply the model to the data

ysNoisy = [ y + err | (y,err) <- zip ys noise] -- and then add the noise, just to make it look more realistic

res = fit xs ys sigma model [1,1,1] defFitOpt{jacob = ManualJacob jac}

main :: IO()
main = plotFit xs ysNoisy sigma model (getParams res) defGraphOpt


#!/usr/bin/env stack
-- stack --resolver lts-11.1 --install-ghc runghc --package random
{-# LANGUAGE TypeApplications #-}
import Data.Complex (Complex(..), magnitude)
import Control.Monad (replicateM, forM_)
import System.Random (randomIO)
import Text.Printf (printf)

approximate :: Int -> IO Double
approximate count = do
    let randomPoint = (:+) <$> randomIO <*> randomIO @Double
        randomPoints = flip replicateM randomPoint
    inCircle <- (length . filter (\z -> magnitude z <= 1)) <$> randomPoints count
    pure $ 4 * (fromIntegral inCircle / fromIntegral count)

main = forM_ [1 .. 100000] $ \n -> printf "%6d %f\n" n =<< approximate n


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

Softmax Loss.
-}

module MachineLearning.NeuralNetwork.SoftmaxLoss
(
  scores
  , gradient
  , loss
)

where

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

scores x = x - reduceByRows V.maximum x

gradient scores y =
  let sum_probs = sumByRows $ exp scores
      probs = (exp scores) / sum_probs
  in probs - y

-- Softmax Loss function
loss :: Matrix -> Matrix -> R
loss scores y = loss / m
  where m = fromIntegral $ LA.rows scores
        sum_probs = sumByRows $ exp scores
        t = sumByRows $ scores * y
        loss = LA.sumElements $ (log sum_probs) - t


{-|
Module: MachineLearning.LogisticModel
Description: Logistic Regression Model
Copyright: (c) Alexander Ignatyev, 2016
License: BSD-3
Stability: experimental
Portability: POSIX

-}

module MachineLearning.LogisticModel
(
  module MachineLearning.Model
  , LogisticModel(..)
  , sigmoid
  , sigmoidGradient
)

where

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

import MachineLearning.Model
import qualified MachineLearning.Regularization as R

data LogisticModel = Logistic

-- | Calculates sigmoid
sigmoid :: Floating a => a -> a
sigmoid z = 1 / (1+exp(-z))

-- | Calculates derivatives of sigmoid
sigmoidGradient :: Floating a => a -> a
sigmoidGradient z = s * (1-s)
  where s = sigmoid z

instance Model LogisticModel where
  hypothesis Logistic x theta = sigmoid (x #> theta)

  cost m lambda x y theta =
    let h = hypothesis m x theta
        nExamples = fromIntegral $ LA.rows x
        tau = 1e-7
        jPositive = log(tau + h) <.> (-y)
        jNegative = log((1 + tau) - h) <.> (1-y)
        regTerm = R.costReg lambda theta
    in (jPositive - jNegative + regTerm) / nExamples

  gradient m lambda x y theta = (((LA.tr x) #> (h  - y)) + regTerm) / nExamples
    where h = hypothesis m x theta
          nExamples = fromIntegral $ LA.rows x
          regTerm = R.gradientReg lambda theta


module Haskfem
    ( solvePoisson
    , makeInterval
    , standardInterval
    ) where

import Numeric.LinearAlgebra

import Grid
import HaskfemInternal

-- $setup
-- >>> import Test.QuickCheck
-- >>> import Numeric.LinearAlgebra

-- | Return the solution of the Poisson's equation
-- > -c Δu = f
--
-- * Right-hand side is a constant
-- * Left-hand side parameter is a constant
-- * Domain is the unit interval
-- * homogeneous Dirichlet boundary conditions
--
-- No proper error handling for @c = 0.0@.
-- The constant 0.0 functions is the standard solution
-- The solution can be evaluated for all x in [0, 1] and returns 0 for points
-- outside of the domain.
--
-- The solution has same sign as @fc@ everywhere:
--
-- prop> (c :: R) * (f :: R) * (solvePoisson standardInterval (c :: R) (f :: R) (x :: R)) >= 0.0
--
-- Dirichlet boundary conditions are fulfilled:
--
-- prop> solvePoisson standardInterval (c :: R) (f :: R) 0.0 == 0.0
-- prop> solvePoisson standardInterval (c :: R) (f :: R) 1.0 == 0.0
solvePoisson :: Grid     -- ^ Grid on which to solve the equation
             -> R        -- ^ left-hand side constant parameter @c@
             -> R        -- ^ right-hand side constant @f@
             -> (R -> R)
solvePoisson _ 0 _ _ = 0.0
solvePoisson grid c f x = sum $ zipWith (*) (toList solVecFree) $ evalBasisF
  where evalBasisF = fmap ($ x) $ basisFuncs grid

        solVecFree = inv (sysMatFreeFree grid c) #> rhs grid f


module AngleSpec where

import Test.Hspec
import Test.QuickCheck hiding (scale)
import Data.Complex
import Geometry
import Geometry.Testing

spec :: Spec
spec = describe "Angle" $ do
    describe "Affinity" $ do
      it "1" $ asCmp 1 == Angle 0 0 0
      it "2" $ property $ \x -> asCmp x == Angle 0 (asCmp x) (asCmp x)
      it "3" $ property $ \x -> cmp (Angle 0 0 x) == 1
      it "4" $ cmp (Angle 0 30 90) == cmp (asDeg 30)
      it "5" $ anAngle 30 # along 45 ~= Angle 0 45 75
      it "6" $ anAngle 30 # along 180 ~= Angle 0 180 210
      it "7" $ anAngle 30 # along 345 ~= Angle 0 345 15
      it "8" $ anAngle 30 # on (Segment (1, 2:+1)) 0 ~= Angle 1 45 75
      it "9" $ anAngle (-30) ~= Angle (0.0 :+ 0.0) 0 330

    describe "Manifold properties" $ do
      it "1" $ Angle 0 0 30 @-> 0 == 0
      it "2" $ Angle 0 0 30 @-> 1 == 30
      it "3" $ Angle 0 0 30 @-> 0.5 == 15
      it "4" $ Angle 0 0 30 @-> 2 == 60
      it "5" $ Angle 0 0 60 @-> 2 == 120
      it "7" $ Angle 0 30 120 @-> 0 == 30
      it "8" $ Angle 0 30 120 @-> 1 == 120
      it "9" $ Angle 0 0 358 @-> 0.5 == 179
      it "10" $ Angle 0 (-2) 0 @-> 0.5 == -1
      it "11" $ asDeg 0 ->@ Angle 0 0 30 == 0
      it "12" $ asDeg 45 ->@ Angle 0 0 30 == 1.5

    describe "Supplementary angles" $ do
      it "1" $ supplementary (Angle 0 30 45) ~= Angle 0 45 210
      it "2" $ supplementary (Angle 0 0 120) ~= Angle 0 120 180
      it "3" $ supplementary (Angle 0 10 200) ~= Angle 0 200 190
      it "4" $ property $ \(AnyAngle a) ->
        angleValue a + angleValue (supplementary a) ~= 180


module AutomatedReviewAnalyzerSpec where

import Numeric.LinearAlgebra as LA
import AutomatedReviewAnalyzer
import SentimentAnalysis
import Test.Hspec

theta :: Vector R
theta = LA.vector [1.0, 1.0]

spec :: Spec
spec = do
  describe "Classify" $ do

    it "Classify 1" $ do
      let x = (3><2) [1.0, 1.0, 1.0, 1.0, 1.0, 1.0]
          theta0 = 0
          m = classify x theta theta0
      m `shouldBe` LA.vector [1.0, 1.0, 1.0]

    it "Classify 2" $ do
      let x = (1><2) [-1.0, 1.0]
          theta = LA.vector [1.0, 1.0]
          theta0 = 0
          m = classify x theta theta0
      m `shouldBe` LA.vector [-1.0]

  describe "Classifier Accuracy 1" $ do

    it "Accuracy 1" $ do
      let x1 = (3><2) [1.0, 0, 1.0, -1.0, 2.0, 3.0]
          x1' = (2><2) [1.0, 1.0, 2.0, -1.0]
          y1 = LA.vector [1.0, -1.0, 1.0]
          y1' = LA.vector [-1.0, 1.0]
          t1 = 1
          m =  classifierAccuracy perceptron x1 x1' y1 y1' t1 [1, 2, 0]
      m `shouldBe` (1.0, 0.0)

    it "Accuracy 2" $ do
      let x2 = (3><2) [1.0, 0, 1.0, -1.0, 2.0, 3.0]
          x2' = (2><2) [1.0, 1.0, 2.0, -1.0]
          y2 = LA.vector [1.0, -1.0, 1.0]
          y2' = LA.vector [-1.0, 1.0]
          t2 = 1
          lambda = 0.2
          m =  classifierAccuracy' pegasos x2 x2' y2 y2' t2 lambda [1, 2, 0]
      m `shouldBe` (1.0, 0.0)


module NaiveBayes.GaussianNB
  ( train
  , predict
  , GaussianNB(..)
  ) where
import           Data.List           ((++))
import qualified Data.List           as L
import           Data.Map            ((!))
import qualified Data.Map            as M
import qualified Data.Vector.Unboxed as U
import           Prelude             hiding ((++))
import           Statistics.Matrix   as S
import           Statistics.Sample   as S

-- Implementation taken from
-- https://chrisalbon.com/machine_learning/naive_bayes/naive_bayes_classifier_from_scratch/

-- | Usage Example
--
-- trainFeatures :: S.Matrix
-- trainFeatures = S.fromRowLists
--   [ [6.00, 180, 12]
--   , [5.92, 190, 11]
--   , [5.58, 170, 12]
--   , [5.92, 165, 10]
--   , [5.00, 100, 6]
--   , [5.50, 150, 8]
--   , [5.42, 130, 7]
--   , [5.75, 150, 9]
--   ]
--
-- trainLabels :: U.Vector Int
-- trainLabels = U.fromList [0, 0, 0, 0, 1, 1, 1, 1]
--
-- trainedData = train trainFeatures trainLabels
-- predict trainedData [6.00, 130, 8]
-- 1

data GaussianNB = GaussianNB
  { cMeans      :: M.Map Int [Double]
  , cVariances  :: M.Map Int [Double]
  , cPriorProbs :: M.Map Int Double
  }

  deriving (Show)

labelsCounts :: U.Vector Int -> M.Map Int Int
labelsCounts = U.foldr' (\x acc -> M.insertWith (+) x 1 acc) M.empty

labelsFeatures :: S.Matrix -> U.Vector Int -> M.Map Int [U.Vector Double]
labelsFeatures features labels =
  L.foldr
    (\(l, fs) acc -> M.insertWith (++) l [fs] acc)
    M.empty
    (zip' labels features)

zip' :: U.Vector Int -> S.Matrix -> [(Int, U.Vector Double)]
zip' vec mx = U.ifoldr' (\i x acc -> (x, S.row mx i):acc) [] vec

means :: M.Map Int [U.Vector Double] -> M.Map Int [Double]
means = fmap (fmap S.mean . S.toRows . S.transpose . S.fromRows)

variances :: M.Map Int [U.Vector Double] -> M.Map Int [Double]
variances =
  fmap (fmap S.variance . S.toRows . S.transpose . S.fromRows)

priorProbs :: M.Map Int Int -> Int -> M.Map Int Double
priorProbs mp totalCount =
  fmap (\x -> fromIntegral x / fromIntegral totalCount) mp

train :: Matrix -> U.Vector Int -> GaussianNB
train features labels =
  let countMap = labelsCounts labels
      featuresMap = labelsFeatures features labels
      meansMap = means featuresMap
      variancesMap = variances featuresMap
      priorProbsMap = priorProbs countMap (U.length labels)
  in  GaussianNB meansMap variancesMap priorProbsMap

predict :: GaussianNB -> [Double] -> Int
predict cf feature =
  fst $ L.maximumBy
    (\(_, a) (_, b) -> a `compare` b)
    (M.toList (posteriorProbs cf feature))

posteriorProbs :: GaussianNB -> [Double] -> M.Map Int Double
posteriorProbs (GaussianNB ms vs pp) feature =
  M.mapWithKey (\k x -> x * likelihoods k) pp
    where likelihoods k = L.product $
            L.map
              (\(x, m, v) -> exp ((- ((x - m) ** 2)) / (2 * v)) / (sqrt (2 * pi * v)))
              (L.zip3 feature (ms ! k) (vs ! k))


#!/usr/bin/env runhaskell

import Data.Complex
import System.Environment

import Escape

usage :: IO ()
usage = do
    progName <- getProgName
    putStrLn $ "usage: " ++ progName ++ " <fractal type> <args>"
    putStrLn $ "  fractal type: mandelbrot"
    putStrLn $ "                julia x y (x y contructs a complex number x+yi)"
    putStrLn $ "                ship"
    putStrLn $ "                nova p r (f(z) = z^p - 1, z' = z - r*f(z)/f'(z))"

main = do
    (op:args) <- fmap (++ [""] ++ [""]) getArgs -- make sure it matches pattern (_:_)
    case op of
        "help"       -> usage
        "mandelbrot" -> mandelbrot
        "julia"      -> do
            let x = read $ args !! 0 :: Double
            let y = read $ args !! 1 :: Double
            julia (x :+ y)
        "ship"       -> burningShip
        "nova"       -> do
            let p = read $ args !! 0 :: Int
            let r = read $ args !! 1 :: Double
            nova p r
        _            -> usage


{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GADTs, DataKinds, PolyKinds, ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-|
Module      : Grenade.Core.WeightInitialization
Description : Defines the Weight Initialization methods of Grenade.
Copyright   : (c) Manuel Schneckenreither, 2018
License     : BSD2
Stability   : experimental

This module defines the weight initialization methods.

-}

module Grenade.Core.WeightInitialization
    ( getRandomVector
    , getRandomMatrix
    , WeightInitMethod (..)
    ) where

import           Data.Proxy
import Control.Monad

import           Data.Singletons.TypeLits

import           Control.Monad.Primitive         (PrimBase, PrimState)
import           System.Random.MWC
import           System.Random.MWC.Distributions

import           GHC.TypeNats (type (*))

import           Numeric.LinearAlgebra.Static

data WeightInitMethod = UniformInit       -- ^ W_l,i ~ U(-1/sqrt(n_l),1/sqrt(n_l))                   where n_l is the number of nodes in layer l
                      | Xavier            -- ^ W_l,i ~ U(-sqrt (6/n_l+n_{l+1}),sqrt (6/n_l+n_{l+1})) where n_l is the number of nodes in layer l
                      | HeEtAl            -- ^ W_l,i ~ N(0,sqrt(2/n_l))                              where n_l is the number of nodes in layer l

-- | Get a random vector initialized according to the specified method.
getRandomVector :: forall m n . (PrimBase m, KnownNat n) => Integer -> Integer -> WeightInitMethod -> Gen (PrimState m) -> m (R n)
getRandomVector i o method gen = do
  unifRands <- vector <$> replicateM n (uniformR (-1,1) gen)
  gaussRands <- vector <$> replicateM n (standard gen)

  return $ case method of
             UniformInit -> (1/sqrt (fromIntegral i)) * unifRands
             Xavier      -> (sqrt 6/sqrt (fromIntegral i + fromIntegral o)) * unifRands
             HeEtAl      -> sqrt (2/fromIntegral i) * gaussRands
  where n = fromIntegral $ natVal (Proxy :: Proxy n)

-- | Get a matrix with weights initialized according to the specified method.
getRandomMatrix :: forall m r n nr . (PrimBase m, KnownNat r, KnownNat n, KnownNat nr, nr ~ (n*r))
                => Integer -> Integer -> WeightInitMethod -> Gen (PrimState m) -> m (L r n)
getRandomMatrix i o method gen = do
  unifRands <- matrix <$> replicateM nr (uniformR (-1,1) gen)
  gaussRands <- matrix <$> replicateM nr (standard gen)

  return $ case method of
             UniformInit -> (1/sqrt (fromIntegral i)) * unifRands
             Xavier -> (sqrt 6/sqrt (fromIntegral i + fromIntegral o)) * unifRands
             HeEtAl -> (sqrt (2/fromIntegral i)) * gaussRands

  where nr = fromIntegral $ natVal (Proxy :: Proxy nr)


module Ranks
  ( initWeights,
    ilsrPairwise,
  )
where

import Data.List ((!!), iterate)
import Import hiding ((<>), Vector, fromList)
import Numeric.LinearAlgebra

mean :: Vector R -> R
mean v = sumElements v / fromIntegral (size v)

expTransform :: Vector R -> Vector R
expTransform weights = weights' / scalar (mean weights')
  where
    weights' = exp (weights - scalar (mean weights))

logTransform :: Vector R -> Vector R
logTransform weights = params - scalar (mean params)
  where
    params = log weights

initWeights :: Int -> Vector R
initWeights = konst 1

iterLsr :: Vector R -> Vector R
iterLsr = expTransform

initChain :: Int -> R -> Matrix R
initChain n alpha = scalar alpha * konst 1 (n, n)

lsrPairwise :: Matrix R -> R -> Vector R -> Vector R
lsrPairwise bm alpha weights = logTransform (statdist chain)
  where
    n = size weights
    denom = asRow weights
    chain' = initChain n alpha + tr' bm / (denom + tr' denom)
    chain = chain' - (diagl . fmap sumElements . toRows) chain'

ilsrPairwise :: Matrix R -> R -> Vector R
ilsrPairwise bm alpha = iterate (lsr . iterLsr) (lsr weights) !! 100
  where
    weights = initWeights (rows bm)
    lsr = lsrPairwise bm alpha

statdist :: Matrix R -> Vector R
statdist chain = res / scalar (mean res)
  where
    (_, u, _, _) = lu (tr' chain)
    left = u ?? (DropLast 1, DropLast 1)
    right = negate (u ?? (DropLast 1, TakeLast 1))
    res = vjoin [flatten (triSolve Upper left right), 1.0]


{-# LANGUAGE ViewPatterns #-}
module EigenDFT where

import           Control.Monad                      as M
import           Control.Monad.Parallel             as MP
import qualified Data.Array.Accelerate              as A
import qualified Data.Array.Accelerate.Data.Complex as A
import           Data.Array.Accelerate.LLVM.PTX
import           Data.Array.Repa                    as R
import           Data.List                          as L
import           Foreign.CUDA.Driver                as CUDA
import           Image.IO
import           Numeric.LinearAlgebra              as NL
import           Pinwheel.Base
import           Pinwheel.FourierSeries2D
import           System.Directory
import           System.Environment
import           System.FilePath
import           Text.Printf

main = do
  args@(nStr:numFreqStr:deltaStr:_) <- getArgs
  let n = read nStr :: Int
      numFreq = read numFreqStr :: Int
      delta = read deltaStr :: Double
      len = n ^ 2
      center = div n 2
      centerFreq = div numFreq 2
      constant = (-2) * pi * delta / (fromIntegral n) :: Double
      matArr' =
        fromFunction (Z :. n :. n :. numFreq :. numFreq) $ \(Z :. x' :. y' :. wx' :. wy') ->
          let wx = wx' - centerFreq
              wy = wy' - centerFreq
              x = x' - center
              y = y' - center
          in cis $ constant * fromIntegral (wx * x + wy * y)
      pinwheelVec =
        NL.fromList . R.toList . fromFunction (Z :. n :. n) $ \(Z :. x' :. y') ->
          let x = x' - center
              y = y' - center
          in fourierMellin (0.5 :: Double) 5 5 (fromIntegral x, fromIntegral y)
      folderPath = "output/test/EigenDFT"
  when (numFreq > n) (error "error: numFreq > n")
  removePathForcibly folderPath
  createDirectoryIfMissing True folderPath
  matArr <- computeUnboxedP matArr'
  let mat = (len >< (numFreq ^ 2)) . R.toList $ matArr
      coefficients = pinwheelVec <# mat
  --     xs =
  --       if numFreq == n
  --         then let (eigVal, eigVec) = eig mat
  --              in snd . L.unzip . L.reverse . L.sortOn fst $
  --                 L.zip
  --                   (L.map magnitude . NL.toList $ eigVal)
  --                   (L.map NL.toList . NL.toColumns $ eigVec)
  --         else let (u, s, v) = thinSVD mat
  --              in snd . L.unzip . L.reverse . L.sortOn fst $
  --                 L.zip (NL.toList $ s) (L.map NL.toList . NL.toColumns $ u)
  -- M.mapM_
  --   (\(i, ys) ->
  --      plotImageRepaComplex (folderPath </> printf "%d.png" i) .
  --      ImageRepa 8 . fromListUnboxed (Z :. (1 :: Int) :. n :. n) $
  --      ys) $
  --   L.zip [0 :: Int .. (numFreq ^ 2 - 1)] xs
  plotImageRepaComplex (folderPath </> "Pinwheel.png" ) . ImageRepa 8 . fromListUnboxed (Z :. (1 :: Int) :. n :. n) . NL.toList $ pinwheelVec
  plotImageRepaComplex (folderPath </> "coefficients.png" ) . ImageRepa 8 . fromListUnboxed (Z :. (1 :: Int) :. numFreq :. numFreq) . NL.toList $ coefficients
  -- let centerAcc = A.constant center
  --     centerFreqAcc = A.constant centerFreq
  --     constantAcc = A.constant constant
  --     matArrAcc' =
  --       A.generate (A.constant (A.Z A.:. numFreq A.:. numFreq A.:. n A.:. n)) $ \(A.unlift -> (A.Z A.:. wx' A.:. wy' A.:. x' A.:. y')) ->
  --         let wx = wx' - centerFreqAcc
  --             wy = wy' - centerFreqAcc
  --             x = x' - centerAcc
  --             y = y' - centerAcc
  --         in A.cis $ constantAcc * A.fromIntegral (wx * x + wy * y)
  -- initialise []
  -- dev <- device 7
  -- ctx <- CUDA.create dev []
  -- ptx <- createTargetFromContext ctx
  -- let matArrAcc = runWith ptx matArrAcc'
  --     mat = ((numFreq^2) >< len) . A.toList $ matArrAcc


import Data.Complex
import Data.Array
import Data.Ratio
import qualified Data.Map as M

fft :: [Complex Double] -> [Complex Double]
fft x = let n = length x
            i = 0 :+ 1
            w = M.fromList [(k%n, exp ((-2)*pi*i*(fromIntegral k)/(fromIntegral n)) ) | k<-[0..n-1]]
            arr = fft' n w (listArray (0,n-1) x)
        in [arr!k | k<-[0..n-1]]
  where
  fft' 1 _ x = x
  fft' n w x = let n2 = div n 2
                   e = fft' n2 w (listArray (0, n2-1) [x!k | k<-[0,2..n-1]])
                   o = fft' n2 w (listArray (0, n2-1) [x!k | k<-[1,3..n-1]])
               in array (0, n-1) $ concat [[(k, e!k + o!k * w M.!(k%n)),
                                            (k + n2, e!k - o!k * w M.!(k%n))]
                                                               | k <- [0..n2-1]]

main = do
  print $ fft [0,1,2,3]


module Vectorspace where

import Data.Complex
import Data.Maybe

newtype Vector a = Vector [a] deriving (Eq)
newtype Matrix a = Matrix [[a]] deriving (Eq)

instance Show a => Show (Vector a) where
        show (Vector v)
            | length v == 0 = "()"
            | length v == 1 = "(" ++ show (v!!0) ++ ")"
            | length v == 2 = start v ++ end v
            | length v >= 3 = start v ++ center v ++ end v where
                start v = vectortop $ (show.head) v
                center v = concatMap (vectorcenter.show) ( (init.tail) v)
                end   v = vectorbottom $ (show.last) v
                vectortop x = "/" ++ x ++ "\\\n"
                vectorcenter x = "|" ++ x ++ "|\n"
                vectorbottom x = "\\" ++ x ++ "/"

instance Show a => Show (Matrix a) where
        show (Matrix m) = start m ++ "\n" ++ center m ++ "\n" ++ end m where
            start m  = (matrixtop.concat) [ cell v | v <- head m ]
            center m = (matrixcenter.concat) [ cell v | v <- (head.init.tail) m ]
            end   m  = (matrixbottom.concat) [ cell v | v <- last m ]
            matrixtop v    = "┌" ++ v ++ "┐"
            matrixcenter v = "│" ++ v ++ "│"
            matrixbottom v = "└" ++ v ++ "┘"
            cell v = [ if i< length (show v) then (show v)!!i else ' ' | i <- [0..cellWidth] ]
            cellWidth =  maximum $ map (length.show) $ concat m

instance Floating a => Num (Vector a) where
        -- componentwise addition
        (Vector v) + (Vector w)
                            | length v == length w = Vector $ zipWith (+) v w
                            | length v >  length w = Vector v + Vector (take (length v) (w++repeat 0))
                            | length v <  length w = Vector w + Vector v
        (Vector v) * (Vector w) = Vector $ zipWith (*) v w
        negate (Vector v) = Vector $ map (*(-1)) v
        abs (Vector v) = Vector [sqrt $ sum (map (**2) v)]
        signum (Vector v) = Vector $ map signum v
        fromInteger n = Vector [fromInteger n]

-- multiplies a vector by a scalar
vecmul :: Integer -> [Integer] -> [Integer]
vecmul a = map (*a)

-- multiplies a matrix by a scalar
matscalmult :: Num a => [[a]] -> a -> [[a]]
matscalmult m s = map (\y -> map (\x -> (m!!y!!x)*s) [0..length (m!!y)-1]) [0..length m-1]

-- multiplies / composes two matrices
matmult :: Num a => [[a]] -> [[a]] -> [[a]]
matmult m n
    | length m > length n         = matmult m (scale n (length m))
    | length m /= length (head m) = matmult (sqrify m) n
    | length n /= length (head n) = matmult m (sqrify n)
    | otherwise                   = [[
                                          sum (zipWith (*) (getColMat m y) (getRowMat n x))
                                      | x<-[0..(length (m!!y)-1)] ]
                                  | y<-[0..(length m-1)]]

-- multiplies a matrix by a vector / applies a matrix to a vector
matvecmult :: Num a => [[a]] -> [a] -> [a]
matvecmult m v = map head $ matmult m (map (\e-> [e]) v)

applyMatrix :: Num a => [[a]] -> [a] -> [a]
applyMatrix m v = map (sum . zipWith (*) v) m

-- adds two matrices together
matadd :: Num a => [[a]] -> [[a]] -> [[a]]
matadd m n
    | length m > length n       = matadd m (scale n (length m))
    | length m /= length (m!!0) = matadd (sqrify m) n
    | length n /= length (n!!0) = matadd m (sqrify n)
    | otherwise                 = [[
                                         (m!!y!!x) + (n!!y!!x)
                                    | x <- [0..((length(m!!0))-1)]]
                                | y <- [0..((length m)-1)]]

-- subtracts one matrix from another
matsub :: Num a => [[a]] -> [[a]] -> [[a]]
matsub m n = matadd m (matscalmult n (-1))

-- creates an identity matrix of dimension n
matid :: Num a => Int -> [[a]]
matid n = matgen n (\ i j -> if i==j then 1 else 0 )

-- maps a matrices entries based on a function that takes the indices as input
matmap :: Num a => [[a]] -> ( Int -> Int -> a -> a ) -> [[a]]
matmap m f = map (\y -> map (\x -> f y x (m!!y!!x) ) [0..(length (m!!y)-1)]) [0..( length m -1)]

-- complex conjugat of a matrix
matcon :: RealFloat a => [[Complex a]] -> [[Complex a]]
matcon m = matmap m (\y x a -> conjugate a)

-- generates a matrix of size t and then maps it with values
matgen :: (Num a, Num t, Enum t) => t -> (t -> t -> a) -> [[a]]
matgen s f = [[
             f x y
        | x<- [0..(s-1)]]
    | y<- [0..(s-1)]]

-- fills in entries with 0's, so that a matrix is square
sqrify :: Num a => [[a]] -> [[a]]
sqrify m = scale m (max (length m) (length (head m)))

-- scales a matrix m to a size s (also makes it a square matrix
scale :: Num a => [[a]] -> Int -> [[a]]
scale m s = [[ if (y<(length m) && x<(length (m!!0))) then(m!!y!!x) else(0) | x <- [0..(s-1)] ] | y <- [0..(s-1)] ]

-- pretty prints a matrix
printMat :: (Foldable t, Show a) => t a -> IO ()
printMat m = mapM_ print m

-- all non zero elements of a matrix are replaces by '.', otherwise they are replaced by ' '
prettifyMat m = [[ if(m!!y!!x == 0)then(' ')else('.') | x<-[0..(length (m!!y)-1)] ] | y<-[0..((length m)-1)]]

indexMatrix :: (Num a, Num b,Enum b)  => [[a]] -> [([(a,b)], b)]
indexMatrix m = (map (\i -> zip i [0..]) m) `zip` [0..]

-- gets the element of the y th row and x th collumn of a matrix
matxy :: Num a => [[a]] -> Int -> Int -> a
matxy m x y = m!!x!!y

-- transposes a matrix
transpose :: Num a => [[a]] -> [[a]]
transpose m = do
    let im = indexMatrix m
    map (\i -> map (\j -> matxy m (snd j) (snd i)) (fst i)) im

-- transposes a vector
vectrans :: Num a => [a] -> [[a]]
vectrans v = [ [x] | x<-v ]

-- adjugate matrix of m
adju :: Num a => [[a]] -> [[a]]
adju m = transpose (cof m)

-- cut out the matrix from x1-x2 and y1-y2 of a matrix m
submatrix :: Num a => [[a]] -> Int -> Int -> Int -> Int -> [[a]]
submatrix m x1 y1 x2 y2 = do
    let ycut = take (y2-y1) (drop y1 m)
    map (\i -> take (x2-x1) (drop x1 i)) ycut

-- gets the elements of a matrix in row r
getRowMat :: Num a => [[a]] -> Int -> [a]
getRowMat m r = [ m!!r!!x | x <- [0..((length (m!!0))-1)]]

-- gets the elements of a matrix in collumn c
getColMat :: Num a => [[a]] -> Int -> [a]
getColMat m c = [ m!!x!!c | x <- [0..((length m)-1)]]

-- return the matrix with collumn c removed
elimRowMat :: Num a => [[a]] -> Int -> [[a]]
elimRowMat m r = map (\i -> take r i ++ drop (r+1) i) m

-- returns the matrix with row r removed
elimColMat :: Num a => [[a]] -> Int -> [[a]]
elimColMat m c = take c m ++ drop (c+1) m

-- eliminates row y and collumn x
elimRowColMat :: (Num a) => [[a]] -> Int -> Int -> [[a]]
elimRowColMat m x y = elimRowMat (elimColMat m y) x

-- takes a matrix and replaces the n th collumn with a vector
replCol :: Num a => [[a]] -> Int -> [a] -> [[a]]
replCol m i v = map (\y -> map (\x -> if(x==i && y<length v)then(v!!y)else(m!!y!!x)) [0..((length (m!!0))-1)]) [0..((length m)-1)]

-- takes a matrix and replaces the n th row with a vector
replRow :: Num a => [[a]] -> Int -> [a] -> [[a]]
replRow m i v = map (\y -> map (\x -> if(y==i && x<length v)then(v!!x)else(m!!y!!x)) [0..((length (m!!0))-1)]) [0..((length m)-1)]

-- calculates the determinant of a matrix
det :: Num a => [[a]] -> a
det m = case (length m, length (m!!0)) of
    (1,1) -> m!!0!!0
    (p,q) -> do
        let grid = [ (m!!0!!x)*(-1)^x | x<-[0..p-1] ]
        let underdet = [ (grid!!x) * det(elimRowColMat m x 0) | x<-[0..p-1]]
        sum underdet

-- returns the minor of a matrix from row x and col y
minor :: Num a => [[a]] -> Int -> Int -> a
minor m x y = det (elimRowColMat m x y)

-- cofactor matrix / i.e. replace each entry with their minor and apply the checkerboard pattern of (1) and (-1)
cof :: Num a => [[a]] -> [[a]]
cof m = [
        [
            ((-1)^(x+y)) * (minor m x y)
        | x<-[0..(length (m!!y))-1]]
    | y<-[0..(length m)-1]]

-- returns if a matrix is invertible or nor
invertible :: (Eq a, Num a) => [[a]]-> Bool
invertible m = (det m) /= 0

-- returns the inverse of a matrix, if it exists
inv :: (Eq a, Fractional a) => [[a]] -> Maybe [[a]]
inv m
    | not (invertible m) = Nothing
    | otherwise = Just (matscalmult (adju m) (1/det(m)))

-- removes duplicates inside a list
remDupl :: (Eq a) => [a] -> [a]
remDupl a
    | a == [] = []
    | not (elem (a!!0) (drop 1 a)) = (a!!0):(remDupl(drop 1 a))
    | otherwise = remDupl (drop 1 a)

-- true if list a and list b are linearily dependent
linDep :: (Fractional a, Eq a, Enum a) => [a] -> [a] -> Bool
linDep a b
    | length a < length b   = linDep b a
    | length a == 0         = True
    | a!!0==b!!0 && a!!0==0  = linDep (tail a) (tail b)
    | a!!0/=0 && b!!0/=0    = all (\e -> (fst e)/b!!0 == (snd e)/a!!0) $ zip a (b++[0,0..])
    | otherwise             = False

-- adds a collumn of 0 at the beginning
addCol :: Num a => [[a]] -> [[a]]
addCol m = map (\e -> 0:e) m

-- reduced row-echelon form (TODO)
rref :: (Fractional a, Eq a) => [[a]] -> [[a]]
rref m = rref_step 0 m

rref_step :: (Fractional a, Eq a) => Int -> [[a]] -> [[a]]
rref_step s m
    | coef s == 0                               = rref_step (s+1) m
    | length (newPivot (normalize s) s) == 0    = normalize s
    | s+1 < length m                            = rref_step (s+1) (elim s)
    | otherwise                                 = normalize s
    where
        coef s          = length ( filter (\i-> i/=0) (getRowMat m s) )
        ones s          = length ( filter (\i-> i==1) (getRowMat m s) )
        emptyUntil s r  = 0 == length ( filter (\i-> i/=0) (take s (getColMat m r)))
        normalize s     = map (\y-> if(m!!y!!s /= 0 && emptyUntil s y)then(map (/m!!y!!s) (m!!y))else(m!!y) ) [0..((length m)-1)]
        newPivot n s    = (take 1 (filter (\y-> (emptyUntil s y) && (n!!y!!s==1)) [0..((length n)-1)]))
        elim s          = do
                            let n = normalize s
                            let np = (newPivot n s)!!0
                            map (\y-> if(n!!y!!s /=0 && y/=np)then( map (\x-> (n!!y!!x)- ((n!!y!!s)*(n!!np!!x))) [0..((length (n!!0))-1)] )else( n!!y )) [0..((length n)-1)]

dimKer :: (Fractional a, Eq a) => [[a]] -> Int
dimKer m = length $ filter (\e-> 0 == (length ( filter (\i-> i/=0) e)) ) (rref m)

--rank :: (Fractional a, Eq a) => [[a]] -> Int
rank m = length m - dimKer m

ker :: (Fractional a, Eq a) => [[a]] -> Maybe [[a]]
ker m
    | det m /= 0 = Nothing
    | otherwise = do
        let r = rref m
        let f = filter (\i-> any (\j-> j/=0) i) r
        Just f

solvMat :: Fractional a => [[a]] -> [a] -> [a]
solvMat m v = map (\x-> det (replCol m x v) / det m) [0..((length (m!!0))-1)]

--jord :: Num a => [[a]] -> [[a]]
--jord m =

--charpoly :: Num a => [[a]] -> a -> a
--charpoly m x = det (matadd m (matscalmult (matid (length m)) x ))
--
--eigenVal :: (RealFrac a, Enum a, Integral b) => [[a]] -> [b]
--eigenVal m = filter (\i-> i/=0) $ remDupl $ map (round) $ filter (\x -> round (charpoly m x)>(-10) && round (charpoly m x)<10) [-20,-19.9 .. 20]
--
--geoMult :: (Fractional a, Eq a) => [[a]] -> a -> Int
--geoMult m e = dimKer $ matadd (matscalmult (matid (length (sqrify m))) e) (matscalmult m (-1))

tr :: Num a => [[a]] -> a
tr m = sum $ map (\i -> (sqrify m)!!i!!i) [0..((length (m!!0))-1)]

polyadd :: Num a => [a] -> [a] -> [a]
polyadd p q
    | length p < length q = polyadd q p
    | otherwise = [ p!!x + if(x<length q)then(q!!x)else(0) | x<- [0..((length p)-1)]]

polymonomult :: Num a => [a] -> (a,Int) -> [a]
polymonomult p m = [0| x<-[1..(snd m)]] ++ map (* (fst m)) p

--polymult :: Num a => [a] -> [a] -> [a]
polymult p q = finish $ map (\i -> polymonomult q (p!!i,i) ) [0..((length p)-1)]
    where
        finish x
            | length x == 1 = x
            | otherwise = finish $ polyadd (x!!0) (x!!1) : tail (tail x)

--jnf :: Num a => [[a,Int,Int]] => [[a]]

--algMult ::
--algMult m es =
--    where s = length (sqrify m)
--
--partitions :: Int -> [Int]
--partitions x =

dotprod :: Num a => [a] -> [a] -> a
dotprod v w = sum $ matvecmult (vectrans v) w

orthoVec :: (Num a, Eq a) => [a] -> [a] -> Bool
orthoVec v w = (dotprod v w) == 0

adjo :: RealFloat a => [[Complex a]] -> [[Complex a]]
adjo m = transpose $ matcon m

ortho :: (Num a, Eq a) => [[a]] -> Bool
ortho m = matid (length (sqrify m)) == matmult m (transpose m)

hermit :: RealFloat a => [[Complex a]] -> Bool
hermit m = adjo m == m

unitar :: RealFloat a => [[Complex a]] -> Bool
unitar m = adjo m == fromMaybe [[0]] (inv m)

kroneck :: Num a => [[a]] -> [[a]] -> [[a]]
kroneck m n = [
            [ (m!!( yPosM y )!!( xPosM x )) * (n!!( yPosN y )!!( xPosN x ))
        | x<-[0..((length (m!!0))*(length (n!!0))-1)]]
    | y<-[0..((length m)*(length n)-1)]]
    where
        yPosM y = y `mod` (length m)
        xPosM x = x `mod` (length (m!!0))
        yPosN y = if (y==0)then(0)else( y `div` (length m) )
        xPosN x = if (x==0)then(0)else( x `div` (length (m!!0)) )


module Trade.Statistics.Summary where

import Control.Applicative (liftA2)

import qualified Data.Map as Map

import qualified Data.Vector as Vec

import qualified Statistics.Sample as Sample

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

import Trade.Type.NestedMap (NestedMap(..))

import Trade.Type.Position (Position(..))
import Trade.Type.WinningLosing (WinningLosing(..))

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

import Trade.Report.Pretty (pretty)
import qualified Trade.Report.Table as Table
import Trade.Report.ToReport (ToReport, toReport)

data Summary = Summary {
  totalTrades :: Int
  , profitFactor :: Double
  , avgProfit :: Double
  , stdDevProfit :: Double
  , winners :: Int
  , largestWinner :: Double
  , avgWinner :: Double
  , losers :: Int
  , largestLoser :: Double
  , avgLoser :: Double
  , cumulativeProfit :: Double
  }

summary :: [LogYield ohlc] -> [LogYield ohlc] -> Summary
summary wins losses =
  let ws = Vec.fromList (map logYield wins)
      ls = Vec.fromList (map logYield losses)
  in Summary {
    totalTrades = length wins + length losses
    , profitFactor = exp (sum ws) / exp (sum ls)
    , avgProfit = exp (Sample.mean (Vec.concat [ws, ls]))
    , stdDevProfit = exp (Sample.stdDev ws)

    , winners = Vec.length ws
    , largestWinner = exp (Vec.maximum ws)
    , avgWinner = exp (Sample.mean ws)

    , losers = Vec.length ls
    , largestLoser = exp (Vec.minimum ls)
    , avgLoser = exp (Sample.mean ls)

    , cumulativeProfit = exp (sum ws + sum ls)
    }

summary2table :: Summary -> [[String]]
summary2table ys =
  [ [ "Summary" ]
  , []
  , [ "Total trades", pretty (totalTrades ys) ]
  , [ "Profit factor", pretty (profitFactor ys) ]
  , [ "Avg. profit", pretty (avgProfit ys) ]
  , [ "StdDev. profit", pretty (stdDevProfit ys) ]
  , []
  , [ "Winners", pretty (winners ys) ]
  , [ "Largest winner", pretty (largestWinner ys) ]
  , [ "Avg. winner", pretty (avgWinner ys) ]
  , []
  , [ "Losers", pretty (losers ys) ]
  , [ "Largest loser", pretty (largestLoser ys) ]
  , [ "Avg. loser", pretty (avgLoser ys) ]
  , []
  , [ "Cumulativ profit", pretty (cumulativeProfit ys) ]
  ]

instance ToReport Summary where
  toReport = Table.table . summary2table

toSummary ::
  NestedMap Position WinningLosing [DeltaSignal ohlc] -> Maybe Summary
toSummary (NestedMap m) =
  let nm = fmap (fmap (map DSA.yield)) m
      win = Map.lookup Invested nm >>= Map.lookup Winning
      lose = Map.lookup Invested nm >>= Map.lookup Losing
  in liftA2 summary win lose


module Layer where
import Numeric.LinearAlgebra
import Utils

data LayerType =
  SigmoidLayer
  | LinearLayer
  | SoftmaxLayer
  | ReluLayer

data VLayer = VLayer {
  layerType :: LayerType,
  rowNum :: Int,
  colNum :: Int,
  weight :: Matrix R,
  bias :: Matrix R,
  val :: Matrix R,
  delta :: Matrix R
  }

{-- Linear Layer --}
linearLayerInit :: Int -> Int -> VLayer
linearLayerInit r c = VLayer {
  layerType = LinearLayer,
  rowNum = r,
  colNum = c,
  weight = (r >< c) genNormal,
  bias = (r >< c) genNormal,
  val = (r >< c) [0..]
                                }

forwardLinearLayer :: Matrix R -> VLayer -> Matrix R
forwardLinearLayer input inputLayer = (weight inputLayer) * input + (bias inputLayer)

backwardLinearLayer :: Matrix R -> VLayer -> Matrix R
backwardLinearLayer backInput inputLayer = backInput

{-- Sigmoid Layer --}
sigmoidLayerInit :: Int -> Int -> VLayer
sigmoidLayerInit r c = VLayer {
  layerType = SigmoidLayer,
  rowNum = r,
  colNum = c,
  weight = (r >< c) genNormal,
  bias = (r >< c) genNormal,
  val = (r >< c) [0..]
  }

getSigmoidMatrix :: Matrix R -> Matrix R
getSigmoidMatrix linear = 1.0 / (1.0 + (exp (- linear)))

forwardSigmoidLayer :: Matrix R -> VLayer -> Matrix R
forwardSigmoidLayer input layer =
  let linear = (weight layer) * input + (bias layer) in
  getSigmoidMatrix linear

backwardSigmoidLayer :: Matrix R -> VLayer -> Matrix R
backwardSigmoidLayer input layer =
  let linear = (weight layer) * input + (bias layer) in
  let sigmoid = getSigmoidMatrix linear in
  sigmoid * (1.0 - sigmoid)

{-- Softmax Layer --}
softmaxLayerInit :: Int -> Int -> VLayer
softmaxLayerInit r c = VLayer {
  layerType = SoftmaxLayer,
  rowNum = r,
  colNum = c,
  weight = (r >< c) genNormal,
  bias = (r >< c) genNormal,
  val = (r >< c) [0..]
                                        }

-- TODO: backward of softmax layer

{-- Relu Layer --}
reluLayerInit :: Int -> Int -> VLayer
reluLayerInit r c = VLayer {
  layerType = ReluLayer,
  rowNum = r,
  colNum = c,
  weight = (r >< c
           ) genNormal,
  bias = (r >< c) genNormal,
  val = (r >< c) [0..]
                                     }
forwardReluLayer :: Matrix R -> VLayer -> Matrix R
forwardReluLayer input layer =
  let flagMatrix = cmap (\x -> if x >= 0.0 then 1.0 else 0.0 ) (weight layer) in
  flagMatrix * input

backwardReluLayer :: Matrix R -> VLayer -> Matrix R
backwardReluLayer backInput layer =
  cmap (\x -> if x <= 0.0 then x else 0.0) backInput