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


{-# 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)
  |]))