{- |

This module defines the monad of sampling functions. See

Park, Pfenning and Thrun (2005) A probabilistic language based upon sampling
functions, Principles of Programming Languages 2005

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

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

Example -- a biased coin:

@
data Throw = Head | Tail

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

tenThrowsCrooked = replicateM 10 $ throw 0.3

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

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

-}

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

module Math.Probably.Sampler where

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

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

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

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

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

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

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

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

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

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

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

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

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

-- * Uniform distributions

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

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

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

-- * Normally distributed sampling function

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

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

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

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

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

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

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

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

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

-- | log-normal distribution <http://en.wikipedia.org/wiki/Log-normal_distribution>
logNormal :: Double -> Double -> Prob Double
logNormal m var =
    fmap exp $  normal m var

-- * Other distribution

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

discrete :: [(Double,a)] -> Prob a
discrete weightedSamples =
   let sumWeights = sum $ map fst weightedSamples
       cummWeightedSamples = scanl (\(csum,_) (w,x) -> (csum+w,x)) (0,undefined) $ sortBy (comparing fst) weightedSamples
   in do u <- unit
         case find ((>=u*sumWeights) . fst) cummWeightedSamples of
           Just (_,x) -> return x
           Nothing -> error $ "discrete error u*sumweigts="++show (u*sumWeights)++"wsams="++show (map fst cummWeightedSamples)

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

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

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

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

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

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

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

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

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

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

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

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

            go = do
                x <- unormal

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

                    x_2 = x * x
                    x_4 = x_2 * x_2

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

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

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

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

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


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

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

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

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

import           GHC.TypeLits

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

import           Grenade.Core.Shape
import           Grenade.Types

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


module Math.Probably.Student where

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

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

--ser :: Double
ser = 1.000000000190015

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


{-# LANGUAGE BangPatterns, TypeFamilies #-}

module Fractal2D ( mandelbrot
                 , juliaAnimated
                 ) where

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

import ConcurrentSegments

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

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

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

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

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


-- nonlinear least-squares fitting

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

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

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

xs = [0..100]

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

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

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

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

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

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


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

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

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


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

-}

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

where

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

import MachineLearning.Model
import qualified MachineLearning.Regularization as R

data LogisticModel = Logistic

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

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

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

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

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


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

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

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

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

  deriving (Show)

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

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

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

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

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

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

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

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

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


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

This module defines the weight initialization methods.

-}

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

import           Data.Proxy
import Control.Monad

import           Data.Singletons.TypeLits

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

import           GHC.TypeNats (type (*))

import           Numeric.LinearAlgebra.Static

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

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

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

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

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

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


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

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

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


module Vectorspace where

import Data.Complex
import Data.Maybe

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


module Layer where
import Numeric.LinearAlgebra
import Utils

data LayerType =
  SigmoidLayer
  | LinearLayer
  | SoftmaxLayer
  | ReluLayer

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

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

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

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

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

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

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

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

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

-- TODO: backward of softmax layer

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

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


-----------------------------------------------------------------------------
-- |
-- Module     : Numeric.LinearAlgebra.Matrix.Cholesky
-- Copyright  : Copyright (c) 2010, Patrick Perry <patperry@gmail.com>
-- License    : BSD3
-- Maintainer : Patrick Perry <patperry@gmail.com>
-- Stability  : experimental
--
-- Cholesky factorizations of symmetric (Hermitian) positive-definite
-- matrices.
--

module Numeric.LinearAlgebra.Matrix.Cholesky (
    -- * Immutable interface
    cholFactor,
    cholSolveVector,
    cholSolveMatrix,

    -- * Mutable interface
    cholFactorM,
    cholSolveVectorM_,
    cholSolveMatrixM_,

    ) where

import Control.Monad( when )
import Control.Monad.ST( ST, runST, unsafeIOToST )
import Text.Printf( printf )

import qualified Foreign.LAPACK as LAPACK

import Numeric.LinearAlgebra.Types

import Numeric.LinearAlgebra.Matrix.Base( Matrix )
import Numeric.LinearAlgebra.Matrix.STBase( RMatrix, STMatrix )
import qualified Numeric.LinearAlgebra.Matrix.STBase as M

import Numeric.LinearAlgebra.Vector( Vector, STVector )
import qualified Numeric.LinearAlgebra.Vector as V

-- | @cholFactor a@ tries to compute the Cholesky
-- factorization of @a@.  If @a@ is positive-definite then the routine
-- returns @Right@ with the factorization.  If the leading minor of order @i@
-- is not positive-definite then the routine returns @Left i@.
cholFactor :: (LAPACK e)
                 => Herm Matrix e
                 -> Either Int (Chol Matrix e)
cholFactor (Herm uplo a) = runST $ do
    ma <- M.newCopy a
    cholFactorM (Herm uplo ma)
        >>= either (return . Left) (\(Chol uplo' ma') -> do
                a' <- M.unsafeFreeze ma'
                return $ Right (Chol uplo' a')
                )

-- | @cholSolveVector a x@ returns @a \\ x@.
cholSolveVector :: (LAPACK e)
                      => Chol Matrix e
                      -> Vector e
                      -> Vector e
cholSolveVector a x = V.create $ do
    x' <- V.newCopy x
    cholSolveVectorM_ a x'
    return x'

-- | @cholSolveMatrix a b@ returns @a \\ b@.
cholSolveMatrix :: (LAPACK e)
                => Chol Matrix e
                -> Matrix e
                -> Matrix e
cholSolveMatrix a c = M.create $ do
    c' <- M.newCopy c
    cholSolveMatrixM_ a c'
    return c'

-- | @cholFactorM a@ tries to compute the Cholesky
-- factorization of @a@ in place.  If @a@ is positive-definite then the
-- routine returns @Right@ with the factorization, stored in the same
-- memory as @a@.  If the leading minor of order @i@ is not
-- positive-definite then the routine returns @Left i@.
-- In either case, the original storage of @a@ is destroyed.
cholFactorM :: (LAPACK e)
            => Herm (STMatrix s) e
            -> ST s (Either Int (Chol (STMatrix s) e))
cholFactorM (Herm uplo a) = do
    (ma,na) <- M.getDim a
    let n = na

    when (not $ (ma,na) == (n,n)) $ error $
        printf ("cholFactorM"
                ++ " (Herm _ <matrix with dim (%d,%d)>): nonsquare matrix"
               ) ma na

    unsafeIOToST $
        M.unsafeWith a $ \pa lda -> do
            info <- LAPACK.potrf uplo n pa lda
            return $ if info > 0 then Left info
                                 else Right (Chol uplo a)

