{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeSynonymInstances #-}

module PLA
  ( Weight(..)
  , Point'(..)
  , viewX
  , trainPLA
  , trainPLAWithInitial
  , isMisclassified
  ) where

import           Control.Lens
import           Control.Lens.Combinators
import           Control.Lens.Operators
import           Control.Monad.Reader
import           Data.List
import           Data.Traversable           (for)
import           Numeric.LinearAlgebra.Data
import           System.Random

--------------------------------
--  Solutions to homework 1, problems 7-10 of
--  the 'Learning from Data' course
-- http://work.caltech.edu/homeworks.html
-------------------------------------
-------------------------------
-- Types and Typeclass Instances
--------------------------------
type Weight = (R, R, R)

type Point = (R, R)

-- | To be used at a later stage - currently just a test
data Point' =
  Point'
    { _x :: R
    , _y :: R
    }

makeLenses ''Point'

instance Num Weight where
  (+) (x0, x1, x2) (w0, w1, w2) = (w0 + x0, w1 + x1, w2 + x2)
  (-) (x0, x1, x2) (w0, w1, w2) = (x0 - w0, x1 - w1, x2 - w2)
  (*) (x0, x1, x2) (w0, w1, w2) =
    (w2 * x1 - w1 * x2, w2 * x0 - w0 * x2, w1 * x0 - w0 * x1)
  negate (w0, w1, w2) = (negate w0, negate w1, negate w2)
  abs (w0, w1, w2) = (abs w0, abs w1, abs w2)
  fromInteger x = (fromInteger x, 0.0, 0.0)
  signum (w0, w1, w2) = signum (w0, w1, w2)

--------------------------------------------
-- Creating the line for the target function
--------------------------------------------
m :: Point -> Point -> R
m (x1, x2) (z1, z2) = (x2 - z2) / (x1 - z1)

b :: Point -> Point -> R
b (x1, x2) (z1, z2) = x2 - x1 * (x2 - z2) / (x1 - z1)

-- | Takes 2 Points and returns the function of a line connecting them
line :: Point -> Point -> (R -> R)
line point1 point2 = \x -> m point1 point2 * x + b point1 point2

-----------------------------------
-- functions for the Weight type
-----------------------------------
-- | The dot product
dotProd :: Weight -> Weight -> R
dotProd (x0, x1, x2) (w0, w1, w2) = w0 * x0 + w1 * x1 + w2 * x2

-- | Scalar multiplication of the weight vecotr
prod :: R -> Weight -> Weight
prod lambda (x0, x1, x2) = (x0 * lambda, x1 * lambda, x2 * lambda)

-- | Converting a point to a weight by adding the first coordinate (1)
point2weight :: Point -> Weight
point2weight (x1, x2) = (1, x1, x2)

-- | looks up the label of the point by applying the target function
yn :: (R -> R) -> Point -> R
yn yLine (x1, x2) =
  if yLine x1 < x2
    then (-1)
    else 1

-- | Checking if a point is misclassified
isMisclassified yLine weight point = classified /= label
  where
    classified = signum $ dotProd (point2weight point) weight
    label = yn yLine point

updateWeight' yLine w xn = w + prod (yn yLine xn) (point2weight xn)

-- | Performs 1 training epoch (one run through all training points)
-- | performs the perceptron learning algorithm
pla yLine w niter gen xs
  | misclassifiedXs == [] = (w, niter)
  | otherwise = pla yLine wUpdated (niter + 1) nextRandom xs
  where
    wUpdated = updateWeight' yLine w $ misclassifiedXs !! number
    misclassifiedXs = filter (isMisclassified yLine w) xs
    randomRange = (0, length misclassifiedXs - 1)
    (number, nextRandom) = randomR randomRange gen

-- | stores the target function and performs training, returning the weight and the number of epochs performed before convergence
weightReader' :: [Point] -> StdGen -> Reader (R -> R) (Weight, Int)
weightReader' points gen = do
  targetFunc <- ask
  let weightsEpochs = pla targetFunc (0, 0, 0) 0 gen points
  return weightsEpochs

-- | stores the target function and performs training, returning the weight and the number of epochs performed before convergence
weightReader :: [Point] -> StdGen -> Weight -> Reader (R -> R) (Weight, Int)
weightReader points gen initialWeights = do
  targetFunc <- ask
  let weightsEpochs = pla targetFunc initialWeights 0 gen points
  return weightsEpochs

-- |Creates a random Point between (-1,-1) and (1,1)
createRandomPoint = do
  rand1 :: R <- randomRIO (-1, 1)
  rand2 :: R <- randomRIO (-1, 1)
  return (rand1, rand2)

-- |Creates a list of n random Points between (-1,-1) and (1,1)
createRandomPoints n = do
  randList1 :: [R] <- for [1 .. n] $ \_ -> randomRIO (-1, 1)
  randList2 :: [R] <- for [1 .. n] $ \_ -> randomRIO (-1, 1)
  return $ zip randList1 randList2-- | creates an infinite list of permutations of the list provided as an argument

pointPermutations = cycle . permutations

-- | Just a test for the point lens
viewX point = view x point

---------------------------------------------------------------
-- The final loop that creates the target function and training and testing data,
-- performs training and testing
-------------------------------------------------------------------
-- | performs the PLA
trainPLA :: Int -> IO ()
trainPLA nPoints = do
  point1 <- createRandomPoint
  point2 <- createRandomPoint
  stdgen <- getStdGen
  let target = line point1 point2
  trainpoints <- createRandomPoints nPoints
  let (weights, epochs) = runReader (weightReader' trainpoints stdgen) target
  putStr "Weights: "
  print weights
  putStr "Epochs: "
  print epochs
  testpoints <- createRandomPoints 1000
  let misclassifiedTestPoints =
        length $ filter (isMisclassified target weights) testpoints
  let prob = fromIntegral misclassifiedTestPoints / 1000
  putStr "Probability f /= g: "
  print prob

-- | performs the PLA with a set of initial weights, training points and a target function
trainPLAWithInitial :: (R, R, R) -> [Point] -> (R -> R) -> IO (Weight, Int)
trainPLAWithInitial initialWeights trainPoints target = do
  stdgen <- getStdGen
  let (weights, epochs) =
        runReader (weightReader trainPoints stdgen initialWeights) target
  return (weights, epochs)


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ParallelListComp #-}
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (c) Edward Kmett 2010-2021
-- License     :  BSD3
-- Maintainer  :  ekmett@gmail.com
-- Stability   :  experimental
-- Portability :  GHC only
--
-----------------------------------------------------------------------------

module Numeric.AD.Newton
  (
  -- * Newton's Method (Forward AD)
    findZero
  , findZeroNoEq
  , inverse
  , inverseNoEq
  , fixedPoint
  , fixedPointNoEq
  , extremum
  , extremumNoEq
  -- * Gradient Ascent/Descent (Reverse AD)
  , gradientDescent, constrainedDescent, CC(..), eval
  , gradientAscent
  , conjugateGradientDescent
  , conjugateGradientAscent
  , stochasticGradientDescent
  ) where

import Data.Foldable (all, sum)
import Data.Reflection (Reifies)
import Data.Traversable
import Numeric.AD.Internal.Combinators
import Numeric.AD.Internal.Forward (Forward)
import Numeric.AD.Internal.On
import Numeric.AD.Internal.Or
import Numeric.AD.Internal.Reverse (Reverse, Tape)
import Numeric.AD.Internal.Type (AD(..))
import Numeric.AD.Mode
import Numeric.AD.Mode.Reverse as Reverse (gradWith, gradWith', grad')
import Numeric.AD.Rank1.Kahn as Kahn (Kahn, grad)
import qualified Numeric.AD.Rank1.Newton as Rank1
import Prelude hiding (all, mapM, sum)

-- $setup
-- >>> import Data.Complex

-- | The 'findZero' function finds a zero of a scalar function using
-- Newton's method; its output is a stream of increasingly accurate
-- results.  (Modulo the usual caveats.) If the stream becomes constant
-- ("it converges"), no further elements are returned.
--
-- Examples:
--
-- >>> take 10 $ findZero (\x->x^2-4) 1
-- [1.0,2.5,2.05,2.000609756097561,2.0000000929222947,2.000000000000002,2.0]
--
-- >>> last $ take 10 $ findZero ((+1).(^2)) (1 :+ 1)
-- 0.0 :+ 1.0
findZero :: (Fractional a, Eq a) => (forall s. AD s (Forward a) -> AD s (Forward a)) -> a -> [a]
findZero f = Rank1.findZero (runAD.f.AD)
{-# INLINE findZero #-}

-- | The 'findZeroNoEq' function behaves the same as 'findZero' except that it
-- doesn't truncate the list once the results become constant. This means it
-- can be used with types without an 'Eq' instance.
findZeroNoEq :: Fractional a => (forall s. AD s (Forward a) -> AD s (Forward a)) -> a -> [a]
findZeroNoEq f = Rank1.findZeroNoEq (runAD.f.AD)
{-# INLINE findZeroNoEq #-}

-- | The 'inverse' function inverts a scalar function using
-- Newton's method; its output is a stream of increasingly accurate
-- results.  (Modulo the usual caveats.) If the stream becomes
-- constant ("it converges"), no further elements are returned.
--
-- Example:
--
-- >>> last $ take 10 $ inverse sqrt 1 (sqrt 10)
-- 10.0
inverse :: (Fractional a, Eq a) => (forall s. AD s (Forward a) -> AD s (Forward a)) -> a -> a -> [a]
inverse f = Rank1.inverse (runAD.f.AD)
{-# INLINE inverse  #-}

-- | The 'inverseNoEq' function behaves the same as 'inverse' except that it
-- doesn't truncate the list once the results become constant. This means it
-- can be used with types without an 'Eq' instance.
inverseNoEq :: Fractional a => (forall s. AD s (Forward a) -> AD s (Forward a)) -> a -> a -> [a]
inverseNoEq f = Rank1.inverseNoEq (runAD.f.AD)
{-# INLINE inverseNoEq #-}

-- | The 'fixedPoint' function find a fixedpoint of a scalar
-- function using Newton's method; its output is a stream of
-- increasingly accurate results.  (Modulo the usual caveats.)
--
-- If the stream becomes constant ("it converges"), no further
-- elements are returned.
--
-- >>> last $ take 10 $ fixedPoint cos 1
-- 0.7390851332151607
fixedPoint :: (Fractional a, Eq a) => (forall s. AD s (Forward a) -> AD s (Forward a)) -> a -> [a]
fixedPoint f = Rank1.fixedPoint (runAD.f.AD)
{-# INLINE fixedPoint #-}

-- | The 'fixedPointNoEq' function behaves the same as 'fixedPoint' except that
-- it doesn't truncate the list once the results become constant. This means it
-- can be used with types without an 'Eq' instance.
fixedPointNoEq :: Fractional a => (forall s. AD s (Forward a) -> AD s (Forward a)) -> a -> [a]
fixedPointNoEq f = Rank1.fixedPointNoEq (runAD.f.AD)
{-# INLINE fixedPointNoEq #-}

-- | The 'extremum' function finds an extremum of a scalar
-- function using Newton's method; produces a stream of increasingly
-- accurate results.  (Modulo the usual caveats.) If the stream
-- becomes constant ("it converges"), no further elements are returned.
--
-- >>> last $ take 10 $ extremum cos 1
-- 0.0
extremum :: (Fractional a, Eq a) => (forall s. AD s (On (Forward (Forward a))) -> AD s (On (Forward (Forward a)))) -> a -> [a]
extremum f = Rank1.extremum (runAD.f.AD)
{-# INLINE extremum #-}

-- | The 'extremumNoEq' function behaves the same as 'extremum' except that it
-- doesn't truncate the list once the results become constant. This means it
-- can be used with types without an 'Eq' instance.
extremumNoEq :: Fractional a => (forall s. AD s (On (Forward (Forward a))) -> AD s (On (Forward (Forward a)))) -> a -> [a]
extremumNoEq f = Rank1.extremumNoEq (runAD.f.AD)
{-# INLINE extremumNoEq #-}

-- | The 'gradientDescent' function performs a multivariate
-- optimization, based on the naive-gradient-descent in the file
-- @stalingrad\/examples\/flow-tests\/pre-saddle-1a.vlad@ from the
-- VLAD compiler Stalingrad sources.  Its output is a stream of
-- increasingly accurate results.  (Modulo the usual caveats.)
--
-- It uses reverse mode automatic differentiation to compute the gradient.
gradientDescent :: (Traversable f, Fractional a, Ord a) => (forall s. Reifies s Tape => f (Reverse s a) -> Reverse s a) -> f a -> [f a]
gradientDescent f x0 = go x0 fx0 xgx0 0.1 (0 :: Int)
  where
    (fx0, xgx0) = Reverse.gradWith' (,) f x0
    go x fx xgx !eta !i
      | eta == 0     = [] -- step size is 0
      | fx1 > fx     = go x fx xgx (eta/2) 0 -- we stepped too far
      | zeroGrad xgx = [] -- gradient is 0
      | otherwise    = x1 : if i == 10
                            then go x1 fx1 xgx1 (eta*2) 0
                            else go x1 fx1 xgx1 eta (i+1)
      where
        zeroGrad = all (\(_,g) -> g == 0)
        x1 = fmap (\(xi,gxi) -> xi - eta * gxi) xgx
        (fx1, xgx1) = Reverse.gradWith' (,) f x1
{-# INLINE gradientDescent #-}

data SEnv (f :: * -> *) a = SEnv { sValue :: a, origEnv :: f a }
  deriving (Functor, Foldable, Traversable)

-- | Convex constraint, CC, is a GADT wrapper that hides the existential
-- ('s') which is so prevalent in the rest of the API.  This is an
-- engineering convenience for managing the skolems.
data CC f a where
  CC :: forall f a. (forall s. Reifies s Tape => f (Reverse s a) -> Reverse s a) -> CC f a

-- |@constrainedDescent obj fs env@ optimizes the convex function @obj@
-- subject to the convex constraints @f <= 0@ where @f `elem` fs@. This is
-- done using a log barrier to model constraints (i.e. Boyd, Chapter 11.3).
-- The returned optimal point for the objective function must satisfy @fs@,
-- but the initial environment, @env@, needn't be feasible.
constrainedDescent :: forall f a. (Traversable f, RealFloat a, Floating a, Ord a)
                   => (forall s. Reifies s Tape => f (Reverse s a)
                                                -> Reverse s a)
                   -> [CC f a]
                   -> f a
                   -> [(a,f a)]
constrainedDescent objF [] env =
  map (\x -> (eval objF x, x)) (gradientDescent objF env)
constrainedDescent objF cs env =
    let s0       = 1 + maximum [eval c env | CC c <- cs]
        -- ^ s0 = max ( f_i(0) )
        cs'      = [CC (\(SEnv sVal rest) -> c rest - sVal) | CC c <- cs]
        -- ^ f_i' = f_i - s0  and thus f_i' <= 0
        envS     = SEnv s0 env
        -- feasible point for f_i', use gd to find feasiblity for f_i
        cc       = constrainedConvex' (CC sValue) cs' envS ((<=0) . sValue)
    in case dropWhile ((0 <) . fst) (take (2^(20::Int)) cc) of
        []                  -> []
        (_,envFeasible) : _ ->
            constrainedConvex' (CC objF) cs (origEnv envFeasible) (const True)
{-# INLINE constrainedDescent #-}

eval :: (Traversable f, Fractional a, Ord a) => (forall s. Reifies s Tape => f (Reverse s a) -> Reverse s a) -> f a -> a
eval f e = fst (grad' f e)
{-# INLINE eval #-}

-- | Like 'constrainedDescent' except the initial point must be feasible.
constrainedConvex' :: forall f a. (Traversable f, RealFloat a, Floating a, Ord a)
                   => CC f a
                   -> [CC f a]
                   -> f a
                   -> (f a -> Bool)
                   -> [(a,f a)]
constrainedConvex' objF cs env term =
  -- 1. Transform cs using a log barrier with increasing t values.
  let os   = map (mkOpt objF cs) tValues
  -- 2. Iteratively run gradientDescent on each os.
      envs =  [(undefined,env)] :
              [gD (snd $ last e) o
                          | o  <- os
                          | e  <- limEnvs
                          ]
      -- Obtain a finite number of elements from the initial len tValues - 1 lists.
      limEnvs = zipWith id nrSteps envs
  in dropWhile (not . term . snd) (concat $ drop 1 limEnvs)
 where
  tValues = map realToFrac $ take 64 $ iterate (*2) (2 :: a)
  nrSteps = [take 20 | _ <- [1..length tValues]] ++ [id]
  -- | `gD f e` is gradient descent with the evaulated result
  gD e (CC f)  = (eval f e, e) :
                 map (\x -> (eval f x, x)) (gradientDescent f e)
{-# INLINE constrainedConvex' #-}

-- @mkOpt u fs t@ converts an inequality convex problem (@u,fs@) into an
-- unconstrained convex problem using log barrier @u + -(1/t)log(-f_i)@.
-- As @t@ increases the approximation is more accurate but the gradient
-- decreases, making the gradient descent more expensive.
mkOpt :: forall f a. (Traversable f, RealFloat a, Floating a, Ord a)
      => CC f a -> [CC f a]
      -> a -> CC f a
mkOpt (CC o) xs t = CC (\e -> o e + sum (map (\(CC c) -> iHat t c e) xs))
{-# INLINE mkOpt #-}

iHat :: forall a f. (Traversable f, RealFloat a, Floating a, Ord a)
     => a
     -> (forall s. Reifies s Tape => f (Reverse s a) -> Reverse s a)
     -> (forall s. Reifies s Tape => f (Reverse s a) -> Reverse s a)
iHat t c e =
   let r = c e
   in if r >= 0 || isNaN r
        then 1  / 0
        else (-1 / auto t) * log( - (c  e))
{-# INLINE iHat #-}

-- | The 'stochasticGradientDescent' function approximates
-- the true gradient of the constFunction by a gradient at
-- a single example. As the algorithm sweeps through the training
-- set, it performs the update for each training example.
--
-- It uses reverse mode automatic differentiation to compute the gradient
-- The learning rate is constant through out, and is set to 0.001
stochasticGradientDescent :: (Traversable f, Fractional a, Ord a)
  => (forall s. Reifies s Tape => e -> f (Reverse s a) -> Reverse s a)
  -> [e]
  -> f a
  -> [f a]
stochasticGradientDescent errorSingle d0 x0 = go xgx0 0.001 dLeft
  where
    dLeft = tail $ cycle d0
    xgx0 = Reverse.gradWith (,) (errorSingle (head d0)) x0
    go xgx !eta d
      | eta ==0       = []
      | otherwise     = x1 : go xgx1 eta (tail d)
      where
        x1 = fmap (\(xi, gxi) -> xi - eta * gxi) xgx
        (_, xgx1) = Reverse.gradWith' (,) (errorSingle (head d)) x1
{-# INLINE stochasticGradientDescent #-}

-- | Perform a gradient descent using reverse mode automatic differentiation to compute the gradient.
gradientAscent :: (Traversable f, Fractional a, Ord a) => (forall s. Reifies s Tape => f (Reverse s a) -> Reverse s a) -> f a -> [f a]
gradientAscent f = gradientDescent (negate . f)
{-# INLINE gradientAscent #-}

-- | Perform a conjugate gradient descent using reverse mode automatic differentiation to compute the gradient, and using forward-on-forward mode for computing extrema.
--
-- >>> let sq x = x * x
-- >>> let rosenbrock [x,y] = sq (1 - x) + 100 * sq (y - sq x)
-- >>> rosenbrock [0,0]
-- 1
-- >>> rosenbrock (conjugateGradientDescent rosenbrock [0, 0] !! 5) < 0.1
-- True
conjugateGradientDescent
  :: (Traversable f, Ord a, Fractional a)
  => (forall s. Chosen s => f (Or s (On (Forward (Forward a))) (Kahn a)) -> Or s (On (Forward (Forward a))) (Kahn a))
  -> f a -> [f a]
conjugateGradientDescent f = conjugateGradientAscent (negate . f)
{-# INLINE conjugateGradientDescent #-}

lfu :: Functor f => (f (Or F a b) -> Or F a b) -> f a -> a
lfu f = runL . f . fmap L

rfu :: Functor f => (f (Or T a b) -> Or T a b) -> f b -> b
rfu f = runR . f . fmap R

-- | Perform a conjugate gradient ascent using reverse mode automatic differentiation to compute the gradient.
conjugateGradientAscent
  :: (Traversable f, Ord a, Fractional a)
  => (forall s. Chosen s => f (Or s (On (Forward (Forward a))) (Kahn a)) -> Or s (On (Forward (Forward a))) (Kahn a))
  -> f a -> [f a]
conjugateGradientAscent f x0 = takeWhile (all (\a -> a == a)) (go x0 d0 d0 delta0)
  where
    dot x y = sum $ zipWithT (*) x y
    d0 = Kahn.grad (rfu f) x0
    delta0 = dot d0 d0
    go xi _ri di deltai = xi : go xi1 ri1 di1 deltai1
      where
        ai = last $ take 20 $ Rank1.extremum (\a -> lfu f $ zipWithT (\x d -> auto x + a * auto d) xi di) 0
        xi1 = zipWithT (\x d -> x + ai*d) xi di
        ri1 = Kahn.grad (rfu f) xi1
        deltai1 = dot ri1 ri1
        bi1 = deltai1 / deltai
        di1 = zipWithT (\r d -> r + bi1 * d) ri1 di
{-# INLINE conjugateGradientAscent #-}


module Numeric.GeometricAlgebra.Metric where

import Numeric.LinearAlgebra
import Data.List (transpose)
import Data.Bits (bit, (.&.))
import Data.List (intercalate)

-- | A metric is a list of basis element names, a list of corresponding squares
-- and a transformation Matrix.
data Metric = EuclideanMetric
            | DiagonalMetric [String] [Square]
            | Metric [String] [Square] MetricMatrix
            deriving (Eq)
type Square = Double
type MetricMatrix = [[Double]]

getNames :: Metric -> [String]
getNames EuclideanMetric          = ["e" ++ show n | n <- [1..]]
getNames (DiagonalMetric names _) = names
getNames (Metric names _ _)       = names

-- | Creates a Metric object from a list of basis element names and a list of lists with the metric matrix.
createMetric :: [String] -> [[Double]] -> Metric
createMetric names metricMatrix
  | not $ allEqual dimensions = error "Dimensions do not match.\n\
  \If there are n basis elements, the matrix has to be n by n."
  | not $ symmetric metricMatrix = error "Matrix has to be symmetric."
  | otherwise = Metric names (toList eigvals) (toLists eigvecs)
  where (eigvals, eigvecs) = eigSH $ fromLists metricMatrix
        dimensions = [length names, length metricMatrix]
                      ++ map length metricMatrix

allEqual :: Eq a => [a] -> Bool
allEqual xs = all (== head xs) (tail xs)

symmetric :: MetricMatrix -> Bool
symmetric m = transpose m == m


module Numeric.Layer.Sigmoid where
import Numeric.Layer
import Dependent.Size
import Numeric.Vector.Sized
import qualified Numeric.Vector.Sized as Sized
import GHC.TypeLits(KnownNat,Nat)

newtype Sigmoid (n :: Nat) = Sigmoid ()

instance Show (Sigmoid n) where
  showsPrec d (Sigmoid _) = showString "Sigmoid"

sigmoid :: Floating x => x -> x
sigmoid x = 1 / (1 + exp (-x))

sigmoid' :: Num a => a -> a
sigmoid' y = (1 - y) * y

instance KnownNat n => Layer (Sigmoid n) where
  type Inputs (Sigmoid n) = ZZ ::. n
  type Outputs (Sigmoid n) = ZZ ::. n
  type Tape (Sigmoid n) = SizedArray (ZZ ::. n)
  type Gradient (Sigmoid n) = ()
  forward _ x = (y, tape)
    where
      y = Sized.map sigmoid x
      tape = y
  backward _ tape dy = (gradient, dx)
    where
      gradient = ()
      dx = Sized.zipWith (*) dy (Sized.map sigmoid' tape)
  applyGradient layer _ = layer


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
module Numeric.Layer.Affine where

import Dependent.Size
import Numeric.Layer
import Numeric.Vector.Sized
import qualified Numeric.Vector.Sized as Sized
import GHC.TypeLits
import Data.Array.Accelerate.LLVM.Native

data Affine (n :: Nat) (m :: Nat) = Affine (SizedMatrix' n m) (SizedVector' m)
  deriving (Show)

instance (KnownNat n, KnownNat m) => Layer (Affine n m) where
  type Inputs (Affine n m) = ZZ '::. n
  type Outputs (Affine n m) = ZZ '::. m
  type Tape (Affine n m) = SizedArray (ZZ ::. n)
  type Gradient (Affine n m) = Affine n m
  forward (Affine ws b) x = (affine (use ws) (use b) x, x)
  backward (Affine ws b) x dy = (Affine dw db, dx)
    where
      dx = use ws #> dy
      dw = runSized run (dy `outer` x)
      db = runSized run (dy)
  applyGradient (Affine ws b) (Affine dw db)
    = Affine
      (runSized run $ Sized.zipWith (-) (use ws) (use dw))
      (runSized run $ Sized.zipWith (-) (use b) (use db))

affine
  :: (KnownNat n, KnownNat m)
  => SizedMatrix n m
  -> SizedVector m
  -> SizedVector n
  -> SizedVector m
affine ws b x = (x <# ws) .+. b

-- affine_dw dedy = dedw
-- affine_db dedy = dedb
-- affine_dx dedy = dedx


-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Random.Distribution.MultivariateNormal
-- Copyright   :  (c) 2016 FP Complete Corporation
-- License     :  MIT (see LICENSE)
-- Maintainer  :  dominic@steinitz.org
--
-- Sample from the multivariate normal distribution with a given
-- vector-valued \(\mu\) and covariance matrix \(\Sigma\). For example,
-- the chart below shows samples from the bivariate normal
-- distribution.
--
-- <<diagrams/src_Data_Random_Distribution_MultivariateNormal_diagM.svg#diagram=diagM&height=600&width=500>>
--
-- Example code to generate the chart:
--
-- > import qualified Graphics.Rendering.Chart as C
-- > import Graphics.Rendering.Chart.Backend.Diagrams
-- >
-- > import Data.Random.Distribution.MultivariateNormal
-- >
-- > import qualified Data.Random as R
-- > import Data.Random.Source.PureMT
-- > import Control.Monad.State
-- > import qualified Numeric.LinearAlgebra.HMatrix as LA
-- >
-- > nSamples :: Int
-- > nSamples = 10000
-- >
-- > sigma1, sigma2, rho :: Double
-- > sigma1 = 3.0
-- > sigma2 = 1.0
-- > rho = 0.5
-- >
-- > singleSample :: R.RVarT (State PureMT) (LA.Vector Double)
-- > singleSample = R.sample $ Normal (LA.fromList [0.0, 0.0])
-- >                (LA.sym $ (2 LA.>< 2) [ sigma1, rho * sigma1 * sigma2
-- >                                      , rho * sigma1 * sigma2, sigma2])
-- >
-- > multiSamples :: [LA.Vector Double]
-- > multiSamples = evalState (replicateM nSamples $ R.sample singleSample) (pureMT 3)
-- > pts = map (f . LA.toList) multiSamples
-- >   where
-- >     f [x, y] = (x, y)
-- >     f _      = error "Only pairs for this chart"
-- >
-- >
-- > chartPoint pointVals n = C.toRenderable layout
-- >   where
-- >
-- >     fitted = C.plot_points_values .~ pointVals
-- >               $ C.plot_points_style  . C.point_color .~ opaque red
-- >               $ C.plot_points_title .~ "Sample"
-- >               $ def
-- >
-- >     layout = C.layout_title .~ "Sampling Bivariate Normal (" ++ (show n) ++ " samples)"
-- >            $ C.layout_y_axis . C.laxis_generate .~ C.scaledAxis def (-3,3)
-- >            $ C.layout_x_axis . C.laxis_generate .~ C.scaledAxis def (-3,3)
-- >
-- >            $ C.layout_plots .~ [C.toPlot fitted]
-- >            $ def
-- >
-- > diagM = do
-- >   denv <- defaultEnv C.vectorAlignmentFns 600 500
-- >   return $ fst $ runBackend denv (C.render (chartPoint pts nSamples) (500, 500))
--
-----------------------------------------------------------------------------

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

module Data.Random.Distribution.MultivariateNormal
    ( Normal(..)
    ) where

import           Data.Random.Distribution
import qualified Numeric.LinearAlgebra.HMatrix as H
import           Control.Monad
import qualified Data.Random as R
import           Foreign.Storable ( Storable )
import           Data.Maybe ( fromJust )

normalMultivariate :: H.Vector Double -> H.Herm Double -> R.RVarT m (H.Vector Double)
normalMultivariate mu bigSigma = do
  z <- replicateM (H.size mu) (rvarT R.StdNormal)
  return $ mu + bigA H.#> (H.fromList z)
  where
    (vals, bigU) = H.eigSH bigSigma
    lSqrt = H.diag $ H.cmap sqrt vals
    bigA = bigU H.<> lSqrt

data family Normal k :: *

data instance Normal (H.Vector Double) = Normal (H.Vector Double) (H.Herm Double)

instance Distribution Normal (H.Vector Double) where
  rvar (Normal m s) = normalMultivariate m s

normalPdf :: (H.Numeric a, H.Field a, H.Indexable (H.Vector a) a, Num (H.Vector a)) =>
             H.Vector a -> H.Herm a -> H.Vector a -> a
normalPdf mu sigma x = exp $ normalLogPdf mu sigma x

normalLogPdf :: (H.Numeric a, H.Field a, H.Indexable (H.Vector a) a, Num (H.Vector a)) =>
                 H.Vector a -> H.Herm a -> H.Vector a -> a
normalLogPdf mu bigSigma x = - H.sumElements (H.cmap log (diagonals dec))
                              - 0.5 * (fromIntegral (H.size mu)) * log (2 * pi)
                              - 0.5 * s
  where
    dec = fromJust $ H.mbChol bigSigma
    t = fromJust $ H.linearSolve (H.tr dec) (H.asColumn $ x - mu)
    u = H.cmap (\v -> v * v) t
    s = H.sumElements u

diagonals :: (Storable a, H.Element t, H.Indexable (H.Vector t) a) =>
             H.Matrix t -> H.Vector a
diagonals m = H.fromList (map (\i -> m H.! i H.! i) [0..n-1])
  where
    n = max (H.rows m) (H.cols m)

instance PDF Normal (H.Vector Double) where
  pdf (Normal m s) = normalPdf m s
  logPdf (Normal m s) = normalLogPdf m s


-- ch03 example 3.7

import Statistics.Distribution
import Statistics.Distribution.Binomial

b :: BinomialDistribution
b = binomial 5 0.05

main = do
  putStrLn $ "If 5 samples is tested, the probabiliy of observing at least one defective: "
          ++ show (1 - probability b 0)


module Fractals
( order
, floatOrder
, mandelbrot
, bmp
, tangentPoint
, mandelbrotCardioid
, mag2
, toBitmap
) where

import Data.Complex (Complex(..), mkPolar)
import Graphics.Gloss
import qualified Data.ByteString as B
import Data.Word
import Control.Parallel.Strategies

import Palette

mag2:: Complex Double -> Double
mag2 (a:+b) = a^(2::Int) + b^(2::Int)

-- | Compute the order of a given complex function.
order :: (Complex Double -> Complex Double) -- ^ a function on the complex plane
      -> Double                             -- ^ the escape radius squared
      -> Int                                -- ^ the maximum order
      -> Complex Double                     -- ^ a starting point
      -> (Int, Complex Double)              -- ^ the order
order f radius2 nMax z0 = let f' = \ (i, z) -> (i+1, f z)
                              fs = dropWhile (\ (i, z) -> i<nMax && mag2 z < radius2) $ iterate f' (0, z0)
                           in head fs

-- | Compute the floating order of a given complex function.
floatOrder :: (Complex Double -> Complex Double) -- ^ a function on the complex plane
           -> Double                             -- ^ the escape radius squared
           -> Int                                -- ^ the maximum order
           -> Complex Double                     -- ^ a starting point
           -> Double                             -- ^ the order
floatOrder f radius2 nMax z0 = let (nu, z) = order f radius2 nMax z0
                                in fromIntegral nu - log (0.5 * (log $ mag2 z)) / log 2.0

-- | the Mandelbrot function: z^2 + c.
mandelbrot :: Complex Double -- ^ the c parameter
           -> Complex Double -- ^ the z variable
           -> Complex Double -- ^ the resulting value
mandelbrot (cr:+ci) (zr:+zi) = (cr + zr^(2::Int) - zi^(2::Int)) :+ (ci + 2*zr*zi)
--mandelbrot c z = z**2 + c

-- | Yield the point tangent to the main cardioid and to the bulb with period q
--   and combinatorial rotation number r=p/q.
tangentPoint :: Rational -> Complex Double
tangentPoint r = mandelbrotCardioid $ mkPolar 1.0 (2.0 * pi * fromRational r)

-- | The equation of the main cardioid.
mandelbrotCardioid :: Complex Double -> Complex Double
mandelbrotCardioid mu = 0.5 * mu * (1.0 - 0.5 * mu)

bitmapFormat :: BitmapFormat
bitmapFormat = BitmapFormat BottomToTop PxRGBA

escapeRadius2 :: Double
escapeRadius2 = 100000.0

maxIter :: Int
maxIter = 255

bmpValues :: Int -> Int -> Double -> Double -> Double -> [Double]
bmpValues w h xc yc picScale =
    let wf = fromIntegral w * picScale
        hf = fromIntegral h * picScale
        floatOrderFromIJ :: (Int, Int) -> Double
        floatOrderFromIJ (i,j) = let x0 = xc - 0.5*wf + (fromIntegral j)*wf/(fromIntegral (w-1))
                                     y0 = yc - 0.5*hf + (fromIntegral i)*hf/(fromIntegral (h-1))
                                     z0 = x0 :+ y0
                                  in floatOrder (mandelbrot z0) escapeRadius2 maxIter z0
        indices = (,) <$> [0..h-1] <*> [0..w-1]
        vals = map floatOrderFromIJ indices
     in vals `using` parListChunk h rseq

toBitmap :: Palette -> [Double] -> [Word8]
toBitmap _ [] = []
toBitmap palette l = let maxL = maximum l
                         toBitmap' _ [] = []
                         toBitmap' maxX (x:xs) = let (r,g,b) = palette (x/maxX)
                                                     in r:g:b:255:(toBitmap' maxX xs)
                      in toBitmap' maxL l

bmpByteString :: Int -> Int -> Double -> Double -> Double -> B.ByteString
bmpByteString w h xc yc picScale = B.pack vals
    where vals = toBitmap hsv $ bmpValues w h xc yc picScale

bmp :: Int -> Int -> Complex Double -> Double -> Picture
bmp w h (xc :+ yc) picScale = bitmapOfByteString w h bitmapFormat (bmpByteString w h xc yc picScale) False


{-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables, FlexibleContexts, TypeFamilies #-}

module Math.Probably.PCA where

import Numeric.LinearAlgebra
import Numeric.LinearAlgebra.Data
import Numeric.LinearAlgebra.HMatrix ((#>))
import Math.Probably.FoldingStats
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Storable as VS
import Foreign.Storable.Tuple ()
import Control.Spoon
import qualified Data.Map.Strict as M
import           Data.Maybe (fromJust)
import           Data.List
import           Data.Ord
import           Data.Number.Erf
import Debug.Trace

empiricalCovariance :: [Vector Double] -> Matrix Double
empiricalCovariance xs
   = let k = length xs
         --barxk = L.scale (recip $ realToFrac $ k+1) $ sum xs
         --m1 = sum $ map (\xv-> L.outer xv xv) xs
         --m2 = L.scale (realToFrac $ k+1) $ L.outer barxk barxk
         xmn = empiricalMean xs
         f xi = outerSame $ xi - xmn
--     in L.scale (recip $ realToFrac k) $ m1 - m2
     in scale (recip $ realToFrac k - 1 ) $ sum $ map f xs

empiricalCovariance' :: Vector Double -> [Vector Double] -> Matrix Double
empiricalCovariance' xmn xs
   = let k = length xs
         --barxk = L.scale (recip $ realToFrac $ k+1) $ sum xs
         --m1 = sum $ map (\xv-> L.outer xv xv) xs
         --m2 = L.scale (realToFrac $ k+1) $ L.outer barxk barxk
         f xi = outerSame $ xi - xmn
--     in L.scale (recip $ realToFrac k) $ m1 - m2
     in scale (recip $ realToFrac k - 1 ) $ sumWith f xs

outerSame v = outer v v

--sumWithVs :: (Vector Double -> Vector Double) -> [Vector Double] -> Vector Double
--sumWithVs f = foldl1' (\acc v -> acc + f v)

sumWith :: Num a => (Vector Double -> a) -> [Vector Double] -> a
sumWith f (v:vs) = foldl' (\acc v -> acc + f v) (f v) vs

empiricalMean :: [Vector Double] -> Vector Double
empiricalMean vecs = scale (recip $ realToFrac $ length vecs) $ sumWith id vecs

-- copied from https://github.com/albertoruiz/hmatrix/blob/master/examples/pca2.hs

type Vec = Vector Double
type Mat = Matrix Double

-- Vector with the mean value of the columns of a matrix
mean :: Mat -> Vec
mean a = constant (recip . fromIntegral . rows $ a) (rows a) <> a

-- covariance matrix of a list of observations stored as rows
cov :: Mat -> Mat
cov x = (trans xc <> xc) / fromIntegral (rows x - 1)
    where xc = x - asRow (mean x)

covN :: Mat -> Mat
covN x = (trans x <> x) / fromIntegral (rows x)

cov0 :: Mat -> Mat
cov0 x = (trans x <> x) / fromIntegral (rows x - 1)
    --where xc = x - asRow (mean x)

type Stat = (Vec, [Double], Mat)
-- 1st and 2nd order statistics of a dataset (mean, eigenvalues and eigenvectors of cov)
stat :: Mat -> Stat
stat x = (m, toList s, trans v) where
    m = mean x
    (s,v) = eigSH' (cov x)

stat0 :: Mat -> Stat
stat0 x = (m, toList s, trans v) where
    m = VS.map (const 0) s
    c = cov0 x
    (s,v) = eigSH' $ trace ("cov00="++(show (c!0!0))) $ c

statSVD :: Mat -> Stat
statSVD x = (m, [], evecs) where
    m = mean x
    c = cov x
    (_, evals, evecCols) = svd c
    evecs = fromRows $ map evecSigns $ toColumns evecCols
    evecSigns ev = let maxelidx = maxIndex $ cmap abs ev
                       sign = signum (ev ! maxelidx)
                   in cmap (sign *) ev

statThinSVD :: Mat -> Stat
statThinSVD x = (m, [], evecs) where
    m = mean x
    c = cov x
    (_, evals, evecCols) = thinSVD c
    evecs = fromRows $ map evecSigns $ toColumns evecCols
    evecSigns ev = let maxelidx = maxIndex $ cmap abs ev
                       sign = signum (ev ! maxelidx)
                   in cmap (sign *) ev

pcaNSVD :: Int -> Stat -> (Vec -> Vec , Vec -> Vec)
pcaNSVD  n (m,_,evecs) = (encode,decode)
  where
    encode x = VS.take n $ evecs #> (x - m)
    decode x = error "not sure right now"

statVs :: [Vector Double] -> Stat
statVs vs = (m, toList s, trans v) where
    m = empiricalMean vs
    (s,v) = eigSH' (empiricalCovariance' m vs)

mbStat :: Mat -> Maybe Stat
mbStat = spoon . stat

pca :: Double -> Stat -> (Vec -> Vec , Vec -> Vec)
pca prec (m,s,v) = (encode,decode)
  where
    encode x = vp <> (x - m)
    decode x = x <> vp + m
    vp = takeRows n v
    n = 1 + (length $ fst $ span (< (prec'*sum s)) $ cumSum s)
    cumSum = tail . scanl (+) 0.0
    prec' = if prec <=0.0 || prec >= 1.0
                then error "the precision in pca must be 0<prec<1"
                else prec

pcaN :: Int -> Stat -> (Vec -> Vec , Vec -> Vec)
pcaN n (m,s,v) = (encode,decode)
  where
    encode x = vp <> (x - m)
    decode x = x <> vp + m
    vp = takeRows n v

type Lens a b = ( (a->b), (a-> b -> a) )

get :: Lens a b -> a -> b
get (f,_) x = f x

set :: Lens a b -> a -> b -> a
set (_,f) x y = f x y

idlens :: Lens a a
idlens = (id,  (\_ x -> x))

--, pcaFeatures
normaliseBy :: (Eq b, Ord b) => Lens a Vec -> Lens a b -> Int -> [a] -> [a]
normaliseBy veclens idlens ncomponents = equaliseVars veclens
                                         . rankTransform veclens idlens
                                         . pcaFeatures veclens ncomponents
                                         . equaliseVars veclens

normaliseNoRank :: Lens a Vec -> Int -> [a] -> [a]
normaliseNoRank veclens  ncomponents = equaliseVars veclens
                                         . pcaFeatures veclens ncomponents
                                         . equaliseVars veclens

equaliseVars ::Lens a Vec -> [a] -> [a]
equaliseVars veclens xs = equal_vars where
  decorr_vars :: VS.Vector (Double,Double)
  decorr_vars = uncurry (VS.zipWith (,)) $ runStat meanSDF $ map (get veclens) xs

  equal_vars =  map (\x -> set veclens x (g $ get veclens x)) xs

  g :: Vec -> Vec
  g fl = VS.zipWith (\x (mn,sd) -> (x-mn)/sd) fl decorr_vars

vecMeanSds :: [Vector Double] -> Vector (Double, Double)
vecMeanSds xs = uncurry (VS.zipWith (,)) $ runStat meanSDF  xs

vecMeans :: [Vector Double] -> Vector Double
vecMeans xs = scale (recip $ realToFrac $ length xs) $ sumWith id xs

rankTransform :: (Eq b, Ord b) => Lens a Vec -> Lens a b -> [a] -> [a]
rankTransform veclens idlens nmfeatures = rankTransformed where
  nfeatures = VS.length $ get veclens $ head $ nmfeatures
  nposters = realToFrac $ length nmfeatures
  sortations = flip map [0..(nfeatures-1)] $ \ix -> toRankMap $ map (get idlens) $ sortBy (comparing ((VS.! ix) . get veclens)) nmfeatures -- decorrelated
  rankTransformed = flip map nmfeatures $ \x ->
                      let nm = get idlens x
                          f sortation = invnormcdf $ realToFrac ((getRank sortation nm)+1) / (nposters+1)
                          newv =  VS.fromList $ map f sortations
                      in set veclens x newv

pcaFeatures :: Lens a Vec -> Int -> [a] -> [a]
pcaFeatures veclens ncomp nmfeatures = pca'd where
  input_data = map (get veclens ) nmfeatures
  pcaStats@(_,eigVals,_) = stat $ fromRows input_data
  (enc,_) = trace ("eigenVals ="++show eigVals ) $ pcaN ncomp pcaStats
--  pca_red = PCA.pcaReduceN input_data 5
  setFeatures x =
      let oldv = get veclens x
          newNormV = enc oldv
      in set veclens x newNormV
  pca'd = map setFeatures nmfeatures

type RankMap a = M.Map a Int

toRankMap :: (Ord a, Eq a) => [a] -> RankMap a
toRankMap = M.fromList . (`zip` [0..])

getRank :: (Ord a, Eq a) => RankMap a -> a -> Int
getRank m x = fromJust $ M.lookup x m

newtype NumUV a = NumUV { unNumUV :: U.Vector a } deriving (Eq, Ord)

numUmap f = NumUV . U.map f . unNumUV
numUlength = U.length . unNumUV

instance (U.Unbox a, Num a) => Num (NumUV a) where
    (+) = binvop (+)
    (-) = binvop (-)
    (*) = binvop (*)
    abs = numUmap abs
    signum = numUmap signum
    fromInteger x = NumUV $ U.fromList [fromInteger x]

instance (U.Unbox a, Fractional a) => Fractional (NumUV a) where
    (/) = binvop (/)
    fromRational x = NumUV $ U.fromList [fromRational x]
instance (U.Unbox a, Floating a) => Floating (NumUV a) where
    pi = NumUV $ U.fromList [pi]
    sqrt = numUmap sqrt
    log = numUmap log
    exp = numUmap exp
    sin = numUmap sin
    cos = numUmap cos
    tan = numUmap tan
    asin = numUmap asin
    acos = numUmap acos
    atan = numUmap atan
    sinh = numUmap sinh
    cosh = numUmap cosh
    tanh = numUmap tanh
    asinh = numUmap asinh
    acosh = numUmap acosh
    atanh = numUmap atanh

binvop f xs ys
  | numUlength ys == 1 = let y = (unNumUV ys) U.! 0 in numUmap (\x-> f x y) xs
  | numUlength xs == 1 = let x = (unNumUV xs) U.! 0 in numUmap (\y-> f x y) ys
  | otherwise = NumUV $ U.zipWith f (unNumUV xs) (unNumUV ys)


module Main where

import Test.Hspec
import Data.Word
import Data.Complex
import Data.Vector.Storable (Vector)
import Data.Vector.Storable as SV
import Codec.Picture
import Data.Monoid
import Control.Monad.State
import Numeric.LinearAlgebra hiding ((<>))
import Test.Hspec.QuickCheck
import Test.QuickCheck.Property
import Test.QuickCheck

import FFT
import ArrayPoking
import RealMain
import Algoritmo

main :: IO ()
main = hspec $ do
  describe "FFT" $ do
    it "Valor conocido de FFT" $
      fft ex_vec1 `shouldBe` SV.fromList [2, 4 :+ 4, -6, 4 :+ (-4)]

    it "ifft . fft = id" $
      ifft (fft ex_vec1) `shouldBe` ex_vec1

  describe "array poking" $ do
    it "Separa inicio" $ do
      lena_img <- loadImage lena_path
      let red   = extractColor 0 lena_img
          green = extractColor 1 lena_img
          blue  = extractColor 2 lena_img
      SV.take 3 (imageData lena_img) `shouldBe`
        (SV.take 1 red <> SV.take 1 green <> SV.take 1 blue)

    it "Recombinacion" $ do
      lena_img <- loadImage lena_path
      let red   = extractColor 0 lena_img
          green = extractColor 1 lena_img
          blue  = extractColor 2 lena_img
      imageData lena_img `shouldBe` combineColors red green blue

    it "Recombinando %error" $ do
      -- lena_img@(Image width height _) <- loadImage lena_path
      let alt = SV.fromList [4, 2, 3, 7, 10, 8, 10, 14]
          res = evalState (secAnalitica 2 alt >> secSintetica 2) []
      norm_2 (res - alt) / norm_2 alt < 0.1 `shouldBe` True

  -- prop "Recombinando %error" $
  --     -- lena_img@(Image width height _) <- loadImage lena_path
  --     let res alt = evalState (secAnalitica 4 alt >> secSintetica) []
  --         -- alt = SV.fromList [4, 2, 3, 7, 10, 8, 10, 14, 40, 22, 90, 33, 11, 34, 38, 50]
  --     in  (forAll (fmap SV.fromList arbitrary)
  --         (\a -> norm_2 (res a - a) / norm_2 a < 0.01))

  -- describe "Pruebas en Lena"
  --   it "Recombinacion Lena" $ do
  --     lena_img <- loadImage lena_path
  --     let red   = extractColor 0 lena_img
  --         green = extractColor 1 lena_img
  --         blue  = extractColor 2 lena_img
  --         go color = evalState (secAnalitica color >>= secSintetica)
  --                              (VS.length color)
  --     imageData lena_img `shouldBe` combineColors red green blue

{- Ejemplo libro pagina 126 -}
ex_vec1 :: Vector (Complex Double)
ex_vec1 = SV.fromList [ 1, 0, -3, 4]


module Rotation where

import Control.Monad
import Numeric.LinearAlgebra ((<>), (#>), Z, Vector, Matrix)
import qualified Numeric.LinearAlgebra as LA
import qualified Data.List as List
import qualified Data.Maybe as Maybe

import Cube (Cube, cubeToVector, vectorToCube)
import qualified Cube as Cube

type CubeRotation = Cube -> Cube

toCubeRotation :: VectorRotation -> CubeRotation
toCubeRotation rotation = vectorToCube . rotation . cubeToVector

type VectorRotation = Vector Z -> Vector Z

toVectorRotation :: MatrixRotation -> VectorRotation
toVectorRotation = (#>)

rotate :: MatrixRotation -> Cube -> Cube
rotate rotation = toCubeRotation $ toVectorRotation rotation

type MatrixRotation = Matrix Z

showMatrixRotation :: MatrixRotation -> String
showMatrixRotation = show . fmap (go 0 . LA.toList) . LA.toColumns
  where
    go i [] = i
    go i (v:vs)
      | v == 1 = i
      | otherwise = go (i + 1) vs

identity :: MatrixRotation
identity = LA.ident $ 9 * 6

topToFront :: MatrixRotation
topToFront =
  let vs = LA.toColumns identity
      mapping = [  9, 10, 11, 12, 13, 14, 15, 16, 17
                , 45, 46, 47, 48, 49, 50, 51, 52, 53
                , 24, 21, 18, 25, 22, 19, 26, 23, 20
                ,  8,  7,  6,  5,  4,  3,  2,  1,  0
                , 38, 41, 44, 37, 40, 43, 36, 39, 42
                , 35, 34, 33, 32, 31, 30, 29, 28, 27 ]
  in LA.fromColumns $ fmap (vs !!) mapping

topToBack :: MatrixRotation
topToBack = topToFront <> topToFront <> topToFront

topToRight :: MatrixRotation
topToRight =
  let vs = LA.toColumns identity
      mapping = [ 20, 23, 26, 19, 22, 25, 18, 21, 24
                , 11, 14, 17, 10, 13, 16,  9, 12, 15
                , 47, 50, 53, 46, 49, 52, 45, 48, 51
                , 33, 30, 27, 34, 31, 28, 35, 32, 29
                ,  2,  5,  8,  1,  4,  7,  0,  3,  6
                , 38, 41, 44, 37, 40, 43, 36, 39, 42 ]
  in LA.fromColumns $ fmap (vs !!) mapping

topToLeft :: MatrixRotation
topToLeft = topToRight <> topToRight <> topToRight

topTwistRight :: MatrixRotation
topTwistRight = topToBack <> topToRight <> topToFront

topTwistLeft :: MatrixRotation
topTwistLeft = topTwistRight <> topTwistRight <> topTwistRight

rightL :: MatrixRotation
rightL =
  let vs = LA.toColumns identity
      mapping = [  0,  1, 11,  3,  4, 14,  6,  7, 17
                ,  9, 10, 47, 12, 13, 50, 15, 16, 53
                , 24, 21, 18, 25, 22, 19, 26, 23, 20
                ,  8, 28, 29,  5, 31, 32,  2, 34, 35
                , 36, 37, 38, 39, 40, 41, 42, 43, 44
                , 45, 46, 33, 48, 49, 30, 51, 52, 27 ]
  in LA.fromColumns $ fmap (vs !!) mapping

rightR :: MatrixRotation
rightR = rightL <> rightL <> rightL

leftL :: MatrixRotation
leftL =
  let twist = topTwistRight <> topTwistRight
  in twist <> rightL <> twist

leftR :: MatrixRotation
leftR = leftL <> leftL <> leftL

topL :: MatrixRotation
topL = topToLeft <> rightL <> topToRight

topR :: MatrixRotation
topR = topL <> topL <> topL

bottomL :: MatrixRotation
bottomL =
  let twist = topToRight <> topToRight
  in twist <> topL <> twist

bottomR :: MatrixRotation
bottomR = bottomL <> bottomL <> bottomL

frontL :: MatrixRotation
frontL = topTwistRight <> rightL <> topTwistLeft

frontR :: MatrixRotation
frontR = frontL <> frontL <> frontL

backL :: MatrixRotation
backL =
  let twist = topTwistLeft <> topTwistLeft
  in twist <> frontL <> twist

backR :: MatrixRotation
backR = backL <> backL <> backL

rotations :: [(MatrixRotation, String)]
rotations = [
    (identity, "identity")
  , (topToFront, "topToFront")
  , (topToBack, "topToBack")
  , (topToRight, "topToRight")
  , (topToLeft, "topToLeft")
  , (topTwistRight, "topTwistRight")
  , (topTwistLeft, "topTwistLeft")
  , (rightL, "rightL")
  , (rightR, "rightR")
  , (leftL, "leftL")
  , (leftR, "leftR")
  , (topL, "topL")
  , (topR, "topR")
  , (bottomL, "bottomL")
  , (bottomR, "bottomR")
  , (frontL, "frontL")
  , (frontR, "frontR")
  , (backL, "backL")
  , (backR, "backR")
  ]

nameMatrixRotation :: MatrixRotation -> String
nameMatrixRotation = Maybe.fromMaybe "unknown" . flip List.lookup rotations

inverse :: MatrixRotation -> Maybe MatrixRotation
inverse r = Maybe.listToMaybe $ do
  r' <- map fst rotations
  guard $ r <> r' == identity
  return r'


module Clash.DSP.FFT.Twiddle (
    twiddleFactors,
    halveTwiddles
) where

import Clash.Prelude
import qualified Data.Complex as C
import qualified Prelude as P
import Clash.DSP.Complex

-- | Calculate FFT `twiddle` factors. You probably want to do this with template Haskell to ensure they are calculated at compile time.
twiddleFactors
    :: Int              -- ^ Twiddle factor vector length
    -> [Complex Double] -- ^ Twiddle factors
twiddleFactors num = P.take num $ [fromComplex $ C.cis $ (-1) * P.pi * fromIntegral i / (fromIntegral num) | i <- [0..]]

-- | Take every second element of a vector of twiddle factors.
halveTwiddles
    :: KnownNat n
    => Vec (2 * n) a -- ^ Twiddle factors
    -> Vec n a       -- ^ Halved output twiddle factors
halveTwiddles vec = transpose (unconcat (SNat  @ 2) vec) !! 0


module Main where

import Math.Probably.EMPCA
import Math.Probably.PCA
import Math.Probably.Datasets

import Data.Random
import System.Environment
import Numeric.LinearAlgebra
import Numeric.LinearAlgebra.Data
import qualified Data.Vector.Storable as VS

main = do
  fnm:_ <- getArgs
  Right plants <- iris fnm
  let plantvs = map (VS.fromList . plantToVector) plants
      basis = stat $ fromRows $ plantvs
      (enc, _) = pcaN 3 basis
      covar = cov $ fromRows $ map enc plantvs
      covarPre = cov $ fromRows $ plantvs
  disp 2 $ covarPre
  disp 2 $ covar
  em <- sample $ emPca 3 10 (Just cinit) plantvs
  let covarEm = cov $ fromRows $ map (applyEmPca em) plantvs
  disp 2 $ covarEm

cinit = (4><3)
        [ 0.6794,    0.0841,    0.6963,
          0.0731,    0.5255,    0.2313,
          0.6621,    0.0939,    0.7125,
          0.5875,    0.4601,    0.0754  ]

--  mapM_ print plants


module Main where

import qualified Numeric.LinearAlgebra as LA
import qualified MachineLearning.Types as T
import qualified MachineLearning as ML
import qualified MachineLearning.Classification.Binary as CB
import qualified MachineLearning.Classification.OneVsAll as OVA
import qualified MachineLearning.TerminalProgress as TP

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

main = do
  putStrLn "\n=== Optical Recognition of Handwritten Digits Data Set ===\n"
  -- Step 1. Data loading.
  -- Step 1.1 Training Data loading.
  (x, y) <- pure ML.splitToXY <*> LA.loadMatrix "digits_classification/optdigits.tra"
  -- Step 1.1 Testing Data loading.
  (xTest, yTest) <- pure ML.splitToXY <*> LA.loadMatrix "digits_classification/optdigits.tes"

  -- Step 2. Outputs and features preprocessing.
  let numLabels = 10
      x1 = processFeatures x
      initialTheta = LA.konst 0 (LA.cols x1)
      initialThetas = replicate numLabels initialTheta
  -- Step 3. Learning.
  (thetas, optPath) <- TP.learnOneVsAllWithProgressBar (CB.learn (OVA.BFGS2 0.01 0.1) 0.001 30 (CB.L2 30) x1) y initialThetas 1

  -- Step 4. Prediction and checking accuracy
  let accuracyTrain = calcAccuracy x1 y thetas
      accuracyTest = calcAccuracy (processFeatures xTest) yTest thetas

  -- Step 5. Printing results.
  putStrLn $ "\nNumber of iterations to learn: " ++ show (map LA.rows optPath)

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


module TransitionMatrix
( makeMatrix
, randomMatrix
, randomMatrixNullDiag
, mkRandomTransitionMatrix
, mkRandomNullDiagTransitionMatrix
, mkBlockTransitionMatrix
, toTransitionMatrix
, toNLMatrix
, fromNLMatrix
, eig
, estimatePAbs
, TransitionMatrix (..)
, TransitionMatrixGenerator (..)
) where

import Data.Matrix
import qualified Data.Vector as V
import System.Random
import Control.Monad (forM)
import qualified Numeric.LinearAlgebra as NL

import MC

newtype TransitionMatrix = TransitionMatrix { toMatrix :: Matrix Double }
                           deriving (Show, Eq)

data TransitionMatrixGenerator =
    RandomMG Int Double |
    RandomNullDiagMG Int Double |
    BlockMG Int Double Double deriving (Eq, Ord, Show)

-- | Produce a transition matrix
makeMatrix :: TransitionMatrixGenerator -- ^ a generator
              -> MC TransitionMatrix    -- ^ a TransitionMatrix, in the MC monad
makeMatrix (RandomMG size absorptionProbability) = mkRandomTransitionMatrix size absorptionProbability
makeMatrix (RandomNullDiagMG size absorptionProbability) = mkRandomNullDiagTransitionMatrix size absorptionProbability
makeMatrix (BlockMG size absorptionProbability coupling) = mkBlockTransitionMatrix size absorptionProbability coupling

{- |
   Produce a random transition matrix
-}
mkRandomTransitionMatrix :: Int           -- ^ the matrix size
                         -> Double        -- ^ the absorption probability
                         -> MC TransitionMatrix
mkRandomTransitionMatrix size pAbs = do
    m <- randomMatrix size
    return $ toTransitionMatrix pAbs m

{- |
   Produce a random transition matrix with null elements on the diagonal
-}
mkRandomNullDiagTransitionMatrix :: Int           -- ^ the matrix size
                                 -> Double        -- ^ the absorption probability
                                 -> MC TransitionMatrix
mkRandomNullDiagTransitionMatrix size pAbs = do
    m <- randomMatrixNullDiag size
    return $ toTransitionMatrix pAbs m

{- |
   Produce a block transition matrix
-}
mkBlockTransitionMatrix :: Int           -- ^ the matrix size
                        -> Double        -- ^ the absorption probability
                        -> Double        -- ^ the coupling
                        -> MC TransitionMatrix
mkBlockTransitionMatrix size pAbs coupling = do
    let blockSize1 = size `div` 2
    let blockSize2 = size - blockSize1
    m1 <- randomMatrix blockSize1
    m4 <- randomMatrix blockSize2
    let fromCoupling = blockSize1 `div` 2
    let toCoupling = blockSize2 `div` 2
    let m2 = zero blockSize2 blockSize1
    let m3 = matrix blockSize1 blockSize2 (\(i,j) -> if j==fromCoupling && i==toCoupling then coupling else 0.0)
    let m = joinBlocks (m1, m2, m3, m4)
    return $ toTransitionMatrix pAbs m

-- | Return a random square matrix of given size, with elements in the [0,1[
--   range
randomMatrix :: Int                 -- ^ size of the matrix
             -> MC (Matrix Double)  -- ^ the matrix, in the MC monad because it's random
randomMatrix n = do
    lss <- forM [0..n-1] $ \ _ -> randomList n
    return $ fromLists lss

-- | Return a random square matrix of given size, with elements in the [0,1[
--   range and null diagonal elements
randomMatrixNullDiag :: Int                 -- ^ size of the matrix
                     -> MC (Matrix Double)  -- ^ the matrix, in the MC monad because it's random
randomMatrixNullDiag n = do
    lss <- forM [0..n-1] $ \ k -> do
        ls <- randomList (n-1)
        let (left, right) = splitAt k ls
        let ls' = left ++ [0.0] ++ right
        return ls'
    return $ fromLists lss

-- | Generate a random list of size n
randomList :: (Random a, Fractional a)
           => Int   -- ^ the list size
           -> MC [a]
randomList 0 = return []
randomList n = do
    x <- uniform
    xs <- randomList (n-1)
    return (x:xs)

--normalizeRow :: Double -> Int -> Matrix Double -> Matrix Double
--normalizeRow norm i m = mapRow (\ _ x -> x*norm/tot) i m
--    where tot = sum $ getRow i m

normalizeCol :: Double -> Int -> Matrix Double -> Matrix Double
normalizeCol norm i m = mapCol (\ _ x -> x*norm/tot) i m
    where tot = sum $ getCol i m

{- |
   Rescale the elements of the given matrix by multiplying by the
   absorption probability
-}
toTransitionMatrix :: Double            -- ^ the absorption probability
                   -> Matrix Double     -- ^ the input matrix
                   -> TransitionMatrix
toTransitionMatrix pAbs m = let nc   = ncols m
                                norm = 1.0 - pAbs
                             in TransitionMatrix $ foldr (normalizeCol norm) m [1..nc]

-- functions for conversion to/from Numeric.LinearAlgebra

toNLMatrix :: NL.Element a => Matrix a -> NL.Matrix a
toNLMatrix = NL.fromLists . toLists

fromNLMatrix :: NL.Element a => NL.Matrix a -> Matrix a
fromNLMatrix = fromLists . NL.toLists

eig :: (NL.Element a, NL.Field a) => Matrix a -> (V.Vector (NL.Complex Double), Matrix (NL.Complex Double))
eig m = let (vnl, mnl) = NL.eig $ toNLMatrix m
            v' = V.fromList $ NL.toList vnl
            m' = fromNLMatrix mnl
         in (v', m')

avg :: (Num a, Fractional a, Foldable t) => t a -> a
avg v = sum v / fromIntegral (length v)

estimatePAbs :: TransitionMatrix -> Double
estimatePAbs (TransitionMatrix m) = 1.0 - fromIntegral (nrows m) * avg (toList m)


module Main where
import           Approx
import           Data.Complex
import           Carlson
import           Elliptic
import           Test.Tasty       (defaultMain, testGroup)
import           Test.Tasty.HUnit (assertEqual, testCase)

i :: Complex Double
i = 0.0 :+ 1.0

main :: IO ()
main = defaultMain $
  testGroup "Tests"
  [ testCase "RF value 1" $
      assertEqual ""
        (approx 12 (carlsonRF 1 2 0))
        (approx 12 1.3110287771461),

    testCase "RF value 2" $
      assertEqual ""
        (approx 12 (carlsonRF i (-i) 0))
        (approx 12 1.8540746773014),

    testCase "RF value 3" $
      assertEqual ""
        (approx 12 (carlsonRF 0.5 1 0))
        (approx 12 1.8540746773014),

    testCase "RF value 4" $
      assertEqual ""
        (approx 13 (carlsonRF (i-1) i 0))
        (approx 13 (0.79612586584234 :+ (-1.2138566698365))),

    testCase "RF value 5" $
      assertEqual ""
        (approx 13 (carlsonRF 2 3 4))
        (approx 13 0.58408284167715),

    testCase "RF value 6" $
      assertEqual ""
        (approx 12 (carlsonRF i (-i) 2))
        (approx 12 1.0441445654064),

    testCase "RF value 7" $
      assertEqual ""
        (approx 13 (carlsonRF (i-1) i (1-i)))
        (approx 13 (0.93912050218619 :+ (-0.53296252018635))),

    testCase "RC value 1" $
      assertEqual ""
        (approx 14 (carlsonRC 0 0.25))
        (approx 14 pi),

    testCase "RC value 2" $
      assertEqual ""
        (approx 14 (carlsonRC 2.25 2))
        (approx 14 (log 2)),

    testCase "RC value 3" $
      assertEqual ""
        (approx 12 (carlsonRC 0 i))
        (approx 12 ((1-i)*1.1107207345396)),

    testCase "RC value 4" $
      assertEqual ""
        (approx 13 (carlsonRC (-i) i))
        (approx 13 (1.2260849569072 :+ (-0.34471136988768))),

    testCase "RC value 5" $
      assertEqual ""
        (approx 14 (carlsonRC 0.25 (-2)))
        (approx 14 ((log 2 :+ (-pi))/ 3)),

    testCase "RC x y = RF x y y" $ do
      let x = 5 :+ 6
          y = 2 :+ (-9)
      assertEqual ""
        (approx 14 (carlsonRC x y))
        (approx 14 (carlsonRF x y y)),

    testCase "RJ x y y p" $ do
      let x = 1 :+ 1
          y = (-2) :+ 3
          p = 0 :+ 4
      assertEqual ""
        (approx 14 (carlsonRJ x y y p))
        (approx 14 (3*(carlsonRC x y - carlsonRC x p) / (p-y))),

    testCase "RJ homogeneity" $ do
      let x = 1 :+ 1
          y = (-2) :+ 3
          z = -3
          p = 0 :+ 4
          kappa = 2 :+ 0
      assertEqual ""
        (approx 14 (carlsonRJ x y z p / kappa / sqrt kappa))
        (approx 14 (carlsonRJ (kappa*x) (kappa*y) (kappa*z) (kappa*p))),

    testCase "Complete elliptic integral K" $ do
      let m = 2 :+ (-3)
      assertEqual ""
        (approx 14 (ellipticF (pi/2) m))
        (approx 14 (carlsonRF 0 (1-m) 1)),

    testCase "Complete ellipticE - RG" $ do
      let m = 2 :+ (-3)
      assertEqual ""
        (approx 14 (ellipticE (pi/2) m))
        (approx 14 (2 * carlsonRG 0 (1-m) 1)),

    testCase "Complete ellipticE - RD" $ do
      let m = 2 :+ (-3)
      assertEqual ""
        (approx 14 (ellipticE (pi/2) m))
        (approx 14 ((1-m) * (carlsonRD 0 (1-m) 1 + carlsonRD 0 1 (1-m)) / 3)),

    testCase "jacobiZeta m=1" $ do
      let z = (-1) :+ 8
      assertEqual ""
        (approx 14 (jacobiZeta z 1))
        (approx 14 (sin z))

  ]


module Trade.Statistics.Algorithm where

import Data.Time.Clock (NominalDiffTime)

import qualified Data.Vector as Vec
import Data.Vector (Vector)

import qualified Statistics.Sample as Stat

import Trade.Type.Equity (Equity(..))
import Trade.Type.Percent (Percent(..))
import Trade.Type.Price (Price(..))

class Statistics a where
  mean :: Vector a -> a
  stdDev :: Vector a -> a
  skewness :: Vector a -> Double
  kurtosis :: Vector a -> Double
  volatility :: Vector a -> Percent

instance Statistics Double where
  mean = Stat.mean
  stdDev = Stat.stdDev
  skewness = Stat.skewness
  kurtosis = Stat.kurtosis

  volatility xs =
    let as = Vec.zipWith (\a b -> log (a/b)) (Vec.tail xs) xs
        s = sqrt (fromIntegral (Vec.length as))
    in Percent (Stat.stdDev as * s)

instance Statistics Price where
  mean = Price . Stat.mean . Vec.map unPrice
  stdDev = Price . Stat.stdDev . Vec.map unPrice
  skewness = Stat.skewness . Vec.map unPrice
  kurtosis = Stat.kurtosis . Vec.map unPrice
  volatility = volatility . Vec.map unPrice

instance Statistics Equity where
  mean = Equity . Stat.mean . Vec.map unEquity
  stdDev = Equity . Stat.stdDev . Vec.map unEquity
  skewness = Stat.skewness . Vec.map unEquity
  kurtosis = Stat.kurtosis . Vec.map unEquity
  volatility = volatility . Vec.map unEquity

instance Statistics NominalDiffTime where
  mean = realToFrac . Stat.mean . Vec.map realToFrac
  stdDev = realToFrac . Stat.stdDev . Vec.map realToFrac
  skewness = Stat.skewness . Vec.map realToFrac
  kurtosis = Stat.kurtosis . Vec.map realToFrac
  volatility = volatility . Vec.map (realToFrac :: NominalDiffTime -> Double)


module FFT.FFTData (
    fftbFlySParZip,
    fftbFlySParZipMap,
    fftMapReduce
) where
import Data.Complex
import FFT.Samples
import System.Environment
import Control.Parallel
import Strategies
import Criterion.Main
import FFT.Orig

-- twiddle factors
tw :: Int -> Int -> Complex Float
tw n k = cis (-2 * pi * fromIntegral k / fromIntegral n)

fftMapReduce :: [Complex Float] -> [Complex Float]
fftMapReduce [a] = [a]
fftMapReduce as = parMapReduceSimple rdeepseq mapper rdeepseq reducer [as]
	where
		mapper = bflyS
		reducer [(cs,ds)] = parinterleave (fftMapReduce cs) (fftMapReduce ds)

fftbFlySParZip :: [Complex Float] -> [Complex Float]
fftbFlySParZip [a] = [a]
fftbFlySParZip as = interleave ls rs
  where
    (cs,ds) = bflySParZip as
    ls = fft cs
    rs = fft ds

fftbFlySParZipMap :: [Complex Float] -> [Complex Float]
fftbFlySParZipMap [a] = [a]
fftbFlySParZipMap as = interleave ls rs
  where
    (cs,ds) = bflySParZipMap as
    ls = fft cs
    rs = fft ds

parinterleave [] bs = bs
parinterleave (a:as) bs = a `par` a : interleave bs as

interleave [] bs = bs
interleave (a:as) bs = a : interleave bs as

bflyS :: [Complex Float] -> ([Complex Float], [Complex Float])
bflyS as = (los,rts)
  where
    (ls,rs) = halve as
    los = zipWith (+) ls rs
    ros = zipWith (-) ls rs

    -- rts = parzipwith (*) ros (parmap (\i -> tw (length (as)) i) [0..(length ros) - 1])
    -- rts = zipWith (*) ros (parmap (\i -> tw (length (as)) i) [0..(length ros) - 1])
    -- rts = parzipwith (*) ros [tw (length as) i | i <- [0..(length ros) - 1]]
    rts = zipWith (*) ros [tw (length as) i | i <- [0..(length ros) - 1]]

bflySParZip as = (los, rts)
    where
        (ls,rs) = halve as
        los = parzipwith (+) ls rs
        ros = parzipwith (-) ls rs
        rts = parzipwith (*) ros [tw (length as) i | i <- [0..(length ros) - 1]]

bflySParZipMap as = (los, rts)
    where
        (ls,rs) = halve as
        los = parzipwith (+) ls rs
        ros = parzipwith (-) ls rs
        rts = parzipwith (*) ros (parmap (\i -> tw (length (as)) i) [0..(length ros) - 1])

halve as = splitAt n' as
  where
    n' = div (length as + 1) 2


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE LambdaCase #-}

module LinearAlgebra (linearAlgebraTest) where

import Test.QuickCheck
import Test.Tasty.QuickCheck

import Test.Tasty

import System.Exit

import Numeric.LinearAlgebra (rank)
import qualified Numeric.LinearAlgebra.Data as Matrix

import Math.Tensor.Internal.LinearAlgebra (independentColumns, independentColumnsMat)

data SmallInt = S0 | S1 deriving (Show, Ord, Eq, Enum, Bounded)

toSmall :: Int -> SmallInt
toSmall 0 = S0
toSmall 1 = S1
toSmall i = error $ "cannot convert " ++ show i ++ " to SmallInt"

fromSmall :: Num a => SmallInt -> a
fromSmall S0 = 0
fromSmall S1 = 1

instance Arbitrary SmallInt where
    arbitrary = arbitraryBoundedEnum

data MatrixData a = MatrixData (Positive Int) (Positive Int) [a] deriving Show

instance Arbitrary a => Arbitrary (MatrixData a) where
    arbitrary = do
      m@(Positive m') <- arbitrary
      n@(Positive n') <- arbitrary
      xs <- vector (m'*n')
      return $ MatrixData m n xs

prop_smallValues :: MatrixData SmallInt -> Bool
prop_smallValues (MatrixData (Positive rows) (Positive cols) xs) =
    rank mat' == rank mat
  where
    mat  = (rows Matrix.>< cols) $ map fromSmall xs
    mat' = independentColumnsMat mat

prop_ints :: MatrixData Int -> Bool
prop_ints (MatrixData (Positive rows) (Positive cols) xs) =
    rank mat' == rank mat
  where
    mat  = (rows Matrix.>< cols) $ map fromIntegral xs
    mat' = independentColumnsMat mat

prop_doubles :: MatrixData Double -> Bool
prop_doubles (MatrixData (Positive rows) (Positive cols) xs) =
    rank mat' == rank mat
  where
    mat  = (rows Matrix.>< cols) xs
    mat' = independentColumnsMat mat

prop_consec :: Positive Int -> Int -> Bool
prop_consec (Positive dim') start =
    independentColumns mat == [0,1]
  where
    dim = dim' + 100
    mat = (dim Matrix.>< dim) $ map fromIntegral [start..]

testCase1 = testProperty "prop_smallValues" prop_smallValues
testCase2 = testProperty "prop_ints" prop_ints
testCase3 = testProperty "prop_doubles" prop_doubles
testCase4 = testProperty "prop_consec" prop_consec

linearAlgebraTest = testGroup "LinearAlgebraTest" [testCase1, testCase2, testCase3, testCase4]


module SimpleNet where

import System.Random
import Numeric.LinearAlgebra

import NeuralNetwork

newtype SimpleNet = SimpleNet { unSimpleNet :: Matrix R }
  deriving (Eq, Show)

makeRandomNet :: Int -> Int -> IO SimpleNet
makeRandomNet rows cols = SimpleNet <$> rand rows cols

-- |
-- >>> net = SimpleNet $ (2 >< 3) [0.47355232, 0.99773930, 0.84668094, 0.85557411, 0.03563661, 0.69422093]
-- >>> x = vector [0.6, 0.9]
-- >>> predict net x
-- [1.054148091,0.630716529,1.132807401]
predict :: SimpleNet -> Vector R -> Vector R
predict (SimpleNet w) x = x <# w

-- |
-- >>> net = SimpleNet $ (2 >< 3) [0.47355232, 0.99773930, 0.84668094, 0.85557411, 0.03563661, 0.69422093]
-- >>> x = vector [0.6, 0.9]
-- >>> t = vector [0, 0, 1]
-- >>> loss net x t
-- 9.746346258628767
loss :: SimpleNet -> Vector R -> Vector R -> Double
loss net@(SimpleNet w) x t = crossEntropyError y t
  where
    z = predict net x
    y = softmax z


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

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

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

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

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

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

main :: IO ()
main = do
  [i',j',size',res',n',filename] <- getArgs
  let res    = read res'     :: Int
      n      = read n'       :: Int
      size   = read size'    :: Double
      i      = read i'       :: Double
      j      = read j'       :: Double
      centre = i :+ j
      cs' = genMandelbrot res n size centre
  cs <- computeP cs' :: IO (Array U DIM2 (Word8,Word8,Word8))
  writeImageToBMP filename cs


-- | Planning by Dynamic Programming (Matrix Version)

module PlanningM where

import           Data.Map                      (Map)
import qualified Data.Map                      as M
import qualified Data.Set                      as S
import           Numeric.LinearAlgebra.Data    (Matrix, Vector, (!))
import           Numeric.LinearAlgebra.HMatrix as H

import           MDP
import           Planning

data MDPM s a = MDPM
    { statesm     :: Map s Int
    , actionsm    :: Map a Int
    , transitionm :: Matrix Double -- matrix S x S
    , rewardm     :: Vector Double     -- vector 1 x S
    , gammam      :: Double             -- discount
    , sizeStates  :: Int           -- S
    , sizeActions :: Int          -- A
    }

type PolicyM = Matrix Double

policyEvaluationM :: (Ord s, Ord a) => MDP s a -> ValueFunction s a
policyEvaluationM mdp policy k s =
    matrixPolicyEvaluation mdpm k ! (M.!) (statesm mdpm) s
  where
    mdpm = prepareMDP mdp (preparePolicy mdp policy)

preparePolicy :: MDP s a -> Policy s a -> PolicyM
preparePolicy mdp policy = H.fromLists (
  map (
    \s -> map (policy s) (S.toList (actions mdp)))
  (S.toList (states mdp)))

prepareMDP :: (Ord s, Ord a) => MDP s a -> PolicyM -> MDPM s a
prepareMDP mdp policy =
    MDPM
    { statesm = statesM
    , actionsm = actionsM
    , transitionm = transitionM
    , rewardm = rewardM
    , gammam = gamma mdp
    , sizeStates = S.size (states mdp)
    , sizeActions = S.size (actions mdp)
    }
  where
    statesM = M.fromList (zip (S.toList (states mdp)) [0 ..])
    actionsM = M.fromList (zip (S.toList (actions mdp)) [0 ..])
    transitionM =
        H.fromRows
            (map
                 (\s ->
                       takeDiag (policy H.<> (transitionMap M.! s)))
                 (S.toList (states mdp)))
    transitionMap =
        M.fromList
            (map
                 (\s ->
                       (s, createMatrix s))
                 (S.toList (states mdp)))
    createMatrix s' =
        H.fromLists
            (map
                 (\a ->
                       map
                           (\s ->
                                 transition mdp a s s')
                           (S.toList (states mdp)))
                 (S.toList (actions mdp)))
    rewardM = takeDiag (policy H.<> createRewardMatrix)
    createRewardMatrix =
        H.fromLists
            (map
                 (\a ->
                       map
                           (
                                 reward mdp a)
                           (S.toList (states mdp)))
                 (S.toList (actions mdp)))

matrixPolicyEvaluation :: MDPM s a -> Int -> Vector Double
matrixPolicyEvaluation mdpm = evalVF (konst 0.0 (sizeStates mdpm))
  where
    evalVF v 0 = v
    evalVF v k =
        evalVF
            (rewardm mdpm + gammam mdpm `scale` (transitionm mdpm H.#> v))
            (k - 1)

matrixPolicyImprove :: MDPM s a -> Vector Double -> Matrix Double
matrixPolicyImprove mdpm vf = undefined


module Measurable.Measures where

import Measurable.Core
import Numeric.SpecFunctions (choose)
import Statistics.Distribution
import qualified Statistics.Distribution.Beta as Statistics
import qualified Statistics.Distribution.Binomial as Statistics
import qualified Statistics.Distribution.ChiSquared as Statistics
import qualified Statistics.Distribution.Gamma as Statistics
import qualified Statistics.Distribution.Exponential as Statistics
import qualified Statistics.Distribution.Normal as Statistics

standard :: Measure Double
standard = fromDensityFunction pdf where
  pdf = density Statistics.standard

normal :: Double -> Double -> Measure Double
normal m s = fromDensityFunction pdf where
  pdf = density $ Statistics.normalDistr m s

logNormal :: Double -> Double -> Measure Double
logNormal m s = fmap exp (normal m s)

exponential :: Double -> Measure Double
exponential r = fromDensityFunction pdf where
  pdf = density $ Statistics.exponential r

gamma :: Double -> Double -> Measure Double
gamma a b = fromDensityFunction pdf where
  pdf = density $ Statistics.gammaDistr a b

inverseGamma :: Double -> Double -> Measure Double
inverseGamma a b = fmap recip (gamma a b)

chiSquare :: Int -> Measure Double
chiSquare k = fromDensityFunction pdf where
  pdf = density $ Statistics.chiSquared k

beta :: Double -> Double -> Measure Double
beta a b = fromDensityFunction pdf where
  pdf = density $ Statistics.betaDistr a b

binomial :: Int -> Double -> Measure Int
binomial n p = fromMassFunction pmf [0..n] where
  pmf = binomialMass n p

bernoulli :: Double -> Measure Int
bernoulli = binomial 1

binomialMass :: Int -> Double -> Int -> Double
binomialMass n p k = bc * p ^ k * (1 - p) ^ (n - k) where
  bc = n `choose` k


module Language.Parser.Number where

import qualified Text.ParserCombinators.Parsec as P
import Language.Definition
import qualified Language.Number as N
import qualified Numeric
import qualified Data.Ratio as Ratio
import qualified Data.Complex as C

parse :: P.Parser LispVal
parse = P.try complex P.<|> P.try rational P.<|> P.try float P.<|> decimal1 P.<|> (P.char '#' >> (decimal2 P.<|> hex P.<|> oct P.<|> bin))
-- simple implementation
-- parse = M.liftM (Number . read) $ P.many1 P.digit
--
-- 'do' notation
-- parse :: P.Parser LispVal
-- parse = do
--                 x <- P.many1 P.digit
--                 return $ Number . read $ x
-- >>=
-- parse :: P.Parser LispVal
-- parse =  P.many1 P.digit >>= return . Number . read

decimal1 :: P.Parser LispVal
decimal1 = P.many1 P.digit >>= (return . Number . read)

decimal2 :: P.Parser LispVal
-- decimal2 = do try $
decimal2 = do P.string "d"
              x <- P.many1 P.digit
              (return . Number . read) $ x

hex :: P.Parser LispVal
-- hex = do try $ string "#x"
hex = do P.string "x"
         x <- P.many1 P.hexDigit
         return $ Number (N.hex2dec x)

oct :: P.Parser LispVal
-- hex = do try $ string "#x"
oct = do P.string "o"
         x <- P.many1 P.octDigit
         return $ Number (N.oct2dec x)

bin :: P.Parser LispVal
-- hex = do try $ string "#x"
bin = do P.string "b"
         x <- P.many1 (P.oneOf "10")
         return $ Number (N.bin2dec x)

-- @todo: add support for precision
float :: P.Parser LispVal
float = do x <- P.many1 P.digit
           P.char '.'
           y <- P.many1 P.digit
           return $ Float (fst . head $ Numeric.readFloat ( x ++ "." ++ y ) )

rational :: P.Parser LispVal
rational = do x <- P.many1 P.digit
              P.char '/'
              y <- P.many1 P.digit
              return $ Ratio ((read x) Ratio.% (read y))

complex :: P.Parser LispVal
complex = do x <- (P.try float P.<|> decimal1)
             P.char '+'
             y <- (P.try float P.<|> decimal1)
             P.char 'i'
             return $ Complex (N.toDouble x C.:+ N.toDouble y)


-- perceptron simulation code
-- created by Tomohiro KIDA 2018/05/08/Tue

module Main
    ( main
    , linearFunc
    , linearFunc'
    , lossFunc
    , gradientDescent
    , plotDataPng
    , simPerceptron
    ) where

import Graphics.Gnuplot.Simple
import System.Random
import Numeric.LinearAlgebra

xxs :: [[Double]]
xxs = [[1,4,6],[1,1,4],[1,3,2],[1,7,3]]
ts :: [Int]
ts = [-1,-1,1,1]
a :: (Fractional frac) => frac
a  = 0.1

-- f (x) = w (tr x)
linearFunc :: Matrix R -> Matrix R -> Double
linearFunc w x
    | fst (size w) == 1 && fst (size x) == 1 = head . head . toLists $ w <> (tr x)
    | otherwise                              = -1 -- error

-- linear function for plot
-- the left hand side is x2
linearFunc' :: Matrix R -> Double -> Double
linearFunc' ws x =
    let w = (toLists ws)!!0
    in (-x)*(w!!1)/(w!!2) - ((w!!0)/(w!!2))

lossFunc :: Double -> Double -> Double
lossFunc t f = max 0.0 (-t*f)

-- return one itaration of gradientDescent
gradientDescent :: Int -> Matrix R -> Matrix R
gradientDescent rn ws =
    let ti      = realToFrac $ ts !! rn
        xi      = fromLists [xxs!!rn] :: Matrix R
        li      = lossFunc ti $ linearFunc ws xi
        wsn     = if li > 0 then ws - ( a*(realToFrac (-ti))*xi ) else ws
    in wsn

-- plot data and png
plotDataPng :: Matrix R -> IO ()
plotDataPng ws = do
    plotPathsStyle atribute plotstyle
    where
        lines     = map (\x->(x,(linearFunc' ws x))) [0..10]
        points_t  = map ((\[x,y]->(x,y)).tail) $ (\xs->[(xs!!0),(xs!!1)]) xxs
        points_f  = map ((\[x,y]->(x,y)).tail) $ (\xs->[(xs!!2),(xs!!3)]) xxs
        label     = [(XLabel "x"), (YLabel "y")]
        range     = [(XRange (0,8)), (YRange (0,8))]
        size      = [Aspect (Ratio 0.7)]
        title     = [(Title "simPerceptron")]
        png       = [(PNG   "simPerceptron.png")]
        atribute  = (label++range++title++png)
        plotstyle = [(defaultStyle {plotType = Points }, points_t),
                     (defaultStyle {plotType = Points }, points_f),
                     (defaultStyle {plotType = Lines  }, lines )]

-- simulation perceptron by grandient descent
simPerceptron :: StdGen -> Matrix R -> Int -> IO ()
simPerceptron gen ws count = do
    let (rn,ng) = randomR (0,3) gen :: (Int, StdGen) -- get one rand data of 4
    let wsn = gradientDescent rn ws -- update ws
    putStrLn $ show count ++ show wsn
    if (count > 0)
        then simPerceptron ng wsn (count-1) -- return recursion
        else plotDataPng wsn -- plot

main :: IO ()
main = do
    gen <- getStdGen
    let ws = (1><3) [-1,2,3] :: Matrix R
    simPerceptron gen ws 100 -- gradientDescent simulation


module Section_3_4_3 where

import Numeric.LinearAlgebra

type Network = [(Matrix Double, Vector Double, Double -> Double)]

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

initNetwork :: Network
initNetwork =
  [ ( (2><3) [0.1, 0.3, 0.5, 0.2, 0.4, 0.6]
    , vector [0.1, 0.2, 0.3]
    , sigmoid
    )
  , ( (3><2) [0.1, 0.4, 0.2, 0.5, 0.3, 0.6]
    , vector [0.1, 0.2]
    , sigmoid
    )
  , ( (2><2) [0.1, 0.3, 0.2, 0.4]
    , vector [0.1, 0.2]
    , id
    )
  ]

forward :: Network -> Vector Double -> Vector Double
forward nw x = foldl (\x (w, b, h) -> cmap h (x <# w + b)) x nw


-- root finding examples
import Numeric.GSL
import Numeric.LinearAlgebra
import Text.Printf(printf)

rosenbrock a b [x,y] = [ a*(1-x), b*(y-x^2) ]

test method = do
    print method
    let (s,p) = root method 1E-7 30 (rosenbrock 1 10) [-10,-5]
    print s -- solution
    disp p -- evolution of the algorithm

jacobian a b [x,y] = [ [-a    , 0]
                     , [-2*b*x, b] ]

testJ method = do
    print method
    let (s,p) = rootJ method 1E-7 30 (rosenbrock 1 10) (jacobian 1 10) [-10,-5]
    print s
    disp p

disp = putStrLn . format "  " (printf "%.3f")

main = do
    test Hybrids
    test Hybrid
    test DNewton
    test Broyden

    mapM_ testJ [HybridsJ .. GNewton]


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies      #-}

module Isumi.Math.Complex
  ( RealOrComplex(..)
  ) where

import           Data.Complex

class Floating a => RealOrComplex a where
  type ToComplex a
  type ToReal a
  toComplex :: a -> ToComplex a

instance RealOrComplex Double where
  type ToComplex Double = Complex Double
  type ToReal Double = Double
  toComplex x = x :+ 0

instance RealOrComplex (Complex Double) where
  type ToComplex (Complex Double) = Complex Double
  type ToReal (Complex Double) = Double
  toComplex = id


-- |
-- Module      :  Spiral.RootOfUnity
-- Copyright   :  (c) 2016-2017 Drexel University
-- License     :  BSD-style
-- Maintainer  :  mainland@drexel.edu

module Spiral.RootOfUnity (
    RootOfUnity(..)
  ) where

import Data.Complex
import Data.Complex.Cyclotomic

-- | Types that have primitive roots of unity.
class Fractional a => RootOfUnity a where
    -- | @rootOfUnity n k@ computes the primitive @n@th root of unity raised to
    -- the @k@th power.
    rootOfUnity :: Int -> Int -> a
    rootOfUnity n k = omega n ^^ k

    -- | Computes the primitive @n@th root of unity.
    omega :: Int -> a
    omega n = rootOfUnity n 1

instance RealFloat a => RootOfUnity (Complex a) where
    -- | $e^{-2 \pi i \frac{k}{n}$
    rootOfUnity n k = exp (-2*pi*i/fromIntegral n)^^k
      where
        i = 0:+1

instance RootOfUnity Cyclotomic where
    -- 'Data.Complex.Cyclotomic.e' computes $e^{2 \pi i/n}$, so we need to take
    -- the reciprocal.
    rootOfUnity n k = (1/e (fromIntegral n))^^k


-----------------------------------------------------------------------------
-- |
-- Module     : Numeric.LinearAlgebra.Packed.Herm
-- Copyright  : Copyright (c) 2010, Patrick Perry <patperry@gmail.com>
-- License    : BSD3
-- Maintainer : Patrick Perry <patperry@gmail.com>
-- Stability  : experimental
--
-- Hermitian views of packed matrices.
--
module Numeric.LinearAlgebra.Packed.Herm (
    -- * Immutable interface

    -- ** Vector multiplication
    hermMulVector,
    hermMulVectorWithScale,
    addHermMulVectorWithScales,

    -- ** Updates
    hermRank1Update,
    hermRank2Update,

    -- * Mutable interface
    hermCreate,

    -- ** Vector multiplication
    hermMulVectorTo,
    hermMulVectorWithScaleTo,
    addHermMulVectorWithScalesM_,

    -- ** Updates
    hermRank1UpdateM_,
    hermRank2UpdateM_,

    ) where

import Numeric.LinearAlgebra.Packed.Base


{-# LANGUAGE BangPatterns #-}
module MachineLearning.ClusteringTest
(
  tests
)

where

import Test.Framework (testGroup)
import Test.Framework.Providers.HUnit
import Test.HUnit
import Test.HUnit.Approx
import Test.HUnit.Plus

import MachineLearning.Types
import qualified Data.Vector as V
import qualified Numeric.LinearAlgebra as LA
import Numeric.LinearAlgebra ((><))
import qualified Control.Monad.Random as RndM
import MachineLearning.Clustering

x1 :: Matrix
x1 = (7><5) [ 1, 2, 3, 4, 5
            , 1, 2, 3, 4, 5
            , 1, 2, 3, 4, 5
            , 7, 4, 3, 2, 1
            , 7, 4, 3, 2, 1
            , 1, 2, 3, 4, 5
            , 1, 2, 3, 4, 5]

x2 :: Matrix
x2 = (7><5) [ 1.1, 2, 3, 4, 5
            , 1, 2, 4, 4, 5
            , 1, 2, 3, 4, 5
            , 5, 4, 3, 2, 1
            , 7, 4, 3, 2, 1
            , 1, 2, 3, 4, 5
            , 0.5, 2, 3, 4, 5]

testKmeans x k expectedK = do
  let gen = RndM.mkStdGen 10171
      clusters = RndM.evalRand (kmeans 10 x k) gen
  assertEqual "number of clusters" expectedK (V.length clusters)

isInDescendingOrder :: [Double] -> Bool
isInDescendingOrder lst = and . snd . unzip $ scanl (\(prev, _) current -> (current, prev-current > (-0.001))) (1/0, True) lst

testDescOrderOfCostValues = do
  let gen = RndM.mkStdGen 10171
      samples = V.fromList $ LA.toRows x1
      (clusters, js) = RndM.evalRand (kmeansIterM samples 3 1) gen
  assertBool "" (isInDescendingOrder js)

tests = [testGroup "kmeans" [
            testCase "perfect clusters, k = 2" $ testKmeans x1 2 2
            , testCase "perfect clusters, k = 3" $ testKmeans x1 3 2
            , testCase "good clusters, k = 2" $ testKmeans x2 2 2
            , testCase "good clusters, k = 3" $ testKmeans x2 3 3
            , testCase "good clusters, k = 4" $ testKmeans x2 4 4
            , testCase "descending order" testDescOrderOfCostValues
            ]
        ]


-- | This module implements the Fast Fourier Transformation purely in Haskell.
module Sound.Hommage.FFT
 (
 -- * FFT
   fft
 , fft'
 , fftt

 -- * FFT
 , fftc
 , fftc'

 , ffttv

 , fftco
 , fftco'

 , rect_transform
 , rect_filter
 , rect_filter'

 , i
 , w
 , ws
 , map2
 , zip2
 , evens
 , odds
 , drop_odds
 , appendpair
-- , fitlastlength
 , reorder
 , reorder_init
 , reorder_init'
-- , reorder_overlap
 , butterfly
 , butterfly'
 , fft_level
 , fft_merge
 , fft_init_overlap
 , fft_level'
 , fft_merge'
 , fft_init
 , fft_overlap_loop
 , expandComplex
 , overlap_curve
 , mix_overlap

 )
 where
import Data.Complex
import Sound.Hommage.Misc
-------------------------------------------------------------------------------
-- | The complex value 'i' = @(0 :+ 1)@
i :: Complex Double
i = 0.0 :+ 1.0

-- | The n-th root of 1
w :: Int -> Complex Double
w n = exp (-2 * i * pi / fromIntegral n)

-- | the 2n-th root with exponents 0, 1, .. n. False=inverse (exponents are negated)
ws :: Bool -> Int -> [Complex Double]
ws b n = take n $ map (w1^^) ix
 where
  w1 = exp (-i * pi / fromIntegral n)
  ix | b         = [0, 1 ..]
     | otherwise = [0, (-1) ..]
-------------------------------------------------------------------------------
map2 :: (a -> a -> b) -> [a] -> [b]
map2 f (x:y:r) = f x y : map2 f r
map2 _ _       = []

map2opt :: (a -> a -> b) -> a -> [a] -> [b]
map2opt f a = loop
 where
  loop (x:y:r) = f x y : loop r
  loop [x]     = [f x a]
  loop _       = []

zip2 :: [a] -> [a] -> [a]
zip2 (x:xs) (y:ys) = x : y : zip2 xs ys
zip2 _ _ = []

evens (x:xs) = x : odds xs
evens []     = []

odds (_:xs) = evens xs
odds []     = []

-- | returns [] if argument has zero or one element.
drop_odds (x:y:r) = x : evens r
drop_odds _       = []

appendpair :: ([a], [a]) -> [a]
appendpair (x,y) = x++y

--fitlastlength :: Int -> a -> [[a]] -> [[a]]
--fitlastlength n a = loop
-- where
--  loop (x:xs) = case loop xs of
--                [] -> [take n (x ++ repeat a)]
--                xs -> x : xs
--  loop []     = []
-------------------------------------------------------------------------------
-- | list is grouped into sublists with length N (must be power of 2) and bitwise reverse order
reorder :: Int -> [[a]] -> [[a]]
reorder 0 = id
reorder n = map2 zip2 . reorder (n-1)

reorder_r2 :: Int -> a -> [[a]] -> [[a]]
reorder_r2 n a = loop n
 where
  loop 0 = id
  loop n = map2opt zip2 (repeat a) . loop (n-1)

reorder_init (x1:x2:x3:x4:xs) = [x1 :+ x2, x3 :+ x4] : reorder_init xs
reorder_init [x1,x2,x3]       = [[x1 :+ x2, x3 :+ 0]]
reorder_init [x1,x2]          = [[x1 :+ x2, 0]]
reorder_init [x1]             = [[x1 :+ 0, 0]]
reorder_init _                = []

reorder_init' :: [a] -> [[a]]
reorder_init' (x:y:r) = [x,y] : reorder_init' r
reorder_init' _       = []

reorder_init_r2' :: a -> [a] -> [[a]]
reorder_init_r2' a = loop
 where
  loop (x:y:r) = [x,y] : loop r
  loop [x]     = [[x,a]]
  loop _       = []

--reorder_overlap :: [[a]] -> [a]
--reorder_overlap (xs:ys:r) = (zip2 xs ys) ++ reorder_overlap (ys:r)
--reorder_overlap _       = []
-------------------------------------------------------------------------------
butterfly :: Complex Double ->  Complex Double -> Complex Double -> (Complex Double, Complex Double)
butterfly (wr :+ wi) (xr :+ xi) (yr :+ yi) = (a, b)
 where
  wyr = wr*yr-wi*yi
  wyi = wr*yi+yr*wi
  a = ( (xr + wyr) * 0.5 :+ (xi + wyi) * 0.5 )
  b = ( (xr - wyr) * 0.5 :+ (xi - wyi) * 0.5 )

butterfly' :: Complex Double ->  Complex Double -> Complex Double -> (Complex Double, Complex Double)
butterfly' (wr :+ wi) (xr :+ xi) (yr :+ yi) = (a, b)
 where
  wyr = wr*yr-wi*yi
  wyi = wr*yi+yr*wi
  a = ( (xr + wyr) :+ (xi + wyi) )
  b = ( (xr - wyr) :+ (xi - wyi) )
-------------------------------------------------------------------------------
-- | FFT transformation. Input is grouped into overlapping parts of 2^(N+2) reals and mapped to sublists
--   with 2^(N+1) complex numbers.
fft :: Int -> [Double] -> [[Complex Double]]
fft n = fft_level (ws True (2^n)) . fft_init_overlap . reorder_r2 (n-1) 0 . reorder_init

fft_level :: [Complex Double] -> [[Complex Double]] -> [[Complex Double]]
fft_level [_] = id
fft_level ws  = map2 (\x -> appendpair . fft_merge ws x) . fft_level (drop_odds ws)

fft_merge :: [Complex Double] -> [Complex Double] -> [Complex Double] -> ([Complex Double], [Complex Double])
fft_merge (w:ws) (x:xs) (y:ys) = let (xs', ys') = fft_merge ws xs ys
                                     (x', y') = butterfly w x y
                                 in (x' : xs', y' : ys')
fft_merge _ _ _ = ([], [])

fft_init_overlap (x:y:r) = (zipWith (\x y -> [(x + y)*0.5, (x - y)*0.5]) x y) ++ fft_init_overlap (y:r)
fft_init_overlap _       = []

fft_init (x:y:r) = (zipWith (\x y -> [(x + y)*0.5, (x - y)*0.5]) x y) ++ fft_init r
fft_init _       = []
-------------------------------------------------------------------------------
-- | Inverse FFT transformation. Complex input is grouped into parts with length 2^(N+1) and mapped to
--   sublists with 2^(N+2) reals, which are overlapped and mixed.
fft' :: Int -> [Complex Double] -> [Double]
fft' n = mix_overlap (2^(n+2)) . map expandComplex . fft_level' (ws False (2^n)) . fft_init' . reorder (n-1) . reorder_init'

fft_level' :: [Complex Double] -> [[Complex Double]] -> [[Complex Double]]
fft_level' [_] = id
fft_level' ws  = map2 (\x -> appendpair . fft_merge' ws x) . fft_level' (drop_odds ws)

fft_merge' :: [Complex Double] -> [Complex Double] -> [Complex Double] -> ([Complex Double], [Complex Double])
fft_merge' (w:ws) (x:xs) (y:ys) = let (xs', ys') = fft_merge' ws xs ys
                                      (x', y') = butterfly' w x y
                                  in (x' : xs', y' : ys')
fft_merge' _ _ _ = ([], [])

fft_init' (x:y:r) = (zipWith (\x y -> [x + y, x - y]) x y) ++ fft_init' r
fft_init' _       = []

fft_overlap_loop (x:r@(y:_)) = (concat $ zipWith (\x y -> [x + y, x - y]) x y) : fft_overlap_loop r
fft_overlap_loop _           = []

expandComplex ((x:+y):r) = x : y : expandComplex r
expandComplex _ = []
-------------------------------------------------------------------------------
-- | Creates a fade with length N
overlap_curve :: Int -> [Double]
overlap_curve n = take n $ map (\k -> 0.5 - 0.5 * cos (fromIntegral k * 2 * pi / fromIntegral n )) [0..]

-- | Overlaps a sequence of parts of length N (overlaps by N\/2).
mix_overlap :: Int -> [[Double]] -> [Double]
mix_overlap n xs = merge (+) l r
  where
  c = cycle $ overlap_curve n
  l = zipWith (*) c $ concat $ evens xs
  r = replicate (div n 2) 0.0 ++ (zipWith (*) c $ concat $ odds xs)
-------------------------------------------------------------------------------
-- | FFT transformation with overlapping and windowing.
--   Argument function maps the coefficients. Windowsize: 2^(N+2), i. e. 2^(N+1) coefficients
fftt :: Int -> ([[Complex Double]] -> [Complex Double]) -> [Double] -> [Double]
fftt n f =
 mix_overlap (2^(n+2)) .
 map expandComplex .
 fft_level' (ws False (2^n)) .
 fft_init' .
 reorder (n-1) .
 reorder_init' .
 f .
 fft_level (ws True (2^n)) .
 fft_init_overlap .
 reorder_r2 (n-1) 0 .
 reorder_init

ffttv :: Int -> [Double] -> [Double] -> [Double]
ffttv n vs = fftt n (zipWith (\v (x:+y) -> (v*x) :+ (v*y)) vs . concat . map (\((a:+_):r) -> (a:+0):r))
-------------------------------------------------------------------------------
-- | FFT transformation for complex input (segments of length 2^n).
--   No overlapping or windowing.
fftc :: Int -> [Complex Double] -> [[Complex Double]]
fftc n = fft_level (ws True (2^n)) . fft_init . reorder_r2 (n-1) 0 . reorder_init_r2' 0

-- | Inverse FFT transformation for complex input (segments of length 2^n).
--   No overlapping or windowing.
fftc' :: Int -> [Complex Double] -> [[Complex Double]]
fftc' n = fft_level' (ws False (2^n)) . fft_init' . reorder (n-1) . reorder_init'
-------------------------------------------------------------------------------
-- | FFT for complex input with overlapping. Segment-size: 2^(n+1)
fftco :: Int -> [Complex Double] -> [[Complex Double]]
fftco n = fft_level (ws True (2^n)) . fft_init_overlap . reorder_r2 (n-1) 0 . reorder_init_r2' 0

fftco' :: Int -> [Complex Double] -> [Complex Double]
fftco' n = mix_overlapc (2^(n+1)) . fft_level' (ws False (2^n)) . fft_init' . reorder (n-1) . reorder_init'

-- | Overlaps a sequence of parts of length N (overlaps by N\/2).
mix_overlapc :: Int -> [[Complex Double]] -> [Complex Double]
mix_overlapc n xs = merge (+) l r
  where
  c = cycle $ map (:+0) $ overlap_curve n
  l = zipWith (*) c $ concat $ evens xs
  r = replicate (div n 2) 0.0 ++ (zipWith (*) c $ concat $ odds xs)
-------------------------------------------------------------------------------

-- | A self-inverse transformation similar to FFT but with a simple butterfly
--   operation that uses always W=1. Modifying the data between application
--   and inverse is similar to filtering but the result will be built up from
--   rectangle waves instead of sinus waves.
rect_transform :: Floating a => Int -> [a] -> [[a]]
rect_transform n = run n . map (:[])
 where
  sq = 1 / sqrt 2
  add x y = (x+y) * sq
  sub x y = (x-y) * sq
  run 0 = id
  run n = loop . run (n-1)
  loop (x:y:r) = iter True x y : loop r
  loop [x]     = [iter True x (repeat 0)]
  loop _       = []
  iter True  (x:xs) (y:ys) = add x y : sub x y : iter False xs ys
  iter False (x:xs) (y:ys) = sub x y : add x y : iter True  xs ys
  iter _     _      _      = []

rect_filter :: Floating a => Int -> ([[a]] -> [[a]]) -> [a] -> [a]
rect_filter n f =  concat . rect_transform n . concat . f . rect_transform n

rect_filter' :: Floating a => Int -> [[a]] -> [a] -> [a]
rect_filter' n vs =  concat . rect_transform n . concat . zipWith f vs . rect_transform n
 where
  f v c = zipWith (*) (v ++ repeat 0) c


import Numeric.LinearAlgebra

and' x1 x2 =
    let w1 = 0.5; w2 = 0.5
        theta = 0.7
        tmp = x1*w1 + x2*w2
    in if tmp > theta then 1 else 0

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

nand :: Num t => Vector R -> t
nand x =
    let w = vector [(-0.5), (-0.5)]
        b = 0.7
        tmp = (x <.> w) + b
    in if tmp > 0 then 1 else 0

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

xor :: Num t => Vector R -> t
xor x =
    let s1 = nand x
        s2 = or' x
    in and'' $ vector [s1, s2]


-- file:Astro/AccretionDisk.hs
-- Numerical tools for accretion disk analysis

module Astro.AccretionDisk
	where

import Control.Monad
import System.IO.Unsafe
import System.Random
import Numeric.LinearAlgebra

import Astro.Misc

seed = 1337

rndDoubles :: Int -> (Double,Double) -> IO [Double]
rndDoubles n (min,max) = replicateM n $ randomRIO (min,max)

rndDouble :: (Double, Double) -> IO Double
rndDouble (min, max) = randomRIO (min,max) :: IO Double

-- Random position and corresponding velocity in a flat xy-plane Keplerian disk
-- with CCW rotation when viewed towards negative z-axis
rndDiskPosVel :: (Double, Double) -> Double -> IO (Vector Double, Vector Double)
rndDiskPosVel (minR,maxR) gpar =
	do
	r <- rndDouble (minR,maxR)
	th <- rndDouble (0, 2*pi)
	let rv = fromList [ r * cos th, r * sin th, 0]
	    vv = fromList [-rv@>1, rv@>0, 0.0]
	    vv' = scale (sqrt gpar/norm rv) vv
	return (rv, vv')

-- Create a flat disk (planar), rotating in a CCW sense when viewed
-- towards negative z-axis
flatDisk :: (Double, Double) -> Double -> Int
		-> [(Vector Double, Vector Double)]
flatDisk (minR, maxR) gpar nparts = unsafePerformIO $
	do
		setStdGen $ mkStdGen seed
		replicateM nparts $ rndDiskPosVel (minR,maxR) gpar


{-# LANGUAGE FlexibleInstances #-}
-----------------------------------------------------------------------------
--
-- Module      :  Math.Test
-- Copyright   :
-- License     :  AllRightsReserved
--
-- Maintainer  :
-- Stability   :
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------

module Math.Test where

import Test.Framework (testGroup, Test)
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.HUnit hiding (Test)
import Test.QuickCheck
import Data.AEq (AEq,(~==))

import Numeric.LinearAlgebra (Matrix, Vector, Element, fromList, toRows, toList, flatten)
import Foreign.Storable (Storable)

import Math

mathSuite :: Test
mathSuite = testGroup "Auxillary math functions"
    [-- testCase "The mean of a vector is the vector itself" (testMean [(fromList [1.0]), (fromList [1.0])] (fromList [1.0]) ),
     -- testCase "should fail" (testMean [(fromList [1.0]), (fromList [2.0])] (fromList [1.0]) ),
     testProperty "The mean of a vector is the vector itself" meanProp1,
     testProperty "Mean addition" mean_addition,
     testProperty "Alternate ScatterMatrix" scatter_alternative,
     testProperty "Mean subtraction" mean_subtraction,
     testProperty "ScatterMatrix addition" scatter_addition,
     testProperty "ScatterMatrix subtraction" scatter_subtraction,
     testProperty "The addition of Summarystats" sstat_addition,
     testProperty "The subtraction of Summarystats" sstat_subtraction
     ]

testMean :: [Vector Double] -> Vector Double -> Assertion
testMean points expected = expected @=? meanv points

instance Arbitrary (Vector Double) where
    arbitrary = sized $ \n -> resize (n+1) $ fmap fromList arbitrary

instance Arbitrary X where
    arbitrary = sized $ \n -> sequence [fmap fromList (vector 3) | i<-[1..n]]

instance (AEq a, Storable a)=> AEq (Vector a) where
    x ~== y = (toList x) ~== (toList y)

instance AEq (Matrix Double) where
    x ~== y = (flatten x) ~== (flatten y)

scatter_alternative x = length x > 0 ==> scatterMatrix x ~== scatterMatrixAlt x
            where types = (x::X)

meanProp1 x = meanv [x] == x
        where types = (x::Vector Double)

mean_addition x k = k <= length x ==> add_means nx (meanv xs) ny (meanv ys) ~== meanv (xs++ys)
            where nx = length xs
                  ny = length ys
                  xs = take k x
                  ys = drop k x
                  types = (x::X, k::Int)

mean_subtraction x k = k <= length x ==> sub_means (nx+ny) (meanv (xs++ys)) ny (meanv ys) ~== meanv xs
            where nx = length xs
                  ny = length ys
                  xs = take k x
                  ys = drop k x
                  types = (x::X, k::Int)

scatter_addition x k = k <= length x ==> add_scatter nx sx mx ny sy my ~== scatterMatrix x
            where nx = length xs
                  ny = length ys
                  xs = take k x
                  ys = drop k x
                  mx = meanv xs
                  my = meanv ys
                  sx = scatterMatrix xs
                  sy = scatterMatrix ys
                  types = (x::X, k::Int)

scatter_subtraction x k = k>= 1 && k >= (quot (length x) 2)+1 && k <= length x ==> sub_scatter n s m ny sy my ~== scatterMatrix xs
            where xs = take k x
                  ys = drop k x
                  n = length x
                  ny = length ys
                  m = meanv x
                  my = meanv ys
                  s = scatterMatrix x
                  sy = scatterMatrix ys
                  types = (x::X, k::Int)

sstat_addition x k = k <= length x ==> (fromX xs) <+> (fromX ys) ~== (fromX x)
            where   xs = take k x
                    ys = drop k x
                    types = (x::X, k::Int)

sstat_subtraction x k = k < length x ==> (fromX x) <-> (fromX xs) ~== (fromX ys)
            where   xs = take k x
                    ys = drop k x
                    types = (x::X, k::Int)

validX xs ys = length xs > 1
               && length ys > 1
               && dimension xs > 1
               && dimension ys > 1
               && dimension xs == dimension ys


{-# LANGUAGE ViewPatterns #-}
import Numeric.GSL.ODE
import Numeric.LinearAlgebra
import Graphics.Plot
import Debug.Trace(trace)
debug x = trace (show x) x

vanderpol mu = do
    let xdot mu t [x,v] = [v, -x + mu * v * (1-x^2)]
        ts = linspace 1000 (0,50)
        sol = toColumns $ odeSolve (xdot mu) [1,0] ts
    mplot (ts : sol)
    mplot sol

harmonic w d = do
    let xdot w d t [x,v] = [v, a*x + b*v] where a = -w^2; b = -2*d*w
        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)
    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 mu t (toList->[x,v]) = fromList [v, -x + mu * v * (1-x^2)]
        jac t (toList->[x,v]) = (2><2) [ 0          ,          1
                                       , -1-2*x*v*mu, mu*(1-x**2) ]
        ts = linspace 1000 (0,50)
        hi = (ts@>1 - ts@>0)/100
        sol = toColumns $ odeSolveV (MSBDF jac) hi 1E-8 1E-8 (xdot mu) (fromList [1,0]) ts
    mplot sol