-- Draw fractal by escape time method

module Escape where

import Graphics.GD
import Data.Complex

import Draw

type C = Complex Double

-- maxTime            ->
-- maxRadius          ->
-- iteration function ->
-- initial value      ->
-- time to escape
escape :: Int -> Double -> (C -> C) -> C -> Int
escape maxTime maxRadius f x = length $ takeWhile (\z -> magnitude z < maxRadius) $ take (maxTime + 1) $ iterate f x

-- exit by difference
escape' :: Int -> Double -> (C -> C) -> C -> Int
escape' maxTime minDiff f x = length $ takeWhile (\(a, b) -> abs (a - b) > minDiff) st where
    a  = map magnitude $ take (maxTime + 2) $ iterate f x
    st = zip a (tail a)

-- f z = z^2 + c, z0 = 0
mandelbrot :: IO ()
mandelbrot = drawFractal "mandelbrot.png" imageSize coorRange colorMagic where
    imageSize = (1000, 1000)
    coorRange = (-2.0, 1.0, -1.5, 1.5)
    colorMagic (x, y)
        | t > maxTime   = rgb 0 0 0
        | otherwise     = color
        where maxTime   = 256
              maxRadius = 2.0
              f         = \z -> z^2 + (x :+ y)
              t         = (escape maxTime maxRadius f 0) - 1
              color     = rgb t t t

-- quadratic polynomials is only a small subset of Julia set
-- f z = z^2 + c, z0 unset
julia :: C -> IO ()
julia c = drawFractal "julia.png" imageSize coorRange (colorMagic c) where
    imageSize = (1000, 1000)
    coorRange = (-2.0, 2.0, -2.0, 2.0)
    colorMagic c (x, y)
        | t > maxTime   = rgb 0 0 0
        | otherwise     = color
        where maxTime   = 256
              maxRadius = 2.0
              f         = \z -> z^2 + c
              t         = (escape maxTime maxRadius f (x :+ y)) - 1
              color     = rgb t t t

-- f z = (|Re(z)| + i|Im(z)|)^2 + c, z0 = 0
-- using (-) to generate, for better view
burningShip :: IO ()
burningShip = drawFractal "burningShip.png" imageSize coorRange colorMagic where
    imageSize = (2000, 1500)
    coorRange = (-1.67, -1.65, -0.002, 0.013)
    colorMagic (x, y)
        | t > maxTime   = rgb 0 0 0
        | otherwise     = color
        where maxTime   = 256
              maxRadius = 2.0
              f         = \z -> ((abs $ realPart z) :+ (negate . abs $ imagPart z))^2 + (x :+ y)
              t         = (escape maxTime maxRadius f 0) - 1
              color     = rgb t t t