-- | @cholSolveVectorM_ a x@ sets @x := a \\ x@.
cholSolveVectorM_ :: (LAPACK e, RMatrix m)
                  => Chol m e
                  -> STVector s e
                  -> ST s ()
cholSolveVectorM_ a x =
    M.withFromColM x $ \x' ->
        cholSolveMatrixM_ a x'

-- | @cholSolveMatrixM_ a b@ sets @b := a \\ b@.
cholSolveMatrixM_ :: (LAPACK e, RMatrix m)
                  => Chol m e
                  -> STMatrix s e
                  -> ST s ()
cholSolveMatrixM_ (Chol uplo a) b = do
    (ma,na) <- M.getDim a
    (mb,nb) <- M.getDim b
    let (n,nrhs) = (mb,nb)

    when ((not . and) [ (ma,na) == (n,n)
                      , (mb,nb) == (n,nrhs)
                      ]) $ error $
        printf ("cholSolveMatrixM_"
                ++ " (Chol _ <matrix with dim (%d,%d)>)"
                ++ " <matrix with dim (%d,%d)>"
                ++ ": dimension mismatch")
               ma na mb nb

    unsafeIOToST $
        M.unsafeWith a $ \pa lda ->
        M.unsafeWith b $ \pb ldb ->
            LAPACK.potrs uplo n nrhs pa lda pb ldb


