{-|
Module      : Approx
Description : Implement Approx for Double, Floats and structures
Copyright   : (c) 2020 Kishaloy Neogi
License     : MIT
Maintainer  : Kishaloy Neogi
Email       : nkishaloy@yahoo.com

The library is created to allow for a easy-to-use reasonable way of emulating approx in Haskell. The codes are all in /pure/ Haskell. The idea is to have a natural mathematical feel in writing code, with operators which just works when working with Double and Float and their composite types like lists, vectors etc.

The __Approx__ module defines 2 operators __@=~@__ and __@/~@__, which are for checking /nearly equal to/ and /not nearly equal to/ respectively.

Both the operators __=~__ and __/~__ are put under the class __Approx__.

At least one of the operators have to be defined and the other gets automatically defined.

The library already defines the functions for some of the basic / common types.

For types where __Eq__ is defined like __Char, Bool, Int, Day, Text__ the approx is simply replaced with __==__.

For __Float__ and __Double__, the following formula is used,

@
if max ( |x|, |y| ) < epsilon_Zero
then True
else
  if |x - y| / max ( |x|, |y| ) < epsilon_Eq
  then True
  else False
@

The motivation for defining Approx for classes for which Eq is also defined is to allow for composite types where both Eq and Approx would be present. For example, the following code evaluates to __@True@__, even though the tuple is of type @(Int,Double,Text,[Int],[[Char]],[Double])@.

@
((2,5.35,"happ",[1,2],["ret","we"],[6.78,3.5])
    :: (Int,Double,Text,[Int],[[Char]],[Double]))

    =~ (2,5.35,"happ",[1,2],["ret","we"],[6.78,3.5])
@

For UTCTime, the approx operator checks for equality to the nearest minute. The following expression evaluates to __@True@__.

@
(parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S" "2020-01-15 15:02:15"
    :: Maybe UTCTime)

    =~ parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S" "2020-01-15 15:01:50"
@

The library also provides approx for Complex and common structures like __List, Boxed and Unboxed Vector, Hashmap, Tuples__ and __Maybe__. For all lists, tuples, hashmaps and vectors, the approximation is checked right down to the elements and the order for lists and vectors are important.

For lists, only finite lists are supported. Any use of infinite lists would cause a runtime error.

There are addtional functions __inRange__, __safeInRange__ and __inTol__, which checks for values within Ranges either /explictily/ defined as in __inRange__ and __safeInRange__ or through tolerances as in __inTol__.

You may see the github repository at <https://github.com/n-kishaloy/approx>

-}