-- only a subset of Nova
-- f z = z^p - 1
-- z => z - Rf/f' + c, (c = 0)
nova :: Int -> Double -> IO ()
nova p r = drawFractal "nova.png" imageSize coorRange (colorMagic p r) where
    imageSize = (1000, 1000)
    coorRange = (-2.0, 2.0, -2.0, 2.0)
    colorMagic p r (x, y)
        | t > maxTime = rgb 0 0 0
        | otherwise   = color
        where maxTime   = 256
              minDiff   = 0.0001
              cr        = r :+ 0
              f         = \z -> z - cr * (z^p - 1) / (fromIntegral p * z^(p-1))
              t         = (escape' maxTime minDiff f (x :+ y)) - 1
              color     = rgb t t t


module ExampleSeeds where

import           Data.Complex
import           Seed                           ( Seed
                                                , createSeed
                                                )

circleSeed :: Seed
circleSeed = createSeed f n spaceScale timeScale trailLength
 where
  f           = cis . (*) (2 * pi)
  n           = 101
  spaceScale  = 300
  timeScale   = 1
  trailLength = 0.8

lineSeed :: Seed
lineSeed = createSeed f n spaceScale timeScale trailLength
 where
  f t = (cos (2 * pi * t) :+ 0) * (1 :+ 1)
  n           = 101
  spaceScale  = 300
  timeScale   = 0.5
  trailLength = 1

rodFunction :: Float -> Complex Float
rodFunction x | x < 0.5   = -1
              | x > 0.5   = 1
              | otherwise = 0

rodSeed :: Seed
rodSeed = createSeed rodFunction n spaceScale timeScale trailLength
 where
  n           = 501
  spaceScale  = 500
  timeScale   = 0.1
  trailLength = 0.01

cardioid :: (RealFloat a) => a -> a -> Complex a
cardioid a t = x :+ y
 where
  x = 2 * a * (1 - cos t) * cos t
  y = 2 * a * (1 - cos t) * sin t

cardioidSeed :: Seed
cardioidSeed = createSeed (cardioid 100 . (*) (2 * pi))
                          n
                          spaceScale
                          timeScale
                          trailLength
 where
  n           = 21
  spaceScale  = 1
  timeScale   = 0.1
  trailLength = 0.8

lissajous :: (RealFloat a) => a -> a -> a -> Complex a
lissajous a b t = cos (a * t) :+ sin (b * t)

infinitySeed :: Seed
infinitySeed = createSeed (lissajous 1 2 . (*) (2 * pi))
                          n
                          spaceScale
                          timeScale
                          trailLength
 where
  n           = 51
  spaceScale  = 300
  timeScale   = 0.1
  trailLength = 1

parabolaSeed :: Seed
parabolaSeed = createSeed (lissajous 2 1 . (*) (2 * pi))
                          n
                          spaceScale
                          timeScale
                          trailLength
 where
  n           = 51
  spaceScale  = 300
  timeScale   = 0.1
  trailLength = 1

heart :: (RealFloat a) => a -> Complex a
heart t = x t :+ y t
 where
  x t = 16 * sin t ^ 3
  y t = 13 * cos t - 5 * cos (2 * t) - 2 * cos (3 * t) - cos (4 * t)

heartSeed :: Seed
heartSeed = createSeed (heart . (*) (2 * pi))
                       n
                       spaceScale
                       timeScale
                       trailLength
 where
  n           = 21
  spaceScale  = 20
  timeScale   = 0.1
  trailLength = 1


-- ch1 ex. 1.3

import qualified Data.Vector as V

import Statistics.Sample.Histogram (histogram)
import Statistics.Sample (mean, varianceUnbiased, stdDev, range)

-- uranium 258 in soil (picocuries per gram)
samples :: V.Vector Double
samples = V.fromList
  [ 0.74, 6.47, 1.90, 2.69, 0.75
  , 0.32, 9.99, 1.77, 2.41, 1.96
  , 1.66, 0.70, 2.42, 0.54, 3.36
  , 3.59, 0.37, 1.09, 8.32, 4.06
  , 4.55, 0.76, 2.03, 5.70,12.48
  ]

hist :: (V.Vector Double, V.Vector Int)
hist = histogram 8 samples

main :: IO ()
main = do
  let (lowerBs, hs) = hist
  putStrLn $ "The lower bounds for each bin: " ++ show lowerBs
  putStrLn $ "The histogram is: " ++ show hs

  let av = mean samples
      sd = stdDev samples
  putStrLn $ "The average value is: " ++ show av ++ "and the standard deviation is: " ++ show sd

  putStrLn $ "The range/4 is: " ++ show (range samples / 4)


module DiscreteFourier (discreteFourier, inverseDiscreteFourier) where

import Data.Complex (Complex, cis, magnitude)
import Data.List (zipWith, length)

import ComplexUtils (toComplex, toComplexM)

getAngles :: Double -> Int -> [(Complex Double)]
getAngles pi2k n = map cis $ map (pi2k *) $ map fromIntegral [0..n-1]

discreteFourierStep :: [(Complex Double)] -> Int -> Int -> (Complex Double)
discreteFourierStep fs op k =
    let
        n = length fs
    in
        if k == 0
            then (foldl (+) (toComplex 0) fs)
            else
                let
                    pi2k = (2 * pi * (fromIntegral k) * (fromIntegral op)) / (fromIntegral n)
                    angles = getAngles pi2k n
                in
                    sum $ zipWith (*) fs angles

iterateDiscreteFourierStep :: Int -> [(Complex Double)] -> [(Complex Double)]
iterateDiscreteFourierStep op fs =
    let
        n = length fs
    in
        map (discreteFourierStep fs op) [0..n-1]

discreteFourier :: [Double] -> [(Complex Double)]
discreteFourier fs = iterateDiscreteFourierStep (-1) $ toComplexM fs

inverseDiscreteFourier :: [(Complex Double)] -> [Double]
inverseDiscreteFourier cs =
    let
        n = length cs
        nd = fromIntegral n
    in
        map magnitude $ map (/nd) $ iterateDiscreteFourierStep 1 cs


module WWN

where

import Data.List
import Data.Ratio
import Data.Char
import Data.Complex
import Nats

binary :: Integral a => a -> [Int]
binary x = reverse (bits x)
  where bits 0 = [0]
        bits 1 = [1]
        bits n = fromIntegral (rem n 2) : bits (quot n 2)

showDigits :: [Int] -> String
showDigits = map intToDigit

bin ::  Integral a => a -> String
bin = showDigits . binary

coprime :: Integer -> Integer -> Bool
coprime m n = (gcd m n) == 1

gcde :: Integral a => a -> a -> (a,a,a)
gcde a b | a == 0 && b == 0 = error "gcd undefined"
         | a < 0  || b < 0  = error "gcd undefined"
         | a == 0           = (b,0,1)
         |           b == 0 = (a,1,0)
         | a > b            = let
                               (k,r)   = quotRem a b
                               (d,x,y) = gcde b r
                              in (d, y, x-k*y)
         | otherwise        = let
                               (k,r)   = quotRem b a
                               (d,x,y) = gcde a r
                              in (d, x-k*y, y)

data Sgn = P | N deriving (Eq,Show)
type MyInt = (Sgn,Natural)

myplus :: MyInt -> MyInt -> MyInt
myplus (s1,m) (s2,n) | s1 == s2           = (s1,m+n)
                     | s1 == P  && n <= m = (P,m-n)
                     | s1 == P  && n > m  = (N,n-m)
                     | otherwise          = myplus (s2,n) (s1,m)

type NatPair = (Natural,Natural)

plus1 :: NatPair -> NatPair -> NatPair
plus1 (m1, m2) (n1, n2) = (m1+n1, m2+n2)

subtr1 :: NatPair -> NatPair -> NatPair
subtr1 (m1, m2) (n1, n2) = plus1 (m1, m2) (n2, n1)

mult1 :: NatPair -> NatPair -> NatPair
mult1 (m1, m2) (n1, n2) = (m1*n1 + m2*n2, m1*n2 + m2*n1)

eq1 :: NatPair -> NatPair -> Bool
eq1 (m1, m2) (n1, n2) = (m1+n2) == (m2+n1)

reduce1 :: NatPair -> NatPair
reduce1 (m1,Z) = (m1,Z)
reduce1 (Z,m2) = (Z,m2)
reduce1 (S m1, S m2) = reduce1 (m1, m2)

decExpand :: Rational -> [Integer]
decExpand x | x < 0     = error "negative argument"
            | r == 0    = [q]
            | otherwise = q : decExpand ((r*10) % d)
   where
   (q,r) = quotRem n d
   n     = numerator x
   d     = denominator x

decForm :: Rational -> (Integer,[Int],[Int])
decForm x | x < 0     = error "negative argument"
          | otherwise = (q,ys,zs)
  where
  (q,r)   = quotRem n d
  n       = numerator x
  d       = denominator x
  (ys,zs) = decF (r*10) d []

decF :: Integer -> Integer -> [(Int,Integer)] -> ([Int],[Int])
decF n d xs | r == 0        = (reverse (q: (map fst xs)),[])
            | elem (q,r) xs = (ys,zs)
            | otherwise     =  decF (r*10) d ((q,r):xs)
     where
     (q',r)  = quotRem n d
     q       = fromIntegral q'
     xs'     = reverse xs
     Just k  = elemIndex (q,r) xs'
     (ys,zs) = splitAt k (map fst xs')

mechanicsRule :: Rational -> Rational -> Rational
mechanicsRule p x = (1 % 2) * (x + (p * (recip x)))

mechanics :: Rational -> Rational -> [Rational]
mechanics p x = iterate (mechanicsRule p) x

sqrtM :: Rational -> [Rational]
sqrtM p | p < 0     = error "negative argument"
        | otherwise = mechanics p s
   where
   s = if xs == [] then 1 else last xs
   xs = takeWhile  (\ m -> m^2 <= p) [1..]

approximate :: Rational -> [Rational] -> Rational
approximate eps (x:y:zs)
  | abs (y-x) < eps = y
  | otherwise       = approximate eps (y:zs)

apprx :: [Rational] -> Rational
apprx = approximate (1/10^6)

mySqrt :: Rational -> Rational
mySqrt p = apprx (sqrtM p)

solveQ :: (Complex Float, Complex Float, Complex Float)
                               -> (Complex Float, Complex Float)
solveQ =  \ (a,b,c) -> if a == 0 then error "not quadratic"
                                 else let d = b^2 - 4*a*c in
                                           ((- b + sqrt d) / 2*a,
                                            (- b - sqrt d) / 2*a)


import Data.Complex

rootsOfUnity n = [cis (2*pi*k/n) | k <- [0..n-1]]


{-|
Module: MachineLearning.PCA
Description: Principal Component Analysis.
Copyright: (c) Alexander Ignatyev, 2017-2018.
License: BSD-3
Stability: experimental
Portability: POSIX

Principal Component Analysis (PCA) - dimensionality reduction algorithm.
It is mostly used to speed up supervising learning (Regression, Classification, etc) and visualization of data.
-}

module MachineLearning.PCA
(
  getDimReducer
  , getDimReducer_rv
)

where

import Prelude hiding ((<>))
import Data.Maybe (fromMaybe)
import qualified Data.Vector.Storable as V
import qualified Numeric.LinearAlgebra as LA
import Numeric.LinearAlgebra ((<>), (??))
import qualified MachineLearning as ML

import MachineLearning.Types (R, Vector, Matrix)

-- | Computes "covariance matrix".
covarianceMatrix :: Matrix -> Matrix
covarianceMatrix x = ((LA.tr x) <> x) / (fromIntegral $ LA.rows x)

-- | Compute eigenvectors (matrix U) and singular values (matrix S) of the given covariance matrix.
pca :: Matrix -> (Matrix, Vector)
pca x = (u, s)
  where sigma = covarianceMatrix x
        (u, s, _) = LA.svd sigma

-- | Gets dimensionality reduction function, retained variance (0..1) and reduced X
-- for given matrix X and number of dimensions to retain.
getDimReducer :: Matrix -> Int -> (Matrix -> Matrix, R, Matrix)
getDimReducer x k = (reducer, retainedVariance, reducer xNorm)
  where muSigma = ML.meanStddev x
        xNorm = ML.featureNormalization muSigma x
        (u, s) = pca xNorm
        u' = u ?? (LA.All, LA.Take k)
        reducer xx = (ML.featureNormalization muSigma xx) <> u'
        retainedVariance = (V.sum $ V.slice 0 k s) / (V.sum s)

-- | Gets dimensionality reduction function, retained number of dimensions and reduced X
-- for given matrix X and variance to retain (0..1].
getDimReducer_rv :: Matrix -> R -> (Matrix -> Matrix, Int, Matrix)
getDimReducer_rv x rv = (reducer, k, reducer xNorm)
  where muSigma = ML.meanStddev x
        xNorm = ML.featureNormalization muSigma x
        (u, s) = pca xNorm
        sum_s = V.sum s
        variances = (V.scanl' (+) 0 s) / (LA.scalar sum_s)
        k = fromMaybe ((V.length s) - 1) $ V.findIndex (\v -> v >= rv) variances
        u' = u ?? (LA.All, LA.Take k)
        reducer xx = (ML.featureNormalization muSigma xx) <> u'


-- file: Astro/Tests.hs
-- Tests for some of the library functions

module Astro.Tests
	where

import Astro.Stumpff
import Astro.Kepler
import Astro.Elements

import Control.Monad
import Numeric.LinearAlgebra
import Test.QuickCheck
import Test.QuickCheck.Arbitrary

-- Stumpff c functions
stumpff_c_rec_lhs k x = x * stumpff_c k x
stumpff_c_rec_rhs k x = 1.0/fromIntegral (fac (k-2)) - stumpff_c (k-2) x
	where fac n = product [1..n]
prop_stumpff_c_0 k = stumpff_c k 0.0 == 0
prop_stumpff_c_rec k x =
	let lhs = stumpff_c_rec_lhs k x
	    rhs = stumpff_c_rec_rhs k x
	in
	(k >= 2 && k <= 35 && x /= 0) ==> abs $ (rhs-lhs)/lhs <= 1e-7
	where fac n = product [1..n]
prop_stumpff_G_0 k beta = (stumpff_G k beta 0.0 == 0)
prop_stumpff_G_rec k beta x =
	(k >= 2) ==> (x * stumpff_G k beta x ==
		x^(k-2)/fromIntegral (fac (k-2)) - stumpff_G (k-2) beta x)
	where fac n = product [1..n]

-- Orbital elements
{-
instance Arbitrary (Vector t) where
	arbitrary = liftM fromList (vectorOf 3 arbitrarySizedFractional)
-}
--prop_oe_rv_id :: Vector Double -> Vector Double -> Double -> Property
prop_oe_rv_id :: [Double] -> [Double] -> Double -> Property
prop_oe_rv_id r v gpar =
	property $ (length r == 3 && length v == 3) ==> (rv == rv' && vv == vv')
	where
		rv = fromList r
		vv = fromList v
		(rv',vv') = orbelToPosvel_gp (posvelToOrbel_gp rv vv gpar) gpar


module Math.TestDimensionsPCA where

import Universum hiding (All, Vector, transpose)

import GPLVM.Types

import Control.Lens (makeLenses)
import Data.Array.Repa
import Data.Array.Repa.Repr.ForeignPtr
import Numeric.LinearAlgebra.Repa hiding (Matrix, Vector)

import Math.Matrix

data PCA = PCA
  { inputData    :: Matrix D Double
  , covariance   :: Covariance Double
  , eigenVectors :: EigenVectors Double
  , eigenValues  :: Vector F Double
  , finalData    :: Matrix D Double
  , restoredData :: Matrix D Double
  }

makePCA
    :: Int
    -> Matrix D Double
    -> PCA
makePCA desiredDimensions input =
  let inputData = input
      (Z :. yInp :. _) = extent input                                          -- get dimension
      (meanVec, covariance) = meanCovS input
      meanMatrix = DimMatrix $ toMatrix meanVec yInp
      adjustInput = DimMatrix input -^^ meanMatrix
      (eigenValues', eigenVec) = eigSHM covariance
      eigenValue = runVector eigenValues'
      eigenVecD@(DimMatrix (ADelayed (Z :. y :. x) f)) = transposeM eigenVec              -- transposing is almost free
      eigenVectors' =                                                        -- leave only n desired eigenvectors
        if desiredDimensions >= y
        then eigenVecD
        else DimMatrix $ ADelayed (Z :. desiredDimensions :. x) f
      eigenVectors = getInternal $ transposeM eigenVectors'                       -- colunmns are eigenvectors
      finalData' = eigenVectors' `mulPM` transposeM adjustInput -- data in new eigenvectors space
      finalData = getInternal . transposeM $ finalData'
      restoredDataWOMean = transposeM $ pinvSM eigenVectors' `mulPM` finalData'  -- restore to the original space
      restoredData = getInternal $ restoredDataWOMean +^^ meanMatrix              -- add mean
  in PCA{..}


module Clustering.Measures where

import           Data.Maybe ( fromMaybe )
import qualified Control.Foldl as L

import qualified Data.Vector as V
import Numeric.LinearAlgebra

import Clustering.Hierarchical
import Clustering.Data

meanCD :: Fractional c => c -> [c] -> c
meanCD a = L.fold L.mean . map (abs . (a -))

maxCD :: (Ord c, Fractional c) => c -> [c] -> c
maxCD a = fromMaybe 0 . L.fold L.maximum . map (abs . (a -))

getPatternMatrix :: [V.Vector Float] -> Matrix Float
getPatternMatrix [] = undefined
getPatternMatrix xs@(x:_) = (length xs >< length x) $  concatMap V.toList xs

xs :: [V.Vector Float]
xs = map V.fromList [[2, 5],
                     [6, 4],
                     [5, 3],
                     [2, 2],
                     [1, 4],
                     [5, 2],
                     [3, 3],
                     [2, 3]]

xs2 :: [V.Vector Float]
xs2 = map V.fromList [[1, 1],
                      [2, 1],
                      [5, 4],
                      [6, 5],
                      [6.5, 6]]

euc :: V.Vector Float -> V.Vector Float -> Float
-- euc v1 v2 = sqrt $ V.sum $ V.zipWith (\a b ->  (a - b)^2) v1 v2
euc = ((sqrt . V.sum) .) . V.zipWith (\a b ->  (a - b)^2)

meanCDeuc :: V.Vector Float -> [V.Vector Float] -> Float
meanCDeuc v l = euc v $ ccentre l

ccentre :: (Fractional b, Foldable t) => t (V.Vector b) -> V.Vector b
ccentre l = V.map (/(fromIntegral $ length l))
            $ foldl1 (V.zipWith (+)) l

meanCCD :: [V.Vector Float] -> [V.Vector Float] -> Float
meanCCD l1 l2 = euc (ccentre l1) (ccentre l2)

meanAgg :: Fractional c => (t -> a -> c) -> t -> [a] -> c
meanAgg f a = L.fold L.mean . map (f a)

reprDD :: Dendrogram (V.Vector Float )
    -> Dendrogram (V.Vector Float )  -> Float
reprDD DNil DNil = 0
reprDD DNil _ = 0
reprDD _ DNil = 0
reprDD DNode{repr=r1} DNode{repr=r2} = euc r1 r2

meanDRU :: Dendrogram (V.Vector Float )
    -> Dendrogram (V.Vector Float)  -> V.Vector Float
meanDRU DNil DNil = undefined
meanDRU DNil _ = undefined
meanDRU _ DNil = undefined
meanDRU DNode{repr=r1} DNode{repr=r2} = ccentre [r1, r2]