{-# LANGUAGE DataKinds, GADTs, LambdaCase, NoImplicitPrelude, RankNTypes #-}
{-# LANGUAGE TypeApplications, TypeOperators                             #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# OPTIONS_GHC -Wno-type-defaults #-}
{-# OPTIONS_GHC -fplugin Data.Singletons.TypeNats.Presburger #-}
module Algebra.Algorithms.Groebner.ZeroDimSpec where
import           Algebra.Algorithms.Groebner
import           Algebra.Algorithms.ZeroDim
import           Algebra.Internal
import           Algebra.Internal
import           Algebra.Prelude.Core             hiding ((%))
import           Algebra.Ring.Ideal
import           Algebra.Ring.Polynomial
import           Algebra.Ring.Polynomial.Quotient
import qualified Prelude                          as P

import           Control.Monad
import           Control.Monad.Random
import           Data.Complex
import           Data.Convertible       (convert)
import qualified Data.Foldable          as F
import qualified Data.Matrix            as M
import           Data.Maybe
import qualified Data.Sized.Builtin     as SV
import qualified Data.Vector            as V
import           Numeric.Field.Fraction (Fraction, (%))
import           Numeric.Natural
import           Test.Hspec
import           Test.Hspec.QuickCheck
import           Test.HUnit
import           Test.QuickCheck        hiding (promote)
import           Utils

default (Fraction Integer, Natural)

asGenListOf :: Gen [a] -> a -> Gen [a]
asGenListOf = const

spec :: Spec
spec = parallel $ do
  describe "solveLinear" $ do
    it "solves data set correctly" $
      forM_ linSet $ \set ->
      solveLinear (M.fromLists $ inputMat set) (V.fromList $ inputVec set)
      `shouldBe` Just (V.fromList $ answer set)
    prop "solves any solvable cases" $
      forAll (resize 10 arbitrary) $ \(MatrixCase ms) ->
      let mat = M.fromLists ms :: M.Matrix (Fraction Integer)
      in rank mat == M.ncols mat ==>
           forAll (vector (length $ head ms)) $ \v ->
             let ans = M.getCol 1 $ mat P.* M.colVector (V.fromList v)
             in solveLinear mat ans == Just (V.fromList v)
    it "cannot solve unsolvable cases" $
      pendingWith "need example"
  describe "univPoly" $ modifyMaxSuccess (const 25) $ modifyMaxSize (const 4) $
    prop "produces monic generators of the elimination ideal" $
      checkForTypeNat [2..4] prop_univPoly
  describe "radical" $
    it "really computes radical" $
      pendingWith "We can verify correctness by comparing with singular, but it's not quite smart way..."

  describe "fglm" $ modifyMaxSuccess (const 25) $ modifyMaxSize (const 3) $ do
    prop "computes monomial basis" $
      checkForTypeNat [2..4] $ \sdim ->
        case zeroOrSucc sdim of
          IsZero -> error "impossible"
          IsSucc k ->
            withWitness (lneqSucc k) $ withWitness (lneqZero k) $
            withKnownNat k $
            forAll (zeroDimOf sdim) $ \(ZeroDimIdeal ideal) ->
            let base =
                  reifyQuotient (mapIdeal (changeOrder Lex) ideal) $ \ii ->
                  map quotRepr $ fromJust $ standardMonomials' ii
            in stdReduced (snd $ fglm ideal) == stdReduced base
    prop "computes lex base" $
      checkForTypeNat [2..4] $ \sdim ->
        case zeroOrSucc sdim of
          IsZero -> error "impossible"
          IsSucc k -> withKnownNat k $
            withWitness (lneqSucc k) $
            withWitness (lneqZero k) $
            forAll (zeroDimOf sdim) $ \(ZeroDimIdeal ideal) ->
            stdReduced (fst $ fglm ideal)
              == stdReduced (calcGroebnerBasisWith Lex ideal)
    prop "returns lex base in descending order" $
      checkForTypeNat [2..4] $ \sdim ->
      case zeroOrSucc sdim of
        IsZero -> error "impossible"
        IsSucc k -> withKnownNat k $
          case (lneqSucc k, lneqZero k) of
            (Witness, Witness) ->
              forAll (zeroDimOf sdim) $ \(ZeroDimIdeal ideal) ->
              isDescending (map leadingMonomial $ fst $ fglm ideal)
  describe "solve'" $ modifyMaxSuccess (const 50) $ modifyMaxSize (const 4) $ do
    it "solves equation with admissible error" $
      checkForTypeNat [2..4] $ prop_isApproximateZero 1e-5 (pure . solve' 1e-5)
    describe "solves regression cases correctly" $
      forM_ companionRegressions $
      approxZeroTestCase 1e-5 (pure . solve' 1e-5)

  describe "solveViaCompanion" $
    modifyMaxSuccess (const 50) $ modifyMaxSize (const 4) $ do
    it "solves equation with admissible error" $
      checkForTypeNat [2..4] $ prop_isApproximateZero 1e-5
        (pure . solveViaCompanion 1e-5)
    describe "solves regression cases correctly" $
      forM_ companionRegressions $
      approxZeroTestCase 1e-5 (pure . solveViaCompanion 1e-5)

  describe "solveM" $ modifyMaxSuccess (const 50) $ modifyMaxSize (const 4) $ do
    prop "solves equation with admissible error" $
      checkForTypeNat [2..4] $ prop_isApproximateZero 1e-9 solveM
    describe "solves regressions correctly" $
      forM_ companionRegressions $
      approxZeroTestCase 1e-9 solveM

isDescending :: Ord a => [a] -> Bool
isDescending xs = and $ zipWith (>=) xs (drop 1 xs)

prop_isApproximateZero
  :: (KnownNat n)
  => Double
  -> (forall m. ((0 < m) ~ 'True, KnownNat m) =>
      Ideal (Polynomial (Fraction Integer) m) -> IO [Sized m (Complex Double)])
  -> SNat n -> Property
prop_isApproximateZero err solver sn =
  case zeroOrSucc sn of
    IsSucc _ -> withKnownNat sn $
      forAll (zeroDimOf sn) $ ioProperty . checkSolverApproxZero err solver
    IsZero -> error "prop_isApproximateZero must be called with non-zero typenats!"

companionRegressions
  :: [SolverTestCase]
companionRegressions =
  [ SolverTestCase @3 $
    let [x,y,z] = vars
    in ZeroDimIdeal $ toIdeal
        [ 2*x^2 + (0.5 :: Fraction Integer) .*. x * y
        , -(0.5 :: Fraction Integer) .*. y ^ 2 + y * z
        , z^2 - z]
  , SolverTestCase @3 $
    let [x,y,z] = vars
    in ZeroDimIdeal $ toIdeal
        [ 2*x + 1, 2*y^2,-z^2 - 1]
  , SolverTestCase @2 $
    let [x,y] = vars
    in ZeroDimIdeal $ toIdeal
        [ x^2 - y, -2*y^2]
  ]

approxZeroTestCase
  :: Double
  -> (forall n. ((0 < n) ~ 'True, KnownNat n)
        => Ideal (Polynomial (Fraction Integer) n) -> IO [Sized n (Complex Double)]
      )
  -> SolverTestCase
  -> SpecWith ()
approxZeroTestCase err calc (SolverTestCase f@(ZeroDimIdeal i)) =
  it (show $ getIdeal f) $ do
    isZeroDimensional (F.toList i) @? "Not zero-dimensional!"
    checkSolverApproxZero err calc f
      @? "Solved correctly"

checkSolverApproxZero
  :: ((0 < n) ~ 'True, KnownNat n)
  => Double
  -> (Ideal (Polynomial (Fraction Integer) n) -> IO [Sized n (Complex Double)])
  -> ZeroDimIdeal n
  -> IO Bool
checkSolverApproxZero err solver (ZeroDimIdeal ideal) = do
  anss <- solver ideal
  let mul r d = convert r * d
  pure
    $ all (\as -> all ((<err) . magnitude . substWith mul as)
    $ generators ideal) anss

data SolverTestCase where
  SolverTestCase
    :: ((0 < n) ~ 'True, KnownNat n)
    => ZeroDimIdeal n -> SolverTestCase

prop_univPoly :: KnownNat n => SNat n -> Property
prop_univPoly sdim =
  forAll (zeroDimOf sdim) $ \(ZeroDimIdeal ideal) ->
  let ods = enumOrdinal sdim
  in conjoin $ flip map ods $ \nth ->
  let gen = univPoly nth ideal
  in forAll (unaryPoly sdim nth) $ \f ->
  (f `modPolynomial` [gen] == 0) == (f `isIdealMember` ideal)

rank :: (Ord r, Fractional r) => M.Matrix r -> Int
rank mat =
  let Just (u, _, _, _,_, _) = M.luDecomp' mat
  in V.foldr (\a acc -> if a /= 0 then acc + 1 else acc) (0 :: Int) $ M.getDiag u

data TestSet = TestSet { inputMat :: [[Fraction Integer]]
                       , inputVec :: [Fraction Integer]
                       , answer   :: [Fraction Integer]
                       } deriving (Show, Eq, Ord)

linSet :: [TestSet]
linSet =
  [TestSet
   [[1 ,0 ,0 ,0 ,0 ]
   ,[0 ,(-2) ,(-2) ,(-2) ,(-2) ]
   ,[0 ,0 ,3 % 2,0 ,(-1) % 2]
   ,[0 ,0 ,0 ,0 ,(-5) % 2]
   ,[0 ,1 ,1 ,1 ,1 ]
   ,[0 ,0 ,(-2) ,1 ,(-1) ]
   ]
   [0 ,(-2) ,19 % 5,14 % 5,1 ,0 ]
   [0 ,(-81) % 25,54 % 25,16 % 5,(-28) % 25]
  ]


module AND where

import Numeric.LinearAlgebra
import AI.HNN.FF.Network

samples :: Samples Double
samples = [ (fromList [0,0], fromList [1,0])
          , (fromList [0,1], fromList [1,0])
          , (fromList [1,0], fromList [1,0])
          , (fromList [1,1], fromList [0,1]) ]

run :: IO ()
run = do
    n <- createNetwork 2 [2] 2
    mapM_ (print . output n tanh . fst) samples
    putStrLn "----------------"
    let n' = trainNTimes 1000 0.8 tanh tanh' n samples
    mapM_ (print . output n' tanh . fst) samples


{-# LANGUAGE FlexibleContexts #-}
-- | Pearson's chi squared test.
module Statistics.Test.ChiSquared (
    chi2test
  , chi2testCont
  , module Statistics.Test.Types
  ) where

import Prelude hiding (sum)

import Statistics.Distribution
import Statistics.Distribution.ChiSquared
import Statistics.Function        (square)
import Statistics.Sample.Internal (sum)
import Statistics.Test.Types
import Statistics.Types
import qualified Data.Vector as V
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U

-- | Generic form of Pearson chi squared tests for binned data. Data
--   sample is supplied in form of tuples (observed quantity,
--   expected number of events). Both must be positive.
--
--   This test should be used only if all bins have expected values of
--   at least 5.
chi2test :: (G.Vector v (Int,Double), G.Vector v Double)
         => Int                 -- ^ Number of additional degrees of
                                --   freedom. One degree of freedom
                                --   is due to the fact that the are
                                --   N observation in total and
                                --   accounted for automatically.
         -> v (Int,Double)      -- ^ Observation and expectation.
         -> Maybe (Test ChiSquared)
chi2test ndf vec
  | ndf <  0  = error $ "Statistics.Test.ChiSquare.chi2test: negative NDF " ++ show ndf
  | n   > 0   = Just Test
              { testSignificance = mkPValue $ complCumulative d chi2
              , testStatistics   = chi2
              , testDistribution = chiSquared ndf
              }
  | otherwise = Nothing
  where
    n     = G.length vec - ndf - 1
    chi2  = sum $ G.map (\(o,e) -> square (fromIntegral o - e) / e) vec
    d     = chiSquared n
{-# INLINABLE  chi2test #-}
{-# SPECIALIZE
    chi2test :: Int -> U.Vector (Int,Double) -> Maybe (Test ChiSquared) #-}
{-# SPECIALIZE
    chi2test :: Int -> V.Vector (Int,Double) -> Maybe (Test ChiSquared) #-}

-- | Chi squared test for data with normal errors. Data is supplied in
--   form of pair (observation with error, and expectation).
chi2testCont
  :: (G.Vector v (Estimate NormalErr Double, Double), G.Vector v Double)
  => Int                                   -- ^ Number of additional
                                           --   degrees of freedom.
  -> v (Estimate NormalErr Double, Double) -- ^ Observation and expectation.
  -> Maybe (Test ChiSquared)
chi2testCont ndf vec
  | ndf < 0   = error $ "Statistics.Test.ChiSquare.chi2testCont: negative NDF " ++ show ndf
  | n   > 0   = Just Test
              { testSignificance = mkPValue $ complCumulative d chi2
              , testStatistics   = chi2
              , testDistribution = chiSquared ndf
              }
  | otherwise = Nothing
  where
    n     = G.length vec - ndf - 1
    chi2  = sum $ G.map (\(Estimate o (NormalErr s),e) -> square (o - e) / s) vec
    d     = chiSquared n


{-# OPTIONS_GHC -Wall                     #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing  #-}
{-# OPTIONS_GHC -fno-warn-type-defaults   #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind  #-}
{-# OPTIONS_GHC -fno-warn-missing-methods #-}
{-# OPTIONS_GHC -fno-warn-orphans         #-}

{-# LANGUAGE MultiParamTypeClasses        #-}
{-# LANGUAGE TypeFamilies                 #-}
{-# LANGUAGE ScopedTypeVariables          #-}
{-# LANGUAGE DataKinds                    #-}

module MultivariateNormal ( MultivariateNormal(..) ) where

import           Data.Random hiding ( StdNormal, Normal )
import qualified Data.Random as R
import           Control.Monad.State ( replicateM )
import qualified Numeric.LinearAlgebra.HMatrix as H
import           Numeric.LinearAlgebra.Static
                 ( R, vector, extract, Sq, Sym, col,
                   tr, linSolve, uncol, chol, (<.>),
                   ℝ, (<>), diag, (#>), eigensystem
                 )
import          GHC.TypeLits ( KnownNat, natVal )
import          Data.Maybe ( fromJust )

normalMultivariate :: KnownNat n =>
                      R n -> Sym n -> RVarT m (R n)
normalMultivariate mu bigSigma = do
  z <- replicateM (fromIntegral $ natVal mu) (rvarT R.StdNormal)
  return $ mu + bigA #> (vector z)
  where
    (vals, bigU) = eigensystem bigSigma
    lSqrt = diag $ mapVector sqrt vals
    bigA = bigU <> lSqrt

mapVector :: KnownNat n => (ℝ -> ℝ) -> R n -> R n
mapVector f = vector . H.toList . H.cmap f . extract

sumVector :: KnownNat n => R n -> ℝ
sumVector x = x <.> 1

data family MultivariateNormal k :: *

data instance MultivariateNormal (R n) = MultivariateNormal (R n) (Sym n)

instance KnownNat n => Distribution MultivariateNormal (R n) where
  rvar (MultivariateNormal m s) = normalMultivariate m s

normalLogPdf :: KnownNat n =>
                R n -> Sym n -> R n -> Double
normalLogPdf mu bigSigma x = - sumVector (mapVector log (takeDiag' dec))
                             - 0.5 * (fromIntegral $ natVal mu) * log (2 * pi)
                             - 0.5 * s
  where
    dec = chol bigSigma
    t = uncol $ fromJust $ linSolve (tr dec) (col $ x - mu)
    u = mapVector (\x -> x * x) t
    s = sumVector u

normalPdf :: KnownNat n =>
             R n -> Sym n -> R n -> Double
normalPdf mu sigma x = exp $ normalLogPdf mu sigma x

takeDiag' :: KnownNat n => Sq n -> R n
takeDiag' = vector . H.toList . H.takeDiag . extract

instance KnownNat n => PDF MultivariateNormal (R n) where
  pdf (MultivariateNormal m s) = normalPdf m s
  logPdf (MultivariateNormal m s) = normalLogPdf m s


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

module MachineLearning.Regression
(
  Model.Model(..)
  , LeastSquares.LeastSquaresModel(..)
  , Optimization.MinimizeMethod(..)
  , Optimization.minimize
  , normalEquation
  , normalEquation_p
  , Regularization(..)
)

where

import Prelude hiding ((<>))
import MachineLearning.Types (Vector, Matrix)
import MachineLearning.Optimization as Optimization
import MachineLearning.Model as Model
import MachineLearning.LeastSquaresModel as LeastSquares
import MachineLearning.Regularization (Regularization(..))

import qualified Numeric.LinearAlgebra as LA
import Numeric.LinearAlgebra ((<>), (#>))

-- | Normal equation using inverse, does not require feature normalization
-- It takes X and y, returns theta.
normalEquation :: Matrix -> Vector -> Vector
normalEquation x y =
  let trX = LA.tr x
  in (LA.inv (trX <> x) <> trX) #> y

-- | Normal equation using pseudo inverse, requires feature normalization
-- It takes X and y, returns theta.
normalEquation_p :: Matrix -> Vector -> Vector
normalEquation_p x y =
  let trX = LA.tr x
  in (LA.pinv (trX <> x) <> trX) #> y


module Xor where

import Nnaskell
import Numeric.LinearAlgebra.Data

xorNN = do nn <- randomNN [2, 2, 1]
           return $ head $ drop 5000 $ optimizeCost (cost xorTD) nn

xorTD :: [(Vector R, Vector R)]
xorTD = [ (vector [0.0, 0.0], vector [0.0])
        , (vector [1.0, 0.0], vector [1.0])
        , (vector [0.0, 1.0], vector [1.0])
        , (vector [1.0, 1.0], vector [0.0])
        ]


{-# LANGUAGE FlexibleContexts #-}
-- |
-- Module    : Statistics.Autocorrelation
-- Copyright : (c) 2009 Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- Functions for computing autocovariance and autocorrelation of a
-- sample.

module Statistics.Autocorrelation
    (
      autocovariance
    , autocorrelation
    ) where

import Prelude hiding (sum)
import Statistics.Function (square)
import Statistics.Sample (mean)
import Statistics.Sample.Internal (sum)
import qualified Data.Vector.Generic as G

-- | Compute the autocovariance of a sample, i.e. the covariance of
-- the sample against a shifted version of itself.
autocovariance :: (G.Vector v Double, G.Vector v Int) => v Double -> v Double
autocovariance a = G.map f . G.enumFromTo 0 $ l-2
  where
    f k = sum (G.zipWith (*) (G.take (l-k) c) (G.slice k (l-k) c))
          / fromIntegral l
    c   = G.map (subtract (mean a)) a
    l   = G.length a

-- | Compute the autocorrelation function of a sample, and the upper
-- and lower bounds of confidence intervals for each element.
--
-- /Note/: The calculation of the 95% confidence interval assumes a
-- stationary Gaussian process.
autocorrelation :: (G.Vector v Double, G.Vector v Int) => v Double -> (v Double, v Double, v Double)
autocorrelation a = (r, ci (-), ci (+))
  where
    r           = G.map (/ G.head c) c
      where c   = autocovariance a
    dllse       = G.map f . G.scanl1 (+) . G.map square $ r
      where f v = 1.96 * sqrt ((v * 2 + 1) / l)
    l           = fromIntegral (G.length a)
    ci f        = G.cons 1 . G.tail . G.map (f (-1/l)) $ dllse


module Mandelbrot where

import Data.Complex
import Data.Maybe
import Data.Word
import qualified Data.Array.Repa as R
import Data.Array.Repa hiding (map,zip,foldr)

mandelbrot :: Complex Double -> Complex Double -> Complex Double
mandelbrot c z = z*z + c

isMandelbrot :: Int -> Complex Double -> Maybe Int
isMandelbrot n c = case (n' < n) of
                     True -> Just n'
                     False -> Nothing
  where
    m = iterate (mandelbrot c) 0
    n' = length . take n . takeWhile (\z -> magnitude z < 2) $ m

isMandelbrot2 :: Int -> Complex Double -> Int
isMandelbrot2 n c = case (n' < n) of
                      True ->   n'
                      False -> (-1)
  where
    m = iterate (mandelbrot c) 0
    n' = length. take n . takeWhile (\z -> magnitude z <2) $ m

array :: Double -> Complex Double -> Int -> Array D DIM2 (Complex Double)
array size centre n = fromFunction (Z:.n:.n) posToVal
  where
    dx = size / (fromIntegral n)
    posToVal (Z:.i:.j) = (((fromIntegral i)*dx - size/2) :+ ((fromIntegral j)*dx - size/2)) + centre

genMandelbrot :: Int -> Int -> Double -> Complex Double -> Array D DIM2 (Word8,Word8,Word8)
genMandelbrot res n size centre = cs
  where
    zs = array size centre res
    cs = R.map (toColor2 . isMandelbrot2 n) zs
    --cs = R.map toColor ms

toColor2 :: Int -> (Word8,Word8,Word8)
toColor2 n = case (n==(-1)) of
               True  -> (0,0,0)
               False -> (255 - (fromIntegral n),fromIntegral n,50)

toColor :: Maybe Int -> (Word8,Word8,Word8)
toColor (Just n) = (255-(fromIntegral n),(fromIntegral n),(fromIntegral n))
toColor Nothing  = (0,0,0)

toBw2 :: Int -> (Word8, Word8, Word8)
toBw2 n = case (n==(-1)) of
            True  -> (0,0,0)
            False ->(255-n', 255-n', 255-n')
  where n' = fromIntegral n

toBw :: Maybe Int -> (Word8,Word8,Word8)
toBw (Just n') = let n = fromIntegral n' in (255-n,255-n,255-n)
toBw Nothing = (0,0,0)


{-# LANGUAGE FlexibleInstances #-}

module HVX.SymbolicSubgradSpec (main, spec) where

import Test.Hspec
import Test.QuickCheck hiding ((><))
import Numeric.LinearAlgebra

import HVX.Primitives
import HVX.Internal.Matrix
import HVX.Internal.Primitives
import HVX.Internal.TestUtil
import HVX.Internal.SymbolicSubgrad

main :: IO ()
main = hspec spec

spec :: Spec
spec = describe "SymbolicSubgrad" $ do
  evaluateSpec
  jacobianWrtVarSpec

evaluateSpec :: Spec
evaluateSpec = describe "evaluate" $ do

  describe "log/exp" $
    it "log(exp(x)) = x" $ property $
      forAll smallVectors $
        \x -> fpequalsMat
          (evaluate (EVar "x") [("x", x)])
          (evaluate (EFun Log (EFun Exp (EVar "x"))) [("x", x)])

  describe "log_sum_exp" $
    it "log_sum_exp(x) = log(ones'*exp(x))" $ property $
      forAll smallVectors $
        \x -> let n = rows x in
          fpequalsMat
            (evaluate (EFun LogSumExp (EVar "x")) [("x", x)])
            (evaluate
              (EFun Log
                (EFun (Mul (konst 1.0 (1, n)))
                  (EFun Exp (EVar "x"))))
              [("x", x)])

  describe "max/min" $
    it "max(x) = -min(-x)" $ property $
      forAll vectors $
        \x -> fpequalsMat
          (evaluate (EFun Max (EVar "x")) [("x", x)])
          (evaluate (EFun Neg (EFun Min (EFun Neg (EVar "x")))) [("x", x)])

  describe "lpnorm" $ do
    it "lpnorm(x, 1) = sum(abs(x))" $ property $
      forAll vectors $
        \x -> fpequalsMat
          (evaluate
            (norm 1 (EVar "x"))
            [("x", x)])
          (evaluate
            (EFun (Mul (konst 1.0 (1, (rows x)))) (habs (EVar "x")))
            [("x", x)])
    it "lpnorm(x, 2)^2 = x^T * x" $ property $
      forAll vectors $
        \x -> fpequalsMat
          (tr x <> x)
          (evaluate
            (EFun (PowBaseP1InfEven 2) (norm 2 (EVar "x")))
            [("x", x)])

  describe "quadform" $
    it "quadform(I, x) = x^T x" $ property $
      forAll vectors $
        \x -> fpequalsMat
          (evaluate
            (EFun (Quadform (ident $ rows x)) (EVar "x"))
            [("x", x)])
          (tr x <> x)

  describe "pow (base variable)" $ do
    it "(x^a)^(1/a) = x (a non integral, a > 1)" $ property $
      forAll (pairsOf positiveVectors smallNonIntPowersGreaterThanOne) $
        \(x, p) -> fpequalsMat
          (evaluate (EVar "x") [("x", x)])
          (evaluate
            (EFun (PowBaseP1InfNotInt p) (EFun (PowBaseP01 (1.0/p)) (EVar "x")))
            [("x", x)])
    it "(x^a)^(1/a) = x (a even, a > 1)" $ property $
      forAll (pairsOf positiveVectors smallEvenPowersGreaterThanOne) $
        \(x, p) -> fpequalsMat
          (evaluate (EVar "x") [("x", x)])
          (evaluate
            (EFun (PowBaseP1InfEven (round p :: Integer)) (EFun (PowBaseP01 (1.0/p)) (EVar "x")))
            [("x", x)])

jacobianWrtVarSpec :: Spec
jacobianWrtVarSpec = describe "jacobianWrtVar" $ do

  it "works with respect to a variable that doesn't occur in Expr." $
    forAll (pairsOf vectors vectors) $
      \(x, y) -> fpequalsMat
        (jacobianWrtVar
          (EVar "x")
          [("x", x), ("y", y)]
          "y")
        (konst 0.0 ((rows x), (rows y)))

  describe "log/exp" $
    it "log(exp(x)) - x has zero jacobian" $ property $
      forAll smallVectors $
        \x -> fpequalsMat
          (jacobianWrtVar
            (EAdd (EFun Log (EFun Exp (EVar "x"))) (EFun Neg (EVar "x")))
            [("x", x)]
            "x")
          (zeroMat $ rows x)

  describe "log_sum_exp" $
    it "jacobian log_sum_exp(x) = jacobian log(ones'*exp(x))" $ property $
      forAll smallVectors $
        \x -> fpequalsMat
          (jacobianWrtVar (EFun LogSumExp (EVar "x")) [("x", x)] "x")
          (jacobianWrtVar
            (EFun Log
              (EFun (Mul (konst 1.0 (1, (rows x))))
                (EFun Exp (EVar "x"))))
            [("x", x)]
            "x")

  describe "max/min" $
    it "max(x) + min(-x) has zero jacobian" $ property $
      forAll vectors $
        \x -> fpequalsMat
          (jacobianWrtVar
            (EAdd (EFun Max (EVar "x")) (EFun Min (EFun Neg (EVar "x"))))
            [("x", x)]
            "x")
          (tr $ zeroVec $ rows x)

  describe "lpnorm" $ do
    it "jacobian lpnorm(x, 1) = jacobian sum(abs(x))" $ property $
      forAll vectors $
        \x -> fpequalsMat
          (jacobianWrtVar
            (norm 1 (EVar "x"))
            [("x", x)]
            "x")
          (jacobianWrtVar
            (EFun (Mul (konst 1.0 (1, (rows x)))) (habs (EVar "x")))
            [("x", x)]
            "x")
    it "jacobian lpnorm(0, 2) = 0" $ property $
      \(Positive n) -> fpequalsMat
        (jacobianWrtVar (norm 2 (EVar "x")) [("x", zeroVec n)] "x")
        (tr $ zeroVec n)

  describe "quadform" $
    it "jacobian quadform(I, x) = jacobian lpnorm(x, 2)^2" $ property $
      forAll vectors $
        \x -> fpequalsMat
          (jacobianWrtVar (EFun (Quadform (ident $ rows x)) (EVar "x")) [("x", x)] "x")
          (jacobianWrtVar (EFun (PowBaseP1InfEven 2) (norm 2 (EVar "x"))) [("x", x)] "x")

  describe "pow (base variable)" $ do
    it "(x^a)^(1/a) - x has zero jacobian (a non integral, a > 1)" $ property $
      forAll (pairsOf positiveVectors smallNonIntPowersGreaterThanOne) $
        \(x, p) -> fpequalsMat
          (jacobianWrtVar
            (EAdd
              (EFun (PowBaseP1InfNotInt p) (EFun (PowBaseP01 (1.0/p)) (EVar "x")))
              (EFun Neg (EVar "x")))
            [("x", x)]
            "x")
          (zeroMat $ rows x)
    it "(x^a)^(1/a) - x has zero jacobian (a even, a > 1)" $ property $
      forAll (pairsOf positiveVectors smallEvenPowersGreaterThanOne) $
        \(x, p) -> fpequalsMat
          (jacobianWrtVar
            (EAdd
              (EFun (PowBaseP1InfEven (round p :: Integer)) (EFun (PowBaseP01 (1.0/p)) (EVar "x")))
              (neg (EVar "x")))
            [("x", x)]
            "x")
          (zeroMat $ rows x)


import Mnist
import Runner
import Backprop

import Numeric.LinearAlgebra
import Data.List
import System.Random

learningRate = 0.007

smallRandoms :: Int -> [Double]
smallRandoms seed = map (/100) (randoms (mkStdGen seed))

randomWeightMatrix :: Int -> Int -> Int -> Matrix Double
randomWeightMatrix numInputs numOutputs seed = (numOutputs><numInputs) weights
    where weights = take (numOutputs*numInputs) (smallRandoms seed)

zeroWeightMatrix :: Int -> Int -> Matrix Double
zeroWeightMatrix numInputs numOutputs = (numOutputs><numInputs) weights
    where weights = repeat 0

main :: IO ()
main = do
  let w1 = randomWeightMatrix (28*28 + 1) 20 7
  let w2 = randomWeightMatrix 20 10 42
  let initialNet = buildBackpropNet learningRate [w1, w2] tanhAS
  trainingData2 <- readTrainingData
  let trainingData = take 20000 trainingData2
  putStrLn $ "Training with " ++ show (length trainingData) ++ " images"
  let finalNet = trainWithAllPatterns initialNet trainingData
  testData2 <- readTestData
  let testData = take 1000 testData2
  putStrLn $ "Testing with " ++ show (length testData) ++ " images"
  let results = evalAllPatterns finalNet testData
  let score = fromIntegral (sum results)
  let count = fromIntegral (length testData)
  let percentage = 100.0 * score / count
  putStrLn $ "I got " ++ show percentage ++ "% correct"


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Marvin.API.Algorithms.LinearRegression (
  LinearRegression (..)
  , defaultLinearRegression

  , LinearRegressionModel
  , coefficients
  , intercept
) where

import qualified Numeric.LinearAlgebra as LA
import Numeric.LinearAlgebra.HMatrix

import qualified Marvin.API.Algorithms.Internal.GradientDescent as GD
import Marvin.API.Algorithms.Internal.GradientDescent hiding (learningRate, lambda, addIntercept)

import Marvin.API.Meta.Model
import Marvin.API.Table.DataType
import Marvin.API.Table.Internal
import Marvin.API.Fallible

import Control.Arrow
import Control.Monad.Except
import qualified Data.Vector as Vec

-- * Parameters

-- | Parameters.
data LinearRegression = LinearRegression {
  learningRate :: Double -- ^ Coefficient of the gradient when updating the model.
  , numberOfIterations :: Int -- ^ Number of iterations.
  , lambda :: Double -- ^ Regularization coefficient.
  , addIntercept :: Bool -- ^ Whether to add a constant 1 column before training.
}

-- | Default parameters.
defaultLinearRegression = LinearRegression {
  learningRate = 0.001
  , numberOfIterations = 10
  , lambda = 0.1
  , addIntercept = True
}

toGradDesc :: LinearRegression -> GradientDescent
toGradDesc linReg = defaultGradientDescent {
  numIter = numberOfIterations linReg
  , GD.cost = linearRegressionCost
  , GD.learningRate = learningRate linReg
  , GD.addIntercept = addIntercept linReg
  , GD.lambda = lambda linReg
}

-- * Model

-- | Resulting model.
newtype LinearRegressionModel = LinRegModel LinearModel

-- | Retrieves a list of the coefficient.
coefficients :: LinearRegressionModel -> [Double]
coefficients (LinRegModel linearModel) = LA.toList $ coefs linearModel

-- | Retrieves the constant to be added.
intercept :: LinearRegressionModel -> Double
intercept (LinRegModel linearModel) = intercept_ linearModel

instance Show LinearRegressionModel where
  show (LinRegModel linear) = "Linear regression model:\n\n" ++ show linear

instance Estimator LinearRegression (NumericTable, NumericColumn) where
  type ResultingModel LinearRegression (NumericTable, NumericColumn) =
    LinearRegressionModel
  fit linReg (train, target) = do
    ensurePositive
      (InvalidAlgorithmParameter "LinearRegression" "numberOfIterations must be positive")
        $ numberOfIterations linReg
    ensurePositive
      (InvalidAlgorithmParameter "LinearRegression" "learning rate must be positive")
        $ learningRate linReg
    ensureNonNegative
      (InvalidAlgorithmParameter "LinearRegression" "lambda must be non-negative")
        $ lambda linReg
    ensureTableColSizeMatch "while training linear regression" train target
    let linearModel = fit' (toGradDesc linReg) (train, target)
    return $ LinRegModel linearModel

instance Predictor LinearRegressionModel where
  type Testing LinearRegressionModel = NumericTable
  type Prediction LinearRegressionModel = NumericColumn
  predict (LinRegModel model) = predict' model

unsafeFit :: LinearRegression -> FeatureMatrix -> TargetVariable -> ModelParameters
unsafeFit linReg = gradientDescent (toGradDesc linReg)


-- |

module Math.Algebra.Roots (zeros) where

import Data.Complex
import Polynomial.Roots

-- roots of a polynomial --------------------------------------------------------
-- no dealing with the complex problem of calculating roots, we will use
-- the Polynomial.Roots module of the `dsp` package, complex roots will look a
-- bit 'odd' to many as the output format is x :+ y for x + iy
zeros :: RealFloat a => [Complex a]
zeros = roots 1e-16 1000 [1,3,-10]
-- note that this uses Laguerre's method
-- >>> zeros
-- [0.5 :+ 0.0,(-0.2) :+ 0.0]


module MachineLearning.SoftmaxClassifierTest
(
  tests
)

where

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

import MachineLearning.DataSets (dataset2)

import qualified Numeric.LinearAlgebra as LA
import qualified MachineLearning as ML
import MachineLearning.Optimization
import MachineLearning.SoftmaxClassifier

(x, y) = ML.splitToXY dataset2

model = MultiClass (Softmax 2)

x1 = ML.addBiasDimension x
onesTheta :: LA.Vector LA.R
onesTheta = LA.konst 1 (2 * LA.cols x1)
zeroTheta :: LA.Vector LA.R
zeroTheta = LA.konst 0 (2 * LA.cols x1)

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

muSigma = ML.meanStddev (ML.mapFeatures 6 x)
x2 = processX muSigma x

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

checkSoftmaxGradient theta eps lambda = minimum . take 5 $ map check [eps, eps+0.001 ..]
  where check e = checkGradient model lambda x1 y theta e

gradientCheckingEps :: Double
gradientCheckingEps = 3e-2

eps = 0.000001

initialTheta = LA.konst 0.001 (2 * LA.cols x2)
(thetaGD, optPathGD) = minimize (GradientDescent 0.0005) model eps 150 (L2 1) x2 y initialTheta
(thetaCGFR, optPathCGFR) = minimize (ConjugateGradientFR 0.05 0.2) model eps 30 (L2 1) x2 y initialTheta
(thetaCGPR, optPathCGPR) = minimize (ConjugateGradientPR 0.05 0.3) model eps 30 (L2 1) x2 y initialTheta

showOptPath optPath = show $  (LA.toColumns optPath) !! 1

tests = [  testGroup "gradient checking" [
              testCase "non-zero theta, non-zero lambda" $ assertApproxEqual "" gradientCheckingEps 0 (checkSoftmaxGradient onesTheta 1e-3 (L2 2))
              , testCase "zero theta, non-zero lambda" $ assertApproxEqual "" gradientCheckingEps 0 (checkSoftmaxGradient zeroTheta 1e-3 (L2 2))
              , testCase "non-zero theta, zero lambda" $ assertApproxEqual "" gradientCheckingEps 0 (checkSoftmaxGradient onesTheta 1e-3 (L2 0))
              , testCase "zero theta, zero lambda" $ assertApproxEqual "" gradientCheckingEps 0 (checkSoftmaxGradient zeroTheta 1e-3 (L2 0))
              , testCase "non-zero theta, no reg" $ assertApproxEqual "" gradientCheckingEps 0 (checkSoftmaxGradient onesTheta 1e-3 RegNone)
              , testCase "zero theta, no reg" $ assertApproxEqual "" gradientCheckingEps 0 (checkSoftmaxGradient zeroTheta 1e-3 RegNone)
              ]

        , testGroup "learn" [
            testCase "Gradient Descent" $ assertVector (showOptPath optPathGD) 0.01 yExpected (hypothesis model xPredict2 thetaGD)
            , testCase "Conjugate Gradient FR" $ assertVector (showOptPath optPathCGFR) 0.01 yExpected (hypothesis model xPredict2 thetaCGFR)
            , testCase "Conjugate Gradient PR" $ assertVector (showOptPath optPathCGPR) 0.01 yExpected (hypothesis model xPredict2 thetaCGPR)
            ]
        ]


module Main where

import Numeric.LinearAlgebra

x1 = [  3,   4,   5,   6,   7,   8] :: [Double]
y1 = [150, 155, 150, 170, 160, 175] :: [Double]

x2 = [-0.2, 0.2, 1]     :: [Double]
y2 = [0.49, 0.64, 1.39] :: [Double]

x3 = [1,2,3,4]  :: [Double]
y3 = [6,5,7,10] :: [Double]

-- | Least square estimator
--
lse :: Int -> [Double] -> [Double] -> Matrix Double
lse deg x y = pinv (tx' <> x') <> tx' <> y'
    where

        tx' = trans x'

        x' :: Matrix Double
        x' = (lx><deg) (foldr (\x xs -> pow x (deg-1) ++ xs) [] x)

        y' :: Matrix Double
        y' = (ly><1) y

        lx = length x
        ly = length y

        pow x deg = go [] x deg
            where go :: [Double] -> Double -> Int -> [Double]
                  go acc _ 0   = 1:acc
                  go acc x deg = go (x**fromIntegral(deg):acc) x (deg-1)

-- | prettify for gnuplot
--
toF :: Matrix Double -> String
toF = concatMap (\(i,[x]) -> show (round' x) ++ "*" ++ "x**"++ (show i) ++ " + ") .  zip [0..] . toLists
  where round' = (/100) . fromInteger . round . (*100) :: Double -> Double

-- | Mean square estimator
mse :: Matrix Double -> [(Double, Double)] -> Double
mse m xys = nth . sum $ map (\(x,y) -> ((f x) - y)**2) xys
  where l = toLists m :: [[Double]]
        f x = sum $ zipWith (\(i, [w]) x -> w * x^i) (zip [0..] l) (repeat x)
        nth = (/ fromIntegral (length xys))

-- | data -> fitting -> gnuplot
plot :: Int -> [Double] -> [Double] -> String
plot deg x y = toF $ lse deg x y


-- This example uses the JuicyPixels package the generate the png.
import Control.Lens
import Data.Bool
import Data.Complex
import Data.Dense
import Data.Word

import Codec.Picture

-- Simple example to compute the manelbrot set in parallel. Compile with
--
-- ghc -O2 -threaded examples/mandel
--
-- (add -fllvm is available) and run with
--
-- examples/mandel +RTS -N4
--
-- replacing 4 with the number of processors to use.

main :: IO ()
main = do
  let plane = complexPlane (V2 2000 2000) ((-2.5) :+ (-2)) (1.5 :+ 2)
      m     = mandel 16 <$> plane
      img   = mkImage (manifest m)

  savePngImage "mandel.png" (ImageY8 img)

complexPlane
  :: V2 Int         -- ^ total size
  -> Complex Double -- ^ lower bound
  -> Complex Double -- ^ upper bound
  -> Delayed V2 (Complex Double)
complexPlane l@(V2 x y) a@(rmin :+ imin) (rmax :+ imax) =
  genDelayed l $
    \(V2 j i) -> a + (rstep * fromIntegral i :+ istep * fromIntegral j)
  where
    rstep = (rmax - rmin) / (fromIntegral x - 1)
    istep = (imax - imin) / (fromIntegral y - 1)

mandel :: Int -> Complex Double -> Word8
mandel n = bool 0 255 . any ((>2) . magnitude) . take n . criticalOrbit

criticalOrbit :: Complex Double -> [Complex Double]
criticalOrbit z0 = iterate (quadratic z0) 0
  where quadratic c z = z*z + c

mkImage :: SArray V2 Word8 -> Image Pixel8
mkImage a = Image x y (a^.vector)
  where V2 x y = extent a


-- | Metropolis-adjusted Langevin diffusion.  See, ex: Girolami and Calderhead
--   (2011):
--
-- http://onlinelibrary.wiley.com/doi/10.1111/j.1467-9868.2010.00765.x/abstract

module Strategy.MALA (mala, adaMala) where

import Control.Applicative
import Control.Monad
import Control.Monad.State.Strict
import Data.Maybe
import Math.Probably.Sampler
import Math.Probably.Types
import Math.Probably.Utils
import Numeric.LinearAlgebra

-- | The MALA transition operator.  Takes a step size tunable parameter.
mala :: Maybe Double -> Transition Double
mala e = do
  Chain current@(ds, cs) target _ t <- get
  let stepSize = fromMaybe t e
  pcs <- lift $ perturb target cs stepSize
  zc  <- lift unit

  let cMean = localMean target cs stepSize
      pMean = localMean target pcs stepSize
      next  = nextState target current cMean (ds, pcs) pMean stepSize zc

  put $ Chain next target (logObjective target next) stepSize
  return next

adaMala :: Transition (Maybe (Double,Int))
adaMala = do
  Chain current@(ds, cs) target _ madaPars <- get
  let (stepSize, trCount) = case madaPars of
          Nothing -> (0.1, 1)
          Just st -> st
  pcs <- lift $ perturb target cs stepSize
  zc  <- lift unit

  let cMean = localMean target cs stepSize
      pMean = localMean target pcs stepSize
      ratio = acceptProb target current cMean (ds, pcs) pMean stepSize
      pAccent | isNaN ratio = 0
              | otherwise   = ratio

  if zc<pAccent
     then do let stepNext = (min 1.4 $ 1+kmala/(realToFrac trCount))*stepSize
             put $ Chain (ds, pcs) target (logObjective target (ds, pcs)) $ Just (stepNext, trCount+1)
             return (ds, pcs)

     else do let stepNext = (max 0.7143 $ 1-kmala/(realToFrac trCount))**1.3*stepSize
             put $ Chain (ds, cs) target (logObjective target (ds, cs)) $ Just (stepNext, trCount+1)
             return (ds, cs)

kmala :: Double
kmala = 5

localMean :: Target -> Vector Double -> Double -> Vector Double
localMean target position e = position .+ scaledGradient position where
  grad = handleGradient (gradient target)
  scaledGradient p = (0.5 * e * e) .* grad p

perturb
  :: Target
  -> ContinuousParams
  -> Double
  -> Prob ContinuousParams
perturb target position e = do
  zs <- fromList <$> replicateM (dim position) unormal
  return $ localMean target position e .+ (e .* zs)

nextState
  :: Target
  -> Parameters
  -> ContinuousParams
  -> Parameters
  -> ContinuousParams
  -> Double
  -> Double
  -> Parameters
nextState target current cMean proposal pMean e z
    | z < pAccent = proposal
    | otherwise   = current
  where
    ratio = acceptProb target current cMean proposal pMean e
    pAccent | isNaN ratio = 0
            | otherwise   = ratio

acceptProb
  :: Target
  -> Parameters
  -> ContinuousParams
  -> Parameters
  -> ContinuousParams
  -> Double
  -> Double
acceptProb target current@(_, cs) cMean proposal@(_, pcs) pMean e =
  exp . min 0 $
      logObjective target proposal + log (sphereGauss cs pMean e)
    - logObjective target current  - log (sphereGauss pcs cMean e)