{-# LANGUAGE DataKinds, GADTs, RankNTypes, TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module Algebra.Algorithms.Groebner.ZeroDimSpec where
import Algebra.Algorithms.Groebner
import Algebra.Algorithms.ZeroDim
import Algebra.Internal
import Algebra.Internal
import Algebra.Ring.Ideal
import Algebra.Ring.Polynomial
import Algebra.Ring.Polynomial.Quotient

import           Control.Monad
import           Control.Monad.Random
import           Data.Complex
import           Data.Convertible       (convert)
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           Test.Hspec
import           Test.Hspec.QuickCheck
import           Test.QuickCheck        hiding (promote)
import           Utils

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 * M.colVector (V.fromList v)
             in solveLinear mat ans == Just (V.fromList v)
    it "cannot solve unsolvable cases" $ do
      pendingWith "need example"
  describe "univPoly" $ modifyMaxSuccess (const 50) $ modifyMaxSize (const 4) $ do
    prop "produces elimination ideal's monic generator" $ do
      checkForArity [2..4] prop_univPoly
  describe "radical" $ do
    it "really computes radical" $ do
      pendingWith "We can verify correctness by comparing with singular, but it's not quite smart way..."
{-
      checkForArity [2..4] $ \sdim ->
        forAll (zeroDimOf sdim) $ \(ZeroDimIdeal ideal) ->
        stdReduced (generators $ radical ideal) == calcGroebnerBasis (singIdealFun "radical" ideal)
      -- pendingWith "I couldn't formulate the spec for radical without existentials :-("
-}
  describe "fglm" $ modifyMaxSuccess (const 25) $ modifyMaxSize (const 3) $ do
    prop "computes monomial basis" $
      checkForArity [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" $ do
      checkForArity [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" $
      checkForArity [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" $ do
      checkForArity [2..4] $ prop_isApproximateZero 1e-5 (solve' 1e-5)
  -- describe "solve''" $ modifyMaxSuccess (const 50) $ modifyMaxSize (const 4) $ do
  --   it "solves equation with admissible error" $ do
  --     checkForArity [2..4] $ prop_isApproximateZero 1e-5 (solve'' 1e-10)
  describe "solveViaCompanion" $ modifyMaxSuccess (const 50) $ modifyMaxSize (const 4) $ do
    it "solves equation with admissible error" $ do
      checkForArity [2..4] $ prop_isApproximateZero 1e-5 (solveViaCompanion 1e-5)
  describe "solveM" $ modifyMaxSuccess (const 50) $ modifyMaxSize (const 4) $ do
    prop "solves equation with admissible error" $ \seed ->
      let gen = mkStdGen seed
      in checkForArity [2..4] $ prop_isApproximateZero 1e-10 (\t -> evalRand (solveM t) gen)

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) -> [Sized m (Complex Double)])
                       -> SNat n -> Property
prop_isApproximateZero err solver sn =
  case zeroOrSucc sn of
    IsSucc k -> withKnownNat k $ forAll (zeroDimOf sn) $ \(ZeroDimIdeal ideal) ->
      (case lneqZero k of
        Witness ->
          let anss = solver ideal
              mul r d = convert r * d
          in all (\as -> all ((<err) . magnitude . substWith mul as) $ generators ideal) anss) :: Bool

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 Quantum where

import Data.AdditiveGroup
import Data.Complex hiding ((:+))
import qualified Data.Complex as C (Complex ((:+)))
import Data.Foldable (foldl')
import Data.VectorSpace hiding (magnitude)
import Lib
import Matrix
import Vector

-- base type for qubits
type CDouble = Complex Double

type CVVec n = VVec n CDouble

type Qubit = CVVec Two

type NQubits n = CVVec (Exp Two n)

-- for ease of use
sqtwo :: Floating a => a
sqtwo = 1 / sqrt 2

i :: Num a => Complex a
i = 0 C.:+ 1

-- define some basic qubits/vectors, and qubit collections
basisVec :: forall n a. (Num a, KnownNat n) => Fin n -> VVec n a
basisVec f = generateMat (\x _ -> fromIntegral $ fromEnum $ x == f)

zero' :: forall n a. (Num a, KnownNat n) => VVec n a
zero' = basisVec FZero

zero :: Qubit
zero = zero'

one' :: forall n a m. (Num a, KnownNat n, n ~ 'Succ m) => VVec n a
one' = basisVec (FSucc FZero)

one :: Qubit
one = one'

plus :: Qubit
plus = sqtwo *^ zero ^+^ sqtwo *^ one

minus :: Qubit
minus = sqtwo *^ zero ^-^ sqtwo *^ one

qubits :: [Qubit]
qubits = [zero, one, plus, minus]

makeTwoQubits :: [Qubit] -> [NQubits Two]
makeTwoQubits qs = (.*.) <$> qs <*> qs

twoQubits :: [NQubits Two]
twoQubits = makeTwoQubits [zero, one]

consQubit :: CDouble -> CDouble -> Qubit
consQubit a b = numMatFromList [[a], [b]]

consVVec :: forall n a. (KnownNat n, Num a) => [a] -> VVec n a
consVVec ns = numMatFromList @n @One (fmap (: []) ns)

-- define some transformation matrices
pauliX :: Num a => Matrix Two Two a
pauliX = numMatFromList [[0, 1], [1, 0]]

pauliY :: RealFloat a => Matrix Two Two (Complex a)
pauliY = numMatFromList [[0, - i], [i, 0]]

pauliZ :: Num a => Matrix Two Two a
pauliZ = numMatFromList [[1, 0], [0, -1]]

hadamard :: Floating a => Matrix Two Two a
hadamard = (* sqtwo) <$> numMatFromList [[1, 1], [1, -1]]

-- a rotation matrix. produces a matrix which rotates by n radians
rotation :: Floating a => a -> Matrix Two Two a
rotation n = numMatFromList [[c, - s], [s, c]]
  where
    c = cos n
    s = sin n

cnot :: Num a => Matrix Four Four a
cnot = numMatFromList [[1, 0, 0, 0], [1, 0, 0, 0], [0, 0, 0, 1], [0, 0, 1, 0]]

cnot' :: Num a => Matrix Four Four a
cnot' = numMatFromList [[1, 0, 0, 0], [0, 0, 0, 1], [0, 0, 1, 0], [0, 1, 0, 0]]

iden2 :: Num a => Matrix Two Two a
iden2 = identity

swap :: Num a => Matrix Four Four a
swap = numMatFromList [[1, 0, 0, 0], [0, 0, 1, 0], [0, 1, 0, 0], [0, 0, 0, 1]]

-- define the tensor product
tensorProd ::
  (Num a) => Matrix n m a -> Matrix i j a -> Matrix (Mul n i) (Mul m j) a
tensorProd n m = expandNested $ fmap (\a -> fmap (a *) m) n

-- ease of use function for the tensor product
(.*.) :: (Num a) => Matrix n m a -> Matrix i j a -> Matrix (Mul n i) (Mul m j) a
(.*.) = tensorProd

infixr 8 .*.

-- apply the tensor product a number of times.
-- to use this function, use `tensorPower @(type number) matrix`
-- for example, to tensor product matrix `a` gate three times, do `tensorPower @Three a`
-- If used in relation to other matrices, tensorPower can infer
--  the `i` value, which is pretty neat
-- Only works on non-vector matrices - see tensorPowerVVec for column vec variant
tensorPower ::
  forall i a n m.
  (Num a, KnownNat i, i ~ GetExp ('Succ n) i, i ~ GetExp ('Succ m) i) =>
  Matrix ('Succ n) ('Succ m) a ->
  Matrix (Exp ('Succ n) i) (Exp ('Succ m) i) a
tensorPower m = tensorPower' @i m natSing

-- apply the tensor product a number of times on a column vector
-- very similar to tensorPower, but only works on column vectors
tensorPowerVVec ::
  forall i a n.
  (Num a, KnownNat i, i ~ GetExp ('Succ n) i) =>
  Matrix ('Succ n) 'One a ->
  Matrix (Exp ('Succ n) i) (Exp 'One i) a
tensorPowerVVec m = tensorPower' @i m natSing

-- helper function for tensorPower
tensorPower' ::
  forall i n m a.
  Num a =>
  Matrix n m a ->
  NatS i ->
  Matrix (Exp n i) (Exp m i) a
tensorPower' m OneS = m
tensorPower' m (SuccS s) = m .*. tensorPower' m s

-- transpose and get the conjugate of the given qubit
-- effectively, find the bra
conjTrans :: CVVec n -> HVec n CDouble
conjTrans v = conjugate <$> Matrix.transpose v

-- using conjTrans, find the inner product of two qubits
innerProduct :: CVVec n -> CVVec n -> CDouble
innerProduct v v' = getVal $ conjTrans v *.* v'

-- generate all basis vectors for a given dimension
compBasis' :: forall n a. (Num a, KnownNat n) => Vector n (VVec n a)
compBasis' = generateVec basisVec

-- define the computational basis
compBasis :: Vector Two Qubit
compBasis = compBasis'

-- apply a transformation matrix to the computational basis
transformBasis ::
  forall n a. (Num a, KnownNat n) => Matrix n n a -> Vector n (VVec n a)
transformBasis m = fmap (m *.*) compBasis'

-- measure in a given basis, returning probabilities for each
-- basis vector
measureIn :: CVVec m -> Vector n (CVVec m) -> Vector n Double
measureIn v = fmap ((** 2) . magnitude . Quantum.innerProduct v)

-- measure in the computational basis, returning probabilities
-- for each basis vector
measure :: Qubit -> Vector Two Double
measure v = measureIn v compBasis

-- given a list of vector-probability pairs, return Just the density matrix
--  if the probabilities sum up to 1; else return Nothing
getDensityMatrix ::
  (KnownNat m) => [(CVVec m, CDouble)] -> Maybe (Matrix m m CDouble)
getDensityMatrix qs
  | sum (map snd qs) == 1 =
    Just $
      foldr (^+^) zeroed [p *^ f tq | (tq, p) <- qs]
  | otherwise = Nothing
  where
    zeroed = generateMat (\_ _ -> 0)
    f m = m *.* conjTrans m

-- given a density matrix (as seen in previous function),
--  and a complex number vector, return the probability of
--  seeing that vector
calcProbability :: Matrix m m CDouble -> CVVec m -> CDouble
calcProbability densityMatrix base =
  getVal $ conjTrans base *.* densityMatrix *.* base

chi_f :: CVVec m -> CVVec m -> CDouble
chi_f s x = (-1) ** Quantum.innerProduct s x

-- vecToFunc :: (KnownNat m) => CVVec m -> Matrix m m CDouble
-- vecToFunc v =
--   generateMat (\f f' -> if f == f' then getAtMatrix f FZero v else 0)

-- fhat :: (KnownNat n) => (CVVec n -> CDouble) -> CVVec n -> CDouble
-- fhat f s =
--   (foldl' (\b a -> b + (apply a)) 0 compBasis') / (2 ** (fst $ Matrix.size s))
--  where
--   chi_s = chi s
--   apply x = (f x) * chi_s x

createInput :: Num a => Vector n (VVec m a) -> VVec (Exp m n) a
createInput (VecSing v) = v
createInput (v :+ vs) = v .*. createInput vs

fourierBasis :: (KnownNat n) => Vector n (CVVec n)
fourierBasis = fmap chi compBasis'

chi :: (KnownNat n) => CVVec n -> CVVec n
chi s = normalise $ toVVec $ fmap (chi_f s) compBasis'

fhat_f :: (KnownNat n) => CVVec n -> CVVec n -> CDouble
fhat_f = Quantum.innerProduct

fhat :: (KnownNat n) => CVVec n -> CVVec n
fhat f = toVVec $ fmap (fhat_f f) fourierBasis

normalise :: (KnownNat n) => CVVec n -> CVVec n
normalise v = v ^/ sqrt (sum $ fmap (abs) v)

groverDiffusion ::
  forall i a.
  (KnownNat (Exp Two i), KnownNat i, i ~ GetExp Two i, Floating a) =>
  Matrix (Exp Two i) (Exp Two i) a
groverDiffusion =
  tensorPower hadamard *.* generateMat f *.* tensorPower hadamard
  where
    f a b
      | a == b && a == FZero = 1
      | a == b = -1
      | otherwise = 0

-- fhat :: (KnownNat n) => CVVec n -> CVVec n -> CDouble
-- fhat f s


module NeuralNet where

import MatrixPlus

import Numeric.LinearAlgebra as N
import Test.QuickCheck

class NeuralNet n where
  evaluate
    :: n        -- ^ The neural net
    -> [Double] -- ^ The input pattern
    -> [Double] -- ^ The output pattern
  train
    :: n        -- ^ The neural net before training
    -> [Double] -- ^ The input pattern
    -> [Double] -- ^ The target pattern
    -> n        -- ^ The neural net after training

-- {{{ Useful things for testing

-- | Generate an arbitrary number between zero and one.
-- | To see sample values, in GHCi type: sample arbZeroToOne
arbZeroToOne :: Gen Double
arbZeroToOne = choose (0, 1)

-- | Generate a column vector of the specified length with arbitrary values.
-- | To see sample values (of length 4), in GHCi type: sample (sizedArbColumnVector 4)
sizedArbColumnVector :: Int -> Gen (ColumnVector Double)
sizedArbColumnVector n = do
    values <- vectorOf n arbZeroToOne
    return (listToColumnVector values)

-- | Generate a column vector where all values are zero
zeroColumnVector :: Int -> ColumnVector Double
zeroColumnVector n = listToColumnVector (replicate n 0)

-- | Generate a weight matrix of the specified dimensions with arbitrary values.
-- | To see sample values (of size 3x2), in GHCi type: sample (sizedArbWeightMatrix 3 2)
sizedArbWeightMatrix :: Int -> Int -> Gen (Matrix Double)
sizedArbWeightMatrix r c = do
    values <- vectorOf (r*c) arbZeroToOne
    return ((r N.><c) values)

-- }}}


{-# LANGUAGE Strict #-}

module HEP.Util.Polynomial (quarticEqSol, quadEqSol) where

import Numeric.GSL.Polynomials (polySolve)

import Data.Complex            (imagPart, realPart)
import Data.List               (nub, sort)

-- | returns the real roots of quartic polynomial equation in ascending order.
--
-- It does not return zero roots. Thus, if the roots are empty, it implies
-- that the polynomial has only zero roots.
quarticEqSol :: (Double -> Double)
             -> [Double]               -- ^ four distinct nonzero inputs
             -> Double                 -- ^ the cut value for complex roots
             -> Maybe (Int, [Double])  -- ^ (the number of real roots, roots)
quarticEqSol f xs eps
    | length (filter (/= 0) xs) /= 4 || xs /= nub xs = Nothing
    | otherwise = do
          let roots = filter (\r -> abs (imagPart r) < eps) $
                      polySolve (coeffQuartic f xs)
              realroots = (sort . filter ((> eps) . abs)) $ realPart <$> roots
          return (length realroots, realroots)

-- | returns the coefficients of quartic polynomial
--   using four distinct nonzero inputs.
--
--   a * x^4 + b * x^3 + c * x^2 + d * x + e
--
--   the output is the list of the coefficients [e, d, c, b, a].
coeffQuartic :: (Double -> Double) -> [Double] -> [Double]
coeffQuartic f xs =
    let [x1, x2, x3, x4] = xs
        [f1, f2, f3, f4] = f <$> xs

        d1 = x1 * (x2 - x1) * (x3 - x1) * (x4 - x1)
        d2 = x2 * (x2 - x1) * (x3 - x2) * (x4 - x2)
        d3 = x3 * (x3 - x1) * (x3 - x2) * (x4 - x3)
        d4 = x4 * (x4 - x1) * (x4 - x2) * (x4 - x3)

        p12 = x1 * x2
        p13 = x1 * x3
        p14 = x1 * x4
        p23 = x2 * x3
        p24 = x2 * x4
        p34 = x3 * x4
        p1234 = p12 * p34

        e = f 0

        a = - f1 / d1 + f2 / d2 - f3 / d3 + f4 / d4 + e / p1234

        b =   f1 * (x2 + x3 + x4) / d1
            - f2 * (x4 + x3 + x1) / d2
            + f3 * (x4 + x2 + x1) / d3
            - f4 * (x3 + x2 + x1) / d4
            - e * (x1 + x2 + x3 + x4) / p1234

        c = - f1 * (p34 + p24 + p23) / d1
            + f2 * (p34 + p14 + p13) / d2
            - f3 * (p24 + p14 + p12) / d3
            + f4 * (p23 + p13 + p12) / d4
            + e * (p34 + p24 + p14 + p23 + p13 + p12) / p1234

        d =   f1 * x2 * p34 / d1
            - f2 * x3 * p14 / d2
            + f3 * x4 * p12 / d3
            - f4 * x1 * p23 / d4
            - e * (x2 * p34 + x3 * p14 + x4 * p12 + x1 * p23) / p1234
    in
        [e, d, c, b, a]

-- | the real roots of quadratic equation: a x^2 + b x + c = 0.
--
-- If the root x0 is complex and |Im(x0)| < cut, it returns Re(x0).
quadEqSol :: Double  -- ^ the coefficient a
          -> Double  -- ^ the coefficient b
          -> Double  -- ^ the coefficient c
          -> Double  -- ^ the cut value for complex roots
          -> Maybe (Double, Double)
quadEqSol a b c epsScale = do
    let d = b * b - 4 * a * c
        eps = 1.0e-12
    if d >= 0
        -- then return ((-b + sqrt d) / (2*a), (-b - sqrt d) / (2*a))
        then do let q = -0.5 * (b + signum b * sqrt d)
                return (q / (a + eps), c / (q  + eps))
        else do let r = sqrt $ c / (a + eps)
                    th = acos $ - b / (2 * sqrt (a * c) + eps)
                    x = r * cos th
                if abs (r * sin th) < epsScale
                    then return (x, x)
                    else Nothing


-- might not work if module is not installed, possible fix is to place the file in
-- hnn-master root folder

import AI.HNN.FF.ComplexNetwork
import Numeric.LinearAlgebra
import Data.Complex
import System.Random.MWC
import Foreign.Storable           (Storable)

samplesXOR :: Samples (Complex Double)
samplesXOR = [ (fromList [(-1):+ (-1)], fromList [1:+0])
          , (fromList [(-1):+1], fromList [0:+0])
          , (fromList [1:+(-1)], fromList [1:+1])
          , (fromList [1:+1], fromList [0:+1])
          ]

real' :: (Floating a) => Complex a -> Complex a
real' (x :+ y) = x :+ 0

mapComplex ::  (Complex a -> a) -> (Complex a -> a) -> Complex a -> Complex a
mapComplex f g z = (f z) :+ (g z)

quarters :: (Floating a, Ord a, RealFloat a) => Complex a -> Complex a
quarters (x :+ y) = (if x > 0 then 1 else 0) :+ (if y > 0 then 1 else 0)

makeSamples :: (Floating a, Variate a, Storable a) => Int -> (Complex a -> Complex a) -> IO (Samples (Complex a))
makeSamples 0 _ = return []
makeSamples n f = do
  z <- randComplex
  lst <- makeSamples (n-1) f
  return ((fromList [z], fromList [f(z)]) : lst)

-- uncomment relevant sections for different tests
main :: IO ()
main = do
  -- Complex XOR:
  --mapM_ (putStrLn . show ) samplesXOR
  --n <- createComplexNetwork 1 [2] 1 :: IO (ComplexNetwork (Complex Double))
  --putStrLn $ show n
  --putStrLn "------------------"
  --let n' = trainNTimes 1000 0.8 complexSigmoid complexSigmoid' n samplesXOR
  --mapM_ (putStrLn . show . output n' complexSigmoid . fst) samplesXOR
  --putStrLn "------------"
  --putStrLn $ show n'

  -- Quarters on plane:
  --samples <- makeSamples 50 quarters
  --test <- makeSamples 10 quarters
  --mapM_ (putStrLn . show ) test
  --n <- createComplexNetwork 1 [2] 1 :: IO (ComplexNetwork (Complex Double))
  --putStrLn $ show n
  --putStrLn "------------------"
  --let n' = trainNTimes 1000 0.8 complexSigmoid complexSigmoid' n samples
  --mapM_ (putStrLn . show . output n' complexSigmoid . fst) test
  --putStrLn "------------"
  --putStrLn $ show n'

  -- Parabolas on plane:
  let h1 (x :+ y) = if x > 0.5*x^2 -0.5 then 1 else 0
  let h2 (x :+ y) = if y > -0.5*x^2 +0.5 then 1 else 0

  samples <- makeSamples 1000 (mapComplex h1 h2)
  test <- makeSamples 10 (mapComplex h1 h2 )

  mapM_ (putStrLn . show ) test
  n <- createComplexNetwork 1 [20] 1 :: IO (ComplexNetwork (Complex Double))
  let n' = trainNTimes 1 0.5 complexSigmoid complexSigmoid' n samples

  mapM_ (putStrLn . show . output n' complexSigmoid . fst) test


{-# LANGUAGE FlexibleInstances #-}
{-|
Module      : Algorithm.ShapeConstraint
Description : evaluation of shape-constraints for symbolic regression
Copyright   : (c) Fabricio Olivetti de Franca, 2022
License     : GPL-3
Maintainer  : fabricio.olivetti@gmail.com
Stability   : experimental
Portability : POSIX

This package provides support functions to evaluate different
shape-constraints for symbolic regression using modal arithmetic.

See https://direct.mit.edu/evco/article/30/1/75/99840 for more details.

@
@article{kronberger2022shape,
  title={Shape-Constrained Symbolic Regression—Improving Extrapolation with Prior Knowledge},
  author={Kronberger, Gabriel and de Fran{\c{c}}a, Fabricio Olivetti and Burlacu, Bogdan and Haider, Christian and Kommenda, Michael},
  journal={Evolutionary computation},
  volume={30},
  number={1},
  pages={75--98},
  year={2022},
  publisher={MIT Press One Rogers Street, Cambridge, MA 02142-1209, USA journals-info~…}
}
@

-}
module Algorithm.ShapeConstraint
    ( getViolationFun
    , Evaluator(..)
    , Shape(..)
    )
      where

import Numeric.ModalInterval
import Numeric.ModalInterval.Algorithms
import Data.SRTree

import Data.Map.Strict (Map(..))
import qualified Data.Map.Strict as M
import qualified Data.Vector as V
import Data.Bool (bool)
import Data.Maybe (fromMaybe)
import qualified Numeric.LinearAlgebra.Data as LA

-- | Data type describing the type of constraint:
--
-- * Range of the function
-- * Range of a partial derivative
-- * Monotonicity (non-increasing and non-decreasing)
-- * Partial monotonicity
-- * Inflection, Convex or Concave
--
-- The monotonicity constraints require the index of the
-- variable, the ranges require a tuple of the minimum and
-- maximum values, the partial monotonicity also requires
-- the range of the domain that has this property,
-- inflection, convexity and concavity requires the first
-- and second index of the partial derivatives.
data Shape   = Range (Double, Double)                     -- ^ f(x) \in [a, b]
             | DiffRng Int (Double, Double)               -- ^ d f(x) / dx \in [a, b]
             | NonIncreasing Int                          -- ^ d f(x) / dx \in [-inf, 0]
             | NonDecreasing Int                          -- ^ d f(x) / dx \in [0, inf]
             | PartialNonIncreasing Int (Double, Double)  -- ^ d f(x) / dx \in [-inf, 0], a <= x <= b
             | PartialNonDecreasing Int (Double, Double)  -- ^ d f(x) / dx \in [0, inf], a <= x <= b
             | Inflection Int Int                         -- ^ d^2 f(x)/dx^2 == 0
             | Convex Int Int                             -- ^ d^2 f(x)/dx^2 \in (0, Infinity)
             | Concave Int Int                            -- ^ d^2 f(x)/dx^2 \in (-Infinitiy,0)
                    deriving (Show, Read)

-- inner (a, b) no sharper than that
-- outer (a, b) no wider than that

-- | The `Evaluator` indicates the algorithm used to calculate the constraint:
--
-- * InnerInterval can result in false positives (i.e., it says it is feasible but it is not)
-- * OuterInterval can result in false negatives (i.e., it says it is infeasible but it is not)
-- * Sampling can result in false positives and usually requires a lot of samples
-- * Hybrid - not yet implemented
-- * Bisection can improve the results of OuterInterval
data Evaluator = InnerInterval | OuterInterval | Sampling Int | Hybrid | Bisection Int
                   deriving (Show, Read)

-- | Function that calculates how much of the constraints a symbolic tree vioaltes
type ConstraintFun = SRTree Int Double -> Double

-- | A list of domains of the variables
type Domains       = [(Double, Double)]

-- | A list of domains using Modal Arithmetic
type KDomains      = Map (Kaucher Double)

-- | Calculates the partial derivatives of a tree when needed.
ofShape :: (Floating a, Eq a, OptIntPow a) => SRTree Int a -> Shape -> SRTree Int a
t `ofShape` Range _ = t
t `ofShape` DiffRng ix _ = simplify $ deriveBy ix t
t `ofShape` NonIncreasing ix = simplify $ deriveBy ix t
t `ofShape` NonDecreasing ix = simplify $ deriveBy ix t
t `ofShape` PartialNonIncreasing ix _ = simplify $ deriveBy ix t
t `ofShape` PartialNonDecreasing ix _ = simplify $ deriveBy ix t
t `ofShape` Inflection ix iy = simplify $ deriveBy iy $ simplify $ deriveBy ix t
t `ofShape` Convex ix iy = simplify $ deriveBy iy $ simplify $ deriveBy ix t
t `ofShape` Concave ix iy = simplify $ deriveBy iy $ simplify $ deriveBy ix t
{-# INLINE ofShape #-}

toTuple :: Kaucher Double -> (Double, Double)
toTuple k = (fromMaybe (-1/0) $ inf k, fromMaybe (1/0) $ sup k)
{-# INLINE toTuple #-}

eps :: Double
eps = 1e-6
{-# INLINE eps #-}

calcPenalty :: Bool -> Double -> Double
calcPenalty b pnlty = bool 0 pnlty b
{-# INLINE calcPenalty #-}

inRng (a, b) (x, y) = calcPenalty (x < a - eps) (a - x) + calcPenalty (y > b + eps) (y - b)
{-# INLINE inRng #-}
isPositive (x, y)   = calcPenalty (x <= -eps) (abs x) + calcPenalty (y <= -eps) (abs y)
{-# INLINE isPositive #-}
isNegative (x, y)   = calcPenalty (x >= eps) (abs x) + calcPenalty (y >= eps) (abs y)
{-# INLINE isNegative #-}
isZero (x, y)       = calcPenalty (x <= -eps) (abs x) + calcPenalty (y >= eps) y
{-# INLINE isZero #-}

-- | Evaluates the constraint
evalConstraints :: Shape -> (Double, Double) -> Double
evalConstraints (Range ab) xy                 = inRng ab xy
evalConstraints (DiffRng _ ab) xy             = inRng ab xy
evalConstraints (NonIncreasing _) xy          = isNegative xy
evalConstraints (NonDecreasing _) xy          = isPositive xy
evalConstraints (PartialNonIncreasing _ _) xy = isNegative xy
evalConstraints (PartialNonDecreasing _ _) xy = isPositive xy
evalConstraints (Inflection _ _) xy           = isZero xy
evalConstraints (Convex _ _) xy               = isPositive xy
evalConstraints (Concave _ _) xy              = isNegative xy
{-# INLINE evalConstraints #-}

-- | Convert the domains for the partial monotonicity constraint
convertDomains :: Shape -> Map Int (Kaucher Double) -> Map Int (Kaucher Double)
convertDomains (PartialNonIncreasing ix (a, b)) ds = M.insert ix (a <.< b) ds
convertDomains (PartialNonDecreasing ix (a, b)) ds = M.insert ix (a <.< b) ds
convertDomains _ ds = ds
{-# INLINE convertDomains #-}

-- | Sum a list of constraint violations
sumCnstr :: (SRTree Int (Kaucher Double) -> Map Int (Kaucher Double) -> Kaucher Double) -> Map Int (Kaucher Double) -> [SRTree Int (Kaucher Double)] -> [Shape] -> Double -> Double
sumCnstr f ds [] []         acc = acc
sumCnstr f ds (x:xs) (z:zs) acc = sumCnstr f ds xs zs (acc + cnstr)
   where
     cnstr = evalConstraints z $ toTuple $ f x $ convertDomains z ds
{-# INLINE sumCnstr #-}

toMap :: Domains -> Map Int (Kaucher Double)
toMap    = M.fromList . zip [0..] . map (uncurry (<.<))
{-# INLINE toMap #-}

-- | Returns a constraint function given an `Evaluator` a list of `Shape` and the
-- `Domains` of the input variables.
getViolationFun :: Evaluator -> [Shape] -> Domains -> ConstraintFun
getViolationFun InnerInterval shapes domains t = sumCnstr innerApprox ds ts shapes 0.0
  where
    t'       = fmap singleton t
    ts       = map (t' `ofShape`) shapes
    ds       = toMap domains

getViolationFun OuterInterval shapes domains t = sumCnstr outerApprox ds ts shapes 0.0
  where
    t'       = fmap singleton t
    ts       = map (t' `ofShape`) shapes
    ds       = toMap domains

getViolationFun (Sampling nSamples) shapes domains t = go shapes ts samples 0.0
  where
    ds        = toMap domains
    samples   = map (M.fromList . zip [0..] . makeSamples nSamples . (`convertDomains` ds)) shapes
    getSize s = LA.size $ s M.! 0
    ts        = map (t `ofShape`) shapes

    evalSamples :: Maybe (LA.Vector Double) -> (Double, Double)
    evalSamples mxs = (fromMaybe (-1/0) mmin, fromMaybe (1/0) mmax)
      where
        mmax = LA.maxElement <$> mxs
        mmin = LA.minElement <$> mxs

    go [] _ _               acc = acc
    go (x:xs) (y:ys) (z:zs) acc = go xs ys zs (acc + cnstr)
      where
        cnstr = evalConstraints x rng
        y'    = fmap (LA.fromList . replicate (getSize z)) y
        rng   = evalSamples $ evalTreeWithMap y' z

getViolationFun e shapes domains t = error $ show e <> " evaluator not implemented"

instance OptIntPow (LA.Vector Double) where
    (^.) = (^^)
    {-# INLINE (^.) #-}

-- | Creates the samples of the `Sampling` approach
makeSamples :: Int -> Map Int (Kaucher Double) -> [LA.Vector Double]
makeSamples n domains = LA.toColumns $ LA.fromLists $ map (map midpoint) $ head $ dropWhile (\x -> length x < n) samples
  where
    step x  = let (a,b) = bisect x in [a,b]
    f       = map (concatMap step)
    samples = map sequence $ iterate f $ map (pure.snd) $ M.toAscList domains
{-# INLINE makeSamples #-}


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TupleSections #-}
module Main where

import Map
import Sector
-- import RepaMap
import Map.PixelMap
-- import SectorTree
-- import SectorMap
import Map.Dimension

import Linear.V as L
import Data.Complex
import qualified Data.Vector as V
import Codec.Picture
-- import Data.Kind

-- mandelbrot :: Int -> Complex Double -> Bool
{-# INLINE mandelbrot #-}
mandelbrot :: (Ord t, Num t, RealFloat a) => t -> Complex a -> Bool
mandelbrot n x = mandelbrot' x x n where
  mandelbrot' z _ _ | (sqr . magnitude $ z) > 4 = False
  mandelbrot' _ _ i | i <= 0 = True
  mandelbrot' z c i = mandelbrot' (z*z + c) c (i - 1)
  sqr a = a * a

{-# INLINE toComplexCoords #-}
toComplexCoords :: V 2 Double -> Complex Double
toComplexCoords (V v) = v V.! 1 :+ v V.! 0

{-# INLINE mandelMap #-}
mandelMap :: Int -> PixelMap Double
mandelMap n = fmap toGrayScale
            . changeCoordinates toComplexCoords
            $ getPoint >>= return . mandelbrot n

{-# INLINE mandelMap' #-}
mandelMap' :: Int -> Sector 2 Double -> Int -> PixelMap Double
mandelMap' n = optimizeMap (mandelMap n)

viewSector :: Zone -> Double -> Sector 2 Double
viewSector (Zone x y r) ratio = V . V.fromList $ [(x - r, x + r), (y - r * ratio, y + r * ratio)]

data Zone = Zone { zoneX :: Double
                 , zoneY :: Double
                 , zoneR :: Double }

interestingZones :: [Zone]
interestingZones =
  [ Zone 0 0 2
  , Zone 0.1 (-0.7) (5e-4)
  , Zone (0.109)  (-0.7443) (0.005)
  -- , Zone (0.1102) (-0.7463) (0.005)
  , Zone (0.1127) (-0.7453) (6.5e-4)
  , Zone (1.0405) (-0.16)   (0.026)
  ]

main :: IO ()
main = do
  let resX          = 1920 * resMultiplier -- x and y dimensions
      resY          = 1080 * resMultiplier
      resMultiplier = 1 -- increment this to get 4k, 8k, etc.
      ratio         = (fromIntegral resX) / (fromIntegral resY)
      zone          = Zone 0 0 2
      depth         = 400
      sec           = viewSector zone ratio
      img           = bakePixelMap
                        sec
                        (resolution resX resY)
                        (mandelMap depth)
  putStrLn "Execution started."
  savePngImage ("/tmp/mandelbrot.png") img
  putStrLn "Execution finished"


module NumericalSpec (main, spec) where

import Yasih.LispTypes
import Yasih.Evaluator
import Yasih

import Test.Hspec
import Test.Tasty
import Test.Tasty.QuickCheck
import System.IO.Unsafe
import Data.Complex
import Data.Ratio

main :: IO ()
main = hspec spec

-- | Exec with local standard library
ev = evalOne ["stdlib/stdlib.scm"]

spec :: Spec
spec = describe "Numerical Primitives" $ do
    describe "Arithmetic Primitives" $ do
        describe "Work correctly with different types" $ do
            it "+" $
                ev "(+ 1 2.4 3/2 3-4i)" `shouldReturn` (Right $ Complex (7.9 :+ (-4)))


-- |
-- Module    : Statistics.Test.WilcoxonT
-- Copyright : (c) 2010 Neil Brown
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- The Wilcoxon matched-pairs signed-rank test is non-parametric test
-- which could be used to whether two related samples have different
-- means.
--
-- WARNING: current implementation contain serious bug and couldn't be
-- used with samples larger than 1023.
-- <https://github.com/bos/statistics/issues/18>
module Statistics.Test.WilcoxonT (
    -- * Wilcoxon signed-rank matched-pair test
    wilcoxonMatchedPairTest
  , wilcoxonMatchedPairSignedRank
  , wilcoxonMatchedPairSignificant
  , wilcoxonMatchedPairSignificance
  , wilcoxonMatchedPairCriticalValue
    -- * Data types
  , TestType(..)
  , TestResult(..)
  ) where

--
--
--
-- Note that: wilcoxonMatchedPairSignedRank == (\(x, y) -> (y, x)) . flip wilcoxonMatchedPairSignedRank
-- The samples are zipped together: if one is longer than the other, both are truncated
-- The value returned is the pair (T+, T-).  T+ is the sum of positive ranks (the
-- These values mean little by themselves, and should be combined with the 'wilcoxonSignificant'
-- function in this module to get a meaningful result.
-- ranks of the differences where the first parameter is higher) whereas T- is
-- the sum of negative ranks (the ranks of the differences where the second parameter is higher).
-- to the the length of the shorter sample.

import Control.Applicative ((<$>))
import Data.Function (on)
import Data.List (findIndex)
import Data.Ord (comparing)
import Prelude hiding (sum)
import Statistics.Function (sortBy)
import Statistics.Sample.Internal (sum)
import Statistics.Test.Internal (rank, splitByTags)
import Statistics.Test.Types (TestResult(..), TestType(..), significant)
import Statistics.Types (Sample)
import qualified Data.Vector.Unboxed as U

wilcoxonMatchedPairSignedRank :: Sample -> Sample -> (Double, Double)
wilcoxonMatchedPairSignedRank a b = (sum ranks1, negate (sum ranks2))
  where
    (ranks1, ranks2) = splitByTags
                     $ U.zip tags (rank ((==) `on` abs) diffs)
    (tags,diffs) = U.unzip
                 $ U.map (\x -> (x>0 , x))   -- Attack tags to distribution elements
                 $ U.filter  (/= 0.0)        -- Remove equal elements
                 $ sortBy (comparing abs)    -- Sort the differences by absolute difference
                 $ U.zipWith (-) a b         -- Work out differences

-- | The coefficients for x^0, x^1, x^2, etc, in the expression
-- \prod_{r=1}^s (1 + x^r).  See the Mitic paper for details.
--
-- We can define:
-- f(1) = 1 + x
-- f(r) = (1 + x^r)*f(r-1)
--      = f(r-1) + x^r * f(r-1)
-- The effect of multiplying the equation by x^r is to shift
-- all the coefficients by r down the list.
--
-- This list will be processed lazily from the head.
coefficients :: Int -> [Integer]
coefficients 1 = [1, 1] -- 1 + x
coefficients r = let coeffs = coefficients (r-1)
                     (firstR, rest) = splitAt r coeffs
  in firstR ++ add rest coeffs
  where
    add (x:xs) (y:ys) = x + y : add xs ys
    add xs [] = xs
    add [] ys = ys

-- This list will be processed lazily from the head.
summedCoefficients :: Int -> [Double]
summedCoefficients n
  | n < 1     = error "Statistics.Test.WilcoxonT.summedCoefficients: nonpositive sample size"
  | n > 1023  = error "Statistics.Test.WilcoxonT.summedCoefficients: sample is too large (see bug #18)"
  | otherwise = map fromIntegral $ scanl1 (+) $ coefficients n

-- | Tests whether a given result from a Wilcoxon signed-rank matched-pairs test
-- is significant at the given level.
--
-- This function can perform a one-tailed or two-tailed test.  If the first
-- parameter to this function is 'TwoTailed', the test is performed two-tailed to
-- check if the two samples differ significantly.  If the first parameter is
-- 'OneTailed', the check is performed one-tailed to decide whether the first sample
-- (i.e. the first sample you passed to 'wilcoxonMatchedPairSignedRank') is
-- greater than the second sample (i.e. the second sample you passed to
-- 'wilcoxonMatchedPairSignedRank').  If you wish to perform a one-tailed test
-- in the opposite direction, you can either pass the parameters in a different
-- order to 'wilcoxonMatchedPairSignedRank', or simply swap the values in the resulting
-- pair before passing them to this function.
wilcoxonMatchedPairSignificant ::
     TestType            -- ^ Perform one- or two-tailed test (see description below).
  -> Int                 -- ^ The sample size from which the (T+,T-) values were derived.
  -> Double              -- ^ The p-value at which to test (e.g. 0.05)
  -> (Double, Double)    -- ^ The (T+, T-) values from 'wilcoxonMatchedPairSignedRank'.
  -> Maybe TestResult    -- ^ Return 'Nothing' if the sample was too
                         --   small to make a decision.
wilcoxonMatchedPairSignificant test sampleSize p (tPlus, tMinus) =
  case test of
    -- According to my nearest book (Understanding Research Methods and Statistics
    -- by Gary W. Heiman, p590), to check that the first sample is bigger you must
    -- use the absolute value of T- for a one-tailed check:
    OneTailed -> (significant . (abs tMinus <=) . fromIntegral) <$> wilcoxonMatchedPairCriticalValue sampleSize p
    -- Otherwise you must use the value of T+ and T- with the smallest absolute value:
    TwoTailed -> (significant . (t <=) . fromIntegral) <$> wilcoxonMatchedPairCriticalValue sampleSize (p/2)
  where
    t = min (abs tPlus) (abs tMinus)

-- | Obtains the critical value of T to compare against, given a sample size
-- and a p-value (significance level).  Your T value must be less than or
-- equal to the return of this function in order for the test to work out
-- significant.  If there is a Nothing return, the sample size is too small to
-- make a decision.
--
-- 'wilcoxonSignificant' tests the return value of 'wilcoxonMatchedPairSignedRank'
-- for you, so you should use 'wilcoxonSignificant' for determining test results.
--  However, this function is useful, for example, for generating lookup tables
-- for Wilcoxon signed rank critical values.
--
-- The return values of this function are generated using the method detailed in
-- the paper \"Critical Values for the Wilcoxon Signed Rank Statistic\", Peter
-- Mitic, The Mathematica Journal, volume 6, issue 3, 1996, which can be found
-- here: <http://www.mathematica-journal.com/issue/v6i3/article/mitic/contents/63mitic.pdf>.
-- According to that paper, the results may differ from other published lookup tables, but
-- (Mitic claims) the values obtained by this function will be the correct ones.
wilcoxonMatchedPairCriticalValue ::
     Int                -- ^ The sample size
  -> Double             -- ^ The p-value (e.g. 0.05) for which you want the critical value.
  -> Maybe Int          -- ^ The critical value (of T), or Nothing if
                        --   the sample is too small to make a decision.
wilcoxonMatchedPairCriticalValue sampleSize p
  = case critical of
      Just n | n < 0 -> Nothing
             | otherwise -> Just n
      Nothing -> Just maxBound -- shouldn't happen: beyond end of list
  where
    m = (2 ** fromIntegral sampleSize) * p
    critical = subtract 1 <$> findIndex (> m) (summedCoefficients sampleSize)

-- | Works out the significance level (p-value) of a T value, given a sample
-- size and a T value from the Wilcoxon signed-rank matched-pairs test.
--
-- See the notes on 'wilcoxonCriticalValue' for how this is calculated.
wilcoxonMatchedPairSignificance :: Int    -- ^ The sample size
                                -> Double -- ^ The value of T for which you want the significance.
                                -> Double -- ^ The significance (p-value).
wilcoxonMatchedPairSignificance sampleSize rnk
  = (summedCoefficients sampleSize !! floor rnk) / 2 ** fromIntegral sampleSize

-- | The Wilcoxon matched-pairs signed-rank test. The samples are
-- zipped together: if one is longer than the other, both are
-- truncated to the the length of the shorter sample.
--
-- For one-tailed test it tests whether first sample is significantly
-- greater than the second. For two-tailed it checks whether they
-- significantly differ
--
-- Check 'wilcoxonMatchedPairSignedRank' and
-- 'wilcoxonMatchedPairSignificant' for additional information.
wilcoxonMatchedPairTest :: TestType   -- ^ Perform one-tailed test.
                        -> Double     -- ^ The p-value at which to test (e.g. 0.05)
                        -> Sample     -- ^ First sample
                        -> Sample     -- ^ Second sample
                        -> Maybe TestResult
                        -- ^ Return 'Nothing' if the sample was too
                        --   small to make a decision.
wilcoxonMatchedPairTest test p smp1 smp2 =
    wilcoxonMatchedPairSignificant test (min n1 n2) p
  $ wilcoxonMatchedPairSignedRank smp1 smp2
  where
    n1 = U.length smp1
    n2 = U.length smp2


{-# LANGUAGE ConstraintKinds #-}

module Quadrature
( getGaussPoints
, numGaussPoints
, integrate
, integrateFunc
) where

import qualified Numeric.LinearAlgebra.HMatrix as HMat

type FrElNuFi a = (Fractional a,HMat.Element a,HMat.Numeric a,HMat.Field a)
type FlElNuFi a = (Floating a,HMat.Element a,HMat.Numeric a,HMat.Field a)

-- Function for computing the required number of Gauss points for a polynomial
numGaussPoints :: Integral a => a -> a
numGaussPoints order = ceiling (0.5 * (fromIntegral order + 1.0))

-- Function for getting Gauss points for integration
-- Given the number of points it returns a list of the points and the weights
getGaussPoints :: Floating a => Int -> ([a], [a])
getGaussPoints 1 = ([0.0], [2.0])
getGaussPoints 2 = ([-1.0/sqrt 3.0, 1.0/sqrt 3.0], [1.0, 1.0])
getGaussPoints 3 = ([-sqrt (3.0/5.0), 0.0, sqrt (3.0/5.0)], [5.0/9.0, 8.0/9.0, 5.0/9.0])
getGaussPoints 4 = ([-0.861136311594053,-0.339981043584856,0.339981043584856,0.861136311594053],[0.347854845137454,0.652145154862546,0.652145154862546,0.347854845137454])
getGaussPoints _ = error "Gauss points only up to 4 point quadrature available."

-- Function for integrating some integrand over an element
-- Usage: integrate dim ngpts integrand
integrate :: FrElNuFi a => Int -> Int -> ([a] -> HMat.Matrix a) -> HMat.Matrix a
integrate 1 ngpts integrand = foldl1 HMat.add $ zipWith HMat.scale wts (map (\x -> integrand [x]) xi)
  where
    gpts = getGaussPoints ngpts
    xi = fst gpts
    wts = snd gpts
integrate _ _ _ = error "Integration only works in 1d for now."

-- Function for integrating a function from -1 to 1
integrateFunc :: Floating a => Int -> (a -> a) -> a
integrateFunc ngpts func = sum $ zipWith (*) wts (map func pts)
  where
    gpts = getGaussPoints ngpts
    pts = fst gpts
    wts = snd gpts


import Graphics.Gloss
import Graphics.Gloss.Raster.Field
import Graphics.Gloss.Data.ViewPort
import Data.Complex
import Data.Colour.RGBSpace
import Data.Colour.RGBSpace.HSV
import qualified Graphics.Gloss.Data.Point.Arithmetic as PA

mandelbrot :: Complex Float -> Complex Float -> Int -> (Complex Float, Int)
mandelbrot z _ 0 = (z, 0)
mandelbrot z c n
  | magnitude z > 2 = (z, n)
  | otherwise = mandelbrot (z * z + c) c (n - 1)

rgbcolor :: Float -> Float -> Float -> Color
rgbcolor r g b = makeColor r g b 1.0

smoothcolor :: Complex Float -> Int -> Int -> Color
smoothcolor _ 0 _ = black
smoothcolor z n max = (uncurryRGB rgbcolor) $ hsv deg 1 1
  where deg = 360 * ((fromIntegral n) - 1.0 + (log (log (magnitude z))) / (log 2)) / (fromIntegral max)

colorof :: Int -> Point -> Color
colorof max (x,y) = let (z, n) = mandelbrot 0 (x :+ y) max
                in smoothcolor z n max

getpicture :: ViewPort -> Float -> (Picture,Point) -> (Picture,Point)
getpicture vp _ pd@(pic,pt) = let npt = invertViewPort vp (1,1)
                                  adjpt = (PA.- (1/300 PA.* t)).(300/scl PA.*)
                                  adjpic = (translate (-tx) (-ty)).(scale (300 /scl) (300/scl))
                                  t@(tx,ty) = viewPortTranslate vp
                                  scl = 300 * (viewPortScale vp)
                                  max = (round $ 4 * (log scl))
                              in case (pt /= npt) of
                                True -> (adjpic $ makePicture 600 600 5 5 ((colorof max).adjpt), npt)
                                False -> pd

main :: IO ()
main = simulate
  (InWindow "Mandelbrot" (600,600) (20,20))
  black
  1
  (Circle 0, (0,0))
  (\(p,_ ) -> p)
  getpicture


-- | Module providing various functions popular in quantum calculations, but
-- not implemented in "Numeric.LinearAlgebra".
module Hoqus.MtxFun where

import Numeric.LinearAlgebra.Data
import Numeric.LinearAlgebra

-- | Trace of a matrix. This function ignores the non-sqare part of the matrix.
trace :: Matrix C -> C
trace = sum.toList.takeDiag

-- | Logarithm of a matrix. Based on 'Numeric.LinearAlgebra.matFunc' function
-- from "Numeric.LinearAlgebra" package.
logm :: Matrix C -> Matrix C
logm = matFunc log


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

Logistic Loss.
-}

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

where

import qualified Numeric.LinearAlgebra as LA
import MachineLearning.Types (R, Matrix)
import qualified MachineLearning.LogisticModel as LM

scores :: Matrix -> Matrix
scores = LM.sigmoid

gradient :: Matrix -> Matrix -> Matrix
gradient scores y = scores - y

-- Logistic Loss function
loss :: Matrix -> Matrix -> R
loss x y = (LA.sumElements $ (-y) * log(tau + x) - (1-y) * log ((1+tau)-x))/m
  where tau = 1e-7
        m = fromIntegral $ LA.rows x


module HopfieldMat ( initialWeights
                   , energy
                   , feed
                   , train
                   ) where

import Numeric.LinearAlgebra

initialWeights :: Int -> Matrix R
initialWeights l = (l><l) $ repeat 0

train :: Vector R -> Matrix R -> Matrix R
train p w = (outer p p) * zeroDiagonal + w
  where
    zeroDiagonal = (sp><sp)(repeat 1) - ident sp
    sp = size p

feed :: Matrix R -> Vector R -> Vector R
feed w = cmap signum . (w #>)

energy :: Matrix R -> Vector R -> Double
energy w p = -0.5 * (sumElements $ p * (w #> p))


module Math.FROG.Retrieval
( retrieve
, calcLoss
) where

import qualified Numeric.LinearAlgebra as LA
import qualified Math.Optimization.SPSA as SPSA

import qualified Math.FROG.Tools as FR
import Math.FROG.Types

retrieve :: Nonlinearity -> Trace -> IO (LA.Vector Double)
retrieve nonlin measurement = do
    let niter = 50000
    let a = 0.2
    let c = 0.00001

    let sz = LA.rows measurement
    let gainA = SPSA.standardAk a (niter `quot` 10) 0.602
    let gainC = SPSA.standardCk c 0.101
    let lossFn = calcLoss nonlin measurement

    spsa <- SPSA.mkUnconstrainedSPSA lossFn gainA gainC (2*sz)
    initialGuess <- FR.mkInitialGuess sz

    return $ SPSA.optimize spsa niter initialGuess

calcLoss :: Nonlinearity -> Trace -> LA.Vector Double -> Double
calcLoss nonlin meas v = (/ (fromIntegral $ LA.rows meas)) . sqrt
                                                           . LA.sumElements $ sqDiff
    where
    field = FR.flatPolar2Complex v
    (signal, gate) = FR.mkSigGate nonlin field field
    sqDiff = (^2) . abs $ (meas - FR.mkTrace signal gate)


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

ReLu Activation.
-}

module MachineLearning.NeuralNetwork.ReluActivation
(
  relu
  , gradient
)

where

import qualified Numeric.LinearAlgebra as LA
import MachineLearning.Types (Matrix)

relu :: Matrix -> Matrix
relu x = x * (LA.step x)

gradient :: Matrix -> Matrix -> Matrix
gradient x dx = dx * (LA.step x)  -- == dx[x<0] = 0


module Numeric.LinearAlgebra.OrthoNormalBasis where

import Numeric.LinearAlgebra.Vector

epsilon :: (Ord a, Floating a) => a
epsilon = 0.01

data ONB a = ONB
  { onbU :: Vec3 a
  , onbV :: Vec3 a
  , onbW :: Vec3 a
  } deriving (Read, Show, Eq, Ord)

mkFromU :: (Ord a, Floating a) => Vec3 a -> ONB a
mkFromU u' = ONB u v w
  where
  n = Vec3 1 0 0
  m = Vec3 0 1 0
  u = unitVector u'
  v = if len (u <%> n) < epsilon
        then u <%> m
        else u <%> n
  w = u <%> v

mkFromV :: (Ord a, Floating a) => Vec3 a -> ONB a
mkFromV v' = ONB u v w
  where
  n = Vec3 1 0 0
  m = Vec3 0 1 0
  v = unitVector v'
  u = if lenSquared (v <%> n) < epsilon
        then v <%> m
        else v <%> n
  w = u <%> v

mkFromW :: (Ord a, Floating a) => Vec3 a -> ONB a
mkFromW w' = ONB u v w
  where
  n = Vec3 1 0 0
  m = Vec3 0 1 0
  w = unitVector w'
  u = if len (w <%> n) < epsilon
        then w <%> m
        else w <%> n
  v = w <%> u

mkFromUV :: Floating a => Vec3 a -> Vec3 a -> ONB a
mkFromUV u' v' = ONB u v w
  where
  u = unitVector u'
  w = unitVector (u' <%> v')
  v = w <%> u

mkFromVU :: Floating a => Vec3 a -> Vec3 a -> ONB a
mkFromVU v' u' = ONB u v w
  where
  v = unitVector v'
  w = unitVector (u' <%> v')
  u = v <%> w

mkFromUW :: Floating a => Vec3 a -> Vec3 a -> ONB a
mkFromUW u' w' = ONB u v w
  where
  u = unitVector u'
  v = unitVector (w' <%> u')
  w = u <%> v

mkFromWU :: Floating a => Vec3 a -> Vec3 a -> ONB a
mkFromWU w' u' = ONB u v w
  where
  w = unitVector w'
  v = unitVector (w' <%> u')
  u = v <%> w

mkFromVW :: Floating a => Vec3 a -> Vec3 a -> ONB a
mkFromVW v' w' = ONB u v w
  where
  v = unitVector v'
  u = unitVector (v' <%> w')
  w = u <%> v

mkFromWV :: Floating a => Vec3 a -> Vec3 a -> ONB a
mkFromWV w' v' = ONB u v w
  where
  w = unitVector w'
  u = unitVector (v' <%> w')
  v = w <%> u


module Language.Hakaru.Util.Coda where

import Statistics.Autocorrelation
import qualified Numeric.LinearAlgebra as V
import qualified Data.Vector.Generic as G

effectiveSampleSize :: [Double] -> Double
effectiveSampleSize samples = n / (1 + 2*(G.sum rho))
  where n = fromIntegral (V.size vec)
        vec = V.fromList samples
        cov = autocovariance vec
        rho = G.map (/ G.head cov) cov

meanVariance :: Fractional a => [a] -> (a,a)
meanVariance lst = (av,sigma2)
  where
    n   = fromIntegral $ length lst
    av  = sum lst / n
    sigma2 = (foldr (\x acc -> sqr (x - av) + acc) 0 lst) / (n - 1)
    sqr x = x * x


{-# LANGUAGE FlexibleContexts #-}

module Evaluator.Numerical where

import LispTypes
import Environment
import Evaluator.Operators

import Data.Complex
import Data.Ratio
import Data.Foldable
import Data.Fixed
import Numeric
import Control.Monad.Except

numericalPrimitives :: [(String, [LispVal] -> ThrowsError LispVal)]
numericalPrimitives =
    -- Binary Numerical operations
    [("+", numAdd),
    ("-", numSub),
    ("*", numMul),
    ("/", numDivide),
    ("modulo", numMod),
    ("quotient", numericBinop quot),
    ("remainder", numericBinop rem),
    ("abs", numAbs),
    ("ceiling", numCeil),
    ("floor", numFloor),
    ("round", numRound),
    ("truncate", numTruncate),
    -- Conversion
    ("number->string", numToString),
    -- Numerical Boolean operators
    ("=", numBoolBinop (==)),
    ("<", numBoolBinop (<)),
    (">", numBoolBinop (>)),
    ("/=", numBoolBinop (/=)),
    (">=", numBoolBinop (>=)),
    ("<=", numBoolBinop (<=)),
    -- Scientific functions
    ("sqrt", sciSqrt),
    ("acos", sciAcos),
    ("asin", sciAsin),
    ("atan", sciAtan),
    ("cos", sciCos),
    ("sin", sciSin),
    ("tan", sciTan),
--    ("acosh", sciAcosh),
--    ("asinh", sciAsinh),
--    ("atanh", sciAtanh),
--    ("cosh", sciCosh),
--    ("sinh", sciSinh),
--    ("tanh", sciTanh),
    ("exp", sciExp),
    ("expt", sciExpt),
    ("log", sciLog),
    -- Complex numbers operations
--    ("angle", cAngle),
    ("real-part", cRealPart),
    ("imag-part", cImagPart),
    ("magnitude", cMagnitude),
    ("make-polar", cMakePolar),
--    ("make-rectangular", cMakeRectangular),
    -- Type testing functions
    ("number?", unaryOp numberp),
    ("integer?", unaryOp integerp),
    ("float?", unaryOp floatp),
    ("ratio?", unaryOp ratiop),
    ("complex?", unaryOp complexp)]

-- |Type testing functions
numberp, integerp, floatp, ratiop, complexp :: LispVal -> LispVal
integerp (Number _)     = Bool True
integerp _              = Bool False
numberp (Number _)      = Bool True
numberp (Float _)       = Bool True
numberp (Ratio _)       = Bool True
numberp (Complex _)     = Bool True
numberp _               = Bool False
floatp (Float _)        = Bool True
floatp _                = Bool False
ratiop (Ratio _)        = Bool True
ratiop _                = Bool False
complexp (Complex _)    = Bool True
complexp _              = Bool False

-- |Absolute value
numAbs :: [LispVal] -> ThrowsError LispVal
numAbs [Number x]   = return $ Number $ abs x
numAbs [Float x]    = return $ Float $ abs x
numAbs [Complex x]  = return $ Complex $ abs x -- Calculates the magnitude
numAbs [Ratio x]    = return $ Ratio $ abs x
numAbs [x] = throwError $ TypeMismatch "number" x
numAbs l = throwError $ NumArgs 1 l

-- |Ceiling, floor, round and truncate
numCeil, numFloor, numRound, numTruncate :: [LispVal] -> ThrowsError LispVal
numCeil [Number x]   = return $ Number $ ceiling $ fromInteger x
numCeil [Ratio x]    = return $ Number $ ceiling $ fromRational x
numCeil [Float x]    = return $ Number $ ceiling x
numCeil [Complex x]  =
    if imagPart x == 0 then return $ Number $ ceiling $ realPart x
    else throwError $ TypeMismatch "integer or float" $ Complex x
numCeil [x] = throwError $ TypeMismatch "integer or float" x
numCeil l = throwError $ NumArgs 1 l

numFloor [Number x]   = return $ Number $ floor $ fromInteger x
numFloor [Ratio x]    = return $ Number $ floor $ fromRational x
numFloor [Float x]    = return $ Number $ floor x
numFloor [Complex x]  =
    if imagPart x == 0 then return $ Number $ floor $ realPart x
    else throwError $ TypeMismatch "integer or float" $ Complex x
numFloor [x] = throwError $ TypeMismatch "integer or float" x
numFloor l = throwError $ NumArgs 1 l

numRound [Number x]   = return $ Number $ round $ fromInteger x
numRound [Ratio x]    = return $ Number $ round $ fromRational x
numRound [Float x]    = return $ Number $ round x
numRound [Complex x]  =
    if imagPart x == 0 then return $ Number $ round $ realPart x
    else throwError $ TypeMismatch "integer or float" $ Complex x
numRound [x] = throwError $ TypeMismatch "integer or float" x
numRound l = throwError $ NumArgs 1 l

numTruncate [Number x]   = return $ Number $ truncate $ fromInteger x
numTruncate [Ratio x]    = return $ Number $ truncate $ fromRational x
numTruncate [Float x]    = return $ Number $ truncate x
numTruncate [Complex x]  =
    if imagPart x == 0 then return $ Number $ truncate $ realPart x
    else throwError $ TypeMismatch "integer or float" $ Complex x
numTruncate [x] = throwError $ TypeMismatch "integer or float" x
numTruncate l = throwError $ NumArgs 1 l

-- |foldl1M is like foldlM but has no base case
foldl1M :: Monad m => (a -> a -> m a) -> [a] -> m a
foldl1M f (x : xs) = foldlM f x xs
foldl1M _ _ = error "unexpected error in foldl1M"

-- | Sum numbers
numAdd :: [LispVal] -> ThrowsError LispVal
numAdd []   = return $ Number 0
numAdd l    = foldl1M (\ x y -> numCast [x, y] >>= go) l
    where
        go (List [Number x, Number y])      = return $ Number $ x + y
        go (List [Float x, Float y])        = return $ Float $ x + y
        go (List [Ratio x, Ratio y])        = return $ Ratio $ x + y
        go (List [Complex x, Complex y])    = return $ Complex $ x + y
        go _ = throwError $ Default "unexpected error in (+)"

-- | Subtract numbers
numSub :: [LispVal] -> ThrowsError LispVal
numSub []           = throwError $ NumArgs 1 []
numSub [Number x]   = return $ Number $ -1 * x
numSub [Float x]    = return $ Float $ -1 * x
numSub [Ratio x]    = return $ Ratio $ -1 * x
numSub [Complex x]  = return $ Complex $ -1 * x
numSub l = foldl1M (\ x y -> numCast [x, y] >>= go) l
    where
        go (List [Number x, Number y])      = return $ Number $ x - y
        go (List [Float x, Float y])        = return $ Float $ x - y
        go (List [Ratio x, Ratio y])        = return $ Ratio $ x - y
        go (List [Complex x, Complex y])    = return $ Complex $ x - y
        go _ = throwError $ Default "unexpected error in (-)"

-- | Multiply numbers
numMul :: [LispVal] -> ThrowsError LispVal
numMul []   = return $ Number 1
numMul l    = foldl1M (\ x y -> numCast [x, y] >>= go) l
    where
        go (List [Number x, Number y])      = return $ Number $ x * y
        go (List [Float x, Float y])        = return $ Float $ x * y
        go (List [Ratio x, Ratio y])        = return $ Ratio $ x * y
        go (List [Complex x, Complex y])    = return $ Complex $ x * y
        go _ = throwError $ Default "unexpected error in (*)"

-- |Divide two numbers
numDivide :: [LispVal] -> ThrowsError LispVal
numDivide [] = throwError $ NumArgs 1 []
numDivide [Number 0]   = throwError DivideByZero
numDivide [Ratio 0]     = throwError DivideByZero
numDivide [Number x]   = return $ Ratio $ 1 / fromInteger x
numDivide [Float x]    = return $ Float $ 1.0 / x
numDivide [Ratio x]    = return $ Ratio $ 1 / x
numDivide [Complex x]  = return $ Complex $ 1 / x
numDivide l = foldl1M (\ x y -> numCast [x, y] >>= go) l
    where
        go (List [Number x, Number y])
            | y == 0 = throwError DivideByZero
            | mod x y == 0 = return $ Number $ div x y -- Integer division
            | otherwise = return $ Ratio $ fromInteger x / fromInteger y
        go (List [Float x, Float y])
            | y == 0 = throwError DivideByZero
            | otherwise = return $ Float $ x / y
        go (List [Ratio x, Ratio y])
            | y == 0 = throwError DivideByZero
            | otherwise = return $ Ratio $ x / y
        go (List [Complex x, Complex y])
            | y == 0 = throwError DivideByZero
            | otherwise = return $ Complex $ x / y
        go _ = throwError $ Default "unexpected error in (/)"

-- |Numerical modulus
numMod :: [LispVal] -> ThrowsError LispVal
numMod [] = return $ Number 1
numMod l = foldl1M (\ x y -> numCast [x, y] >>= go) l
    where
        go (List [Number a, Number b]) = return $ Number $ mod' a b
        go (List [Float a, Float b]) = return $ Float $ mod' a b
        go (List [Ratio a, Ratio b]) = return $ Ratio $ mod' a b
        -- #TODO implement modulus for complex numbers
        go (List [Complex a, Complex b]) = throwError $ Default "modulus is not yet implemented for complex numbers"
        go _ = throwError $ Default "unexpected error in (modulus)"

-- | Boolean operator
numBoolBinop :: (LispVal -> LispVal -> Bool) -> [LispVal] -> ThrowsError LispVal
numBoolBinop op [] = throwError $ Default "need at least two arguments"
numBoolBinop op [x] = throwError $ Default "need at least two arguments"
numBoolBinop op [x, y] = numCast [x, y] >>= go op
    where
        go op (List [x@(Number _),  y@(Number _)])      = return $ Bool $ x `op` y
        go op (List [x@(Float _),   y@(Float _)])       = return $ Bool $ x `op` y
        go op (List [x@(Ratio _),   y@(Ratio _)])       = return $ Bool $ x `op` y
        go op (List [x@(Complex _), y@(Complex _)])     = return $ Bool $ x `op` y
        go op _ = throwError $ Default "unexpected error in boolean operation"

-- |Accept two numbers and cast one as the appropriate type
numCast :: [LispVal] -> ThrowsError LispVal
-- Same type, just return the two numbers
numCast [a@(Number _),  b@(Number _)]   = return $ List [a,b]
numCast [a@(Float _),   b@(Float _)]    = return $ List [a,b]
numCast [a@(Ratio _),   b@(Ratio _)]    = return $ List [a,b]
numCast [a@(Complex _), b@(Complex _)]  = return $ List [a,b]
-- First number is an integer
numCast [Number a,  b@(Float _)]      = return $ List [Float $ fromInteger a, b]
numCast [Number a,  b@(Ratio _)]      = return $ List [Ratio $ fromInteger a, b]
numCast [Number a,  b@(Complex _)]    = return $ List [Complex $ fromInteger a, b]
-- First number is a float
numCast [a@(Float _),  Number b]      = return $ List [a, Float $ fromInteger b]
numCast [a@(Float _),  Ratio b]       = return $ List [a, Float $ fromRational b]
numCast [Float a,  b@(Complex _)]     = return $ List [Complex $ a :+ 0, b]
-- First number is a rational
numCast [a@(Ratio _),  Number b]      = return $ List [a, Ratio $ fromInteger b]
numCast [Ratio a,  b@(Float _)]       = return $ List [Float $ fromRational a, b]
numCast [Ratio a,  b@(Complex _)] =
    return $ List [Complex $ fromInteger (numerator a) / fromInteger (denominator a), b]
-- First number is a complex
numCast [a@(Complex _),  Number b] = return $ List [a, Complex $ fromInteger b]
numCast [a@(Complex _),  Float b]     = return $ List [a, Complex $ b :+ 0]
numCast [a@(Complex _),  Ratio b] =
    return $ List [a, Complex $ fromInteger (numerator b) / fromInteger (denominator b)]
-- Error cases
numCast [a, b] = case a of
        Number _ -> throwError $ TypeMismatch "number" b
        Float _ -> throwError $ TypeMismatch "number" b
        Ratio _ -> throwError $ TypeMismatch "number" b
        Complex _ -> throwError $ TypeMismatch "number" b
        _ -> throwError $ TypeMismatch "number" a
numCast _ = throwError $ Default "unknown error in numCast"

-- |Take a primitive Haskell Integer function and wrap it
-- with code to unpack an argument list, apply the function to it
-- and return a numeric value
numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
-- Throw an error if there's only one argument
numericBinop op val@[_] = throwError $ NumArgs 2 val
-- Fold the operator leftway if there are enough args
numericBinop op params = mapM unpackNum params >>= return . Number . foldl1 op

-- |Convert a Number to a String
numToString :: [LispVal] -> ThrowsError LispVal
numToString [Number x] = return $ String $ show x
numToString [Float x] = return $ String $ show x
numToString [Ratio x] = return $ String $ show x
numToString [Complex x] = return $ String $ show x
numToString [x] = throwError $ TypeMismatch "number" x
numToString badArgList = throwError $ NumArgs 2 badArgList

-- | Trigonometric functions
sciCos, sciSin, sciTan, sciAcos, sciAsin, sciAtan :: [LispVal] -> ThrowsError LispVal
-- | Cosine of a number
sciCos [Number x] = return $ Float $ cos $ fromInteger x
sciCos [Float x] = return $ Float $ cos x
sciCos [Ratio x] = return $ Float $ cos $ fromRational x
sciCos [Complex x] = return $ Complex $ cos x
sciCos [notnum] = throwError $ TypeMismatch "number" notnum
sciCos badArgList = throwError $ NumArgs 1 badArgList
-- | Sine of a number
sciSin [Number x] = return $ Float $ sin $ fromInteger x
sciSin [Float x] = return $ Float $ sin x
sciSin [Ratio x] = return $ Float $ sin $ fromRational x
sciSin [Complex x] = return $ Complex $ sin x
sciSin [notnum] = throwError $ TypeMismatch "number" notnum
sciSin badArgList = throwError $ NumArgs 1 badArgList
-- | Tangent of a number
sciTan [Number x] = return $ Float $ tan $ fromInteger x
sciTan [Float x] = return $ Float $ tan x
sciTan [Ratio x] = return $ Float $ tan $ fromRational x
sciTan [Complex x] = return $ Complex $ tan x
sciTan [notnum] = throwError $ TypeMismatch "number" notnum
sciTan badArgList = throwError $ NumArgs 1 badArgList
-- | Arccosine of a number
sciAcos [Number x] = return $ Float $ acos $ fromInteger x
sciAcos [Float x] = return $ Float $ acos x
sciAcos [Ratio x] = return $ Float $ acos $ fromRational x
sciAcos [Complex x] = return $ Complex $ acos x
sciAcos [notnum] = throwError $ TypeMismatch "number" notnum
sciAcos badArgList = throwError $ NumArgs 1 badArgList
-- | Sine of a number
sciAsin [Number x] = return $ Float $ asin $ fromInteger x
sciAsin [Float x] = return $ Float $ asin x
sciAsin [Ratio x] = return $ Float $ asin $ fromRational x
sciAsin [Complex x] = return $ Complex $ asin x
sciAsin [notnum] = throwError $ TypeMismatch "number" notnum
sciAsin badArgList = throwError $ NumArgs 1 badArgList
-- | Tangent of a number
sciAtan [Number x] = return $ Float $ atan $ fromInteger x
sciAtan [Float x] = return $ Float $ atan x
sciAtan [Ratio x] = return $ Float $ atan $ fromRational x
sciAtan [Complex x] = return $ Complex $ atan x
sciAtan [notnum] = throwError $ TypeMismatch "number" notnum
sciAtan badArgList = throwError $ NumArgs 1 badArgList

-- #TODO Implement hyperbolic functions
-- Ask teacher
-- | Hyperbolic functions
-- sciAcosh, sciAsinh, sciAtanh, sciCosh, sciSinh, sciTanh :: [LispVal] -> ThrowsError LispVal

-- Misc. Scientific primitives
sciSqrt, sciExp, sciExpt, sciLog :: [LispVal] -> ThrowsError LispVal
-- | Square root of a number
sciSqrt [Number x] = return $ Float $ sqrt $ fromInteger x
sciSqrt [Float x] = return $ Float $ sqrt x
sciSqrt [Ratio x] = return $ Float $ sqrt $ fromRational x
sciSqrt [Complex x] = return $ Complex $ sqrt x
sciSqrt [notnum] = throwError $ TypeMismatch "number" notnum
sciSqrt badArgList = throwError $ NumArgs 1 badArgList
-- | Return e to the power of x
sciExp [Number x] = return $ Float $ exp $ fromInteger x
sciExp [Float x] = return $ Float $ exp x
sciExp [Ratio x] = return $ Float $ exp $ fromRational x
sciExp [Complex x] = return $ Complex $ exp x
sciExp [notnum] = throwError $ TypeMismatch "number" notnum
sciExp badArgList = throwError $ NumArgs 1 badArgList
-- | Return x to the power of y
sciExpt [x, y] = numCast [x, y] >>= go
    where
        go (List [Number x, Number y])      = return $ Number $ round $ (fromInteger x) ** (fromInteger y)
        go (List [Float x, Float y])        = return $ Float $ x ** y
        go (List [Ratio x, Ratio y])        = return $ Float $ (fromRational x) ** (fromRational y)
        go (List [Complex x, Complex y])    = return $ Complex $ x ** y
        go _ = throwError $ Default "unexpected error in (-)"
sciExpt badArgList = throwError $ NumArgs 2 badArgList
-- | Return the natural logarithm of x
sciLog [Number x] = return $ Float $ log $ fromInteger x
sciLog [Float x] = return $ Float $ log x
sciLog [Ratio x] = return $ Float $ log $ fromRational x
sciLog [Complex x] = return $ Complex $ log x
sciLog [notnum] = throwError $ TypeMismatch "number" notnum
sciLog badArgList = throwError $ NumArgs 1 badArgList

-- #TODO implement phase (angle)
-- Ask teacher how to convert phase formats from haskell to guile scheme
-- | Complex number functions
cRealPart, cImagPart, cMakePolar, cMagnitude  :: [LispVal] -> ThrowsError LispVal
-- | Real part of a complex number
cRealPart [Number x] = return $ Number $ fromInteger x
cRealPart [Float x] = return $ Float x
cRealPart [Ratio x] = return $ Float $ fromRational x
cRealPart [Complex x] = return $ Float $ realPart x
cRealPart [notnum] = throwError $ TypeMismatch "number" notnum
cRealPart badArgList = throwError $ NumArgs 1 badArgList
-- | Imaginary part of a complex number
cImagPart [Number x] = return $ Number 0
cImagPart [Float x] = return $ Number 0
cImagPart [Ratio x] = return $ Number 0
cImagPart [Complex x] = return $ Float $ imagPart x
cImagPart [notnum] = throwError $ TypeMismatch "number" notnum
cImagPart badArgList = throwError $ NumArgs 1 badArgList
-- | Form a complex number from polar components of magnitude and phase.
cMakePolar [mag, p] = numCast [mag, p] >>= go
        where
            go (List [Number mag, Number p])
                | mag == 0 = return $ Number 0
                | p == 0 = return $ Number mag
                | otherwise = return $ Complex $ mkPolar (fromInteger mag) (fromInteger p)
            go (List [Float mag, Float p])
                | mag == 0 = return $ Number 0
                | p == 0 = return $ Float mag
                | otherwise = return $ Complex $ mkPolar mag p
            go (List [Ratio mag, Ratio p])
                | mag == 0 = return $ Number 0
                | p == 0 = return $ Float (fromRational mag)
                | otherwise = return $ Complex $ mkPolar (fromRational mag) (fromRational p)
            go val@(List [Complex mag, Complex p]) = throwError $ TypeMismatch "real" val
            go _ = throwError $ Default "unexpected error in make-polar"
cMakePolar badArgList = throwError $ NumArgs 2 badArgList
-- | Return the magnitude (length) of a complex number
cMagnitude [Number x] = return $ Number $ fromInteger x
cMagnitude [Float x] = return $ Float x
cMagnitude [Ratio x] = return $ Float $ fromRational x
cMagnitude [Complex x] = return $ Float $ magnitude x
cMagnitude [notnum] = throwError $ TypeMismatch "number" notnum
cMagnitude badArgList = throwError $ NumArgs 1 badArgList


-- Gaussian arithmetic
-- http://www.codewars.com/kata/55182e34a5808b90f4001335/

module Data.Complex.Gaussian.Instances (Gaussian (..)) where

import Data.Complex.Gaussian (Gaussian (..))

instance Num Gaussian where
    (+) (Gaussian a b) (Gaussian c d) = Gaussian (a + c) (b + d)
    (*) (Gaussian a b) (Gaussian c d) = Gaussian (a*c-b*d) (a*d+b*c)
    negate (Gaussian a b) = Gaussian (negate a) (negate b)
    signum (Gaussian 0 0) = Gaussian 0 0
    signum (Gaussian a b) | a  > 0 && b >= 0 = Gaussian   1   0
                          | a <= 0 && b >  0 = Gaussian   0   1
                          | a  < 0 && b <= 0 = Gaussian (-1)  0
                          | a >= 0 && b <  0 = Gaussian   0 (-1)
    abs (Gaussian 0 0) = Gaussian 0 0
    abs (Gaussian a b) | a  > 0 && b >= 0 = Gaussian   a    b
                       | a <= 0 && b >  0 = Gaussian   b  (-a)
                       | a  < 0 && b <= 0 = Gaussian (-a) (-b)
                       | a >= 0 && b <  0 = Gaussian (-b)   a
    fromInteger n = Gaussian n 0

instance Integral Gaussian where
    toInteger (Gaussian a b) = a*a + b*b
    quotRem (Gaussian a b) (Gaussian c d) = (q, (Gaussian a b) - q * (Gaussian c d))
        where q = Gaussian ((a*c+b*d) `quot` (c*c+d*d)) ((b*c-a*d) `quot` (c*c+d*d))


{-|
Module: Math.Ftensor.Algebra
Copyright: (c) 2015 Michael Benfield
License: ISC

Classes supporting arithmetic operations. Haskell's numeric classes are too
coarse for our needs. Types which are instances of more than one of these
classes should satisfy the obvious compatibility relations between the various
operations.

For instance, the equalities @x -. x = zero@ and @x *. (y +. z) = x *. y +. x
*. z@ and @one *. x = x@ should hold. If the type in question implements
inexact arithmetic, they should hold approximately.

For an instance of @Num@, these should hold whenever the type is also an
instance of the classes defining these functions:

* @(+.) = (+)@

* @(*.) = (*)@

* @(-.) = (-)@

* @neg = negate@

* @one = fromInteger 1@

* @zero = fromInteger 0@

Similarly, for an instance of @Fractional@

* @(\/.) = (\/)@

* @inv = recip@
-}

{-# LANGUAGE CPP #-}

module Math.Ftensor.Algebra (
    Additive(..),
    WithZero(..),
    WithNegatives(..),
    Multiplicative(..),
    WithOne(..),
    WithReciprocals(..),
    WithScalars(..),
    Rg,
    Rng,
    Rig,
    Ring,
    Field,
    Module,
    VectorSpace,
    Algebra,
    UnitalAlgebra,
) where

import Data.Complex (Complex)
import Data.Int
import Data.Ratio (Ratio)
import Data.Word
import Numeric.Natural

infixl 6 +.

class Additive a where
    (+.) :: a -> a -> a

-- | Types that have an additive identity. Should satisfy:
--
-- * @x +. zero = zero +. x = x@
class Additive a => WithZero a where
    zero :: a

infixl 6 -.

-- | Types that have additive inverses. Should satisfy:
-- @neg x = zero -. x@ and @x -. x = zero@.
class WithZero a => WithNegatives a where
    {-# MINIMAL neg | (-.) #-}
    neg :: a -> a
    neg x = zero -. x
    (-.) :: a -> a -> a
    lhs -. rhs = lhs +. neg rhs

infixl 7 *.

class Multiplicative a where
    (*.) :: a -> a -> a

-- | Types with a multiplicative identity. Should satisfy:
--
-- * @one *. x = x *. one = x@.
class Multiplicative a => WithOne a where
    one :: a

infixl 7 /.

-- | Types with multiplicative inverse.
-- @inv x@ and @y /. x@
-- may throw an exception or behave in undefined ways if
-- @invertible x = False@.
--
-- * @inv x = one ./ x@
--
-- * @y *. x /. y = x@
--
-- * @x /. y *. x = y@
class WithOne a => WithReciprocals a where

    {-# MINIMAL invertible, (inv | (/.)) #-}
    invertible :: a -> Bool

    inv :: a -> a
    inv x = one /. x

    (/.) :: a -> a -> a
    lhs /. rhs = lhs *. inv rhs

infixl 7 *:

-- | Types like mathematical vectors that can be multiplied by another type.
class WithScalars a where
    type Scalar a
    (*:) :: Scalar a -> a -> a

-- | A @Rg@ is a Ring without one or negatives.
type Rg a = (WithZero a, Multiplicative a)

-- | A @Rng@ is a Ring without one.
type Rng a = (Rg a, WithNegatives a)

-- | A @Rig@ is a Ring without negatives.
type Rig a = (Rg a, WithOne a)

type Ring a = (Rng a, Rig a)

type Field a = (Ring a, WithReciprocals a)

type Module a = (WithNegatives a, WithScalars a, Ring (Scalar a))

type VectorSpace a = (Module a, Field (Scalar a))

type Algebra a = (VectorSpace a, Rng a)

type UnitalAlgebra a = (Algebra a, WithOne a)

#define INSTANCES_NUM(typ, ctxt) \
instance ctxt Additive (typ) where { \
; {-# INLINE (+.) #-} \
; (+.) = (+) \
} ; instance ctxt WithZero (typ) where { \
; {-# INLINE zero #-} \
; zero = 0 \
} ; instance ctxt WithNegatives (typ) where { \
; {-# INLINE neg #-} \
; neg = negate \
; {-# INLINE (-.) #-} \
; (-.) = (-) \
} ; instance ctxt Multiplicative (typ) where { \
; {-# INLINE (*.) #-} \
; (*.) = (*) \
} ; instance ctxt WithOne (typ) where { \
; {-# INLINE one #-} \
; one = 1 \
} ; instance ctxt WithScalars (typ) where { \
; type Scalar (typ) = typ \
; {-# INLINE (*:) #-} \
; (*:) = (*) \
}

#define INSTANCES_FRACTIONAL(typ, ctxt) \
INSTANCES_NUM(typ, ctxt) ; \
instance ctxt WithReciprocals (typ) where { \
; {-# INLINE invertible #-} \
; invertible = (/= 0) \
; {-# INLINE inv #-} \
; inv = recip \
; {-# INLINE (/.) #-} \
; (/.) = (/) \
}

INSTANCES_NUM(Natural, )
INSTANCES_NUM(Integer, )
INSTANCES_NUM(Int, )
INSTANCES_NUM(Int8, )
INSTANCES_NUM(Int16, )
INSTANCES_NUM(Int32, )
INSTANCES_NUM(Int64, )
INSTANCES_NUM(Word, )
INSTANCES_NUM(Word8, )
INSTANCES_NUM(Word16, )
INSTANCES_NUM(Word32, )
INSTANCES_NUM(Word64, )

INSTANCES_FRACTIONAL(Float, )
INSTANCES_FRACTIONAL(Double, )
INSTANCES_FRACTIONAL(Complex a, RealFloat a =>)
INSTANCES_FRACTIONAL(Ratio a, Integral a =>)


{-- --:= Mark: find better way to construct complex number
type ImaginaryUnit = Integer
type RealNumber = Integer
data ComplexNumber = ComplexN {real :: RealNumber,
                               imag :: ImaginaryUnit}
--}

import           Data.Complex

readComplex :: String -> Complex Double
readComplex = read

result :: (String, String) -> Complex Double
result (x,y) = (readComplex x) * (readComplex y)

main = do
  let exm1 = ("1 :+ 1","1 :+ 1")
  let exm2 = ("1 :+ -1","1 :+ -1")
  print $ result exm1
  print $ result exm2


{-# LANGUAGE RankNTypes, BangPatterns, ScopedTypeVariables #-}

module Main where

import Math.Probably.MCMC
import qualified Math.Probably.PDF as PDF
import Math.Probably.RandIO
import Math.Probably.HamMC
import Math.Probably.MALA
import Math.Probably.FoldingStats
import Math.Probably.Sampler
import Control.Applicative
import Control.Monad

import Numeric.LinearAlgebra
import Numeric.AD
import Text.Printf

import Graphics.Gnewplot.Exec
import Graphics.Gnewplot.Types
import Graphics.Gnewplot.Style
import Graphics.Gnewplot.Panels
import Graphics.Gnewplot.Instances
import Graphics.Gnewplot.Histogram
import qualified Data.Vector.Storable as V

import Debug.Trace

import qualified Control.Monad.State.Strict as S

varf i = [10, 0.5, 1, 5, 0.1]!!(i `mod` 5)

corrf i j | i < j = corrf j i
          | otherwise = [-0.5, -0.2, 0, 0.2, 0.5]!!((i+j) `mod` 5)

covf (i,j) | i == j = varf i
           | otherwise = varf i * varf j * corrf i j

d = 3

muMVN = fromList $ replicate d 10
covMVN = buildMatrix d d covf

(invSigmaMVN, (lndetMVN, _)) = invlndet covMVN

pdfMVN = PDF.multiNormalByInv lndetMVN invSigmaMVN muMVN

--pdfI :: [Double] -> Double
pdfI xs = sum $ map f $ zip xs (map varf [0..]) where
  f (x, var) = PDF.normal 10 var x

pdfI2 xs = sum $ map f $ zip xs (map varf [0..]) where
  f (x, var) = PDF.logNormal 0.1 var x

pdf3 [alpha, error_sd] = sum $ map f regrdata where
  f (age, height) = PDF.normalLogPdf (alpha) error_sd  height

pdf2 [alpha, error_sd, beta] = sum $ map f regrdata where
  f (age, height) = PDF.normalLogPdf (alpha+(age*beta)) error_sd  height

regrdata :: (Real a, Floating a) => [(a,a)]
regrdata = [ 35.1**6.3,
 1.5**	2.1,
 35.2**	5.1,
 4.5**	3.1,
 10.1**	3.9,
 80.4**	9.1,
 5.2**	3.2,
 60.1**	8.1,
 70.1**	9.1,
 40.6**	7] where (**) = (,)

-- split HMC paper p 5
nealCov :: Matrix Double
neal_d = 200

nealCov = buildMatrix neal_d neal_d $ \(i,j) -> if i==j then realToFrac (i+1) / 100 else 0
--(2><2) [1, 0.95, 0.95, 2]
(nealCovInv, (nealLnDet,_)) = invlndet nealCov
nealMean = fromList $ replicate neal_d 3
nealPDF v = PDF.multiNormalByInv nealLnDet nealCovInv nealMean v
nealPostGrad v =
  let p = nealPDF v
      tol = 0.001
      f (i,x) = let h = max (tol/10) $ tol * x
                    v' = v V.// [(i,x+h)]
                    v'' = v V.// [(i,x-h)]
                in (nealPDF v' - nealPDF v'')/(2*h)
      grad3 = fromList $ map f $ zip [0..] $ toList v
  in (p,grad3)

covM1 :: Matrix Double
covM1 = (3><3) [1, 0,0,
                0 , 2,0,
                0, 0, 4]

means1, vars2 :: Vector Double
vars2 = fromList [1,2,4]

means1 = fromList [3,3,3]

(covMinv, (covMLnDet,_)) = invlndet covM1

main = runRIO $ do
  --io $ print $ nealCov
  --io $ print $ nealCovInv
{-  vs1 <- sample $ sequence $ replicate 10000 $ multiNormal means1 covM1
  io $ print $ runStat meanSDF $ map (@>0) $ vs1
  io $ print $ runStat meanSDF $ map (@>1) $ vs1
  io $ print $ runStat meanSDF $ map (@>2) $ vs1
  vs1 <- sample $ sequence $ replicate 10000 $ mvnSampler means1 2 vars2
  io $ print $ runStat meanSDF $ map (@>0) $ vs1
  io $ print $ runStat meanSDF $ map (@>1) $ vs1
  io $ print $ runStat meanSDF $ map (@>2) $ vs1
  io $ print $ PDF.multiNormal means1 (scale 2 covM1) (fromList [2,2,2])
--  io $ print $ PDF.multiNormalByInv covMLnDet covMinv means1 (fromList [2,2,2])
--  io $ print $ PDF.multiNormalIndep vars2 means1  (fromList [2,2,2])
  io $ print $ mvnPDF means1 2 vars2  (fromList [2,2,2]) -}
  let vinit = fromList $ replicate neal_d (1)
  --io $ print $ nealPostGrad vinit
  let pinit = fst $ nealPostGrad vinit
  io $ print $ ("pinit", pinit)
  let hmcp0 = HMCPar vinit 100 0 0.15 0 0 True
--  (vs') <- runMalaRioSimple (nealCov, nealCovInv, cholSH nealCov) nealPostGrad 2000 100 10 vinit
  (hmcp1, vs') <- runHMC nealPostGrad 100 hmcp0
  let vs = drop 50 $ reverse vs'
  --io $ forM (vs) $ \v -> print (v, nealPDF v)
  io $ print $ runStat meanSDF $ map (@>20) $ vs
  io $ print $ runStat meanSDF $ map (@>80) $ vs
  let have_ess = calcESSprim $ vs
  io  $ putStrLn $ "ESS=" ++show have_ess
  --io $ print hmcp1
  return ()

thin n [] = []
thin n (x:xs) = x : thin n (drop n xs)

covF i j = pure (-) <*> before meanF (\v -> v@>i * v@>j)
                    <*> fmap (uncurry (*)) (both (before meanF (@>i)) (before meanF (@>j)))

--cache prev, use grad'?


{-# LANGUAGE FlexibleContexts #-}
-- |
-- Module    : Statistics.Quantile
-- Copyright : (c) 2009 Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- Functions for approximating quantiles, i.e. points taken at regular
-- intervals from the cumulative distribution function of a random
-- variable.
--
-- The number of quantiles is described below by the variable /q/, so
-- with /q/=4, a 4-quantile (also known as a /quartile/) has 4
-- intervals, and contains 5 points.  The parameter /k/ describes the
-- desired point, where 0 ≤ /k/ ≤ /q/.

module Statistics.Quantile
    (
    -- * Quantile estimation functions
      weightedAvg
    , ContParam(..)
    , continuousBy
    , midspread

    -- * Parameters for the continuous sample method
    , cadpw
    , hazen
    , s
    , spss
    , medianUnbiased
    , normalUnbiased

    -- * References
    -- $references
    ) where

import Data.Vector.Generic ((!))
import Numeric.MathFunctions.Constants (m_epsilon)
import Statistics.Function (partialSort)
import qualified Data.Vector as V
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U

-- | O(/n/ log /n/). Estimate the /k/th /q/-quantile of a sample,
-- using the weighted average method.
weightedAvg :: G.Vector v Double =>
               Int        -- ^ /k/, the desired quantile.
            -> Int        -- ^ /q/, the number of quantiles.
            -> v Double   -- ^ /x/, the sample data.
            -> Double
weightedAvg k q x
  | G.any isNaN x   = modErr "weightedAvg" "Sample contains NaNs"
  | n == 1          = G.head x
  | q < 2           = modErr "weightedAvg" "At least 2 quantiles is needed"
  | k < 0 || k >= q = modErr "weightedAvg" "Wrong quantile number"
  | otherwise       = xj + g * (xj1 - xj)
  where
    j   = floor idx
    idx = fromIntegral (n - 1) * fromIntegral k / fromIntegral q
    g   = idx - fromIntegral j
    xj  = sx ! j
    xj1 = sx ! (j+1)
    sx  = partialSort (j+2) x
    n   = G.length x
{-# SPECIALIZE weightedAvg :: Int -> Int -> U.Vector Double -> Double #-}
{-# SPECIALIZE weightedAvg :: Int -> Int -> V.Vector Double -> Double #-}

-- | Parameters /a/ and /b/ to the 'continuousBy' function.
data ContParam = ContParam {-# UNPACK #-} !Double {-# UNPACK #-} !Double

-- | O(/n/ log /n/). Estimate the /k/th /q/-quantile of a sample /x/,
-- using the continuous sample method with the given parameters.  This
-- is the method used by most statistical software, such as R,
-- Mathematica, SPSS, and S.
continuousBy :: G.Vector v Double =>
                ContParam  -- ^ Parameters /a/ and /b/.
             -> Int        -- ^ /k/, the desired quantile.
             -> Int        -- ^ /q/, the number of quantiles.
             -> v Double   -- ^ /x/, the sample data.
             -> Double
continuousBy (ContParam a b) k q x
  | q < 2          = modErr "continuousBy" "At least 2 quantiles is needed"
  | k < 0 || k > q = modErr "continuousBy" "Wrong quantile number"
  | G.any isNaN x  = modErr "continuousBy" "Sample contains NaNs"
  | otherwise      = (1-h) * item (j-1) + h * item j
  where
    j               = floor (t + eps)
    t               = a + p * (fromIntegral n + 1 - a - b)
    p               = fromIntegral k / fromIntegral q
    h | abs r < eps = 0
      | otherwise   = r
      where r       = t - fromIntegral j
    eps             = m_epsilon * 4
    n               = G.length x
    item            = (sx !) . bracket
    sx              = partialSort (bracket j + 1) x
    bracket m       = min (max m 0) (n - 1)
{-# SPECIALIZE
    continuousBy :: ContParam -> Int -> Int -> U.Vector Double -> Double #-}
{-# SPECIALIZE
    continuousBy :: ContParam -> Int -> Int -> V.Vector Double -> Double #-}

-- | O(/n/ log /n/). Estimate the range between /q/-quantiles 1 and
-- /q/-1 of a sample /x/, using the continuous sample method with the
-- given parameters.
--
-- For instance, the interquartile range (IQR) can be estimated as
-- follows:
--
-- > midspread medianUnbiased 4 (U.fromList [1,1,2,2,3])
-- > ==> 1.333333
midspread :: G.Vector v Double =>
             ContParam  -- ^ Parameters /a/ and /b/.
          -> Int        -- ^ /q/, the number of quantiles.
          -> v Double   -- ^ /x/, the sample data.
          -> Double
midspread (ContParam a b) k x
  | G.any isNaN x = modErr "midspread" "Sample contains NaNs"
  | k <= 0        = modErr "midspread" "Nonpositive number of quantiles"
  | otherwise     = quantile (1-frac) - quantile frac
  where
    quantile i        = (1-h i) * item (j i-1) + h i * item (j i)
    j i               = floor (t i + eps) :: Int
    t i               = a + i * (fromIntegral n + 1 - a - b)
    h i | abs r < eps = 0
        | otherwise   = r
        where r       = t i - fromIntegral (j i)
    eps               = m_epsilon * 4
    n                 = G.length x
    item              = (sx !) . bracket
    sx                = partialSort (bracket (j (1-frac)) + 1) x
    bracket m         = min (max m 0) (n - 1)
    frac              = 1 / fromIntegral k
{-# SPECIALIZE midspread :: ContParam -> Int -> U.Vector Double -> Double #-}
{-# SPECIALIZE midspread :: ContParam -> Int -> V.Vector Double -> Double #-}

-- | California Department of Public Works definition, /a/=0, /b/=1.
-- Gives a linear interpolation of the empirical CDF.  This
-- corresponds to method 4 in R and Mathematica.
cadpw :: ContParam
cadpw = ContParam 0 1

-- | Hazen's definition, /a/=0.5, /b/=0.5.  This is claimed to be
-- popular among hydrologists.  This corresponds to method 5 in R and
-- Mathematica.
hazen :: ContParam
hazen = ContParam 0.5 0.5

-- | Definition used by the SPSS statistics application, with /a/=0,
-- /b/=0 (also known as Weibull's definition).  This corresponds to
-- method 6 in R and Mathematica.
spss :: ContParam
spss = ContParam 0 0

-- | Definition used by the S statistics application, with /a/=1,
-- /b/=1.  The interpolation points divide the sample range into @n-1@
-- intervals.  This corresponds to method 7 in R and Mathematica.
s :: ContParam
s = ContParam 1 1

-- | Median unbiased definition, /a/=1\/3, /b/=1\/3. The resulting
-- quantile estimates are approximately median unbiased regardless of
-- the distribution of /x/.  This corresponds to method 8 in R and
-- Mathematica.
medianUnbiased :: ContParam
medianUnbiased = ContParam third third
    where third = 1/3

-- | Normal unbiased definition, /a/=3\/8, /b/=3\/8.  An approximately
-- unbiased estimate if the empirical distribution approximates the
-- normal distribution.  This corresponds to method 9 in R and
-- Mathematica.
normalUnbiased :: ContParam
normalUnbiased = ContParam ta ta
    where ta = 3/8

modErr :: String -> String -> a
modErr f err = error $ "Statistics.Quantile." ++ f ++ ": " ++ err

-- $references
--
-- * Weisstein, E.W. Quantile. /MathWorld/.
--   <http://mathworld.wolfram.com/Quantile.html>
--
-- * Hyndman, R.J.; Fan, Y. (1996) Sample quantiles in statistical
--   packages. /American Statistician/
--   50(4):361–365. <http://www.jstor.org/stable/2684934>


module Lib
  (
    trainNetwork
  , classifyTest
  , generateExps
  , runExperiment
  , runExpsIO
  , runExpIO
  ) where

import Numeric.LinearAlgebra

import Net
import CSVMatrixParser

import Data.List
import Text.Printf

type LearningRate = Double
type Epochs = Int
type HiddenUnits = Int
type Sigmoid = Bool

data Experiment = Experiment LearningRate Epochs HiddenUnits Sigmoid deriving (Show, Eq)

latexExp :: Experiment -> String
latexExp (Experiment lr e hu s) = show hu ++ " & " ++ show e ++ " & "
                                  ++ (printf "%.3f" lr :: String) ++ " & " ++ (if s then "Sigmoid" else "Tanh")

latexResults :: [Double] -> String
latexResults results = foldl (\str r -> str ++ " & " ++ (printf "%.2f" (100 * r) :: String) ++ "\\%") "" results

generateExps :: [LearningRate] -> [Epochs] -> [HiddenUnits] -> [Sigmoid] -> [Experiment]
generateExps lrs es hus ss = [Experiment lr e hu s | lr <- lrs, e <- es, hu <- hus, s <- ss]

runExpIO :: String -> [String] -> Experiment -> IO ()
runExpIO trainData testData exp = do
  results1 <- runExperiment trainData testData exp
  results2 <- runExperiment trainData testData exp
  results3 <- runExperiment trainData testData exp
  let avgResults = zipWith3 (\a b c -> (a + b + c) / 3.0) results1 results2 results3
  putStrLn (latexExp exp ++ latexResults avgResults ++ "\\\\")

runExpsIO :: String -> [String] -> [Experiment] -> IO ()
runExpsIO trainData testData = mapM_ (runExpIO trainData testData)

runExperiment :: String -> [String] -> Experiment -> IO [Double]
runExperiment trainData testData (Experiment lr e hu s)  = do
  network <- trainNetwork trainData lr e hu s
  sequence $ map (classifyTest network) testData

trainNetwork :: String -> LearningRate -> Epochs -> HiddenUnits -> Sigmoid -> IO NN
trainNetwork trainingData lr epochs nh isSigmoid = do
  let (f, f') = if isSigmoid then (sigmoid, sigmoid') else (tanh, tanh')
  (i,o) <- getData trainingData
  net   <- buildNetwork (f,f') [5,nh,2]
  return $ repTrain epochs lr i o net

classifyTest :: NN -> String -> IO Double
classifyTest net testData = do
  (i,o) <- getData testData
  let output = forward net i
      testRows = toRows o
      expRows = toRows output
      testClass = map classification testRows
      expClass = map classification expRows
      correct = zipWith xnor testClass expClass
      numCorrect = length $ filter id correct
      percentageCorrect = (fromIntegral numCorrect) / (fromIntegral $ length correct)
  return percentageCorrect

classification :: Vector R -> Bool
classification vec = vec ! 0 < 0.5 && vec ! 1 > 0.5

xnor :: Bool -> Bool -> Bool
xnor True True = True
xnor False False = True
xnor _ _ = False


module NeuralNet.MatrixSpec (matrixSpec) where

import Test.Hspec
import Numeric.LinearAlgebra
import NeuralNet.Matrix

matrixSpec :: SpecWith ()
matrixSpec =
  describe "NeuralNet.Matrix" $ do
    describe "sumRows" $
      it "should work correctly" $
        let
          source = fromLists [[0, 1], [2, 3], [4, 5]]
          expected = fromLists [[1], [5], [9]]
        in
          sumRows source `shouldBe` expected


{-# LANGUAGE ScopedTypeVariables #-}

module NaiveBayes where

import Data.List (maximumBy)
import Data.Ord (comparing)
import Mnist (LabeledData, groupByLabel, dat)
import Data.Function (on)
import Numeric.LinearAlgebra (Vector, Matrix, R, size, fromList, toColumns, sumElements, fromRows, (#>), toList)

-- TODO: later expand this by receiving label type and data type
data NaiveBayesClassifier = NBC
    { p :: !(Vector R)
    , l :: !(Matrix R)
    }

-- represents a classifier that predicts the class from input sample
class Classifier a where
    -- given the prior and likelihood, with a sample data, predict the class
    predict :: a -> Vector R -> Int  -- TODO: parameterize label type

instance Classifier NaiveBayesClassifier where
    predict nbc sample = argmax $ (p nbc) * (l nbc #> sample)

-- divide two integers to make a fraction
fractionDiv :: Fractional b => Int -> Int -> b
fractionDiv = (/) `on` fromIntegral

-- calculates the prior probability of a dataset
-- the data are organized as rows having same label
-- P(y)
prior :: LabeledData -> Vector R
prior ld = fromList $ map (flip fractionDiv totalNum) numElemsPerLabel
  where
    grouped :: [Matrix R] = groupByLabel ld
    numElemsPerLabel :: [Int] = map (fst . size) grouped
    totalNum = sum numElemsPerLabel

-- used as prior distribution of likelihood
epsilon :: R = 0.001

-- conditional likelihood of each data attributes given the class
-- P(x | y)
likelihood :: LabeledData -> Matrix R  -- data_class * data_dimension shape
likelihood ld = fromRows $ map attrProb colSumByLabel
  where
    grouped :: [Matrix R] = groupByLabel ld
    colSum :: Matrix R -> [R] = map sumElements . toColumns
    colSumByLabel :: [[R]] = map colSum grouped
    totalSum :: [R] = colSum $ dat ld
    -- create a vector of size DATA_DIMENSION that contains probability of each attributes
    attrProb classSum = fromList $ map (\ a -> fst a / (epsilon + snd a)) $ zip classSum totalSum

-- find maximum index in the vector
argmax :: Vector R -> Int
argmax = fst . maximumBy (comparing snd) . zip [0..] . toList


module Sound (soundFFT, wavesToTime) where

import qualified Config       as Conf
import           Data.Complex
import           Data.WAVE
import           Numeric.FFT

-- | Perform Fast Fourier Transform on the input data, called the
-- "time" domain, in order to get its representation in the "frequency"
-- domain.
soundFFT :: [Double] -> [Double]
soundFFT timeDomain = take Conf.samplesPerFreq (drop Conf.samplesShift $ mfft $ map (\t -> t :+ 0) timeDomain)

mfft :: [Complex Double] -> [Double]
mfft p = map (\l -> realPart $ abs l) (fft p)

-- | Converts WAVESamples to [Double] using sampleToDouble
-- function. For each channel it takes the average.
wavesToTime :: WAVESamples -> [Double]
wavesToTime []     = []
wavesToTime (h:tl) = (average $ map sampleToDouble h) : wavesToTime tl

-- | Calculates the average value of a given list.
average :: [Double] -> Double
average list = (sum list) / realToFrac (length list)


{-# LANGUAGE DataKinds       #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns    #-}

import           Data.Maybe
import           Numeric.Hamilton
import           Numeric.LinearAlgebra.Static
import qualified Data.Vector.Sized            as V

doublePendulum :: System 4 2
doublePendulum = mkSystem' masses coordinates potential
  where
    masses :: R 4
    masses = vec4 1 1 2 2
    coordinates
        :: Floating a
        => V.Vector 2 a
        -> V.Vector 4 a
    coordinates (V2 θ1 θ2) = V4 (sin θ1)            (-cos θ1)
                                (sin θ1 + sin θ2/2) (-cos θ1 - cos θ2/2)
    potential
        :: Num a
        => V.Vector 4 a
        -> a
    potential (V4 _ y1 _ y2) = (y1 + 2 * y2) * 5    -- assuming g = 5

pattern V2 :: a -> a -> V.Vector 2 a
pattern V2 x y <- (V.toList->[x,y])
  where
    V2 x y = fromJust (V.fromList [x,y])

pattern V4 :: a -> a -> a -> a -> V.Vector 4 a
pattern V4 x y z a <- (V.toList->[x,y,z,a])
  where
    V4 x y z a = fromJust (V.fromList [x,y,z,a])

config0 :: Config 2
config0 = Cfg (vec2 1 0  )  -- initial positions
              (vec2 0 0.5)  -- initial velocities

phase0 :: Phase 2
phase0 = toPhase doublePendulum config0

evolution :: [Phase 2]
evolution = evolveHam' doublePendulum phase0 [0,0.1 .. 1]

evolution' :: [Phase 2]
evolution' = iterate (stepHam 0.1 doublePendulum) phase0

positions :: [R 2]
positions = phsPositions <$> evolution'

positions' :: [R 4]
positions' = underlyingPos doublePendulum <$> positions

main :: IO ()
main = withRows (take 25 positions) (disp 4)


module Plotting where

import qualified Data.Random.Distribution.Normal        as DRDN
import qualified Data.Vector                            as V
import           Graphics.Rendering.Chart.Backend.Cairo
import           Graphics.Rendering.Chart.Easy
import qualified Numeric.LinearAlgebra.Data             as LAD
import qualified Sample                                 as S
import qualified Statistics.Distribution                as SD
import qualified Statistics.Distribution.Normal         as SDN
import qualified Statistics.Sample.Histogram            as SSH

normGrid :: [Double]
normGrid = LAD.toList $ LAD.linspace 100 (-3, 3)

normDensityGrid :: [Double]
normDensityGrid = fmap (SD.density SDN.standard) normGrid

fillFromZero :: [(Double, Double)] -> EC m2 (PlotFillBetween Double Double)
fillFromZero points = liftEC $ do
  plot_fillbetween_style .= solidFillStyle (grey `withOpacity` 0.25)
  plot_fillbetween_values .= fmap (\(x, y) -> (x, (0, y))) points

histPlot :: FilePath -> [(Double, Double)] -> IO ()
histPlot filename points = toFile def filename $ do
    setColors [opaque black]
    color <- takeColor
    plot (line "Density" [points])
    plot (fillFromZero points)

pHistPlot :: FilePath -> [Double] -> IO ()
pHistPlot = undefined

histogram :: Int -> [Double] -> [(Double, Double)]
histogram nBins xs = zip (V.toList grid) (V.toList densities)
  where
      (grid, counts) = SSH.histogram nBins (V.fromList xs)
      densities = V.map (\x -> x / fromIntegral (length xs)) counts

xs :: [Double]
xs = take 1000 (S.sample 123 DRDN.StdNormal)

go = histogram 25 xs