{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP #-}

{- |
Module      :  Physics.Learn.QuantumMat
Copyright   :  (c) Scott N. Walck 2016-2018
License     :  BSD3 (see LICENSE)
Maintainer  :  Scott N. Walck <walck@lvc.edu>
Stability   :  experimental

This module contains state vectors and matrices
for quantum mechanics.
-}

-- Using only Complex Double here, no cyclotomic

module Physics.Learn.QuantumMat
    (
    -- * Complex numbers
      C
    -- * State Vectors
    , xp
    , xm
    , yp
    , ym
    , zp
    , zm
    , np
    , nm
    , dim
    , scaleV
    , inner
    , norm
    , normalize
    , probVector
    , gramSchmidt
    , conjV
    , fromList
    , toList
    -- * Matrices (operators)
    , sx
    , sy
    , sz
    , scaleM
    , (<>)
    , (#>)
    , (<#)
    , conjugateTranspose
    , fromLists
    , toLists
    , size
    , matrixFunction
    -- * Density matrices
    , couter
    , dm
    , trace
    , normalizeDM
    , oneQubitMixed
    -- * Quantum Dynamics
    , timeEvMat
    , timeEv
    , timeEvMatSpec
    -- * Composition
    , Kronecker(..)
    -- * Measurement
    , possibleOutcomes
    , outcomesProjectors
    , outcomesProbabilities
    -- * Vector and Matrix
    , Vector
    , Matrix
    )
    where

import Numeric.LinearAlgebra
    ( C
    , Vector
    , Matrix
    , Herm
    , iC        -- square root of negative one
    , (><)      -- matrix definition
    , ident
    , scale
    , norm_2
    , inv
    , (<\>)
    , sym
    , eigenvaluesSH
    , eigSH
    , cmap
    , takeDiag
    , conj
    , dot
    , tr
    )
--    , (<>)      -- matrix product (not * !!!!)
--    , (#>)      -- matrix-vector product
--    , fromList  -- vector definition

import qualified Numeric.LinearAlgebra as H
-- because H.outer does not conjugate
import Data.Complex
    ( Complex(..)
    , magnitude
    , realPart
    )
#if MIN_VERSION_base(4,11,0)
import Prelude hiding ((<>))
#endif

-- | The state resulting from a measurement of
--   spin angular momentum in the x direction
--   on a spin-1/2 particle
--   when the result of the measurement is hbar/2.
xp :: Vector C
xp = normalize $ fromList [1, 1]

-- | The state resulting from a measurement of
--   spin angular momentum in the x direction
--   on a spin-1/2 particle
--   when the result of the measurement is -hbar/2.
xm :: Vector C
xm = normalize $ fromList [1, -1]

-- | The state resulting from a measurement of
--   spin angular momentum in the y direction
--   on a spin-1/2 particle
--   when the result of the measurement is hbar/2.
yp :: Vector C
yp = normalize $ fromList [1, iC]

-- | The state resulting from a measurement of
--   spin angular momentum in the y direction
--   on a spin-1/2 particle
--   when the result of the measurement is -hbar/2.
ym :: Vector C
ym = normalize $ fromList [1, -iC]

-- | The state resulting from a measurement of
--   spin angular momentum in the z direction
--   on a spin-1/2 particle
--   when the result of the measurement is hbar/2.
zp :: Vector C
zp = normalize $ fromList [1, 0]

-- | The state resulting from a measurement of
--   spin angular momentum in the z direction
--   on a spin-1/2 particle
--   when the result of the measurement is -hbar/2.
zm :: Vector C
zm = normalize $ fromList [0, 1]

-- | The state resulting from a measurement of
--   spin angular momentum in the direction
--   specified by spherical angles theta (polar angle)
--   and phi (azimuthal angle)
--   on a spin-1/2 particle
--   when the result of the measurement is hbar/2.
np :: Double -> Double -> Vector C
np theta phi = fromList [ cos (theta/2) :+ 0
                        , exp(0 :+ phi) * (sin (theta/2) :+ 0) ]

-- | The state resulting from a measurement of
--   spin angular momentum in the direction
--   specified by spherical angles theta (polar angle)
--   and phi (azimuthal angle)
--   on a spin-1/2 particle
--   when the result of the measurement is -hbar/2.
nm :: Double -> Double -> Vector C
nm theta phi = fromList [ sin (theta/2) :+ 0
                        , -exp(0 :+ phi) * (cos (theta/2) :+ 0) ]

-- | Dimension of a vector.
dim :: Vector C -> Int
dim = H.size

-- | Scale a complex vector by a complex number.
scaleV :: C -> Vector C -> Vector C
scaleV = scale

-- | Complex inner product.  First vector gets conjugated.
inner :: Vector C -> Vector C -> C
inner = dot

-- | Length of a complex vector.
norm :: Vector C -> Double
norm = norm_2

-- | Return a normalized version of a given state vector.
normalize :: Vector C -> Vector C
normalize v = scale (1 / norm_2 v :+ 0) v

-- | Return a vector of probabilities for a given state vector.
probVector :: Vector C       -- ^ state vector
           -> Vector Double  -- ^ vector of probabilities
probVector = cmap (\c -> magnitude c**2)

-- | Conjugate the entries of a vector.
conjV :: Vector C -> Vector C
conjV = conj

-- | Construct a vector from a list of complex numbers.
fromList :: [C] -> Vector C
fromList = H.fromList

-- | Produce a list of complex numbers from a vector.
toList :: Vector C -> [C]
toList = H.toList

--------------
-- Matrices --
--------------

-- | The Pauli X matrix.
sx :: Matrix C
sx = (2><2) [ 0, 1
            , 1, 0 ]

-- | The Pauli Y matrix.
sy :: Matrix C
sy = (2><2) [  0, -iC
            , iC,   0 ]

-- | The Pauli Z matrix.
sz :: Matrix C
sz = (2><2) [ 1,  0
            , 0, -1 ]

-- | Scale a complex matrix by a complex number.
scaleM :: C -> Matrix C -> Matrix C
scaleM = scale

-- | Matrix product.
(<>) :: Matrix C -> Matrix C -> Matrix C
(<>) = (H.<>)

-- | Matrix-vector product.
(#>) :: Matrix C -> Vector C -> Vector C
(#>) = (H.#>)

-- | Vector-matrix product
(<#) :: Vector C -> Matrix C -> Vector C
(<#) = (H.<#)

-- | Conjugate transpose of a matrix.
conjugateTranspose :: Matrix C -> Matrix C
conjugateTranspose = tr

-- | Construct a matrix from a list of lists of complex numbers.
fromLists :: [[C]] -> Matrix C
fromLists = H.fromLists

-- | Produce a list of lists of complex numbers from a matrix.
toLists :: Matrix C -> [[C]]
toLists = H.toLists

-- | Size of a matrix.
size :: Matrix C -> (Int,Int)
size = H.size

-- | Apply a function to a matrix.
--   Assumes the matrix is a normal matrix (a matrix
--   with an orthonormal basis of eigenvectors).
matrixFunction :: (C -> C) -> Matrix C -> Matrix C
matrixFunction f m
    = let (valv,vecm) = H.eig m
          fvalv = fromList [f val | val <- toList valv]
      in vecm <> H.diag fvalv <> tr vecm

----------------------
-- Density Matrices --
----------------------

-- | Complex outer product
couter :: Vector C -> Vector C -> Matrix C
couter v w = v `H.outer` conj w

-- | Build a pure-state density matrix from a state vector.
dm :: Vector C -> Matrix C
dm cvec = cvec `couter` cvec

-- | Trace of a matrix.
trace :: Matrix C -> C
trace = sum . toList . takeDiag

-- | Normalize a density matrix so that it has trace one.
normalizeDM :: Matrix C -> Matrix C
normalizeDM rho = scale (1 / trace rho) rho

-- | The one-qubit totally mixed state.
oneQubitMixed :: Matrix C
oneQubitMixed = normalizeDM $ ident 2

----------------------
-- Quantum Dynamics --
----------------------

-- | Given a time step and a Hamiltonian matrix,
--   produce a unitary time evolution matrix.
--   Unless you really need the time evolution matrix,
--   it is better to use 'timeEv', which gives the
--   same numerical results without doing an explicit
--   matrix inversion.  The function assumes hbar = 1.
timeEvMat :: Double -> Matrix C -> Matrix C
timeEvMat dt h
    = let ah = scale (0 :+ dt / 2) h
          (l,m) = size h
          n = if l == m then m else error "timeEv needs square Hamiltonian"
          identity = ident n
      in inv (identity + ah) <> (identity - ah)

-- | Given a time step and a Hamiltonian matrix,
--   advance the state vector using the Schrodinger equation.
--   This method should be faster than using 'timeEvMat'
--   since it solves a linear system rather than calculating
--   an inverse matrix.  The function assumes hbar = 1.
timeEv :: Double -> Matrix C -> Vector C -> Vector C
timeEv dt h v
    = let ah = scale (0 :+ dt / 2) h
          (l,m) = size h
          n = if l == m then m else error "timeEv needs square Hamiltonian"
          identity = ident n
      in (identity + ah) <\> ((identity - ah) #> v)

-- | Given a Hamiltonian matrix, return a function from time
--   to evolution matrix.  Uses spectral decomposition.
--   Assumes hbar = 1.
timeEvMatSpec :: Matrix C -> Double -> Matrix C
timeEvMatSpec m t = matrixFunction (\h -> exp(-iC * h * (t :+ 0))) m

-----------------
-- Composition --
-----------------

class Kronecker a where
    kron :: a -> a -> a

instance H.Product t => Kronecker (Vector t) where
    kron v1 v2 = H.fromList [c1 * c2 | c1 <- H.toList v1, c2 <- H.toList v2]

instance H.Product t => Kronecker (Matrix t) where
    kron = H.kronecker

-----------------
-- Measurement --
-----------------

-- | The possible outcomes of a measurement
--   of an observable.
--   These are the eigenvalues of the matrix
--   of the observable.
possibleOutcomes :: Matrix C -> [Double]
possibleOutcomes observable
    = H.toList $ eigenvaluesSH (sym observable)

-- From a Hermitian matrix, a list of pairs of eigenvalues and eigenvectors.
valsVecs :: Herm C -> [(Double,Vector C)]
valsVecs h = let (valv,m) = eigSH h
                 vals = H.toList valv
                 vecs = map (conjV . fromList) $ toLists (conjugateTranspose m)
             in zip vals vecs

-- From a Hermitian matrix, a list of pairs of eigenvalues and projectors.
valsPs :: Herm C -> [(Double,Matrix C)]
valsPs h = [(val,couter vec vec) | (val,vec) <- valsVecs h]

combineFst :: (Eq a, Num b) => [(a,b)] -> [(a,b)]
combineFst [] = []
combineFst [p] = [p]
combineFst ((x1,m1):(x2,m2):ps)
    = if x1 == x2
      then combineFst ((x1,m1+m2):ps)
      else (x1,m1):combineFst ((x2,m2):ps)

-- | Given an obervable, return a list of pairs
--   of possible outcomes and projectors
--   for each outcome.
outcomesProjectors :: Matrix C -> [(Double,Matrix C)]
outcomesProjectors m = combineFst (valsPs (sym m))

-- | Given an observable and a state vector, return a list of pairs
--   of possible outcomes and probabilites
--   for each outcome.
outcomesProbabilities :: Matrix C -> Vector C -> [(Double,Double)]
outcomesProbabilities m v
    = [(a,realPart (inner v (p #> v))) | (a,p) <- outcomesProjectors m]

------------------
-- Gram-Schmidt --
------------------

-- | Form an orthonormal list of complex vectors
--   from a linearly independent list of complex vectors.
gramSchmidt :: [Vector C] -> [Vector C]
gramSchmidt [] = []
gramSchmidt (v:vs) = let nvs = gramSchmidt vs
                         nv = normalize (v - sum [scale (inner w v) w | w <- nvs])
                     in nv:nvs

-- To Do
--   Generate higher spin operators and state vectors
--   eigenvectors
--   projection operators


{-# LANGUAGE RecordWildCards #-}

module Regression.Logistic
  ( computeCost
  , gradientDescent
  , minimizeBFGS2
  ) where

import Numeric.GSL.Minimization (MinimizeMethodD(VectorBFGS2), minimizeVD)
import Numeric.LinearAlgebra (( #> ), (<.>), add)
import Numeric.LinearAlgebra.Data
  ( Matrix
  , R
  , Vector
  , (?)
  , atIndex
  , cmap
  , cols
  , flatten
  , fromList
  , scalar
  , size
  , toList
  , tr'
  )
import Common (MinimizationOpts(..), sigmoid, sigmoidMatrix)

computeCost :: Matrix R -> Vector R -> Vector R -> R
computeCost x y theta =
  let s = sigmoidMatrix (x #> theta)
      m = size y
   in ((y <.> log (s)) + ((1 - y) <.> log (1 - s))) / fromIntegral (-m)

gradientDescent :: Matrix R -> Vector R -> Vector R -> R -> Int -> R -> Vector R
gradientDescent _ _ _ alpha numIters regFactor
  | regFactor < 0 = error "Regularization factor cannot be < 0"
  | alpha < 0 = error "Learning factor cannot be < 0"
  | numIters < 0 = error "Number of iterations cannot be < 0"
gradientDescent x y theta alpha depth regFactor = go 0 theta
  where
    alpha' = scalar alpha
    --
    m = fromIntegral $ size y
    --
    go k accum
      | k >= depth = accum
      | otherwise =
        let delta = computeDelta accum
         in go (k + 1) (accum - (alpha' * delta))
    --
    penalizedTheta = fromList $ 0 : (tail $ ((* regFactor) <$> toList theta))
    --
    computeDelta th =
      let delta = (tr' x) #> ((sigmoidMatrix (x #> th)) - y)
       in (delta + penalizedTheta) / scalar m

minimizeBFGS2 ::
     Matrix R
  -> Vector R
  -> Vector R
  -> Int
  -> MinimizationOpts
  -> R
  -> Vector R
minimizeBFGS2 _ _ _ numIters _ regFactor
  | regFactor < 0 = error "Regularization factor cannot be < 0"
  | numIters < 0 = error "Number of iterations cannot be < 0"
minimizeBFGS2 x y theta numIters MinimizationOpts {..} regFactor =
  let (params, _) =
        minimizeVD
          VectorBFGS2
          precision
          numIters
          sizeOfFirstTrialStep
          tolerance
          (computeCost x y)
          computeGradients
          theta
   in params
  where
    m = fromIntegral $ size y
    --
    xTr = tr' x
    --
    penalizedTheta = fromList $ 0 : (tail $ ((* regFactor) <$> toList theta))
    --
    computeGradients :: Vector R -> Vector R
    computeGradients th =
      let delta = (tr' x) #> ((sigmoidMatrix (x #> th)) - y)
       in (delta + penalizedTheta) / scalar m


module LearnHaskDA.Chapter5 where
--import Math.Combinatorics.Exact.Binomial
import Numeric.SpecFunctions (choose)
import LearnHaskDA.Chapter2
import LearnHaskDA.Chapter4
import Graphics.EasyPlot
import System.Random
import Data.Number.Erf

{- Using Math.Combinatorics.Exact.Binomial in the exact-combinatorics
package we could have a more general type here and an exact, yet
efficient, computation of choose. But exact-combinatorics is not on
stackage so I changed to the approximation (from Numeric.SpecFunctions
which is on stackage). We only use it for plotting anyway.

-- probabilityMassFunction :: (Integral i, Num n) => i -> i -> n -> n
-}
probabilityMassFunction :: Int -> Int -> Double -> Double
probabilityMassFunction k n p = (n `choose` k)
                              * p^k * (1-p)^(n-k)
plot81 :: IO Bool
plot81 = plot (PNG "coinflips.png") $
              Function2D [Title "Coin Flip Probabilities"]
                         [Range 0 1000]
                         (\k -> probabilityMassFunction (floor k) 1000 0.5)

-- almost equal would be enough
sanitycheck :: Bool
sanitycheck = 1 == sum (map (\k -> probabilityMassFunction k 1000 0.5) [0..1000])

-- sumMid :: (Fractional a, Integral i) => i -> a
sumMid :: Int -> Double
sumMid d = sum $ map (\k -> probabilityMassFunction k 1000 0.5) [500-d .. 500+d]

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

standardDeviation :: (Floating a, Real a) => [a] -> a
standardDeviation values = sqrt (sum [(x-mu)^2 | x <- values]) / sqrt_nm1
  where  mu = average values
         sqrt_nm1 = sqrt $ fromIntegral (length values - 1)

select place = "SELECT "++place++"team, SUM("++place++"score) "++
                 "FROM winloss "++
                 "GROUP BY "++ place ++"team " ++
                 "ORDER BY "++ place ++"team"

test91 = do
  runsAtHome <- queryDatabase "winloss.sql" (select "home")
  runsAway   <- queryDatabase "winloss.sql" (select "away")
  let runsHomeAway = zip (readDoubleColumn runsAtHome 1) (readDoubleColumn runsAway 1)
  plot (PNG "HomeScoreAwayScore.png") $ Data2D [Title "Runs at Home (x axis) and Runs Away (y axis)"] [] runsHomeAway
  let runsHomeAwayDiff = map (\(a,b) -> a-b) runsHomeAway
  plot (PNG "HomeScoreAwayScoreDiff.png") $ Data2D [Title "Difference in Runs at Home and Runs Away"] [] $ zip [1..] runsHomeAwayDiff
  let n = fromIntegral (length runsHomeAwayDiff)
      avg = average runsHomeAwayDiff
      stdDev = standardDeviation runsHomeAwayDiff
      stdErr = stdDev / sqrt n
  return (avg, stdDev, stdErr)

--

from = invnormcdf ((1-95/100)/2 :: Double)
to = - from

test95 = test91 >>= \ (avg, stdDev, stdErr) ->
         return (avg + from*stdErr, avg + to*stdErr)

-- The 95% confidence interval is (-14.9, 26.6) which contains zero so
-- the null hypothesis could not be rejected.


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

module NeuralNetwork where

import Control.Lens
import Numeric.LinearAlgebra

stepFunction :: Double -> Double
stepFunction x | x > 0 = 1.0
               | otherwise = 0.0

sigmoidFunction :: Double -> Double
sigmoidFunction x = 1 / (1 + (exp (-x)))

reluFunction :: Double -> Double
reluFunction = max 0

-- |
-- >>> :set -XOverloadedLists
-- >>> softmax [1010, 1000, 990]
-- [0.999954600070331,4.539786860886666e-5,2.061060046209062e-9]
-- >>> softmax [0.3, 2.9, 4.0]
-- [1.821127329554753e-2,0.24519181293507392,0.7365969137693786]
-- >>> sumElements $ softmax [0.3, 2.9, 4.0]
-- 1.0
softmax :: Vector R -> Vector R
softmax xs = cmap (/denom) ys
  where ys = cmap calc xs
        calc x = exp (x - c)
        c = maxElement xs
        denom = sumElements ys

-- |
-- >>> :set -XOverloadedLists
-- >>> meanSquaredError [0, 0, 1, 0, 0, 0, 0, 0, 0, 0] [0.1, 0.05, 0.6, 0, 0.05, 0.1, 0, 0.1, 0, 0]
-- 9.750000000000003e-2
-- >>> meanSquaredError [0, 0, 1, 0, 0, 0, 0, 0, 0, 0] [0.1, 0.05, 0.1, 0, 0.05, 0.1, 0, 0.6, 0.5, 0]
-- 0.7224999999999999
meanSquaredError :: Vector R -> Vector R -> Double
meanSquaredError t y = (/2) $ sumElements $ cmap (^2) $ t - y

-- |
-- >>> :set -XOverloadedLists
-- >>> crossEntropyError [0, 0, 1, 0, 0, 0, 0, 0, 0, 0] [0.1, 0.05, 0.6, 0, 0.05, 0.1, 0, 0.1, 0, 0]
-- 0.510825457099338
-- >>> crossEntropyError [0, 0, 1, 0, 0, 0, 0, 0, 0, 0] [0.1, 0.05, 0.1, 0, 0.05, 0.1, 0, 0.6, 0.5, 0]
-- 2.302584092994546
crossEntropyError :: Vector R -> Vector R -> Double
crossEntropyError t y = negate $ dot t $ cmap (log . (+delta)) y
  where delta = 1e-7 :: Double

-- |
-- >>> function1 x = 0.01 * x * x + 0.1 * x
-- >>> numericalDiff function1 5
-- 0.1999999999990898
-- >>> numericalDiff function1 10
-- 0.2999999999997449
-- >>> function2 x y = x * x + y * y
-- >>> numericalDiff (flip function2 4) 3
-- 6.00000000000378
-- >>> numericalDiff (function2 3) 4
-- 7.999999999999119
numericalDiff :: (Double -> Double) -> Double -> Double
numericalDiff f x = (f (x + h) - f (x - h)) / (2 * h)
  where h = 1e-4 :: Double

-- |
-- >>> function2 v = dot v v
-- >>> numericalGradient function2 $ vector [3.0, 4.0]
-- [6.00000000000378,7.999999999999119]
-- >>> numericalGradient function2 $ vector [0.0, 2.0]
-- [0.0,4.000000000004]
-- >>> numericalGradient function2 $ vector [3.0, 0.0]
-- [6.000000000012662,0.0]
numericalGradient
  :: (Gradible c)
  => ((c R) -> R) -> c R -> c R
numericalGradient f v = assoc (size v) 0 xs
  where
    h = 1e-4 :: R
    size' = size v
    xs = do
      idx <- indicesOf v
      let v1 = v - assoc size' 0 [(idx, h)]
          v2 = v + assoc size' 0 [(idx, h)]
          x' = f v2 - f v1
      return (idx, x' / (2 * h))

-- |
-- >>> function2 v = dot v v
-- >>> gradientDescent function2 (vector [-3.0, 4.0]) 0.1 100
-- [-6.111107928998789e-10,8.148143905314271e-10]
gradientDescent :: ((Vector R) -> Double) -> Vector R -> Double -> Int -> Vector R
gradientDescent f v lr steps = gradientDescents f lr v !! steps

-- |
-- >>> function2 v = dot v v
-- >>> take 3 $ gradientDescents function2 0.1 (vector [-3.0, 4.0])
-- [[-3.0,4.0],[-2.399999999999622,3.200000000000088],[-1.9199999999982538,2.5599999999976717]]
gradientDescents :: ((Vector R) -> Double) -> Double -> Vector R -> [Vector R]
gradientDescents f lr v = iterate desc v
  where desc v = v - cmap (* lr) (numericalGradient f v)

class (Container c R, Num (c R)) => Gradible c where
  indicesOf :: c R -> [IndexOf c]

instance Gradible Vector where
  indicesOf v = take (size v) [0..]

instance Gradible Matrix where
  indicesOf w = (,) <$> (take (rows w) [0..]) <*> (take (cols w) [0..])


{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
-- |
-- Module    : Statistics.Distribution.Exponential
-- Copyright : (c) 2009 Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- The exponential distribution.  This is the continunous probability
-- distribution of the times between events in a poisson process, in
-- which events occur continuously and independently at a constant
-- average rate.

module Statistics.Distribution.Exponential
    (
      ExponentialDistribution
    -- * Constructors
    , exponential
    , exponentialFromSample
    -- * Accessors
    , edLambda
    ) where

import Data.Aeson (FromJSON, ToJSON)
import Data.Binary (Binary)
import Data.Data (Data, Typeable)
import GHC.Generics (Generic)
import Numeric.MathFunctions.Constants (m_neg_inf)
import qualified Statistics.Distribution         as D
import qualified Statistics.Sample               as S
import qualified System.Random.MWC.Distributions as MWC
import Statistics.Types (Sample)
import Data.Binary (put, get)

newtype ExponentialDistribution = ED {
      edLambda :: Double
    } deriving (Eq, Read, Show, Typeable, Data, Generic)

instance FromJSON ExponentialDistribution
instance ToJSON ExponentialDistribution

instance Binary ExponentialDistribution where
    put = put . edLambda
    get = fmap ED get

instance D.Distribution ExponentialDistribution where
    cumulative      = cumulative
    complCumulative = complCumulative

instance D.ContDistr ExponentialDistribution where
    density (ED l) x
      | x < 0     = 0
      | otherwise = l * exp (-l * x)
    logDensity (ED l) x
      | x < 0     = m_neg_inf
      | otherwise = log l + (-l * x)
    quantile = quantile

instance D.Mean ExponentialDistribution where
    mean (ED l) = 1 / l

instance D.Variance ExponentialDistribution where
    variance (ED l) = 1 / (l * l)

instance D.MaybeMean ExponentialDistribution where
    maybeMean = Just . D.mean

instance D.MaybeVariance ExponentialDistribution where
    maybeStdDev   = Just . D.stdDev
    maybeVariance = Just . D.variance

instance D.Entropy ExponentialDistribution where
  entropy (ED l) = 1 - log l

instance D.MaybeEntropy ExponentialDistribution where
  maybeEntropy = Just . D.entropy

instance D.ContGen ExponentialDistribution where
  genContVar = MWC.exponential . edLambda

cumulative :: ExponentialDistribution -> Double -> Double
cumulative (ED l) x | x <= 0    = 0
                    | otherwise = 1 - exp (-l * x)

complCumulative :: ExponentialDistribution -> Double -> Double
complCumulative (ED l) x | x <= 0    = 1
                         | otherwise = exp (-l * x)

quantile :: ExponentialDistribution -> Double -> Double
quantile (ED l) p
  | p == 1          = 1 / 0
  | p >= 0 && p < 1 = -log (1 - p) / l
  | otherwise       =
    error $ "Statistics.Distribution.Exponential.quantile: p must be in [0,1] range. Got: "++show p

-- | Create an exponential distribution.
exponential :: Double            -- ^ λ (scale) parameter.
            -> ExponentialDistribution
exponential l
  | l <= 0 =
    error $ "Statistics.Distribution.Exponential.exponential: scale parameter must be positive. Got " ++ show l
  | otherwise = ED l

-- | Create exponential distribution from sample. No tests are made to
-- check whether it truly is exponential.
exponentialFromSample :: Sample -> ExponentialDistribution
exponentialFromSample = ED . S.mean


{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE Trustworthy #-}

{- |
Module      :  Data.Complex.Cyclotomic
Copyright   :  (c) Scott N. Walck 2012-2017
License     :  GPL-3 (see LICENSE)
Maintainer  :  Scott N. Walck <walck@lvc.edu>
Stability   :  experimental

The cyclotomic numbers are a subset of the complex numbers with
the following properties:

     1.  The cyclotomic numbers are represented exactly, enabling exact
     computations and equality comparisons.

     2.  The cyclotomic numbers contain the Gaussian rationals
     (complex numbers of the form 'p' + 'q' 'i' with 'p' and 'q' rational).
     As a consequence, the cyclotomic numbers are a dense subset of the
     complex numbers.

     3.  The cyclotomic numbers contain the square roots of all rational numbers.

     4.  The cyclotomic numbers form a field:  they are closed under addition, subtraction,
     multiplication, and division.

     5.  The cyclotomic numbers contain the sine and cosine of all rational
     multiples of pi.

     6.  The cyclotomic numbers can be thought of as the rational field extended
     with 'n'th roots of unity for arbitrarily large integers 'n'.

     Floating point numbers do not do well with equality comparison:

>(sqrt 2 + sqrt 3)^2 == 5 + 2 * sqrt 6
> -> False

     "Data.Complex.Cyclotomic" represents these numbers exactly, allowing equality comparison:

>(sqrtRat 2 + sqrtRat 3)^2 == 5 + 2 * sqrtRat 6
> -> True

     'Cyclotomic's can be exported as inexact complex numbers using the 'toComplex' function:

>e 6
> -> -e(3)^2
>real $ e 6
> -> 1/2
>imag $ e 6
> -> -1/2*e(12)^7 + 1/2*e(12)^11
>imag (e 6) == sqrtRat 3 / 2
> -> True
>toComplex $ e 6
> -> 0.5000000000000003 :+ 0.8660254037844384

     The algorithms for cyclotomic numbers are adapted from code by
     Martin Schoenert and Thomas Breuer in the GAP project <http://www.gap-system.org/>
     (in particular source files gap4r4\/src\/cyclotom.c and
     gap4r4\/lib\/cyclotom.gi).
-}

module Data.Complex.Cyclotomic
    ( Cyclotomic(..)
    , i
    , e
    , sqrtInteger
    , sqrtRat
    , sinDeg
    , cosDeg
    , sinRev
    , cosRev
    , gaussianRat
    , polarRat
    , polarRatDeg
    , polarRatRev
    , conj
    , real
    , imag
    , isReal
    , isRat
    , isGaussianRat
    , toComplex
    , toReal
    , toRat
    , goldenRatio
    , dft
    , dftInv
    , rootsQuadEq
    , heron
    )
    where

import Data.List
    ( nub
    )
import Data.Ratio
    ( (%)
    , numerator
    , denominator
    )
import Data.Complex
    ( Complex(..)
    , realPart
    )
import qualified Data.Map as M
    ( Map
    , empty
    , singleton
    , lookup
    , keys
    , elems
    , size
    , fromList
    , toList
    , mapKeys
    , filter
    , insertWith
    , delete
    , map
    , unionWith
    , findWithDefault
    , fromListWith
    )
import Math.NumberTheory.Primes.Factorisation
    ( factorise
    )

-- | A cyclotomic number.
data Cyclotomic = Cyclotomic { order  :: Integer
                             , coeffs :: M.Map Integer Rational
                             } deriving (Eq)

-- | @abs@ and @signum@ are partial functions.
--   A cyclotomic number is not guaranteed to have a cyclotomic absolute value.
--   When defined, @signum c@ is the complex number with magnitude 1 that has the same argument as c;
--   @signum c = c / abs c@.
instance Num Cyclotomic where
    (+) = sumCyc
    (*) = prodCyc
    (-) c1 c2 = sumCyc c1 (aInvCyc c2)
    negate = aInvCyc
    abs = absVal
    signum = sigNum
    fromInteger 0 = zeroCyc
    fromInteger n = Cyclotomic 1 (M.singleton 0 (fromIntegral n))

instance Fractional Cyclotomic where
    recip = invCyc
    fromRational 0 = zeroCyc
    fromRational r = Cyclotomic 1 (M.singleton 0 r)

-- | The primitive @n@th root of unity.
--   For example, @'e'(4) = 'i'@ is the primitive 4th root of unity,
--   and 'e'(5) = exp(2*pi*i/5) is the primitive 5th root of unity.
--   In general, 'e' 'n' = exp(2*pi*i/'n').
e :: Integer -> Cyclotomic
e n
    | n < 1      = error "e requires a positive integer"
    | n == 1     = Cyclotomic 1 (M.singleton 0 1)
    | otherwise  = cyclotomic n $ convertToBase n (M.singleton 1 1)

instance Show Cyclotomic where
    show (Cyclotomic n mp)
        | mp == M.empty  = "0"
        | otherwise      = leadingTerm rat n ex ++ followingTerms n xs
        where ((ex,rat):xs) = M.toList mp

showBaseExp :: Integer -> Integer -> String
showBaseExp n 1  = "e(" ++ show n ++ ")"
showBaseExp n ex = "e(" ++ show n ++ ")^" ++ show ex

leadingTerm :: Rational -> Integer -> Integer -> String
leadingTerm r _ 0 = showRat r
leadingTerm r n ex
    | r == 1     = t
    | r == (-1)  = '-' : t
    | r > 0      = showRat r ++ "*" ++ t
    | r < 0      = "-" ++ showRat (abs r) ++ "*" ++ t
    | otherwise  = ""
    where t = showBaseExp n ex

followingTerms :: Integer -> [(Integer,Rational)] -> String
followingTerms _ [] = ""
followingTerms n ((ex,rat):xs) = followingTerm rat n ex ++ followingTerms n xs

followingTerm :: Rational -> Integer -> Integer -> String
followingTerm r n ex
    | r == 1     = " + " ++ t
    | r == (-1)  = " - " ++ t
    | r > 0      = " + " ++ showRat r ++ "*" ++ t
    | r < 0      = " - " ++ showRat (abs r) ++ "*" ++ t
    | otherwise  = ""
    where t = showBaseExp n ex

showRat :: Rational -> String
showRat r
    | d == 1     = show n
    | otherwise  = show n ++ "/" ++ show d
    where
      n = numerator r
      d = denominator r

-- GAP function EB from gap4r4/lib/cyclotom.gi
eb :: Integer -> Cyclotomic
eb n
    | n < 1           = error "eb needs a positive integer"
    | n `mod` 2 /= 1  = error "eb needs an odd integer"
    | n == 1          = zeroCyc
    | otherwise       = let en = e n
                        in sum [en^(k*k `mod` n) | k <- [1..(n-1) `div` 2]]

sqrt2 :: Cyclotomic
sqrt2 = e 8 - e 8 ^ (3 :: Int)

-- | The square root of an 'Integer'.
sqrtInteger :: Integer -> Cyclotomic
sqrtInteger n
    | n == 0     = zeroCyc
    | n < 0      = i * sqrtPositiveInteger (-n)
    | otherwise  = sqrtPositiveInteger n

sqrtPositiveInteger :: Integer -> Cyclotomic
sqrtPositiveInteger n
    | n < 1      = error "sqrtPositiveInteger needs a positive integer"
    | otherwise  = let factors = factorise n
                       factor = product [p^(m `div` 2) | (p,m) <- factors]
                       nn     = product [p^(m `mod` 2) | (p,m) <- factors]
                   in case nn `mod` 4 of
                        1 -> fromInteger factor * (2 * eb nn + 1)
                        2 -> fromInteger factor * sqrt2 * sqrtPositiveInteger (nn `div` 2)
                        3 -> fromInteger factor * (-i) * (2 * eb nn + 1)
                        _ -> fromInteger factor * 2 * sqrtPositiveInteger (nn `div` 4)

-- | The square root of a 'Rational' number.
sqrtRat :: Rational -> Cyclotomic
sqrtRat r = prodRatCyc (1 % fromInteger den) (sqrtInteger (numerator r * den))
    where
      den = denominator r

-- | The square root of -1.
i :: Cyclotomic
i = e 4

-- | Make a Gaussian rational; @gaussianRat p q@ is the same as @p + q * i@.
gaussianRat :: Rational -> Rational -> Cyclotomic
gaussianRat p q = fromRational p + fromRational q * i

-- | A complex number in polar form, with rational magnitude @r@ and rational angle @s@
--   of the form @r * exp(2*pi*i*s)@; @polarRat r s@ is the same as @r * e q ^ p@,
--   where @s = p/q@.  This function is the same as 'polarRatRev'.
polarRat :: Rational    -- ^ magnitude
         -> Rational    -- ^ angle, in revolutions
         -> Cyclotomic  -- ^ cyclotomic number
polarRat r s
    = let p = numerator s
          q = denominator s
      in case p >= 0 of
           True  -> fromRational r * e q ^ p
           False -> conj $ fromRational r * e q ^ (-p)

-- | A complex number in polar form, with rational magnitude and rational angle
--   in degrees.
polarRatDeg :: Rational    -- ^ magnitude
            -> Rational    -- ^ angle, in degrees
            -> Cyclotomic  -- ^ cyclotomic number
polarRatDeg r deg
    = let s = deg / 360
          p = numerator s
          q = denominator s
      in case p >= 0 of
           True  -> fromRational r * e q ^ p
           False -> conj $ fromRational r * e q ^ (-p)

-- | A complex number in polar form, with rational magnitude and rational angle
--   in revolutions.
polarRatRev :: Rational    -- ^ magnitude
            -> Rational    -- ^ angle, in revolutions
            -> Cyclotomic  -- ^ cyclotomic number
polarRatRev r s
    = let p = numerator s
          q = denominator s
      in case p >= 0 of
           True  -> fromRational r * e q ^ p
           False -> conj $ fromRational r * e q ^ (-p)

-- | Complex conjugate.
conj :: Cyclotomic -> Cyclotomic
conj (Cyclotomic n mp)
    = mkCyclotomic n (M.mapKeys (\k -> (n-k) `mod` n) mp)

-- | Real part of the cyclotomic number.
real :: Cyclotomic -> Cyclotomic
real z = (z + conj z) / 2

-- | Imaginary part of the cyclotomic number.
imag :: Cyclotomic -> Cyclotomic
imag z = (z - conj z) / (2*i)

absVal :: Cyclotomic -> Cyclotomic
absVal c = let modsq = c * conj c
           in case toRat modsq of
                Just msq -> sqrtRat msq
                Nothing  -> error "abs not available for this number"

sigNum :: Cyclotomic -> Cyclotomic
sigNum 0 = zeroCyc
sigNum c = let modsq = c * conj c
           in if isRat modsq then c / absVal c
              else error "signum not available for this number"

convertToBase :: Integer -> M.Map Integer Rational -> M.Map Integer Rational
convertToBase n mp = foldr (\(p,r) m -> replace n p r m) mp (extraneousPowers n)

removeZeros :: M.Map Integer Rational -> M.Map Integer Rational
removeZeros = M.filter (/= 0)

-- Corresponds to GAP implementation.
-- Expects that convertToBase has already been done.
cyclotomic :: Integer -> M.Map Integer Rational -> Cyclotomic
cyclotomic ord = tryReduce . tryRational . gcdReduce . Cyclotomic ord

mkCyclotomic :: Integer -> M.Map Integer Rational -> Cyclotomic
mkCyclotomic ord = cyclotomic ord . removeZeros . convertToBase ord

-- | Step 1 of cyclotomic is gcd reduction.
gcdReduce :: Cyclotomic -> Cyclotomic
gcdReduce cyc@(Cyclotomic n mp) = case gcdCyc cyc of
                                    1 -> cyc
                                    d -> Cyclotomic (n `div` d) (M.mapKeys (`div` d) mp)

gcdCyc :: Cyclotomic -> Integer
gcdCyc (Cyclotomic n mp) = gcdList (n:M.keys mp)

-- | Step 2 of cyclotomic is reduction to a rational if possible.
tryRational :: Cyclotomic -> Cyclotomic
tryRational c
    | lenCyc c == fromIntegral phi && sqfree
        = case equalCoefficients c of
            Nothing -> c
            Just r  -> fromRational $ (-1)^(nrp `mod` 2)*r
    | otherwise
        = c
    where
      (phi,nrp,sqfree) = phiNrpSqfree (order c)

-- | Compute phi(n), the number of prime factors, and test if n is square-free.
--   We do these all together for efficiency, so we only call factorise once.
phiNrpSqfree :: Integer -> (Integer,Int,Bool)
phiNrpSqfree n = (phi,nrp,sqfree)
    where
      factors = factorise n
      phi = foldr (\p n' -> n' `div` p * (p-1)) n [p | (p,_) <- factors]
      nrp = length factors
      sqfree = all (<=1) [m | (_,m) <- factors]

equalCoefficients :: Cyclotomic -> Maybe Rational
equalCoefficients (Cyclotomic _ mp)
    = case ts of
        []    -> Nothing
        (x:_) -> if equal ts then Just x else Nothing
      where
        ts = M.elems mp

lenCyc :: Cyclotomic -> Int
lenCyc (Cyclotomic _ mp) = M.size $ removeZeros mp

-- | Step 3 of cyclotomic is base reduction
tryReduce :: Cyclotomic -> Cyclotomic
tryReduce c
    = foldr reduceByPrime c squareFreeOddFactors
      where
        squareFreeOddFactors = [p | (p,m) <- factorise (order c), p > 2, m <= 1]

reduceByPrime :: Integer -> Cyclotomic -> Cyclotomic
reduceByPrime p c@(Cyclotomic n _)
    = case mapM (\r -> equalReplacements p r c) [0,p..n-p] of
        Just cfs -> Cyclotomic (n `div` p) $ removeZeros $ M.fromList $ zip [0..(n `div` p)-1] (map negate cfs)
        Nothing  -> c

equalReplacements :: Integer -> Integer -> Cyclotomic -> Maybe Rational
equalReplacements p r (Cyclotomic n mp)
    =  case [M.findWithDefault 0 k mp | k <- replacements n p r] of
         [] -> error "equalReplacements generated empty list"
         (x:xs) | equal (x:xs) -> Just x
         _ -> Nothing

replacements :: Integer -> Integer -> Integer -> [Integer]
replacements n p r = takeWhile (>= 0) [r-s,r-2*s..] ++ takeWhile (< n) [r+s,r+2*s..]
    where s = n `div` p

replace :: Integer -> Integer -> Integer -> M.Map Integer Rational -> M.Map Integer Rational
replace n p r mp = case M.lookup r mp of
                     Nothing  -> mp
                     Just rat -> foldr (\k m -> M.insertWith (+) k (-rat) m) (M.delete r mp) (replacements n p r)

includeMods :: Integer -> Integer -> Integer -> [Integer]
includeMods n q start = [start] ++ takeWhile (>= 0) [start-q,start-2*q..] ++ takeWhile (< n) [start+q,start+2*q..]

removeExps :: Integer -> Integer -> Integer -> [Integer]
removeExps n 2 q = concatMap (includeMods n q) $ map ((n `div` q) *) [q `div` 2..q-1]
removeExps n p q = concatMap (includeMods n q) $ map ((n `div` q) *) [-m..m]
    where m = (q `div` p - 1) `div` 2

pqPairs :: Integer -> [(Integer,Integer)]
pqPairs n = map (\(p,k) -> (p,p^k)) (factorise n)

extraneousPowers :: Integer -> [(Integer,Integer)]
extraneousPowers n
    | n < 1      = error "extraneousPowers needs a postive integer"
    | otherwise  = nub $ concat [[(p,r) | r <- removeExps n p q] | (p,q) <- pqPairs n]

-- | Sum of two cyclotomic numbers.
sumCyc :: Cyclotomic -> Cyclotomic -> Cyclotomic
sumCyc (Cyclotomic o1 map1) (Cyclotomic o2 map2)
    = let ord = lcm o1 o2
          m1 = ord `div` o1
          m2 = ord `div` o2
          map1' = M.mapKeys (m1*) map1
          map2' = M.mapKeys (m2*) map2
      in mkCyclotomic ord $ M.unionWith (+) map1' map2'

-- | Product of two cyclotomic numbers.
prodCyc :: Cyclotomic -> Cyclotomic -> Cyclotomic
prodCyc (Cyclotomic o1 map1) (Cyclotomic o2 map2)
    = let ord = lcm o1 o2
          m1 = ord `div` o1
          m2 = ord `div` o2
      in mkCyclotomic ord $ M.fromListWith (+)
             [((m1*e1+m2*e2) `mod` ord,c1*c2) | (e1,c1) <- M.toList map1, (e2,c2) <- M.toList map2]

-- | Product of a rational number and a cyclotomic number.
prodRatCyc :: Rational -> Cyclotomic -> Cyclotomic
prodRatCyc 0 _                   = zeroCyc
prodRatCyc r (Cyclotomic ord mp) = Cyclotomic ord $ M.map (r*) mp

-- | Additive identity.
zeroCyc :: Cyclotomic
zeroCyc = Cyclotomic 1 M.empty

-- | Additive inverse.
aInvCyc :: Cyclotomic -> Cyclotomic
aInvCyc = prodRatCyc (-1)

multiplyExponents :: Integer -> Cyclotomic -> Cyclotomic
multiplyExponents j (Cyclotomic n mp)
    | gcd j n /= 1  = error "multiplyExponents needs gcd == 1"
    | otherwise     = mkCyclotomic n (M.mapKeys (\k -> j*k `mod` n) mp)

productOfGaloisConjugates :: Cyclotomic -> Cyclotomic
productOfGaloisConjugates c
    = product [multiplyExponents j c | j <- [2..ord], gcd j ord == 1]
      where
        ord = order c

-- | Multiplicative inverse.
invCyc :: Cyclotomic -> Cyclotomic
invCyc z = case toRat (z * prod) of
             Just r  -> prodRatCyc (1 / r) prod
             Nothing -> error "invCyc:  product of Galois conjugates not rational; this is a bug, please inform package maintainer"
    where
      prod = productOfGaloisConjugates z

-- | Is the cyclotomic a real number?
isReal :: Cyclotomic -> Bool
isReal c = c == conj c

-- | Is the cyclotomic a rational?
isRat :: Cyclotomic -> Bool
isRat (Cyclotomic 1 _) = True
isRat _                = False

-- | Is the cyclotomic a Gaussian rational?
isGaussianRat :: Cyclotomic -> Bool
isGaussianRat c = isRat (real c) && isRat (imag c)

-- | Original implementation of toComplex
origToComplex :: RealFloat a => Cyclotomic -> Complex a
origToComplex c = sum [fromRational r * en^p | (p,r) <- M.toList (coeffs c)]
    where en = exp (0 :+ 2*pi/n)
          n = fromIntegral (order c)

-- | Export as an inexact complex number.
-- This function avoids some error that origToComplex introduces.
toComplex :: RealFloat a => Cyclotomic -> Complex a
toComplex x = re :+ im
  where
    Just re = fromRational . toRational <$> (toReal (real x) :: Maybe Double)
    Just im = fromRational . toRational <$> (toReal (imag x) :: Maybe Double)

-- | Export as an inexact real number if possible.
toReal :: RealFloat a => Cyclotomic -> Maybe a
toReal c
    | isReal c   = Just $ realPart (origToComplex c)
    | otherwise  = Nothing

-- | Return an exact rational number if possible.
toRat :: Cyclotomic -> Maybe Rational
toRat (Cyclotomic 1 mp)
    | mp == M.empty  = Just 0
    | otherwise      = M.lookup 0 mp
toRat _ = Nothing

-- | Sine function with argument in degrees.
sinDeg :: Rational -> Cyclotomic
sinDeg d = let n = d / 360
               nm = abs (numerator n)
               dn = denominator n
               a = e dn^nm
           in fromRational(signum d) * (a - conj a) / (2*i)

-- | Cosine function with argument in degrees.
cosDeg :: Rational -> Cyclotomic
cosDeg d = let n = d / 360
               nm = abs (numerator n)
               dn = denominator n
               a = e dn^nm
           in (a + conj a) / 2

-- | Sine function with argument in revolutions.
sinRev :: Rational -> Cyclotomic
sinRev n = let nm = abs (numerator n)
               dn = denominator n
               a = e dn^nm
           in fromRational(signum n) * (a - conj a) / (2*i)

-- | Cosine function with argument in revolutions.
cosRev :: Rational -> Cyclotomic
cosRev n = let nm = abs (numerator n)
               dn = denominator n
               a = e dn^nm
           in (a + conj a) / 2

gcdList :: [Integer] -> Integer
gcdList [] = error "gcdList called on empty list"
gcdList (n:ns) = foldr gcd n ns

equal :: Eq a => [a] -> Bool
equal [] = True
equal [_] = True
equal (x:y:ys) = x == y && equal (y:ys)

-- | The golden ratio, @(1 + √5)/2@.
goldenRatio :: Cyclotomic
goldenRatio = (1 + sqrtRat 5) / 2

-- | Discrete Fourier transform,
--   @X_k = \sum_{n=0}^{N-1} x_n \cdot e^{-i 2 \pi \frac{k}{N} n}@.
dft :: [Cyclotomic] -> [Cyclotomic]
dft cs = [sum $ zipWith (*) [conj (e m^(k*n)) | n <- [0..]] cs | k <- [0..m-1]]
          where m = fromIntegral $ length cs

-- | Inverse discrete Fourier transform,
--   @x_n = \frac{1}{N} \sum_{k=0}^{N-1} X_k \cdot e^{i 2 \pi \frac{k}{N} n}@.
dftInv :: [Cyclotomic] -> [Cyclotomic]
dftInv cs = [minv * sum (zipWith (*) [e m^(k*n) | n <- [0..]] cs) | k <- [0..m-1]]
          where m = fromIntegral $ length cs
                minv = fromRational (1 % m)

-- | Solutions to the quadratic equation
--   a x^2 + b x + c = 0.
--   Returns 'Nothing' if a == 0.
rootsQuadEq :: Rational  -- ^ a
            -> Rational  -- ^ b
            -> Rational  -- ^ c
            -> Maybe (Cyclotomic,Cyclotomic)  -- ^ roots
rootsQuadEq a b c
    | a == 0     = Nothing
    | otherwise  = Just ((-bb + sqrtDisc)/(2*aa),(-bb - sqrtDisc)/(2*aa))
    where
      aa = fromRational a
      bb = fromRational b
      sqrtDisc = sqrtRat (b*b - 4*a*c)

-- | Heron's formula for the area of a triangle with
--   side lengths a, b, c.
heron :: Rational    -- ^ a
      -> Rational    -- ^ b
      -> Rational    -- ^ c
      -> Cyclotomic  -- ^ area of triangle
heron a b c
    = sqrtRat (s * (s-a) * (s-b) * (s-c))
      where
        s = (a + b + c) / 2


{-# LANGUAGE FlexibleContexts #-}

module Taylor where

import Data.Complex

-- also this is a vector space
data Taylor a = Integ a (Taylor a)

instance Show a => Show (Taylor a) where
  show = show . take 10 . toList

toList (Integ x xs) = x:toList xs

zero = Integ 0 zero

instance Num a => Num (Taylor a) where
  (a `Integ` as) + (b `Integ` bs)  =  (a + b)  `Integ`  (as + bs)
  (a `Integ` as) * (b `Integ` bs) = (a*b) `Integ`  (as * (b `Integ` bs) + (a `Integ` as) * bs)
  fromInteger x = integ (fromInteger x) 0
  negate (a `Integ` as) = negate a `Integ` negate as

constant :: Num a => a -> Taylor a
constant x = integ x 0

integ :: a -> Taylor a -> Taylor a
integ = Integ

sinx :: Taylor Integer
sinx = integ 0 cosx

cosx :: Taylor Integer
cosx = integ 1 (-sinx)

expx :: Taylor (Complex Double)
expx = integ 1 expx

-- expkx :: Taylor Double -> Taylor Double
-- expkx k = integ 1 (k*expx)

varx :: Taylor (Complex Double)
varx = integ 0 1

(*^) :: Num t => t -> Taylor t -> Taylor t
a *^ (Integ k ks) = Integ (a * k) (a *^ ks)

evalPart :: Fractional p => [p] -> p -> p -> p
evalPart [] _ _  = 0
evalPart (k:ks) n y = k + evalPart (((y/n) *) <$> ks) (n+1) y

eval :: Fractional p => Taylor p -> Int -> p -> p
eval t n x = evalPart (take n $ toList t) 1 x

-- f . g
-- integ ((f . g) 0) (D (f . g))
-- integ (f (g 0)) (D f . g * g')

compose :: (Eq a, Num a) => Taylor a -> Taylor a -> Taylor a
compose (Integ f0 f') g@(Integ g0 g') = Integ fg0 ((f' `compose` g) * g')
  where
    -- fg0 is the evaluation of f at point g0. (An infinite sum in the general case, but...)
    fg0 = if g0 == 0 then f0 else error "fg0: computation diverges"

-- >>> varx
-- [0,1,0,0,0,0,0,0,0,0]

-- >>> 3 * varx
-- [0.0,3.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0]

-- >>> expx `compose` ((constant (0 :+ 1) * varx))
-- [1.0 :+ 0.0,
--  0.0 :+ 1.0,
--  (-1.0) :+ 0.0,
--  0.0 :+ (-1.0),
--  1.0 :+ 0.0,
--  0.0 :+ 1.0,
--  (-1.0) :+ 0.0,
--  0.0 :+ (-1.0),
--  1.0 :+ 0.0,
--  0.0 :+ 1.0]


module Main where
import Plot
import Graphics.GD
import Data.Complex

imageDim :: Size
imageDim = (600,600)

-- How many iterations before  we declare the point doesn't diverge
maxIter = 96

-- How close successive tests must be before we declare they have converged
minDiff = 0.0001

-- formula to iterate
f z = 3 * z^4 - 1
-- derivative
f' z = 12 * ( z^3)

-- Coordinates in the complex plane to graph
-- First coordinate must be top left.
mbWindow :: Window
mbWindow = ( (-2.0, 2.0), (2.0, -2.0) ) -- Full view

main :: IO ()
main = drawPlot drawNewton imageDim mbWindow "newtons-method.png"

drawNewton :: Coordinate -> Color
drawNewton (x,y) = colorIterations $ newton (x :+ y) 0

-- Count number of iterations for the given point to diverge
-- Non-diverging points return 0
newton :: Complex Double -- Coordinate to test
       -> Int -- Current iteration
       -> Int -- Iterations before diverging
newton z iter
    | iter > maxIter = 0
    | ( abs $ magnitude r - magnitude z) > minDiff = newton r (iter + 1)
    | otherwise = iter
    where r = z - f z / f' z

colorIterations :: Int -> Color
colorIterations x
    | x > maxIter = rgb 255 255 255
    | otherwise = rgb (x^2) x (x*3)


-- | Module for operating on vectors and matrices. It includes some functions
-- for using bra-ket notation.
module DiracLists where

import Data.Complex
import Data.List (transpose)

-- 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 represented as lists and are stored
-- in column-order (as in Mathematica). Operations on vectors and matrices have
-- to be defined using new operators.
ket :: Int -> Int -> [Complex Double]
ket d i = (take i zeros) ++ [1] ++ (take (d-1-i) zeros)
  where zeros = replicate (d-1) 0

-- | The 'norm' function calculates the Euclidean norm of a vector.
norm :: [Complex Double] -> Double
norm a = sqrt $ realPart $ sum [ x^2 | x<-a ]

-- | The 'proj' function builds d-dimensional operator |i><j|.
proj :: Int -> Int -> Int -> [Complex Double]
proj d i j = outerWith (*) (ket d i) (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 ]

-- | Kronecker product is defined in terms of the outer product.
kron ::  Num a => [a] -> [a] -> [a]
kron a b = outerWith (*) a b

-- | Function 'overlap' for calculating the inner product of two vectors. In
-- Dirac notation this is represented as <v|w>.
overlap :: Num a => [a] -> [a] -> a
overlap vec1 vec2 = sum $ zipWith (*) vec1 vec2

-- | The scalar product is defined to be consistent with the other operators. It
-- is identical with the 'overlap' function and it suppose to resemble the
-- braket.
(<>) :: [Complex Double] -> [Complex Double] -> Complex Double
(<>) = overlap

-- | Definition of the vector addition for two complex vectors. The standard '+'
-- operator does not work, and it is not a good idead to hide it.
(+>) :: [Complex Double] -> [Complex Double] -> [Complex Double]
(+>) = zipWith (+)

-- | The multiplication of a vector by a scalar.
(.*) :: Complex Double -> [Complex Double] -> [Complex Double]
(.*) c v = [ c*x | x<-v ]

-- | Matrix-vector multiplication.
(#>) :: [[Complex Double]] -> [Complex Double] -> [Complex Double]
(#>) m v = [ overlap w v | w<-tm ]
  where tm = transpose m


module Hw3
    (Vec(..),
    pure',
    realV,
    imagV ) where

import Data.Complex

-- {-# LANGUAGE FlexibleInstances #-}
-- {-# LANGUAGE UndecidableInstances #-}
-- {-# LANGUAGE RebindableSyntax #-}
-- TODO:
-- Show
-- Num: +, -, *, negate, abs, sigsum, fromInteger
-- Fractional: /, fromRational
-- Floating: pi, exp, log, sin, cos, asin, acos, atan, sinh, cosh, asinh, acosh, atanh
-- Foldable: foldr
-- pure
-- realV
-- imagV

data Vec a = Vec [a]

instance Show a => Show (Vec a) where
    show (Vec a) = "[" ++ show' a ++ "]"

show' :: Show a => [a] -> [Char]
show' [] = ""
show' [x] = show x
show' (x:xs) = show x ++ " " ++ show' xs

instance Num a => Num (Vec a) where
    fromInteger x = Vec $ repeat $ fromInteger x
    (+) (Vec a) (Vec b) = Vec (zipWith (+) a b)
    (-) (Vec a) (Vec b) = Vec (zipWith (-) a b)
    (*) (Vec a) (Vec b) = Vec (zipWith (*) a b)
    negate (Vec a) = Vec (map (\x -> x * (-1)) a)
    abs (Vec a) = Vec (map abs a)
    signum (Vec a) = Vec (map signum a)

instance Fractional a => Fractional (Vec a) where
    (/) (Vec a) (Vec b) = Vec (zipWith (/) a b)
    fromRational x = Vec $ repeat $ fromRational x

instance Floating a => Floating (Vec a) where
    exp (Vec a) = Vec (map exp a)
    log (Vec a) = Vec (map log a)
    sin (Vec a) = Vec (map sin a)
    cos (Vec a) = Vec (map cos a)
    asin (Vec a) = Vec (map asin a)
    acos (Vec a) = Vec (map acos a)
    atan (Vec a) = Vec (map atan a)
    sinh (Vec a) = Vec (map sinh a)
    cosh (Vec a) = Vec (map cosh a)
    asinh (Vec a) = Vec (map asinh a)
    acosh (Vec a) = Vec (map acosh a)
    atanh (Vec a) = Vec (map atanh a)
    pi = Vec $ repeat pi

instance Foldable Vec where
    foldr f x (Vec a) = foldr f x a

pure' x = Vec $ repeat x
realV :: Num a => Vec a -> Vec (Complex a)
imagV :: Num a => Vec a -> Vec (Complex a)
realV (Vec a) = Vec(map (:+ 0) a)
imagV (Vec a) = Vec(map (0:+) a)


module Section_2_3_3 where

import Numeric.LinearAlgebra

and' :: Double -> Double -> Double
and' x1 x2 =
  let x = vector [x1, x2]
      w = vector [0.5, 0.5]
      b = (-0.7)
      tmp = w <.> x + b
   in if tmp <= 0
         then 0
         else 1

nand :: Double -> Double -> Double
nand x1 x2 =
  let x = vector [x1, x2]
      w = vector [(-0.5), (-0.5)]
      b = 0.7
      tmp = w <.> x + b
   in if tmp <= 0
         then 0
         else 1

or' :: Double -> Double -> Double
or' x1 x2 =
  let x = vector [x1, x2]
      w = vector [0.5, 0.5]
      b = (-0.2)
      tmp = w <.> x + b
   in if tmp <= 0
         then 0
         else 1


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

-}

module MachineLearning.LeastSquaresModel
(
  LeastSquaresModel(..)
)

where

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

import qualified MachineLearning.Regularization as R

import MachineLearning.Model

data LeastSquaresModel = LeastSquares

instance Model LeastSquaresModel where
  hypothesis LeastSquares x theta = x #> theta

  cost LeastSquares lambda x y theta =
    let m = x #> theta - y
        nExamples = fromIntegral $ LA.rows x
        regTerm = R.costReg lambda theta
    in (LA.sumElements (m * m) * 0.5 + regTerm) / nExamples

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


module FEECa.Utility.Quadrature where

import Math.Combinatorics.Exact.Factorial
import Numeric.LinearAlgebra.HMatrix
-- import Numeric.LinearAlgebra.Data
import FEECa.Utility.Utility (pairM)

-- | Type synomnym to represent a quadrature as a list pairs
-- | of nodes and corresponding weights, the first element being the node
-- | and the second the weight.
type Quadrature = [(Double, Double)]

-- | Type synomym for the coefficients a_i, b_i, c_i of the recurrence relation of
-- | a given est of orthogonal polynomials.
type Coeff a = (Int -> a)

-- | Compute the Gauss-Jacobi quadrature of degree n and parameters alpha = a
-- | and beta = b.
gaussJacobiQuadrature :: Int -> Int -> Int -> Quadrature
gaussJacobiQuadrature = golubWelsch

-- | Compute the Gauss-Jacobi quadrature of degree n and parameters alpha = a
-- | and beta = b shifted and scaled to the interval [0,1].
gaussJacobiQuadrature' :: Int -> Int -> Int -> Quadrature
gaussJacobiQuadrature' alpha beta n = transform (gaussJacobiQuadrature alpha beta n)
    where transform = map (pairM scale1 id)
          scale1 x = 0.5 + x/2
          -- scale2 y = y

-- | Compute the Gauss-Legendre quadrature of degree n.
gaussLegendreQuadrature :: Int -> Quadrature
gaussLegendreQuadrature = golubWelsch 0 0

-- | Golub-Welsch algorithm as described in "Calculation of Gauss Quadrature
-- | Rules" (Golub, Welsch).
golubWelsch :: Int -> Int -> Int -> Quadrature
golubWelsch alpha beta n = extract $ eigSH' (buildMatrix n a b c)
    where a = a_jac alpha beta
          b = b_jac alpha beta
          c = c_jac alpha beta
          extract (v, m) = zip (toList v)
                               (square (toList (head (toRows m))))
          square  = map (** 2)
          -- TODO: why is scale defined but not used?
          -- normalize l = map ((2 / sum l) *) l
          -- alpha' = fromIntegral alpha
          -- scale = map ((2.0**(1.0+ alpha') / (1 + alpha')) *)

gamma :: Int -> Int -> Double
gamma a b = fromInteger (2^(a + b + 1) * factorial a * factorial b) /
            fromInteger (factorial (a + b + 1))

-- Build the tridiagonal matrix used in the Golub-Welsch algorithm.
buildMatrix :: Int -> Coeff Double -> Coeff Double -> Coeff Double -> Matrix Double
buildMatrix n a b c = (n >< n) $ concat [ p1 i ++ [p2 i] ++ p3 i | i <- [1..n] ]
    where p1 i = replicate (i - 2) 0 ++ f1 i
          p2 i = - (b i / a i)
          p3 i = f2 i ++ replicate (n - i - 1) 0
          f1 i = [ beta (i-1) | i > 1 ]
          f2 i = [ beta  i    | i < n ]
          beta i = sqrt (c (i + 1) / (a i * a (i+1)))

-- | Evaluate an orthogonal Polynomial using the coefficient functions describing
-- | its recurrence relation.
orthogonalPolynomial :: Int -> Int -> Int -> Double -> Double
orthogonalPolynomial n alpha beta x
    | n == 0     = 1.0
    | n > 0      = orthogonalPolynomial' n 1 alpha beta x 1.0 0.0
    | otherwise  = error $ "orthogonalPolynomial: n = " ++ show n ++ " < 0"

-- Iterative implementation of the recursion relations for orthogonal polynomials.
-- See article by Golub and Welsch.
orthogonalPolynomial' ::
  Int -> Int -> Int -> Int ->
  Double -> Double -> Double -> Double
orthogonalPolynomial' n i alpha beta x pi1 pi2
    | n == i     = p_i
    | otherwise  = orthogonalPolynomial' n (i+1) alpha beta x p_i pi1
    where  p_i  = (a i * x + b i) * pi1 - c i * pi2
           a    = a_jac alpha beta
           b    = b_jac alpha beta
           c    = c_jac alpha beta

-- a_i coefficient for Jacobi polynomials as defined in the paper by
-- Golub and Welsch.
a_jac :: Int -> Int -> Coeff Double
a_jac alpha beta i
    | (2*i + alpha + beta) <= 2 = 1
    | otherwise = i2ab * (i2ab - 1) * (i2ab -2) / den_jac alpha beta i
  where i2ab = fromIntegral (2 * i + alpha + beta)

-- b_i coefficient for Jacobi polynomials as defined in the paper by
-- Golub and Welsch.
b_jac :: Int -> Int -> Coeff Double
b_jac alpha beta i
    | (2*i + alpha + beta) <= 2 = 0
    | otherwise = (2*i' + a' + b' - 1) * (a'*a' - b'*b') / den_jac alpha beta i
  where a' = fromIntegral alpha
        b' = fromIntegral beta
        i' = fromIntegral i

-- c_i coefficient for Jacobi polynomials as defined in the paper by
-- Golub and Welsch.
c_jac :: Int -> Int -> Coeff Double
c_jac alpha beta i
    | (2*i + alpha + beta) <= 2 = 0
    | otherwise = 2 * (i' + a' - 1) * (i' + b' - 1) * (2*i' + a' + b') /
                  den_jac alpha beta i
  where a' = fromIntegral alpha
        b' = fromIntegral beta
        i' = fromIntegral i

-- Common denominator for the coefficient functions of the recurrence relation
-- for the Jacobi integrals.
den_jac :: Int -> Int -> Int -> Double
den_jac alpha beta i =
    fromIntegral (2*i * (i + alpha + beta) * (2*i + alpha + beta - 2))

-- | Evaluate Jacobi Polynomial.
jacobiP :: Int -> Int -> Int -> Double -> Double
jacobiP alpha beta n = orthogonalPolynomial n alpha beta

-- | Evaluate Legendre polynomial of degree n at x.
legendreP :: Int -> Double -> Double
legendreP n = orthogonalPolynomial n 0 0


module Ch03.Matrix where

import Prelude hiding (and, or)
import Numeric.LinearAlgebra

import Control.Exception

-- Matrix
as :: Matrix R
as = matrix 4 [1,2,3,4]
--  (1><4)
-- [ 1.0, 2.0, 3.0, 4.0 ]

as' :: Vector R
as' = vector [1,2,3,4]
-- [1.0,2.0,3.0,4.0]

bs :: Matrix R
bs = (3><2) [1..6]
-- (3><2)
--  [ 1.0, 2.0
--  , 3.0, 4.0
--  , 5.0, 6.0 ]

-- Dimensions
ndim  :: Matrix t -> Int
ndim     = rows

shape :: Matrix t -> (Int, Int)
shape xs = (rows xs, cols xs)

t1 = assert (shape as == (1,4)) "OK"
t2 = assert (shape bs == (3,2)) "OK"

-- Inner Product
as1 :: Matrix R
as1 = (2><2) [1..4]
bs1 :: Matrix R
bs1 = (2><2) [5..8]

as1bs1 :: Matrix R
as1bs1 = as1 <> bs1
-- (2><2)
--  [ 19.0, 22.0
--  , 43.0, 50.0 ]

as2 :: Matrix R
as2 = (2><3) [1..6]
bs2 :: Matrix R
bs2 = (3><2) [1..6]

as2bs2 :: Matrix R
as2bs2 = as2 <> bs2
-- (2><2)
--  [ 22.0, 28.0
--  , 49.0, 64.0 ]

c :: Matrix R
c = (2><2) [1..4]

-- Inconsistent Dimensions
as2c :: Matrix R
as2c = as2 <> c
-- *** Exception: inconsistent dimensions in matrix product (2,3) x (2,2)
-- CallStack (from HasCallStack):
--   error, called at src/Internal/LAPACK.hs:56:31 in hmatrix-0.17.0.2-HoBfYSJ1dMG9PoVkmbcnW2:Internal.LAPACK


module Numeric.Fourier
    ( fft
    , ifft

    -- * Testing
    , prop_fourier
    )
  where

import Data.Complex ( cis, realPart, Complex )
import Data.Vector.Unboxed ( Unbox, Vector, (!) )

import qualified Data.Vector.Unboxed as V

{-----------------------------------------------------------------------------
    Fast Fourier transformation
------------------------------------------------------------------------------}
-- | Compute the discrete Fourier transform (DFT) of a vector
-- using a fast Fourier transform (FFT) algorithm.
--
-- The discrete Fourier transform is defined as
--
-- > (fft xs) ! k = sum [ exp(- j*k * 2*pi*i/n) * (xs ! j) | j <- [0..(n-1)] ]
-- >   where n = length xs
--
-- Let $n$ be the length of the input vector.
-- The algorithm recursively divides this vector into parts of equal lengths.
-- Consequently, the running time is $O(n \log n)$ if $n$ is a power of two.
-- However, the running time will degrade to $O(n^2)$
-- if $n$ contains prime factors other than $2$.
fft :: Vector (Complex Double) -> Vector (Complex Double)
fft xs
    | n <= 1    = xs
    | even n    = fftStep xs
    | otherwise = dftSlow xs
  where
    n = V.length xs

-- | Perform an fft step on a vector of even, nonzero length.
--
-- TODO: Perform more operations in-place.
fftStep :: Vector (Complex Double) -> Vector (Complex Double)
fftStep xs =
        V.izipWith (\k ev od -> ev + xi k * od) dftL dftR
    <>  V.izipWith (\k ev od -> ev - xi k * od) dftL dftR
  where
    n  = V.length xs
    n2 = n `div` 2

    -- exp(- 2πi·k (2j+1)/n) = exp(- 2πi k/n) * exp(- 2πi·kj/(2n))
    xi k = cis (- 2*pi* fromIntegral k/fromIntegral n)

    xsEven = V.generate n2 $ \j -> xs ! (2*j)
    xsOdd  = V.generate n2 $ \j -> xs ! (2*j+1)

    dftL = fft xsEven
    dftR = fft xsOdd

-- | Inverse of the discrete fourier transform.
--
-- Implemented using 'fft'.
ifft :: Vector (Complex Double) -> Vector (Complex Double)
ifft xs = V.generate n $ \k ->
    (if k == 0 then ys ! 0 else ys ! (n-k)) / fromIntegral n
  where
    ys = fft xs
    n = V.length xs

{-----------------------------------------------------------------------------
    Testing
------------------------------------------------------------------------------}
-- | Definition of the discrete Fourier transform (DFT).
-- Slow, for testing only.
dftSlow :: Vector (Complex Double) -> Vector (Complex Double)
dftSlow xs = V.generate n $ \k ->
    V.sum $ V.imap (\j x -> cis (- 2*pi * double (k*j) / double n) * x) xs
  where
    double = fromIntegral
    n = V.length xs

-- | Test whether the 'fft' function really is a Fourier transform,
-- i.e. gives the same result as 'dftSlow'.
prop_fourier :: Vector (Complex Double) -> Bool
prop_fourier xs = fft xs `approx` dftSlow xs
  where
    dist xs ys = realPart $ V.sum $ V.zipWith (\x y -> abs (x-y)) xs ys
    approx xs ys = dist xs ys / dist xs (V.map (const 0) ys) < eps
    eps = 1e-15


import Data.Array.CArray
import Data.Complex
import Data.List (intercalate, transpose)
import Math.FFT (dft, idft)

type Vector = CArray Int (Complex Double)

(.*), (.+) :: Vector -> Vector -> Vector
a .* b = liftArray2 (*) a b
a .+ b = liftArray2 (+) a b

normalize :: Double -> Vector -> Vector
normalize dx v =
  let factor = 1 / sqrt dx / norm2 v :+ 0
   in liftArray (factor *) v

data Parameters = Parameters
  { xmax :: Double
  , res :: Int
  , dt :: Double
  , timesteps :: Int
  , dx :: Double
  , x :: Vector
  , dk :: Double
  , ks :: Vector
  , imTime :: Bool
  }

defaultParameters :: Parameters
defaultParameters = makeParameters 10 512 0.01 1000 True

makeParameters :: Double -> Int -> Double -> Int -> Bool -> Parameters
makeParameters xmax res dt timesteps imTime =
  let fi = fromIntegral
      rng = (0, res - 1)
      ks = [0 .. div res 2 - 1] ++ [-div res 2 .. -1]
   in Parameters
        xmax
        res
        dt
        timesteps
        (2 * xmax / fi res)
        (listArray rng $
         map (\n -> xmax * (-1 + 2 * fi n / fi res) :+ 0) [1 .. res])
        (pi / xmax)
        (listArray rng $ map ((:+ 0) . (pi / xmax *) . fi) ks)
        imTime

data Operators = Operators
  { v :: Vector
  , rStep :: Vector
  , kStep :: Vector
  , wfc :: Vector
  }

makeOperators :: Parameters -> Complex Double -> Complex Double -> Operators
makeOperators param v0 wfc0 =
  let rng = (0, res param - 1)
      time
        | imTime param = dt param :+ 0
        | otherwise = 0 :+ dt param
      v = liftArray (\x -> 0.5 * (x - v0) ^ 2) (x param)
      rStep = liftArray (\x -> exp (-0.5 * time * x)) v
      kStep = liftArray (\k -> exp (-0.5 * time * k ^ 2)) (ks param)
      wfc = liftArray (\x -> exp (-(x - wfc0) ^ 2 / 2)) (x param)
   in Operators v rStep kStep (normalize (dx param) wfc)

evolve :: Parameters -> Operators -> [Operators]
evolve param op@(Operators _ rStep kStep _) = iterate splitop op
  where
    splitop op = op {wfc = wfc' op}
    wfc' = norm . (rStep .*) . idft . (kStep .*) . dft . (rStep .*) . wfc
    norm = if imTime param then normalize (dx param) else id

calculateEnergy :: Parameters -> Operators -> Double
calculateEnergy param ops = (* dx param) . sum . map realPart $ elems totalE
  where
    totalE = potentialE .+ kineticE
    potentialE = wfcConj .* v ops .* wfc ops
    kineticOp = liftArray ((/ 2) . (^ 2)) (ks param)
    kineticE = wfcConj .* idft (kineticOp .* dft (wfc ops))
    wfcConj = liftArray conjugate $ wfc ops

-- Use gnuplot to make an animated  GIF using ../gnuplot/plot_output.plt
-- $ gnuplot -e "folder='../haskell'" plot_output.plt
printEvolution :: Parameters -> [Operators] -> IO ()
printEvolution param =
  mapM_ (export . (format <$>)) . zip [0 ..] . take 100 . skip
  where
    skip (x:xs) = x : skip (drop (div (timesteps param) 100 - 1) xs)
    format (Operators v _ _ wfc) =
      let density = liftArray ((^ 2) . abs) wfc
          values = map (map (show . realPart) . elems) [x param, density, v]
       in intercalate "\n" $ map (intercalate "\t") $ transpose values
    export (i, f) = writeFile ("output" ++ pad (show i) ++ ".dat") f
    pad n = replicate (5 - length n) '0' ++ n

main :: IO ()
main = do
  let p = defaultParameters
      o = makeOperators p 0 4
      evol = evolve p o
  print $ calculateEnergy p (evol !! timesteps p)
  printEvolution p evol


import Data.Complex (cis, phase)

meanAngle
  :: RealFloat c
  => [c] -> c
meanAngle = (/ pi) . (* 180) . phase . sum . map (cis . (/ 180) . (* pi))

main :: IO ()
main =
  mapM_
    (\angles ->
        putStrLn $
        "The mean angle of " ++
        show angles ++ " is: " ++ show (meanAngle angles) ++ " degrees")
    [[350, 10], [90, 180, 270, 360], [10, 20, 30]]


module Main where

import qualified Numeric.LinearAlgebra as LA
import qualified MachineLearning.Types as T
import qualified MachineLearning as ML
import qualified MachineLearning.Classification.OneVsAll as OVA
import qualified MachineLearning.PCA as PCA
import qualified MachineLearning.LogisticModel as LM

processFeatures :: T.Matrix -> T.Matrix
processFeatures = ML.addBiasDimension . (ML.mapFeatures 2)

calcAccuracy :: T.Matrix -> T.Vector -> [T.Vector] -> Double
calcAccuracy x y thetas = OVA.calcAccuracy y yPredicted
  where yPredicted = OVA.predict x thetas

printOptPath x optPath =
  let thetas = optPath LA.?? (LA.All, LA.Drop 2)
      thetas_norm = LA.col $ map (LA.norm_2) $ LA.toRows . log $ 1 - LM.sigmoid (thetas LA.<> LA.tr x)
  in LA.disp 3 $ (optPath LA.?? (LA.All, LA.Take 2)) LA.||| thetas_norm

printInfinities x thetaList =
  let thetas = LA.fromColumns thetaList
      y :: T.Matrix
      y = log $ 1-LM.sigmoid (x LA.<> thetas)
      inf = 1/0
      xList = LA.toRows x
      x' = LA.fromRows $ map (\(xi, _) -> xList !! xi) $ LA.find (<=(-inf)) y
      z = x' LA.<> thetas
      h = LM.sigmoid z
      h' = 1 - h
      logh = log h
      logh' = log h'
  in do
    putStrLn "X"
    LA.disp 3 x'
    putStrLn "Z = X * Theta"
    LA.disp 3 z
    putStrLn "h(Theta) = sigmoid(Z)"
    LA.disp 3 h
    putStrLn "1 - h(Theta)"
    LA.disp 3 h'
    putStrLn "log (h(Theta))"
    LA.disp 3 logh
    putStrLn "log (1-h(Theta))"
    LA.disp 3 logh'

main = do
  -- Step 1. Data loading.
  -- Step 1.1 Training Data loading.
  (x, y) <- pure ML.splitToXY <*> LA.loadMatrix "samples/digits_classification/optdigits.tra"
  -- Step 1.1 Testing Data loading.
  (xTest, yTest) <- pure ML.splitToXY <*> LA.loadMatrix "samples/digits_classification/optdigits.tes"

  -- Step 2. Outputs and features preprocessing.
  let numLabels = 10
      x' = processFeatures x
      (reduceDims, reducedDimensions, x1) = PCA.getDimReducer x' 10
      initialTheta = LA.konst 0 (LA.cols x1)
      initialThetaList = replicate numLabels initialTheta
  -- Step 3. Learning.
      (thetaList, optPath) = OVA.learn (OVA.BFGS2 0.1 0.5) 0.0001 30 (OVA.L2 30) numLabels x1 y initialThetaList
  -- Step 4. Prediction and checking accuracy
      accuracyTrain = calcAccuracy x1 y thetaList
      accuracyTest = calcAccuracy (reduceDims $ processFeatures xTest) yTest thetaList

  -- Step 5. Printing results.
  putStrLn "\n=== Numerical Issues Demonstration ==="

  putStrLn $ "\nNumber of iterations to learn: " ++ show (map LA.rows optPath)

  putStrLn $ "\nReduced from " ++ show (LA.cols x') ++ " to " ++ show (LA.cols x1) ++ " dimensions"

  putStrLn "\nOptimization Paths (# iter, J(Theta), norm_2(Theta))"
  mapM_ (printOptPath x1) optPath

  print "\nDisplay numerical issues"
  printInfinities x1 thetaList

  putStrLn $ "\nAccuracy on train set (%): " ++ show (accuracyTrain*100)
  putStrLn $ "Accuracy on test set (%): " ++ show (accuracyTest*100)


{-|
Module      : MachineLearning.Model.Measure
Description : TIR expression data structures
Copyright   : (c) Fabricio Olivetti de Franca, 2022
License     : GPL-3
Maintainer  : fabricio.olivetti@gmail.com
Stability   : experimental
Portability : POSIX

Performance measures for Regression and Classification.
-}
module MachineLearning.Model.Measure
  ( Measure(..)
  , toMeasure
  , measureAll
  , _rmse
  )
  where

import Data.Semigroup (Sum(..))

import qualified Numeric.LinearAlgebra       as LA
import qualified Numeric.Morpheus.Statistics as Stat
import qualified Data.Vector.Storable        as V

type Vector = LA.Vector Double
-- * Performance measures

-- | A performance measure has a string name and a function that
-- takes a vector of the true values, a vector of predict values
-- and returns a `Double`.
data Measure = Measure { _name :: String
                       , _fun  :: Vector -> Vector -> Double -- ^ true values -> predicted values -> measure
                       }

instance Show Measure where
  show (Measure n _) = n

-- | Mean for a vector of doubles
mean :: Vector -> Double
mean xs = V.sum xs / fromIntegral (V.length xs)
{-# INLINE mean #-}

-- | Variance for a vector of doubles
var :: Vector -> Double
var xs = sum' / fromIntegral (V.length xs)
  where
    mu   = mean xs
    sum' = V.foldl (\s x -> s + (x-mu)^(2 :: Int)) 0 xs
{-# INLINE var #-}

-- | generic mean error measure
meanError :: (Vector -> Vector) -- ^ a function to be applied to the error terms (abs, square,...)
          -> Vector             -- ^ target values
          -> Vector             -- ^ fitted values
          -> Double
meanError op ys ysHat = mean $ op $ ysHat - ys
{-# INLINE meanError #-}

-- * Common error measures for regression:
-- MSE, MAE, RMSE, NMSE, r^2

-- | Mean Squared Error
mse :: Vector -> Vector -> Double
--mse           = meanError (^(2 :: Int))
mse ys ysHat = mean $ (ysHat - ys) ^(2 :: Int)
{-# INLINE mse #-}

-- | Mean Absolute Error
mae :: Vector -> Vector -> Double
mae ys ysHat = mean $ abs (ysHat - ys) -- meanError abs
{-# INLINE mae #-}

-- | Normalized Mean Squared Error
nmse :: Vector -> Vector -> Double
nmse ys ysHat = mse ysHat ys / var ys
{-# INLINE nmse #-}

-- | Root of the Mean Squared Error
rmse :: Vector -> Vector -> Double
rmse ys ysHat = sqrt $ mse ysHat ys
{-# INLINE rmse #-}

-- | negate R^2 - minimization metric
rSq :: Vector -> Vector -> Double
rSq ys ysHat = negate (1 - r/t)
  where
    ym      = Stat.mean ys
    t       = sumOfSq $ V.map (\yi -> yi - ym) ys
    r       = sumOfSq $ ys - ysHat
    sumOfSq = V.foldl (\s di -> s + di^(2 :: Int)) 0
{-# INLINE rSq #-}

-- * Regression measures
_rmse, _mae, _nmse, _r2 :: Measure
_rmse = Measure "RMSE" rmse
_mae  = Measure "MAE" mae
_nmse = Measure "NMSE" nmse
_r2   = Measure "R^2" rSq

-- * Classification measures
_accuracy,_recall,_precision,_f1,_logloss :: Measure
_accuracy  = Measure "Accuracy" accuracy
_recall    = Measure "Recall" recall
_precision = Measure "Precision" precision
_f1        = Measure "F1" f1
_logloss   = Measure "Log-Loss" logloss

-- | Accuracy: ratio of correct classification
accuracy :: Vector -> Vector -> Double
accuracy ys ysHat = -equals/tot
  where
    ys'    = map round $ LA.toList ys
    ysHat' = map round $ LA.toList ysHat
    (Sum equals, Sum tot) = foldMap cmp $ zip ysHat' ys'
    cmp :: (Integer, Integer) -> (Sum Double, Sum Double)
    cmp (yH, y)
      | yH == y   = (Sum 1, Sum 1)
      | otherwise = (Sum 0, Sum 1)

-- | Precision: ratio of correct positive classification
precision :: Vector -> Vector -> Double
precision ys ysHat = equals/tot
  where
    ys'    = map round $ LA.toList ys
    ysHat' = map round $ LA.toList ysHat
    (Sum equals, Sum tot) = foldMap cmp $ zip ysHat' ys'
    cmp :: (Integer, Integer) -> (Sum Double, Sum Double)
    cmp (1, 1)  = (Sum 1, Sum 1)
    cmp (1, 0)  = (Sum 0, Sum 1)
    cmp (_, _) = (Sum 0, Sum 0)

-- | Recall: ratio of retrieval of positive labels
recall :: Vector -> Vector -> Double
recall ys ysHat = equals/tot
  where
    ys'    = map round $ LA.toList ys
    ysHat' = map round $ LA.toList ysHat
    (Sum equals, Sum tot) = foldMap cmp $ zip ysHat' ys'

    cmp :: (Integer, Integer) -> (Sum Double, Sum Double)
    cmp (1, 1)  = (Sum 1, Sum 1)
    cmp (0, 1)  = (Sum 0, Sum 1)
    cmp (_, _) = (Sum 0, Sum 0)

-- | Harmonic average between Precision and Recall
f1 :: Vector -> Vector -> Double
f1 ys ysHat = 2*prec*rec/(prec+rec)
  where
    prec = precision ysHat ys
    rec  = recall ysHat ys

-- | LogLoss of a classifier that returns a probability.
logloss :: Vector -> Vector -> Double
logloss ys ysHat = mean $ -(ys * log ysHat' + (1 - ys)*log(1 - ysHat'))
  where
    ysHat' = LA.cmap (min (1.0 - 1e-15) . max 1e-15) ysHat

-- | List of all measures
measureAll :: [Measure]
measureAll = [_rmse, _mae, _nmse, _r2
             , _accuracy, _recall, _precision, _f1, _logloss
             ]

-- | Read a string into a measure
toMeasure :: String -> Measure
toMeasure input
  | null cmp  = error ("Invalid measure: " ++ input)
  | otherwise = (snd.head) cmp
  where
    cmp                       = filter fst $ map isThis measureAll
    isThis m@(Measure name _) = (name == input, m)


{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}
module NeuralNetwork where
import Control.Arrow hiding (app)
import Control.Monad
import Control.Monad.Trans.State.Lazy
import Data.List
import Numeric.LinearAlgebra.HMatrix
import System.Random
import qualified Data.Vector.Storable as V

-- ActivationFunction wraps a function with its derivative, along with a name (for printing)
data ActivationFunction a = AF (a -> a) (a -> a) String
instance Show (ActivationFunction a) where show (AF _ _ n) = "ActivationFunction " ++ n

tanhAF = AF tanh (\x -> 1 - (tanh x)^2) "tanh"
logisticAF = AF f (\x -> f x * (1 - f x)) "logistic" where f x = (1 / (1 + exp (-x)))

data NeuralNetwork a = NN {
    getWeightMatrices :: [Matrix a],
    getActivationFunction :: ActivationFunction a
    } deriving Show

applyNN :: Numeric a => NeuralNetwork a -> Vector a -> Vector a
applyNN (NN mats (AF theta _ _)) x = foldl' ((cmap theta .) . flip (app . tr) . V.cons 1) x mats

-- (forwardPropagate nn x) returns the values at all the intermediate layers, before and after the activation function is applied
forwardPropagate :: Numeric a => NeuralNetwork a -> Vector a -> ([Vector a], [Vector a])
forwardPropagate (NN mats (AF theta _ _)) x = first tail . unzip $ scanl aux (undefined, V.cons 1 x) mats where
    aux (_,z) w = let v = app (tr w) z in (v, V.cons 1 (cmap theta v))

-- (backPropagate nn x y) returns all the errors (in the same shape as the weights) of applying nn to x, with target value y
backPropagate :: (Num (Vector a), Numeric a) => NeuralNetwork a -> Vector a -> Vector a -> [Matrix a]
backPropagate nn@(NN mats (AF theta theta' _)) x y = gradient where
    deltaStep (ds, d) (v, w) = let d' = (cmap theta' v) * (V.tail $ app w d) in (d':ds, d')
    (v:vs, zs) = first reverse $ forwardPropagate nn x
    ws = reverse mats
    dLast = 2 * (cmap theta v - y)
    ds = fst $ foldl' deltaStep ([dLast], dLast) (zip vs ws)
    gradient = zipWith outer zs ds

batchUpdate alpha nn@(NN oldWeights _) dataset = let
    (gradient, size) = foldr (\(x, y) (gr, n) -> (zipWith (+) gr (backPropagate nn x y), n+1)) (cycle [scalar 0], 0) dataset
    step = map (*scalar (alpha / size)) gradient
    newWeights = zipWith (-) oldWeights step
    in nn {getWeightMatrices = newWeights}

stochasticGradientDescent dataset alpha nn = foldl' (\nn' pt -> batchUpdate alpha nn' [pt]) nn dataset

initializeMatrix mkEntry (m, n) = runState (fmap (matrix m) $ replicateM (m*n) (state mkEntry))

randomlyWeightedNetwork seed dims af = NN (evalState (mapM mkMat (zip dims (tail dims))) (mkStdGen seed)) af where
    mkMat (m, n) = state $ initializeMatrix (randomR (-1, 1)) (n,m+1)


{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

{-# LANGUAGE ViewPatterns #-}

import           Numeric.Sundials.ARKode.ODE
import           Numeric.LinearAlgebra
import           Graphics.Plot

vanderpol mu = do
    let xdot nu _t [x,v] = [v, -x + nu * v * (1-x*x)]
        xdot _ _ _ = error "vanderpol RHS not defined"
        ts = linspace 1000 (0,50)
        sol = toColumns $ odeSolve (xdot mu) [1,0] ts
    mplot (ts : sol)
    mplot sol

harmonic w d = do
    let xdot u dd _t [x,v] = [v, a*x + b*v] where a = -u*u; b = -2*dd*u
        xdot _ _ _ _ = error "harmonic RHS not defined"
        ts = linspace 100 (0,20)
        sol = odeSolve (xdot w d) [1,0] ts
    mplot (ts : toColumns sol)

kepler v a = mplot (take 2 $ toColumns sol) where
    xdot _t [x,y,vx,vy] = [vx,vy,x*k,y*k]
        where g=1
              k=(-g)*(x*x+y*y)**(-1.5)
    xdot _ _ = error "kepler RHS not defined"
    ts = linspace 100 (0,30)
    sol = odeSolve xdot [4, 0, v * cos (a*degree), v * sin (a*degree)] ts
    degree = pi/180

main = do
    vanderpol 2
    harmonic 1 0
    harmonic 1 0.1
    kepler 0.3 60
    kepler 0.4 70
    vanderpol' 2

-- example of odeSolveV with jacobian
vanderpol' mu = do
    let xdot nu _t (toList->[x,v]) = fromList [v, -x + nu * v * (1-x*x)]
        xdot _ _ _ = error "vanderpol' RHS not defined"
        jac _ (toList->[x,v]) = (2><2) [ 0          ,          1
                                       , -1-2*x*v*mu, mu*(1-x**2) ]
        jac _ _ = error "vanderpol' Jacobian not defined"
        ts = linspace 1000 (0,50)
        hi = pure $ (ts!1 - ts!0) / 100.0
        sol = toColumns $ odeSolveV (SDIRK_5_3_4 jac) hi 1E-8 1E-8 (xdot mu) (fromList [1,0]) ts
    mplot sol


module AoC2021.Day06 where

import           Data.Semigroup        (stimes)
import           Numeric.LinearAlgebra ((#>), (><))
import qualified Numeric.LinearAlgebra as M
import qualified Parsers               as P

-- Linear (in growth days) time algorithm ----------------------------------------------------------
-- See Leslie Matrices (https://en.wikipedia.org/wiki/Leslie_matrix)

leslieMatrix :: M.Matrix Double -- Use double, to use optimized matrix multiplication of hmatrix
leslieMatrix = (9><9) [ 0, 1, 0, 0, 0, 0, 0, 0, 0 -- Count 1 -> 0
                      , 0, 0, 1, 0, 0, 0, 0, 0, 0 -- Count 2 -> 1
                      , 0, 0, 0, 1, 0, 0, 0, 0, 0 -- Count 3 -> 2
                      , 0, 0, 0, 0, 1, 0, 0, 0, 0 -- Count 4 -> 3
                      , 0, 0, 0, 0, 0, 1, 0, 0, 0 -- Count 5 -> 4
                      , 0, 0, 0, 0, 0, 0, 1, 0, 0 -- Count 6 -> 5,
                      , 1, 0, 0, 0, 0, 0, 0, 1, 0 -- Count 7 -> 6, 0 -> 6 (re-spawn, instead of dying)
                      , 0, 0, 0, 0, 0, 0, 0, 0, 1 -- Count 8 -> 7
                      , 1, 0, 0, 0, 0, 0, 0, 0, 0 -- Count 9 -> 8, 0 -> 8 (spawn child with 8)
                      ]

projectNDays :: Int -> M.Matrix Double -> M.Matrix Double
projectNDays = stimes

day0 :: [Int] -> M.Vector Double
day0 = M.vector . zipWith count [0..8] . repeat
  where count x = fromIntegral . length . filter (==x)

solve' :: Int -> [Int] -> Int
solve' days fishes = round $ M.sumElements dayN
  where dayN = projectNDays days leslieMatrix #> day0 fishes
----------------------------------------------------------------------------------------------------

-- Exponential (in growth days) time algorithm -----------------------------------------------------
-- | Calculate the number of fishes spawned by one fish within d days
f :: Int -> Int
f d = (1+) . sum . map (f . childOffset) $ [0 .. nSpawn - 1]
  where
    childOffset i = d-9-(7*i)
    nSpawn = ceiling $ fromIntegral d / 7

-- | Total number of fishes within d days, given a list of fishes with their initial counter
solve :: Int -> [Int] -> Int
solve d = sum . map (f . (d-))
----------------------------------------------------------------------------------------------------

solve01 :: String -> String
solve01 input = case P.runParser P.parseIntegerList () "" input of
  Left e   -> show e
  Right is -> show (solve' 80 is)

-- | Way to inefficient, maybe solve the sum of f?
solve02 :: String -> String
solve02 input = case P.runParser P.parseIntegerList () "" input of
  Left e   -> show e
  Right is -> show (solve' 256 is)


-- nonlinear least-squares fitting

import Numeric.GSL.Fitting
import Numeric.LinearAlgebra

xs = map return [0 .. 39]
sigma = 0.1
ys = map return $ toList $ fromList (map (head . expModel [5,0.1,1]) xs)
            + scalar sigma * (randomVector 0 Gaussian 40)

dat :: [([Double],([Double],Double))]

dat = zip xs (zip ys (repeat sigma))

expModel [a,lambda,b] [t] = [a * exp (-lambda * t) + b]

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

(sol,path) = fitModelScaled 1E-4 1E-4 20 (expModel, expModelDer) dat [1,0,0]

main = do
    print dat
    print path
    print sol


module Quadratic where

import Data.Complex

data Quadratic = Quadratic { a :: Double, b :: Double, c :: Double } deriving Show

type RootT = Complex Double

data Roots = Roots RootT RootT deriving Show

-- | Calculates roots of a polynomial and return set of roots
roots :: Quadratic -> Roots

-- Trivial, all constants are zero, error roots are not defined
roots (Quadratic 0 0 _) = error "Not a quadratic polynomial"

-- Is a polynomial of degree 1, x = -c / b
roots (Quadratic 0.0 b c) = let root = ( (-c) / b :+ 0)
                            in Roots root root

-- b^2 - 4ac = 0
roots (Quadratic a b c) =
  let discriminant = b * b - 4 * a * c
  in rootsInternal (Quadratic a b c) discriminant

rootsInternal :: Quadratic -> Double -> Roots
-- Discriminant is zero, roots are real
rootsInternal q d | d == 0 = let r = (-(b q) / 2.0 / (a q))
                                 root = r :+ 0
                             in Roots root root

-- Discriminant is negative, roots are complex
rootsInternal q d | d < 0 = Roots (realpart :+ complexpart) (realpart :+ (-complexpart))
  where plusd = -d
        twoa = 2.0 * (a q)
        complexpart = (sqrt plusd) / twoa
        realpart = - (b q) / twoa

-- discriminant is positive, all roots are real
rootsInternal q d = Roots (root1 :+ 0) (root2 :+ 0)
  where plusd = -d
        twoa = 2.0 * (a q)
        dpart = (sqrt plusd) / twoa
        prefix = - (b q) / twoa
        root1 = prefix + dpart
        root2 = prefix - dpart


module Polymorphic where

import Data.Complex
import Data.Ratio
import Prelude hiding (product)

stringLength :: String -> Int
stringLength x = case x of
  [] -> 0
  ['a',_] -> 1
  _:xs -> 1 + stringLength xs

integerListLength :: [Integer] -> Int
integerListLength n = case n of
  [] -> 0
  _:xs -> 1 + integerListLength xs

-- | A polymorphic length function
polymorphicLength :: [a] -> Int
polymorphicLength list = case list of
  []     -> 0
  _ : xs -> 1 + polymorphicLength xs

-- | A polymorphic reverse function
reverseOf :: [a] -> [a]
reverseOf n = case n of
  [] -> []
  x:xs -> reverseOf xs ++ [x]

-- | A polymorphic isPalindrome function
isPalindrome :: (Eq a) => [a] -> Bool
isPalindrome list = list == reverseOf list

-- | A polymorphic list equality function
listEqual :: (Eq a) => [a] -> [a] -> Bool
listEqual list1 list2 = case (list1,list2) of
  ([],[] )-> True
  ([],_) -> False
  (_,[]) -> False
  (x:xs,y:ys) -> (x==y) && (xs `listEqual` ys)

isMonotonicallyIncreasing :: (Ord a) => [a] -> Bool
isMonotonicallyIncreasing list = case list of
  [] -> True
  i1:i2:is
    |i1<=i2 -> isMonotonicallyIncreasing (i2:is)
    |otherwise -> False
  [_] -> True

normaliseVector :: (Floating a) => [a] -> [a]
normaliseVector vector = divideByScalar vector (norm vector)

divideByScalar :: (Fractional a) =>[a] -> a -> [a]
divideByScalar vector' scalar = case vector' of
   [] -> []
   f: fs -> (f / scalar): divideByScalar fs scalar

norm :: (Floating a) => [a] -> a
norm vector' = sqrt(sumSqr vector')
  where
  sumSqr :: (Num a)=> [a] -> a
  sumSqr vector'' = case vector'' of
    []    -> 0
    f: fs -> f*f + sumSqr fs

reallyPolymorphicLength :: (Integral b) => [a] -> b
reallyPolymorphicLength list = case list of
  []    -> 0
  _: xs -> 1 + reallyPolymorphicLength xs

printLargestAsString :: (Ord a, Show a) => [a] -> String
printLargestAsString list =
  "The largest element in the list is " ++ show (maximum list)

rationalZero :: Ratio Integer
floatZero    :: Float
doubleZero   :: Double
complexZero  :: Complex Double

rationalZero = 0
floatZero    = 0.0
doubleZero   = 0.0
complexZero  = mkPolar 0.0 0.0

product :: (Num a, Eq a) => a -> a -> a
product x y = case y of
  0->0
  1->x
  _->x+product x(y-1)


import Statistics.Distribution
import Statistics.Distribution.Normal

nd :: NormalDistribution
nd = normalDistr 0.0 1.0

main = do
  putStrLn $ "P( 2< Z) =      " ++ show (complCumulative nd 2)
  putStrLn $ "P(-2<=Z<=2)=    " ++ show (cumulative nd 2 - cumulative nd (-2))
  putStrLn $ "P( 0<=Z<=1.73)= " ++ show (cumulative nd 1.73 - cumulative nd 0)


-- PCA.hs
-- Compiles to library.
-- This library contains the functions needed to perform principle
-- component anlysis on vectorized data.
module PCA
( Hyperplane (..)
, mean
, saveHyperplane
, loadHyperplane
, linRegression
, distance
) where

import Numeric.LinearAlgebra.HMatrix
import Numeric.LinearAlgebra.Data
import Data.Packed.Matrix
import Data.Packed.Vector

data Hyperplane = Hyperplane Int (Vector Double) (Matrix Double) deriving (Show, Read)
-- First argument is the dimension of the ambient space.
-- Second argument is some vector in the hyperplane.
-- Rows of third argument form the basis of the parallel
-- linear subspace.
-- The Hyperplane is the coset of the second arg mod the third arg.

saveHyperplane :: FilePath -> Hyperplane -> IO ()
-- Saves a hyperplane in machine-readable plaintext format.
saveHyperplane f h = writeFile f (show h)

loadHyperplane :: FilePath -> IO Hyperplane
-- Loads a hyperplane that was saved in the syntax of `save`.
loadHyperplane f = readFile f >>= (return . read)

mean :: Matrix Double -> Vector Double
-- Returns the average of the rows of a matrix.
mean x = scale n . sum . toRows $ x
  where
  n = 1 / (fromIntegral . rows $ x) :: Double

normalize :: Matrix Double -> Matrix Double
-- Subtracts the average of/from the rows of a matrix.
normalize x = x - (fromRows . replicate (rows x) . mean $ x)

linRegression :: Int -> Matrix Double -> Hyperplane
-- Finds the best-fit hyperplane of the rows of a matrix.
-- First argument is the threshold to use a singular value.
-- Second argument is your data, rows are individual datapoints.
-- The first argument controls the size of the hyperplane.
-- If the first argument is too small, the hyperplane will just be
-- the whole space. If the first argument is too big, the hyper-
-- plane will just be a single point.
linRegression numsv inmat = Hyperplane n m rows
  where
  n = cols inmat
  m = mean inmat
  normalizedmat = normalize inmat
  (_,rows) = trimSVDRight numsv normalizedmat

trimSVDRight :: Int -> Matrix Double -> (Vector Double, Matrix Double)
-- Returns partial diagonal and right-side factor from SVD of
-- a matrix.
trimSVDRight numsv inmat = (v, outmat)
  where
  n' = min numsv (dim v1 - 1)
  (v1,m1) = rightSV inmat
  v = fromList . take n' . toList $ v1
  outmat = trans $ takeColumns (dim v) m1

distance :: Hyperplane -> Vector Double -> Double
-- Finds the distance from a vector to a hyperplane.
distance (Hyperplane n hv m) v
  | cols m == 0 = norm_2 v'
  | rows m == 0 = norm_2 v'
  | otherwise   = norm_2 $ distancevec
  where
  v' = v - hv
  distancevec = let a = m #> v'
                    b = trans m #> a in
                a `seq` b `seq` (b - v')


-- example 3.19

import Statistics.Distribution
import Statistics.Distribution.Poisson

-- Let a half-hour be our unital time.
pd :: PoissonDistribution
pd = poisson 1.0

p :: Int -> Double
p = probability pd

main = do
  putStrLn $ "the patrol will miss during the 0th period: " ++ show (p 0)
  putStrLn $ "the patrol will miss during the 1th period: " ++ show (p 1)
  putStrLn $ "the patrol will miss during the 2th period: " ++ show (p 2)
  putStrLn $ "the patrol will miss at least once:         " ++ show (1 - p 0)


module NN where

import Numeric.LinearAlgebra as LA

rectifiedLinearUnit :: R -> R
rectifiedLinearUnit = max 0

rectifiedLinearUnit' :: R -> R
rectifiedLinearUnit' x = if rectifiedLinearUnit x == 0 then 0 else 1

trainNeuralNetwork :: [((R, R), R)] -> Matrix R -> Matrix R -> Matrix R -> R -> Int -> (Matrix R, Matrix R, Matrix R)
trainNeuralNetwork xys wT b vT learningRate epochs = iterate (step xys learningRate) (wT, b, vT) !! epochs
    where
        step xys learningRate (wT, b, vT) = train xys wT b vT learningRate

train :: [((R, R), R)] -> Matrix R -> Matrix R -> Matrix R -> Double -> (Matrix R, Matrix R, Matrix R)
train xys wT b vT learningRate = train' xys wT b vT learningRate
    where
        train' [] wTs b vTs _ = (wTs, b, vTs)
        train' (((x1,x2), y):xys') wTs b vTs learningRate =
            let (wTs', b', vTs') = trainPoint wTs b vTs learningRate x1 x2 y
            in train' xys' wTs' b' vTs' learningRate

testNeuralNetwork :: [(R, R)] -> Matrix R -> Matrix R -> Matrix R -> R -> [R]
testNeuralNetwork xs wT b vT learningRate = map (calc wT b vT learningRate) xs
    where
        calc wT b vT learningRate (x1, x2) = predict wT b vT learningRate x1 x2

trainPoint :: Matrix R -> Matrix R -> Matrix R -> R -> R -> R -> R -> (Matrix R, Matrix R, Matrix R)
trainPoint wT b vT learningRate x1 x2 y = (wT - scalar learningRate * dw, b - scalar learningRate * db, vT - scalar learningRate * dv)
    where
        x = (2 >< 1) [x1, x2]

        z = wT LA.<> x + b
        a =  cmap rectifiedLinearUnit z

        u =  vT LA.<> a

        du = u - scalar y
        dv = du LA.<> tr a
        da = tr vT LA.<> du
        dz = da * cmap rectifiedLinearUnit' z

        db = dz
        dw = dz LA.<> tr x

predict :: Matrix R -> Matrix R -> Matrix R -> R -> R -> R -> R
predict wT b vT learningRate x1 x2  = u `atIndex` (0,0)
    where
        z = wT LA.<> (2 >< 1) [x1, x2] + b
        a = cmap rectifiedLinearUnit z
        u = vT LA.<> a


-- |
-- Module:      Math.NumberTheory.RootsOfUnity
-- Copyright:   (c) 2018 Bhavik Mehta
-- Licence:     MIT
-- Maintainer:  Bhavik Mehta <bhavikmehta8@gmail.com>
--
-- Implementation of roots of unity
--

module Math.NumberTheory.RootsOfUnity
(
-- * Roots of unity
   RootOfUnity (..)
-- ** Conversions
   , toRootOfUnity
   , toComplex )

where

import Data.Complex                                        (Complex(..), cis)
import Data.Semigroup                                      (Semigroup(..))
import Data.Ratio                                          ((%), numerator, denominator)

-- | A representation of <https://en.wikipedia.org/wiki/Root_of_unity roots of unity>: complex
-- numbers \(z\) for which there is \(n\) such that \(z^n=1\).
newtype RootOfUnity =
  RootOfUnity { -- | Every root of unity can be expressed as \(e^{2 \pi i q}\) for some
                -- rational \(q\) satisfying \(0 \leq q < 1\), this function extracts it.
                fromRootOfUnity :: Rational }
  deriving (Eq)

instance Show RootOfUnity where
  show (RootOfUnity q)
    | n == 0    = "1"
    | d == 1    = "-1"
    | n == 1    = "e^(πi/" ++ show d ++ ")"
    | otherwise = "e^(" ++ show n ++ "πi/" ++ show d ++ ")"
    where n = numerator (2*q)
          d = denominator (2*q)

-- | Given a rational \(q\), produce the root of unity \(e^{2 \pi i q}\).
toRootOfUnity :: Rational -> RootOfUnity
toRootOfUnity q = RootOfUnity ((n `rem` d) % d)
  where n = numerator q
        d = denominator q
        -- effectively q `mod` 1
  -- This smart constructor ensures that the rational is always in the range 0 <= q < 1.

-- | This Semigroup is in fact a group, so @'stimes'@ can be called with a negative first argument.
instance Semigroup RootOfUnity where
  RootOfUnity q1 <> RootOfUnity q2 = toRootOfUnity (q1 + q2)
  stimes k (RootOfUnity q) = toRootOfUnity (q * fromIntegral k)

instance Monoid RootOfUnity where
  mappend = (<>)
  mempty = RootOfUnity 0

-- | Convert a root of unity into an inexact complex number. Due to floating point inaccuracies,
-- it is recommended to avoid use of this until the end of a calculation. Alternatively, with
-- the [cyclotomic](http://hackage.haskell.org/package/cyclotomic-0.5.1) package, one can use
-- @[polarRat](https://hackage.haskell.org/package/cyclotomic-0.5.1/docs/Data-Complex-Cyclotomic.html#v:polarRat)
-- 1 . @'fromRootOfUnity' to convert to a cyclotomic number.
toComplex :: Floating a => RootOfUnity -> Complex a
toComplex (RootOfUnity t)
  | t == 1/2 = (-1) :+ 0
  | t == 1/4 = 0 :+ 1
  | t == 3/4 = 0 :+ (-1)
  | otherwise = cis . (2*pi*) . fromRational $ t


import Data.Complex
import Data.Array
import System.Random

predict_point_from_sources :: [Float] -> [Float] -> (Float,Float) -> Complex Float
predict_point_from_sources ls ms (u,v) =  foldl1 (+) $ map (\(l, m) ->
                                                               cos(2*pi * (u*l + v*m)) :+
                                                               sin(2*pi * (u*l + v*m))) $ zip ls ms

sample_uv_grid :: Int -> Float -> [Float] -> [Float] -> Array(Int, Int) (Complex Float)
sample_uv_grid size du ls ms =
  array((0,0),(size-1,size-1))
  [((x,y),predict_point_from_sources ls ms (du*fromIntegral(x - quot size 2),du*fromIntegral(y - quot size 2))) | x<-[0..size-1], y<-[0..size-1]]

generateArray :: Float -> Float -> IO [Float]
generateArray lowerb upperb =
  (getStdGen >>= return . randomRs (lowerb, upperb))

main :: IO()
main = do
  l <- generateArray 0.0 1.0
  m <- generateArray 0.0 1.0
  let ls = map (\x -> (x - 0.5)*0.1) $ take 100 $ l
  let ms = map (\x -> (x - 0.5)*0.1) $ take 100 $ m
  let point = predict_point_from_sources ls ms (3.4,5.6)
  print point
  let uvgrid = sample_uv_grid 5 5.0 ls ms
  print uvgrid


-- Haskell code for navigating the interface between lists of edges and
-- adjacency matrices.

module Adjacency where

import Numeric.LinearAlgebra hiding (fromList)
import qualified Numeric.LinearAlgebra as LA (fromList)
import Numeric.LinearAlgebra.Data
import qualified Data.Map.Strict as M
import qualified Data.List as L
import Data.Ord
import Data.KMeans

-- Data structure for graphs and networks. Just a list of edges.
data Graph a = Graph { nodes :: [a]
                     , edges :: [(a, a)]
                     } deriving (Show, Eq)

data Graph' a = Graph' { nodes' :: [a]
                       , edges' :: M.Map a [a]
                       } deriving (Show, Eq)

data Graph'' a = Graph'' { nodes'' :: [a]
                         , edges'' :: Matrix Double
                         } deriving (Show, Eq)

-- Converts the edge list to a map structure. Takes up more space, but it's
-- faster for looking up what else is connected to a particular node.
toMap :: (Ord a, Eq a) => Graph a -> Graph' a
toMap (Graph ns es) = Graph' ns es'
  where
    fInsert o o' m x = M.insertWith (++) (o x) [o' x] m
    iMap = M.fromList $ map (\x -> (x, [])) ns
    es' = L.foldl' (fInsert snd fst) (L.foldl' (fInsert fst snd) iMap es) es

-- Converts a graph (edge list) to an adjacency matrix structure.
toAdjacency :: (Ord a, Eq a) => Graph a -> Graph'' a
toAdjacency gr@(Graph ns es) = Graph'' ns m
  where
    n = length ns
    m = (n >< n) . concat . map (to01List ns) $ map ((M.!) . edges' $ toMap gr) ns

-- Converts a graph (edge list) to an adjacency matrix structure. About 1/3
-- slower than `toAdjacency`.
-- toAdjacency' :: (Ord a, Eq a) => Graph a -> Graph'' a
-- toAdjacency' gr@(Graph ns es) = Graph'' ns m
--   where
--     n = length ns
--     m = (n >< n) . M.foldl' (++) [] $ M.map (to01List ns) (edges' $ toMap es)

-- Given a list of edges which are all connected to a node, generates
-- a list of 0's and 1's denoting membership.
to01List ::  (Eq a) => [a] -> [a] -> [Double]
to01List ns es = map (boolTo01 . flip elem es) ns

-- Converts False/True to 0/1.
boolTo01 :: Bool -> Double
boolTo01 b
  | b    = 1
  | True = 0

-- SVD approximation to a graph (uses k-element SVD of the adjacency
-- matrix). In reality we need the SVD of XY^T, but that will come later.
svdGraph :: Int -> Graph'' a -> Graph'' a
svdGraph k (Graph'' ns es) = Graph'' ns $ compress k es

-- This function was written by Nicolas Favre-Felix. It returns an
-- approximation of the given matrix, by taking only the k largest entries
-- of Sigma.
compress :: Int -> Matrix Double -> Matrix Double
compress k m = u_k <> sigma_k <> v_k where
  (u,sigma,v) = svd m  -- get SVD
  sigma_k = takeBoth k $ diag sigma -- keep k values of Σ
  u_k = takeColumns k u    -- keep k columns of U
  v_k = takeRows k $ tr v   -- keep k rows of v

-- Constructs the graph Laplacian.
laplacian :: (Ord a, Eq a) => Graph a -> Matrix Double
laplacian gr = (diag $ LA.fromList counts) - (edges'' $ toAdjacency gr)
  where
    counts = M.foldl (\x y -> x ++ [fromIntegral $ length y]) [] . edges'
             $ toMap gr

-- A little wrapper to simplify taking the upper submatrix.
takeBoth :: (Element t) => Int -> Matrix t -> Matrix t
takeBoth d = takeColumns d . takeRows d

-- Spanning tree counter; uses Kirchhoff's Theorem.
spanTreeCount :: (Ord a, Eq a) => Graph a -> Integer
spanTreeCount gr@(Graph ns es) = round . det . takeBoth n' $ laplacian gr
  where
    n' = length ns - 1

-- spectralCluster performs spectral clustering to estimate group membership.
spectralCluster :: (Ord a, Eq a) => Int -> Graph a -> [[[Double]]]
spectralCluster k gr@(Graph ns es) = kmeans k u
  where
    n = length ns
    -- u = map toList . drop (n-k) . toColumns . snd . eigSH . sym $ laplacian gr
    u = map toList . drop (n-k) . toColumns . snd . eigSH $ laplacian gr

-- spectralCluster performs spectral clustering to estimate group
-- membership. Estimates the best choice of k using consecutive
-- differences of the eigenvalues.
spectralCluster' :: (Ord a, Eq a) => Graph a -> [[[Double]]]
spectralCluster' gr@(Graph ns es) = kmeans k u
  where
    n = length ns
    -- e = eigSH . sym $ laplacian gr
    e = eigSH $ laplacian gr
    k = (+1) . fst . L.minimumBy (comparing snd) . zip [0..] . reverse
        . diff . toList $ fst e
    u = map toList . drop (n-k) . toColumns $ snd e

lambdaSelect :: (Ord a, Eq a) => Graph a -> Int
lambdaSelect gr@(Graph ns es) = k
  where
    n = length ns
    -- e = eigSH . sym $ laplacian gr
    e = eigSH $ laplacian gr
    k = (+1) . fst . L.minimumBy (comparing snd) . zip [0..] . reverse
        . diff . toList $ fst e
    u = map toList . drop (n-k) . toColumns $ snd e

-- Consecutive differences.
diff :: (Num a) => [a] -> [a]
diff xs = zipWith (-) (drop 1 xs) xs


module Window (

    hamming
  , hammingC
  , c
  , Window
  , CWindow

  ) where

import Data.Vector
import qualified Data.Complex as C

type Window = Vector Double -- Windowing function

type CWindow = Vector (C.Complex Double) -- Windowing function

-- quick conversion to complex
c :: Num a => a -> C.Complex a
c = (C.:+ 0)

-- A hamming window of size n.
hamming :: Int -> Window
hamming m = generate m hamming' where
  hamming' n = 0.54 - 0.46*cos(2 * pi * (fromIntegral n)/(fromIntegral m-1))

-- A hamming window of type Complex Double of size n
hammingC :: Int -> CWindow
hammingC m = generate m hamming' where
  hamming' n = c $ 0.54 - 0.46*cos(2 * pi * (fromIntegral n)/(fromIntegral m-1))