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


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


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]