-------------------------------------------------------------------------------
-- |
-- Module    :  Supervised.LinearRegression
-- Copyright :  (c) Sam Stites 2017
-- License   :  MIT
-- Maintainer:  sam@stites.io
-- Stability :  experimental
-- Portability: non-portable
--
-- Fits a linear model with coefficients w = (w_1, ..., w_p) to minimize the
-- residual sum of squares between the observed responses in the dataset, and
-- the responses predicted by the linear approximation. Mathematically it solves
-- a problem of the form:
--
--     \underset{w}{min\,} {|| X w - y||_2}^2
--
-- === Ordinary Least Squares Complexity
--
-- This method computes the least squares solution using a singular value
-- decomposition of X. If X is a matrix of size (n, p) this method has a cost of
-- O(n p^2), assuming that n \geq p.
-------------------------------------------------------------------------------
{-# LANGUAGE TypeFamilies #-}
module Supervised.LinearRegression where

import Prelude
import qualified Data.Monoid as M
import Numeric.LinearAlgebra
import qualified Numeric.LinearAlgebra.Data as LD
import Debug.Trace

type Labels  = Vector Double
type Weights = Vector Double
type Inputs  = Matrix Double
type Model   = (Weights, Inputs -> Labels)

data LinearRegression = LinearRegression
  { nIters       :: Integer  -- ^ The number of iterations the algorithm will train weights for.
  , learningRate :: Double   -- ^ Step length for updating weights
  }

-- "scikit-learn style" naming
mkModel :: LinearRegression
mkModel = LinearRegression 100 0.001

fit :: LinearRegression -> Inputs -> Labels -> Model
fit cfg i l = weightedFit cfg w i l
  where
    nfs :: Int
    nfs = cols i

    w :: Weights
    w =  (vector $ replicate nfs 1) / (konst (fromIntegral nfs) nfs)

weightedFit :: LinearRegression -> Weights -> Inputs -> Labels -> Model
weightedFit cfg _ _xs y = (w, \i -> snocBias i #> w)
  where
    xs :: Matrix Double
    xs = snocBias _xs

    u, s, v :: Matrix Double
    (u, s, v) = svdM $ tr xs <> xs

    xSqInv :: Matrix Double
    xSqInv = (v <> pinv s) <> tr u

    w :: Vector Double
    w = (xSqInv <> tr xs) #> y

svdM :: Matrix Double -> (Matrix Double, Matrix Double, Matrix Double)
svdM = (\(a,b,c) -> (a, diag b, c)) . svd

consBias :: Matrix Double -> Matrix Double
consBias m = LD.fromColumns $ ones (snd $ size m) : LD.toColumns m

snocBias :: Matrix Double -> Matrix Double
snocBias m = m ||| konst 1 (fst (size m), 1)

ones :: Int -> Vector Double
ones = konst 1

predict :: Model -> Inputs -> Labels
predict (_, fn) i = fn i

-- | Returns the coefficient of determination R^2 of the prediction.
scoreR2Regressor :: (truth ~ Labels) => Model -> truth -> Inputs -> Double
scoreR2Regressor (_, fn) truth i = rSquare truth (fn i)

-- | Compute R^2, the coefficient of determination that
-- indicates goodness-of-fit of a regression.
rSquare :: (truth ~ Labels) => truth -> Labels -> Double
rSquare truth pred = 1 - numerator / denominator
  where
    weight :: Vector Double
    weight = 1

    numerator :: Double
    numerator = sumElements $ weight * ((truth - pred) ** 2)

    denominator :: Double
    denominator = sumElements $ weight * ((truth - averageTruth) ** 2)

    averageTruth :: Vector Double
    averageTruth = konst ((sumElements truth) / (fromIntegral n)) n
      where
        n :: Int
        n = size truth

sumColumns :: Matrix Double -> Vector Double
sumColumns = vector . fmap sumElements . toColumns

coefficients :: Model -> Weights
coefficients = fst


module Numeric.MixtureModel.Exponential ( -- * General data types
                                          Sample
                                        , SampleIdx
                                        , Samples
                                        , ComponentIdx
                                        , Assignments
                                        , Weight
                                        -- * Exponential parameters
                                        , Rate, Beta
                                        , Exponential(..)
                                        , ComponentParams
                                        , paramFromSamples
                                        , paramsFromAssignments
                                        -- * Exponential distribution
                                        , Prob
                                        , prob
                                        , tauMean, tauVariance
                                        , modelProb
                                        -- * Gibbs sampling
                                        , estimateWeights
                                        , updateAssignments
                                        -- * Score
                                        , scoreAssignments
                                        , maxLikelihoodScore
                                        -- * Classification
                                        , classify
                                        ) where

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

import           Numeric.Log hiding (Exp, sum)
import qualified Numeric.Log as Log
import           Numeric.SpecFunctions (logBeta)
import           Statistics.Sample (mean)
import           Numeric.Newton
import           Math.Gamma (gamma)

import           Data.Random hiding (gamma)
import           Data.Random.Distribution.Categorical

type Prob = Log Double
type Sample = Double
type SampleIdx = Int
type ComponentIdx = Int
type Weight = Double

type Rate = Double -- ^ The rate parameter
type Beta = Double -- ^ The stretching parameter
data Exponential = Exp Rate
                 | StretchedExp Rate Beta
                 | FixedExp Rate Beta
                 deriving (Show, Read, Eq)

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

-- | `expProb lambda tau` is the probability of `tau` under Exponential
-- distribution defined by rate `lambda`
prob :: Exponential -> Sample -> Prob
prob _ tau | tau < 0 = error "Exponential distribution undefined for tau<0"
prob (FixedExp lambda 1) tau = prob (Exp lambda) tau
prob (FixedExp lambda beta) tau = prob (StretchedExp lambda beta) tau
prob (StretchedExp lambda 1) tau = prob (Exp lambda) tau
prob (StretchedExp lambda beta) tau =
    Log.Exp $ log beta + (beta-1) * log tau + beta * log lambda - (tau * lambda)**beta
prob (Exp lambda) tau = Log.Exp $ log lambda - lambda * tau

-- | Probability of a sample under a mixture
modelProb :: ComponentParams -> Sample -> Prob
modelProb _ tau | tau < 0 = error "Exponential distribution undefined for tau<0"
modelProb model tau = VB.sum $ VB.map (\(w,e)->prob e tau) model

-- | Mean of the given distribution
tauMean :: Exponential -> Double
tauMean (Exp lambda) = 1 / lambda
tauMean (StretchedExp lambda beta) = gamma (1/beta) / beta / lambda
tauMean (FixedExp lambda beta) = tauMean (StretchedExp lambda beta)

-- | Variance of the given distribution
tauVariance :: Exponential -> Double
tauVariance (Exp lambda) = 1/lambda^2
tauVariance (StretchedExp lambda beta) = 2 * gamma (2/beta) / lambda^2 / beta
tauVariance (FixedExp lambda beta) = tauVariance (StretchedExp lambda beta)

-- | Exponential parameter from samples
paramFromSamples :: Exponential -> V.Vector Sample -> Exponential
paramFromSamples (FixedExp lambda beta) _ = FixedExp lambda beta
paramFromSamples _ v | V.null v = error "Can't estimate parameters without samples"
paramFromSamples (Exp _) v = Exp $ 1 / mean v
paramFromSamples (StretchedExp _ betaOld) v =
    let v' = runST $ do a <- V.thaw v
                        sort a
                        V.freeze a
        n = realToFrac $ V.length v'
        tn = V.head v'
        s beta = V.sum (V.map (\t->t**beta) v') - n*tn**beta
        betaOpt beta = let num = V.sum (V.map (\t->t**beta * log t) v') - n*tn**beta*log tn
                       in num / s beta - V.sum (V.map log v') / n - 1 / beta
        betaOpt' beta = let denom = V.sum (V.map (**beta) v') - n*tn**beta
                            num1 = V.sum (V.map (\t->t**beta * log t) v')
                                   - n*tn**beta * log tn
                            num2 = V.sum (V.map (\t->t**beta * (log t)^2) v')
                                   - n*tn**beta * (log tn)^2
                        in 1/beta^2 - (num1/denom)^2 + num2/denom
        beta' = findRoot 1e-5 betaOpt betaOpt' betaOld
        lambda' = (s beta' / n)**(-1/beta')
    in StretchedExp lambda' beta'

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

-- | Exponential parameters for all components given samples and their
-- component assignments
paramsFromAssignments :: Samples -> VB.Vector Exponential -> Assignments -> VB.Vector Exponential
paramsFromAssignments samples params assignments =
  VB.map (paramFromAssignments samples assignments) $ VB.indexed params

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

-- | `countIndices n v` is the list of counts
countIndices :: Int -> V.Vector Int -> VB.Vector Int
countIndices n v = runST $ do
    accum <- VB.thaw $ VB.replicate n 0
    V.forM_ v $ \k -> do n' <- MV.read accum k
                         MV.write accum k $! n'+1
    VB.freeze accum

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

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

-- | "Likelihood" of sample assignments under given model
-- parameters. Note that the exponential distribution is a density
-- function and as such this will give an unnormalized result unless
-- multiplied by dtau^N
scoreAssignments :: Samples -> ComponentParams -> Assignments -> Prob
scoreAssignments samples params assignments =
    V.product
    $ V.map (\(k,x)->let (w,p) = params VB.! k
                     in realToFrac w * prob p x
            )
    $ V.zip assignments samples

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

-- | Score of the maximum likelihood assignment for a set of samples
maxLikelihoodScore :: ComponentParams -> Samples -> Prob
maxLikelihoodScore params samples =
  let assignments = V.map (classify params) samples
  in scoreAssignments samples params assignments


{-# LANGUAGE NoMonomorphismRestriction, QuasiQuotes #-}
import Control.Arrow
import Control.Monad
import NeuralNetwork
import Numeric.LinearAlgebra.HMatrix
import Text.Printf.TH
import VisualizeFunction

andDataSet = map (vector *** vector) [
    ([0,0], [0]),
    ([0,1], [0]),
    ([1,0], [0]),
    ([1,1], [1])
    ]

xorDataSet = map (vector *** vector) [
    ([0,0], [0]),
    ([0,1], [1]),
    ([1,0], [1]),
    ([1,1], [0])
    ]

nn = randomlyWeightedNetwork 0 [2, 9, 1] logisticAF
trainOn dataset = iterate (stochasticGradientDescent dataset 0.25) nn

andNNs = trainOn andDataSet
xorNNs = trainOn xorDataSet

outputs dataset nns = map (\nn -> map (applyNN nn) (map fst dataset)) nns
andOutputs = outputs andDataSet andNNs
xorOutputs = outputs xorDataSet xorNNs

image = visualizeFunctionBMP (0,0) (1,1) (1024,1024) (0,1) . ((!0).) . applyNN

main = forM_ [0..10] $ \i -> do
    saveImage ([s|neuralnetwork_and_%04d.bmp|] (2^i)) (image (andNNs !! (2^i)))
    saveImage ([s|neuralnetwork_xor_%04d.bmp|] (2^i)) (image (xorNNs !! (2^i)))


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Lib.Utility.NeuralNet where

import qualified Numeric.LinearAlgebra as LA
import Numeric.LinearAlgebra.Static
import Numeric.LinearAlgebra.Devel
import Control.Monad.State
import Control.Arrow
import GHC.TypeLits
import Data.Proxy

data Layer (il :: Nat) (is :: Nat) (wc :: Nat) (state :: *) where
    Layer :: state -> (X il is -> (Y il wc, state)) -> (state -> Delta il wc -> (DX il is, state)) -> Layer il is wc state

type ReluState il wc = Maybe (L il wc)
reluLayer :: forall il wc. (KnownNat il, KnownNat wc) =>
   Layer il wc wc (ReluState il wc)
reluLayer = Layer Nothing forwardF backwardF
    where forwardF x = (lt0, Just lt0)
              where (Just lt0) = create $ LA.cmap (\ e -> if e <= 0 then 0 else e) $ extract x
          backwardF Nothing _ = error "State is Nothing"
          backwardF (Just lt0) d = (zipWithM' (\ e1 e2 -> if e1 == 0 then 0 else e2) lt0 d, Just lt0)

type SigmoidState il wc = Maybe (L il wc)
sigmoidLayer :: forall il wc. (KnownNat il, KnownNat wc) =>
   Layer il wc wc (ReluState il wc)
sigmoidLayer = Layer Nothing forwardF backwardF
    where forwardF x = (y, Just y)
              where y = 1 / (1 + exp (-x))
          backwardF Nothing _ = error "State Y is Nothing"
          backwardF (Just s) d = (d * (1 - s) * s, Just s)

type AffineState il is wc = (NeuralParam is wc, Maybe (X il is), Maybe (NeuralParam is wc))
affineLayer :: forall il is wc. (KnownNat il, KnownNat is, KnownNat wc) =>
    NeuralParam is wc -> Layer il is wc (AffineState il is wc)
affineLayer param@(w, b) = Layer (param, Nothing, Nothing) forwardF backwardF
    where forwardF x = (x <> w + v2m b, (param, Just x, Nothing))
          backwardF (_, Nothing, _) _ = error "State X is Nothing"
          backwardF (param@(w, b), Just x, _) d = (dx, (param, Just x, Just (dw, db)))
              where dx = d <> tr w
                    dw = tr x <> d
                    db = unrow $ (1 :: L 1 il) <> d

type SoftmaxWithLossState il os = (T il os, Maybe (Y il os), Maybe (Loss il 1))
softmaxWithLossLayer :: forall il os. (KnownNat il, KnownNat os) =>
    T il os -> Layer il os 1 (SoftmaxWithLossState il os)
softmaxWithLossLayer t = Layer (t, Nothing, Nothing) forwardF backwardF
    where forwardF x = (loss, (t, Just y, Just loss))
              where y = softmax x
                    loss = crossEntropyError t y
          backwardF (_, Nothing, _) d = error "State Y is Nothing"
          backwardF state@(t, Just y, _) d = ((y - t) / fromIntegral il, state)
              where (il, _) = size d

class NeuralNet (a :: Nat -> Nat -> Nat -> *) where
    predict :: forall il is os. (KnownNat il, KnownNat is, KnownNat os)
         => a il is os -> X il is -> Prediction il os
    loss :: forall il is os. (KnownNat il, KnownNat is, KnownNat os)
         => a il is os -> X il is -> Loss il os
    accuracy :: forall il is os. (KnownNat il, KnownNat is, KnownNat os)
         => a il is os -> X il is -> T il os -> Double
    gradients :: forall il is os. (KnownNat il, KnownNat is, KnownNat os)
         => a il is os -> X il is -> T il os -> ()
    training :: forall il is os. (KnownNat il, KnownNat is, KnownNat os)
         => a il is os -> X il is -> T il os -> a il is os

    accuracy a x t = LA.sumElements (extract t1f0) / fromIntegral (size t1f0)
        where y = predict a x
              (y', t') = (maxIndex' y, maxIndex' t)
              t1f0 = uncol $ zipWithM' (\ e1 e2 -> if e1 == e2 then 1 else 0) y' t'

data MnistTwoLayerNet (wc :: Nat) (il :: Nat)  (is :: Nat) (os :: Nat) where
    MnistTwoLayerNet ::
        Layer il is wc (AffineState il is wc)
     -> Layer il wc wc (ReluState il wc)
     -> Layer il wc os (AffineState il wc os)
     -> AdaGrad wc il is os
     -> MnistTwoLayerNet wc il is os
instance NeuralNet (MnistTwoLayerNet 50) where
    predict (MnistTwoLayerNet af1 relu af2 _) x = y3
        where (y1, af1s) = case af1 of (Layer _ ff _) -> ff x
              (y2, relus) = case relu of (Layer _ ff _) -> ff y1
              (y3, af2s) = case af2 of (Layer _ ff _) -> ff y2
    loss = undefined
    gradients = undefined
    training = undefined

class Updater (a :: Nat -> Nat -> Nat -> Nat -> *) where
    update :: forall wc il is os. (KnownNat wc, KnownNat il, KnownNat is, KnownNat os)
         => a wc il is os
         -> (NeuralParam is wc, NeuralParam wc os)
         -> (NeuralParam is wc, NeuralParam wc os)
         -> ((NeuralParam is wc, NeuralParam wc os), a wc il is os)

data SGD (wc :: Nat) (il :: Nat) (is :: Nat) (os :: Nat) where
    SGD :: Double -> SGD wc il is os
instance Updater SGD where
    update (SGD lr) (p1, p2) (dp1, dp2) = ((newParam lr p1 dp1, newParam lr p2 dp2), SGD lr)

newParam :: forall is wc. (KnownNat is, KnownNat wc) => Double
    -> NeuralParam is wc -> NeuralParam is wc -> NeuralParam is wc
newParam lr (w, b) (dw, db) = (w - lr_w * dw, b - lr_b * db)
    where (lr_w, lr_b) = (realToFrac lr, realToFrac lr)

data AdaGrad (wc :: Nat) (il :: Nat) (is :: Nat) (os :: Nat) where
    AdaGrad :: Double -> (NeuralParam is wc, NeuralParam wc os) -> AdaGrad wc il is os
instance Updater AdaGrad where
    update (AdaGrad lr (h1, h2)) (p1, p2) (dp1, dp2) = (result, AdaGrad lr newH)
        where result = (newParam lr p1 dp1', newParam lr p2 dp2')
              (dp1', dp2') = (f' newH1 dp1, f' newH2 dp2)
                  where f h dx = dx / sqrt (h + 1e-7)
                        f' (hw, hb) (dw, db) = (f hw dw, f hb db)
              newH@(newH1, newH2) = (f h1 dp1, f h2 dp2)
                  where f (hw, hb) (dw, db) = (dw ** 2 + hw, db ** 2 + hb)
newAdaGrad lr = AdaGrad lr ((0, 0), (0, 0))

initTestNet :: forall wc il is os. (KnownNat wc, KnownNat il, KnownNat is, KnownNat os) => Double -> IO (MnistTwoLayerNet wc il is os)
initTestNet wis = result
    where initParams = do
              w1 <- randn'
              let b1 = konst 0
              w2 <- randn'
              let b2 = konst 0
              return (w1 * realToFrac wis, b1, w2 * realToFrac wis, b2)
          result = do
              (w1, b1, w2, b2) <- initParams
              let affine1 = affineLayer (w1, b1)
              let relu = reluLayer
              let affine2 = affineLayer (w2, b2)
              return $ MnistTwoLayerNet affine1 relu affine2 $ newAdaGrad 0.1

type LastLayer il hs os = X il hs -> T il os

type X il is = L il is
type Y il wc = L il wc
type T il os = Y il os
type W is wc = L is wc
type B wc = R wc
type NeuralParam is wc = (W is wc, B wc)
type Prediction il wc = Y il wc
type Loss il wc = Y il wc
type Delta il is = X il is
type DX il is = X il is
type ForwardF il is wc = X il is -> Y il wc
type BackwardF il is wc = Y il wc -> X il is

v2m :: forall m n. (KnownNat m, KnownNat n) => R n -> L m n
v2m v = fromList $ (>>= id) $ replicate mVal $ LA.toList $ extract v
    where mVal = fromIntegral $ natVal (Proxy :: Proxy m)

softmax :: forall m n. (KnownNat m, KnownNat n) => L m n -> L m n
softmax a = expA / sumExpA
    where maxs = foldAndExtractRow' LA.maxElement a
          a' = a - maxs
          expA = exp a'
          sumExpA = foldAndExtractRow' LA.sumElements expA

crossEntropyError :: forall m n. (KnownNat m, KnownNat n) => L m n -> L m n -> L m 1
crossEntropyError t y = negate $ foldRow' LA.sumElements $ t * log (y + delta)
    where delta = 1e-7

foldRow' :: forall m n. (KnownNat m, KnownNat n) => (LA.Vector Double -> Double) -> L m n -> L m 1
foldRow' f m = fromList $ map (f . extract) $ toRows m

foldAndExtractRow' :: forall m n. (KnownNat m, KnownNat n) => (LA.Vector Double -> Double) -> L m n -> L m n
foldAndExtractRow' f m = fromList $ toRows m >>= (replicate nVal . f . extract)
    where nVal = fromIntegral $ natVal (Proxy :: Proxy n)

randn' :: forall m n. (KnownNat m, KnownNat n) => IO (L m n)
randn' = result
    where mVal = fromIntegral $ natVal (Proxy :: Proxy m)
          nVal = fromIntegral $ natVal (Proxy :: Proxy n)
          result = do
              m <- LA.randn mVal nVal
              return $ case create m of
                  Nothing -> error "Something wrong"
                  Just x -> x

dmmap' :: forall m n. (KnownNat m, KnownNat n) => (Double -> Double) -> L m n -> L m n
dmmap' f m = mapped
    where m' = extract m
          mapped = case create $ LA.cmap f m' of
              Nothing -> error "Something wrong"
              Just x -> x

zipWithM' :: forall m n. (KnownNat m, KnownNat n) => (Double -> Double -> Double) -> L m n -> L m n -> L m n
zipWithM' f m1 m2 = result
    where m1' = extract m1
          m2' = extract m2
          result = build (\ r c -> f (atIndex m1' r c) (atIndex m2' r c))
              where atIndex m r c = LA.atIndex m (truncate r, truncate c)

maxIndex' :: forall m n. (KnownNat m, KnownNat n) => L m n -> L m 1
maxIndex' = foldRow' (fromIntegral . LA.maxIndex)


-- | Module for operating on vectors and matrices. It includes some functions
-- for using bra-ket notation, based on data types and functions from 'hmarix'
-- package.
module Hoqus.Dirac where

import Numeric.LinearAlgebra.Data
import Numeric.LinearAlgebra

-- This can be used to hide the standard operators.
-- import Prelude hiding ((+))
-- import qualified Prelude

-- | Function 'ket' provides basic functionality for producing vectors from the
-- canonical basis. Vectors and matrices are not represented as lists (as in
-- Mathematica), but using data types from "Numeric.LinearAlgebra.Data" in
-- 'hmatrix' package. This makes possible to use operations on vectors  and
-- matrices defined in 'hmatrix'.
ket :: Int -> Int -> Vector C
ket d i = fromList $ (take i zeros) ++ [1] ++ (take (d-1-i) zeros)
  where zeros = replicate (d-1) 0

-- | The 'proj' function builds d-dimensional operator |i><j|.
proj :: Int -> Int -> Int -> Matrix C
proj d i j = (d><d) $ outerWith (*) (toList $ ket d i) (toList $ ket d j)

-- | The 'outer' defines the form of outer product resulting in paris of elements.
outer :: [a] -> [b] -> [(a,b)]
outer a b = [ (x,y) | x<-a, y<-b ]

-- | General form of the outer product resulting in paris of elements.
outerWith :: (a -> b -> c) -> [a] -> [b] -> [c]
outerWith f a b = [ f x y | x<-a, y<-b ]

-- | Function `overlap` is just an alternative for the scalar product from
-- hmatrix.
overlap :: Vector C -> Vector C -> C
overlap = (<.>)


module Mandroots where

import Data.Complex

data Qaudratic a = Qaudratic a a a deriving (Show, Eq)

solveQuadratic :: Qaudratic (Complex Double) -> (Complex Double, Complex Double)
solveQuadratic (Qaudratic a b c) = let d = sqrt (b*b - 4 * a * c) in ((-b + d)/(2 * a), (-b - d)/(2 * a))

evalQuadratic :: Num a => Qaudratic a -> a -> a
evalQuadratic (Qaudratic a b c) x =  x*x * a + x * b + c

rootsIteration :: Qaudratic (Complex Double) -> Qaudratic (Complex Double)
rootsIteration q@(Qaudratic a b c) = let (rt1, rt2) = solveQuadratic q in (Qaudratic rt1 rt2 c)

type QCD = Qaudratic (Complex Double)

timeToEscape :: (QCD -> QCD) -> QCD -> Int -> Int
timeToEscape f q max = count q 0
  where
    count p n
      | n ==  max = max
      | let a = evalQuadratic p (1 :+ 0) in realPart (a * conjugate a) > 25 = n
      | otherwise = count (f q) (n + 1)


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

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

  (fromList [ 1, 1, 1, 1, 1
            , 0, 0, 0, 0, 1
            , 1, 1, 1, 1, 1
            , 0, 0, 0, 0, 1
            , 1, 1, 1, 1, 1 ], fromList [1]),   -- three

  (fromList [ 0, 1, 1, 1, 1
            , 0, 0, 0, 0, 1
            , 0, 0, 0, 1, 1
            , 0, 0, 0, 0, 1
            , 0, 1, 1, 1, 1 ], fromList [1]),   -- three

  (fromList [ 1, 1, 1, 1, 1
            , 1, 0, 0, 0, 1
            , 1, 0, 0, 0, 1
            , 1, 0, 0, 0, 1
            , 1, 1, 1, 1, 1 ], fromList [0]),   -- not a three

  (fromList [ 1, 1, 1, 1, 1
            , 1, 0, 0, 0, 0
            , 1, 0, 0, 0, 0
            , 1, 0, 0, 0, 0
            , 1, 0, 0, 0, 0 ], fromList [0]),   -- not a three

  (fromList [ 0, 1, 1, 1, 0
            , 0, 1, 0, 1, 0
            , 0, 1, 1, 1, 0
            , 0, 1, 0, 1, 0
            , 0, 1, 1, 1, 0 ], fromList [0]),   -- not a three

  (fromList [ 0, 0, 1, 0, 0
            , 0, 1, 1, 0, 0
            , 1, 0, 1, 0, 0
            , 0, 0, 1, 0, 0
            , 0, 0, 1, 0, 0 ], fromList [0]) ]  -- not a three

main :: IO ()
main = do
  n <- createNetwork 25 [250] 1
  let n' = trainNTimes 10000 0.5 tanh tanh' n samples
  mapM_ (print . output n' tanh . fst) samples
  putStrLn "-------------"
  print . output n' tanh $ testInput

  where testInput = fromList [ 0, 0, 1, 1, 1
                             , 0, 0, 0, 0, 1
                             , 0, 0, 1, 1, 1
                             , 0, 0, 0, 0, 1
                             , 0, 0, 1, 1, 1 ]

{-

OUTPUT:
fromList [0.9996325368507625]
fromList [0.9997784075859734]
fromList [0.9996165887689248]
fromList [-2.8107935971909852e-2]
fromList [7.001808876464477e-3]
fromList [2.54989546107178e-2]
fromList [5.286805464313172e-4]
-------------
fromList [0.9993713524712442]
-}


-- DTMF Analyzer
-- Haskell School Project (Faculty of Mathematics and Physics, Charles University in Prague)
-- Author: Lukas Jendele
import System.Environment
import qualified Data.ByteString.Lazy as B
import qualified Data.Complex as C
import Data.Binary.Get
import Data.Word
import qualified Numeric as Numeric
import qualified Data.List as List
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Function as DataFunction

nthPrimitiveSquareRoot :: Int -> C.Complex Float
nthPrimitiveSquareRoot 0 = 1
nthPrimitiveSquareRoot n = C.conjugate $ C.mkPolar 1 (2*pi/(fromIntegral n))

-- returns filters odd-indexed elements
takeOdd :: [C.Complex a] -> [C.Complex a]
takeOdd lst = map snd $ filter (\(x,_) -> x `mod` 2 == 1) $ zip [0..] lst
-- returns filters even-indexed elements
takeEven :: [C.Complex a] -> [C.Complex a]
takeEven lst = map snd $ filter (\(x,_) -> x `mod` 2 == 0) $ zip [0..] lst

--FFT see: http://mj.ucw.cz/vyuka/ads/44-fft.pdf
fftHelper1 :: Int -> Int -> C.Complex Float -> [C.Complex Float] -> [C.Complex Float] -> [C.Complex Float]
fftHelper1 _ _ _ [] [] = []
fftHelper1 i n omega (e:evenLst) (o:oddLst) | i == n    = []
                                            | otherwise = (e + ((omega^i) * o)):(fftHelper1 (i+1) n omega evenLst oddLst)
--FFT see: http://mj.ucw.cz/vyuka/ads/44-fft.pdf
fftHelper2 :: Int -> Int -> C.Complex Float -> [C.Complex Float] -> [C.Complex Float] -> [C.Complex Float]
fftHelper2 _ _ _ [] [] = []
fftHelper2 i n omega (e:evenLst) (o:oddLst) | i == n    = []
                                            | otherwise = (e - ((omega^i) * o)):(fftHelper2 (i+1) n omega evenLst oddLst)

--FFT see: http://mj.ucw.cz/vyuka/ads/44-fft.pdf
--fft :: (Integral a) => a -> C.Complex Float -> [C.Complex Float] -> [C.Complex Float]
fft :: Int -> C.Complex Float -> [C.Complex Float] -> [C.Complex Float]
fft n omega lst = if n == 1 then (take 1 lst) else
                    let evenLst = (fft (n `div` 2) (omega^2) (takeEven lst))
                        oddLst  = (fft (n `div` 2) (omega^2) (takeOdd lst))
                    in ((fftHelper1 0 (n `div` 2) omega evenLst oddLst) ++ (fftHelper2 0 (n `div` 2) omega evenLst oddLst))

--fftForward :: (Integral a, RealFloat a) => a -> [C.Complex Float] -> [C.Complex Float]
fftForward :: Int -> [C.Complex Float] -> [C.Complex Float]
fftForward n lst = fft n (nthPrimitiveSquareRoot n) lst

-- divides complex number by components
div' :: C.Complex Float -> Int -> C.Complex Float
div' c r = ((C.realPart c) / (fromIntegral r)) C.:+ ((C.imagPart c) / (fromIntegral r))

--fftBackward :: (Integral a, RealFloat a) => a -> [C.Complex a] -> [C.Complex a]
fftBackward :: Int -> [C.Complex Float] -> [C.Complex Float]
fftBackward n lst = map (`div'` n) $ fft n ((C.conjugate (nthPrimitiveSquareRoot n))) lst

main = do
    (filePath:_) <- getArgs
    analyzeFile filePath

--loads the WaveFile from a file given a path
parseFile filePath = do
    fileContents <- B.readFile filePath
    let result = runGet getWaveFile fileContents
    putStrLn (filePath ++ " loaded!")
    return (result)

data WaveFile = WaveFile {
    chunkID ::      Int,
    fileSize ::     Int,
    riffType ::     Int,
    fmtId    ::     Int,
    fmtSize ::      Int,
    fmtCode ::      Int,
    channels ::     Int,
    sampleRate ::   Int,
    fmtAvgBPS ::    Int,
    fmtBlockAlign ::Int,
    bitDepth ::     Int,
    dataID ::       Int,
    dataSize ::     Int,
    fileData ::     [Float]
} -- deriving (Show)

instance Show WaveFile where
    show wav = "FileSize: " ++ (show $ fileSize wav) ++ "\nDataSize: " ++ (show $ dataSize wav) ++ "\nSampleRate: " ++ (show $ sampleRate wav) ++ "\nBitDepth: " ++ (show $ bitDepth wav) ++ "\nChannels: " ++ (show $ channels wav) ++ "\n"

-- parses the header of wav file and reads its contents
getWaveFile :: Get WaveFile
getWaveFile = do
    w_chunkID <- getWord32le
    let chunkID = (fromIntegral w_chunkID)
    w_fileSize <- getWord32le
    let fileSize = fromIntegral w_fileSize
    w_riffType <- getWord32le
    let riffType = fromIntegral w_riffType
    w_fmtID <- getWord32le
    let fmtID = fromIntegral w_fmtID
    w_fmtSize <- getWord32le
    let fmtSize = fromIntegral w_fmtSize
    w_fmtCode <- getWord16le
    let fmtCode = fromIntegral w_fmtCode
    w_channels <- getWord16le
    let channels = fromIntegral w_channels
    w_sampleRate <- getWord32le
    let sampleRate = fromIntegral w_sampleRate
    w_fmtAvgBPS <- getWord32le
    let fmtAvgBPS = fromIntegral w_fmtAvgBPS
    w_fmtBlockAlign <- getWord16le
    let fmtBlockAlign = fromIntegral w_fmtBlockAlign
    w_bitDepth <- getWord16le
    let bitDepth = fromIntegral w_bitDepth
    w_dataID <- getWord32le
    let dataID = fromIntegral w_dataID
    w_dataSize <- getWord32le
    let dataSize = fromIntegral w_dataSize
    fileData <- getWaveContents 0 dataSize
    return $! WaveFile chunkID fileSize riffType fmtID fmtSize fmtCode channels sampleRate fmtAvgBPS fmtBlockAlign bitDepth dataID dataSize fileData

--getWaveContents :: (Integral a) => a -> a-> Get [Float]
getWaveContents i size = do
    if i == size
       then return []
       else do
           fl <- getFloat
           rest <- getWaveContents (i+2) size
           return (fl:rest)

-- turns UInt16 to Int16
wordToInt :: Word16 -> Int
wordToInt word | word < notWord = (fromIntegral word :: Int)
               | otherwise      = (-1) * (fromIntegral notWord :: Int)
               where notWord = (-word)

-- read 16bit Float from the stream
getFloat :: Get Float
getFloat = do
    word <- getWord16le
    let signedWord = wordToInt word
    return ((fromIntegral signedWord :: Float)/(2^15))

-- Duration of the file
wavDuration :: WaveFile -> Float
wavDuration wav = ((fromIntegral $ dataSize wav) * (fromIntegral $ channels wav) * 8) / ((fromIntegral $ sampleRate wav) * (fromIntegral $ bitDepth wav) )

-- turns the list into a list of small intervals
intervalLength = 100

intervals_internal [] = []
intervals_internal lst@(head:tail) = (take (intervalLength) lst) : (intervals_internal tail)

intervals lst = filter (\l -> (length l) == (intervalLength)) (intervals_internal lst)

-- calculates the average of the absolute values in the list
my_average :: [Float] -> Float
my_average lst = (sum $ map (abs) lst) / (fromIntegral $ length lst)

-- get the interval of values from to in msec
getInterval :: Float -> Float -> WaveFile -> [Float]
getInterval from to wav = let rate = ((fromIntegral $ sampleRate wav) :: Float)
                              fromIndex = floor $ (rate * from)
                              toIndex = floor $ (rate * to)
                          in take (toIndex - fromIndex) (drop fromIndex $ fileData wav)

-- helper function for getBeepIntervals
getBeeps _ [] _ = []
getBeeps i (interval:tailOfIntervals) globalAverage = (i, if globalAverage < intervalAverage then True else False, head interval):(getBeeps (i+1) tailOfIntervals globalAverage)
                                                   where intervalAverage = my_average interval
-- handy function for debugging
indexToTime index wav = (fromIntegral index) / (fromIntegral $ sampleRate wav)

filterBeepValues [] = []
filterBeepValues ((index, isQuiet, value):tail)     |   (not isQuiet)     = []
                                                    |   otherwise         = (index, value):(filterBeepValues tail)

-- splits the wav file into into intervals and returns only non-quiet ones
-- it takes little windows and if the abs average value of the window > abs average of the file, the window is regarded as non-quite
getBeepIntervals wav = let wavData = fileData wav
                           globalAverage = my_average wavData
                           listOfIntervals = intervals wavData
                           beeps = getBeeps 0 listOfIntervals globalAverage
                           listOfBeeps = List.groupBy (\(_, isQuiet1, _) (_, isQuiet2, _) -> isQuiet1 == isQuiet2) beeps
                       in filter (\lst -> length lst > 9) $ filter (not . null) $ map (filterBeepValues) listOfBeeps
                           -- firstLast = map (\lst -> (head lst, last lst)) listOfBeeps
                       -- in  filter (\t -> (snd $ fst t)) firstLast

{-
DTMF keypad frequencies (with sound clips)
            5/1209 Hz 	6/1336 Hz 	7/1477 Hz 	8/1633 Hz
1/697 Hz  	 1 / 5   	 2 / 6    	 3 / 7   	 A / 8
2/770 Hz 	 4 / 10  	 5 / 12   	 6 / 14  	 B / 16
3/852 Hz 	 7 / 15 	 8 / 18   	 9 / 21 	 C / 24
4/941 Hz 	 * / 20 	 0 / 24 	 # / 28 	 D / 32

Each frequency button and frequency has its index. If you multiply the indices of two DTMF frequencies, you get index of the button
-}

-- constant - range around the precise DTMF freq
freqLimit = 15

dtmfFrequencies = [697,770,852,941,1209,1336,1477,1633]

dtmfFrequencyRanges_internal :: [Int] -> [Set.Set Int]
dtmfFrequencyRanges_internal [] = []
dtmfFrequencyRanges_internal (freq:rest) = (Set.fromList [(freq - freqLimit)..(freq + freqLimit)]):(dtmfFrequencyRanges_internal rest)

-- set for looking up if frequency is regarded as DTMF frequency or not
dtmfFrequencyRanges :: [Set.Set Int]
dtmfFrequencyRanges = dtmfFrequencyRanges_internal dtmfFrequencies

-- dictionary to look up chars representing buttons, we look up by the index of the button
dtmfTonesDict = Map.fromList $ zip ([x*y | x<- [1..4], y<-[5..8]]) ['1','2','3','A','4','5','6','B','7','8','9','C','*','0','#','D']

-- returns 0 if no otherwise index of frequency from table above
isDTMFFreq :: Int -> Int
isDTMFFreq freq = snd $ foldl f (1,0) dtmfFrequencyRanges
                where f acc@(index, result) set = if result /= 0 then acc
                                                  else
                                                    if freq `Set.member` set then (index+1, index)
                                                    else (index+1, 0)

-- given FFT Output, it returns recognized DTMF frequencies
analyzeFFTOutput :: Int -> Int -> [C.Complex Float] -> Int -> Float -> [(Int, Float)]
analyzeFFTOutput i n (x:xs) smplRate avrgValue   | i == n          = []
                                                 | i > (n `div` 2) = []
                                                 | otherwise       = let freq = (fromIntegral i) / ((fromIntegral n) / (fromIntegral smplRate))  -- calculate the frequency
                                                                         dfmtFreq = isDTMFFreq $ floor freq
                                                                         currentVal = (C.realPart $ abs x)
                                                                     in if dfmtFreq == 0 then restOfRecurrsion
                                                                        else if currentVal > avrgValue then (dfmtFreq, currentVal):(restOfRecurrsion)
                                                                             else restOfRecurrsion
                                                                     where restOfRecurrsion = analyzeFFTOutput (i+1) n xs smplRate avrgValue

maybeCharToChar :: Maybe Char -> Char
maybeCharToChar Nothing = '?'
maybeCharToChar (Just c) = c

-- analyzes interval of function and returns which button it is dialing
analyzeInterval :: [(Int, Float)] -> Int -> Char
analyzeInterval interval smplRate = let len = length interval
                                        floorPow2 = if len <= 1 then 0 else 2 ^ (floor $ logBase 2 (fromIntegral len)) -- calculate the n for FFT
                                        --startIndex = fst $ head interval
                                        --endIndex = fst $ last interval
                                        cmplxValues = map ((C.:+0).snd) interval -- make the values complex and trim the index
                                        fftImage = fftForward floorPow2 cmplxValues
                                        avrgValue = (sum $ map (C.realPart . abs) fftImage) / (fromIntegral floorPow2)
                                        frequencies = reverse $ List.sortBy (compare `DataFunction.on` snd) $ analyzeFFTOutput 0 floorPow2 fftImage smplRate avrgValue
                                        tone = if (length frequencies) < 2 then 0 else (fst $ head frequencies) * (fst $ head (tail frequencies))
                                    in  maybeCharToChar $ Map.lookup tone dtmfTonesDict

analyzeIntervals :: [[(Int, Float)]] -> Int -> String
analyzeIntervals [] _ = []
analyzeIntervals (interval:rest) smplRate = (analyzeInterval interval smplRate):(analyzeIntervals rest smplRate)

analyzeFile filePath = do
    wav <- parseFile filePath
    let beeps = getBeepIntervals wav
    putStrLn (analyzeIntervals beeps (sampleRate wav))


module Fractal.Math.Kernel(
  evaluateFractal
)where

import Data.Complex

type Point = Complex Double
type Limit = Double
type Iteration = Complex Double
type Magnitude = Double
type MaxIter = Int
type Iter = Int

evaluateFractal :: (Point -> Iteration -> Iteration) -> Limit -> MaxIter -> Point -> Iter
evaluateFractal f l m c = res c (0.0 :+ 0.0) 0
  where res c z i             = if i == m then i else rest (f c z) i
        rest val i             = if checkAcceptance l (magnitude val) then i else res c val (i + 1)

checkAcceptance :: Limit -> Double -> Bool
checkAcceptance l val
  | val >= l    = True
  | val == 0.0  = True
  | otherwise   = False


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import Lib

import Numeric.AD
import Numeric.AD.Internal.Forward
import Numeric.AD.Rank1.Tower(Tower)
import Numeric.SpecFunctions
import Data.Csv
import qualified Data.ByteString.Lazy.Char8 as C

--c :: Num a => (a -> a) -> a -> a -> a
difference :: Fractional a => (forall s. AD s (Tower a) -> AD s (Tower a)) -> a -> (forall s. AD s (Tower a) -> AD s (Tower a))
difference v base = \x -> v x - v (auto base)

difference' :: Num a => (t -> a) -> t -> t -> a
difference' v base x = v x - v base

optValLin :: Num a => a -> a
optValLin r = 1000 * r

optValQuad :: Num a => a -> a
--optValQuad r = 1000 * (r + r*r)
optValQuad r = 10000 * (r*r) + 10* r

-- Truncate a taylor exapansion
-- If nothing don't take a taylor expansion just evaluate the 0th derivative a.k.a zero
trunTay :: Fractional a => Maybe Int -> (forall s. AD s (Tower a) -> AD s (Tower a)) -> a -> a -> a
trunTay Nothing  f centre x =  (diffs f x)!!0
trunTay (Just n) f centre x = foldr (+) 0 $ take (n+1) $ (taylor0 f centre (x-centre))

-- create convexity correction function
-- takes a function and two points and calculates the adjustment needed for the difference
convexityAdj :: Fractional a => (forall s. AD s (Tower a) -> AD s (Tower a)) -> a -> a -> a
convexityAdj f centre b = difference' (\x -> trunTay (Just x) (difference f centre) centre b ) 1 2

main :: IO ()
main = do
    --tr (Just 1) (c d 0.02) 0.02 0.04
    print $ trunTay (Just 0) (difference optValLin 0.02) 0.02 0.04
    --print $ trunTay (Just 1) (difference optionVal 0.02) 0.02 0.04
    --print $ trunTay (Just 2) (difference optionVal 0.02) 0.02 0.04
    --print $ trunTay Nothing (difference optionVal 0.02) 0.02 0.04

    print $ "convexity"
    print $ convexityAdj optValLin 0.02 0.04
    print $ convexityAdj optValQuad 0.02 0.04
    -- just get the second derivative of the adjustment

    -- plot a function trunTay for a range from like 0 -> 0.1 for examples with Nothing
    let xFunValues = [ x*0.001 | x <- [1..100] ]
        linValues = map (\x -> trunTay Nothing optValLin 0.02 x) xFunValues
        quadValues = map (\x -> trunTay Nothing optValQuad 0.02 x) xFunValues

--    print $ (linValues :: [(Double,Double)])
    C.writeFile "./plotting/funVals.csv" $ encode (zip3 xFunValues linValues quadValues :: [(Double,Double,Double)])

    -- Then plot first order derivaitve trunTay (Just 1) centred at 0.02 up to 0.04 to get straight line
    let xApproxValues = [ x*0.001 + 0.02 | x <- [0..60] ]
        quadApproxVals1 = map (\x -> trunTay (Just 1) optValQuad  0.02 x) xApproxValues
        quadApproxVals2 = map (\x -> trunTay (Just 2) optValQuad  0.02 x) xApproxValues

    C.writeFile "./plotting/approxVals.csv" $ encode (zip3 xApproxValues quadApproxVals1 quadApproxVals2 :: [(Double,Double,Double)])

    -- Now plot the convexity adustment as a constant values starting at 0.8
    let sPoint = trunTay (Just 1) optValQuad  0.02 0.08
        convexAdj = (convexityAdj optValQuad 0.02 0.08)
    writeFile "./plotting/convexAdj.csv" $ "0.08," ++ show sPoint ++ ",0," ++ show convexAdj

    print "done"