{-# LANGUAGE Strict #-}

module Data.Approx
(
-- *How to use this library
-- |Add @approx@ to build-depends and @import Data.Approx@

-- *Documentation
  Approx (..)
, inRange, safeInRange, inTol

) where

import Data.List (foldl')
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Unboxed.Mutable as M
import qualified Data.Vector as V
import Data.Time (Day, UTCTime)
import Data.Time.Clock (diffUTCTime)
import qualified Data.HashMap.Strict as Hm
import Data.Hashable

import Data.Text (Text)
import qualified Data.Complex as Cx
import Data.Complex (Complex ( (:+) ) )

eZerD :: Double
eZerD = 1e-8;   {-# INLINE eZerD  #-}

eEqD :: Double
eEqD   = 1e-7;  {-# INLINE eEqD    #-}

eZerF :: Float
eZerF = 1e-6;   {-# INLINE eZerF   #-}

eEqF :: Float
eEqF   = 1e-5;  {-# INLINE eEqF     #-}

infix 4 =~, /~

-- |The class @Approx@ defines 2 operators __@=~@__ and __@/~@__, which are for checking /nearly equal to/ and /not nearly equal to/ respectively.
class Approx a where
  (=~), (/~) :: a -> a -> Bool

  (=~) x y = not (x /~ y)
  {-# INLINE (=~) #-}
  (/~) x y = not (x =~ y)
  {-# INLINE (/~) #-}

  {-# MINIMAL (=~) | (/~) #-}

instance Approx Day where x =~ y = x == y; {-# INLINE (=~) #-}

instance Approx Char where x =~ y = x == y; {-# INLINE (=~) #-}

instance Approx Bool where x =~ y = x == y; {-# INLINE (=~) #-}

instance Approx Text where x =~ y = x == y; {-# INLINE (=~) #-}

instance Approx Int where x =~ y = x == y; {-# INLINE (=~) #-}

instance Approx Integer where x =~ y = x == y; {-# INLINE (=~) #-}

instance Approx UTCTime where
  x =~ y = (round . (/60.0) . realToFrac $ x `diffUTCTime` y) == 0
  {-# INLINE (=~) #-}

instance Approx a => Approx (Cx.Complex a) where
  (a :+ b) =~ (x :+ y) = (a =~ x) && (b =~ y); {-# INLINE (=~) #-}

instance Approx Float where
  x =~ y = (mx < eZerF) || abs (x-y) / mx < eEqF where mx = max (abs x) (abs y)
  {-# INLINE (=~) #-}

instance Approx Double where
  x =~ y = (mx < eZerD) || abs (x-y) / mx < eEqD where mx = max (abs x) (abs y)
  {-# INLINE (=~) #-}

instance Approx a => Approx (Maybe a) where
  Nothing =~ Nothing  =   True
  Just x  =~ Just y   =   x =~ y
  _       =~ _        =   False
  {-# INLINE (=~) #-}

instance Approx a => Approx [a] where
  x =~ y = (length x == length y) && and (zipWith (=~) x y)

instance (Approx a, Approx b) => Approx (a, b) where
  (x,y) =~ (a,b) =
    (   (x =~ a)
    &&  (y =~ b)
    )
  {-# INLINE (=~) #-}

instance (Approx a, Approx b, Approx c) => Approx (a, b, c) where
  (x,y,z) =~ (a,b,c) =
    (   (x =~ a)
    &&  (y =~ b)
    &&  (z =~ c)
    )
  {-# INLINE (=~) #-}

instance (Approx a,Approx b,Approx c,Approx d) => Approx (a,b,c,d) where
  (x,y,z,u) =~ (a,b,c,d) =
    (   (x =~ a)
    &&  (y =~ b)
    &&  (z =~ c)
    &&  (u =~ d)
    )
  {-# INLINE (=~) #-}

instance (Approx a,Approx b,Approx c,Approx d, Approx e) => Approx (a,b,c,d,e) where
  (x,y,z,u,v) =~ (a,b,c,d,e) =
    (   (x =~ a)
    &&  (y =~ b)
    &&  (z =~ c)
    &&  (u =~ d)
    &&  (v =~ e)
    )
  {-# INLINE (=~) #-}

instance (Approx a,Approx b,Approx c,Approx d, Approx e, Approx f) => Approx (a,b,c,d,e,f) where
  (x,y,z,u,v,w) =~ (a,b,c,d,e,f) =
    (   (x =~ a)
    &&  (y =~ b)
    &&  (z =~ c)
    &&  (u =~ d)
    &&  (v =~ e)
    &&  (w =~ f)
    )
  {-# INLINE (=~) #-}

instance (Approx a,Approx b,Approx c,Approx d, Approx e, Approx f, Approx g) => Approx (a,b,c,d,e,f,g) where
  (x,y,z,u,v,w,p) =~ (a,b,c,d,e,f,g) =
    (   (x =~ a)
    &&  (y =~ b)
    &&  (z =~ c)
    &&  (u =~ d)
    &&  (v =~ e)
    &&  (w =~ f)
    &&  (p =~ g)
    )
  {-# INLINE (=~) #-}

instance (Approx a,Approx b,Approx c,Approx d, Approx e, Approx f, Approx g, Approx h) => Approx (a,b,c,d,e,f,g,h) where
  (x,y,z,u,v,w,p,q) =~ (a,b,c,d,e,f,g,h) =
    (   (x =~ a)
    &&  (y =~ b)
    &&  (z =~ c)
    &&  (u =~ d)
    &&  (v =~ e)
    &&  (w =~ f)
    &&  (p =~ g)
    &&  (q =~ h)
    )
  {-# INLINE (=~) #-}

instance (Approx a,Approx b,Approx c,Approx d, Approx e, Approx f, Approx g, Approx h, Approx i) => Approx (a,b,c,d,e,f,g,h,i) where
  (x,y,z,u,v,w,p,q,r) =~ (a,b,c,d,e,f,g,h,i) =
    (   (x =~ a)
    &&  (y =~ b)
    &&  (z =~ c)
    &&  (u =~ d)
    &&  (v =~ e)
    &&  (w =~ f)
    &&  (p =~ g)
    &&  (q =~ h)
    &&  (r =~ i)
    )
  {-# INLINE (=~) #-}

instance (Approx a,Approx b,Approx c,Approx d, Approx e, Approx f, Approx g, Approx h, Approx i, Approx j) => Approx (a,b,c,d,e,f,g,h,i,j) where
  (x,y,z,u,v,w,p,q,r,s) =~ (a,b,c,d,e,f,g,h,i,j) =
    (   (x =~ a)
    &&  (y =~ b)
    &&  (z =~ c)
    &&  (u =~ d)
    &&  (v =~ e)
    &&  (w =~ f)
    &&  (p =~ g)
    &&  (q =~ h)
    &&  (r =~ i)
    &&  (s =~ j)
    )
  {-# INLINE (=~) #-}

instance (Approx a,Approx b,Approx c,Approx d, Approx e, Approx f, Approx g, Approx h, Approx i, Approx j, Approx k) => Approx (a,b,c,d,e,f,g,h,i,j,k) where
  (x,y,z,u,v,w,p,q,r,s,t) =~ (a,b,c,d,e,f,g,h,i,j,k) =
    (   (x =~ a)
    &&  (y =~ b)
    &&  (z =~ c)
    &&  (u =~ d)
    &&  (v =~ e)
    &&  (w =~ f)
    &&  (p =~ g)
    &&  (q =~ h)
    &&  (r =~ i)
    &&  (s =~ j)
    &&  (t =~ k)
    )
  {-# INLINE (=~) #-}

instance (M.Unbox a, Approx a) => Approx (U.Vector a) where
  x =~ y = (U.length x == U.length y) && U.and (U.zipWith (=~) x y)

instance (Approx a) => Approx (V.Vector a) where
  x =~ y = (V.length x == V.length y) && V.and (V.zipWith (=~) x y)

instance (Eq a, Hashable a, Approx b) => Approx (Hm.HashMap a b) where
  x =~ y = fz x y && fz y x where
    fz p q = and $ (\(k,v) -> Hm.lookup k p =~ Just v) <$> Hm.toList q

infix 4 `inRange`, `safeInRange`, `inTol`

{-|@inRange (u,v) x = check if x is inside the range (u,v)@

Note: The function __assumes @u < v@__. This is done to ensure speed of operations. Use safeInRange, otherwise.
-}
inRange :: Ord a => (a,a) -> a -> Bool
inRange (u,v) x = (u <= x) && (x <= v)
{-# INLINE inRange #-}

{-|@safeInRange (u,v) x = check if x is inside the range (u,v)@

Note: The function works even if u>v. However, it has addtional checks and is more expensive. Use only if you are not sure that u < v for your use-case.
-}
safeInRange :: Ord a => (a,a) -> a -> Bool
safeInRange (u,v) = inRange $ if u<v then (u,v) else (v,u)
{-# INLINE safeInRange #-}

{-|@inTol t p x = inRange (p - t, p + t) x@

The Function checks if __@x@__ is close to __@p@__ within a tolerance band __@t@__. Please ensure __@t@__ is /positive/ or there would be /incorrect/ results.
-}
inTol :: (Num a, Ord a) => a -> a -> a -> Bool
inTol t a = inRange (a - t, a + t)
{-# INLINE inTol #-}


module Render(render) where

import Core
import Codec.Picture
import Codec.Picture.Types
import Control.Monad
import System.Random
import Control.Monad.Random

import Numeric.LinearAlgebra

deltas :: RenderSettings -> (Vec3, Vec3)
deltas settings  =
    let
        scale_x = 1 / (fromIntegral (width settings) - 1)
        scale_y = 1 / (fromIntegral (height settings) - 1)
        dx = scale scale_x (topRight settings - topLeft settings)
        dy = scale scale_y (bottomRight settings - topRight settings)
    in (dx,dy)

calc_ray :: RenderSettings -> Int -> Int -> Ray
calc_ray settings x y =
    let
        (dx,dy) = deltas settings
        point = topLeft settings + scale (fromIntegral x) dx + scale (fromIntegral y) dy
        dir = point - origin settings
    in (Ray point dir)

render :: RenderSettings -> Scene -> IO DynamicImage
render settings scene = do
    mut_img <- createMutableImage (width settings) (height settings) (background settings)
    let pixels = [(x,y) | x <- [1..width settings], y <- [1..height settings]]
    let (dx,dy) = deltas settings
    forM_ pixels $ \(x,y) -> do
        let (Ray point dir) = calc_ray settings x y
        colors <- forM [1..antialiasing settings] $ \_ -> do
            kx <- randomRIO (-1,1)
            ky <- randomRIO (-1,1)
            gen <- getStdGen
            let ray' = Ray (point) (dir + scale kx dx + scale ky dy)
            let (color, gen') = runRand (traceRay (background settings) scene ray') gen
            setStdGen gen'
            return $! (1/fromIntegral (antialiasing settings),color)
        writePixel mut_img (x-1) (y-1) (weigh colors)
    img <- unsafeFreezeImage mut_img
    return $! ImageRGBF img


-- Kolmogorov-Smirnov tests for distribution
--
-- Note that it's not most powerful test for normality.
module MWC.KS (
  tests
  ) where

import qualified Data.Vector.Unboxed as U

import Statistics.Test.KolmogorovSmirnov

import Statistics.Types
import Statistics.Distribution
import Statistics.Distribution.Binomial
import Statistics.Distribution.Exponential
import Statistics.Distribution.Gamma
import Statistics.Distribution.Normal
import Statistics.Distribution.Uniform
import Statistics.Distribution.Beta

import qualified System.Random.MWC               as MWC
import qualified System.Random.MWC.Distributions as MWC

import Test.HUnit hiding (Test)
import Test.Framework
import Test.Framework.Providers.HUnit

tests :: MWC.GenIO -> Test.Framework.Test
tests g = testGroup "Kolmogorov-Smirnov"
  [ testCase "standard"           $ testKS standard           MWC.standard    g
  , testCase "normal m=1 s=2"     $ testKS (normalDistr 1 2) (MWC.normal 1 2) g
    -- Gamma distribution
  , testCase "gamma  k=1   θ=1"   $ testKS (gammaDistr  1   1  ) (MWC.gamma  1   1  ) g
  , testCase "gamma  k=0.3 θ=0.4" $ testKS (gammaDistr  0.3 0.4) (MWC.gamma  0.3 0.4) g
  , testCase "gamma  k=0.3 θ=3"   $ testKS (gammaDistr  0.3 3  ) (MWC.gamma  0.3 3  ) g
  , testCase "gamma  k=3   θ=0.4" $ testKS (gammaDistr  3   0.4) (MWC.gamma  3   0.4) g
  , testCase "gamma  k=3   θ=3"   $ testKS (gammaDistr  3   3  ) (MWC.gamma  3   3  ) g
    -- Uniform
  , testCase "uniform -2 .. 3"    $ testKS (uniformDistr (-2) 3) (MWC.uniformR (-2,3)) g
    -- Exponential
  , testCase "exponential l=1"    $ testKS (exponential 1)       (MWC.exponential 1) g
  , testCase "exponential l=3"    $ testKS (exponential 3)       (MWC.exponential 3) g
    -- Beta
  , testCase "beta a=0.3,b=0.5"    $ testKS (betaDistr 0.3 0.5)       (MWC.beta 0.3 0.5) g
  , testCase "beta a=0.1,b=0.8"    $ testKS (betaDistr 0.3 0.5)       (MWC.beta 0.3 0.5) g
  , testCase "beta a=0.8,b=0.1"    $ testKS (betaDistr 0.3 0.5)       (MWC.beta 0.3 0.5) g
  ]

testKS :: (Distribution d) => d -> (MWC.GenIO -> IO Double) -> MWC.GenIO -> IO ()
testKS distr generator g = do
  sample <- U.replicateM 1000 (generator g)
  case kolmogorovSmirnovTest distr sample of
    Nothing -> assertFailure "Not enough data to make test"
    Just t
      | isSignificant (mkPValue 0.01) t == Significant
        -> assertFailure ("KS test failed: " ++ show t)
      | otherwise
        -> return ()


{-# language TypeFamilies #-}
{-# language FlexibleInstances #-}
{-# language FlexibleContexts #-}

module Geometry.Circle
  ( Circle, Circular (..)
  , trivialCircle, mkCircle
  ) where

import Data.Complex
import Data.Semigroup
import Geometry.Base

-- | Class for circle and decorated circle
class (Trans c, Manifold c, Curve c, ClosedCurve c, Figure c) =>
  Circular c where
  {-# MINIMAL toCircle, asCircle #-}
  toCircle :: c -> Circle
  asCircle :: Circle -> c

  -- | Center of the circle.
  center :: c -> Cmp
  center = center . toCircle

  -- | Radius of the circle
  radius :: c -> Double
  radius = radius . toCircle

  -- | The angle of the starting point.
  phaseShift :: c -> Direction
  phaseShift = phaseShift . toCircle

  -- | The orientation of the circle (positive -- CCW).
  orientation :: c -> Direction
  orientation = orientation . toCircle

-- | Represents a circle with given center, radius vector and tangent direction.
data Circle = Circle Cmp Cmp Double
  deriving Show

instance Circular Circle where
  toCircle = id
  asCircle = id
  center (Circle c _ _) = c
  radius (Circle _ r _) = norm r
  orientation (Circle _ _ o) = asDeg (signum o)
  phaseShift (Circle _ r _) = angle r

instance Circular c => Circular (Maybe c) where
  toCircle = maybe trivialCircle toCircle
  asCircle = Just . asCircle

-- | The trivial circle with zero radius.
trivialCircle :: Circle
trivialCircle = mkCircle 0 0

-- | The constructor for a circle with given center and radius.
-- The radius-vector has zero angle, and circle is CCW-oriented.
mkCircle :: Double -> Cmp -> Circle
mkCircle r c = Circle c (r:+0) 1

instance Eq Circle where
  c1 == c2 = radius c1 ~= radius c2 &&
             center c1 ~= center c2 &&
             phaseShift c1 ~= phaseShift c2

instance Trans Circle where
  transform t (Circle c r o) = Circle c' r' o'
    where c' = transformCmp t c
          r' = transformCmp t (c + r) - c'
          o' = transformOrientation t * o

instance Manifold Circle where
  type Domain Circle = Cmp
  param c t = center c + mkPolar (radius c) (rad x)
    where
      ph = turns $ phaseShift c
      x = asTurns $ ph + t * deg (orientation c)

  project c p = turns (x - ph)
    where
      ph = phaseShift c
      x = orientation c * azimuth (center c) p

  isContaining c p = distance p (center c) ~= radius c
  unit _ = 2 * pi

  distanceTo p c = abs (distance p (center c) - radius c)

instance Curve Circle where
  normal c t = azimuth (center c) (c @-> t)
  tangent c t = normal c t + 90 * orientation c

instance ClosedCurve Circle where
  location c p = res
    where res | r' ~= radius c = OnCurve
              | r' < radius c  = Inside
              | r' > radius c  = Outside
          r' = distance (cmp p) (center c)

instance Figure Circle where
  isTrivial c = radius c <= 0
  refPoint = center
  box cir = ((Min x1, Min y1), (Max x2, Max y2))
    where c = center cir
          r = radius cir
          x1:+y1 = c-(r:+r)
          x2:+y2 = c+(r:+r)


{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE Strict #-}

module Main where

import qualified Data.ByteString as BS
import qualified Data.Vector as V
import           Data.Vector (Vector)

import           Control.Monad (replicateM)
import           Control.Arrow ((&&&))
-- import           System.Random

import           Linear.Trace

import           Data.Vector.Split (chunksOf)
import           Data.List (nub)

import           Linear.Vector

import           Net
import           Dense --(softplus, sigmoid, reLU)
import           Backprop (Net, computeNetState)
import           Parser
import           Utils

import           System.Random.MWC
import           Statistics.Distribution
import           Statistics.Distribution.Normal

import           Control.DeepSeq (force)
import           Control.Exception (evaluate)

imageSize :: Int
imageSize = 28*28

stepSize :: Double
stepSize = 0.1
-- stepSize = 0.15

genWeight :: GenIO -> Int -> IO Double
genWeight gen numWeights = genContVar (normalDistr 0 (1/sqrt (fromIntegral numWeights))) gen

genBias :: GenIO -> Int -> IO Double
genBias gen _numWeights = genContVar (normalDistr 0 1) gen

actFn :: Floating a => a -> a
actFn = sigmoid

boolToDouble :: Bool -> Double
boolToDouble False = 0
boolToDouble True  = 1

instance Trace Vector where
  diagonal m =
    V.fromList $ map (\i -> (m V.! i) V.! i) [0..size-1]
    where
      size = V.length m

classify :: Vector Double -> Vector Double
classify v =
  let idx = V.maxIndex v
  in fmap boolToDouble (oneHotEncode (fromIntegral idx))

main :: IO ()
main = do
  -- setStdGen (mkStdGen 200)
  -- setStdGen (mkStdGen 203)
  genIO <- createSystemRandom

  trainLabels0 <- parseLabels <$> BS.readFile "images/train/train-labels-idx1-ubyte"
  trainImages <- parseImages <$> BS.readFile "images/train/train-images-idx3-ubyte"

  testLabels0 <- parseLabels <$> BS.readFile "images/test/t10k-labels-idx1-ubyte"
  testImages <- parseImages <$> BS.readFile "images/test/t10k-images-idx3-ubyte"

  let trainLabels = fmap (fmap boolToDouble) trainLabels0
      testLabels  = fmap (fmap boolToDouble) testLabels0

  let testSampleSize   = 1000
      sampleTestImages = V.take testSampleSize testImages
      sampleTestLabels = V.take testSampleSize testLabels

  let trainLabelsAndImages
        = V.zip trainImages trainLabels

  initialNet <-
    initNet V.replicateM V.fromList imageSize [16, 16, 10] actFn (genWeight genIO) (genBias genIO)
      :: IO (Net Vector Double)

  minibatches <- evaluate $ force $ chunksOf 10 (V.take 700 trainLabelsAndImages)

  putStrLn "Minibatches created."

  let trainedNet =
        -- train 50 stepSize initialNet (map V.fromList $ chunksOf 10 (take 700 trainLabelsAndImages))
        train 50 stepSize initialNet minibatches

        -- train 500 stepSize actFn initialNet [V.fromList $ take 3 trainLabelsAndImages]
        -- train 10 stepSize actFn initialNet (take 2 (map V.fromList $ chunksOf 200 trainLabelsAndImages))

  putStrLn "Measuring training set accuracy..."
  putStr "Training accuracy: "
  putStr (show (netTestAccuracy classify trainedNet (V.take 1000 trainImages) (V.take 1000 trainLabels)*100))
  putStrLn "%"

  putStrLn "Measuring testing set accuracy..."
  putStr "Test accuracy: "
  putStr (show (netTestAccuracy classify trainedNet sampleTestImages sampleTestLabels*100))
  putStrLn "%"


{-# LANGUAGE FlexibleContexts #-}

module Common
  ( splitMatrixOfSamples
  , addOnesColumn
  , getDimensions
  , featureNormalize
  , sigmoid
  , sigmoidMatrix
  , regularizeCost
  , MinimizationOpts(..)
  ) where

import Numeric.LinearAlgebra.Data
  ( Matrix
  , R
  , Vector
  , (|||)
  , (¿)
  , cmap
  , cols
  , flatten
  , fromList
  , fromLists
  , matrix
  , rows
  , toList
  , toLists
  , tr'
  )
import Numeric.LinearAlgebra (Container)
import Numeric.LinearAlgebra.Devel (foldVector)

data MinimizationOpts = MinimizationOpts
  { precision :: R
  , tolerance :: R
  , sizeOfFirstTrialStep :: R
  } deriving (Eq)

splitMatrixOfSamples :: Matrix R -> (Matrix R, Vector R)
splitMatrixOfSamples mx =
  let c = cols mx
   in (mx ¿ [0 .. (c - 2)], flatten $ mx ¿ [(c - 1)])

addOnesColumn :: Matrix R -> Matrix R
addOnesColumn mx = matrix 1 (replicate (rows mx) 1) ||| mx

getDimensions :: Matrix R -> (Int, Int)
getDimensions mx = (rows mx, cols mx)

sigmoid :: R -> R
sigmoid z = 1 / (1 + exp (-1 * z))

sigmoidMatrix :: Container c R => c R -> c R
sigmoidMatrix = cmap sigmoid

regularizeCost :: Int -> Vector R -> R -> R -> R
regularizeCost m theta lambda cost =
  let m' = fromIntegral m
      regVal = (foldVector (\v accum -> (v ** 2) + accum) 0 theta)
   in cost + ((regVal * lambda) / (3 * m'))

featureNormalize :: Matrix R -> Matrix R
featureNormalize mx =
  let trMx = toLists $ tr' mx
      normalizedTrMx =
        zipWith
          (\vals (mean, std) -> normalize mean std <$> vals)
          trMx
          (computeMeanAndStd <$> trMx)
   in tr' $ fromLists normalizedTrMx
  where
    computeMean vals =
      let (accum, n) = foldl (\(v', n') v -> (v + v', n' + 1)) (0, 0) vals
       in (accum / n, n)
    computeStd n mn vals =
      let sumOfSquares =
            foldl (\v' v -> ((v - mn) ** (2 :: Double)) + v') (0 :: Double) vals
       in sqrt $ sumOfSquares / (n - 1)
    computeMeanAndStd vals =
      let (mean, n) = computeMean vals
          std = computeStd n mean vals
       in (mean, std)
    normalize mean std val =
      if std == 0
        then mean
        else (val - mean) / std


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- |
-- Module      :  Test.Factorization
-- Copyright   :  (c) 2016-2020 Drexel University
-- License     :  BSD-style
-- Maintainer  :  mainland@drexel.edu

module Test.Factorization (
    factorizationTests,
    f2Test,
    f4Test,
    f8Test,
    cooleyTukeyDITTest,
    cooleyTukeyDIFTest,
    goodThomasTest,
    raderTest,
    bluesteinTest,
    winogradSmallTest,
    ditTest,
    difTest,
    splitRadixTest,
    splitRadix8Test,
    conjPairSplitRadixTest,
    improvedSplitRadixTest,
    opcountSearchTest
  ) where

import Data.Complex
import Data.Modular
import Data.Proxy (Proxy(..))
import Test.HUnit ((@?=))
import Test.Hspec

import Spiral.Array (M,
                     Matrix)
import qualified Spiral.Array as A
import Spiral.Convolution
import Spiral.Driver
import Spiral.Exp
import Spiral.FFT.Bluestein
import Spiral.FFT.CooleyTukey
import Spiral.FFT.GoodThomas
import Spiral.FFT.Rader
import Spiral.FFT.Winograd
import Spiral.NumberTheory (factors)
import Spiral.RootOfUnity
import Spiral.SPL
import Spiral.Search.FFTBreakdowns (getCycs)
import Spiral.Search.OpCount

factorizationTests :: Spec
factorizationTests = do
    f2Test
    f4Test
    f8Test
    complexFactorizationTests
    describe "Modular DFT" $ do
        describe "ℤ/17" $
            sequence_ [ditTest (Proxy :: Proxy (ℤ/17)) i | i <- [1..4::Int]]
        describe "ℤ/2013265921" $
            sequence_ [ditTest (Proxy :: Proxy (ℤ/2013265921)) i | i <- [1..7::Int]]

complexFactorizationTests :: Spec
complexFactorizationTests = do
    describe "Cooley-Tukey" $ do
        cooleyTukeyDITTest p 5 7
        cooleyTukeyDIFTest p 5 7
    describe "Good-Thomas" $
        goodThomasTest p 5 7
    describe "Rader" $ do
        mapM_ (raderTest p "Rader" rader) [7, 23]
        mapM_ (raderTest p "RaderI" (\n w -> raderI n w (ConvolutionTheorem (n-1)))) [7, 17, 23]
        mapM_ (raderTest p "RaderII" raderII) [7, 17, 23]
        mapM_ (raderTest p "RaderIII" raderIII) [7, 17, 23]
        mapM_ (raderTest p "RaderIV" raderIV) [7, 17, 23]
        mapM_ (raderTest p "raderLuIII" raderLuIII) [7, 17, 23]
    describe "Bluestein" $ do
        mapM_ (bluesteinTest p "Bluestein" bluestein) [(3, 6), (4, 8), (4, 9), (9, 18)]
        mapM_ (bluesteinTest p "Bluestein'" bluestein') [(3, 6), (4, 8), (4, 9), (9, 18)]
    describe "Winograd Small" $ do
        winogradSmallTest 3 (ConvolutionTheorem 2)
        winogradSmallTest 5 (ConvolutionTheorem 4)
        winogradSmallTest 7 (SplitNesting [3, 2] [(Winograd 3 [Standard 1, Standard 2]), (Winograd 2 [Standard 1, Standard 1])])
        winogradSmallTest 7 (AgarwalCooley 3 2 (Winograd 3 [Standard 1, Lift 2 6 (Tensor [3,2] [Standard 3,Standard 2])]) (Winograd 2 [Standard 1,Standard 1]))
    describe "Winograd Large" $
        mapM_ winogradLargeTest [(2,3), (5, 2), (2,7), (3,4), (4,3), (5,4), (3,8), (5,8), (8,3), (3,5), (5,3)]
    describe "Winograd 2^n" $
        mapM_ winogradTwoTest [2^i | i <- [1..5::Int]]
    describe "Winograd Power" $ do
        winogradPowerTest 3 2
        winogradSquareTest 3
        winogradSquareTest 5
    describe "DIT" $
        sequence_ [ditTest p n | n <- [1..7]]
    describe "DIF" $
        sequence_ [difTest p n | n <- [1..7]]
    describe "Split Radix" $
        sequence_ [splitRadixTest p n | n <- [1..3]]
    describe "Split Radix 8" $
        sequence_ [splitRadix8Test p n | n <- [1..2]]
    describe "Conjugate Pair Split Radix" $
        sequence_ [conjPairSplitRadixTest p n | n <- [1..3]]
    describe "Improved Split Radix" $
        sequence_ [improvedSplitRadixTest p n | n <- [1..3]]
  where
    p :: Proxy (Complex Double)
    p = Proxy

-- $F_2$
f2Test :: Spec
f2Test = it "F_2" $ toMatrix (dit 2) @?= f2
  where
    f2 :: Matrix M (Exp (Complex Double))
    f2 = A.matrix [[1,  1],
                   [1, -1]]

-- $F_4$ calculated per "SPL: A Language and Compiler for DSP Algorithms"
f4Test :: Spec
f4Test = it "F_4" $ toMatrix (dit 4) @?= f4
  where
    f4 :: Matrix M (Exp (Complex Double))
    f4 = A.matrix [[1,  1,  1,  1],
                   [1, -i, -1,  i],
                   [1, -1,  1, -1],
                   [1,  i, -1, -i]]
      where
        i :: Exp (Complex Double)
        i = complexE (0 :+ 1)

-- $F_8$ calculated per "SPL: A Language and Compiler for DSP Algorithms"
-- See also:
--   https://en.wikipedia.org/wiki/DFT_matrix
f8Test :: Spec
f8Test = it "F_8" $ toMatrix (dit 8) @?= f8
  where
    f8 :: Matrix M (Exp (Complex Double))
    f8 = A.matrix [[1,  1,  1,  1, 1, 1, 1, 1],
                   [1,  w, -i,  -i*w, -1, -w, i, i*w],
                   [1, -i, -1, i, 1, -i, -1, i],
                   [1, -i*w, i, w, -1, i*w, -i, -w],
                   [1, -1, 1, -1, 1, -1, 1, -1],
                   [1, -w, -i, i*w, -1, w, i, -i*w],
                   [1, i, -1, -i, 1, i, -1, -i],
                   [1, i*w, i, -w, -1, -i*w, -i, w]]
      where
        i = complexE (0 :+ 1)

        w = omega 8

-- Test Cooley-Tukey DIT
cooleyTukeyDITTest :: forall p . RootOfUnity (Exp p)
                   => Proxy p
                   -> Int
                   -> Int
                   -> Spec
cooleyTukeyDITTest _ r s =
    it ("CooleyTukeyDIT(" ++ show r ++ "," ++ show s ++ ")") $
    toMatrix (cooleyTukeyDIT r s w) @?= toMatrix (F rs w)
  where
    w :: Exp p
    w = omega rs

    rs :: Int
    rs = r*s

-- Test Cooley-Tukey DIF
cooleyTukeyDIFTest :: forall p . RootOfUnity (Exp p)
                   => Proxy p
                   -> Int
                   -> Int
                   -> Spec
cooleyTukeyDIFTest _ r s =
    it ("CooleyTukeyDIF(" ++ show r ++ "," ++ show s ++ ")") $
    toMatrix (cooleyTukeyDIF r s w) @?= toMatrix (F rs w)
  where
    w :: Exp p
    w = omega rs

    rs :: Int
    rs = r*s

-- Test Good-Thomas with factors 5 and 7
goodThomasTest :: forall p . RootOfUnity (Exp p)
               => Proxy p
               -> Int
               -> Int
               -> Spec
goodThomasTest _ r s =
    it ("GoodThomas(" ++ show r ++ "," ++ show s ++ ")") $
    toMatrix (goodThomas r s w) @?= toMatrix (F rs w)
  where
    w :: Exp p
    w = omega rs

    rs :: Int
    rs = r*s

-- Test Rader for given prime
raderTest :: forall p . RootOfUnity (Exp p)
          => Proxy p
          -> String
          -> (Int -> Exp p -> SPL (Exp p))
          -> Int
          -> Spec
raderTest _ desc rader n = it (desc ++ "(" ++ show n ++ ")") $
    toMatrix (rader (fromIntegral n) w) @?= toMatrix (F n w)
  where
    w :: Exp p
    w = omega n

-- Test Bluestein for given n and m
bluesteinTest :: forall p . RootOfUnity (Exp p)
              => Proxy p
              -> String
              -> (Int -> Int -> Exp p -> SPL (Exp p))
              -> (Int, Int)
              -> Spec
bluesteinTest _ desc bluestein (n, m) = it (desc ++ "(" ++ show n ++ "," ++ show m ++ ")") $
    toMatrix (bluestein n m w) @?= toMatrix (DFT n)
  where
    w :: Exp p
    w = omega (2*n)

winogradSmallTest :: Int
                  -> CyclicConvolution (Exp (Complex Double))
                  -> Spec
winogradSmallTest n cyc =
    it ("WinogradSmall(" ++ show n ++ "--" ++ show cyc ++ ")") $
    toMatrix (winogradSmall n w cyc) @?= toMatrix (F n w)
  where
    w :: Exp (Complex Double)
    w = omega n

winogradLargeTest :: (Int, Int) -> Spec
winogradLargeTest (r, s) = it ("WinogradLarge(" ++ show r ++ ", " ++ show s ++ ")") $
    sequence_ [toMatrix (winogradLarge r s w cr cc) @?= toMatrix (F n w)
                | cr <- take 2 $ getWinogradTriple' r s w getCycs
                , cc <- take 2 $ getWinogradTriple' s r w getCycs]
  where
    n :: Int
    n = r*s

    w :: Exp (Complex Double)
    w = omega n

winogradTwoTest :: Int -> Spec
winogradTwoTest n@2 = describe ("Winograd N=" ++ show n) $ do
    sequence_ [it ("DIF(2,1): w^" ++ show i) $ toMatrix (winogradDIF 2 1 (w^i)) @?= toMatrix (F n (w^i)) | i <- [1..n-1], rem i 2 /= 0]
    sequence_ [it ("DIT(2,1): w^" ++ show i) $ toMatrix (winogradDIT 2 1 (w^i)) @?= toMatrix (F n (w^i)) | i <- [1..n-1], rem i 2 /= 0]
  where
    w :: Exp (Complex Double)
    w = omega n

winogradTwoTest n = describe ("Winograd N=" ++ show n) $ do
    sequence_ [it ("DIF(" ++ show r ++ "," ++ show s ++ "): w^" ++ show i) $ toMatrix (winogradDIF r s (w^i)) @?= toMatrix (F n (w^i)) | i <- [1,n-1], rem i 2 /= 0, (r,s) <- factors n]
    sequence_ [it ("DIT(" ++ show r ++ "," ++ show s ++ "): w^" ++ show i) $ toMatrix (winogradDIT r s (w^i)) @?= toMatrix (F n (w^i)) | i <- [1,n-1], rem i 2 /= 0, (r,s) <- factors n]
    sequence_ [it ("SplitRadix: w^" ++ show i) $ toMatrix (winogradSplitRadix n (w^i)) @?= toMatrix (F n (w^i)) | i <- [1,n-1], rem i 2 /= 0]
    sequence_ [it ("ConjPairSplitRadix: w^" ++ show i) $ toMatrix (winogradConjPairSplitRadix n (w^i)) @?= toMatrix (F n (w^i)) | i <- [1,n-1], rem i 2 /= 0]
    sequence_ [it ("SplitRadix8: w^" ++ show i) $ toMatrix (winogradSplitRadix8 n (w^i)) @?= toMatrix (F n (w^i)) | i <- [1,n-1], n >= 8, rem i 2 /= 0]
    sequence_ [it ("ImprovedSplitRadix: w^" ++ show i) $ toMatrix (winogradImprovedSplitRadix n (w^i)) @?= toMatrix (F n (w^i)) | i <- [1,n-1], rem i 2 /= 0]
  where
    w :: Exp (Complex Double)
    w = omega n

winogradPowerTest :: Int -> Int -> Spec
winogradPowerTest p k = describe ("WinogradPower(" ++ show p ++ "^" ++ show k ++ ")") $
    sequence_
    [it ("w^" ++ show i ++ " -- p': " ++ show cP ++ " -- s: " ++ show cS) $
        toMatrix (winogradPower p k (w^^i) cP cS) @?= toMatrix (F n (w^^i))
        | i  <- [1,8],
          cP <- take 2 $ getCycs p',
          cS <- take 2 $ getCycs s]
  where
    n, p', s :: Int
    n  = p^k
    p' = (p-1)
    s  = p * p'

    w :: Exp (Complex Double)
    w = omega n

winogradSquareTest :: Int -> Spec
winogradSquareTest p = describe ("WinogradSquare(" ++ show p ++ "^2)") $
    sequence_
    [it ("w^" ++ show i) $ toMatrix f @?= toMatrix (F n (w^^i))
        | i  <- [1,p],
          f  <- take 1 $ winogradSquare p k (w^^i) getCycs]
  where
    n, p', s, k :: Int
    k  = 2
    n  = p^k
    p' = (p-1)
    s  = p * p'

    w :: Exp (Complex Double)
    w = omega n

-- DIT test
ditTest :: forall p . RootOfUnity (Exp p)
        => Proxy p
        -> Int
        -> Spec
ditTest _ n = it ("DIT(2^" ++ show n ++ ")") $
    toMatrix fft_spl @?= toMatrix (DFT (2^n))
  where
    fft_spl :: SPL (Exp p)
    fft_spl = dit (2^n)

-- DIF test
difTest :: forall p . RootOfUnity (Exp p)
        => Proxy p
        -> Int
        -> Spec
difTest _ n = it ("DIF(2^" ++ show n ++ ")") $
    toMatrix fft_spl @?= toMatrix (DFT (2^n))
  where
    fft_spl :: SPL (Exp p)
    fft_spl = dif (2^n)

-- Split radix test
splitRadixTest :: forall p . RootOfUnity (Exp p)
               => Proxy p
               -> Int
               -> Spec
splitRadixTest _ n = it ("SplitRadix(4^" ++ show n ++ ")") $
    toMatrix (splitRadix (4^n) w) @?= toMatrix (DFT (4^n))
  where
    w :: Exp p
    w = omega (4^n)

-- Split radix 8 test
splitRadix8Test :: forall p . RootOfUnity (Exp p)
                => Proxy p
                -> Int
                -> Spec
splitRadix8Test _ n = it ("SplitRadix(8^" ++ show n ++ ")") $
    toMatrix (splitRadix8 (8^n) w) @?= toMatrix (DFT (8^n))
  where
    w :: Exp p
    w = omega (8^n)

-- Split radix test
conjPairSplitRadixTest :: forall p . RootOfUnity (Exp p)
                       => Proxy p
                       -> Int
                       -> Spec
conjPairSplitRadixTest _ n = it ("ConjPairSplitRadix(4^" ++ show n ++ ")") $
    toMatrix (conjPairSplitRadix (4^n) w) @?= toMatrix (DFT (4^n))
  where
    w :: Exp p
    w = omega (4^n)

-- Split radix test
improvedSplitRadixTest :: forall p . (Floating (Exp p), RootOfUnity (Exp p))
                       => Proxy p
                       -> Int
                       -> Spec
improvedSplitRadixTest _ n = it ("ImprovedSplitRadix(4^" ++ show n ++ ")") $
    toMatrix (improvedSplitRadix (4^n) w) @?= toMatrix (DFT (4^n))
  where
    w :: Exp p
    w = omega (4^n)

-- Lowest-opcount test
opcountSearchTest :: Int -> Spec
opcountSearchTest n = it ("OpcountSearch(" ++ show n ++ ")") $ do
    Re e <- runSpiralWith mempty $
            searchOpCount (Re (DFT n) :: SPL (Exp Double))
    toMatrix e @?= toMatrix (DFT n)


{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}

module Cas.Internal.Def where

import           PreludeCustom
import           Data.Complex.Generic

type F = Complex Rational

instance Ord F where
   (x0:+y0) <= (x1:+y1) = x0 < x1 || x0==x1 && y0 < y1

data C      = Pi  | E               deriving (Eq, Ord, Show)
newtype X   = X    { xI    :: Int } deriving (Eq,Ord)
newtype Add = Add  { addTs :: [T] } deriving (Eq,Ord)
newtype Mul = Mul  { mulTs :: [T] } deriving (Eq,Ord)

data T   = TF   { tF    :: F    }
         | TX   { tX    :: X    }
         | TC   { tC    :: C    }
         | TAdd { tAdd  :: Add  }
         | TMul { tMul  :: Mul  }
         | TPow { tPowB :: T
                , tPowE :: T    }
         | TLn  { tLnT  :: T    }
         deriving (Eq,Ord)

data Equ    = Equ    { equT       :: T     }  deriving (Eq,Ord)
data LinSys = LinSys { linSysEqus :: [Equ] }  deriving (Eq,Ord)

data Rule   = Rule {ruleX::X, ruleT::T}
(-->) :: X -> T -> Rule
(-->) = Rule

data LinSysSolution = LinSysSolution { solutionRules :: [Rule]
                                     , constraints   :: [Equ]  }


-----------------------------------------------------------------------------
-- |
-- Module     : Numeric.LinearAlgebra.Matrix.ST
-- Copyright  : Copyright (c) , Patrick Perry <patperry@gmail.com>
-- License    : BSD3
-- Maintainer : Patrick Perry <patperry@gmail.com>
-- Stability  : experimental
--
-- Mutable matrices in the ST monad.

module Numeric.LinearAlgebra.Matrix.ST (
    -- * Mutable matrices
    STMatrix,
    IOMatrix,
    create,

    -- * Read-only matrices
    RMatrix(..),

    -- * Creating new matrices
    new_,
    new,

    -- * Copying matrices
    newCopy,
    copyTo,

    -- * Matrix views
    withSlice,
    withTakeRows,
    withDropRows,
    withSplitRowsAt,
    withTakeCols,
    withDropCols,
    withSplitColsAt,
    withSliceM,
    withTakeRowsM,
    withDropRowsM,
    withSplitRowsAtM,
    withTakeColsM,
    withDropColsM,
    withSplitColsAtM,

    -- * Matrix rows and columns
    rowTo,
    unsafeRowTo,
    setRow,
    unsafeSetRow,
    withCol,

    withColM,
    withColsM,

    swapRows,
    unsafeSwapRows,
    swapCols,
    unsafeSwapCols,

    -- * Matrix diagonals
    diagTo,
    setDiag,

    -- * Reading and writing matrix elements
    read,
    write,
    modify,
    getIndices,
    getElems,
    getElems',
    getAssocs,
    getAssocs',
    setElems,
    setAssocs,

    -- * List-like operations
    mapTo,
    zipWithTo,

    -- * Matrix math operations
    shiftDiagM_,
    shiftDiagWithScaleM_,
    addTo,
    subTo,
    scaleM_,
    addWithScaleM_,
    scaleRowsM_,
    scaleColsM_,
    negateTo,
    conjugateTo,

    -- * Linear algebra
    transTo,
    conjTransTo,
    rank1UpdateM_,

    -- ** Matrix-Vector multiplication
    mulVectorTo,
    mulVectorWithScaleTo,
    addMulVectorWithScalesM_,

    -- ** Matrix-Matrix multiplication
    mulMatrixTo,
    mulMatrixWithScaleTo,
    addMulMatrixWithScalesM_,

    -- * Conversions between mutable and immutable matrices
    freeze,

    -- * Vector views of matrices
    maybeWithVectorM,

    -- * Matrix views of vectors
    withFromVector,
    withFromCol,
    withFromRow,

    withFromVectorM,
    withFromColM,
    withFromRowM,

    -- * Unsafe operations
    unsafeCopyTo,
    unsafeAddWithScaleM_,

    ) where

import Prelude()
import Numeric.LinearAlgebra.Matrix.STBase


module PCA
    ( fitPCA, transformPCA
    ) where

import PCA.QModels
import Numeric.LinearAlgebra.Data
       (Matrix, Vector, toRows, fromRows)
import qualified Numeric.LinearAlgebra.HMatrix as H

-- | Theta parameteres which we will you for predict in model
data PCAModel = PCAModel
    { scale :: Matrix Double  -- ^ W
    , shift :: Vector Double  -- ^ \mu
    }

fitPCA :: Matrix Double -> PCAModel
fitPCA t =
    let (w,mu) = calculateQ t
    in PCAModel
       { scale = w
       , shift = mu
       }

transformPCA :: PCAModel -> Matrix Double -> Matrix Double
transformPCA (PCAModel w mu) t =
    fromRows
        (map
             (\tn ->
                   tn + mu)
             (toRows (t H.<> w)))


module Approx where
import Data.Complex

approxDbl :: Int -> Double -> Double
approxDbl n x = fromInteger (round $ x * (10^n)) / (10.0^^n)

approx :: Int -> Complex Double -> Complex Double
approx n z = approxDbl n (realPart z) :+ approxDbl n (imagPart z)


{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MagicHash             #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UnboxedTuples         #-}
{-# LANGUAGE UndecidableInstances  #-}

module Numeric.Matrix.Bidiagonal
  ( BiDiag (..), biDiag, bidiagonalHouseholder
  ) where

import Control.Monad
import Control.Monad.ST
import Data.Kind
import Numeric.Basics
import Numeric.DataFrame.ST
import Numeric.DataFrame.SubSpace
import Numeric.DataFrame.Type
import Numeric.Dimensions
import Numeric.Matrix.Internal
import Numeric.Scalar.Internal
import Numeric.Subroutine.Householder
import Numeric.Vector.Internal

-- | Put two vectors on the main and first upper diagonal.
biDiag :: forall (t :: Type) (n :: Nat) (m :: Nat)
        . (PrimBytes t, Num t)
       => Dims '[n,m]
       -> Vector t (Min n m)
       -> Vector t (Min n m)
       -> Matrix t n m
biDiag (dn@D :* dm@D :* U) a b = runST $ do
    dnm@D <- pure $ minDim dn dm
    rPtr <- thawDataFrame 0
    forM_ [0 .. dimVal dnm - 1] $ \i -> do
      writeDataFrame rPtr (Idx i :* Idx i :* U) $ a ! i
      when (i+1 < dimVal dm) $
        writeDataFrame rPtr (Idx i :* Idx (i+1) :* U) $ b ! i
    unsafeFreezeDataFrame rPtr

-- | Decomposition of a matrix \( A = U B V^\intercal \) such that
--   \( U \) and \( V \) are orthogonal and \( B \) is bidiagonal.
data BiDiag (t :: Type) (n :: Nat)  (m :: Nat)
  = BiDiag
  { bdU     :: Matrix t n n
    -- ^ \( U \) left orthogonal matrix
  , bdUDet  :: Scalar t
    -- ^ A shortcut for evaluating a determinant of \( |U| = \pm 1 \)
  , bdAlpha :: Vector t (Min n m)
    -- ^ Main diagonal of \( B \)
  , bdBeta  :: Vector t (Min n m)
    -- ^ First upper diagonal of \( B \);
    --   its last element equals zero if \( n \geq m \)
  , bdV     :: Matrix t m m
    -- ^ \( B \) left orthogonal matrix
  , bdVDet  :: Scalar t
    -- ^ A shortcut for evaluating a determinant of \( |V| = \pm 1 \)
  }

deriving instance ( Show t, PrimBytes t
                  , KnownDim n, KnownDim m, KnownDim (Min n m))
                  => Show (BiDiag t n m)
deriving instance ( Eq t, PrimBytes t
                  , KnownDim n, KnownDim m, KnownDim (Min n m)
                  , KnownBackend t '[Min n m])
                  => Eq (BiDiag t n m)

{- |
Decompose a matrix \( A = U B V^\intercal \) such that
\( U \) and \( V \) are orthogonal and \( B \) is bidiagonal.

The first returned number
 -}
bidiagonalHouseholder ::
       forall (t :: Type) (n :: Nat) (m :: Nat)
     . (PrimBytes t, Ord t, Epsilon t, KnownDim n, KnownDim m)
    => Matrix t n m
    -> BiDiag t n m
bidiagonalHouseholder a = runST $ do
      D <- pure $ minDim (dim @n) (dim @m)
      tmpNPtr <- newDataFrame
      tmpMPtr <- newDataFrame
      uPtr <- thawDataFrame eye
      bPtr <- thawDataFrame a
      vPtr <- thawDataFrame eye
      (ud, vd) <-
        let f (ud, vd) i = do
              ud' <- householderReflectionInplaceL tmpNPtr uPtr bPtr
                     (Idx (i - 1) :* Idx (i - 1) :* U)
              vd' <- householderReflectionInplaceR tmpMPtr vPtr bPtr
                     (Idx (i - 1) :* Idx i :* U)
              return (ud /= ud', vd /= vd')
        in foldM f (False, False) [1 .. lim - 1]

      udn <- householderReflectionInplaceL tmpNPtr uPtr bPtr
                     (Idx (lim - 1) :* Idx (lim - 1) :* U)
      vdn <- if (m > lim)
             then householderReflectionInplaceR tmpMPtr vPtr bPtr
                     (Idx (lim - 1) :* Idx lim :* U)
             else pure False
      bdU <- unsafeFreezeDataFrame uPtr
      bdV <- unsafeFreezeDataFrame vPtr
      b <- unsafeFreezeDataFrame bPtr
      let bdAlpha = iwgen @t @'[Min n m]
            (\(Idx i :* U) -> index (Idx i :* Idx i :* U) b)
          bdBeta  = iwgen @t @'[Min n m]
            (\(Idx i :* U) -> if i+1 < m then index (Idx i :* Idx (i+1) :* U) b else 0)
          bdUDet = if ud /= udn then -1 else 1
          bdVDet = if vd /= vdn then -1 else 1
      return BiDiag {..}
  where
    n = dimVal' @n
    m = dimVal' @m
    lim = max 1 (min n m)


import Test.HUnit
import FFT.DFTControl
import FFT.Orig
import FFT.Samples
import System.Environment
import Data.Complex

testDcDft = TestCase (assertEqual "DFTDc" expected actual)
    where
        expected = (sum $ dcdft samples512)
        actual = (sum $ dft samples512)
        samples512 = samples 1 512

tests = TestList [TestLabel "testDcDFT" testDcDft
                    ]

main = runTestTT tests


-----------------------------------------------------------------------------
-- |
-- Module      :  Numeric.Statistics.Histogram
-- Copyright   :  (c) A. V. H. McPhail 2010, 2014
-- License     :  BSD3
--
-- Maintainer  :  haskell.vivian.mcphail <at> gmail <dot> com
-- Stability   :  provisional
-- Portability :  portable
--
-- create histograms from density functions
--
-----------------------------------------------------------------------------

module Numeric.Statistics.Histogram (
                                     cumulativeToHistogram
                                    , gaussianHistogram
                                  ) where

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

--import qualified Data.Packed.Vector as V
import qualified Data.Vector.Storable as V

import qualified Numeric.GSL.Histogram as H
--import qualified Numeric.GSL.Histogram2D as H2

import qualified Numeric.GSL.Distribution.Continuous as C

--import Numeric.LinearAlgebra.Algorithms
--import Numeric.LinearAlgebra.Interface()

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

vectorToTuples = toTuples . V.toList
    where toTuples []         = error "need a minimum of two elements"
          toTuples [_]        = error "need a minimum of two elements"
          toTuples [x1,x2]    = [(x1,x2)]
          toTuples (x1:x2:xs) = (x1,x2) : (toTuples (x2:xs))

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

cumulativeToHistogram :: (Double -> Double)   -- ^ the cumulative distribution function D(x <= X)
                   -> V.Vector Double        -- ^ the bins
                   -> H.Histogram            -- ^ the resulting histogram
cumulativeToHistogram f v = H.addListWeighted (H.emptyRanges v) $ map (\(x1,x2) -> ((x1 + x2) / 2.0,f x2 - f x1)) (vectorToTuples v)

gaussianHistogram :: Double               -- ^ mean
                  -> Double              -- ^ standard deviation
                  -> V.Vector Double     -- ^ the bins
                  -> H.Histogram         -- ^ the resulting histogram
gaussianHistogram u s = cumulativeToHistogram (\x -> C.density_1p C.Gaussian C.Lower s (x-u))

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


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ConstraintKinds #-}
module Noise(
      histogram
    , Structure(..)
    , quantizationNoise
    ) where

import qualified Statistics.Sample.Histogram as H
import qualified Data.Vector.Unboxed as U
import Plot
import Graphics.PDF
import Common
import Generators
import Signal
import System.Random
import Text.Printf

nbBins = 20

drawHist :: Int
         -> U.Vector Double
         -> U.Vector Double
         -> Int
         -> Int
         -> CoordinateMapping Double Double
         -> Draw ()
drawHist nb v b wi hi (toPoint,_) = do
    let binWidth :: Double
        binWidth = fromIntegral wi / fromIntegral nb
        d = binWidth / 2.0
        drawBin p = do
           fillColor (Rgb 0.8 0.8 1.0)
           let (x :+ y) = toPoint p
               r = Rectangle ((x - d) :+ 0) ((x + d) :+ y)
           fill r
           stroke r
           return ()
    mapM_ drawBin $ (U.toList $ U.zip v b)

histogram :: (U.Unbox a, HasDoubleRepresentation a)
          => [a]
          -> StyledSignal Double Double
histogram l = do
    let (s,v1) = H.histogram nbBins (U.fromList . map toDouble $ l)
        v = U.map (/ (U.sum v1)) v1
        nb = U.length s
        mas = U.maximum s
        mis = U.minimum s
        d = (mas - mis) / fromIntegral nb / 2.0
        detailed x = printf "%.2g" x
        style = defaultPlotStyle { title = Just "Histogram"
                                 , horizontalLabel = Nothing
                                 , verticalLabel = Nothing
                                 , horizontalBounds = Just (mis-d,mas+d)
                                 , verticalBounds = Just (U.minimum v, U.maximum v)
                                 , epilog = drawHist nb s v
                                 , axis = False
                                 , horizontalTickRepresentation = detailed
                                 }
    discreteSignalsWithStyle (U.length s) style []

class Structure m where
    doubleVersion :: (Sample i, Sample o) => m f i o -> m Double Double Double
    transferFunction :: (Sample i, Sample o) => m f i o -> Signal i -> Signal o

quantizationNoise :: (Structure m , Random i, Sample o, Sample i)
                  => Signal i
                  -> m p i o
                  -> IO (Signal Double)
quantizationNoise r structure = do
    let ds = transferFunction (doubleVersion structure) (mapS toDouble r)
        fs = mapS toDouble . transferFunction structure $ r
    return $ zipWithS (-) ds fs


{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ConstraintKinds #-}
module DSLsofMath.Algebra where
import qualified Data.Ratio
import qualified Prelude
import Prelude (Double, Rational, Int, Integer, Bool(..), otherwise,
                Foldable(foldr), (.), const, (==), (<), error)
import Data.Complex

-------------------------------
-- Classes
infixl 6 -
infixl 6 +

infixl 7 *
infixl 7 /

class Additive a where
  zero :: a
  (+) :: a -> a -> a

sum :: (Foldable t, Additive a) => t a -> a
sum = foldr (+) zero

times :: Additive a => Integer -> a -> a
times n0 = if n0 < 0  then  error "Algebra.Classes.times: negative number of times"
                      else  go n0
  where go 0 _ = zero
        go 1 x = x
        go n x = if r == 0 then twoy else x + twoy
          where (m,r) = n `Prelude.divMod` 2
                y = go m x
                twoy = y+y

(-) :: AddGroup a => a -> a -> a
x - y           =  x + negate y

class Additive a => AddGroup a where
  negate :: a -> a

mult :: AddGroup a => Integer -> a -> a
mult n x = if n < 0 then negate (times (negate n) x) else times n x

class Multiplicative a where
  one :: a
  (*) :: a -> a -> a

two :: (Additive a, Multiplicative a) => a
two = one+one

(^+) :: Multiplicative a => a -> Int -> a

x0 ^+ n0 = if n0 < 0  then  error "Algebra.Classes.^: negative exponent"
                      else  go n0 x0
  where go 0 _ = one
        go 1 x = x
        go n x = if r == 0 then y2 else x * y2
          where  (m,r) = n `Prelude.divMod` 2
                 y = go m x
                 y2 = y * y

type Ring a = (AddGroup a, Multiplicative a)

fromInteger :: Ring a => Integer -> a
fromInteger n = mult n one

class Multiplicative a => MulGroup a where
  {-# MINIMAL (recip | (/)) #-}
  recip :: a -> a
  recip x         =  one / x

  (/) :: a -> a -> a
  x / y           =  x * recip y

(^) :: MulGroup a => a -> Int -> a
a ^ b | b < 0      = recip (a ^+ (negate b))
      | otherwise  = (a ^+ b)

type Field a = (Ring a, MulGroup a)

fromRational :: Field a => Data.Ratio.Ratio Integer -> a
fromRational x  =  fromInteger (Data.Ratio.numerator x) / fromInteger (Data.Ratio.denominator x)

class Field a => Algebraic a where
  sqrt :: a -> a

-- normally it should be "Algebraic" instead of "Field" but we're lazy like that.
--   (Also Transcendental is a terrible name; taken from the "numeric prelude".)
class Field a => Transcendental a where
  pi  :: a
  exp :: a -> a
  sin :: a -> a
  cos :: a -> a

cosh, sinh :: Transcendental a => a -> a
cosh x = (exp x + exp (negate x))/two
sinh x = (exp x - exp (negate x))/two

---------------------------------
-- Instances

instance Additive        Int       where  (+)  = (Prelude.+);  zero  = 0
instance Additive        Integer   where  (+)  = (Prelude.+);  zero  = 0
instance Additive        Rational  where  (+)  = (Prelude.+);  zero  = 0
instance Additive        Double    where  (+)  = (Prelude.+);  zero  = 0

instance AddGroup        Int       where  negate = Prelude.negate
instance AddGroup        Integer   where  negate = Prelude.negate
instance AddGroup        Rational  where  negate = Prelude.negate
instance AddGroup        Double    where  negate = Prelude.negate

instance Multiplicative  Int       where  (*)  = (Prelude.*);  one   = 1
instance Multiplicative  Integer   where  (*)  = (Prelude.*);  one   = 1
instance Multiplicative  Rational  where  (*)  = (Prelude.*);  one   = 1
instance Multiplicative  Double    where  (*)  = (Prelude.*);  one   = 1

instance MulGroup        Rational  where  (/)  = (Prelude./);  recip = Prelude.recip
instance MulGroup        Double    where  (/)  = (Prelude./);  recip = Prelude.recip

lift0 ::  a         ->  (x->a)
lift1 :: (a->b)     ->  (x->a) -> (x->b)
lift2 :: (a->b->c)  ->  (x->a) -> (x->b) -> (x->c)
lift0 = const
lift1 = (.)
lift2 op2 f g = \x -> op2 (f x) (g x)

instance Additive a        => Additive        (x -> a) where (+)  = lift2 (+);  zero  = lift0 zero
instance Multiplicative a  => Multiplicative  (x -> a) where (*)  = lift2 (*);  one   = lift0 one

instance AddGroup a   => AddGroup   (x -> a)  where   negate  =  lift1 negate
instance MulGroup a   => MulGroup   (x -> a)  where   recip   =  lift1 recip
instance Algebraic a  => Algebraic  (x -> a)  where   sqrt    =  lift1 sqrt

instance Transcendental a => Transcendental (x -> a) where
   pi = lift0 pi;  sin = lift1 sin;  cos = lift1 cos;  exp = lift1 exp

instance Algebraic       Double where   sqrt = Prelude.sqrt
instance Transcendental  Double where
   pi = Prelude.pi;  sin = Prelude.sin;  cos = Prelude.cos;  exp = Prelude.exp

instance Additive a  => Additive        (Complex a) where  (+) = addC;  zero  = zeroC
instance Ring a      => Multiplicative  (Complex a) where  (*) = mulC;  one   = oneC
instance AddGroup a  => AddGroup        (Complex a) where  negate  = negateC
instance Field a     => MulGroup        (Complex a) where  recip   = recipC

addC :: Additive a => Complex a -> Complex a -> Complex a
addC (x :+ y) (x' :+ y') = (x + x') :+ (y+y')

negateC :: AddGroup a => Complex a -> Complex a
negateC (a :+ b) = negate a :+ negate b

mulC :: Ring a => Complex a -> Complex a -> Complex a
mulC (a :+ b) (a' :+ b') = (a * a' - b * b') :+ (a * b' + b * a')

toC :: Additive a => a -> Complex a
toC x = x :+ zero

zeroC :: Additive a => Complex a
zeroC = toC zero

oneC :: (Additive a, Multiplicative a) => Complex a
oneC = toC one

recipC (a :+ b) = (a / m)  :+ (negate b / m)
  where m = a*a + b*b

instance (Algebraic a, Prelude.RealFloat a) =>  Algebraic (Complex a) where
  sqrt = Prelude.sqrt

instance (Transcendental a) => Transcendental (Complex a) where
  pi = piC;  exp = expC;  sin = sinC;  cos = cosC

piC :: Transcendental a => Complex a
piC = toC pi

expC, sinC, cosC, sinhC, coshC :: Transcendental a => Complex a -> Complex a
expC   (x:+y)  =  expx  * cos y  :+ expx * sin y  where expx = exp x
sinC   (x:+y)  =  sin x * cosh y :+ cos x * sinh y
cosC   (x:+y)  =  cos x * cosh y :+ negate (sin x * sinh y)

sinhC  (x:+y)  =  cos y * sinh x :+ sin y * cosh x
coshC  (x:+y)  =  cos y * cosh x :+ sin y * sinh x

---------------------------------
-- For RebindableSyntax

ifThenElse :: Bool -> p -> p -> p
ifThenElse c a b = if c then a else b

-------------------------------
-- Typesetting aliases.

neg :: AddGroup a => a -> a
neg = negate   -- |neg| is used to typeset unary minus as a shorter dash, closer to its argument

frac :: MulGroup a => a -> a -> a
frac = (/)     -- |frac| is used to typeset a fraction (more compactly than |x / y|)


{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
-- |
-- Module    : Statistics.Distribution.ChiSquared
-- Copyright : (c) 2010 Alexey Khudyakov
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- The chi-squared distribution. This is a continuous probability
-- distribution of sum of squares of k independent standard normal
-- distributions. It's commonly used in statistical tests
module Statistics.Distribution.ChiSquared (
          ChiSquared
        -- Constructors
        , chiSquared
        , chiSquaredNDF
        ) where

import Data.Aeson (FromJSON, ToJSON)
import Data.Binary (Binary)
import Data.Data (Data, Typeable)
import GHC.Generics (Generic)
import Numeric.SpecFunctions (
  incompleteGamma,invIncompleteGamma,logGamma,digamma)

import qualified Statistics.Distribution         as D
import qualified System.Random.MWC.Distributions as MWC
import Data.Binary (put, get)

-- | Chi-squared distribution
newtype ChiSquared = ChiSquared Int
                     deriving (Eq, Read, Show, Typeable, Data, Generic)

instance FromJSON ChiSquared
instance ToJSON ChiSquared

instance Binary ChiSquared where
    get = fmap ChiSquared get
    put (ChiSquared x) = put x

-- | Get number of degrees of freedom
chiSquaredNDF :: ChiSquared -> Int
chiSquaredNDF (ChiSquared ndf) = ndf

-- | Construct chi-squared distribution. Number of degrees of freedom
--   must be positive.
chiSquared :: Int -> ChiSquared
chiSquared n
  | n <= 0    = error $
     "Statistics.Distribution.ChiSquared.chiSquared: N.D.F. must be positive. Got " ++ show n
  | otherwise = ChiSquared n

instance D.Distribution ChiSquared where
  cumulative = cumulative

instance D.ContDistr ChiSquared where
  density  = density
  quantile = quantile

instance D.Mean ChiSquared where
    mean (ChiSquared ndf) = fromIntegral ndf

instance D.Variance ChiSquared where
    variance (ChiSquared ndf) = fromIntegral (2*ndf)

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

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

instance D.Entropy ChiSquared where
  entropy (ChiSquared ndf) =
    let kHalf = 0.5 * fromIntegral ndf in
    kHalf
    + log 2
    + logGamma kHalf
    + (1-kHalf) * digamma kHalf

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

instance D.ContGen ChiSquared where
    genContVar (ChiSquared n) = MWC.chiSquare n

cumulative :: ChiSquared -> Double -> Double
cumulative chi x
  | x <= 0    = 0
  | otherwise = incompleteGamma (ndf/2) (x/2)
  where
    ndf = fromIntegral $ chiSquaredNDF chi

density :: ChiSquared -> Double -> Double
density chi x
  | x <= 0    = 0
  | otherwise = exp $ log x * (ndf2 - 1) - x2 - logGamma ndf2 - log 2 * ndf2
  where
    ndf  = fromIntegral $ chiSquaredNDF chi
    ndf2 = ndf/2
    x2   = x/2

quantile :: ChiSquared -> Double -> Double
quantile (ChiSquared ndf) p
  | p == 0         = 0
  | p == 1         = 1/0
  | p > 0 && p < 1 = 2 * invIncompleteGamma (fromIntegral ndf / 2) p
  | otherwise      =
    error $ "Statistics.Distribution.ChiSquared.quantile: p must be in [0,1] range. Got: "++show p


{-# LANGUAGE FlexibleContexts #-}
module PlotGreensFunctionR2S1 where

import           Data.Array.Repa         as R
import           Data.Complex
import           Data.List               as L
import           FokkerPlanck.MonteCarlo
import           Image.IO
import           System.Directory
import           System.Environment
import           System.FilePath
import           Text.Printf
import           Utils.Array

{-# INLINE reduceContrast #-}
reduceContrast
  :: (R.Source s Double)
  => Int -> Array s DIM3 Double -> Array D DIM3 Double
reduceContrast idx arr =
  let x = L.head . L.drop idx . L.reverse . L.sort . R.toList $ arr
  in R.map
       (\y ->
          if y >= x
            then x
            else y)
       arr

main = do
  args@(numPointStr:numOrientationStr:sigmaStr:taoStr:lenStr:initStr:numTrailStr:numThreadStr:_) <-
    getArgs
  print args
  let numPoint = read numPointStr :: Int
      numOrientation = read numOrientationStr :: Int
      sigma = read sigmaStr :: Double
      tao = read taoStr :: Double
      len = read lenStr :: Int
      numTrail = read numTrailStr :: Int
      numThread = read numThreadStr :: Int
  arr <-
    solveMonteCarloR2S1
      numThread
      numTrail
      numPoint
      numPoint
      numOrientation
      sigma
      tao
      numPoint
      ""
  let arr' =
        computeS .
        -- reduceContrast 10 .
        R.extend (Z :. (1 :: Int) :. All :. All) . R.sumS . rotate3D $
        arr
      folderPath = "output/app/PlotGreensFunctionR2S1"
  createDirectoryIfMissing True folderPath
  plotImageRepa (folderPath </> printf "GreensR2S1.png") . ImageRepa 8 $
    arr'


{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE TypeApplications #-}

module Lib.STFTSpec where

import           Data.Coerce
import           Data.Complex
import           Data.Proxy
import qualified Data.Vector     as V
import           GHC.TypeNats
import qualified Lib.STFT        as STFT
import qualified Lib.Util        as U
import           Test.Hspec
import           Test.QuickCheck

takeLast :: Int -> V.Vector a -> V.Vector a
takeLast n vec = V.reverse $ V.take n $ V.reverse vec

spec = do

  describe "STFT.hamming" $ do
    it "creates a hamming window of size N" $ do
      let result = V.fromList [8.000000000000002e-2 :+ 0.0,
              0.54 :+ 0.0,1.0 :+ 0.0,
              0.5400000000000001 :+ 0.0,
              8.000000000000002e-2 :+ 0.0
            ]
      STFT.runWindow STFT.hamming (STFT.MkWinsz (Proxy @5)) `shouldBe` result

  describe "STFT.zeroPhaseZeroPad" $ do
    it "peforms zero phase and zero padding" $ do
      tuple <- U.readWav "static/audio/singing-female.wav"
      let firstFive = V.fromList [(-0.553192138671875) :+ 0.0,
              (-0.55218505859375) :+ 0.0,
              (-0.556488037109375) :+ 0.0,
              (-0.58892822265625) :+ 0.0,
              (-0.610992431640625) :+ 0.0
            ]
          lastFive = V.fromList [(-0.443511962890625) :+ 0.0,
              (-0.479644775390625) :+ 0.0,
              (-0.49029541015625) :+ 0.0,
              (-0.493133544921875) :+ 0.0,
              (-0.52313232421875) :+ 0.0
            ]
          (_, audio) = U.makeSignal tuple
          result :: V.Vector (Complex Double)
          result = coerce $ STFT.zeroPhaseZeroPad (STFT.MkFFTsz (Proxy @2048)) audio
      V.take 5 result `shouldBe` firstFive
      takeLast 5 result `shouldBe` lastFive

  describe "STFT.dftAnal" $ do
    it "performs a dft of the given FFT size" $ do
      tuple <- U.readWav "static/audio/singing-female.wav"
      let firstFive = V.fromList [-12.049319770407699,
              -3.8232231987269523,
              -3.5161910098012816,
              -5.778847744891994,
              -4.450941161692169
            ]
          lastFive = V.fromList [9.085997084736617,
              12.384474935554943,
              11.667317158981483,
              20.354458129771224,
              11.951847223595225
            ]
          (_, audio) = U.makeSignal tuple
          (STFT.MkSpect (STFT.MkMag mag, _)) = STFT.dftAnal (STFT.MkFFTsz (Proxy @2048)) audio
      V.take 5 mag `shouldBe` firstFive
      takeLast 5 mag `shouldBe` lastFive

  describe "STFT.stft" $ do
    it "Performs the short time fourier transform" $ do
      (_, audio) <- U.readWav "static/audio/singing-female.wav"
      let firstFive = V.fromList [-95.55314985231192,
              -75.57780027962905,
              -72.63091749228488,
              -74.5060313038982,
              -80.35599835805851
            ]
          lastFive = V.fromList [-132.57867497788396,
              -128.76434452701437,
              -128.15973988408462,
              -131.54917075905306,
              -140.28246959896572
            ]
          (STFT.MkSpect (STFT.MkMag mag, _)) = head $ STFT.stft STFT.config (U.makeSig audio)
      V.take 5 mag `shouldBe` firstFive
      takeLast 5 mag `shouldBe` lastFive

  describe "STFT.divvy" $ do
    it "Splits the vector into " $ do
      let vec = V.replicate 272243 ()
          divvyVec = STFT.divvy (STFT.MkWinsz (Proxy @2048)) (STFT.MkHopsz (Proxy @256)) vec
      fmap length divvyVec `shouldBe` replicate 1056 2048


module Main where

import Graphics.Rendering.Chart.Backend.Diagrams (toFile)
import qualified Graphics.Rendering.Chart.Easy as Plt
import Numeric.GSL.ODE
import Numeric.LinearAlgebra

dynamics :: Double -> [Double] -> [Double]
dynamics _ [_, x1, w] =
  [ x1,
    - mass * g + k * w + cd * x1 ** 2,
    (torque - c * w) / j
  ]
  where
    -- timestep
    dt = 0.01
    -- Coefficient of drag
    cd = 0.1
    -- mass
    mass = 22
    -- gravity
    g = 9.8
    -- inertia
    j = 0.05
    -- Omega to thrust
    k = 5
    -- Coefficient of friction motor
    c = 0.1
    -- Calculate a physics based torque
    torque =
      clamp (-10, 10) $
        mass * g * j / (k * dt)
          - x1 / dt ** 2
          - w * j / dt
          + c * w
    -- Clamp between lower bound and upper bound
    clamp (lb, ub) x = max lb (min ub x)

dumbCopter :: IO ()
dumbCopter = toFile Plt.def "DumpCopter.svg" $ do
  let totalTime = 5
      dt = 0.01
      ts = linspace (round $ totalTime / dt) (0, totalTime)
      sol = odeSolve dynamics [0, -10, 0] ts
      [pos, vel, omega] = toColumns sol
      ts' = toList ts
  Plt.plot (Plt.line "pos" [zip ts' (toList pos)])
  Plt.plot (Plt.line "vel" [zip ts' (toList vel)])
  Plt.plot (Plt.line "omega" [zip ts' (toList omega)])

main :: IO ()
main = dumbCopter


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -Wall #-}

-- | Metric classes
module Plankton.Metric
  ( Signed(..)
  , Normed(..)
  , Metric(..)
  , Epsilon(..)
  , (≈)
  ) where

import Data.Complex (Complex(..))
import Plankton.Additive
import Plankton.Field
import Plankton.Multiplicative
import qualified Protolude as P
import Protolude
       (Bool(..), Double, Eq(..), Float, Int, Integer, Ord(..), ($), (&&))

-- | 'signum' from base is not an operator replicated in numhask, being such a very silly name, and preferred is the much more obvious 'sign'.  Compare with 'Norm' and 'Banach' where there is a change in codomain
--
-- > abs a * sign a == a
--
-- Generalising this class tends towards size and direction (abs is the size on the one-dim number line of a vector with its tail at zero, and sign is the direction, right?).
class (MultiplicativeUnital a) =>
      Signed a where
  sign :: a -> a
  abs :: a -> a

instance Signed Double where
  sign a =
    if a >= zero
      then one
      else negate one
  abs = P.abs

instance Signed Float where
  sign a =
    if a >= zero
      then one
      else negate one
  abs = P.abs

instance Signed Int where
  sign a =
    if a >= zero
      then one
      else negate one
  abs = P.abs

instance Signed Integer where
  sign a =
    if a >= zero
      then one
      else negate one
  abs = P.abs

-- | Like Signed, except the codomain can be different to the domain.
class Normed a b where
  size :: a -> b

instance Normed Double Double where
  size = P.abs

instance Normed Float Float where
  size = P.abs

instance Normed Int Int where
  size = P.abs

instance Normed Integer Integer where
  size = P.abs

instance (Multiplicative a, ExpField a, Normed a a) =>
         Normed (Complex a) a where
  size (rx :+ ix) = sqrt (rx * rx + ix * ix)

-- | distance between numbers
--
-- > distance a b >= zero
-- > distance a a == zero
-- > \a b c -> distance a c + distance b c - distance a b >= zero &&
-- >           distance a b + distance b c - distance a c >= zero &&
-- >           distance a b + distance a c - distance b c >= zero &&
class Metric a b where
  distance :: a -> a -> b

instance Metric Double Double where
  distance a b = abs (a - b)

instance Metric Float Float where
  distance a b = abs (a - b)

instance Metric Int Int where
  distance a b = abs (a - b)

instance Metric Integer Integer where
  distance a b = abs (a - b)

instance (Multiplicative a, ExpField a, Normed a a) =>
         Metric (Complex a) a where
  distance a b = size (a - b)

-- | todo: This should probably be split off into some sort of alternative Equality logic, but to what end?
class (AdditiveGroup a) =>
      Epsilon a where
  nearZero :: a -> Bool
  aboutEqual :: a -> a -> Bool
  positive :: (Eq a, Signed a) => a -> Bool
  positive a = a == abs a
  veryPositive :: (Eq a, Signed a) => a -> Bool
  veryPositive a = P.not (nearZero a) && positive a
  veryNegative :: (Eq a, Signed a) => a -> Bool
  veryNegative a = P.not (nearZero a P.|| positive a)

infixl 4 ≈

-- | todo: is utf perfectly acceptable these days?
(≈) :: (Epsilon a) => a -> a -> Bool
(≈) = aboutEqual

instance Epsilon Double where
  nearZero a = abs a <= (1e-12 :: Double)
  aboutEqual a b = nearZero $ a - b

instance Epsilon Float where
  nearZero a = abs a <= (1e-6 :: Float)
  aboutEqual a b = nearZero $ a - b

instance Epsilon Int where
  nearZero a = a == zero
  aboutEqual a b = nearZero $ a - b

instance Epsilon Integer where
  nearZero a = a == zero
  aboutEqual a b = nearZero $ a - b

instance (Epsilon a) => Epsilon (Complex a) where
  nearZero (rx :+ ix) = nearZero rx && nearZero ix
  aboutEqual a b = nearZero $ a - b


{-# LANGUAGE ScopedTypeVariables #-}

module Types
    ( Planet(..)
    , mass
    , diameter
    , pullOn
    , distance
    , distanceScale
    , alterSpeed
    , newPoint
    )
where

import           Numeric.LinearAlgebra

data Planet = Earth  | Jupiter deriving (Eq, Show)

type Point = (Float, Float)

mass :: Planet -> Int
mass Earth   = 5972
mass Jupiter = 1898000

distanceScale :: Float
distanceScale = 1000000

diameter :: Planet -> Integer
diameter Earth   = 12756000 -- m
diameter Jupiter = 142984000

distance :: Point -> Point -> Float
distance (aX, aY) (bX, bY) =
    let height  = abs (bY - aY)
        width   = abs (bX - aX)
        height2 = height ^ 2
        width2  = width ^ 2
    in  sqrt (height2 + width2) * distanceScale * 100 -- planets actual size so brag about distance

pullOn :: Planet -> Point -> Planet -> Point -> Vector Float -- a accelaration pointing out from a
pullOn on a from b =
    let
        gConstant = 15 * 10 ^ 12
        massA     = mass on
        massB     = mass from
        dist      = distance b a ^ 2
        forceScalar =
            (-gConstant * fromIntegral massA * fromIntegral massB) / dist
        accScalar = forceScalar / fromIntegral massA
    in
        scale accScalar (vectorize b a)

vectorize :: Point -> Point -> Vector Float
vectorize (ax, ay) (bx, by) = fromList [bx - ax, by - ay]

alterSpeed :: Vector Float -> Vector Float -> Vector Float
alterSpeed current pullForce = add current pullForce -- todo

newPoint :: Point -> Vector Float -> Point
newPoint (ax, ay) v = case toList v of
    [bx, by] -> (ax + bx, ay + by)
    x ->
        error
            $  "cannot create new point from speed vector with /= 2 elements "
            ++ show x


{-# LANGUAGE TypeApplications #-}

module Section_4_5 where

import MNIST
import Numeric.LinearAlgebra
import Section_4_5.TwoLayer

main :: IO ()
main = do
  putStrLn "Loading Labels..."
  (Labels _ labels)     <- getLabels @Training @OneHotLabel

  putStrLn "Loading Images..."
  (Images _ _ _ images) <- getImages @Training @FlattenImage True

  putStrLn "Creating Initial Network..."
  network <- initNetwork [784, 50, 10] [sigmoid, softmax]

  putStrLn "Picking Learning Data..."
  let label = vector $ map fromIntegral $ labels !! 10
      image = vector $ images !! 10

  putStrLn $ "Answer: " ++ show label

  putStrLn $ "Prediction before learning: " ++ show (predict network image)

  putStrLn "Learning Network..."
  let nw = updateNetwork loss [image] [label] network

  putStrLn $ "Prediction after learning: " ++ show (predict nw image)


{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
module Primitives.Math (primitives) where

import Data.Complex (Complex(..))
import Data.Functor ((<&>))
import Data.List (foldl', foldl1')
import Data.Ratio (approxRational)

import Val
import EvaluationMonad (throwError, panic)
import Types.Unwrappers (unwrapNum, unwrapRealNum, unwrapExactInteger)
import Primitives.Bool (predicate, predicateM)
import Primitives.Misc (valuesB)

addP, mulP, modP, quotP, remP :: Primitive
addP = numericBinop "+" (+) 0
mulP = numericBinop "*" (*) 1
modP = realBinop1 "mod" mod
quotP = realBinop1 "quotient" quot
remP = realBinop1 "remainder" rem

-- | Converts a (Haskell) builtin function on Integers to a 'Primitive'.
--   The primitive can only cause type errors;
--   Too many arguments will be folded over the operation;
--   none will use the default value.
numericBinop :: Symbol
             -> (Number -> Number -> Number)
             -> Number
             -> Primitive
numericBinop name op start = Prim name (AtLeast 0) $
  fmap (Number . foldl' op start) . mapM unwrapNum

-- | Same as numericBinop, except at least one arg must be given.
realBinop1 :: Symbol
              -> (RealNumber -> RealNumber -> RealNumber)
              -> Primitive
realBinop1 name op = Prim name (AtLeast 1) $
  fmap (Number . Real . foldl1' op) . mapM unwrapRealNum

guardDivZero :: Primitive -> Primitive
guardDivZero (Prim name arity f) = Prim name arity $ \args ->
    if any isExactZeroVal $ tail args
    then throwError $ Default "divide by zero"
    else f args
  where
    isExactZeroVal (Number n) = isExactZero n
    isExactZeroVal _ = False

-- | See the r7rs standard.
--
-- (- n) evaluates to -n, but (- x y z) evaluates to ((x - y) - z).
subP :: Primitive
subP = Prim "-" (AtLeast 1) $ \case
  [x]      -> Number . negate <$> unwrapNum x
  as@(_:_) -> Number . foldl1' (-) <$> mapM unwrapNum as
  _ -> panic "sub arity"

-- | r7rs: (/ n) is 1/n, (/ x y z) is ((x / y) / z)
divP :: Primitive
divP = guardDivZero $ Prim "/" (AtLeast 1) $ \case
  [] -> panic "div arity"
  [x] -> Number . (1 /) <$> unwrapNum x
  as  -> Number . foldl1' (/) <$> mapM unwrapNum as

negateP :: Primitive
negateP = Prim "negate" (Exactly 1) $
  \[x] -> Number . negate <$> unwrapNum x

numericPredicate :: Symbol -> (RealNumber -> Bool) -> Primitive
numericPredicate name p = predicateM name $ fmap p . unwrapRealNum

zeroCheck :: Primitive
zeroCheck = predicate "zero?" unwrapNum (== 0)

positiveCheck :: Primitive
positiveCheck = numericPredicate "positive?" (> 0)

negativeCheck :: Primitive
negativeCheck = numericPredicate "negative?" (< 0)

oddCheck :: Primitive
oddCheck = numericPredicate "odd?" $ (0 /=) . mod 2

evenCheck :: Primitive
evenCheck = numericPredicate "even?" $ (0 ==) . mod 2

-------------------------------------------------------------------------------
-- typically useful math operations
-------------------------------------------------------------------------------

inexactP :: Primitive
inexactP = Prim "inexact" (Exactly 1) $
  \[x] -> unwrapNum x <&> \case
    Real r -> Number $ Real $ realInexact r
    Complex (r :+ i) -> Number $ Complex $ realInexact r :+ realInexact i

rationalizeP :: Primitive
rationalizeP = Prim "rationalize" (Exactly 2) $
  \[x, eps] -> do
    rx <- unwrapRealNum x
    reps <- unwrapRealNum eps
    return $ Number $ Real $ Ratnum $ approxRational rx reps

squareP :: Primitive
squareP = Prim "square" (Exactly 1) $
  \[x] -> Number . (\n -> n*n) <$> unwrapNum x

-- | specialize ^ to Int powers
(^!) :: Num a => a -> Int -> a
x ^! n = x ^ n

exactIntegerSqrtP :: Primitive
exactIntegerSqrtP = Prim "exact-integer-sqrt" (Exactly 1) $
  \[k] -> do
    kN <- unwrapExactInteger k
    let root = squareRoot kN
        residual = kN - root ^! 2
    valuesB [makeBignum root, makeBignum residual]
  where
    -- This impl of the standard integer square root algorithm is from
    -- https://wiki.haskell.org/Generic_number_type#squareRoot
    squareRoot :: Integer -> Integer
    squareRoot 0 = 0
    squareRoot 1 = 1
    squareRoot n =
      let twopows = iterate (^! 2) 2
          (lowerRoot, lowerN) =
            last $ takeWhile ((n >=) . snd) $ zip (1:twopows) twopows
          newtonStep x = div (x + n `div` x) 2
          iters = iterate newtonStep (squareRoot (div n lowerN) * lowerRoot)
          isRoot r = r ^! 2 <= n && n < (r+1) ^! 2
       in head $ dropWhile (not . isRoot) iters

exptP :: Primitive
exptP = Prim "expt" (Exactly 2) $
  \[z1, z2] -> do
    z1' <- unwrapNum z1
    z2' <- unwrapNum z2
    return $ Number $ z1' ** z2'

-------------------------------------------------------------------------------
-- Complex functions
-------------------------------------------------------------------------------

makeRectangularP :: Primitive
makeRectangularP = Prim "make-rectangular" (Exactly 2) $
  \[x, y] -> do
    a <- unwrapRealNum x
    b <- unwrapRealNum y
    return $ Number $ Complex $ a :+ b

makePolarP :: Primitive
makePolarP = Prim "make-polar" (Exactly 2) $
  \[m, theta] -> do
    m' <- unwrapRealNum m
    theta' <- unwrapRealNum theta
    return $ Number $ Real m' * Complex (cos theta' :+ sin theta')

realPartP :: Primitive
realPartP = Prim "real-part" (Exactly 1) $
  \[z] -> unwrapNum z <&> \case
    Real r -> Number $ Real r
    Complex (r :+ _i) -> Number $ Real r

imagPartP :: Primitive
imagPartP = Prim "imag-part" (Exactly 1) $
  \[z] -> unwrapNum z <&> \case
    Real _r -> Number $ Real 0
    Complex (_r :+ i) -> Number $ Real i

magnitudeP :: Primitive
magnitudeP = Prim "magnitude" (Exactly 1) $
  \[z] -> Number . abs <$> unwrapNum z

angleP :: Primitive
angleP = Prim "angle" (Exactly 1) $
  \[z] -> unwrapNum z <&> \case
    Real r
      | r < 0 || isNegativeZero r -> Number pi
      | otherwise -> Number 0
    Complex (a :+ b) -> Number $ Real $ atan2 b a

liftFloatingMonop :: (Number -> Number) -> Builtin
liftFloatingMonop f = asBuiltin
  where asBuiltin [x] = do
          nx <- unwrapNum x
          return $ Number $ f nx
        asBuiltin _ = panic "liftFloatingMonop arity"

makeFloatingMonopPrim :: (Symbol, Number -> Number) -> Primitive
makeFloatingMonopPrim (name, f) = Prim name (Exactly 1) $ liftFloatingMonop f

floatingMonopPs :: [Primitive]
floatingMonopPs = map makeFloatingMonopPrim
  [ ("exp", exp)
  , ("sqrt", sqrt)
  , ("sin", sin)
  , ("cos", cos)
  , ("tan", tan)
  , ("asin", asin)
  , ("acos", acos)
  ]

logP :: Primitive
logP = Prim "log" (Between 1 2) $ \case
  [z] -> Number . log <$> unwrapNum z
  [z1, z2] -> do
    z1' <- unwrapNum z1
    z2' <- unwrapNum z2
    return $ Number $ logBase z2' z1'
  _ -> panic "logB arity"

atanP :: Primitive
atanP = Prim "atan" (Between 1 2) $ \case
  [z] -> Number . atan <$> unwrapNum z
  [y, x] -> do
    y' <- unwrapRealNum y
    x' <- unwrapRealNum x
    return $ Number $ Real $ atan2 y' x'
  _ -> panic "atanB arity"

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

primitives :: [Primitive]
primitives = [ addP
             , subP
             , mulP
             , divP
             , modP
             , quotP
             , remP
             , negateP
             , zeroCheck
             , positiveCheck
             , negativeCheck
             , oddCheck
             , evenCheck

             , inexactP
             , rationalizeP
             , atanP
             , exactIntegerSqrtP
             , squareP
             , exptP

             , makeRectangularP
             , makePolarP
             , realPartP, imagPartP
             , magnitudeP, angleP
             , logP
             ]
             ++ floatingMonopPs


module ECC.Estimate (estimate,showEstimate) where

import ECC.Types
import qualified Data.Vector.Unboxed as U
import Statistics.Sample (mean)
import Statistics.Resampling (resample, fromResample, Estimator(..))
import Statistics.Resampling.Bootstrap (bootstrapBCA)
import Statistics.Types (Estimate (..), ConfInt, mkCL, ConfInt(..), confidenceLevel)
import System.Random.MWC (create)
import System.Random.MWC
import Numeric

-- Estimate the lower and upper bounds, given a random generator state,
-- a confidence percentage, and a Bit Errors structure.

-- If there are to many samples (as often happens with good error correcting codes),
-- then we cheat, and combine samples.

estimate :: GenIO -> Double -> MessageLength -> BEs -> IO (Maybe (Estimate ConfInt Double))
estimate g confidence m_len bes
  | sumBEs bes == 0 = return Nothing
  | otherwise =
       -- 1000 is the default for criterion
       do resamples <- resample g [Mean] 1000 sampleU
--          print $ U.length $ fromResample $ head $ resamples
--          print resamples
          return $ Just $ head $ bootstrapBCA (mkCL confidence) sampleU {- [Mean] -} resamples
  where
    sample = map (\ be -> be / fromIntegral m_len)
           $ extractBEs bes
    sampleU = U.fromList sample

-- | Show estimate in an understandable format"
showEstimate :: Estimate ConfInt Double -> String
showEstimate est = showEFloat (Just 2) (estPoint est)
                 $ (" +" ++)
                 $ (if confIntLDX estErr == 0 then ("?" ++)
                    else showsPercent ((confIntUDX estErr) / (estPoint est)))
                 $ (" -" ++)
                 $ (if confIntUDX estErr == 0 then ("?" ++)
                    else showsPercent ((confIntLDX estErr) / (estPoint est)))
                 $ (" " ++)
                 $ showsPercent (confidenceLevel (confIntCL estErr))
                 $ ""
  where
    estErr = estError est

showsPercent f = shows (round (100 * f)) . ("%" ++)

-- (1 - (estLowerBound est) / (estPoint est))))


{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}
module Physics.Quaternion
  ( Quaternion(..)
  , Complicated(..)
  , Hamiltonian(..)
  , slerp
  , asinq
  , acosq
  , atanq
  , asinhq
  , acoshq
  , atanhq
  , absi
  , pow
  , rotate
  ) where

import Control.Applicative
import Control.Lens
import Control.Lens.Rep
import Data.Complex (Complex((:+)))
import Data.Data
import Data.Distributive
import Data.Foldable
import Data.Monoid
import Data.Traversable
import Physics.Epsilon
import Physics.Involutive
import Physics.Metric
import Physics.V3
import Physics.Vector
import Prelude hiding (any)

data Quaternion a = Quaternion a a a a deriving (Eq,Ord,Read,Show,Data,Typeable)

instance Functor Quaternion where
  fmap f (Quaternion e i j k) = Quaternion (f e) (f i) (f j) (f k)
  a <$ _ = Quaternion a a a a

instance Applicative Quaternion where
  pure a = Quaternion a a a a
  Quaternion f g h i <*> Quaternion a b c d = Quaternion (f a) (g b) (h c) (i d)

instance Monad Quaternion where
  return = pure
  (>>=) = bindRep

instance Representable Quaternion where
  rep f = Quaternion (f e) (f i) (f j) (f k)

instance Foldable Quaternion where
  foldMap f (Quaternion e i j k) = f e `mappend` f i `mappend` f j `mappend` f k
  foldr f z (Quaternion e i j k) = f e (f i (f j (f k z)))

instance Traversable Quaternion where
  traverse f (Quaternion e i j k) = Quaternion <$> f e <*> f i <*> f j <*> f k

instance RealFloat a => Num (Quaternion a) where
  {-# SPECIALIZE instance Num (Quaternion Float) #-}
  {-# SPECIALIZE instance Num (Quaternion Double) #-}
  (+) = liftA2 (+)
  (-) = liftA2 (-)
  negate = fmap negate
  Quaternion a1 b1 c1 d1 * Quaternion a2 b2 c2 d2 = Quaternion
    (a1*a2 - b1*b2 - c1*c2 - d1*d2)
    (a1*b2 + b1*a2 + c1*d2 - d1*c2)
    (a1*c2 - b1*d2 + c1*a2 + d1*b2)
    (a1*d2 + b1*c2 - c1*b2 + d1*a2)
  fromInteger x = Quaternion (fromInteger x) 0 0 0
  abs z = Quaternion (norm z) 0 0 0
  signum q@(Quaternion e i j k)
    | m == 0.0 = q
    | not (isInfinite m || isNaN m) = q ^/ sqrt m
    | any isNaN q = qNaN
    | not (ii || ij || ik) = Quaternion 1 0 0 0
    | not (ie || ij || ik) = Quaternion 0 1 0 0
    | not (ie || ii || ik) = Quaternion 0 0 1 0
    | not (ie || ii || ij) = Quaternion 0 0 0 1
    | otherwise = qNaN
    where
      m = quadrance q
      ie = isInfinite e
      ii = isInfinite i
      ij = isInfinite j
      ik = isInfinite k

  -- abs    = error "Quaternion.abs: use norm"
  -- signum = error "Quaternion.signum: use signorm"

qNaN :: RealFloat a => Quaternion a
qNaN = Quaternion fNaN fNaN fNaN fNaN where fNaN = 0/0

-- {-# RULES "abs/norm" abs x = Quaternion (norm x) 0 0 0 #-}
-- {-# RULES "signum/signorm" signum = signorm #-}

-- this will attempt to rewrite calls to abs to use norm intead when it is available.

instance RealFloat a => Fractional (Quaternion a) where
  {-# SPECIALIZE instance Fractional (Quaternion Float) #-}
  {-# SPECIALIZE instance Fractional (Quaternion Double) #-}
  Quaternion q0 q1 q2 q3 / Quaternion r0 r1 r2 r3 = Quaternion (r0*q0+r1*q1+r2*q2+r3*q3)
                                                               (r0*q1-r1*q0-r2*q3+r3*q2)
                                                               (r0*q2+r1*q3-r2*q0-r3*q1)
                                                               (r0*q3-r1*q2+r2*q1-r3*q0)
                                                 ^/ (r0*r0 + r1*r1 + r2*r2 + r3*r3)
  recip q = q ^/ quadrance q
  fromRational x = Quaternion (fromRational x) 0 0 0

instance Metric Quaternion where
  Quaternion e i j k `dot` Quaternion e' i' j' k' = e*e' + i*i' + j*j' + k*k'

class Complicated t where
  e :: Functor f => (a -> f a) -> t a -> f (t a)
  i :: Functor f => (a -> f a) -> t a -> f (t a)

instance Complicated Complex where
  e f (a :+ b) = (:+ b) <$> f a
  i f (a :+ b) = (a :+) <$> f b

instance Complicated Quaternion where
  e f (Quaternion a b c d) = (\a' -> Quaternion a' b c d) <$> f a
  i f (Quaternion a b c d) = (\b' -> Quaternion a b' c d) <$> f b

class Complicated t => Hamiltonian t where
  j :: Functor f => (a -> f a) -> t a -> f (t a)
  k :: Functor f => (a -> f a) -> t a -> f (t a)
  ijk :: Functor f => (V3 a -> f (V3 a)) -> t a -> f (t a)

instance Hamiltonian Quaternion where
  j f (Quaternion a b c d) = (\c' -> Quaternion a b c' d) <$> f c
  k f (Quaternion a b c d) = Quaternion a b c <$> f d

  ijk f (Quaternion a b c d) = (\(V3 b' c' d') -> Quaternion a b' c' d') <$> f (V3 b c d)

instance Distributive Quaternion where
  distribute f = Quaternion (fmap (^.e) f) (fmap (^.i) f) (fmap (^.j) f) (fmap (^.k) f)

instance (Involutive a, Num a) => Involutive (Quaternion a) where
  conjugate (Quaternion e i j k) = Quaternion (conjugate e) (-i) (-j) (-k)

reimagine :: RealFloat a => a -> a -> Quaternion a -> Quaternion a
reimagine r s (Quaternion _ i j k)
  | isNaN s || isInfinite s = Quaternion r
    (if i /= 0 then i * s else 0)
    (if j /= 0 then j * s else 0)
    (if k /= 0 then k * s else 0)
  | otherwise = Quaternion r (i * s)  (j * s) (k * s)

-- | quadrance of the imaginary component
qi :: Num a => Quaternion a -> a
qi (Quaternion _ i j k) = i*i + j*j + k*k

absi :: Floating a => Quaternion a -> a
absi = sqrt . qi

pow :: RealFloat a => Quaternion a -> a -> Quaternion a
pow q t = exp (t *^ log q)

-- ehh..
instance RealFloat a => Floating (Quaternion a) where
  {-# SPECIALIZE instance Floating (Quaternion Float) #-}
  {-# SPECIALIZE instance Floating (Quaternion Double) #-}
  pi = Quaternion pi 0 0 0
  exp q@(Quaternion e i j k)
    | qiq == 0 = Quaternion (exp e) i j k
    | ai <- sqrt qiq, ee <- exp e = reimagine (ee * cos ai) (ee * (sin ai / ai)) q
    where qiq = qi q
  log q@(Quaternion e i j k)
    | qiq == 0 = if e >= 0 then Quaternion (log e) i j k else Quaternion (log (negate e)) pi j k -- mmm, pi
    | ai <- sqrt qiq, m <- sqrt (e*e + qiq) = reimagine (log m) (atan2 m e / ai) q
    where qiq = qi q
  x ** y = exp (y * log x)
  sqrt q@(Quaternion e i j k)
    | m   == 0 = q
    | qiq == 0 = if e > 0 then Quaternion (sqrt e) 0 0 0 else Quaternion 0 (sqrt (negate e)) 0 0
    | im <- sqrt (0.5*(m-e)) / sqrt qiq = Quaternion (0.5*(m+e)) (i*im) (j*im) (k*im)
    where qiq = qi q
          m = sqrt (e*e + qiq)
  cos q@(Quaternion e i j k)
    | qiq == 0 = Quaternion (cos e) i j k
    | ai <- sqrt qiq = reimagine (cos e * cosh ai) (- sin e * (sinh ai / ai)) q
    where qiq = qi q
  sin q@(Quaternion e i j k)
    | qiq == 0 = Quaternion (sin e) i j k
    | ai <- sqrt qiq = reimagine (sin e * cosh ai) (cos e * (sinh ai / ai)) q
    where qiq = qi q
  tan q@(Quaternion e i j k)
    | qiq == 0 = Quaternion (tan e) i j k
    | ai <- sqrt qiq, ce <- cos e, sai <- sinh ai, d <- ce*ce + sai*sai =
      reimagine (ce * sin e / d) (cosh ai * (sai / ai) / d) q
    where qiq = qi q
  sinh q@(Quaternion e i j k)
    | qiq == 0 = Quaternion (sinh e) i j k
    | ai <- sqrt qiq = reimagine (sinh e * cos ai) (cosh e * (sin ai / ai)) q
    where qiq = qi q
  cosh q@(Quaternion e i j k)
    | qiq == 0 = Quaternion (cosh e) i j k
    | ai <- sqrt qiq = reimagine (cosh e * cos ai) ((sinh e * sin ai) / ai) q
    where qiq = qi q
  tanh q@(Quaternion e i j k)
    | qiq == 0 = Quaternion (tanh e) i j k
    | ai <- sqrt qiq, se <- sinh e, cai <- cos ai, d <- se*se + cai*cai =
      reimagine ((cosh e * se) / d) ((cai * (sin ai / ai)) / d) q
    where qiq = qi q

  asin q = cut asin q
  acos q = cut acos q
  atan q = cut atan q

  asinh q = cut asinh q
  acosh q = cut acosh q
  atanh q = cut atanh q

cut :: RealFloat a => (Complex a -> Complex a) -> Quaternion a -> Quaternion a
cut f q@(Quaternion e _ j k)
  | qiq == 0 = Quaternion a b j k
  | otherwise = reimagine a (b / ai) q
  where qiq = qi q
        ai = sqrt qiq
        a :+ b = f (e :+ ai)

cutWith :: RealFloat a => Complex a -> Quaternion a -> Quaternion a
cutWith (r :+ im) q@(Quaternion e i j k)
  | e /= 0 || qiq == 0 || isNaN qiq || isInfinite qiq = error "bad cut"
  | s <- im / sqrt qiq = Quaternion r (i*s) (j*s) (k*s)
  where qiq = qi q

asinq :: RealFloat a => Quaternion a -> Quaternion a -> Quaternion a
asinq q@(Quaternion e _ _ _) u
  | qiq /= 0.0 || e >= -1 && e <= 1 = asin q
  | otherwise = cutWith (asin (e :+ sqrt qiq)) u
  where qiq = qi q

acosq :: RealFloat a => Quaternion a -> Quaternion a -> Quaternion a
acosq q@(Quaternion e _ _ _) u
  | qiq /= 0.0 || e >= -1 && e <= 1 = acos q
  | otherwise = cutWith (acos (e :+ sqrt qiq)) u
  where qiq = qi q

atanq :: RealFloat a => Quaternion a -> Quaternion a -> Quaternion a
atanq q@(Quaternion e _ _ _) u
  | e /= 0.0 || qiq >= -1 && qiq <= 1 = atan q
  | otherwise = cutWith (atan (e :+ sqrt qiq)) u
  where qiq = qi q

asinhq :: RealFloat a => Quaternion a -> Quaternion a -> Quaternion a
asinhq q@(Quaternion e _ _ _) u
  | e /= 0.0 || qiq >= -1 && qiq <= 1 = asinh q
  | otherwise = cutWith (asinh (e :+ sqrt qiq)) u
  where qiq = qi q

acoshq :: RealFloat a => Quaternion a -> Quaternion a -> Quaternion a
acoshq q@(Quaternion e _ _ _) u
  | qiq /= 0.0 || e >= 1 = asinh q
  | otherwise = cutWith (acosh (e :+ sqrt qiq)) u
  where qiq = qi q

atanhq :: RealFloat a => Quaternion a -> Quaternion a -> Quaternion a
atanhq q@(Quaternion e _ _ _) u
  | qiq /= 0.0 || e > -1 && e < 1 = atanh q
  | otherwise = cutWith (atanh (e :+ sqrt qiq)) u
  where qiq = qi q

slerp :: RealFloat a => Quaternion a -> Quaternion a -> a -> Quaternion a
slerp q p t
  | 1.0 - cosphi < 1e-8 = q
  | phi <- acos cosphi, r <- recip (sin phi)
  = (sin ((1-t)*phi)*r *^ q ^+^ f (sin (t*phi)*r) *^ p) ^/ sin phi
  where
   dqp = dot q p
   (cosphi, f) = if dqp < 0 then (-dqp, negate) else (dqp, id)
{-# SPECIALIZE slerp :: Quaternion Float -> Quaternion Float -> Float -> Quaternion Float #-}
{-# SPECIALIZE slerp :: Quaternion Double -> Quaternion Double -> Double -> Quaternion Double #-}

--slerp :: RealFloat a => Quaternion a -> Quaternion a -> a -> Quaternion a
--slerp q0 q1 = let q10 = q1 / q0 in \t -> pow q10 t * q0

rotate :: Num a => Quaternion a -> V3 a -> V3 a
rotate (Quaternion a' b c d) (V3 x y z) = V3
  (2*((t8+t10)*x+(t6- t4)*y+(t3+t7)*z)+x)
  (2*((t4+ t6)*y+(t5+t10)*y+(t9-t2)*z)+y)
  (2*((t7- t3)*z+(t2+ t9)*z+(t5+t8)*z)+z)
  where
    a = -a'
    t2 = a*b
    t3 = a*c
    t4 = a*d
    t5 = -b*b
    t6 = b*c
    t7 = b*d
    t8 = -c*c
    t9 = c*d
    t10 = -d*d
{-# SPECIALIZE rotate :: Quaternion Float -> V3 Float -> V3 Float #-}
{-# SPECIALIZE rotate :: Quaternion Double -> V3 Double -> V3 Double #-}

instance (RealFloat a, Epsilon a) => Epsilon (Quaternion a) where
  nearZero = nearZero . quadrance