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


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


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


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


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

import Prelude hiding (sum)

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

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

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


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

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

module MultivariateNormal ( MultivariateNormal(..) ) where

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

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

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

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

data family MultivariateNormal k :: *

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

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

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

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

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

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


module Xor where

import Nnaskell
import Numeric.LinearAlgebra.Data

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

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


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

module Statistics.Autocorrelation
    (
      autocovariance
    , autocorrelation
    ) where

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

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

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


module Mandelbrot where

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

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

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

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

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

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

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

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

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

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


-- |

module Math.Algebra.Roots (zeros) where

import Data.Complex
import Polynomial.Roots

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


module Main where

import Numeric.LinearAlgebra

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

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

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

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

        tx' = trans x'

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

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

        lx = length x
        ly = length y

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

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

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

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


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

import Codec.Picture

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

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

  savePngImage "mandel.png" (ImageY8 img)

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

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

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

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


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

module Strategy.MALA (mala, adaMala) where

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

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

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

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

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

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

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

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

kmala :: Double
kmala = 5

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

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

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

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