-- |
-- Module      :  DirichletSpec
-- Description :  Unit tests for DirichletSpec
-- Copyright   :  (c) Dominik Schrempf, 2021
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Tue Oct 20 10:40:06 2020.
module Statistics.Distribution.DirichletSpec
  ( spec,
  )
where

import Control.Monad
import Data.Either
import qualified Data.Vector.Unboxed as V
import Numeric.Log hiding (sum)
import Statistics.Distribution.Dirichlet
import Test.Hspec
import System.Random.MWC

eps :: Double
eps = 1e-14

dd3 :: DirichletDistribution
dd3 = either error id $ dirichletDistribution $ V.fromList [0.2, 10, 20]

alphas10 :: V.Vector Double
alphas10 = V.fromList [0.1, 0.2, 0.3, 0.4, 0.5, 16, 17, 18, 19, 20]

dd10 :: DirichletDistribution
dd10 = either error id $ dirichletDistribution alphas10

ddSym :: Int -> Double -> DirichletDistribution
ddSym n a = either error id $ dirichletDistribution $ V.replicate n a

-- Extract means.
xbar :: Int -> [V.Vector Double] -> Double
xbar n xss = sum xs / fromIntegral (length xs)
  where xs = map (V.! n) xss

spec :: Spec
spec = do
  describe "dirichletDistribution" $ do
    it "only works for valid parameter vectors" $ do
      dirichletDistribution (V.fromList []) `shouldSatisfy` isLeft
      dirichletDistribution (V.fromList [1]) `shouldSatisfy` isLeft
      dirichletDistribution (V.fromList [-3, 3, 192]) `shouldSatisfy` isLeft
      dirichletDistribution (V.fromList [0, 3, 192]) `shouldSatisfy` isLeft
  describe "dirichletDensity" $ do
    it "is correct for some test cases" $ do
      let ddSym2 = ddSym 2 0.5
      let r = dirichletDensity ddSym2 (V.fromList [0.2, 0.8])
      abs (exp (ln r) - 0.7957747154594766) `shouldSatisfy` (< eps)
      let rBound = dirichletDensity ddSym2 (V.fromList [0, 1])
      rBound `shouldBe` 0
      let rOutBound1 = dirichletDensity ddSym2 (V.fromList [0, 1.1])
      rOutBound1 `shouldBe` 0
      let rOutBound2 = dirichletDensity ddSym2 (V.fromList [-0.1, 0.9])
      rOutBound2 `shouldBe` 0
      let r3 = dirichletDensity dd3 (V.fromList [0.3, 0.3, 0.4])
      abs (exp (ln r3) - 0.0001217825570884453) `shouldSatisfy` (< eps)
      let rWrongDim = dirichletDensity dd3 (V.fromList [0.3, 0.7])
      rWrongDim `shouldBe` 0
  describe "dirichletSample" $ do
    it "returns valid value vectors with expected mean" $ do
      g <- create
      let ddSym10 = ddSym 10 10
      xs <- replicateM 1000 (dirichletSample ddSym10 g)
      map V.length xs `shouldBe` replicate 1000 10
      -- print [ xbar i xs | i <- [0..9]]
      [ abs (xbar i xs - 0.1) > 0.01 | i <- [0..9]] `shouldBe` replicate 10 False
      xs' <- replicateM 1000 (dirichletSample dd10 g)
      map V.length xs' `shouldBe` replicate 1000 10
      -- print [ xbar i xs | i <- [0..9]]
      let aSum = V.sum alphas10
      [ abs (xbar i xs' - (alphas10 V.! i / aSum)) > 0.01 | i <- [0..9]] `shouldBe` replicate 10 False


--
-- ActLayer: activate layer
--

module CNN.ActLayer (
  relu
, relu'
, step
, softmax
, activate
, deactivate
, reverseActFunc
, funcToNum
, numToFunc
) where

import Numeric.LinearAlgebra hiding (step)
import CNN.Algebra
import CNN.Image
import CNN.LayerType

{- |
step

  IN : matrix

  OUT: matrix

>>> let m = fromLists [[1.0, 0.0, (-1.1), (-0.5), 2.1]] :: Matrix R
>>> step m
(1><5)
 [ 1.0, 0.0, 0.0, 0.0, 1.0 ]

-}

step :: ActFunc
step = cmap f
  where
    f :: Double -> Double
    f a = if a > 0.0 then 1.0 else 0.0

{- |
relu

  IN : array of Double

  OUT: array of Double

>>> relu $ fromLists [[1.0, 0.0, (-1.1), (-0.5), 2.1]]
(1><5)
 [ 1.0, 0.0, 0.0, 0.0, 2.1 ]

-}

relu :: ActFunc
relu = cmap (`max` 0.0)

{- |
relu'

  IN : array of Double

  OUT: array of Double

>>> relu' $ fromLists [[1.0, 0.0, (-1.1), (-0.5), 2.1]]
(1><5)
 [ 1.0, 0.0, 0.0, 0.0, 1.0 ]

-}

relu' :: ActFunc
relu' = cmap (\x -> if x > 0.0 then 1.0 else 0.0)

{- |
softmax

  IN : array of Double

  OUT: normalized array of Double

>>> let a1 = softmax $ fromLists [[1.0, 1.0, 1.0]]
>>> (a1 `atIndex` (0,0)) * 3.0
1.0
>>> let a2 = softmax $ fromLists [[1.0, 3.0, 2.0]]
>>> (a2 `atIndex` (0,0)) < (a2 `atIndex` (0,1))
True
>>> (a2 `atIndex` (0,0)) < (a2 `atIndex` (0,2))
True
>>> (a2 `atIndex` (0,1)) > (a2 `atIndex` (0,2))
True
-}

softmax :: ActFunc
softmax as = mscale (1.0 / sume) es
  where
    amax = maxElement as
    es   = cmap (\x -> exp (x - amax)) as
    sume = sumElements es

{-
activate

  IN : activation function
       image

  OUT: calculated image

-}

activate :: ActFunc -> Image -> Image
activate f = map f

{- |
deactivate

  IN : activation function
       image
       difference from previous layer

  OUT: difference and updated layer

>>> fst $ deactivate relu [fromLists [[1.5,(-2.0)]]] [fromLists [[0.5,0.1]]]
[(1><2)
 [ 0.5, 0.0 ]]

-}

m0 :: Matrix R
m0 = fromLists [[0.0]]
m1 :: Matrix R
m1 = fromLists [[1.0]]

deactivate :: ActFunc -> Image -> Delta -> (Delta, Maybe Layer)
deactivate f im delta
  | c == m0   = (dl', Nothing)
  | c == m1   = ([] , Nothing)
  | otherwise = ([] , Nothing)
  where
    c = f m0
    f' = map relu' im
    dl' = zipWith (*) delta f'

reverseActFunc :: ActFunc -> Layer
reverseActFunc relu = ActLayer step

{- |
>>> funcToNum step
0
>>> funcToNum relu
1
-}

funcToNum :: ActFunc -> Int
funcToNum f = case f of
  step    -> 0
  relu    -> 1
  relu'   -> 2
  softmax -> 3
  _       -> error ("invalid function")

numToFunc :: Int -> ActFunc
numToFunc i = case i of
  0 -> step
  1 -> relu
  2 -> relu'
  3 -> softmax
  _ -> error ("invalid function number: " ++ (show i))


{-# LANGUAGE FlexibleContexts #-}

module RandomUtil.RandomMatrix
  (
    selectRandomMatrixElement
  , randomMatrixIndex
  , randomizeRandomMatrixElement
  , addGaussianNoiseToMatrixElement
  , addGaussianNoiseToRandomMatrixElement
  , randomNMatrixElements
  , RandomMatrixMutation
  ) where

import System.Random
import Data.Random.Normal
import Matrix.State
import Numeric.LinearAlgebra.HMatrix hiding (corr)

import Util.Tuples

type RandomMatrixMutation g a = g -> Matrix a -> (Matrix a, g)
type RandomMatrixIndex g = (MatrixIndex, g)

randomMatrixIndex :: RandomGen g => g -> Matrix a -> RandomMatrixIndex g
randomMatrixIndex gen m = let (i, gen')  = randomR (0, (rows m) - 1) gen
                              (j, gen'') = randomR (0, (cols m) - 1) gen'
                           in ((i,j), gen'')

selectRandomMatrixElement :: (Element a, Indexable (Vector a) a, RandomGen g)
  => g -> Matrix a -> (a, g)
selectRandomMatrixElement gen m = let (i, gen') = randomMatrixIndex gen m
                                  in (getElement m i, gen')

randomizeRandomMatrixElement :: (Element a, Random a, RandomGen g)
  =>  (a,a) -> RandomMatrixMutation g a
randomizeRandomMatrixElement bounds gen m = let (i, gen')  = randomMatrixIndex gen m
                                                (e, gen'') = randomR bounds gen'
                                            in (replaceMatrixElement i e m, gen'')

type Mean = Double
type Sigma = Double
addGaussianNoiseToRandomMatrixElement :: RandomGen g =>  Mean -> Sigma -> RandomMatrixMutation g Double
addGaussianNoiseToRandomMatrixElement u s gen m =
  let (i,gen') = randomMatrixIndex gen m
  in addGaussianNoiseToMatrixElement i u s gen' m

addGaussianNoiseToMatrixElement :: RandomGen g
  => MatrixIndex -> Mean -> Sigma -> RandomMatrixMutation g Double
addGaussianNoiseToMatrixElement index u s gen m =
  let (sample, gen') = normal' (u,s) gen
  in (applyFMatrixElement (+ sample) index m, gen')

randomNMatrixElements :: (Element a, Random a, RandomGen g)
  => Int -> RandomMatrixMutation g a -> RandomMatrixMutation g a
randomNMatrixElements 0 _ gen m = (m, gen)
randomNMatrixElements n f gen m = let (m', gen') = f gen m
                                  in randomNMatrixElements (n-1) f gen' m'


module Day10.Day10 where

import           Data.Complex
import qualified Data.Set                      as S
import           Data.List
import           Lib
import qualified Data.List.Key                 as K
import           Data.Ord

type Asteroid = Complex Float

toCoords :: [String] -> [(Float, Float)]
toCoords input =
  [ (x, y) | (row, y) <- zip input [0 ..], (s, x) <- zip row [0 ..], s == '#' ]

parse :: [(Float, Float)] -> [Asteroid]
parse coords = [ x :+ y | (x, y) <- coords ]

genPolarCoords :: [Asteroid] -> [([Complex Float], Complex Float)]
genPolarCoords asteroids = map
  (\asteroid1 ->
    ( filter (\x -> x /= 0 :+ 0)
      $ map (\asteroid2 -> asteroid2 - asteroid1) asteroids
    , asteroid1
    )
  )
  asteroids

highest :: [([Complex Float], Complex Float)] -> ([Complex Float], Complex Float)
highest = K.maximum (length . S.fromList . map normalizePhase . fst)

normalizePhase :: Complex Float -> Float
normalizePhase x =
  let y = phase x
  in  if y < (-0.5) * pi
        then 2.5 * pi + y
        else 0.5 * pi + y

day10 :: IO ()
day10 = do
  contents <- fileContents "/src/Day10/input.txt"
  let coords               = toCoords (lines contents)
      asteroids            = genPolarCoords $ parse coords
      (bestStation, index) = highest asteroids
      sortOrder = mconcat [comparing normalizePhase, comparing magnitude]
      rows                 = length $ head $ lines contents
      groupedAsteroids =
        groupBy (\x y -> normalizePhase x == normalizePhase y)
          $ sortBy sortOrder bestStation
  print $ length groupedAsteroids
  print $ index + (head $ groupedAsteroids !! 199)


{-# LANGUAGE RebindableSyntax, TypeSynonymInstances #-}
module DSLsofMath.W08 where
import Prelude hiding (Num(..),(/),(^),Fractional(..),Floating(..),sum)
import DSLsofMath.W05
import qualified DSLsofMath.W06
import DSLsofMath.W06 (Taylor, integ, sinx, sinf, cosx, cosf)
import DSLsofMath.Algebra
import Data.Complex

expx :: Field a => PowerSeries a
expx = integ 1 expx

expf :: Field a => a -> a
expf = evalPS 100 expx

i :: Ring a => Complex a
i = zero :+ one

ex1 :: Field a => Complex a
ex1 = expf i

compScale :: Ring a => a -> PowerSeries a -> PowerSeries a
compScale c (Poly as) = Poly (zipWith (*) as (iterate (c*) 1))

type PSC a = PowerSeries (Complex a)
expix :: Field a => PSC a
expix = compScale i expx

cosxisinx :: Field a => PSC a
cosxisinx = cosx + Poly [i] * sinx

ex2, ex2' :: Field a => PSC a
ex2   = takePoly 8 expix
ex2'  = takePoly 8 cosxisinx

test2 :: Bool
test2 = ex2 == (ex2' :: PSC Rational)

check2 :: Bool
check2 = ex2 == coeff2

coeff2 ::  PSC Rational
coeff2 =   Poly [      1            :+ 0, {-"\qquad"-}  0 :+     1,
                   (-  1  /  2)     :+ 0, {-"\qquad"-}  0 :+ (-  1  /  6),
                       1  /  24     :+ 0, {-"\qquad"-}  0 :+     1  /  120,
                   (-  1  /  720)   :+ 0, {-"\qquad"-}  0 :+ (-  1  /  5040)]

ex2R :: Poly Rational
ex2R = takePoly 8 cosx

ex2I :: Poly Rational
ex2I = takePoly 8 sinx

derivT :: Taylor a -> Taylor a
derivT = tail

integT :: a -> Taylor a -> Taylor a
integT = (:)

val ::  Additive a => Taylor a  ->  a
val (a:_)   =   a
val _       =   zero

expT, sinT, cosT :: Transcendental a => Taylor a -> Taylor a
expT  as  = integT  (exp  (val as))  (expT as   * derivT as)
sinT  as  = integT  (sin  (val as))  (cosT as   * derivT as)
cosT  as  = integT  (cos  (val as))  (-sinT as  * derivT as)

instance Transcendental a => Transcendental (Taylor a) where
   pi   =  [pi]; exp  =  expT;  sin  =  sinT;  cos  =  cosT

instance Field a => MulGroup (Taylor a) where
  recip = recipStream

recipStream :: Field a => Taylor a -> Taylor a
recipStream [] = error "recipStream: divByZero"
recipStream (f0:f') = g
  where  g   = g0:g'
         g0  = recip f0
         g'  = negate (f' * g*g)

expTx :: Taylor REAL
expTx = expT [0,1]
testExpT = take 5 expTx == [1.0, 1.0, 1.0, 1.0, 1.0]

expix3 :: Taylor (Complex Double)
expix3 = exp (i * x)            where  i  = [0 :+ 1]; x  = [0,1]

ex2alt3 = take 10 expix3
testex2alt3 = ex2alt3 ==  take 10 (concat (repeat [1, i, -1, -i]))

cosxisinx3 :: Taylor (Complex Double)
cosxisinx3 = cos x + i * sin x  where  i  = [0 :+ 1];  x  = [0,1]

ex2'alt3 = take 10 cosxisinx3

fs :: Field a => PowerSeries a
fs = integ 1 fs'
   where  fs'   = integ 0 fs''
          fs''  = exp3x + 3 * fs' - 2 * fs
exp3x :: Field a => PowerSeries a
exp3x = compScale 3 expx


{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving  #-}
{-# LANGUAGE TypeOperators       #-}

import Control.Monad
import Control.Monad.Random
import Data.List
import Data.Maybe
import Data.Singletons
import Data.Singletons.Prelude
import Data.Singletons.TypeLits
import Numeric.LinearAlgebra.Static
import System.Environment
import Text.Read

data Weights i o = W { wBiases :: !(R o)
                     , wNodes  :: !(L o i)
                     }                      -- an "o x i" layer

data Network :: Nat -> [Nat] -> Nat -> * where
    O     :: !(Weights i o)
          -> Network i '[] o
    (:&~) :: KnownNat h
          => !(Weights i h)
          -> !(Network h hs o)
          -> Network i (h ': hs) o
infixr 5 :&~

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

logistic' :: Floating a => a -> a
logistic' x = logix * (1 - logix)
  where
    logix = logistic x

runLayer :: (KnownNat i, KnownNat o)
         => Weights i o
         -> R i
         -> R o
runLayer (W wB wN) v = wB + wN #> v

runNet :: (KnownNat i, KnownNat o)
       => Network i hs o
       -> R i
       -> R o
runNet = \case
   O w -> \(!v) -> logistic (runLayer w v)
   (w :&~ n') -> \(!v) -> let v' = logistic (runLayer w v)
                          in runNet n' v'

randomWeights :: (MonadRandom m, KnownNat i, KnownNat o)
              => m (Weights i o)
randomWeights = do
    s1 :: Int <- getRandom
    s2 :: Int <- getRandom
    let wB = randomVector  s1 Uniform * 2 - 1
        wN = uniformSample s2 (-1) 1
    return $ W wB wN

randomNet :: forall m i hs o. (MonadRandom m, KnownNat i, SingI hs, KnownNat o)
          => m (Network i hs o)
randomNet = go sing
  where
    go :: forall h hs'. KnownNat h
       => Sing hs'
       -> m (Network h hs' o)
    go = \case
        SNil            ->     O <$> randomWeights
        SNat `SCons` ss -> (:&~) <$> randomWeights <*> go ss

train :: forall i hs o. (KnownNat i, KnownNat o)
      => Double           -- ^ learning rate
      -> R i              -- ^ input vector
      -> R o              -- ^ target vector
      -> Network i hs o   -- ^ network to train
      -> Network i hs o
train rate x0 target = fst . go x0
  where
    go  :: forall j js. KnownNat j
        => R j              -- ^ input vector
        -> Network j js o   -- ^ network to train
        -> (Network j js o, R j)
    go !x (O w@(W wB wN))
        = let y    = runLayer w x
              o    = logistic y
              -- the gradient (how much y affects the error)
              --   (logistic' is the derivative of logistic)
              dEdy = logistic' y * (o - target)
              -- new bias weights and node weights
              wB'  = wB - konst rate * dEdy
              wN'  = wN - konst rate * (dEdy `outer` x)
              w'   = W wB' wN'
              -- bundle of derivatives for next step
              dWs  = tr wN #> dEdy
          in  (O w', dWs)
    -- handle the inner layers
    go !x (w@(W wB wN) :&~ n)
        = let y          = runLayer w x
              o          = logistic y
              -- get dWs', bundle of derivatives from rest of the net
              (n', dWs') = go o n
              -- the gradient (how much y affects the error)
              dEdy       = logistic' y * dWs'
              -- new bias weights and node weights
              wB'  = wB - konst rate * dEdy
              wN'  = wN - konst rate * (dEdy `outer` x)
              w'   = W wB' wN'
              -- bundle of derivatives for next step
              dWs  = tr wN #> dEdy
          in  (w' :&~ n', dWs)

netTest :: MonadRandom m => Double -> Int -> m String
netTest rate n = do
    inps <- replicateM n $ do
      s <- getRandom
      return $ randomVector s Uniform * 2 - 1
    let outs = flip map inps $ \v ->
                 if v `inCircle` (fromRational 0.33, 0.33)
                      || v `inCircle` (fromRational (-0.33), 0.33)
                   then fromRational 1
                   else fromRational 0
    net0 :: Network 2 '[16, 8] 1 <- randomNet
    let trained = foldl' trainEach net0 (zip inps outs)
          where
            trainEach :: (KnownNat i, SingI hs, KnownNat o)
                      => Network i hs o
                      -> (R i, R o)
                      -> Network i hs o
            trainEach nt (i, o) = train rate i o nt

        outMat = [ [ render (norm_2 (runNet trained (vector [x / 25 - 1,y / 10 - 1])))
                   | x <- [0..50] ]
                 | y <- [0..20] ]
        render r | r <= 0.2  = ' '
                 | r <= 0.4  = '.'
                 | r <= 0.6  = '-'
                 | r <= 0.8  = '='
                 | otherwise = '#'

    return $ unlines outMat
  where
    inCircle :: KnownNat n => R n -> (R n, Double) -> Bool
    v `inCircle` (o, r) = norm_2 (v - o) <= r

main :: IO ()
main = do
    args <- getArgs
    let n    = readMaybe =<< (args !!? 0)
        rate = readMaybe =<< (args !!? 1)
    putStrLn "Training network..."
    putStrLn =<< evalRandIO (netTest (fromMaybe 0.25   rate)
                                     (fromMaybe 500000 n   )
                            )

(!!?) :: [a] -> Int -> Maybe a
xs !!? i = listToMaybe (drop i xs)

-- * Exercises
--

popLayer :: Network i (h ': hs) o -> (Weights i h, Network h hs o)
popLayer (w :&~ n) = (w, n)

addNetWeights :: forall i hs o. (KnownNat i, KnownNat o)
              => Sing hs
              -> Network i hs o
              -> Network i hs o
              -> Network i hs o
addNetWeights = \case
    SNil -> \case
      O w1 -> \case
        O w2      -> O (addW w1 w2)
    SNat `SCons` ss -> \case
      w1 :&~ n1 -> \case
        w2 :&~ n2 -> addW w1 w2 :&~ addNetWeights ss n1 n2
  where
    addW :: (KnownNat n, KnownNat m)
         => Weights n m
         -> Weights n m
         -> Weights n m
    addW (W b1 w1) (W b2 w2) = W (b1 + b2) (w1 + w2)

hiddenSing :: Network i hs o -> Sing hs
hiddenSing = \case
    O _      -> SNil
    _ :&~ n' -> SNat `SCons` hiddenSing n'


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}

module Math.Markov where

import Control.Monad.Random (getRandoms, Rand, RandomGen)
import Data.Counter (count)
import Data.Default (Default(..))
import Data.List (nub, sort)
import Data.List.Split (splitOn)
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import qualified Data.Set as S
import qualified Data.Vector as VB
import qualified Data.Vector.Storable as V
import qualified Numeric.LinearAlgebra as LA

import Misc.Utils (ngrams)
import Math.Dist (DiscreteDist(..), IndexMap, JointDiscreteDistribution(..), Prob, Simulable(..), bisect, getProb, normalizeVec, trainDiscrete, valsToIndices)
import Math.Multiarray ((^!^), (^:^), MultiArray(..), multiarray)

-- MARKOV MODEL --

data MarkovModel v a = Markov { pi0 :: DiscreteDist v a, trans :: LA.Matrix Prob }
    deriving (Eq, Show)

rowStochasticMatrix :: [V.Vector Double] -> LA.Matrix Prob
rowStochasticMatrix rows = LA.fromRows $ normalizeVec <$> rows

-- construct a MarkovModel from an initial distribution and a transition matrix (entry i, j is probability of transition from i to j, so that the matrix is row-stochastic)
markov :: DiscreteDist v a -> [V.Vector Prob] -> MarkovModel v a
markov dist rows
    | length rows /= n               = error $ "transition matrix must have " ++ show n ++ " rows"
    | any (/= n) $ V.length <$> rows = error $ "all rows of transition matrix must have length " ++ show n
    | otherwise                      = Markov {pi0 = dist, trans = mat}
    where
        n = length $ vals dist
        mat = rowStochasticMatrix rows

instance (Enum v, Num v, Ord v, Ord a, Show a) => JointDiscreteDistribution MarkovModel v a where
    -- vars are always [0, 1, 2, ...]
    getVars :: MarkovModel v a -> [v]
    getVars _ = [0..]
    getJointProbEvent :: MarkovModel v a -> [[a]] -> Prob
    getJointProbEvent dist valss = exp $ getJointLogProbEvent dist valss
    getJointLogProb :: MarkovModel v a -> [a] -> Double
    getJointLogProb _ []                       = 0.0
    getJointLogProb (Markov {pi0, trans}) vals = sum logProbs
        where
            indices = valsToIndices pi0 vals
            transitionIndices = zip indices (tail indices)
            logProbs = log <$> ((probs pi0 V.! (head indices)) : (LA.atIndex trans <$> transitionIndices))
    -- marginal distribution is no longer a simple Markov chain
    marginalizeIndices = undefined
    -- infinite list of marginal distributions
    marginals :: MarkovModel v a -> [DiscreteDist v a]
    marginals (Markov {pi0, trans}) = dists
        where
            pis = normalizeVec <$> iterate (LA.<# trans) (probs pi0)
            vals' = vals pi0
            cdfs = V.scanl' (+) 0.0 <$> pis
            dists = [Discrete {var = i, vals = vals', probs = pmf, cdf = cdf'} | (i, pmf, cdf') <- zip3 [0..] pis cdfs]
    -- conditional distribution is no longer a simple Markov chain
    conditionOn = undefined
    -- distribution is infinite so can't be represented as a DiscreteDist
    forgetJoint = undefined

-- computes conditional distribution on a single variable given the nearest preceding and succeeding variable (if existent)
-- input is t and a pair ((k, val), (l, val')), and we compute P(X_t | X_{t - k} = val, X_{t + l} = val')
-- each subpair can also be Nothing, indicating the absence of such a condition
markovConditionOn :: (Integral v, Ord a) => MarkovModel v a -> v -> (Maybe (Int, a), Maybe (Int, a)) -> DiscreteDist v a
markovConditionOn (Markov {pi0, trans}) t pair = Discrete {var = t, vals = vals', probs = pmf', cdf = cdf'}
    where
        stepRow :: V.Vector Prob -> Int -> V.Vector Prob
        stepRow vec k = (iterate (LA.<# trans) vec) !! k
        stepCol :: V.Vector Prob -> Int -> V.Vector Prob
        stepCol vec k = (iterate (trans LA.#>) vec) !! k
        pis = iterate (LA.<# trans) (probs pi0)
        vals' = vals pi0
        n = VB.length vals'
        indVec :: Int -> V.Vector Prob
        indVec i = V.generate n (\j -> if (j == i) then 1.0 else 0.0)
        vecMul = V.zipWith (*)
        t' = (fromInteger $ toInteger t) :: Int
        valIdx = M.fromList $ zip (VB.toList (vals pi0)) [0..]
        val2Index = (valIdx M.!)
        pmf = case pair of
            (Nothing, Nothing)              -> pis !! t'
            (Just (k, val), Nothing)        -> stepRow (indVec $ val2Index val) k
            (Nothing, Just (l, val'))       -> stepCol (indVec $ val2Index val') l `vecMul` (pis !! t')
            (Just (k, val), Just (l, val')) -> stepCol (indVec $ val2Index val') l `vecMul` stepRow (indVec $ val2Index val) k
        pmf' = normalizeVec pmf
        cdf' = V.scanl' (+) 0.0 pmf'

-- trains a Markov model from data
-- smoothing constant is how much to add to each entry of transition matrix, and to each entry of initial vector
trainMarkovModel :: (Ord a, Show a) => Maybe [a] -> Double -> [[a]] -> MarkovModel Integer a
trainMarkovModel vals smooth chains = markov pi0 (LA.toRows trans)
    where
        allVals = fromMaybe (sort $ nub $ concat chains) vals
        chains' = filter (not . null) chains
        pi0 = trainDiscrete 0 (Just allVals) smooth (head <$> chains)
        indices = valsToIndices pi0 <$> chains
        transitionPairs = concat [zip inds (tail inds) | inds <- indices]
        n = length allVals
        addSmooth (key, val) = (key, val + smooth)
        trans = LA.assoc (n, n) smooth (addSmooth <$> (M.toList $ count transitionPairs))

-- samples a Markov model (infinitely)
markovSample :: (RandomGen g) => MarkovModel v a -> Rand g [a]
markovSample (Markov {pi0, trans}) = do
    rs <- getRandoms
    let indices = bisect (head rs) cdf0 : [bisect r (transCdfs VB.! i) | (i, r) <- zip indices (tail rs)]
    return $ (vs VB.!) <$> indices
    where
        vs = vals pi0
        cdf0 = cdf pi0
        transCdfs = VB.fromList $ (V.scanl' (+) 0.0) <$> (LA.toRows trans)

instance (b ~ [a]) => Simulable (MarkovModel v) a b where
    sample :: (RandomGen g) => MarkovModel v a -> Rand g [a]
    sample = markovSample

-- given a distribution on integers steps, creates a MarkovModel representing the random walk on the i.i.d. steps
-- must be bounded within a finite range
boundedIntegerRandomWalk :: DiscreteDist v Int -> (Int, Int) -> MarkovModel Integer Int
boundedIntegerRandomWalk dist (low, high) = markov pi0 rows
    where
        n = high - low + 1
        pi0 = trainDiscrete 0 (Just [low..high]) 0.0 [0]
        rows = [V.generate n (\j -> getProb dist (j + low - i)) | i <- [low..high]]

-- gets backward transition probabilities P(X_n = i | X_{n+1} = j)
backwardTransitions :: MarkovModel v a -> [V.Vector Prob]
backwardTransitions (Markov {trans}) = normalizeVec <$> (LA.toRows $ LA.tr trans)

-- TERMINATING MARKOV MODEL --

-- type for values in a terminating Markov chain
data Token a = Token a | Stop
    deriving (Eq, Ord, Show)

isToken :: Token a -> Bool
isToken (Token _) = True
isToken _         = False

fromToken :: Token a -> a
fromToken (Token t) = t
fromToken _         = error "invalid token"

-- converts elements to Tokens and appends a final Stop element
-- this Nothing value can be used as a terminating value for Markov chain generation
terminate :: [a] -> [Token a]
terminate = (++ [Stop]) . map Token

trainTerminatingMarkovModel :: (Ord a, Show a) => Maybe [a] -> Double -> [[a]] -> MarkovModel Integer (Token a)
trainTerminatingMarkovModel vals smooth chains = trainMarkovModel tokens smooth (terminate <$> chains)
    where tokens = (Stop :) . map Token <$> vals

instance {-# OVERLAPPING #-} (b ~ [a]) => Simulable (MarkovModel v) (Token a) b where
    -- override behavior so sampling terminates upon reaching Stop
    sample = fmap (map fromToken . takeWhile isToken) . markovSample

-- N-GRAM MODELS --

-- stores n, alphabet, mapping from alphabet to indices, and transition probability matrices for each Markovity level
data NgramModel v a = Ngrams Int (VB.Vector a) (IndexMap a) [MultiArray Prob]
    deriving (Eq, Show)

instance (Enum v, Num v, Ord v, Ord a, Show a) => JointDiscreteDistribution NgramModel v a where
    getVars :: NgramModel v a -> [v]
    getVars _ = [0..]
    getJointProbEvent :: NgramModel v a -> [[a]] -> Prob
    getJointProbEvent dist valss = exp $ getJointLogProbEvent dist valss
    getJointLogProb :: NgramModel v a -> [a] -> Double
    getJointLogProb (Ngrams n _ valIdx mats) vals = sum logprobs
        where
            indices = (valIdx M.!) <$> vals
            idxGrams = [take i indices | i <- [1..(n - 1)]] ++ ngrams n indices
            matSeq = init mats ++ repeat (last mats)
            logprobs = log <$> zipWith (^!^) matSeq idxGrams
    marginalizeIndices = undefined
    marginals = undefined
    conditionOn = undefined
    forgetJoint = undefined

trainNgramModel :: (Ord a, Show a) => Int -> Maybe [a] -> Double -> [[a]] -> NgramModel Integer a
trainNgramModel n alphabet smooth chains = Ngrams n (VB.fromList alphabet') valIdx transArrs
    where
        alphabet' = fromMaybe (sort $ nub $ concat chains) alphabet
        m = length alphabet'
        valIdx = M.fromList $ zip alphabet' [0..]  -- mapping from alphabet values to indices
        idxChains = map (valIdx M.!) <$> chains
        getTransitions :: Int -> MultiArray Prob
        getTransitions k = multiarray (replicate k m) (concat rows)
            where
                pairs = concat $ (map (splitAt (k - 1)) . ngrams k) <$> idxChains
                cumProds = (m ^) <$> reverse [0..(k - 2)]
                transitionPairs = [(sum $ zipWith (*) cumProds fromInds, head toInds) | (fromInds, toInds) <- pairs]
                addSmooth (key, val) = (key, val + smooth)
                trans = LA.assoc (m ^ (k - 1), m) smooth (addSmooth <$> (M.toList $ count transitionPairs))
                rows = V.toList . normalizeVec <$> LA.toRows trans
        transArrs = getTransitions <$> [1..n]

-- samples an n-gram model (infinitely)
ngramSample :: (RandomGen g) => NgramModel v a -> Rand g [a]
ngramSample (Ngrams n alphabet _ transArrs) = do
    rs <- getRandoms
    let indices = [] : [rotateInds arr prev r | (prev, arr, r) <- zip3 indices arrs rs]
    return [alphabet VB.! (last inds) | inds <- tail indices]
    where
        getTail :: [Int] -> [Int]
        getTail inds = if (length inds < n) then inds else tail inds
        rotateInds :: MultiArray Prob -> [Int] -> Double -> [Int]
        rotateInds arr inds r = indTail ++ [nextInd]
            where
                indTail = getTail inds
                row = entries $ arr ^:^ (((Just . pure) <$> indTail) ++ [Nothing])
                cdf = V.scanl' (+) 0.0 row
                nextInd = bisect r cdf
        arrs = transArrs ++ (repeat $ last transArrs)

instance (b ~ [a]) => Simulable (NgramModel v) a b where
    sample :: (RandomGen g) => NgramModel v a -> Rand g [a]
    sample = ngramSample

-- condSlice :: (Ord a) => NgramModel v a -> [a] -> [(Int, a, Prob)]
-- condSlice (Ngrams n vals valIdx transArrs) vals' = zip3 [0..] (VB.toList vals) (V.toList pdf)
--     where
--         lastN = reverse $ take (n - 1) $ reverse vals'
--         inds = (valIdx M.!) <$> lastN
--         arr = transArrs !! length inds
--         pdf = entries $ arr ^:^ (((Just . pure) <$> inds) ++ [Nothing])

-- TERMINATING N-GRAM MODELS --

trainTerminatingNgramModel :: (Ord a, Show a) => Int -> Maybe [a] -> Double -> [[a]] -> NgramModel Integer (Token a)
trainTerminatingNgramModel n alphabet smooth chains = trainNgramModel n toks smooth (terminate <$> chains)
    where toks = (Stop :) . map Token <$> alphabet

instance {-# OVERLAPPING #-} (b ~ [a]) => Simulable (NgramModel v) (Token a) b where
    -- override behavior so sampling terminates upon reaching Stop
    sample = fmap (map fromToken . takeWhile isToken) . ngramSample

-- TEXT N-GRAM MODELS --

data CharNgramParams = CharNgramParams {
      charAlphabet :: Maybe String,   -- alphabet to use
      charSmooth :: Double,           -- smoothing constant
      charLineSep :: String,          -- line separator string
      charTransform :: Char -> Char,  -- function to transform each character
      charFilter :: Bool              -- if True, filter out missing characters
}

instance Default CharNgramParams where
    def = CharNgramParams { charAlphabet = Nothing, charSmooth = 1e-8, charLineSep = "\n", charTransform = id, charFilter = True }

trainCharNgramModel :: Int -> CharNgramParams -> String -> NgramModel Integer (Token Char)
trainCharNgramModel n params text = trainTerminatingNgramModel n (charAlphabet params) (charSmooth params) lines''
    where
        lines = splitOn (charLineSep params) text
        lines' = map (charTransform params) <$> lines
        lines'' = case (charAlphabet params) of
            Just alphabet -> if (charFilter params)
                                then filter (`S.member` alphabetSet) <$> lines'
                                else lines'
                where alphabetSet = S.fromList alphabet
            Nothing       -> lines'


{-# OPTIONS -cpp #-}
module Main where

-- import MathObj.FFT.Radix4Par as R4 (fft,fftDo2,fftDo3)
import MathObj.FFT.Radix4Seq as R4 (fft)
import MathObj.FFT.Reference as R2 (fft, ifft)
import MathObj.FFT.MultiPar (twoDimFft, twoDimFftG, twoDimFftRD)
import Prelude
-- import System.CPUTime
import Data.Complex
import MathObj.FFT.Complex
import Control.Concurrent
#ifdef TEST
import qualified MathObj.FFT.Reference as Ref
#endif

import System.Environment (getArgs)
import System.IO
import Control.Parallel.Eden (rnf, Trans)
import Control.Parallel.Eden.Map (farmS)

instance (RealFloat a, Trans a) => Trans (Complex a) -- ???

main = do
  hSetBuffering stdout NoBuffering
  putStrLn "usage: testfftTest <size or base for power of 4(1024) of one side> <version 0,1,2,3,4(3)> <chunksize(512), no effect?> <prefetch(20)>"
  args <- getArgs
  let f = mkLists n
--      n = if null args then 512 else read (head args)
      n = if b > 15 then b else 4^b
      b = if null args then 1024 else read (head args)
      v = if length args < 2 then 3 else read (args!!1)
      s = if length args < 3 then 512 else read (args!!2)
      p = if length args < 4 then 20 else read (args!!3)
--  let r = fftDo3 s (n, f)
--      r2 = fftDo2 s (n,f)
      r4 = twoDimFft n n f
      r5 = twoDimFftG map R4.fft n n f
      r6 = twoDimFftG (farmS p) R2.fft n n f
      r7 = twoDimFftG (farmS p) R4.fft n n f
      r8 = twoDimFftRD (farmS p) R4.fft n n f
#ifdef TEST
  let (len,resultlist) = r
  putStrLn ("Length given as " ++ show len ++
	    ", in reality " ++ show (length resultlist))
  let ref = Ref.fft (n,f)
  if (r /= ref) then putStrLn "WRONG RESULT" else putStrLn "CORRECT"
  rnf r2 `seq`
--  (length (snd r)) `seq`
--  (fst r ) `seq`
    putStrLn "Done version fftDo2"
  threadDelay 100000
  rnf r `seq`
--  (length (snd r)) `seq`
--  (fst r ) `seq`
    putStrLn "Done version fft"
  if r == r2
     then putStrLn "same result"
     else outputDiff 5 r r2
#else
  case v of
--     0 -> rnf r `seq` putStrLn ("Done, version fft")
--     1 -> rnf r2 `seq` putStrLn ("Done, version fftDo2")
     2 -> putStrLn ("not defined in this version, look in code/small/")
     3 -> rnf r4 `seq` putStrLn ("Done, version twoDimFft with seqmap R2 (sequential ground truth for R2)")
     4 -> rnf r5 `seq` putStrLn ("Done, version twoDimFft with seqmap R4 (sequential ground truth for R4)")
     5 -> rnf r6 `seq` putStrLn ("Done, version twoDimFft with farm R2")
     6 -> rnf r7 `seq` putStrLn ("Done, version twoDimFft with farm R4")
     7 ->rnf r7 `seq` putStrLn ("Done, version twoDimFftRD(!) with farm R4")
     _ -> putStrLn ("no version " ++ show v ++ " defined")
#endif

mkLists :: Int -> [[Complex Double]]
mkLists n = map (\k -> lift $ [k..k+n]) [1..n]

outputDiff :: (Show a,Eq a,Num a) => Int -> (Int,[a]) -> (Int,[a]) -> IO ()
outputDiff n (n1,l1) (n2,l2)
    | n1 /= n2  = putStrLn "different length"
    | otherwise = do putStrLn (show (length diffs) ++ " different elements")
		     putStrLn (unlines (map show (take n diffs)))
    where diffs = [ (k,x,y,x-y) | (k,x,y) <- zip3 [0..] l1 l2, x/=y ]


{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-|
Module      : Grenade.Layers.Gelu
Description : Gaussian Error Linear Unit (GELU)
Copyright   : (c) Manuel Schneckenreither, 2020
License     : BSD2
Stability   : experimental

This module implements the Gaussian Error Linear Unit (GELU) activiation function. See

Hendrycks, Dan, and Kevin Gimpel. "Gaussian error linear units (gelus)." arXiv preprint arXiv:1606.08415 (2016).

Available at: https://arxiv.org/pdf/1606.08415.pdf

As in the paper we simply let μ = 0 and σ = 1. Futher, we use the simplified and thus fast representation: x * sigmoid (1.702 * x)

-}
module Grenade.Layers.Gelu (
    Gelu (..)
  ) where

import           Control.DeepSeq                (NFData (..))
import           Data.Serialize
import           GHC.Generics                   (Generic)
import           GHC.TypeLits
import qualified Numeric.LinearAlgebra.Static   as LAS

import           Grenade.Core

-- | A Gaussion Error Linear Unit.
--   A layer which can act between any shape of the same dimension, acting as a
--   diode on every neuron individually.
--
--   Hendrycks, Dan, and Kevin Gimpel. "Gaussian error linear units (gelus)." arXiv preprint arXiv:1606.08415 (2016).
data Gelu = Gelu
  deriving (Generic, NFData, Show)

instance UpdateLayer Gelu where
  type Gradient Gelu = ()
  runUpdate _ _ _ = Gelu
  reduceGradient _ = ()

instance RandomLayer Gelu where
  createRandomWith _ _ = return Gelu

instance Serialize Gelu where
  put _ = return ()
  get = return Gelu

geluForwardFast :: Floating x => x -> x
geluForwardFast x = x / (e ** (-1.702 * x) + 1) -- = x * sigmoid (1.702 * x)
  where
    e = 2.71828

geluBackwardFast :: Floating x => x -> x
geluBackwardFast x = (e ** (1.702 * x) * (1 + e ** (1.702 * x) + 1.702 * x)) / (1 + e ** (1.702 * x)) ** 2
  where
    e = 2.71828

instance (KnownNat i) => Layer Gelu ('D1 i) ('D1 i) where
  type Tape Gelu ('D1 i) ('D1 i) = S ('D1 i)

  runForwards _ (S1D y) = (S1D y, S1D (gelu y))
    where
      gelu = LAS.dvmap geluForwardFast
  runBackwards _ (S1D y) (S1D dEdy) = ((), S1D (gelu' y * dEdy))
    where
      gelu' = LAS.dvmap geluBackwardFast

instance (KnownNat i, KnownNat j) => Layer Gelu ('D2 i j) ('D2 i j) where
  type Tape Gelu ('D2 i j) ('D2 i j) = S ('D2 i j)

  runForwards _ (S2D y) = (S2D y, S2D (gelu y))
    where
      gelu = LAS.dmmap geluForwardFast
  runBackwards _ (S2D y) (S2D dEdy) = ((), S2D (gelu' y * dEdy))
    where
      gelu' = LAS.dmmap geluBackwardFast

instance (KnownNat i, KnownNat j, KnownNat k) => Layer Gelu ('D3 i j k) ('D3 i j k) where

  type Tape Gelu ('D3 i j k) ('D3 i j k) = S ('D3 i j k)

  runForwards _ (S3D y) = (S3D y, S3D (gelu y))
    where
      gelu = LAS.dmmap geluForwardFast
  runBackwards _ (S3D y) (S3D dEdy) = ((), S3D (gelu' y * dEdy))
    where
      gelu' = LAS.dmmap geluBackwardFast


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
-- |
-- Module    : Statistics.Distribution.Poisson
-- Copyright : (c) 2009, 2011 Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- The Poisson distribution.  This is the discrete probability
-- distribution of a number of events occurring in a fixed interval if
-- these events occur with a known average rate, and occur
-- independently from each other within that interval.

module Statistics.Distribution.Poisson
    (
      PoissonDistribution
    -- * Constructors
    , poisson
    , poissonE
    -- * Accessors
    , poissonLambda
    -- * References
    -- $references
    ) where

import Control.Applicative
import Data.Data            (Data, Typeable)
import GHC.Generics         (Generic)
import Numeric.SpecFunctions (incompleteGamma,logFactorial)
import Numeric.MathFunctions.Constants (m_neg_inf)

import qualified Statistics.Distribution as D
import qualified Statistics.Distribution.Poisson.Internal as I
import Statistics.Internal

newtype PoissonDistribution = PD {
      poissonLambda :: Double
    } deriving (Eq, Typeable, Data, Generic)

instance Show PoissonDistribution where
  showsPrec i (PD l) = defaultShow1 "poisson" l i
instance Read PoissonDistribution where
  readPrec = defaultReadPrecM1 "poisson" poissonE

instance D.Distribution PoissonDistribution where
    cumulative (PD lambda) x
      | x < 0        = 0
      | isInfinite x = 1
      | isNaN      x = error "Statistics.Distribution.Poisson.cumulative: NaN input"
      | otherwise    = 1 - incompleteGamma (fromIntegral (floor x + 1 :: Int)) lambda

instance D.DiscreteDistr PoissonDistribution where
    probability (PD lambda) x = I.probability lambda (fromIntegral x)
    logProbability (PD lambda) i
      | i < 0     = m_neg_inf
      | otherwise = log lambda * fromIntegral i - logFactorial i - lambda

instance D.Variance PoissonDistribution where
    variance = poissonLambda

instance D.Mean PoissonDistribution where
    mean = poissonLambda

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

instance D.MaybeVariance PoissonDistribution where
    maybeStdDev   = Just . D.stdDev

instance D.Entropy PoissonDistribution where
  entropy (PD lambda) = I.poissonEntropy lambda

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

-- | Create Poisson distribution.
poisson :: Double -> PoissonDistribution
poisson l = maybe (error $ errMsg l) id $ poissonE l

-- | Create Poisson distribution.
poissonE :: Double -> Maybe PoissonDistribution
poissonE l
  | l >=  0   = Just (PD l)
  | otherwise = Nothing

errMsg :: Double -> String
errMsg l = "Statistics.Distribution.Poisson.poisson: lambda must be non-negative. Got "
        ++ show l

-- $references
--
-- * Loader, C. (2000) Fast and Accurate Computation of Binomial
--   Probabilities. <http://projects.scipy.org/scipy/raw-attachment/ticket/620/loader2000Fast.pdf>
-- * Adell, J., Lekuona, A., and Yu, Y. (2010) Sharp Bounds on the
--   Entropy of the Poisson Law and Related Quantities
--   <http://arxiv.org/pdf/1001.2897.pdf>


{-# LANGUAGE ViewPatterns        #-}
--------------------------------------------------------------------------------
-- |
-- Module      : ArrayFire.BLAS
-- Copyright   : David Johnson (c) 2019-2020
-- License     : BSD3
-- Maintainer  : David Johnson <djohnson.m@gmail.com>
-- Stability   : Experimental
-- Portability : GHC
--
-- Basic Linear Algebra Subprograms (BLAS) API
--
-- @
-- main :: IO ()
-- main = print (matmul x y xProp yProp)
--  where
--     x,y :: Array Double
--     x = matrix (2,3) [[1,2],[3,4],[5,6]]
--     y = matrix (3,2) [[1,2,3],[4,5,6]]
--
--     xProp, yProp :: MatProp
--     xProp = None
--     yProp = None
-- @
-- @
--  ArrayFire Array
--  [2 2 1 1]
--     22.0000    49.0000
--     28.0000    64.0000
-- @
--------------------------------------------------------------------------------
module ArrayFire.BLAS where

import Data.Complex

import ArrayFire.FFI
import ArrayFire.Internal.BLAS
import ArrayFire.Internal.Types

-- | The following applies for Sparse-Dense matrix multiplication.
--
-- This function can be used with one sparse input. The sparse input must always be the lhs and the dense matrix must be rhs.
--
-- The sparse array can only be of 'CSR' format.
--
-- The returned array is always dense.
--
-- optLhs an only be one of AF_MAT_NONE, AF_MAT_TRANS, AF_MAT_CTRANS.
--
-- optRhs can only be AF_MAT_NONE.
--
-- >>> matmul (matrix @Double (2,2) [[1,2],[3,4]]) (matrix @Double (2,2) [[1,2],[3,4]]) None None
-- ArrayFire Array
-- [2 2 1 1]
--     7.0000    15.0000
--    10.0000    22.0000
matmul
  :: AFType a
  => Array a
  -- ^ 2D matrix of Array a, left-hand side
  -> Array a
  -- ^ 2D matrix of Array a, right-hand side
  -> MatProp
  -- ^ Left hand side matrix options
  -> MatProp
  -- ^ Right hand side matrix options
  -> Array a
  -- ^ Output of 'matmul'
matmul arr1 arr2 prop1 prop2 = do
  op2 arr1 arr2 (\p a b -> af_matmul p a b (toMatProp prop1) (toMatProp prop2))

-- | Scalar dot product between two vectors. Also referred to as the inner product.
--
-- >>> dot (vector @Double 10 [1..]) (vector @Double 10 [1..]) None None
-- ArrayFire Array
-- [1 1 1 1]
--   385.0000
dot
  :: AFType a
  => Array a
  -- ^ Left-hand side input
  -> Array a
  -- ^ Right-hand side input
  -> MatProp
  -- ^ Options for left-hand side. Currently only AF_MAT_NONE and AF_MAT_CONJ are supported.
  -> MatProp
  -- ^ Options for right-hand side. Currently only AF_MAT_NONE and AF_MAT_CONJ are supported.
  -> Array a
  -- ^ Output of 'dot'
dot arr1 arr2 prop1 prop2 =
  op2 arr1 arr2 (\p a b -> af_dot p a b (toMatProp prop1) (toMatProp prop2))

-- | Scalar dot product between two vectors. Also referred to as the inner product. Returns the result as a host scalar.
--
-- >>> dotAll (vector @Double 10 [1..]) (vector @Double 10 [1..]) None None
-- 385.0 :+ 0.0
dotAll
  :: AFType a
  => Array a
  -- ^ Left-hand side array
  -> Array a
  -- ^ Right-hand side array
  -> MatProp
  -- ^ Options for left-hand side. Currently only AF_MAT_NONE and AF_MAT_CONJ are supported.
  -> MatProp
  -- ^ Options for right-hand side. Currently only AF_MAT_NONE and AF_MAT_CONJ are supported.
  -> Complex Double
  -- ^ Real and imaginary component result
dotAll arr1 arr2 prop1 prop2 = do
  let (real,imag) =
        infoFromArray22 arr1 arr2 $ \a b c d ->
          af_dot_all a b c d (toMatProp prop1) (toMatProp prop2)
  real :+ imag

-- | Transposes a matrix.
--
-- >>> array = matrix @Double (2,3) [[2,3],[3,4],[5,6]]
-- >>> array
-- ArrayFire Array
-- [2 3 1 1]
--     2.0000     3.0000     5.0000
--     3.0000     4.0000     6.0000
--
-- >>> transpose array True
-- ArrayFire Array
-- [3 2 1 1]
--     2.0000     3.0000
--     3.0000     4.0000
--     5.0000     6.0000
--
transpose
  :: AFType a
  => Array a
  -- ^ Input matrix to be transposed
  -> Bool
  -- ^ Should perform conjugate transposition
  -> Array a
  -- ^ The transposed matrix
transpose arr1 (fromIntegral . fromEnum -> b) =
  arr1 `op1` (\x y -> af_transpose x y b)

-- | Transposes a matrix.
--
-- * Warning: This function mutates an array in-place, all subsequent references will be changed. Use carefully.
--
-- >>> array = matrix @Double (2,2) [[1,2],[3,4]]
-- >>> array
-- ArrayFire Array
-- [3 2 1 1]
--    1.0000     4.0000
--    2.0000     5.0000
--    3.0000     6.0000
--
-- >>> transposeInPlace array False
-- >>> array
-- ArrayFire Array
-- [2 2 1 1]
--    1.0000     2.0000
--    3.0000     4.0000
--
transposeInPlace
  :: AFType a
  => Array a
  -- ^ Input matrix to be transposed
  -> Bool
  -- ^ Should perform conjugate transposition
  -> IO ()
transposeInPlace arr (fromIntegral . fromEnum -> b) =
  arr `inPlace` (`af_transpose_inplace` b)


{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
{- |
Module      :  Numeric.LinearAlgebra.Util.Convolution
Copyright   :  (c) Alberto Ruiz 2012
License     :  GPL

Maintainer  :  Alberto Ruiz (aruiz at um dot es)
Stability   :  provisional

-}
-----------------------------------------------------------------------------

module Numeric.LinearAlgebra.Util.Convolution(
   corr, conv, corrMin,
   corr2, conv2, separable
) where

import Numeric.LinearAlgebra

vectSS :: Element t => Int -> Vector t -> Matrix t
vectSS n v = fromRows [ subVector k n v | k <- [0 .. dim v - n] ]

corr :: Product t => Vector t -- ^ kernel
                  -> Vector t -- ^ source
                  -> Vector t
{- ^ correlation

>>> corr (fromList[1,2,3]) (fromList [1..10])
fromList [14.0,20.0,26.0,32.0,38.0,44.0,50.0,56.0]

-}
corr ker v | dim ker <= dim v = vectSS (dim ker) v <> ker
           | otherwise = error $ "corr: dim kernel ("++show (dim ker)++") > dim vector ("++show (dim v)++")"

conv :: (Product t, Num t) => Vector t -> Vector t -> Vector t
{- ^ convolution ('corr' with reversed kernel and padded input, equivalent to polynomial product)

>>> conv (fromList[1,1]) (fromList [-1,1])
fromList [-1.0,0.0,1.0]

-}
conv ker v = corr ker' v'
  where
    ker' = (flatten.fliprl.asRow) ker
    v' | dim ker > 1 = join [z,v,z]
       | otherwise   = v
    z = constant 0 (dim ker -1)

corrMin :: (Container Vector t, RealElement t, Product t)
        => Vector t
        -> Vector t
        -> Vector t
-- ^ similar to 'corr', using 'min' instead of (*)
corrMin ker v = minEvery ss (asRow ker) <> ones
  where
    minEvery a b = cond a b a a b
    ss = vectSS (dim ker) v
    ones = konst' 1 (dim ker)

matSS :: Element t => Int -> Matrix t -> [Matrix t]
matSS dr m = map (reshape c) [ subVector (k*c) n v | k <- [0 .. r - dr] ]
  where
    v = flatten m
    c = cols m
    r = rows m
    n = dr*c

corr2 :: Product a => Matrix a -> Matrix a -> Matrix a
-- ^ 2D correlation
corr2 ker mat = dims
              . concatMap (map ((<.> ker') . flatten) . matSS c . trans)
              . matSS r $ mat
  where
    r = rows ker
    c = cols ker
    ker' = flatten (trans ker)
    rr = rows mat - r + 1
    rc = cols mat - c + 1
    dims | rr > 0 && rc > 0 = (rr >< rc)
         | otherwise = error $ "corr2: dim kernel ("++sz ker++") > dim matrix ("++sz mat++")"
    sz m = show (rows m)++"x"++show (cols m)

conv2 :: (Num a, Product a) => Matrix a -> Matrix a -> Matrix a
-- ^ 2D convolution
conv2 k m = corr2 (fliprl . flipud $ k) pm
  where
    pm | r == 0 && c == 0 = m
       | r == 0           = fromBlocks [[z3,m,z3]]
       |           c == 0 = fromBlocks [[z2],[m],[z2]]
       | otherwise        = fromBlocks [[z1,z2,z1]
                                       ,[z3, m,z3]
                                       ,[z1,z2,z1]]
    r = rows k - 1
    c = cols k - 1
    h = rows m
    w = cols m
    z1 = konst' 0 (r,c)
    z2 = konst' 0 (r,w)
    z3 = konst' 0 (h,c)

-- TODO: could be simplified using future empty arrays

separable :: Element t => (Vector t -> Vector t) -> Matrix t -> Matrix t
-- ^ matrix computation implemented as separated vector operations by rows and columns.
separable f = fromColumns . map f . toColumns . fromRows . map f . toRows


import Data.Complex
import Data.Ratio

-- types

a1 :: Int
a1 = 4

a2 :: Complex Double
a2 = 2 :+ 3

a3 :: Ratio Int
a3 = 2%3

main = do
       print a1
       print a2
       print a3

-- string literal

c1 :: Char
c1 = '\x0053'

c2 :: [Char]
c2 = "\o0120"

main2 = do
        putChar c1 >> putChar '\n'
        putChar (c2!!0) >> putChar '\n'

-- lists

l0 :: [Int]
l0 = [1, 3..10]

l1 :: [Int]
l1 = [1..]

l2 :: [String]
l2 = ["aa", "bb", "cc"]

main3 = do
       print l0
       print $ take 20 l1
       print l2

-- tuples

t0 :: (Int, Int)
t0 = (69,96)

t1 :: (String, Int, Double)
t1  = ("something", 8, 3.123)

t2 :: ([Int],([String], (Int, Float)))
t2 = ([1..4], (["1..4","sdf"], (1234, 1234.1234)))

main4 = do
        print t0
        print t1
        print t2

--functions

f0 :: String -> Int
f0 = length

f1 :: String -> (String, Int)
f1 x = (x, length x)

f2 :: [String] -> [(String, Int)]
f2 = map f1

main5 = do
        print $ f0 "1234567890"
        print $ f1 "0987654321"
        print $ f2 ["HEYYY", "Maaaan"]


{- | Relevant Vector Machine. Classifier -}
module Numeric.BMML.RVMC
    ( fit
    , predict
    ) where

import           Numeric.LinearAlgebra.Data (Matrix, Vector)
import qualified Numeric.LinearAlgebra.HMatrix as H

data RVMCModel = RVMCModel
    { mean :: Vector Double
    , covariance :: Matrix Double
    }

initAlpha :: Int -> Vector Double
initAlpha = H.konst 1

initY :: Int -> Vector Double
initY = H.konst 0.5

calcB :: Vector Double -> Matrix Double
calcB y =
    H.diag
        (H.cmap
             (\yi ->
                   (sigmoid yi) * (1 - sigmoid yi))
             y)

calcSigma :: Matrix Double -> Matrix Double -> Vector Double -> Matrix Double
calcSigma phi b alpha = H.inv (H.tr phi H.<> b H.<> phi + H.diag alpha)

calcW
    :: Vector Double
    -> Matrix Double
    -> Matrix Double
    -> Matrix Double
    -> Vector Double
    -> Vector Double
    -> Vector Double
calcW mu sigma b phi t y = (sigma H.<> (H.tr phi) H.<> b) H.#> hatt
  where
    hatt = phi H.#> mu + (H.inv b) H.#> (t - y)

calcY :: Vector Double -> Matrix Double -> Vector Double
calcY w phi = H.cmap sigmoid (phi H.#> w)

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

fit :: Matrix Double -> Vector Double -> RVMCModel
fit phi t =
    let (n,d) = H.size phi
        alpha = initAlpha d
        y = initY n
        b = calcB y
        sigma = calcSigma phi b alpha
    in go
           (2 * floor (sqrt (fromIntegral n)))
           alpha
           y
           b
           (H.konst 0.1 d)
           sigma
  where
    go 0 _ _ _ w sigma =
        RVMCModel
        { mean = w
        , covariance = sigma
        }
    go k alpha y b w sigma = go (k - 1) na ny nb nw ns
      where
        gamma = H.cmap (1 -) (alpha * (H.takeDiag sigma))
        na = gamma / (w * w)
        ny = calcY w phi
        nb = calcB ny
        ns = calcSigma phi nb na
        nw = calcW w sigma b phi t ny

-- | Return probability of phi is from C_1 (t = 1)
predict :: RVMCModel -> Vector Double -> Double
predict (RVMCModel w s) phi = sigmoid ((k sigma_a) * m_a)
  where
    m_a = w `H.dot` phi
    sigma_a = phi `H.dot` (s H.#> phi)
    k x = sqrt (1 + 3 * x / 8)


module Statistics.Information.Discrete.Entropy where

import Data.Function.Memoize
import Data.Matrix
import Statistics.Information.Utils.List

entropy :: Eq a => Int -> Matrix a -> Double
entropy = memoize $ \base xs ->
  -(sum (map elog . hist . toLists $ xs)) / log (fromIntegral base)
  where
    elog x | x <= 0.0 = 0
    elog x | x >= 1.0 = 0
    elog x = x * log x

centropy :: Eq a => Int -> Matrix a -> Matrix a -> Double
centropy base xs ys = entropy base (xs <|> ys) - entropy base ys


{-# LANGUAGE ForeignFunctionInterface #-}
-----------------------------------------------------------------------------
{- |
Module      : Numeric.GSL.Fourier
Copyright   :  (c) Alberto Ruiz 2006
License     :  GPL-style

Maintainer  :  Alberto Ruiz (aruiz at um dot es)
Stability   :  provisional
Portability :  uses ffi

Fourier Transform.

<http://www.gnu.org/software/gsl/manual/html_node/Fast-Fourier-Transforms.html#Fast-Fourier-Transforms>

-}
-----------------------------------------------------------------------------
module Numeric.GSL.Fourier (
    fft,
    ifft
) where

import Data.Packed.Internal
import Data.Complex
import Foreign.C.Types
import System.IO.Unsafe (unsafePerformIO)

genfft code v = unsafePerformIO $ do
    r <- createVector (dim v)
    app2 (c_fft code) vec v vec r "fft"
    return r

foreign import ccall unsafe "gsl-aux.h fft" c_fft ::  CInt -> TCVCV

{- | Fast 1D Fourier transform of a 'Vector' @(@'Complex' 'Double'@)@ using /gsl_fft_complex_forward/. It uses the same scaling conventions as GNU Octave.

@> fft ('fromList' [1,2,3,4])
vector (4) [10.0 :+ 0.0,(-2.0) :+ 2.0,(-2.0) :+ 0.0,(-2.0) :+ (-2.0)]@

-}
fft :: Vector (Complex Double) -> Vector (Complex Double)
fft = genfft 0

-- | The inverse of 'fft', using /gsl_fft_complex_inverse/.
ifft :: Vector (Complex Double) -> Vector (Complex Double)
ifft = genfft 1


{- |
Description :  Random values, distributions, etc.
Copyright   :  (c) Dominik Schrempf 2017
License     :  GPLv3

Maintainer  :  dominik.schrempf@gmail.com
Stability   :  unstable
Portability :  non-portable (not tested)

Impure.

Some functions to work with random computations such as a definition of a
distribution, and convenience functions to draw from distributions.

* Changelog

-}

module Distribution where

-- I had problems with using =scanl= for vectors, a function provided by
-- Data.Vector. However, hmatrix reexports some definitions of vector which
-- results in errors. The qualified imports solve this problems.
import           Control.Monad.Random.Strict
import qualified Data.Vector.Generic         as V
import qualified Numeric.LinearAlgebra       as L

-- | A discrete distribution is a real vector.
type Distribution = L.Vector L.R

-- | Randomly sample an index from a discrete probability distribution.
drawFromDist :: (RandomGen g) => Distribution -> Rand g Int
drawFromDist dist = do
  p <- getRandomR (0.0 :: Double, 1.0 :: Double)
  return $ fromDist p dist

-- | A probability is just a double, an index is just an Int.
type Probability = Double

-- | For a given value, return the index of the sample according to a given
-- distribution. In Control.Monad.Trans.Random, this is implemented for lists,
-- but I happen to use vectors in this program, so I had to rewrite this
-- function.
fromDist :: Probability -> Distribution -> Int
fromDist p dist = V.length $ V.takeWhile (<p) cums
  -- The cumulative distribution.
  where cums = V.scanl1' (+) dist

-- | Get a uniform distribution with n categories.
uniformDist :: Int -> Distribution
uniformDist n = L.vector $ replicate n $ 1.0 / fromIntegral n


module Neural.MNIST where

import Control.Monad
import Data.Bits
import qualified Data.ByteString.Lazy as BSL
import Numeric.LinearAlgebra
import System.IO

readLittleEndian :: Handle -> IO (Int)
readLittleEndian hdl =
  (liftM BSL.reverse $ BSL.hGet hdl 4)
  >>= (\bytes -> return $
                foldl (\res (byte, i) -> res + (shift (fromIntegral byte) $ i * 8))
                0 $ zip (BSL.unpack bytes) [0..])

loadMNISTImages :: FilePath -> IO (Maybe [(Matrix Double)])
loadMNISTImages path =
  withBinaryFile path ReadMode readMNIST
  where readMNIST hdl =
          do test <- readLittleEndian hdl
             case test of
               2051 ->
                 (do imageCount <- readLittleEndian hdl
                     imageWidth <- readLittleEndian hdl
                     imageHeight <- readLittleEndian hdl

                     liftM Just $ readImages hdl imageWidth imageHeight)

               _ -> return Nothing

        readImages hdl w h = do
          img <- (readImage hdl w h)
          case img of
            Just img -> liftM2 (:) (return img) (readImages hdl w h)
            Nothing -> return []

        readImage hdl w h =
          (BSL.hGet hdl (w * h))
          >>= (\bytes ->
                if (fromIntegral $ BSL.length bytes) == (fromIntegral $ (w * h))
                then return $ Just $
                     (w><h) $ map (\pixel -> fromIntegral pixel / 255.0) $ BSL.unpack bytes
                else return Nothing)

loadMNISTLabels :: FilePath -> IO (Maybe [Int])
loadMNISTLabels path =
  withBinaryFile path ReadMode readMNIST
  where readMNIST hdl =
          do test <- readLittleEndian hdl
             case test of
               2049 -> (readLittleEndian hdl) >>= (readLabels hdl)
               _ -> return Nothing

        readLabels hdl labelCount =
          (BSL.hGet hdl labelCount)
          >>= (\bytes ->
                if (fromIntegral $ BSL.length bytes) == (fromIntegral labelCount)
                then return $ Just $ map fromIntegral $ BSL.unpack bytes
                else return Nothing)

loadMNISTDataSet :: FilePath -> FilePath -> IO (Maybe [((Matrix Double), Int)])
loadMNISTDataSet imagesPath labelsPath =
  do maybeImages <- loadMNISTImages imagesPath
     maybeLabels <- loadMNISTLabels labelsPath

     case (maybeImages,maybeLabels) of
       (Just images, Just labels) -> return $ Just $ zip images labels
       (_,_) -> return Nothing

printMNISTImage :: (Matrix Double) -> IO ()
printMNISTImage image = putStr $ foldl (++) "" $ map printRow (toLists image)
  where printRow row = (reverse $ foldl (\str e -> (if e > 0.5 then '#' else ' ') : str) [] row) ++ "\n"


module TestHelpers where

import Control.Newtype.Generics (over)
import Data.Complex
import qualified Data.Vector as V
import HABQTlib.Data
import HABQTlib.Data.Particle
import qualified Numeric.LinearAlgebra as LA
import qualified Test.QuickCheck as QC
import Test.QuickCheck (Arbitrary(..), Gen, Positive(..))

getRank :: DensityMatrix -> Rank
getRank (DensityMatrix dm) =
  let (_, s, _) = LA.compactSVD dm
   in LA.size s

arbDimRank :: QC.Gen (Dim, Rank)
arbDimRank = do
  dim <- QC.suchThat arbitrary (> 1)
  Positive rank <- QC.suchThat arbitrary (\(Positive v) -> v <= dim)
  return (dim, rank)

arbDM :: Dim -> Rank -> QC.Gen DensityMatrix
arbDM dim rank = do
  let genXs =
        QC.vectorOf
          dim
          (QC.vectorOf rank (QC.arbitrary :: QC.Gen (Complex Double)))
  xs <- QC.suchThat genXs (\ll -> any (/= 0.0 :+ 0.0) (zipWith (!!) ll [0 ..]))
  let a = LA.fromLists xs
      h = a LA.<> LA.tr a
      hTr = LA.sumElements $ LA.takeDiag h
      dm = h / LA.scalar hTr
  return $ DensityMatrix dm

arbWDM :: Dim -> Rank -> QC.Gen WeighedDensityMatrix
arbWDM dim rank = do
  Positive w <- QC.arbitrary
  dm <- arbDM dim rank
  return $ WeighedDensityMatrix (w, dm)

arbNormedVecDim :: Int -> Gen (LA.Matrix (Complex Double))
arbNormedVecDim dim = do
  let genXs = QC.vectorOf dim (arbitrary :: Gen (Complex Double))
  xs <- QC.suchThat genXs (any (/= 0))
  let sv = LA.asColumn . LA.fromList $ xs
  return $ sv / LA.toComplex (LA.scalar (LA.norm_2 sv), 0)

arbitraryWeighed :: Arbitrary x => Gen (Weight, x)
arbitraryWeighed = do
  dim <- QC.suchThat QC.getSize (> 0)
  w <- getPositive <$> arbitrary
  dm <- QC.resize dim arbitrary
  return (w, dm)

arbParticles :: Dim -> Rank -> NumberOfParticles -> QC.Gen Particles
arbParticles dim rank num = do
  vdms <- V.replicateM num (arbWDM dim rank)
  let wr = V.foldl' (\acc (WeighedDensityMatrix (wi, _)) -> acc + wi) 0 vdms
      vdmsn = V.map (over WeighedDensityMatrix (\(w, dm) -> (w / wr, dm))) vdms
  QC.Positive w <- QC.arbitrary
  return $ Particles rank w num vdmsn

instance Arbitrary DensityMatrix where
  arbitrary = do
    dim <- QC.suchThat QC.getSize (> 0)
    arbDM dim dim

instance Arbitrary PureStateVector where
  arbitrary = do
    dim <- QC.suchThat QC.getSize (> 0)
    sv <- arbNormedVecDim dim
    return . PureStateVector $ sv

instance Arbitrary WeighedDensityMatrix where
  arbitrary = do
    (w, dm) <- arbitraryWeighed
    return . WeighedDensityMatrix $ (w, dm)

instance Arbitrary WeighedPureStateVector where
  arbitrary = do
    (w, sv) <- arbitraryWeighed
    return . WeighedPureStateVector $ (w, sv)

instance QC.Arbitrary Particles where
  arbitrary = do
    (dim, rank) <- arbDimRank
    num <- QC.suchThat QC.arbitrary (> 100)
    arbParticles dim rank num

class MEq a where
  infix 4 <==>
  (<==>) :: a -> a -> Bool

instance MEq DensityMatrix where
  DensityMatrix dm1 <==> DensityMatrix dm2 = LA.norm_Frob (dm1 - dm2) < 1e-6

instance MEq WeighedDensityMatrix where
  WeighedDensityMatrix (w1, DensityMatrix dm1) <==> WeighedDensityMatrix (w2, DensityMatrix dm2) =
    LA.norm_Frob (LA.scalar (w1 :+ 0) * dm1 - LA.scalar (w2 :+ 0) * dm2) < 1e-6

instance MEq PureStateVector where
  sv1 <==> sv2 = 1 - fidelity sv1 sv2 < 1e-6

instance MEq WeighedPureStateVector where
  WeighedPureStateVector (w1, sv1) <==> WeighedPureStateVector (w2, sv2) =
    abs (w1 - w2) <= 1e-6 * 0.5 * (w1 + w2) && sv1 <==> sv2


module Lib.Practice.P0
    (
        f0
    ) where

import Numeric.LinearAlgebra
import Lib.Utility

f0 = do
    -- 配列の生成
    let x = vector [1..3]
    print x

    -- 加減乗除
    let y = vector [2, 4..6]
    print $ x + y
    print $ x - y
    print $ x * y
    print $ x / y

    -- ブロードキャスト
    print $ x / 2

    -- 行列
    let mA = (2><2) [1..4] :: Matrix Double
    print mA
    print $ size mA
    let mB = (2><2) [3, 0, 0, 6]
    print $ mA + mB
    print $ mA * mB

    -- 行列のブロードキャスト
    print $ mA * 10
    print $ mA * row [10, 20]
    -- ↑MatrixとVectorのelement-wiseな計算用の演算子がない？

    -- 要素へのアクセス
    let mX = (3><2) [51, 55, 14, 19, 0, 4 :: Double]
    print $ mX ! 0
    print $ mX ! 0 ! 1
    mapM_ print $ toRows mX
    let flattened = flatten mX
    print $ map (flattened !) $ [0, 2, 4]
    print $ map (==1) $ toList $ flattened .>. 15
    print $ filter (>15) $ toList flattened


module Test where

  import Numeric.LinearAlgebra
  import Data.List
  import Debug.Trace

  import Neural
  import Tool

  {- Network test codes-}

  -- Train a network and run validation and test
  runSuite :: Int -> Double -> [Int] -> ([Example], [Example], [Example]) -> IO ()
  runSuite epoch learningRate hiddenDims (training, validation, test) = do
    initialNetwork <- initNetwork hiddenDims (size $ (fst.head) training)
    let network = train epoch learningRate training initialNetwork
    putStrLn "Validation Phase"
    runTest validation (predict network)
    putStrLn "Test Phase"
    runTest test (predict network)

  -- Run test with given examples
  runTest :: [Example] -> (Vector Double -> Vector Double) -> IO ()
  runTest examples predictFunction =
    do
      putStrLn "Confusion Matrix : "
      disp 6 confusion
      putStr "Precision : "
      putStrLn $ show (getPrecision confusion)
        where
          confusion = getConfusion predictions gts
            where
              predictions = (predictFunction . fst) `map` examples
              gts = snd `map` examples

  -- Generate confusion matrix
  -- Row for prediction, col for ground truth
  getConfusion :: [Vector Double] -> [Vector Double] -> Matrix Double
  --getConfusion pred gts | trace ("getConfusion " ++ show pred ++ " " ++ show gts) False = undefined
  getConfusion pred gts =
    accum (zeromat width height) (+) ((\p -> (p, 1)) `map` pts)
      where
        width = size (head pred)
        height = width
        pts = zip (stepLabel `map` pred) (stepLabel `map` gts)

  -- Computes precision from a confusion matrix
  getPrecision :: Matrix Double -> Double
  getPrecision confusion = (sumElements $ takeDiag confusion) / (sumElements confusion)

  -- Splits examples into test/validation/test sets
  splitDataSet :: [Example] -> ([Example], [Example], [Example])
  splitDataSet wholeData = training `seq` validation `seq` test `seq` (training, validation, test)
    where
      half = length wholeData `quot` 2
      valLen  = 2 * (length wholeData `quot` 10)
      testLen  = 3 * (length wholeData `quot` 10)

      training = take half wholeData
      validation = ((take valLen) . (drop half)) wholeData
      test = ((take testLen) . (drop valLen) . (drop half)) wholeData


module Neural where

import qualified Numeric.LinearAlgebra               as HM  -- non-backprop hmatrix
import qualified Numeric.LinearAlgebra.Data          as HMD
import qualified Numeric.LinearAlgebra.Static        as HMS -- hmatrix with type-checked operations :D

linear weights bias x = (HMS.mul x weights) + bias
relu weights = map (\x -> max 0 x) (HM.toLists weights)


import Graphics.UI.GLUT
import Data.Complex

iterations = 400

chunk :: Int -> [a] -> [[a]]
chunk n [] = []
chunk n xs = let (xs', rest) = splitAt n xs in xs' : chunk n rest

vertices :: IO [Vertex2 GLfloat]
vertices = get windowSize >>= \(Size w h) ->
           return $ [pixel (Size w h) (x, y) | x <- [0..w-1], y <- [0..h-1]]
  where
    pixel (Size w h) (x, y) = Vertex2 ((fromIntegral 3 / fromIntegral w * fromIntegral x) - 2.0) ((fromIntegral 2 / fromIntegral h * fromIntegral y) - 1.0)

getcol :: Int -> Color3 Float
getcol iter | iter == iterations = Color3 0 0 0
              | otherwise          = Color3 (amt*0.5) amt (amt*0.5)
  where
    amt = fromIntegral iter / fromIntegral iterations

mandelbrot :: RealFloat a => Vertex2 a -> Int
mandelbrot (Vertex2 r i) = length . takeWhile (\z -> magnitude z <= 2) . take iterations $ iterate (\z -> z^2 + (r :+ i)) 0

drawVert :: (RealFloat a, VertexComponent a) => Vertex2 a -> IO ()
drawVert v = do color . getcol $ mandelbrot v
                vertex v

display' :: [[Vertex2 GLfloat]] -> IO ()
display' chunks = do mapM_ (\vs -> do renderPrimitive Points $ mapM_ drawVert vs
                                      flush) chunks
                     displayCallback $= display

display :: IO ()
display = do clear [ ColorBuffer ]
             displayCallback $= (vertices >>= display' . chunk 256)
             get currentWindow >>= postRedisplay

main :: IO ()
main = do
   getArgsAndInitialize
   initialDisplayMode $= [ SingleBuffered, RGBMode ]
   initialWindowSize $= Size 1200 1024
   initialWindowPosition $= Position 100 100
   createWindow "Mandelbrot"
   clearColor $= Color4 0 0 0 0
   matrixMode $= Projection
   loadIdentity
   ortho (-2) 1 (-1) 1 (-1) 1
   displayCallback $= display
   mainLoop


{-# Language TypeApplications #-}

module LineSpec where

import Test.Hspec
import Test.QuickCheck
import Test.Invariant
import Data.Complex
import Data.Fixed (mod')
import Data.Maybe
import Geometry
import Geometry.Testing

spec :: Spec
spec = describe "Line" $ do
    describe "Affinity" $ do
      it "1" $ (asCmp 1 :: Line) == Line (0,1)
      it "2" $ (asCmp 1 :: Ray) == Ray (0,1)
      it "3" $ (asCmp 1 :: Segment) == Segment (0,1)
      it "4" $ property $ \l -> asCmp (cmp l) # at' (refPoint l) == (l :: Line)
      it "5" $ property $ \l -> asCmp (cmp l) # at' (refPoint l) == (l :: Ray)
      it "5" $ property $ \l -> asCmp (cmp l) # at' (refPoint l) == (l :: Segment)
      it "6" $ property $ \x -> cmp (asCmp x :: Line) == x
      it "7" $ property $ \x -> cmp (asCmp x :: Ray) == x
      it "8" $ property $ \x -> cmp (asCmp x :: Segment) == x

    describe "parametrization" $ do
      it "1" $ property $ \(AnyLine l) x -> (l @-> x) ->@ l ~= x

      it "2" $ property $ \(AnyLine l) x ->
        let p = l @-> x
        in l @-> (p ->@ l) ~= p

      it "3" $ line' @Cmp @Cmp 0 1 @-> 0 == 0
      it "4" $ line' @Cmp @Cmp 0 2 @-> 1 == 2
      it "5" $ line' @Cmp @Cmp 0 2 @-> 0.5 == 1

      it "6" $ property $ \(AnyLine l) x ->
        isJust (l @->? x)

      it "7" $ property $ \(AnyRay r) x ->
        isJust (r @->? x) <==> x >= 0

      it "8" $ property $ \(AnySegment s) x ->
        let x' = 2 * cos x
        in isJust (s @->? x') <==> 0 <= x' && x' <= 1

      it "9" $ property $ \(AnyLine l) (AnyPoint p) -> isJust (p ->@? l)

      it "10" $ property $ \(AnyRay r) (AnyPoint p) ->
        let an = deg . angleValue $ angleBetween r (r # through' p)
        in isJust (p ->@? r)
           <==>
           (0 <= an && an <= 90) || (270 <= an && an <= 360)

      it "11" $ property $ \(AnySegment s) (AnyPoint p) ->
        let (p1, p2) = refPoints s
            an1 = deg . angleValue . innerAngle $ angleWithin p p1 p2
            an2 = deg . angleValue . innerAngle $ angleWithin p p2 p1
        in isJust (p ->@? s)
           <==>
           (0 <= an1 && an1 <= 90) && (0 <= an2 && an2 <= 90)

    describe "containing" $ do
      it "1.1" $
        property $ \(AnyLine l) x -> l `isContaining` (l @-> x)
      it "1.2" $
        property $ \(AnyLine l) -> l `isContaining` refPoint l

      it "2.1" $ aRay `isContaining` ((0,0) :: XY)
      it "2.2" $ aRay `isContaining` ((1,0) :: XY)
      it "2.5" $ not $ aRay `isContaining` ((-1,0) :: XY)
      it "2.6" $ not $ aRay `isContaining` ((1,1) :: XY)

      it "3.1" $ aSegment `isContaining` ((0,0) :: XY)
      it "3.2" $ aSegment `isContaining` ((1,0) :: XY)
      it "3.3" $ aSegment `isContaining` (aSegment @-> 0)
      it "3.4" $ aSegment `isContaining` (aSegment @-> 1)
      it "3.5" $ not $ aSegment `isContaining` ((-1,0) :: XY)
      it "3.6" $ not $ aSegment `isContaining` ((3,0) :: XY)

    describe "tangent and family" $ do
      it "1" $ angle (line' @Cmp @Cmp 0 (1:+1)) == 45
      it "2" $ normal (line' @Cmp @Cmp 0 (1:+2)) 0 == asCmp ((-2):+1)

    describe "unit" $ do
      it "1" $ unit (line' @Cmp @Cmp 0 (3:+4)) == 5
      it "2" $ unit (asCmp 1 :: Ray) == 1
      it "3" $ unit (asCmp 1 :: Segment) == 1
      it "4" $ property $ \l -> unit l == norm (l :: Line)
      it "5" $ property $ \l -> unit l == norm (l :: Ray)
      it "6" $ property $ \l -> unit l == norm (l :: Segment)

    describe "at" $
      it "1" $ aLine # at ((1,2) :: XY) == line (1,2) (2,2)

    describe "along" $ do
      it "1" $ aLine # at (2,3) # along 0 == line (2,3) (3,3)
      it "2" $ aLine # at (2,3) # along 90 == line (2,3) (2,4)
      it "3" $
        property $ \a p l ->
                     let _ = (a :: Direction, p :: Point, l :: Line)
                     in l # at' p # along' a == l # along' a # at' p

    describe "extendToLength" $
      it "1" $ property $ \(AnySegment s) d ->
        unit (s # extendToLength d) ~= abs d

    describe "extendTo" $ do
      it "1" $ property $ \(AnySegment s) (AnyLine l) ->
        (asRay s `isIntersecting` l) ==>
        l `isContaining` ((s # extendTo l) @-> 1)
      it "2" $ property $ \(AnySegment s) (AnyCircle c) ->
        (asRay s `isIntersecting` c) ==>
        c `isContaining` ((s # extendTo c) @-> 1)

    describe "heightTo" $
      it "1" $ property $ \(AnyPoint p) (AnyLine l) ->
        not (l `isContaining` cmp p) ==>
        fromMaybe False $ do
          h <- l # heightFrom p
          return $ l `isContaining` end h && l `isOrthogonal` h

      -- it "2" $ property $ \(AnyPoint p) (AnyCircle c) ->
      --   not (c `isContaining` p) ==>
      --   fromMaybe False $ do
      --     h <- p # heightTo c
      --     let n = normal c (project c (end h))
      --     return $ c `isContaining` (end h) && h `isCollinear` n

    describe "distanceTo" $ do
      it "1" $ origin `distanceTo` aLine == 0
      it "2" $ origin `distanceTo` (aLine # at (0,1)) == 1
      it "3" $ origin `distanceTo` (aLine # at (0,1) # along 45) ~= 1/sqrt 2
      it "4" $ origin `distanceTo` aRay == 0
      it "5" $ origin `distanceTo` (aRay # at (3,4)) == 5
      it "6" $ origin `distanceTo` (aRay # at (-1,0)) == 0
      it "7" $ origin `distanceTo` aSegment == 0
      it "8" $ origin `distanceTo` (aSegment # at (3,4)) ~= 5
      it "9" $ origin `distanceTo` (aSegment # at (-2,0)) ~= 1
      it "10" $ origin `distanceTo` segment (-1,0) (0,1) ~= 1/sqrt 2

    describe "intersections" $ do
      it "1" $
        property $ \(AnyLine l1) (AnyLine l2) ->
             isIntersecting l1 l2
             <==>
             not (l1 `isCollinear` l2) || l1 `isContaining` refPoint l2
      let r = Ray (0, 1:+1)
          s = Segment (0, 1:+1)
      it "2.1" $ r `intersections` (r # translate (3,0)) # null
      it "2.2" $ r `intersections` (r # rotate 90 # translate (2,0) ) == [1:+1]
      it "2.3" $ r `intersections` (r # rotate 90 # translate (-1,0) ) # null
      it "3.1" $ r `intersections` (s # translate (3,0)) # null
      it "3.2" $ r `intersections` (s # rotate 90 # translate (2,0) ) == [1:+1]
      it "3.3" $ r `intersections` (s # rotate 90 # translate (2.1,0) ) # null
      it "3.4" $ r `intersections` (s # rotate 90 # translate (1,1) ) == [1:+1]
      it "4.4" $ s `intersections` (s # rotate 90 # translate (1,1) ) == [1:+1]
      it "4.5" $ s `intersections` (s # rotate 90) == [0]
      it "4.6" $ s `intersections` (s # rotate 90 # translate (1.01,1.01) ) # null
      it "4.7" $ s `intersections` (s # rotate 90 # translate (0.5,0.5) ) ~= [0.5:+0.5]

      it "5.1" $
        property $ \(AnyLine l) (AnyRay r) ->
            if l `isCollinear` r
            then null (l `intersections` r) ||
                 (r `intersections` l ~= [start r]
                   && l `intersections` r ~= [start l])
            else l `intersections` r ~= r `intersections` l

      it "5.2" $
        property $ \(AnyLine l) (AnySegment s) ->
             if l `isCollinear` s
             then null (l `intersections` s) ||
                  (s `intersections` l ~= [start s]
                   && l `intersections` s ~= [start l])
             else l `intersections` s ~= s `intersections` l

      it "5.3" $
          property $ \(AnySegment s) (AnyRay r) ->
             if s `isCollinear` r
             then null (s `intersections` r) ||
                  (r `intersections` s ~= [start r]
                   && s `intersections` r ~= [start s])
             else s `intersections` r ~= r `intersections` s

    describe "clipping" $ do
      it "1" $ aLine # rotate 45 # clipBy aSquare == [Segment (0, 1:+1)]
      it "2" $ aLine # rotate 45 # at (0.5,0.5) # clipBy aSquare ==
                [Segment (0, 1:+1)]
      it "3" $ aRay # rotate 45 # at (0.5,0.5) # clipBy aSquare ==
                [Segment (0.5:+0.5, 1:+1)]
      it "4" $ aSegment # rotate 45 # at (0.1,0.1) # clipBy aSquare ==
                [Segment (0.1:+0.1, 0.8071067811865475:+0.8071067811865475)]
      it "5" $ aLine # rotate 45 # at (-0.5,0) # clipBy aSquare ==
                [Segment (0:+0.5, 0.5:+1)]


-- |
module Main where

import Control.Monad
import Control.Monad.ST (runST)

import qualified Data.Vector.Unboxed as U

import Criterion.Main
import System.Random.MWC
--
import Numeric.Sum
import Statistics.Monoid
import Statistics.Monoid.Extra

sampleD10,sampleD100,sampleD1000 :: U.Vector Double
sampleD10   = runST $ U.replicateM 10   . uniform =<< create
sampleD100  = runST $ U.replicateM 100  . uniform =<< create
sampleD1000 = runST $ U.replicateM 1000 . uniform =<< create

sampleI10,sampleI100,sampleI1000 :: U.Vector Int
sampleI10   = runST $ U.replicateM 10   . uniform =<< create
sampleI100  = runST $ U.replicateM 100  . uniform =<< create
sampleI1000 = runST $ U.replicateM 1000 . uniform =<< create

main :: IO ()
main = defaultMain
  [ bgroup "Count"
      [ bench "10   D" $ whnf (reduceSampleVec :: U.Vector Double -> Count) sampleD10
      , bench "100  D" $ whnf (reduceSampleVec :: U.Vector Double -> Count) sampleD100
      , bench "1000 D" $ whnf (reduceSampleVec :: U.Vector Double -> Count) sampleD1000
      ]
  , bgroup "KBN"
      [ bench "10   D" $ whnf (reduceSampleVec :: U.Vector Double -> KBNSum) sampleD10
      , bench "100  D" $ whnf (reduceSampleVec :: U.Vector Double -> KBNSum) sampleD100
      , bench "1000 D" $ whnf (reduceSampleVec :: U.Vector Double -> KBNSum) sampleD1000
      ]
  , bgroup "Kahan"
      [ bench "10   D" $ whnf (reduceSampleVec :: U.Vector Double -> KahanSum) sampleD10
      , bench "100  D" $ whnf (reduceSampleVec :: U.Vector Double -> KahanSum) sampleD100
      , bench "1000 D" $ whnf (reduceSampleVec :: U.Vector Double -> KahanSum) sampleD1000
      ]
  , bgroup "MeanKBN"
      [ bench "10   D" $ whnf (reduceSampleVec :: U.Vector Double -> MeanKBN) sampleD10
      , bench "100  D" $ whnf (reduceSampleVec :: U.Vector Double -> MeanKBN) sampleD100
      , bench "1000 D" $ whnf (reduceSampleVec :: U.Vector Double -> MeanKBN) sampleD1000
      , bench "10   I" $ whnf (reduceSampleVec :: U.Vector Int    -> MeanKBN) sampleI10
      , bench "100  I" $ whnf (reduceSampleVec :: U.Vector Int    -> MeanKBN) sampleI100
      , bench "1000 I" $ whnf (reduceSampleVec :: U.Vector Int    -> MeanKBN) sampleI1000
      ]
  , bgroup "WelfordMean"
      [ bench "10   D" $ whnf (reduceSampleVec :: U.Vector Double -> WelfordMean) sampleD10
      , bench "100  D" $ whnf (reduceSampleVec :: U.Vector Double -> WelfordMean) sampleD100
      , bench "1000 D" $ whnf (reduceSampleVec :: U.Vector Double -> WelfordMean) sampleD1000
      , bench "10   I" $ whnf (reduceSampleVec :: U.Vector Int    -> WelfordMean) sampleI10
      , bench "100  I" $ whnf (reduceSampleVec :: U.Vector Int    -> WelfordMean) sampleI100
      , bench "1000 I" $ whnf (reduceSampleVec :: U.Vector Int    -> WelfordMean) sampleI1000
      ]
  , bgroup "Variance"
      [ bench "10   D" $ whnf (reduceSampleVec :: U.Vector Double -> Variance) sampleD10
      , bench "100  D" $ whnf (reduceSampleVec :: U.Vector Double -> Variance) sampleD100
      , bench "1000 D" $ whnf (reduceSampleVec :: U.Vector Double -> Variance) sampleD1000
      , bench "10   I" $ whnf (reduceSampleVec :: U.Vector Int    -> Variance) sampleI10
      , bench "100  I" $ whnf (reduceSampleVec :: U.Vector Int    -> Variance) sampleI100
      , bench "1000 I" $ whnf (reduceSampleVec :: U.Vector Int    -> Variance) sampleI1000
      ]
  ]


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

module Main where

import Mandelbrot

import Control.Parallel.Strategies

import Data.Complex
import Data.Maybe
import Data.List (foldl')
import Data.Word

import Data.Colour.SRGB (sRGB, toSRGB)
import Data.Colour.RGBSpace
import Data.Colour.Palette.BrewerSet

import Data.ByteString (ByteString, pack, concat)
import Data.ByteString.Conversion
import Codec.BMP

-- Number of samples per dimension.
resolution = 2400

-- How many samples to calculate in each parallel unit of work.
chunkSize = 100

-- Useful coordinates.
starburst = (-0.3740) :+ 0.6596
trident = (-0.1011) :+ 0.9563
seahorse = (-0.75) :+ 0.01
origin = 0 :+ 0

imageLocus = starburst
imageScale = 0.02

palette :: [Kolor]
palette = let
  style = Spectral
  size = 9
  in brewerSet style size

xMin = realPart imageLocus - imageScale
xMax = realPart imageLocus + imageScale
xInc = (xMax - xMin) / resolution
yMin = imagPart imageLocus - imageScale
yMax = imagPart imageLocus + imageScale
yInc = (yMax - yMin) / resolution

samples = [x :+ y | y <- ys, x <- xs] where
  xs = tail [xMin, (xMin + xInc) .. xMax]
  ys = tail [yMin, (yMin + yInc) .. yMax]

divMap :: [Complex Double] -> [Int]
divMap = withStrategy (parListChunk chunkSize rpar) . map divergence

normalizeDiv :: Int -> Double
normalizeDiv d = fromIntegral d / 200 --fromIntegral iterations

-- Assign a color to a divergence value in [0..iterations].
colorify :: Int -> Kolor
colorify d = let
  cap = length palette
  nDiv = normalizeDiv d
  in
    if d < iterations
    then
      let intensity = min (nDiv * nDiv) 1
      in sRGB intensity intensity intensity
    else sRGB 0.0 0.0 0.0

normalizeColor :: Double -> Word8
normalizeColor val = fromIntegral $ floor (val * 256)

packColor :: Kolor -> ByteString
packColor c = let rgb = toSRGB c
  in pack $ normalizeColor <$> [channelRed rgb, channelGreen rgb, channelBlue rgb, 256]

byteArray :: ByteString
byteArray = Data.ByteString.concat (packColor . colorify <$> divMap samples)

main = let bitmap = packRGBA32ToBMP resolution resolution byteArray
  in writeBMP "/dev/stdout" bitmap


{-# LANGUAGE TemplateHaskell #-}
{-|
    Module      :  Numeric.MixedType.Complex
    Description :  Instances for Data.Complex
    Copyright   :  (c) Michal Konecny
    License     :  BSD3

    Maintainer  :  mikkonecny@gmail.com
    Stability   :  experimental
    Portability :  portable

    Instances for "Data.Complex".
-}

{-# OPTIONS_GHC -Wno-orphans #-}
module Numeric.MixedTypes.Complex
(
  tComplex
)
where

import Numeric.MixedTypes.PreludeHiding
-- import qualified Prelude as P
-- import Text.Printf

import Utils.TH.DeclForTypes

import Data.Complex

import Numeric.MixedTypes.Literals
import Numeric.MixedTypes.Bool
import Numeric.MixedTypes.Eq
import Numeric.MixedTypes.MinMaxAbs
import Numeric.MixedTypes.AddSub
import Numeric.MixedTypes.Mul
import Numeric.MixedTypes.Div
-- import Numeric.MixedTypes.Power
-- import Numeric.MixedTypes.Field
import Numeric.MixedTypes.Elementary

tComplex :: T t -> T (Complex t)
tComplex (T tName) = T ("(Complex " ++ tName ++ ")")

instance (ConvertibleExactly Integer t) => (ConvertibleExactly Integer (Complex t))
  where
  safeConvertExactly n =
    do
    nT <- safeConvertExactly n
    zT <- safeConvertExactly 0
    return $ nT :+ zT

instance (ConvertibleExactly Int t) => (ConvertibleExactly Int (Complex t))
  where
  safeConvertExactly n =
    do
    nT <- safeConvertExactly n
    zT <- safeConvertExactly (int 0)
    return $ nT :+ zT

instance (ConvertibleExactly Rational t) => (ConvertibleExactly Rational (Complex t))
  where
  safeConvertExactly r =
    do
    rT <- safeConvertExactly r
    zT <- safeConvertExactly 0.0
    return $ rT :+ zT

instance (ConvertibleExactly t1 t2) => (ConvertibleExactly (Complex t1) (Complex t2))
  where
  safeConvertExactly (a1 :+ i1) =
    do
    a2 <- safeConvertExactly a1
    i2 <- safeConvertExactly i1
    return $ a2 :+ i2

instance (HasEqAsymmetric a b) => HasEqAsymmetric (Complex a) (Complex b) where
  type EqCompareType (Complex a) (Complex b) = EqCompareType a b
  equalTo (a1 :+ i1) (a2 :+ i2) = (a1 == a2) && (i1 == i2)

instance (CanTestInteger t, CanTestZero t) => CanTestInteger (Complex t) where
  certainlyNotInteger (a :+ i) =
    certainlyNotInteger a || isCertainlyNonZero i
  certainlyIntegerGetIt (a :+ i) =
    case (certainlyIntegerGetIt a, certainlyIntegerGetIt i) of
      (Just aN, Just iN) | iN == 0 -> Just aN
      _ -> Nothing

instance CanNeg t => CanNeg (Complex t) where
  type NegType (Complex t) = Complex (NegType t)
  negate (a :+ i) = (negate a) :+ (negate i)

instance (CanAddAsymmetric a b) => CanAddAsymmetric (Complex a) (Complex b) where
  type AddType (Complex a) (Complex b) = Complex (AddType a b)
  add (a1 :+ i1) (a2 :+ i2) = (a1 + a2) :+ (i1 + i2)

instance (CanSub a b) => CanSub (Complex a) (Complex b) where
  type SubType (Complex a) (Complex b) = Complex (SubType a b)
  sub (a1 :+ i1) (a2 :+ i2) = (a1 - a2) :+ (i1 - i2)

instance
  (CanMulAsymmetric a b
  , CanAddSameType (MulType a b), CanSubSameType (MulType a b))
  =>
  CanMulAsymmetric (Complex a) (Complex b)
  where
  type MulType (Complex a) (Complex b) = Complex (MulType a b)
  mul (a1 :+ i1) (a2 :+ i2) =
    (a1*a2 - i1*i2) :+ (a1*i2 + i1*a2)

instance
  (CanMulAsymmetric a b
  , CanAddSameType (MulType a b), CanSubSameType (MulType a b)
  , CanMulAsymmetric b b, CanAddSameType (MulType b b)
  , CanDiv (MulType a b) (MulType b b))
  =>
  CanDiv (Complex a) (Complex b)
  where
  type DivType (Complex a) (Complex b) = Complex (DivType (MulType a b) (MulType b b))
  divide (a1 :+ i1) (a2 :+ i2) =
    let d = a2*a2 + i2*i2 in
    ((a1*a2 + i1*i2)/d) :+ ((i1*a2-a1*i2)/d)

instance
  (CanMulAsymmetric t t
  , CanAddSameType (MulType t t)
  , CanSqrt (MulType t t))
  =>
  CanAbs (Complex t)
  where
  type AbsType (Complex t) = SqrtType (MulType t t)
  abs (a :+ i) = sqrt (a*a + i*i)

instance
  (CanExp t
  , CanSinCos t
  , CanMulAsymmetric (ExpType t) (SinCosType t))
  =>
  CanExp (Complex t)
  where
  type ExpType (Complex t) = Complex (MulType (ExpType t) (SinCosType t))
  exp (a :+ i) =
    let ea = exp a in
    (ea * cos i) :+ (ea * sin i)

$(declForTypes
  [[t| Integer |], [t| Int |], [t| Rational |], [t| Double |]]
  (\ t -> [d|

    instance (HasEqAsymmetric $t b) => HasEqAsymmetric $t (Complex b) where
      type EqCompareType $t (Complex b) = EqCompareType $t b
      equalTo n (a2 :+ i2) = (n == a2) && (convertExactlyTargetSample n 0 == i2)

    instance (HasEqAsymmetric a $t) => HasEqAsymmetric (Complex a) $t where
      type EqCompareType (Complex a) $t = EqCompareType a $t
      equalTo (a1 :+ i1) n = (a1 == n) && (i1 == convertExactlyTargetSample n 0)

    instance (CanAddAsymmetric $t b) => CanAddAsymmetric $t (Complex b) where
      type AddType $t (Complex b) = Complex (AddType $t b)
      add n (a2 :+ i2) = (n + a2) :+ (convertExactlyTargetSample n 0 + i2)

    instance (CanAddAsymmetric a $t) => CanAddAsymmetric (Complex a) $t where
      type AddType (Complex a) $t = Complex (AddType a $t)
      add (a1 :+ i1) n = (a1 + n) :+ (i1 + (convertExactlyTargetSample n 0))

    instance (CanSub $t b) => CanSub $t (Complex b) where
      type SubType $t (Complex b) = Complex (SubType $t b)
      sub n (a2 :+ i2) = (n - a2) :+ (convertExactlyTargetSample n 0 - i2)

    instance (CanSub a $t) => CanSub (Complex a) $t where
      type SubType (Complex a) $t = Complex (SubType a $t)
      sub (a1 :+ i1) n = (a1 - n) :+ (i1 - (convertExactlyTargetSample n 0))

    instance
      (CanMulAsymmetric $t b) => CanMulAsymmetric $t (Complex b)
      where
      type MulType $t (Complex b) = Complex (MulType $t b)
      mul n (a2 :+ i2) = (n*a2) :+ (n*i2)

    instance
      (CanMulAsymmetric a $t) => CanMulAsymmetric (Complex a) $t
      where
      type MulType (Complex a) $t = Complex (MulType a $t)
      mul (a1 :+ i1) n = (a1*n) :+ (i1*n)

    instance
      (CanMulAsymmetric $t b
      , CanMulAsymmetric b b, CanAddSameType (MulType b b)
      , CanDiv (MulType $t b) (MulType b b))
      =>
      CanDiv $t (Complex b)
      where
      type DivType $t (Complex b) = Complex (DivType (MulType $t b) (MulType b b))
      divide n (a2 :+ i2) =
        let d = a2*a2 + i2*i2 in
        ((n*a2)/d) :+ (((-n)*i2)/d)

    instance
      (CanDiv a $t) => CanDiv (Complex a) $t
      where
      type DivType (Complex a) $t = Complex (DivType a $t)
      divide (a1 :+ i1) n = (a1/n) :+ (i1/n)
  |]))