{-# LANGUAGE AllowAmbiguousTypes                      #-}
{-# LANGUAGE ApplicativeDo                            #-}
{-# LANGUAGE DeriveDataTypeable                       #-}
{-# LANGUAGE DeriveGeneric                            #-}
{-# LANGUAGE FlexibleContexts                         #-}
{-# LANGUAGE FlexibleInstances                        #-}
{-# LANGUAGE GADTs                                    #-}
{-# LANGUAGE KindSignatures                           #-}
{-# LANGUAGE MultiParamTypeClasses                    #-}
{-# LANGUAGE PatternSynonyms                          #-}
{-# LANGUAGE RankNTypes                               #-}
{-# LANGUAGE RecordWildCards                          #-}
{-# LANGUAGE ScopedTypeVariables                      #-}
{-# LANGUAGE TypeApplications                         #-}
{-# LANGUAGE TypeFamilies                             #-}
{-# LANGUAGE TypeInType                               #-}
{-# LANGUAGE TypeOperators                            #-}
{-# LANGUAGE UndecidableInstances                     #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-}

module Backprop.Learn.Model.Regression (
    LinReg(..)
  , LogReg, pattern LogReg
  , LRp(..), lrBeta, lrAlpha, runLRp
  , expandInput, expandOutput, reshapeInput, reshapeOutput
  , ARIMA(..), ARIMAp(..), ARIMAs(..)
  , ARIMAUnroll, arimaUnroll
  , ARIMAUnrollFinal, arimaUnrollFinal
  , AR, MA, ARMA
  ) where

import           Backprop.Learn.Initialize
import           Backprop.Learn.Model.Class
import           Backprop.Learn.Model.Combinator
import           Backprop.Learn.Model.Function
import           Backprop.Learn.Model.Parameter
import           Backprop.Learn.Model.State
import           Control.DeepSeq
import           Control.Monad.Primitive
import           Data.Finite
import           Data.Kind
import           Data.List
import           Data.Maybe
import           Data.Proxy
import           Data.Type.Equality
import           Data.Typeable
import           GHC.Generics                          (Generic)
import           GHC.TypeLits.Compare
import           GHC.TypeLits.Extra
import           GHC.TypeNats
import           Lens.Micro
import           Numeric.Backprop
import           Numeric.LinearAlgebra.Static.Backprop
import           Numeric.LinearAlgebra.Static.Vector
import           Numeric.OneLiner
import           Numeric.Opto.Ref
import           Numeric.Opto.Update hiding            ((<.>))
import           Statistics.Distribution
import           Unsafe.Coerce
import qualified Data.Binary                           as Bi
import qualified Data.Type.Tuple                       as T
import qualified Data.Vector.Generic.Sized             as SVG
import qualified Data.Vector.Sized                     as SV
import qualified Data.Vector.Storable.Sized            as SVS
import qualified Numeric.LinearAlgebra                 as HU
import qualified Numeric.LinearAlgebra.Static          as H
import qualified System.Random.MWC                     as MWC

-- | Multivariate linear regression, from an i-vector to an o-vector.
data LinReg (i :: Nat) (o :: Nat) = LinReg
  deriving Typeable

-- | Mutivariate Logistic regression, from an i-vector to an o-vector.
--
-- Essentially a linear regression postcomposed with the logistic
-- function.
type LogReg i o = RMap (R o) (R o) (LinReg i o)

-- | Constructor for a 'LogReg'
pattern LogReg :: LogReg i o
pattern LogReg <- RM _ LinReg
  where
    LogReg = RM logistic LinReg
{-# COMPLETE LogReg #-}

-- | Linear Regression parameter
data LRp i o = LRp
    { _lrAlpha :: !(R o)
    , _lrBeta  :: !(L o i)
    }
  deriving (Generic, Typeable, Show)

instance NFData (LRp i o)
instance (KnownNat i, KnownNat o) => Initialize (LRp i o)
instance (KnownNat i, KnownNat o) => Additive (LRp i o)
instance (KnownNat i, KnownNat o) => Scaling Double (LRp i o)
instance (KnownNat i, KnownNat o) => Metric Double (LRp i o)
instance (KnownNat i, KnownNat o, Ref m (LRp i o) v) => AdditiveInPlace m v (LRp i o)
instance (KnownNat i, KnownNat o, Ref m (LRp i o) v) => ScalingInPlace m v Double (LRp i o)
instance (KnownNat i, KnownNat o) => Bi.Binary (LRp i o)
instance (KnownNat i, KnownNat o) => Backprop (LRp i o)

lrBeta :: Lens (LRp i o) (LRp i' o) (L o i) (L o i')
lrBeta f lrp = (\w -> lrp { _lrBeta = w }) <$> f (_lrBeta lrp)

lrAlpha :: Lens' (LRp i o) (R o)
lrAlpha f lrp = (\b -> lrp { _lrAlpha = b }) <$> f (_lrAlpha lrp)

runLRp
    :: (KnownNat i, KnownNat o, Reifies s W)
    => BVar s (LRp i o)
    -> BVar s (R i)
    -> BVar s (R o)
runLRp lrp x = (lrp ^^. lrBeta) #> x + (lrp ^^. lrAlpha)

instance (KnownNat i, KnownNat o) => Num (LRp i o) where
    (+)         = gPlus
    (-)         = gMinus
    (*)         = gTimes
    negate      = gNegate
    abs         = gAbs
    signum      = gSignum
    fromInteger = gFromInteger

instance (KnownNat i, KnownNat o) => Fractional (LRp i o) where
    (/)          = gDivide
    recip        = gRecip
    fromRational = gFromRational

instance (KnownNat i, KnownNat o) => Floating (LRp i o) where
    pi    = gPi
    sqrt  = gSqrt
    exp   = gExp
    log   = gLog
    sin   = gSin
    cos   = gCos
    tan   = gTan
    asin  = gAsin
    acos  = gAcos
    atan  = gAtan
    sinh  = gSinh
    cosh  = gCosh
    asinh = gAsinh
    acosh = gAcosh
    atanh = gAtanh

instance (KnownNat i, KnownNat o) => Learn (R i) (R o) (LinReg i o) where
    type LParamMaybe (LinReg i o) = 'Just (LRp i o)

    runLearn _ (J_ p) = stateless (runLRp p)

-- | Adjust an 'LRp' to take extra inputs, initialized randomly.
--
-- Initial contributions to each output is randomized.
expandInput
    :: (PrimMonad m, ContGen d, KnownNat i, KnownNat j, KnownNat o)
    => LRp i o
    -> d
    -> MWC.Gen (PrimState m)
    -> m (LRp (i + j) o)
expandInput LRp{..} d g = LRp _lrAlpha . (_lrBeta H.|||) <$> initialize d g

-- | Adjust an 'LRp' to return extra ouputs, initialized randomly
expandOutput
    :: (PrimMonad m, ContGen d, KnownNat i, KnownNat o, KnownNat p)
    => LRp i o
    -> d
    -> MWC.Gen (PrimState m)
    -> m (LRp i (o + p))
expandOutput LRp{..} d g = do
    newAlpha <- initialize d g
    newBeta  <- initialize d g
    pure (LRp (_lrAlpha H.# newAlpha) (_lrBeta H.=== newBeta))

-- | Premute (or remove) inputs
--
-- Removed inputs will simply have their contributions removed from each
-- output.
reshapeInput
    :: KnownNat i
    => SV.Vector i' (Finite i)
    -> LRp i o
    -> LRp i' o
reshapeInput is p = p { _lrBeta = colsL . fmap (β `SV.index`) $ is }
  where
    β = lCols (_lrBeta p)

-- | Premute (or remove) outputs
reshapeOutput
    :: KnownNat o
    => SV.Vector o' (Finite o)
    -> LRp i o
    -> LRp i o'
reshapeOutput is LRp{..} =
    LRp { _lrAlpha = vecR . SVG.convert . fmap (α `SVS.index`) $ is
        , _lrBeta  = rowsL . fmap (β `SV.index`) $ is
        }
  where
    α = rVec _lrAlpha
    β = lRows _lrBeta

-- | Auto-regressive integrated moving average model.
--
-- ARIMA(p,d,q) is an ARIMA model with p autoregressive history terms on
-- the d-th order differenced history and q error (innovation) history
-- terms.
--
-- It is a @'Learn' Double Double@ instance, and is meant to predict the
-- "next step" of a time sequence.
--
-- In this state, it is a runnable stateful model.  To train, use with
-- 'ARIMAUnroll' to unroll and fix the initial state.
data ARIMA :: Nat -> Nat -> Nat -> Type where
    ARIMA :: { _arimaGenYHist :: forall m. PrimMonad m => MWC.Gen (PrimState m) -> m Double
             , _arimaGenEHist :: forall m. PrimMonad m => MWC.Gen (PrimState m) -> m Double
             }
          -> ARIMA p d q

-- | The "unrolled" and "destated" 'ARIMA' model, which takes a vector of
-- sequential inputs and outputs a vector of the model's expected next
-- steps.
--
-- Useful for actually training 'ARIMA' using gradient descent.
--
-- This /fixes/ the initial error history to be zero (or a fixed stochastic
-- sample), and treats the initial output history to be a /learned
-- parameter/.
--
-- @
-- instance 'Learn' ('SV.Vector' n 'Double') (SV.Vector n Double) ('ARIMAUnroll' p q) where
--     -- | Initial state is a parameter, but initial error history is fixed
--     type 'LParamMaybe' (ARIMAUnroll p q) = 'Just (T2 (ARIMAp p q) (ARIMAs p q))
--     type 'LStateMaybe' (ARIMAUnroll p q) = 'Nothing
-- @
type ARIMAUnroll p d q = DeParamAt (T.T2 (ARIMAp p q) (ARIMAs p d q))
                                   (T.T2 (ARIMAp p q) (T.T2 Double (R (p + d))))
                                   (R q)
                                   (UnrollTrainState (Max (p + d) q) (ARIMA p d q))

-- | 'ARIMAUnroll', but only looking at the final output after running the
-- model on all inputs.
--
-- @
-- instance 'Learn' ('SV.Vector' n 'Double') Double ('ARIMAUnrollFinal' p q) where
--     -- | Initial state is a parameter, but initial error history is fixed
--     type 'LParamMaybe' (ARIMAUnrollFinal p q) = 'Just (T2 (ARIMAp p q) (ARIMAs p q))
--     type 'LStateMaybe' (ARIMAUnrollFinal p q) = 'Nothing
-- @
type ARIMAUnrollFinal p d q = DeParamAt (T.T2 (ARIMAp p q) (ARIMAs p d q))
                                        (T.T2 (ARIMAp p q) (T.T2 Double (R (p + d))))
                                        (R q)
                                        (UnrollFinalTrainState (Max (p + d) q) (ARIMA p d q))

splitHist
    :: T.T2 (ARIMAp p q) (ARIMAs p d q)
    -> (T.T2 (ARIMAp p q) (T.T2 Double (R (p + d))), R q)
splitHist (T.T2 p ARIMAs{..}) = (T.T2 p (T.T2 _arimaYPred _arimaYHist), _arimaEHist)

joinHist
    :: T.T2 (ARIMAp p q) (T.T2 Double (R (p + d)))
    -> R q
    -> T.T2 (ARIMAp p q) (ARIMAs p d q)
joinHist (T.T2 p (T.T2 _arimaYPred _arimaYHist)) _arimaEHist = T.T2 p ARIMAs{..}

-- | Constructor for 'ARIMAUnroll'
arimaUnroll
    :: KnownNat q
    => ARIMA p d q
    -> ARIMAUnroll p d q
arimaUnroll a@ARIMA{..} = DPA
    { _dpaSplit      = splitHist
    , _dpaJoin       = joinHist
    , _dpaParam      = 0
    , _dpaParamStoch = fmap vecR . SVS.replicateM . _arimaGenEHist
    , _dpaLearn      = UnrollTrainState a
    }

-- | Constructor for 'ARIMAUnrollFinal'
arimaUnrollFinal
    :: KnownNat q
    => ARIMA p d q
    -> ARIMAUnrollFinal p d q
arimaUnrollFinal a@ARIMA{..} = DPA
    { _dpaSplit      = splitHist
    , _dpaJoin       = joinHist
    , _dpaParam      = 0
    , _dpaParamStoch = fmap vecR . SVS.replicateM . _arimaGenEHist
    , _dpaLearn      = UnrollFinalTrainState a
    }

-- | 'ARIMA' parmaeters
data ARIMAp :: Nat -> Nat -> Type where
    ARIMAp :: { _arimaPhi      :: !(R p)
              , _arimaTheta    :: !(R q)
              , _arimaConstant :: !Double
              }
           -> ARIMAp p q
  deriving (Generic, Show)

-- | 'ARIMA' state
data ARIMAs :: Nat -> Nat -> Nat -> Type where
    ARIMAs :: { _arimaYPred :: !Double
              , _arimaYHist :: !(R (p + d))
              , _arimaEHist :: !(R q)
              }
          -> ARIMAs p d q
  deriving (Generic, Show)

instance (KnownNat p, KnownNat d, KnownNat q) => Learn Double Double (ARIMA p d q) where
    type LParamMaybe (ARIMA p d q) = 'Just (ARIMAp p q)
    type LStateMaybe (ARIMA p d q) = 'Just (ARIMAs p d q)

    runLearn ARIMA{..} (J_ p) x (J_ s) = (y, J_ s')
      where
        d :: L p (p + d)
        d  = difference
        e  = x - (s ^^. arimaYPred)
        y  = (p ^^. arimaConstant)
           + (p ^^. arimaPhi  ) <.> (constVar d #> (s ^^. arimaYHist))
           + (p ^^. arimaTheta) <.> (s ^^. arimaEHist)
        yHist' = case Proxy @1 %<=? Proxy @(p + d) of
          LE Refl -> single y # constVar dropLast #> (s ^^. arimaYHist)
          NLE _ _ -> 0
        eHist' = case Proxy @1 %<=? Proxy @q of
          LE Refl -> single e # constVar dropLast #> (s ^^. arimaEHist)
          NLE _ _ -> 0
        s' = isoVar3 ARIMAs (\(ARIMAs pr yh eh) -> (pr,yh,eh))
                y
                yHist'
                eHist'

monosquare :: forall n. (n <=? (n ^ 2)) :~: 'True
monosquare = unsafeCoerce Refl

dropLast :: forall n. (KnownNat n, 1 <= n) => L (n - 1) n
dropLast = case monosquare @n of
    Refl -> vecL . SVS.generate $ \ij ->
      let i :: Finite n
          j :: Finite (n - 1)
          (i, j) = separateProduct ij
      in  if fromIntegral @_ @Int i == fromIntegral j
            then 1
            else 0

single :: Reifies s W => BVar s Double -> BVar s (R 1)
single = konst

difference'
    :: Int                  -- ^ initial
    -> Int                  -- ^ target
    -> HU.Matrix Double     -- ^ target x initial
difference' n m = foldl' go (HU.ident m) [m + 1 .. n]
  where
    go x k = x HU.<> d k
    d k = HU.build (k-1, k) $ \i j ->
        case round @_ @Int (j - i) of
          0 -> 1
          1 -> -1
          _ -> 0

difference :: forall n m. (KnownNat n, KnownNat m) => L n (n + m)
difference = fromJust . H.create $ difference' (n + m) n
  where
    n = fromIntegral $ natVal (Proxy @n)
    m = fromIntegral $ natVal (Proxy @m)

instance NFData (ARIMAp p q)
instance NFData (ARIMAs p d q)

instance Num (ARIMAp p q) where
    (+)         = gPlus
    (-)         = gMinus
    (*)         = gTimes
    negate      = gNegate
    abs         = gAbs
    signum      = gSignum
    fromInteger = gFromInteger

instance Num (ARIMAs p d q) where
    (+)         = gPlus
    (-)         = gMinus
    (*)         = gTimes
    negate      = gNegate
    abs         = gAbs
    signum      = gSignum
    fromInteger = gFromInteger

instance Fractional (ARIMAp p q) where
    (/)          = gDivide
    recip        = gRecip
    fromRational = gFromRational

instance Fractional (ARIMAs p d q) where
    (/)          = gDivide
    recip        = gRecip
    fromRational = gFromRational

instance Floating (ARIMAp p q) where
    pi    = gPi
    sqrt  = gSqrt
    exp   = gExp
    log   = gLog
    sin   = gSin
    cos   = gCos
    asin  = gAsin
    acos  = gAcos
    atan  = gAtan
    sinh  = gSinh
    cosh  = gCosh
    asinh = gAsinh
    acosh = gAcosh
    atanh = gAtanh

instance Floating (ARIMAs p d q) where
    pi    = gPi
    sqrt  = gSqrt
    exp   = gExp
    log   = gLog
    sin   = gSin
    cos   = gCos
    asin  = gAsin
    acos  = gAcos
    atan  = gAtan
    sinh  = gSinh
    cosh  = gCosh
    asinh = gAsinh
    acosh = gAcosh
    atanh = gAtanh

instance Additive (ARIMAp p q) where
    (.+.)   = gAdd
    addZero = gAddZero
instance Additive (ARIMAs p d q) where
    (.+.)   = gAdd
    addZero = gAddZero

instance (KnownNat p, KnownNat q) => Scaling Double (ARIMAp p q)
instance (KnownNat p, KnownNat d, KnownNat q) => Scaling Double (ARIMAs p d q)

instance (KnownNat p, KnownNat q) => Metric  Double (ARIMAp p q)
instance (KnownNat p, KnownNat d, KnownNat q) => Metric  Double (ARIMAs p d q)

instance (KnownNat p, KnownNat q, Ref m (ARIMAp p q) v) => AdditiveInPlace m v (ARIMAp p q)
instance (KnownNat p, KnownNat d, KnownNat q, Ref m (ARIMAs p d q) v) => AdditiveInPlace m v (ARIMAs p d q)

instance (KnownNat p, KnownNat q, Ref m (ARIMAp p q) v) => ScalingInPlace m v Double (ARIMAp p q)
instance (KnownNat p, KnownNat d, KnownNat q, Ref m (ARIMAs p d q) v) => ScalingInPlace m v Double (ARIMAs p d q)

instance (KnownNat p, KnownNat q) => Initialize (ARIMAp p q)
instance (KnownNat p, KnownNat d, KnownNat q) => Initialize (ARIMAs p d q)

instance (KnownNat p, KnownNat q) => Bi.Binary (ARIMAp p q)
instance (KnownNat p, KnownNat d, KnownNat q) => Bi.Binary (ARIMAs p d q)

instance (KnownNat p, KnownNat q) => Backprop (ARIMAp p q)
instance (KnownNat p, KnownNat d, KnownNat q) => Backprop (ARIMAs p d q)

arimaPhi :: Lens (ARIMAp p q) (ARIMAp p' q) (R p) (R p')
arimaPhi f a = (\x' -> a { _arimaPhi = x' } ) <$> f (_arimaPhi a)

arimaTheta :: Lens (ARIMAp p q) (ARIMAp p q') (R q) (R q')
arimaTheta f a = (\x' -> a { _arimaTheta = x' } ) <$> f (_arimaTheta a)

arimaConstant :: Lens' (ARIMAp p q) Double
arimaConstant f a = (\x' -> a { _arimaConstant = x' } ) <$> f (_arimaConstant a)

arimaYPred :: Lens' (ARIMAs p d q) Double
arimaYPred f a = (\x' -> a { _arimaYPred = x' } ) <$> f (_arimaYPred a)

arimaYHist :: Lens' (ARIMAs p d q) (R (p + d))
arimaYHist f a = (\x' -> a { _arimaYHist = x' } ) <$> f (_arimaYHist a)

arimaEHist :: Lens (ARIMAs p d q) (ARIMAs p d q') (R q) (R q')
arimaEHist f a = (\x' -> a { _arimaEHist = x' } ) <$> f (_arimaEHist a)

-- | Autoregressive model
type AR p = ARIMA p 0 0

-- | Moving average model
type MA = ARIMA 0 0

-- | Autoregressive Moving average model
type ARMA p = ARIMA p 0


import System.Exit

import Quipper
import Quipper.Internal

import Quantum.Synthesis.Matrix
import Quantum.Synthesis.Ring
import Quipper.Libraries.Synthesis

import Quipper.Libraries.Decompose.GateBase
import Quipper.Libraries.Decompose

import Data.Complex
import Data.Ratio
import Data.Tuple

import Quipper.Utils.RandomSource
import System.Random

-- declare sample_oracle's data type
data Oracle = Oracle {
   qubit_num :: Int,
   function :: ([Qubit], Qubit) -> Circ ([Qubit], Qubit)
}

-- declare circuit function
circuit_function :: Oracle -> Circ ([Bit], Bit)
circuit_function oracle = do
     -- initialize string of qubits
     top_qubits <- qinit (replicate (qubit_num oracle) False)
     bottom_qubit <- qinit False
     label (top_qubits, bottom_qubit) ("|0>","|0>")

     --prepare the initial states
     --mapUnary hadamard top_qubits
     --mapUnary hadamard bottom_qubit

     comment "before oracle"
     -- call oracle
     function oracle (top_qubits, bottom_qubit)
     comment "after oracle"

     -- measure qubits
     (top_qubits, bottom_qubit) <- measure (top_qubits, bottom_qubit)
     -- discard unnecessary output and return result
     return (top_qubits, bottom_qubit)

-- * From a matrix
type Sixteen = Ten_and Six

mymatrix :: Matrix Sixteen Sixteen (Integer)
mymatrix = matrix [[1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0], -- ([],0)
                   [0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0], -- ([],1)
                   [0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0], -- ([0],0)
                   [0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0], -- ([0],1)
                   [0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0], -- ([0,0],0)
                   [0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0], -- ([0,0],1)
                   [0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0], -- ([1,0],0)
                   [0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0], -- ([1,0],1)
                   [0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0], -- ([1],0)
                   [0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0], -- ([1],1)
                   [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0], -- ([0,1],0)
                   [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0], -- ([0,1],1)
                   [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0], -- ([1,1],0)
                   [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0], -- ([1,1],1)
                   [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0], -- ([0,0,0],0)
                   [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1]] -- ([0,0,0],1)

synthesized = exact_synthesis mymatrix

circuit ::([Qubit], Qubit)-> Circ ([Qubit], Qubit)
circuit ([a, b, c], d) = do
  synthesized [a,b,c,d]
  return ([a,b,c],d)

-- Standard decompose in X, Y , Z, H , S, S*, T, T* and CNOT
-- needs : precision and randomSource
rand = RandomSource(fst(split(mkStdGen 10)))
prec = 20 * bits
circuit_decompose = decompose_generic (Standard prec rand) circuit

--
original_pdf :: IO ()
original_pdf = do
  print_generic Preview (circuit_function my_oracle)
    where
    -- declare empty_oracle's data type
    my_oracle :: Oracle
    my_oracle = Oracle {
    -- set the length of qubit string
        qubit_num = 3,
        function = circuit
    }

--
original_ASCII :: IO ()
original_ASCII = do
  print_generic ASCII (circuit_function my_oracle)
    where
     -- declare empty_oracle's data type
     my_oracle :: Oracle
     my_oracle = Oracle {
      -- set the length of qubit string
       qubit_num = 3,
       function = circuit
     }

decompose_pdf :: IO ()
decompose_pdf = do
  print_generic Preview (circuit_function my_oracle)
    where
   -- declare empty_oracle's data type
   my_oracle :: Oracle
   my_oracle = Oracle {
     -- set the length of qubit string
      qubit_num = 3,
      function = circuit_decompose
   }
 -- print mymatrix

decompose_ASCII :: IO ()
decompose_ASCII = do
  print_generic ASCII (circuit_function my_oracle)
    where
   -- declare empty_oracle's data type
   my_oracle :: Oracle
   my_oracle = Oracle {
     -- set the length of qubit string
      qubit_num = 3,
      function = circuit_decompose
   }

main_menu = do
  putStrLn "\n \n \n \n \n \n \n \n choose an option:"
  putStrLn " 1 - PDF original circuit\n"
  putStrLn " 2 - text description of original circuit\n"
  putStrLn " 3 - PDF decomposed circuit\n"
  putStrLn " 4 - text description of decomposed circuit\n"
  putStrLn " 5 - exit\n"
  line <- getLine
  case line of
    "1" -> do original_pdf
              main
    "2" -> do original_ASCII
              main
    "3" -> do decompose_pdf
              main
    "4" -> do decompose_ASCII
              main
    "5" -> do exitSuccess
    _ -> do main

main_qfold_cnot_7x2 = do
  decompose_ASCII

main = do
  --main_menu

  -- or
  -- if you want the circuit description a .txt file
  -- comment the main_menu above
  -- replacing it by:

  main_qfold_cnot_7x2

  -- and run:
  -- $ ./qfold_cnot_7x2_quipper > circuit_cnot_7x2_quipper.txt


-----------------------------------------------------------------------------
-- |
-- Module      :  RL.Util
-- Description :  Misc. Utilities
-- Copyright   :  (c) David Banas, 2018
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  David.Banas@target.com
-- Stability   :  experimental
-- Portability :  ?
--
-- Common utilities used throughout the RL package.
-----------------------------------------------------------------------------

{-# OPTIONS_GHC -Wall #-}

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}

module RL.Util where

import qualified Prelude as P
import Prelude (Show(..))
import Protolude  hiding (show, for)

import GHC.TypeLits

import qualified Data.Vector.Sized   as VS
import Data.Vector.Sized             (Vector)

import Control.Monad.Writer
import Data.Finite
import Data.Finite.Internal
import Data.List                     ((!!))
import Statistics.Distribution       (density)
import Statistics.Distribution.Gamma (gammaDistr)
import Text.Printf

import ConCat.TArr

-- | Convenient abbreviation of: `natVal (Proxy @n)`.
nat :: forall n. KnownNat n => Integer
nat = natVal (Proxy @n)

-- | Convenient abbreviation of: `fromIntegral (nat @n)`.
int :: forall n. KnownNat n => Int
int = fromIntegral (nat @n)

-- | Apply the matrix representation of a two argument function.
--
-- The first argument is assumed to index the rows of the matrix.
appFm
  :: ( HasFin' a,   HasFin' b )
  => Vector (Card a) (Vector (Card b) c)  -- ^ matrix representation of @f(r,c)@
  -> a                                    -- ^ row
  -> b                                    -- ^ column
  -> c
appFm f x y = f `VS.index` toFin x `VS.index` toFin y

-- | Apply the vector representation of a function.
appFv
  :: ( HasFin' x )
  => Vector (Card x) a  -- ^ vector representation of @f(x)@
  -> x                  -- ^ function argument
  -> a
appFv f x = f `VS.index` toFin x

-- | Convert an action-value matrix to a value vector.
--
-- (i.e. - \(Q(s,a) -> V(s)\))
qToV
  :: ( Ord a
     , KnownNat m, KnownNat n, KnownNat k
     , n ~ (k + 1)
     )
  => Vector m (Vector n a)  -- ^ matrix representation of @Q(s,a)@
  -> Vector m a             -- ^ vector representation of @V(s)@
qToV = VS.map VS.maximum

-- | Convert an action-value matrix to a policy vector.
--
-- (i.e. - \(Q(s,a) -> A(s)\))
qToP
  :: ( Ord a, HasFin' act
     , KnownNat m, KnownNat n, KnownNat k
     , n ~ (k + 1), Card act ~ n
     )
  => Vector m (Vector n a)  -- ^ matrix representation of Q(s,a)
  -> Vector m act           -- ^ vector representation of P(s)
qToP = VS.map (unFin . VS.maxIndex)

{----------------------------------------------------------------------
  Misc.
----------------------------------------------------------------------}

-- | To control the formatting of printed floats in output matrices.
newtype Pfloat = Pfloat { unPfloat :: Float}
  deriving (Eq)

instance Show Pfloat where
  show x = printf "%4.1f" (unPfloat x)

-- | To control the formatting of printed doubles in output matrices.
newtype Pdouble = Pdouble { unPdouble :: Double }
  deriving (Eq, Ord)

instance Show Pdouble where
  show x = printf "%4.1f" (unPdouble x)

poisson :: Finite 5 -> Finite 12 -> Float
poisson (Finite lambda) (Finite n') =
  lambda' ^ n * exp (-lambda') / fromIntegral (fact n)
 where lambda' = fromIntegral lambda
       n       = fromIntegral n'

fact :: Int -> Int
fact 0 = 1
fact n = product [1..n]

poissonVals :: VS.Vector 5 (VS.Vector 12 Float)
poissonVals = VS.generate (VS.generate . poisson)

poisson' :: Finite 5 -> Finite 21 -> Float
poisson' n x@(Finite x') =
  if x > 11  -- The Python code enforces this limit. And we're trying
    then 0   -- for an "apples-to-apples" performance comparison.
    else poissonVals `VS.index` n `VS.index` finite x'

-- | Gamma pdf
--
-- Assuming `scale = 1`, `shape` should be: 1 + mean.
gammaPdf :: Double -> Double -> Double -> Double
gammaPdf shape scale = density (gammaDistr shape scale)

-- | Gamma pmf
--
-- Scale assumed to be `1`, so as to match the calling signature of
-- `poisson`.
gamma :: Finite 5 -> Finite 12 -> Double
gamma (Finite expect') (Finite n') =
  0.1 * sum [gammaPdf' (n + x) | x <- [0.1 * m | m <- [-4..5]]]
    where gammaPdf' = gammaPdf (1 + expect) 1
          expect    = fromIntegral expect'
          n         = fromIntegral n'

gammaVals :: VS.Vector 5 (VS.Vector 12 Double)
gammaVals = VS.generate (VS.generate . gamma)

gamma' :: Finite 5 -> Finite 21 -> Double
gamma' n (Finite x') =
  if x' > 11
    then 0
    else gammaVals `VS.index` n `VS.index` finite x'

-- | Monadically search list for first element less than
-- given threshold under the given function, and return the last element
-- if the threshold was never met.
-- Return 'Nothing' if the input list was empty.
withinOnM :: Monad m
          => Double
          -> (a -> m Double)
          -> [a]
          -> m (Maybe a)
withinOnM _   _ [] = return Nothing
withinOnM eps f xs = do
  n <- withinIxM eps $ map f xs
  case n of
    Nothing -> return Nothing
    Just n' -> return $ Just (xs !! n')

-- | Monadically find index of first list element less than or equal to
-- given threshold, or the index of the last element if the threshold
-- was never met.
--
-- A return value of 'Nothing' indicates an empty list was given.
withinIxM :: Monad m
          => Double
          -> [m Double]
          -> m (Maybe Int)
withinIxM _   [] = return Nothing
withinIxM eps xs = withinIxM' 0 xs
 where withinIxM' n []     = return $ Just (n - 1)
       withinIxM' n (y:ys) = do
         y' <- y
         if y' < eps then return (Just n)
                     else withinIxM' (n+1) ys

-- | Return the maximum value of a set, as well as a count of the number
-- of non-zero elements in the set.
--
-- (See documentation for `chooseAndCount` function.)
maxAndNonZero :: (Foldable t, Num a, Ord a) => t a -> Writer [Int] a
maxAndNonZero = chooseAndCount max (/= 0)

-- | Choose a value from the set using the given comparison function,
-- and provide a count of the number of elements in the set meeting the
-- given criteria.
chooseAndCount :: (Foldable t, Num a)
               => (a -> a -> a)  -- ^ choice function
               -> (a -> Bool)    -- ^ counting predicate
               -> t a            -- ^ foldable set of elements to count/compare
               -> Writer [Int] a
chooseAndCount f p xs = do
  let (val, cnt::Int) =
        foldl' ( \ (v, c) x ->
                   ( f v x
                   , if p x
                       then c + 1
                       else c
                   )
               ) (0,0) xs
  tell [cnt]
  return val

for :: [a] -> (a -> b) -> [b]
for = flip map

vsFor :: Vector n a -> (a -> b) -> Vector n b
vsFor = flip VS.map

-- | Mean value of a collection
mean :: (Foldable f, Fractional a) => f a -> a
mean = uncurry (/) . second fromIntegral . foldl' (\ (!s, !n) x -> (s+x, n+1)) (0,0::Integer)

-- | Find the mean square of a list of lists.
arrMeanSqr :: (Functor f, Foldable f, Functor g, Foldable g, Fractional a) => f (g a) -> a
arrMeanSqr = mean . fmap mean . fmap (fmap sqr)

-- | Take the square of a numerical type.
sqr :: Num a => a -> a
sqr x = x * x

-- | Convert any showable type to a string, avoiding the introduction
-- of extra quotation marks when that type is a string to begin with.
toString :: (Show a, Typeable a) => a -> P.String
toString x = fromMaybe (show x) (cast x)

-- | Convert a Bool to a Double.
boolToDouble :: Bool -> Double
boolToDouble True = 1
boolToDouble _    = 0

-- | Take every nth element from a list.
takeEvery :: Int -> [a] -> [a]
takeEvery _ [] = []
takeEvery n xs = P.head xs : (takeEvery n $ drop n xs)


module Budget.Budgeter(
  budgeter
  )where

import Numeric.LinearAlgebra
import Budget.Types
import Budget.Parse
import Budget.Printer
import Text.Parsec
import Finance.FutureValue

getNeededExpense :: BudgetItem -> Expense
getNeededExpense bs = case needed bs of
  True -> Expense (name bs) (minPrice bs)
  False -> Expense (name bs) 0.0

reduceBs :: [BudgetItem] -> [Expense] -> [BudgetItem]
reduceBs bs xs = map removeMin $ zip bs xs

removeMin :: (BudgetItem, Expense) -> BudgetItem
removeMin ((BudgetItem s i l h n), Expense _ m) = BudgetItem s i (l-m) (h-m) n

aDiag :: BudgetItem -> Double
aDiag (BudgetItem _ i low high _)
  | low == high = 100000
  | otherwise = (-2.0) * i * k**2
  where k = 1.0 / (high-low)

aDiags :: [BudgetItem] -> [Double]
aDiags = map aDiag

type CurrentIndex = Integer
type Rank = Integer
aList :: CurrentIndex -> Rank -> [Double] -> [Double]
aList c r (x:xs)
  |c `mod` (r+1) == 0 = x : aList (c+1) r xs
aList c r xs
  | c == r^2-1 = [0]
  | ((c+1) `mod` r == 0) && (c /= r^2-1) = -1 : aList (c+1) r xs
  | (c `mod` (r+1) /= 0 && c >= r^2-r) = 1 : aList (c+1) r xs
  | otherwise = 0 : aList (c+1) r xs

availableCosts :: Double -> Double -> Double -> Double -> Double -> Double
availableCosts cpm y v ipm apr
  | cpm <= 0 = 0
  | retirement > sustainableRetirement = cpm
  | otherwise = availableCosts (cpm-10) y v ipm apr
  where retirement = futureValue numberMonths v (ipm-cpm) ratePerMonth
        sustainableRetirement = costsPerYear / apr
        numberMonths = floor (12 * y)
        ratePerMonth = apr/12
        costsPerYear = cpm * 12

aMatrix :: [BudgetItem] -> Matrix Double
aMatrix bs = let as = aDiags bs
                 r = (length as) + 1
             in (r><r) $ aList 0 (toInteger r) as

bElem :: BudgetItem -> Double
bElem (BudgetItem _ i low high _)
  | low == high = 100000
  | otherwise = (-2.0) * i * k**2 * high
  where k = 1.0 / (high-low)

bElems :: [BudgetItem] -> [Double]
bElems = map bElem

type TotalCost = Double
bVector :: [BudgetItem] -> TotalCost -> Vector Double
bVector bs tc = let vecElems = bElems bs ++ [tc]
                in vector vecElems

removeNeeded :: BudgetInfo -> (BudgetInfo, [Expense])
removeNeeded (BudgetInfo i s y a bs) = (BudgetInfo (i - totalNeeded) s y a newBs, needs)
  where needs = map getNeededExpense bs
        newBs = reduceBs bs needs
        totalNeeded = sum [x | (Expense _ x) <- needs]

type ItemNames = [String]
calculateBudget :: BudgetInfo -> [Expense]
calculateBudget (BudgetInfo i s y a bs)
  | i > totalMaxCosts = expenses
  | otherwise = calculateBudget' [] (BudgetInfo i s y a bs)
  where maxCosts = map maxPrice bs
        names = map name bs
        expenses = [Expense n m | (n, m) <- zip names maxCosts]
        totalMaxCosts = sum maxCosts

inefficientNames :: [BudgetItem] -> Costs -> ItemNames
inefficientNames bs costs  = [(name b)| (b,c) <- (zip bs costs), c < 0]

optimizedCosts :: Double -> [BudgetItem] -> [Double]
optimizedCosts i bs = init $ toList $ (aMatrix bs) <\> (bVector bs (realToFrac i))

calculateBudget' :: ItemNames -> BudgetInfo -> [Expense]
calculateBudget' unusedItems (BudgetInfo i s y a bs)
  | validCosts = expenses
  | otherwise = calculateBudget' newUnusedNames cleanedBI
  where costs = optimizedCosts i bs
        validCosts = length [c | c <- costs, c < 0] == 0
        allNames = (map name bs) ++ unusedItems
        newUnusedNames = unusedItems ++ inefficientNames bs costs
        cleanedBI = BudgetInfo i s y a [b | (b,c) <- (zip bs costs), c > 0]
        appendedCosts = costs ++ (replicate ((length allNames) - (length costs)) 0)
        expenses = [Expense n m | (n, m) <- zip allNames appendedCosts]

storeSavings (BudgetInfo ipm v ytr apr bs) = BudgetInfo cpm v ytr apr bs
  where cpm = availableCosts ipm ytr v ipm apr

unsafe :: Either ParseError BudgetInfo -> BudgetInfo
unsafe (Right x) = x

yearlySavings (BudgetInfo ipm _ _ _ _) cs = ipm - (sum cs)

combineExpenses :: [Expense] -> [Expense] -> [Expense]
combineExpenses e1s e2s = [Expense n1 (cost1 + cost2) | (Expense n1 cost1) <- e1s, (Expense n2 cost2) <- e2s,
                           n1 == n2]

getBudget :: BudgetInfo -> String
getBudget bi = let saved_bi = storeSavings bi
                   (available_bi, mandatory_costs) = removeNeeded saved_bi
                   distro = calculateBudget available_bi
                   finalExpenses = combineExpenses mandatory_costs distro
               in fullPrint bi finalExpenses

budgeter :: String -> String
budgeter s = let bi = parse getBudgetInfo "Fetching budget info" s
             in case fmap getBudget bi of
                Left parsecError -> "Encountered Input Parsing errror:\n" ++ show parsecError
                Right finalString -> finalString


{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

import           Control.Applicative
import           Control.DeepSeq
import           Control.Monad
import           Control.Monad.Random
import           Control.Monad.Trans.Except

import qualified Data.Attoparsec.Text         as A
import           Data.List                    (foldl')
import qualified Data.Text                    as T
import qualified Data.Text.IO                 as T
import qualified Data.Vector.Storable         as V

import           Numeric.LinearAlgebra        (maxIndex)
import qualified Numeric.LinearAlgebra.Static as SA

import           Options.Applicative

import           Grenade
import           Grenade.Utils.OneHot

--
-- Note: Input files can be downloaded at https://www.kaggle.com/scolianni/mnistasjpg
--

-- It's logistic regression!
--
-- This network is used to show how we can embed a Network as a layer in the larger MNIST
-- type.
type FL i o =
  Network
    '[ FullyConnected i o, Logit ]
    '[ 'D1 i, 'D1 o, 'D1 o ]

-- The definition of our convolutional neural network.
-- In the type signature, we have a type level list of shapes which are passed between the layers.
-- One can see that the images we are inputing are two dimensional with 28 * 28 pixels.

-- It's important to keep the type signatures, as there's many layers which can "squeeze" into the gaps
-- between the shapes, so inference can't do it all for us.

-- With the mnist data from Kaggle normalised to doubles between 0 and 1, learning rate of 0.01 and 15 iterations,
-- this network should get down to about a 1.3% error rate.
--
-- /NOTE:/ This model is actually too complex for MNIST, and one should use the type given in the readme instead.
--         This one is just here to demonstrate Inception layers in use.
--
type MNIST =
  Network
    '[ Reshape,
       Concat ('D3 28 28 1) Trivial ('D3 28 28 14) (InceptionMini 28 28 1 5 9),
       Pooling 2 2 2 2, Relu,
       Concat ('D3 14 14 3) (Convolution 15 3 1 1 1 1) ('D3 14 14 15) (InceptionMini 14 14 15 5 10), Crop 1 1 1 1, Pooling 3 3 3 3, Relu,
       Reshape, FL 288 80, FL 80 10 ]
    '[ 'D2 28 28, 'D3 28 28 1,
       'D3 28 28 15, 'D3 14 14 15, 'D3 14 14 15, 'D3 14 14 18,
       'D3 12 12 18, 'D3 4 4 18, 'D3 4 4 18,
       'D1 288, 'D1 80, 'D1 10 ]

randomMnist :: IO MNIST
randomMnist = randomNetwork

convTest :: Int -> FilePath -> FilePath -> Optimizer opt -> ExceptT String IO ()
convTest iterations trainFile validateFile opt = do
  net0         <- lift randomMnist
  trainData    <- readMNIST trainFile
  validateData <- readMNIST validateFile
  lift $ foldM_ (runIteration trainData validateData) net0 [1..iterations]

    where
  trainEach !opt' !network (!i, !o) = force (train opt' network i o)

  runIteration !trainRows !validateRows !net !i = do
    putStrLn $ "Number of training rows: " ++ show (length trainRows)
    let !trained' = foldl' (trainEach (sgdUpdateLearningParamters opt)) net trainRows
    let !res      = fmap (\(rowP,rowL) -> (rowL,) $ runNet trained' rowP) validateRows
    let !res'     = fmap (\(S1D label, S1D prediction) -> (maxIndex (SA.extract label), maxIndex (SA.extract prediction))) res
    print trained'
    putStrLn $ "Iteration " ++ show i ++ ": " ++ show (length (filter ((==) <$> fst <*> snd) res')) ++ " of " ++ show (length res')
    return trained'
  sgdUpdateLearningParamters :: Optimizer opt -> Optimizer opt
  sgdUpdateLearningParamters (OptSGD rate mom reg) = OptSGD rate mom (reg * 10)
  sgdUpdateLearningParamters o                     = o

data MnistOpts = MnistOpts FilePath FilePath Int Bool (Optimizer 'SGD) (Optimizer 'Adam)

mnist' :: Parser MnistOpts
mnist' = MnistOpts <$> argument str (metavar "TRAIN")
                   <*> argument str (metavar "VALIDATE")
                   <*> option auto (long "iterations" <> short 'i' <> value 15)
                 <*> flag False True (long "use-adam" <> short 'a')
                 <*> (OptSGD
                       <$> option auto (long "train_rate" <> short 'r' <> value 0.01)
                       <*> option auto (long "momentum" <> value 0.9)
                       <*> option auto (long "l2" <> value 0.0005)
                       )
                 <*> (OptAdam
                       <$> option auto (long "alpha" <> short 'r' <> value 0.001)
                       <*> option auto (long "beta1" <> value 0.9)
                       <*> option auto (long "beta2" <> value 0.999)
                       <*> option auto (long "epsilon" <> value 1e-4)
                       <*> option auto (long "lambda" <> value 1e-3)
                      )

main :: IO ()
main = do
    MnistOpts mnist vali iter useAdam sgd adam <- execParser (info (mnist' <**> helper) idm)
    putStrLn "Training convolutional neural network..."
    res <- if useAdam
      then runExceptT $ convTest iter mnist vali adam
      else runExceptT $ convTest iter mnist vali sgd

    case res of
      Right () -> pure ()
      Left err -> putStrLn err

readMNIST :: FilePath -> ExceptT String IO [(S ('D2 28 28), S ('D1 10))]
readMNIST mnist = ExceptT $ do
  mnistdata <- T.readFile mnist
  return $ traverse (A.parseOnly parseMNIST) (tail $ T.lines mnistdata)

parseMNIST :: A.Parser (S ('D2 28 28), S ('D1 10))
parseMNIST = do
  Just lab <- oneHot <$> A.decimal
  pixels   <- many (A.char ',' >> A.double)
  image    <- maybe (fail "Parsed row was of an incorrect size") pure (fromStorable . V.fromList $ map realToFrac pixels)
  return (image, lab)


{-# language BangPatterns #-}
{-# language DataKinds #-}
{-# language FlexibleContexts #-}
{-# language KindSignatures #-}
{-# language LambdaCase #-}
{-# language PolyKinds #-}
{-# language StandaloneDeriving #-}
{-# language TypeFamilies #-}
{-# language TypeFamilyDependencies #-}
{-# language UndecidableInstances #-}

module Qprob where

import Control.Monad (join)
import Data.Coerce (coerce)
import Data.Kind (Type)
import Linear.Epsilon (nearZero)
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Complex as Complex

data Setting = Classical | Quantum

--type family Setting' s = (s' :: Type) | s' -> s

class V (s :: Setting) where
  type Setting' s = (s' :: Type) | s' -> s
  oneS :: Setting' s
  plusS :: Setting' s -> Setting' s -> Setting' s
  zeroS :: Setting' s
  timesS :: Setting' s -> Setting' s -> Setting' s
  negateS :: Setting' s -> Setting' s
  nearZeroS :: Setting' s -> Bool

instance V 'Classical where
  type Setting' 'Classical = Double
  oneS = one; plusS = plus; zeroS = zero; timesS = times; negateS = negate; nearZeroS = nearZero;
  {-# inline oneS #-}
  {-# inline plusS #-}
  {-# inline zeroS #-}
  {-# inline timesS #-}
  {-# inline negateS #-}
  {-# inline nearZeroS #-}

instance V 'Quantum where
  type Setting' 'Quantum = Complex Double
  oneS = one; plusS = plus; zeroS = zero; timesS = times; negateS = negate; nearZeroS = nearZero;
  {-# inline oneS #-}
  {-# inline plusS #-}
  {-# inline zeroS #-}
  {-# inline timesS #-}
  {-# inline negateS #-}
  {-# inline nearZeroS #-}

data Space (s :: Setting) a = Space !a !(Setting' s)

deriving instance (Show a, Show (Setting' s)) => Show (Space s a)
deriving instance (Eq a, Eq (Setting' s)) => Eq (Space s a)

mapSpace :: (Setting' s -> Setting' s) -> Space s a -> Space s a
mapSpace f (Space a s) = Space a (f s)

-- | @W s a@ is a vector space whose basis elements are labelled
--   by objects of type @a@ and where the coefficients are of type @Settings'' s@.
--
--   This is very similar to standard probability monads except that we
--   allow probabilities to be types other than 'Double'.
newtype W (s :: Setting) a = W { runW :: [Space s a] }

deriving instance (Show a, Show (Setting' s)) => Show (W s a)
deriving instance (Eq a, Eq (Setting' s)) => Eq (W s a)

-- | Transform the probabilities inside of 'W'.
mapW :: (Setting' s -> Setting' s) -> W s a -> W s a
mapW f (W l) = W (List.map (mapSpace f) l)

instance Semigroup (W s a) where
  W x <> W y = W (x <> y)
  {-# inline (<>) #-}

instance Monoid (W s a) where
  mempty = W mempty
  {-# inline mempty #-}

instance Functor (W s) where
  fmap f w = fmapW f w
  {-# inline fmap #-}

fmapW :: (a -> b) -> W s a -> W s b
fmapW f (W l) = W (List.map (\(Space a p) -> Space (f a) p) l)
{-# NOINLINE [1] fmapW #-}

{-# RULES "fmapW/coerce" fmapW coerce = coerce #-}

instance V s => Applicative (W s) where
  pure x = W [Space x oneS]
  {-# inline pure #-}
  W fs <*> W xs = W
    ( do Space f a <- fs
         Space x b <- xs
         pure (Space (f x) (timesS a b))
    )

infixl 7 .*
(.*) :: V s => Setting' s -> W s a -> W s a
a .* b = mapW (a `timesS`) b

type P a = W 'Classical a
type Q a = W 'Quantum   a

star :: Q a -> Q a
star = mapW Complex.conjugate

kron :: V s => W s a -> W s c -> W s (a,c)
kron (W x) (W y) = W
  ( do Space a r1 <- x
       Space c r2 <- y
       pure (Space (a,c) (r1 `timesS` r2))
  )

collect :: (V s, Ord a) => W s a -> W s a
collect (W l) = W $ toList . fromListWith plusS $ l
  where
    toList = Map.foldrWithKey (\k x xs -> (Space k x):xs) []
    fromListWith f xs = fromListWithKey (\_ x y -> f x y) xs
    fromListWithKey f xs =
      let ins t (Space a s) = Map.insertWithKey f a s t
      in List.foldl' ins mempty xs

instance V s => Monad (W s) where
  l >>= f = W $ List.concatMap (\(Space (W d) p) -> List.map (\(Space x q) -> (Space x (p `timesS` q))) d) (runW $ fmap f l)

-- | When we come to observe the state of a quantum system, the quantum state becomes an ordinary probablistic one.
observe :: Ord a => Q a -> P a
observe = W . List.map (\(Space a w) -> Space a (Complex.magnitude (w `times` w))) . runW . collect

rotate :: Double -> Bool -> Q Bool
rotate theta = \case
  True ->
    let theta' = theta :+ 0
    in subtract (cos (theta' / 2) .* pure True) (sin (theta' / 2) .* pure False)
  False ->
    let theta' = theta :+ 0
    in (cos (theta' / 2) .* pure False) <> (sin (theta' / 2) .* pure True)

repeat :: Int -> (a -> a) -> (a -> a)
repeat 0 _ = id
repeat n f = repeat (n - 1) f . f

repeatM :: Monad m => Int -> (a -> m a) -> m a -> m a
repeatM n f = repeat n (>>= f)

snot :: Bool -> Q Bool
snot = rotate (pi / 2)

snot1 :: Int -> P Bool
snot1 n = pure True & repeatM n snot & observe

subtract :: V s => W s a -> W s a -> W s a
subtract a b = a <> ((negateS oneS) .* b)

-- | Quantum Zeno effect.
--
-- A watched pot never boils.
zeno1 :: Int -> P Bool
zeno1 n = pure True & repeatM n (rotate (pi / fromIntegral n)) & collect & observe

ffor :: Functor f => f a -> (a -> b) -> f b
ffor = flip fmap

liftBind :: (Functor f, Monad g) => f (g a) -> (a -> g b) -> f (g b)
liftBind fga f = fmap (>>= f) fga

zeno2 :: Int -> P Bool
zeno2 n = pure True & repeat n
  (\x -> x `ffor` pure `liftBind` rotate (pi / fromIntegral n) `ffor` observe & join
  ) & collect

type MixedState a = P (Q a)

data Experimenter = Experimenter
  { experimenterMemory :: [Bool]
  , experimenterState :: !Bool
  }
  deriving (Eq, Ord)

zeno3 :: Int -> P Bool
zeno3 n = pure (Experimenter [] True) & repeatM n
  (\(Experimenter m s) -> do
    s' <- rotate (pi / fromIntegral n) s
    pure $ Experimenter (s:m) s'
  ) & observe & fmap experimenterState & collect

trimZero :: V s => W s a -> W s a
trimZero = W . List.filter (\(Space _ v) -> not $ nearZeroS v) . runW

simplify :: Ord a => Q a -> Q a
simplify = trimZero . collect


{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# OPTIONS_HADDOCK show-extensions #-}

-- |
-- Module      : VectorSpace
-- Description : Particle Swarm Optimisation
-- Copyright   : (c) Tom Westerhout, 2017
-- License     : BSD3
-- Maintainer  : t.westerhout@student.ru.nl
-- Stability   : experimental

module PSO.VectorSpace
  ( Scalable(..)
  , VectorSpace(..)
  ) where

import           Data.Complex        (Complex (..))
import           Foreign.Storable
import qualified Data.Vector.Storable as V
import qualified Data.Vector.Generic as GV

class Scalable a v where
  scale :: a -> v -> v

instance (Num a) => Scalable a a where
  scale = (*)

instance (Num a) => Scalable a (Complex a) where
  scale c (x :+ y) = (c * x) :+ (c * y)

instance (Num a, Storable a) => Scalable a (V.Vector a) where
  scale c = V.map (c*)

instance (RealFloat a, Storable a) => Scalable a (V.Vector (Complex a)) where
  scale c = scale (c :+ 0)

class (Num a, Num v, Scalable a v) => VectorSpace v a

instance (Num a, Num v, Scalable a v) => VectorSpace v a


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Numeric.Signal
-- Copyright   :  (c) Alexander Vivian Hugh McPhail 2010, 2014, 2015, 2016
-- License     :  BSD3
--
-- Maintainer  :  haskell.vivian.mcphail <at> gmail <dot> com
-- Stability   :  provisional
-- Portability :  uses FFI
--
-- Signal processing functions
--
-----------------------------------------------------------------------------

module Numeric.Signal (
                       S.Convolvable(..),
                       S.Filterable(),
                       -- * Filtering
                       hamming,
                       pwelch,
                       fir,standard_fir,broadband_fir,
                       freqzF,freqzN,
                       filter,broadband_filter,
                       -- * Analytic Signal
                       analytic_signal,analytic_power,analytic_phase,
                       unwrap,
                       -- * Statistics
                       cross_covariance,cross_correlation,cross_spectrum,
                       auto_covariance,auto_correlation,
                       -- * Preprocessing
                       detrend,
                       resize,
                       downsample,
                       deriv,
                       cumulative_sum
                ) where

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

import qualified Numeric.Signal.Internal as S

import Numeric.GSL.Fitting.Linear

import Data.Complex
import Foreign.Storable()

--import Data.Function.Unicode

import qualified Data.List as L

--import Data.Packed.Vector
--import Data.Packed(Container(..))
import Numeric.LinearAlgebra

import qualified Data.Vector.Generic as GV

import qualified Numeric.GSL.Fourier as F

import Prelude hiding(filter)

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

-- | filters the signal
filter :: (S.Filterable a)
         => Vector a   -- ^ zero coefficients
       -> Vector a     -- ^ pole coefficients
       -> Int   -- ^ sampling rate
       -> Vector a     -- ^ input signal
       -> Vector a     -- ^ output signal
filter b a s v = let len = size v
                     w = min s len
                     start = (negate . fromList . reverse . toList . subVector 0 w) v
                     finish = (negate . fromList . reverse . toList . subVector (len-w) w) v
                     v' = vjoin [start,v,finish]
                 in subVector s len $ S.filter_ b a v'

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

-- | Welch (1967) power spectrum density using periodogram/FFT method
pwelch :: Int            -- ^ sampling rate
       -> Int            -- ^ window size
       -> Vector Double  -- ^ input signal
       -> (Vector Double,Vector Double)  -- ^ (frequency index,power density)
pwelch s w v = let w' = max s w -- make window at least sampling rate
                   r  = S.pwelch w' v
                   sd = (fromIntegral s)/2
                   -- scale for sampling rate
                   r' = scale (recip sd) r
                   f  = linspace ((w `div` 2) + 1) (0,sd)
               in (f,r')

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

-- | a broadband FIR
broadband_fir :: (S.Filterable a, Double ~ DoubleOf a, Convert (Complex a)) =>
                Int           -- ^ sampling rate
              -> (Int,Int)     -- ^ (lower,upper) frequency cutoff
              -> Vector a -- ^ filter coefficients
broadband_fir s (l,h) = let o = 501
                            ny = (fromIntegral s) / 2.0
                            fl = (fromIntegral l) / ny
                            fh = (fromIntegral h) / ny
                            f = [0, fl*0.95, fl, fh, fh*1.05, 1]
                            m = [0,0,1,1,0,0]
                            be = zip f m
                        in standard_fir o be

-- | a broadband filter
broadband_filter :: (S.Filterable a, Double ~ DoubleOf a)
                   => Int        -- ^ sampling rate
                 -> (Int,Int)    -- ^ (lower,upper) frequency cutoff
                 -> Vector a            -- ^ input signal
                 -> Vector a            -- ^ output signal
broadband_filter s f v = let b = S.fromDouble $ broadband_fir s f
                         in filter b (scalar 1.0) s v

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

-- | standard FIR filter
-- |   FIR filter with grid a power of 2 greater than the order, ramp = grid/16, hamming window
standard_fir :: (S.Filterable a, Double ~ DoubleOf a, Convert (Complex a)) =>
               Int -> [(a,a)] -> Vector a
standard_fir o be = let grid  = calc_grid o
                        trans_ = grid `div` 16
                    in fir o be grid trans_ $ S.hamming_ (o+1)

calc_grid :: Int -> Int
calc_grid o = let next_power = ceiling (((log $ fromIntegral o) :: Double) / (log 2.0)) :: Int
              in floor $ 2.0 ** ((fromIntegral next_power) :: Double)

-- | produce an FIR filter
fir :: (S.Filterable a
      , Convert (Complex a), Double ~ DoubleOf a) =>
      Int               -- ^ order (one less than the length of the filter)
    -> [(a,a)] -- ^ band edge frequency, nondecreasing, [0, f1, ..., f(n-1), 1]
                        -- ^ band edge magnitude
    -> Int               -- ^ grid spacing
    -> Int               -- ^ transition width
    -> Vector a     -- ^ smoothing window (size is order + 1)
    -> Vector a     -- ^ the filter coefficients
fir o be gn tn w = let mid = o `div` 2
                       (f,m) = unzip be
                       f' = diff (((fromIntegral gn))/((fromIntegral tn))/2.0) f
                       m' = interpolate f m f'
                       grid = interpolate f' m' $ map (\x -> (fromIntegral x)/(fromIntegral gn)) [0..(gn-1)]
                       grid' = map (\x -> x :+ 0) grid
                       b = S.fromDouble $ fst $ fromComplex $ F.ifft $ double $ fromList $ grid' ++ (reverse (drop 1 grid'))
                       b' = vjoin [subVector ((size b)-mid-1) (mid+1) b, subVector 1 (mid+1) b]
                   in b' * w

floor_zero x
    | x < 0.0   = 0.0
    | otherwise = x

ceil_one x
    | x > 1.0   = 1.0
    | otherwise = x

diff :: S.Filterable a => a -> [a] -> [a]
diff _ []  = []
diff _ [x] = [x]
diff inc (x1:x2:xs)
     | x1 == x2     = (floor_zero $ x1-inc):x1:(ceil_one $ x1+inc):(diff inc (L.filter (/= x2) xs))
     | otherwise    = x1:(diff inc (x2:xs))

interpolate :: S.Filterable a => [a] -> [a] -> [a] -> [a]
interpolate _ _ []      = []
interpolate x y (xp:xs) = if xp == 1.0
                             then ((interpolate'' ((length x)-1) x y xp):(interpolate x y xs))
                             else ((interpolate' x y xp):(interpolate x y xs))

interpolate' :: S.Filterable a => [a] -> [a] -> a -> a
interpolate' x y xp = let Just j = L.findIndex (> xp) x
                      in (interpolate'' j x y xp)

interpolate'' :: S.Filterable a => Int -> [a] -> [a] -> a -> a
interpolate'' j x y xp = let x0 = x !! (j-1)
                             y0 = y !! (j-1)
                             x1 = x !! j
                             y1 = y !! j
                         in y0 + (xp - x0) * ((y1 - y0)/(x1-x0))

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

-- | determine the frequency response of a filter, given a vector of frequencies
freqzF :: (S.Filterable a, Double ~ DoubleOf a, S.Filterable (DoubleOf a)) =>
         Vector a     -- ^ zero coefficients
       -> Vector a       -- ^ pole coefficients
       -> Int     -- ^ sampling rate
       -> Vector a       -- ^ frequencies
       -> Vector a       -- ^ frequency response
freqzF b a s f = S.freqz b a ((2*pi/(fromIntegral s)) * f)

-- | determine the frequency response of a filter, given a number of points and sampling rate
freqzN :: (S.Filterable a, Double ~ DoubleOf a) =>
         Vector a     -- ^ zero coefficients
       -> Vector a       -- ^ pole coefficients
       -> Int     -- ^ sampling rate
       -> Int     -- ^ number of points
       -> (Vector a,Vector a)   -- ^ (frequencies,response)
freqzN b a s n = let w' = linspace n (0,((fromIntegral n)-1)/(fromIntegral (2*n)))
                     r = S.freqz b a ((2*pi)*w')
                     in ((fromIntegral s)*w',r)

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

-- | an analytic signal is the original signal with Hilbert-transformed signal as imaginary component
analytic_signal :: Vector Double -> Vector (Complex Double)
analytic_signal = S.hilbert

-- | the power (amplitude^2 = v * (conj c)) of an analytic signal
analytic_power :: S.Filterable a => Vector (Complex Double) -> Vector a
analytic_power = S.complex_power_

-- | the phase of an analytic signal
analytic_phase :: (S.Filterable a) =>
                 Vector (Complex a) -> Vector a
analytic_phase = (uncurry arctan2) . fromComplex

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

-- | remove a linear trend from data
detrend :: Int             -- ^ window size
        -> Vector Double   -- ^ data to be detrended
        -> Vector Double   -- ^ detrended data
detrend w v = let windows = size v `div` w
                  re = size v - (windows * w)
                  re' = if re == 0 then [] else [re]
                  ws = takesV ((replicate windows w) ++ re') v
                  ds = map detrend' ws
                  windows' = (size v - (w `div` 2)) `div` w
                  ws' = takesV (((w `div` 2):(replicate windows' w)) ++ [size v - (w `div` 2) - (windows' * w)]) v
                  ds' = map detrend' ws'
              in (vjoin ds + vjoin ds') / 2
    where detrend' x = let ln = size x
                           t = linspace ln (1.0,fromIntegral ln)
                           (c0,c1,_,_,_,_) = linear t x
                       in x - (scale c1 t + scalar c0)

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

-- | resize the vector to length n by resampling
resize :: S.Filterable a => Int -> Vector a -> Vector a
resize n v = S.downsample_ (size v `div` n) v

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

-- | cross covariance of two signals
--     the cross correlation is computed by dividing the result
--     by the product of the two standard deviations
cross_covariance :: S.Filterable a =>
                   Int           -- ^ maximum delay
                 -> Vector a -- ^ time series
                 -> Vector a -- ^ time series
                 -> (a,a,Vector a) -- ^ (sd_x,sd_y,cov_xy)
cross_covariance = S.cross_covariance_

-- | cross correlation of two signals
cross_correlation :: S.Filterable a =>
                   Int           -- ^ maximum delay
                 -> Vector a -- ^ time series
                 -> Vector a -- ^ time series
                 -> Vector a -- ^ result
cross_correlation l x y = let (sx,sy,r) = S.cross_covariance_ l x y
                          in GV.map(/ (sx*sy)) r

-- | compute the cross spectrum
cross_spectrum :: (S.Filterable a, Double ~ DoubleOf a) =>
                 Int                      -- ^ maximum delay
               -> Vector a                 -- ^ time series
               -> Vector a                 -- ^ time series
               -> Vector (Complex Double)  -- ^ result
cross_spectrum l x y = (\(_,_,c) -> F.fft (complex $ double c)) (cross_covariance l x y)

-- | auto covariance of two signals
--     the auto correlation is computed by dividing the result
--     by the variance
auto_covariance :: S.Filterable a =>
                   Int           -- ^ maximum delay
                 -> Vector a -- ^ time series
                 -> (a,Vector a) -- ^ (var,cov_xx)
auto_covariance l v = let (sd,_,r) = cross_covariance l v v
                      in (sd*sd,r)

-- | auto correlation of two signals
auto_correlation :: S.Filterable a =>
                   Int           -- ^ maximum delay
                 -> Vector a -- ^ time series
                 -> Vector a -- ^ result
auto_correlation l v = let (var,r) = auto_covariance l v
                          in GV.map(/ var) r

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

-- | coefficients of a Hamming window
hamming :: S.Filterable a =>
          Int           -- ^ length
        -> Vector a -- ^ the Hamming coeffficents
hamming = S.hamming_

-- | resample, take one sample every n samples in the original
downsample :: S.Filterable a => Int -> Vector a -> Vector a
downsample = S.downsample_

-- | the difference between consecutive elements of a vector
deriv :: S.Filterable a => Vector a -> Vector a
deriv = S.deriv_

-- | cumulative sum of a series
cumulative_sum :: S.Filterable a =>
                 Vector a
               -> Vector a
cumulative_sum = S.cumulative_sum_

-- | unwrap the phase of signal (input expected to be within (-pi,pi))
unwrap :: S.Filterable a => Vector a -> Vector a
unwrap = S.unwrap_

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


{-# LANGUAGE Strict #-}
module STC.Multiplication where

import           Control.Concurrent.Async
import           Control.Monad            as M
import           Data.Array.Repa          as R
import           Data.Complex
import           Data.List                as L
import           Data.Vector.Storable     as VS
import           DFT.Plan
import           Filter.Utils
import           STC.DFTArray
import           Utils.List
import           Utils.Parallel

{-# INLINE multiplyPinwheelBasis #-}
multiplyPinwheelBasis :: DFTPlan -> DFTArray -> DFTArray -> IO DFTArray
multiplyPinwheelBasis plan (DFTArray rows cols thetaFreqs rFreqs vecs1) (DFTArray _ _ _ _ vecs2) = do
  dftVecs1 <-
    dftExecuteBatchP plan (DFTPlanID DFT1DG [cols, rows] [0, 1]) .
    L.map
      (VS.convert .
       toUnboxed .
       computeS . makeFilter2D . fromUnboxed (Z :. cols :. rows) . VS.convert) $
    vecs1
  dftVecs2 <- dftExecuteBatchP plan (DFTPlanID DFT1DG [cols, rows] [0, 1]) vecs2
  let dftVecs3 = L.zipWith (VS.zipWith (*)) dftVecs1 dftVecs2
  DFTArray rows cols thetaFreqs rFreqs <$>
    dftExecuteBatchP plan (DFTPlanID IDFT1DG [cols, rows] [0, 1]) dftVecs3

{-# INLINE multiplyPinwheelBasisBatch #-}
multiplyPinwheelBasisBatch ::
     DFTPlan -> Int -> DFTArray -> DFTArray -> IO DFTArray
multiplyPinwheelBasisBatch plan numBatch (DFTArray rows cols thetaFreqs rFreqs vecs1) (DFTArray _ _ _ _ vecs2) = do
  let forwardPlanID = DFTPlanID DFT1DG [cols, rows] [0, 1]
      backwardPlanID = DFTPlanID IDFT1DG [cols, rows] [0, 1]
      forwardPlan = getDFTPlan plan forwardPlanID
      backwardPlan = getDFTPlan plan backwardPlanID
  fmap (DFTArray rows cols thetaFreqs rFreqs . L.concat) .
    mapConcurrently
      (M.mapM
         (\(vec1, vec2) -> do
            dftVec1 <-
              dftExecuteWithPlan forwardPlanID forwardPlan .
              VS.convert .
              toUnboxed .
              computeS .
              makeFilter2D . fromUnboxed (Z :. cols :. rows) . VS.convert $
              vec1
            dftVec2 <- dftExecuteWithPlan forwardPlanID forwardPlan vec2
            dftExecuteWithPlan backwardPlanID backwardPlan $
              VS.zipWith (*) dftVec1 dftVec2)) .
    divideListN numBatch $
    L.zip vecs1 vecs2

{-# INLINE multiplyPinwheelBasisBatch1 #-}
multiplyPinwheelBasisBatch1 ::
     DFTPlan -> Int -> VS.Vector (Complex Double) -> DFTArray -> IO DFTArray
multiplyPinwheelBasisBatch1 plan numBatch dftVec1 (DFTArray rows cols thetaFreqs rFreqs vecs2) = do
  let forwardPlanID = DFTPlanID DFT1DG [cols, rows] [0, 1]
      backwardPlanID = DFTPlanID IDFT1DG [cols, rows] [0, 1]
      forwardPlan = getDFTPlan plan forwardPlanID
      backwardPlan = getDFTPlan plan backwardPlanID
  fmap (DFTArray rows cols thetaFreqs rFreqs . L.concat) .
    mapConcurrently
      (M.mapM
         (\vec2 -> do
            dftVec2 <- dftExecuteWithPlan forwardPlanID forwardPlan vec2
            dftExecuteWithPlan backwardPlanID backwardPlan $
              VS.zipWith (*) dftVec1 dftVec2)) .
    divideListN numBatch $
    vecs2


{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}

module Backprop.Learn.Regularize (
    Regularizer
  , Regularize(..)
  , l1Reg
  , l2Reg
  , noReg
  , l2RegMetric
  , l1RegMetric
  -- * Build instances
  -- ** DerivingVia
  , RegularizeMetric(..), NoRegularize(..)
  -- ** Linear
  , lassoLinear, ridgeLinear
  -- ** Generics
  , grnorm_1, grnorm_2
  , glasso, gridge
  -- * Manipulate regularizers
  , addReg
  , scaleReg
  ) where

import           Control.Applicative
import           Control.Monad.Trans.State
import           Data.Ratio
import           Data.Semigroup hiding                 (Any(..))
import           Data.Type.Functor.Product
import           Data.Type.Tuple
import           Data.Vinyl
import           GHC.Exts
import           GHC.Generics
import           GHC.TypeNats
import           Generics.OneLiner
import           Numeric.Backprop                      as B
import           Numeric.LinearAlgebra.Static.Backprop ()
import           Numeric.Opto.Update hiding            ((<.>))
import qualified Data.Functor.Contravariant            as Co
import qualified Data.Vector.Generic                   as VG
import qualified Data.Vector.Generic.Sized             as SVG
import qualified Numeric.LinearAlgebra.Static          as H

-- | A regularizer on parameters
type Regularizer p = forall s. Reifies s W => BVar s p -> BVar s Double

-- | A class for data types that support regularization during training.
--
-- This class is somewhat similar to @'Metric' 'Double'@, in that it
-- supports summing the components and summing squared components.
-- However, the main difference is that when summing components, we only
-- consider components that we want to regularize.
--
-- Often, this doesn't include bias terms (terms that "add" to inputs), and
-- only includes terms that "scale" inputs, like components in a weight
-- matrix of a feed-forward neural network layer.
--
-- However, if all of your components are to be regularized, you can use
-- 'norm_1', 'norm_2', 'lassoLinear', and 'ridgeLinear' as sensible
-- implementations, or use DerivingVia with 'RegularizeMetric':
--
-- @
-- data MyType = ...
--   deriving Regularize via (RegularizeMetric MyType)
-- @
--
-- You can also derive an instance where /no/  are regularized, using
-- 'NoRegularize':
--
-- @
-- data MyType = ...
--   deriving Regularize via (NoRegularize MyType)
-- @
--
-- The default implementations are based on 'Generics', and work for types
-- that are records of items that are all instances of 'Regularize'.
class Backprop p => Regularize p where

    -- | Like 'norm_1': sums all of the weights in @p@, but only the
    -- ones you want to regularize:
    --
    -- \[
    -- \sum_w \lvert w \rvert
    -- \]
    --
    -- Note that typically bias terms (terms that add to inputs) are not
    -- regularized.  Only "weight" terms that scale inputs are typically
    -- regularized.
    --
    -- If @p@ is an instance of 'Metric', then you can set @'rnorm_1'
    -- = 'norm_1'@.  However, this would count /all/ terms in @p@, even
    -- potential bias terms.
    rnorm_1 :: p -> Double

    default rnorm_1 :: (ADT p, Constraints p Regularize) => p -> Double
    rnorm_1 = grnorm_1

    -- | Like 'norm_2': sums all of the /squares/ of the weights
    -- n @p@, but only the ones you want to regularize:
    --
    -- \[
    -- \sum_w w^2
    -- \]
    --
    -- Note that typically bias terms (terms that add to inputs) are not
    -- regularized.  Only "weight" terms that scale inputs are typically
    -- regularized.
    --
    -- If @p@ is an instance of 'Metric', then you can set @'rnorm_2'
    -- = 'norm_2'@.  However, this would count /all/ terms in @p@, even
    -- potential bias terms.
    rnorm_2 :: p -> Double

    default rnorm_2 :: (ADT p, Constraints p Regularize) => p -> Double
    rnorm_2 = grnorm_2

    -- | @'lasso' r p@ sets all regularized components (that is, components
    -- summed by 'rnorm_1') in @p@ to be either @r@ if that component was
    -- positive, or @-r@ if that component was negative.  Behavior is not
    -- defined if the component is exactly zero, but either @r@ or @-r@ are
    -- sensible possibilities.
    --
    -- It must set all /non-regularized/ components (like bias terms, or
    -- whatever items that 'rnorm_1' ignores) to zero.
    --
    -- If @p@ is an instance of @'Linear' 'Double'@ and 'Num', then you can set
    -- @'lasso' = 'lassoLinear'@.  However, this is only valid if 'rnorm_1'
    -- counts /all/ terms in @p@, including potential bias terms.
    lasso   :: Double -> p -> p

    default lasso :: (ADT p, Constraints p Regularize) => Double -> p -> p
    lasso = glasso

    -- | @'ridge' r p@ scales all regularized components (that is,
    -- components summed by 'rnorm_2') in @p@ by @r@.
    --
    -- It must set all /non-regularized/ components (like bias terms, or
    -- whatever items that 'rnorm_2' ignores) to zero.
    --
    -- If @p@ is an instance of @'Linear' 'Double'@ and 'Num', then you can set
    -- @'ridge' = 'ridgeLinear'@.  However, this is only valid if 'rnorm_2'
    -- counts /all/ terms in @p@, including potential bias terms.
    ridge   :: Double -> p -> p

    default ridge :: (ADT p, Constraints p Regularize) => Double -> p -> p
    ridge = gridge

grnorm_1 :: (ADT p, Constraints p Regularize) => p -> Double
grnorm_1 = getSum . gfoldMap @Regularize (Sum . rnorm_1)

grnorm_2 :: (ADT p, Constraints p Regularize) => p -> Double
grnorm_2 = getSum . gfoldMap @Regularize (Sum . rnorm_2)

glasso :: (ADT p, Constraints p Regularize) => Double -> p -> p
glasso r = gmap @Regularize (lasso r)

gridge :: (ADT p, Constraints p Regularize) => Double -> p -> p
gridge r = gmap @Regularize (ridge r)

-- | Backpropagatable L1 regularization; also known as lasso
-- regularization.
--
-- \[
-- \sum_w \lvert w \rvert
-- \]
--
-- Note that typically bias terms (terms that add to inputs) are not
-- regularized.  Only "weight" terms that scale inputs are typically
-- regularized.
l1Reg :: Regularize p => Double -> Regularizer p
l1Reg λ = liftOp1 . op1 $ \x ->
    ( λ * rnorm_1 x
    , (`lasso` x) . (* λ)
    )

-- | Backpropagatable L2 regularization; also known as ridge
-- regularization.
--
-- \[
-- \sum_w w^2
-- \]
--
-- Note that typically bias terms (terms that add to inputs) are not
-- regularized.  Only "weight" terms that scale inputs are typically
-- regularized.
l2Reg :: Regularize p => Double -> Regularizer p
l2Reg λ = liftOp1 . op1 $ \x ->
    ( λ * rnorm_2 x
    , (`ridge` x) . (* λ)
    )

-- | No regularization
noReg :: Regularizer p
noReg _ = auto 0

-- | A default implementation of 'lasso' for instances of @'Linear'
-- 'Double'@ and 'Num'.  However, this is only valid if the corresponding
-- 'rnorm_1' counts /all/ terms in @p@, including potential bias terms.
lassoLinear :: (Linear Double p, Num p) => Double -> p -> p
lassoLinear r = (r .*) . signum

-- | A default implementation of 'ridge' for instances of @'Linear'
-- 'Double'@.  However, this is only valid if the corresponding
-- 'rnorm_2' counts /all/ terms in @p@, including potential bias terms.
ridgeLinear :: Linear Double p => Double -> p -> p
ridgeLinear = (.*)

-- | L2 regularization for instances of 'Metric'.  This will count
-- all terms, including any potential bias terms.
--
-- You can always use this as a regularizer instead of 'l2Reg', if you want
-- to ignore the default behavior for a type, or if your type has no
-- instance.
--
-- This is what 'l2Reg' would be for a type @p@ if you declare an instance
-- of 'Regularize' with @'rnorm_2' = 'norm_2'@, and @'ridge'
-- = 'ridgeLinear'@.
l2RegMetric
    :: (Metric Double p, Backprop p)
    => Double                   -- ^ scaling factor (often 0.5)
    -> Regularizer p
l2RegMetric λ = liftOp1 . op1 $ \x ->
            ( λ * quadrance x, (.* x) . (* λ))

-- | L1 regularization for instances of 'Metric'.  This will count
-- all terms, including any potential bias terms.
--
-- You can always use this as a regularizer instead of 'l2Reg', if you want
-- to ignore the default behavior for a type, or if your type has no
-- instance.
--
-- This is what 'l1Reg' would be for a type @p@ if you declare an instance
-- of 'Regularize' with @'rnorm_1' = 'norm_1'@, and @'lasso'
-- = 'lassoLinear'@.
l1RegMetric
    :: (Num p, Metric Double p, Backprop p)
    => Double                   -- ^ scaling factor (often 0.5)
    -> Regularizer p
l1RegMetric λ = liftOp1 . op1 $ \x ->
            ( λ * norm_1 x, (.* signum x) . (* λ)
            )

-- | Add together two regularizers
addReg :: Regularizer p -> Regularizer p -> Regularizer p
addReg f g x = f x + g x

-- | Scale a regularizer's influence
scaleReg :: Double -> Regularizer p -> Regularizer p
scaleReg λ reg = (* auto λ) . reg

-- | Newtype wrapper (meant to be used with DerivingVia) to derive an
-- instance of 'Regularize' that uses its 'Metric' instance, and
-- regularizes every component of a data type, including any potential bias
-- terms.
newtype RegularizeMetric a = RegularizeMetric a
  deriving (Show, Eq, Ord, Read, Generic, Functor, Backprop)

instance (Metric Double p, Num p, Backprop p) => Regularize (RegularizeMetric p) where
    rnorm_1 = coerce $ norm_1 @_ @p
    rnorm_2 = coerce $ norm_2 @_ @p
    lasso   = coerce $ lassoLinear @p
    ridge   = coerce $ ridgeLinear @p

-- | Newtype wrapper (meant to be used with DerivingVia) to derive an
-- instance of 'Regularize' that does not regularize any part of the type.
newtype NoRegularize a = NoRegularize a
  deriving (Show, Eq, Ord, Read, Generic, Functor, Backprop)

instance Backprop a => Regularize (NoRegularize a) where
    rnorm_1 _ = 0
    rnorm_2 _ = 0
    lasso _   = B.zero
    ridge _   = B.zero

instance Regularize Double where
    rnorm_1 = id
    rnorm_2 = (** 2)
    lasso r = (r *) . signum
    ridge   = (*)

instance Regularize Float where
    rnorm_1 = realToFrac
    rnorm_2 = (** 2) . realToFrac
    lasso r = (realToFrac r *) . signum
    ridge   = (*) . realToFrac

instance Integral a => Regularize (Ratio a) where
    rnorm_1 = realToFrac
    rnorm_2 = (** 2) . realToFrac
    lasso r = (realToFrac r *) . signum
    ridge   = (*) . realToFrac

instance Regularize () where
    rnorm_1 _ = 0
    rnorm_2 _ = 0
    lasso _ _ = ()
    ridge _ _ = ()
instance (Regularize a, Regularize b) => Regularize (a, b)
instance (Regularize a, Regularize b, Regularize c) => Regularize (a, b, c)
instance (Regularize a, Regularize b, Regularize c, Regularize d) => Regularize (a, b, c, d)
instance (Regularize a, Regularize b, Regularize c, Regularize d, Regularize e) => Regularize (a, b, c, d, e)

instance (Regularize a, Regularize b) => Regularize (a :# b)
instance Regularize a => Regularize (TF a)

instance (RPureConstrained Regularize as, ReifyConstraint Backprop TF as, RMap as, RApply as, RFoldMap as) => Regularize (Rec TF as) where
    rnorm_1 = getSum
            . rfoldMap getConst
            . rzipWith coerce (rpureConstrained @Regularize (Co.Op rnorm_1))
    rnorm_2 = getSum
            . rfoldMap getConst
            . rzipWith coerce (rpureConstrained @Regularize (Co.Op rnorm_2))
    lasso r = rzipWith coerce (rpureConstrained @Regularize (Endo (lasso r)))
    ridge r = rzipWith coerce (rpureConstrained @Regularize (Endo (ridge r)))

instance (PureProdC Maybe Backprop as, PureProdC Maybe Regularize as) => Regularize (PMaybe TF as) where
    rnorm_1 = getSum
            . foldMapProd getConst
            . zipWithProd coerce (pureProdC @_ @Regularize (Co.Op rnorm_1))
    rnorm_2 = getSum
            . foldMapProd getConst
            . zipWithProd coerce (pureProdC @_ @Regularize (Co.Op rnorm_2))
    lasso r = zipWithProd coerce (pureProdC @_ @Regularize (Endo (lasso r)))
    ridge r = zipWithProd coerce (pureProdC @_ @Regularize (Endo (ridge r)))

instance (VG.Vector v a, Regularize a, Backprop (SVG.Vector v n a)) => Regularize (SVG.Vector v n a) where
    rnorm_1 = (`execState` 0) . SVG.mapM_ (modify . (+) . rnorm_1)
    rnorm_2 = (`execState` 0) . SVG.mapM_ (modify . (+) . rnorm_2)
    lasso r = SVG.map (lasso r)
    ridge r = SVG.map (ridge r)

deriving via (RegularizeMetric (H.R n)) instance KnownNat n => Regularize (H.R n)
deriving via (RegularizeMetric (H.L n m)) instance (KnownNat n, KnownNat m) => Regularize (H.L n m)


{-# OPTIONS_GHC  -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-name-shadowing -fno-warn-missing-signatures #-}
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, FlexibleContexts, TypeSynonymInstances #-}

---------------------------------------------------------------------------------------------------
---------------------------------------------------------------------------------------------------
-- |
-- | Module : Approximate median
-- | Creator: Xiao Ling
-- | Created: 12/08/2015
-- | TODO   : test standard deviation of alpha, beta, and final version
-- |
---------------------------------------------------------------------------------------------------
---------------------------------------------------------------------------------------------------

module ApproxMedian (

      MaxSize
    , Store

    , aMedian
    , aMedian'

  ) where

import Control.Monad.Trans
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Identity

import Data.Random
import Data.Conduit
import Data.Sequence
import Data.Foldable (toList)
import qualified Data.Conduit.List as Cl

import Core
import Statistics

{-----------------------------------------------------------------------------
  Types
------------------------------------------------------------------------------}

type MaxSize = Int
type Store a = (Seq a, MaxSize)

-- * Construct an empty store given max size `s`
store :: MaxSize -> Store a
store = (,) empty

{-----------------------------------------------------------------------------
  Median II
------------------------------------------------------------------------------}

-- * determine the `e`ps -approx median of a list `xs` with confidence `d`elta.
aMedian :: (Ord a, Floating a) => Eps -> Delta -> [a] -> IO a
aMedian e d xs = eval $ Cl.sourceList xs $$ toMedian $ store s
  where eval p = fmap (median . toList) . fmap fst . flip runRVar StdRandom $ evalStateT p 0
        s      = round $ 7/(e^2) * log (2/d)

-- * `tick` up a counter for each item `a` seen
-- * and with probability min(1, s/i) put item `a` into store `t`
toMedian :: Store a -> Sink a (StateT Counter RVar) (Store a)
toMedian t = Cl.foldM (\t a -> tick >> t $|> a) t

-- * count items seen so far
tick :: Enum s => MonadState s m => m ()
tick = modify succ

-- * with probability `s/i` uniformly select an item from the store `t` and replace it with `a`
-- * mnemonic: `|>` is insertion for Sequences, and `$f` means do f probabilistically
($|>) :: Store a -> a -> StateT Counter RVar (Store a)
($|>) t@(as,s) a = do

  i <- get

  let p = s ./ i
  if p >= 1 then return (as |> a, s) else do

      h <- lift . toss $ coin p

      if isHead h then do
          x <- lift (uniform 0 s :: RVar Int)
          let as' = update x a as
          return (as',s)
      else return t

-- * Sledghammer division
(./) :: (Fractional a, Read a, Show s, Show i) => s -> i -> a
(./) s i = (read . show $ s)/(read . show $ i)

{-----------------------------------------------------------------------------
  Median II
------------------------------------------------------------------------------}

-- * determine the `e`ps - approx median of a list `xs` with confidence `d`elta.
aMedian' :: (Ord a, Floating a) => Eps -> Delta -> [a] -> IO a
aMedian' e d xs = eval $ Cl.sourceList xs $$ toMedian'
  where eval p = fmap (median . toList) . fmap fst $ runRVar (evalStateT (runStateT p 0) (store s)) StdRandom
        s      = round $ 7/(e^2) * log (2/d)

-- * `tick` up a counter `i` of items seen so far
-- * and with uniform probability put the item `a` into a store `as` of max size `s`
toMedian' :: Sink a (StateT Counter (StateT (Store a) RVar)) (Seq a)
toMedian' = tick' >> do
  ma <- await
  case ma of
    Nothing -> (lift . lift $ get) >>= return . fst
    Just a  -> (lift . place $ a ) >>  toMedian'

tick' :: (Enum s, MonadTrans t, MonadState s m) => t m ()
tick' = lift . modify $ succ

-- * with uniform probability `s/i` select an item from the
-- * store and re`place` it with `a`
place :: a -> StateT Counter (StateT (Store a) RVar) ()
place a = do

  i        <- get
  t@(as,s) <- lift get

  let p = s ./ i

  if p >= 1 then lift $ put (as |> a, s) else do

      h <- lift . lift . toss $ coin p
      case isHead h of
        False -> lift $ put (as,s)
        _     -> do
          x <- lift $ lift (uniform 0 s :: RVar Int)
          let as' = update x a as
          lift $ put (as',s)

{-----------------------------------------------------------------------------
  Awaiting SO response for this stuff
------------------------------------------------------------------------------}

instance MonadState s m => MonadState s (RVarT m) where
  get   = lift get
  put   = lift . put
  state = lift . state

foo :: (MonadState s m, MonadRandom m) => s -> RVarT m ()
foo s = do
  x <- (uniformT 0 1 :: RVarT m Double)
  if x < 0.5 then put s else return ()

foo' :: (MonadState String m, MonadRandom m) => RVarT m ()
foo' = foo "hello"

--foo'' :: (MonadState String m, MonadRandom m) => m ()
--foo''= runRVarT foo' StdRandom

bar :: (MonadTrans t1, MonadState t m, MonadState s (t1 m)) => s -> RVarT (t1 m) ()
bar s = do
  x <- (uniformT 0 1 :: RVarT m Double)
  a <- lift . lift $ get
  if x < 0.5 then put s else return ()

-- * desired behavior with state and ranndomness

baz :: (MonadState s m, MonadReader t m) => m ()
baz = get >> ask >> return ()

baz1 :: MonadReader t m => m ((),Int)
baz1 = runStateT baz 0

baz1' :: Identity ((),Int)
baz1' = runReaderT baz1 (1,"hello")

baz2 :: MonadState s m => m ()
baz2 = runReaderT baz "hello"

baz2' :: Identity ((),[Int])
baz2' = runStateT baz2 [1..10]


{-|
Module      : ODMatrix.ElementaryDecomposition.ShortestPath
Description : This module is responsible for computing the shortest path between two ODMs.

Contains the necesary functions to measure and compare ODMs.

-}
module ODMatrix.ElementaryDecomposition.ShortestPath (
      Measure
    , sePath
    , ev
    , ev3
  ) where

  import Control.Monad.State.Lazy
  --import Control.Monad.Loops (iterateUntilM)

  import Numeric.LinearAlgebra

  import qualified Data.HashMap.Lazy as M
  import qualified Data.Hashable as H
  import Data.Maybe

  import ODMatrix.ElementaryDecomposition (ElementaryMatrix(..), ODM,
                                       getChildren, applyElementary,
                                       applyPath,
                                       applicables, elementaryValue,
                                       opposite, isNullElementary)

  -- import Debug.Trace (trace)

  -- | Measure or Metric prototype
  type Measure = Int -> Int -> Double

  -- | Elementary Value.
  -- Given a metric m, a in route metric mr and a scale factor alpha returns a elementary value metric.
  ev :: Double    -- ^ Scale factor alpha
     -> Measure   -- ^ Metric m
     -> Measure   -- ^ In route metric mr
     -> Measure   -- ^ Elementary value metric
  ev a m mr i j
    | a < 0 = error "The ajustment parameter must be greater than 0."
    | otherwise = m i j + a * mr i j

  -- | Shortest Path
  -- Computes the sequence of elementary matrices between ODMs
  sePath :: Measure             -- ^ Elementary value metric
         -> ODM                 -- ^ Source ODM
         -> ODM                 -- ^ Target ODM
         -> [ElementaryMatrix]  -- ^ Sequence of elementary matrices in the shortest path
  sePath m a b = evalState _process (_initialSEPState m a b)

  -- | Map a Elementary Matrix to it related cells indexes
  emc :: ElementaryMatrix -> (Int, Int)
  emc (Elementary _ (cell1, _) (cell2, _)) = (cell1,cell2)

  -- | Compares two ODMs
  odmc :: (Matrix Double -> Double) -- ^ Function g to compute the remainder
       -> Measure                   -- ^ Elementary value metric
       -> Double                    -- ^ Scale factor
       -> ODM                       -- ^ ODM A
       -> ODM                       -- ^ ODM B
       -> Double                    -- ^ Difference between A and B
  odmc g ev beta a b = beta * g s + sum [ev i j | (i,j) <- sp]
    where p = sePath ev a b
          sp = map emc . filter (not . isNullElementary) $ p
          s = b - applyPath a p -- Remainder

  newtype HashMatrix = HashMatrix { hm :: ODM }

  instance Show HashMatrix where
    show (HashMatrix m) = show m

  instance Eq HashMatrix where
    (==) (HashMatrix a) (HashMatrix b) = a == b

  instance H.Hashable HashMatrix where
    hashWithSalt salt (HashMatrix m) = floor $ m `atIndex` (salt `mod` rows m, salt `mod` cols m)

  data SEP = SEP {
      dist      :: M.HashMap HashMatrix Double
    , prev      :: M.HashMap HashMatrix ElementaryMatrix
    , visited   :: [ODM]
    , target    :: ODM
    , measure   :: Measure
    }

  instance Show SEP where
    show = show . visited

  -- | Elementary Value 3 (See the paper).
  -- This is a special case of elementary value computed with only one metric.
  -- Only works for regular grids.
  ev3 :: Double -> Measure -> Measure
  ev3 a m i j
    | a <= 0 || a >= 1 = error "The ajustment parameter a must be 0 < a < 1."
    | otherwise = a * m i j + (1-a) * sum [ m k (k+1) | k <- [min i j .. max i j] ]

  -- TODO: Implement metrics.

  _initialSEPState :: Measure -> ODM -> ODM -> SEP
  _initialSEPState m src trg = SEP (M.singleton (HashMatrix src) 0) M.empty [] trg m

  -- | TODO: take out the harcoded 60.
  -- | MAYBE IF IN THE FINAL STEP ASK FOR NEIGHBORS EMPTY.
  _process :: State SEP [ElementaryMatrix]
  _process = do
    s <- get
    let (curr,d) = _getNext (dist s)
        neighbors = applicables (0,60) curr . getChildren $ (target s) - curr
        -- Filter out the visited neighbors
        unvisited = filter (\e -> applyElementary curr e `notElem` visited s) neighbors
    -- Calculate min distance to all neighbors (unvisited)
    modify $ minAndPrev curr d unvisited
    -- \t -> t {dist = foldr (mindist (measure t) curr d) (dist t) unvisited}
    -- Add current to the previous of unvisited

    -- Mark the current as visited.
    modify $ \t -> t {dist = M.delete (HashMatrix curr) (dist t),
                      visited = curr:visited t}
    sn <- get
    if curr == (target sn) || null neighbors  then return . fst $ _wrapUp curr sn else _process
    -- if curr == (target sn) then return . fst $ _wrapUp curr sn else _process

  -- Calculate the min distance and the corresponding previous.
  minAndPrev :: ODM -> Double -> [ElementaryMatrix] -> SEP -> SEP
  minAndPrev curr d unvisited t = foldr f t nds
    where nds = map (neighborsDists t curr d) unvisited
          f (md,k,e) s = s { dist = M.insert k md (dist s),
                             prev = M.insert k e (prev s) }

  neighborsDists :: SEP                           -- ^ Final state
                 -> ODM                           -- ^ Current
                 -> Double                        -- ^ Dist from origin
                 -> ElementaryMatrix              -- ^ Neighbor
                 -> (Double,HashMatrix,ElementaryMatrix)     -- ^ Min distance and Neighbor
  neighborsDists s m d e = (min newd oldd, k, e)
    where newd = d + elementaryValue (measure s) e
          oldd = M.lookupDefault newd k (dist s)
          k = HashMatrix $ applyElementary m e

  -- | Get next matrix to process and the shortest distance from src
  _getNext :: M.HashMap HashMatrix Double -- ^ List of distances by ODM
           -> (ODM,Double)                -- ^ ODM with min distance and the distance
  _getNext ds
    | null ds = error "Not destination found"
    | otherwise = (\(m,d) -> (hm m, d)) $ M.foldrWithKey f initial ds
    where initial = head . M.toList $ ds            -- (k,v)
          f k v mn@(_, minv) | v < minv = (k,v)
                             | otherwise = mn

  _wrapUp :: ODM -> SEP -> ([ElementaryMatrix],SEP)
  _wrapUp m s = (es, s)
    where p = M.lookup (HashMatrix m) (prev s)
          --op e = e {sign = - sign e}
          odm = (\x -> applyElementary m (opposite x)) <$> p
          es = maybe [] (\x -> fromJust p : fst (_wrapUp x s)) odm

  -- _testMatrix :: ODM
  -- _testMatrix = matrix 10 [0,0,0,1,0,0,0,0,0,0,0,2,1,0,1,3,0,0,0,0,0,0,2,0,0,4,1,0,1,0,0,0,0,1,0,0,0,0,2,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]

  -- _testSimMatrix :: ODM
  -- _testSimMatrix = matrix 10 [0,0,1,0,0,0,0,0,0,0,0,2,0,1,1,3,0,0,0,0,0,0,2,0,0,4,1,0,1,0,0,0,0,1,0,0,0,0,2,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]

  -- _testDifMatrix :: ODM
  -- _testDifMatrix = matrix 10 [0,0,0,1,0,0,0,0,0,0,0,2,1,0,1,3,0,0,0,0,0,0,2,0,0,4,2,0,0,0,0,0,0,1,0,0,0,0,2,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]