module QLib
    ( quantumRun
    ) where

import Data.Complex
import Data.Bits
import qualified Data.List as L
import Text.Printf
import Numeric.LinearAlgebra

quantumRun :: IO ()
quantumRun = do putStrLn "Some Func"
                let a = newRegister 4
                putStrLn $ show a
--                putStrLn $ printf "%b" (3 :: Int)
--                let c = Qubit $ fromList [1 :+ 0, 0]
--                putStrLn $ show c
--                let d = sauliX c
--                putStrLn $ show d
--                let e = Register $ take 5 $ repeat (Qubit $ fromList [1, 0])
--                --let e = sauliZ d
--                putStrLn $ show e

--data Qubit = Qubit (Double, Int)
data Qubit = Qubit { probability :: Double, qubit :: Int }

instance Eq Qubit where
    x == y = qubit x == qubit y

instance Ord Qubit where
    x <= y = qubit x <= qubit y

instance Show Qubit where
    show x = (show . probability $ x) ++ " |" ++ (show . qubit $ x) ++ ">"

data Register = Register { nStates :: Int, qubits :: [Qubit] }

instance Show Register where
    --show (Register a x) = (show a) (show x) ++ ">"
    show x = concatMap ((flip (++) "\n") . show) $ qubits x

instance Eq Register where
    x == y = qubits x == qubits y

newRegister :: Int -> Register
newRegister n = Register { nStates = n, qubits = [blankQubit (x-1) | x <- [1..2^n] ] }
                where blankQubit 0 = Qubit { probability = 1.0, qubit = 0 }
                      blankQubit y = Qubit { probability = 0.0, qubit = y }

sauliX :: Register -> Int -> Register
sauliX xs pos = map (\x -> x `xor` pos) xs

--newRegister :: Int -> QuantumRegister
--newRegister 0 = QuantumRegister 0 []
--newRegister 1 = QuantumRegister 1 [ (Register 0 [Zero]), (Register 0 [One]) ]
--newRegister x = QuantumRegister x [

--sauliX :: Qubit -> Qubit
--sauliX (Qubit x) = Qubit (xgate #> x)
--                where xgate = (2><2)[0, 1, 1, 0] :: Matrix C
--
--sauliY :: Qubit -> Qubit
--sauliY (Qubit x) = Qubit (ygate #> x)
--                where ygate = (2><2)[0:+1, 0, 0, 0:+1] :: Matrix C
--
--sauliZ :: Qubit -> Qubit
--sauliZ (Qubit x) = Qubit (zgate #> x)
--                where zgate = (2><2)[1, 0, 0, -1] :: Matrix C

--data Bit = Zero | One deriving Eq
--
--instance Show Bit where
--    show Zero = "|0>"
--    show One  = "|1>"
--
--data Qubit a = Qubit (Complex a) (Complex a) deriving Show
--
--sauliX :: Qubit a -> Qubit a
--sauliX (Qubit x y) = Qubit y x
--
--sauliY :: (Fractional a, RealFloat a) => Qubit a -> Qubit a
--sauliY (Qubit x y) = Qubit rotY rotX
--        where i = 0 :+ 1
--              rotY = -y*i
--              rotX = x*i
--
--sauliZ :: (RealFloat a) => Qubit a -> Qubit a
--sauliZ (Qubit x y) = Qubit x (-y)

--data Qubit a = Qubit (Vector a)
--
---- Show the Qubit using Ket notation
--instance (Show a, Numeric a) => Show (Qubit a) where
--    show (Qubit x) = '(':(show first) ++ ")|0> + (" ++ (show second) ++ ")|1>"
--                    where first = (fromList [1, 0]) <.> x
--                          second = fromList [0, 1] <.> x
--
--notGate :: Qubit R -> Qubit R
--notGate (Qubit x) = let invertMatrix = (2><2) [-1, 0, 0, -1] in
--                        Qubit (invertMatrix #> x)


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}

module Main where

import Data.Array
import Data.Complex
import qualified Data.IntMap.Strict as IM
import Data.List (intercalate)
import Data.Map (empty, fromList, union)
import Data.Maybe (fromJust)
import Data.STRef.Strict
import qualified Data.Set as Set
import HashedExpression.Derivative.Partial
import Graphics.EasyPlot
import HashedExpression
import HashedExpression.Derivative
import HashedExpression.Interp
import HashedExpression.Operation
import qualified HashedExpression.Operation
import HashedExpression.Prettify
import Data.String.Interpolate
import Prelude hiding ((^))

main :: IO ()
main = do
  let x = variable "x"
  let y = variable "y"
  let f = sum [x^2 , 2*x , 1] * (x^2 + 2 * y + 1)
  print $ allEntries f


{-# LANGUAGE BangPatterns, LambdaCase #-}

module Main where

import           Help
import           Input
import           Fractals
import           Colors
import           Data.Complex
import qualified Graphics.Image                as I
import qualified Graphics.Image.Interface      as I
import           System.IO
import           Data.Word
import           System.Environment
import           System.Directory
import           Data.Time

-- Entry point for program
main :: IO ()
main = do
   args <- getArgs
   if not (length args == 0) &&
      (  head args == "h"
      || head args == "-h"
      || head args == "help"
      || head args == "-help"
      || head args == "?"
      || head args == "-?"
      )
     then do
        putStrLn $ help args
        hFlush stdout
     else do
        let options = processArgs args
        putStrLn $ pPrintOptions options
        hFlush stdout
        fractal args options

fractal :: [String] -> Options -> IO ()
fractal args options@(Options fractalType (numRows, numColumns) (centerReal :+ centerImag)
                      range iterations power aaIn normalization color animation
                      cValue setColor framesIn startingFrame)
   = do
      currentDir <- getCurrentDirectory
      {- Path is generated by finding the current date/time, replacing colons (an invalid character in
       Windows paths) with an alternate Unicode colon, and removing the last 12 digits (which contain
       the fractional part of the seconds and the "UTC" code) -}
      path  <- fmap
         ( ((currentDir ++ "\\Generated Fractals\\") ++)
         . reverse . drop 12 . reverse
         . map (\case ':' -> '\xA789'; x -> x)
         . show
         )
         getCurrentTime
      createDirectoryIfMissing True path
      setCurrentDirectory path
      writeFile "data.txt" $ (pPrintOptions options) ++ '\n' : "Arguments:       " ++ (unwords args)
      putStr $ (show $ startingFrame - 1) ++ '/' : (show $ floor frames)
      hFlush stdout
      mapM_
         (\frame -> do
            I.writeImageExact (I.PNG) []
                  (path ++ '\\' : (take ((countDigits $ floor frames) - (countDigits $ frame)) $ repeat '0')
                   ++ show (frame) ++ ".png") $
                  I.toManifest $ I.toWord8I $ I.makeImageR I.RPS
                                       (numRows, numColumns)
                                       (\point -> colorFunc $ fractalFunction frame point)
            putStr $ '\r' : (show $ frame + 1) ++ '/' : (show $ floor frames)
            hFlush stdout
         )
         [startingFrame - 1 .. (truncate frames) - 1]
      putStrLn ""
 where
   frames = case animation of
      NoAnimation -> 1
      otherwise   -> fromIntegral framesIn
   colorFunc =
      case color of
            Greyscale                  -> colorGrey setColor
            Hue                        -> colorHue setColor
            Gradient isCircular colors -> colorGrad setColor isCircular colors
         . fmap
            (case normalization of
               Linear               -> normLinear iterations
               Sigmoid center power -> normSigmoid center power
               Periodic period      -> normPeriodic period
               Sine     period      -> normSine period
            )
   aa = case aaIn of
      AAEnabled  -> True
      AADisabled -> False
   animVals = map
      (case animation of
         Zoom final _ -> ((exp $ (log (final / range)) / (frames - 1)) **)
         Grid rIni rFnl _ _ rNum _ ->
            interpolate rIni rFnl . (/ (fromIntegral rNum - 1)) . fromIntegral . (`mod` rNum) . floor
         otherwise ->
            case animation of
                NoAnimation      -> \x -> 1
                Power final      -> interpolate power final
                Iterations final -> interpolate (fromIntegral iterations) (fromIntegral final)
                Theta final _    -> interpolate (phase cValue) (final * pi / 180)
                LinearC final    -> interpolate (realPart cValue) (realPart final)
            . if frames /= 1 then (/ (frames - 1)) else id
      )
      [fromIntegral startingFrame - 1 .. frames - 1]
   altAnimVals = map
      (case animation of
         Grid _ _ iIni iFnl rNum iNum ->
            interpolate iIni iFnl . (/ (fromIntegral iNum - 1)) . fromIntegral . (`div` rNum) . floor
         otherwise ->
            case animation of
                Zoom _ (Just finalIter) -> interpolate (fromIntegral iterations) (fromIntegral finalIter)
                Zoom _ Nothing          -> \x -> fromIntegral iterations
                Theta _ (Just final)    -> interpolate (magnitude cValue) final
                Theta _ Nothing         -> \x -> magnitude cValue
                LinearC final           -> interpolate (imagPart cValue) (imagPart final)
            . if frames /= 1 then (/ (frames - 1)) else id
      )
      [fromIntegral startingFrame - 1 .. frames - 1]
   fractalFunction :: Int -> (Int, Int) -> Maybe Double
   fractalFunction frame (r, c) = case (fractalType, animation) of
      -- Mandelbrot animation functions
      (Mandelbrot, NoAnimation) ->
         pMandelbrot aa pixelSize iterations power $ pairToComplex (r, c)
      (Mandelbrot, Power _) ->
         pMandelbrot aa pixelSize iterations value $ pairToComplex (r, c)
      (Mandelbrot, Zoom _ _) ->
         pMandelbrot aa (pixelSize * value) (round $ altValue) power $ pairToComplexZ (r, c) value
      (Mandelbrot, Iterations _) ->
         pMandelbrot aa pixelSize (round value) power $ pairToComplex (r, c)
      (Mandelbrot, Theta _ _) ->
         error "Theta animations can only be generated for Julia fractals"
      (Mandelbrot, LinearC _) ->
         error "Linear C-Value animations can only be generated for Julia fractals"
      (Mandelbrot, Grid _ _ _ _ _ _) ->
         error "Grided c-values can only be generated for Julia fractals"
      -- Julia animation functions
      (Julia, NoAnimation) ->
         pJulia aa pixelSize iterations power cValue $ pairToComplex (r, c)
      (Julia, Power _) ->
         pJulia aa pixelSize iterations value cValue $ pairToComplex (r, c)
      (Julia, Zoom _ _) ->
         pJulia aa (pixelSize * value) (round $ altValue) power cValue $ pairToComplexZ (r, c) value
      (Julia, Iterations _) ->
         pJulia aa pixelSize (round value) power cValue $ pairToComplex (r, c)
      (Julia, Theta _ _) ->
         pJulia aa pixelSize iterations power (mkPolar altValue value) $ pairToComplex (r, c)
      (Julia, LinearC _) ->
         pJulia aa pixelSize iterations power (value :+ altValue) $ pairToComplex (r, c)
      (Julia, Grid _ _ _ _ _ _) ->
         pJulia aa pixelSize iterations power (value :+ altValue) $ pairToComplex (r, c)
      where
         -- The value being animated
         value     = animVals !! frame
         altValue  = altAnimVals !! frame
         -- Other values
         pixelSize = (2 * range) / (fromIntegral $ numColumns - 1)
         halfV     = 0.5 * fromIntegral numRows
         halfH     = 0.5 * fromIntegral numColumns
         -- Function to get a complex point from a pixel coordinate pair
         pairToComplex (r, c) =
            (centerReal - range + fromIntegral c * pixelSize)
               :+ (centerImag + (pixelSize * (fromIntegral (numRows - 1) / 2)) - fromIntegral r * pixelSize)
         -- Same as above but for zoom animations
         pairToComplexZ (r, c) zoomFactor =
            ((fromIntegral c - halfH) * pixelSize * zoomFactor + centerReal)
               :+ ((fromIntegral r - halfV) * pixelSize * zoomFactor - centerImag)

-- Helper function for interpolating from the start to the end of an animation's value range
interpolate :: RealFloat a => a -> a -> a -> a
interpolate i f = (i +) . (*) (f - i)

-- Helper funtion to count the number of digits in an integer when expressed in base 10
countDigits :: Integral a => a -> a
countDigits = (+ 1) . floor . logBase 10 . fromIntegral


module AI.GeneticAlgorithm
    ( Genome
    , Individual
    , Population
    , individualGenome
    , individualFitness
    , mutate
    , proportionalSelection
    , getBasePopulation
    , evolve
    , evolves
    , bestAverageWorst ) where

import           AI.NeuralNetwork            as NN
import           Control.Lens
import           Control.Monad.State
import           Control.Parallel.Strategies
import           Data.Function
import           Data.Functor.Identity
import           Data.Maybe
import           Data.Random.Normal
import qualified Data.Vector                 as V
import qualified Data.Vector.Generic         as VG
import           Numeric.LinearAlgebra
import           System.Random

type Genome       = NN.Network
-- An individual with a genome and fitness
data Individual a = Individual Genome a
    deriving (Eq, Show)
type Population a = V.Vector (Individual a)

mut :: Double -> Double -> Double -> State StdGen Double
mut rate amount val = do
    rRate <- state random
    if rRate < rate
       then fmap (\x -> val + x * amount) (state normal)
       else return val

toIndividual :: (Genome -> a) -> Genome -> Individual a
toIndividual fitfunc genome = Individual genome (fitfunc genome)

toPopulation :: (Genome -> a) -> V.Vector Genome -> V.Vector (Individual a)
toPopulation fitfunc genomes = let pop = V.map (toIndividual fitfunc) genomes
                                in pop `using` parTraversable rseq

individualGenome :: Individual a -> Genome
individualGenome (Individual g _) = g

individualFitness :: Individual a -> a
individualFitness (Individual _ f) = f

mutate :: Double -> Double -> Genome -> State StdGen Genome
mutate rate amount genome = do
    let cmut = mut rate amount
    newBiases  <- mapM (VG.mapM    cmut) (genome^.biases)
    newWeights <- mapM (mapMatrixM cmut) (genome^.weights)
    let newNN = execState (biases .= newBiases >> weights .= newWeights) genome
    return newNN

proportionalSelection :: (Random a, Ord a, Num a, NFData a) =>
    Population a -> State StdGen (Population a)
proportionalSelection pop =
    let fitness  = individualFitness <$> pop
        accFit   = V.scanl1 (+) fitness
        choose p = snd $ fromJust $ V.find (\t -> p <= fst t) (V.zip accFit pop)
     in forM pop $ \_ -> do
         p <- state $ randomR (0, V.last accFit)
         return $ choose p

getBasePopulation :: (Genome -> a) -> State StdGen Genome ->
    Int -> State StdGen (Population a)
getBasePopulation fitfunc genomeGen popSize =
    toPopulation fitfunc <$> V.replicateM popSize genomeGen

evolve :: (Genome -> Double) -> (Genome -> State StdGen Genome) ->
    Population Double -> State StdGen (Population Double)
evolve fitfunc mutfunc pop = do
    selected <- proportionalSelection pop
    mutated  <- mapM (\(Individual g _) -> mutfunc g) selected
    return $ toPopulation fitfunc mutated

evolves :: Int -> Int -> State StdGen Genome ->
    (Genome -> Double) -> (Genome -> State StdGen Genome) ->
        State StdGen [Population Double]
evolves generations popSize genomeGen fitfunc mutfunc = do
    basePop <- getBasePopulation fitfunc genomeGen popSize
    let evofunc = evolve fitfunc mutfunc
    evolutions <- V.iterateNM generations evofunc basePop
    return $ V.toList evolutions

bestAverageWorst :: (Fractional a, Ord a) =>
    [Population a] -> [(Individual a, a, Individual a)]
bestAverageWorst = reverse . foldl (\acc pop ->
        let fitness = individualFitness <$> pop
            best = V.maximumBy (compare `on` individualFitness) pop
            avgFit = sum fitness / fromIntegral (V.length fitness)
            worst = V.minimumBy (compare `on` individualFitness) pop
         in (best, avgFit, worst) : acc) []

mapMatrixM :: (Element a, Element b, Monad m) =>
    (a -> m b) -> Matrix a -> m (Matrix b)
mapMatrixM f m = let ll  = toLists m
                     mmM = mapM . mapM
                  in fromLists <$> mmM f ll


{-# LANGUAGE AllowAmbiguousTypes       #-}
{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TypeApplications          #-}
{-# LANGUAGE TypeOperators             #-}
{-# LANGUAGE QuasiQuotes               #-}
{-# LANGUAGE PartialTypeSignatures #-}
module Main where

import qualified Control.Foldl                as FL
import           Control.Monad.IO.Class (MonadIO (..))
import qualified Data.List                    as List
import           Data.Maybe                   (fromMaybe)
import qualified Data.Map                     as M
import qualified Data.Text                    as T
import qualified Data.Text.IO                 as T
import qualified Data.Text.Lazy               as TL
import qualified Data.Vector.Storable         as V
import qualified Data.Vinyl                   as V
import qualified Frames                       as F

import qualified Numeric.LinearAlgebra        as LA
import           Numeric.LinearAlgebra        (R, Matrix)

import qualified Frames.Regression            as FR
import qualified Frames.VegaLite               as FV

import qualified Text.Blaze.Html5              as H
import qualified Text.Blaze.Html5.Attributes   as HA
import           Text.Blaze.Html              ((!))
import qualified Text.Blaze.Html.Renderer.Text as BH

import qualified Statistics.Types             as S

import qualified Knit.Report                  as K
import qualified Knit.Report.Other.Blaze      as KB

{-
import qualified Polysemy                      as P
import qualified Knit.Effects.Logger           as Log
import qualified Knit.Effects.Pandoc           as PE
import qualified Knit.Effects.PandocMonad           as PM
import qualified Knit.Report.Blaze             as RB
import qualified Knit.Report.Pandoc           as PR
-}

import Data.String.Here

templateVars = M.fromList
  [
    ("lang", "English")
  , ("author", "Adam Conner-Sax")
  , ("pagetitle", "Frame Regression Examples")
--  , ("tufte","True")
  ]

regressionNotesMD
  = [here|
## Regression Algorithm Comparison
* To get data for testing we choose xs evenly spaced between -0.5 and 0.5.  Then we compute ys via $y=1 + 2.2x$.  Then we add Gaussian noise to the ys.  We can optionally add Gaussian noise to the observed xs as well (that is, the ys are still calculated from the exact xs but we add noise to the xs before we regress) and add weights to the (x,y) pairs.
* For unweighted data we use ordinary least squares (OLS) and total least square (TLS).
* For weighted data we use weighted least squares (WOLS) and weighted total least squares (WTLS).
* Both TLS and WTLS are computed via the Singular Value Decomposition.
* For each comparison we vary the level of noise on the ys and/or xs, regress, then show the results of each regression in tabular form, a plot of the fits and prediction intervals together with a scatter of the noisy data, and a plot of the coefficients and confidence intervals. The shaded regions in each plot are the "prediction intervals" which take into account the uncertainty of the coefficients as well as the remainining noise in the data.
* The F-stat is computed for each fit via comparision to the model of intercept-only.  So the p-value of the overall fit is the probability that the data are better explained as noise around their (weighted) mean value than by the fit.
|]

main :: IO ()
main = asPandoc

asPandoc :: IO ()
asPandoc = do
  let pandocWriterConfig = K.PandocWriterConfig (Just "pandoc-templates/minWithVega-pandoc.html")  templateVars K.mindocOptionsF
  htmlAsTextE <- K.knitHtml (Just "FrameRegressions.Main") K.logAll pandocWriterConfig $ do
    K.addMarkDown regressionNotesMD
    testMany
  case htmlAsTextE of
    Right htmlAsText -> T.writeFile "examples/html/FrameRegressions.html" $ TL.toStrict  $ htmlAsText
    Left err -> putStrLn $ "pandoc error: " ++ show err

{-
asBlaze :: IO ()
asBlaze = do
  let runAllP = FR.runPandocAndLoggingToIO Log.logAll . Log.wrapPrefix "Main" . blazeToText
  htmlAsTextE <- runAllP $ do
    regressionNotesBlaze <- P.markDownTextToBlazeFragment regressionNotesMD
    blaze $ H.makeReportHtml "Frame Regression Examples" $ do
      H.placeTextSection $ regressionNotesBlaze
    testMany
  case htmlAsTextE of
    Right htmlAsText -> T.writeFile "examples/html/FrameRegressions.html" $ TL.toStrict  $ htmlAsText
    Left err -> putStrLn $ "pandoc error: " ++ show err
-}

-- regression tests

-- build some data for testing
-- uniformly distributed measurements, normally distributed noise.  Separate noise amplitudes for xs and ys
-- also allow building heteroscedastic data

type Y = "y" F.:-> Double
type X = "x" F.:-> Double
--type X2 = "x2" F.:-> Double
type Weight = "weight" F.:-> Double

buildRegressable :: [Double] -> Maybe (LA.Vector R) -> Double -> LA.Vector R -> Double -> IO (LA.Vector R, LA.Matrix R)
buildRegressable variances offsetsM noiseObs coeffs noiseMeas = do
  -- generate random measurements
  let d = LA.size coeffs
      nObs = List.length variances
      xsO = LA.asColumn (LA.fromList (List.replicate nObs 1)) LA.<> LA.asRow (fromMaybe (LA.fromList $ List.replicate (d-1) 0) offsetsM)
--  xs0 <- LA.cmap (\x-> x - 0.5) <$> LA.rand nObs (d-1) -- 0 centered uniformly distributed random numbers
  let xs0 :: Matrix R = LA.asColumn $ LA.fromList $ [-0.5 + (realToFrac i/realToFrac nObs) | i <- [0..(nObs-1)]]
  xNoise <- LA.randn nObs (d-1) -- 0 centered normally (sigma=1) distributed random numbers
  let xsC = 1 LA.||| (xs0 + xsO)
      xsN = 1 LA.||| (xs0 + xsO + LA.scale noiseMeas xNoise)
  let ys0 = xsC LA.<> LA.asColumn coeffs
  yNoise <- fmap (List.head . LA.toColumns) (LA.randn nObs 1) -- 0 centered normally (sigma=1) distributed random numbers
  let ys = ys0 + LA.asColumn (LA.scale noiseObs (V.zipWith (*) yNoise (LA.cmap sqrt (LA.fromList variances))))
  return (List.head (LA.toColumns ys), xsN)

type AllCols = [Y,X,Weight]

makeFrame :: [Double] -> (LA.Vector R, LA.Matrix R) -> IO (F.FrameRec AllCols)
makeFrame vars (ys, xs) = do
  if snd (LA.size xs) /= 2 then error ("Matrix of xs wrong size (" ++ show (LA.size xs) ++ ") for makeFrame") else return ()
  let rows = LA.size ys
      rowIndex = [0..(rows - 1)]
      makeRecord :: Int -> F.Record AllCols
      makeRecord n = ys `LA.atIndex` n F.&: xs `LA.atIndex` (n,1) F.&: vars List.!! n F.&: V.RNil -- skip bias column
  return $ F.toFrame $ makeRecord <$> rowIndex

unweighted :: Int -> [Double]
unweighted n = List.replicate n (1.0)

coneWeighted :: Int -> Double -> Double -> [Double]
coneWeighted n base increment =
  let w0 = [base + (realToFrac i) * increment | i <- [1..n]]
      s = realToFrac n/FL.fold FL.sum w0
  in fmap (*s) w0

showText :: Show a => a -> T.Text
showText = T.pack . show

coeffs :: LA.Vector R = LA.fromList [1.0, 2.2]
offsets :: LA.Vector R = LA.fromList [1]
vars = coneWeighted 100 1 0.1
varListToWeights = LA.cmap (\x -> 1/sqrt x) . LA.fromList
wgts = varListToWeights vars

testRegressions :: ( F.ColumnHeaders '[w]
                   , FR.BoolVal (FR.NonVoidField w)
                   , V.KnownField w
                   , Traversable f
                   , Foldable f
                   , K.Member K.ToPandoc effs
                   , K.PandocEffects effs
                   , MonadIO (K.Sem effs))
                => Double
                -> Double
                -> Bool
                -> Bool
                -> T.Text
                -> f (T.Text, (F.FrameRec AllCols -> K.Sem effs (FR.FrameRegressionResult Y True '[X] w AllCols)))
                -> K.Sem effs ()
testRegressions  yNoise xNoise weighted offset vizId keyedFs = do
  let title = "Sy=" <> showText yNoise <> " gaussian noise added to ys & "
               <> "Sx=" <> showText xNoise <> " gaussian noise added to xs"
               <> " (" <> (if weighted then "cone weights" else "unweighted") <> (if offset then ", w/offsets" else "") <> ")"
      vars = if weighted then coneWeighted 100 1 0.1 else unweighted 100
      wgts = varListToWeights vars
      offsetM = if offset then (Just offsets) else Nothing
      doOne dat (key, f) = do
        result <- f dat
        return (key, result)
  frame <- liftIO (buildRegressable vars offsetM yNoise coeffs xNoise >>= makeFrame vars)
  results <- traverse (doOne frame) keyedFs
  let header _ _ = title
  K.addMarkDown $ "\n## " <> title
  K.addBlaze $ do
    H.div ! HA.style "display: block-inline" $ do
      FR.prettyPrintRegressionResults id results S.cl95 FR.prettyPrintRegressionResultBlaze mempty
      KB.placeVisualization (vizId <> "_fits") $ FV.keyedLayeredFrameScatterWithFit title id results S.cl95 frame
      KB.placeVisualization (vizId <> "_regresssionCoeffs") $ FV.regressionCoefficientPlotMany id "Parameters" ["intercept","x"] (fmap (\(k,frr) -> (k, FR.regressionResult frr)) results) S.cl95

-- I can't test the weighted and unweighted on the same things because those algos return different types in their results.  Which, maybe, is a good point.
testMany :: ( K.Member K.ToPandoc effs
            , K.PandocEffects effs
            , MonadIO (K.Sem effs)) =>  K.Sem effs ()
testMany = K.wrapPrefix "Many" $ do
  let toTestUW :: _ -- that this is required is suspicious
      toTestUW =
        [
          ("OLS", FR.ordinaryLeastSquares)
        , ("TLS", FR.totalLeastSquares)
        ]
      toTestW :: _ -- that this is required is suspicious
      toTestW =
        [
          ("WOLS", FR.weightedLeastSquares)
        , ("WTLS", FR.weightedTLS)
        ]
  testRegressions 0.0 0.0 False False "many1" toTestUW
  testRegressions 0.3 0.0 False False "many2" toTestUW
  testRegressions 0.5 0.0 False False "many3" toTestUW
  testRegressions 0.3 0.1 False False "many4" toTestUW
  testRegressions 3 0.0 False False "many9" toTestUW
  testRegressions @Weight 0.3 0.0 True False "many6" toTestW
  testRegressions @Weight 0.5 0.0 True False "many7" toTestW
  testRegressions @Weight 0.3 0.1 True False "many8" toTestW


{-# LANGUAGE AllowAmbiguousTypes                      #-}
{-# LANGUAGE DataKinds                                #-}
{-# LANGUAGE FlexibleContexts                         #-}
{-# LANGUAGE GADTs                                    #-}
{-# LANGUAGE PartialTypeSignatures                    #-}
{-# LANGUAGE ScopedTypeVariables                      #-}
{-# LANGUAGE TupleSections                            #-}
{-# LANGUAGE TypeApplications                         #-}
{-# LANGUAGE TypeOperators                            #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures     #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-}

import           Backprop.Learn
import           Control.DeepSeq
import           Control.Exception
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.State
import           Data.Char
import           Data.Conduit
import           Data.Default
import           Data.Foldable
import           Data.Proxy
import           Data.Time
import           Data.Type.Equality
import           Data.Type.Tuple
import           GHC.TypeNats
import           Numeric.LinearAlgebra.Static.Backprop
import           Numeric.LinearAlgebra.Static.Vector
import           Numeric.Opto
import           System.Environment
import           Text.Printf
import qualified Conduit                               as C
import qualified Data.Conduit.Combinators              as C
import qualified Data.Set                              as S
import qualified Data.Text                             as T
import qualified Data.Vector.Sized                     as SV
import qualified Data.Vector.Storable.Sized            as SVS
import qualified System.Random.MWC                     as MWC
import qualified System.Random.MWC.Distributions       as MWC

-- | TODO: replace with 'LModel'
charRNN
    :: forall n h1 h2. (KnownNat n, KnownNat h1, KnownNat h2)
    => LModel _ _ (R n) (R n)
charRNN = fca softMax
       #: dropout @h2 0.25
       #: lstm
       #: dropout @h1 0.25
       #: lstm
       #: nilLM

oneHotChar
    :: KnownNat n
    => S.Set Char
    -> Char
    -> R n
oneHotChar cs = oneHotR . fromIntegral . (`S.findIndex` cs)

main :: IO ()
main = MWC.withSystemRandom @IO $ \g -> do
    sourceFile:_  <- getArgs
    charMap <- S.fromList <$> readFile sourceFile
    SomeNat (Proxy :: Proxy n) <- pure $ someNatVal (fromIntegral (length charMap))
    SomeNat (Proxy :: Proxy n') <- pure $ someNatVal (fromIntegral (length charMap - 1))
    Just Refl <- pure $ sameNat (Proxy @(n' + 1)) (Proxy @n)

    printf "%d characters found.\n" (natVal (Proxy @n))

    let model0 = charRNN @n @100 @50
        model  = trainState . unrollFinal @(SV.Vector 15) $ model0

    p0 <- initParamNormal model 0.2 g

    let report n b = do
          liftIO $ printf "(Batch %d)\n" (b :: Int)
          t0 <- liftIO getCurrentTime
          C.drop (n - 1)
          mp <- mapM (liftIO . evaluate . force) =<< await
          t1 <- liftIO getCurrentTime
          case mp of
            Nothing -> liftIO $ putStrLn "Done!"
            Just p@(p' :# s') -> do
              chnk <- lift . state $ (,[])
              liftIO $ do
                printf "Trained on %d points in %s.\n"
                  (length chnk)
                  (show (t1 `diffUTCTime` t0))
                let trainScore = testModelAll maxIxTest model (TJust p) chnk
                printf "Training error:   %.3f%%\n" ((1 - trainScore) * 100)

                forM_ (take 15 chnk) $ \(x,y) -> do
                  let primed = primeModel model0 (TJust p') x (TJust s')
                  testOut <- fmap reverse . flip execStateT [] $
                      iterateModelM ( fmap (oneHotR . fromIntegral)
                                    . (>>= \r -> r <$ modify (r:))    -- trace
                                    . (`MWC.categorical` g)
                                    . SVS.fromSized
                                    . rVec
                                    )
                            100 model0 (TJust p') y primed
                  printf "%s|%s\n"
                    (sanitize . (`S.elemAt` charMap) . fromIntegral . maxIndexR <$> (toList x ++ [y]))
                    (sanitize . (`S.elemAt` charMap) <$> testOut)
              report n (b + 1)

    C.runResourceT . flip evalStateT []
        . runConduit
        $ forever ( C.sourceFile sourceFile
                 .| C.decodeUtf8
                 .| C.concatMap T.unpack
                 .| C.map (oneHotChar charMap)
                 .| leadings
                  )
       .| skipSampling 0.02 g
       .| C.iterM (modify . (:))
       .| optoConduit
            def
            p0
            (adam def (modelGradStoch crossEntropy noReg model g))
       .| report 2500 0
       .| C.sinkNull

sanitize :: Char -> Char
sanitize c | isPrint c = c
           | otherwise = '#'


{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TemplateHaskell #-}

import Frames
import Frames.CSV (rowGen, RowGen(..), readTableOpt)
import Pipes (Producer)
import qualified Data.Foldable as F
import qualified Numeric.LinearAlgebra.HMatrix as H

import Numeric.BMML.RVMC

tableTypes'
    rowGen
    { rowTypeName = "Iris"
    , columnNames = [ "sepal length"
                    , "sepal width"
                    , "petal length"
                    , "petal width"
                    , "iris name"]
    }
    "data/iris.csv"

irisStream :: Producer Iris IO ()
irisStream = readTableOpt irisParser "data/iris.csv"

loadIris :: IO (Frame Iris)
loadIris = inCoreAoS irisStream

restructureIris :: ( CanDelete IrisName rs
                   , rs' ~ RDelete IrisName rs
                   , AllAre Double (UnColumn rs')
                   , AsVinyl rs') => Record rs -> Record (IrisName ': rs')
restructureIris r = frameCons (rget' irisName' r) (rdel [pr|IrisName|] r)

splitXY :: (AllAre Double (UnColumn rs), AsVinyl rs)
        => Record (s :-> Text ': rs) -> (Text, [Double])
splitXY (recUncons -> (h, t)) = (h, recToList t)

loadDataSet :: IO ([Text], [[Double]])
loadDataSet =
    loadIris >>=
    \ds ->
         return $ unzip $ F.foldMap ((: []) . splitXY . restructureIris) ds

splitTrainTest :: [[Double]]
               -> [Text]
               -> (([[Double]], [Double]), ([[Double]], [Double]))
splitTrainTest x y =
    splitTT
        (takeN
             (foldr
                  (\(xi,yi) ((x1,y1),(x0,y0)) ->
                        if yi == "Iris-setosa"
                            then ((x1 ++ [xi], y1 ++ [1]), (x0, y0))
                            else ((x1, y1), (x0 ++ [xi], y0 ++ [0])))
                  (([], []), ([], []))
                  (zip x y)))
  where
    takeN ((x1,y1),(x0,y0)) = ((take n x1, take n y1), (take n x0, take n y0))
      where
        n = min (length y1) (length y0)
    splitTT ((x1,y1),(x0,y0)) = ((x1Train ++ x0Train, y1Train ++ y0Train), (x1Test ++ x0Test, y1Test ++ y0Test))
      where
        n = length y1
        m = floor (0.7 * fromIntegral n)
        (x1Train,x1Test) = splitAt m x1
        (y1Train,y1Test) = splitAt m y1
        (x0Train,x0Test) = splitAt m x0
        (y0Train,y0Test) = splitAt m y0

main :: IO ()
main = do
    (y,x) <- loadDataSet
    let ((xTrain,yTrain),(xTest,yTest)) = splitTrainTest x y
        c = fit (H.fromLists xTrain) (H.fromList yTrain)
    mapM_
        (\(x,y) ->
              print
                  ("Real: " ++
                   show y ++
                   "probability of class 1: " ++
                   show (predict c (H.fromList x))))
        (zip xTest yTest)


{-# LANGUAGE ConstraintKinds  #-}
{-# LANGUAGE FlexibleContexts #-}

module Poisson1D
where

import qualified Basis
import           Data.List
import           Element               as E
import           Mesh
import           Numeric.LinearAlgebra
import           Quadrature            (integrate)
import qualified ShapeFcns

-- Synonym for numeric/fractional constraints
type FrElNuFi a = (Fractional a,Element a,Numeric a,Field a)

-- Element stiffness integrand
stiffnessIntegrand :: (E.Element e,ShapeFcns.ShapeFcn s,Basis.Basis b,FrElNuFi a) => e a -> s b -> [a] -> Matrix a
stiffnessIntegrand elem shpFcn xi = fromLists [[]]

-- Element mass integrand
massIntegrand :: (E.Element e,ShapeFcns.ShapeFcn s,Basis.Basis b,FrElNuFi a) => e a -> s b -> [a] -> Matrix a
massIntegrand elem shpFcn xi = fromLists [[]]

-- Element mass and stiffness matrices
-- Must multiply by the determinant of the Jacobian here!!!
elemMatrices :: (E.Element e,ShapeFcns.ShapeFcn s,Basis.Basis b,FrElNuFi a) => e a -> s b -> Int -> (Matrix a,Matrix a)
elemMatrices elem shpFcn ngpts = (stiffnessMat, massMat)
  where
    stiffnessMat = integrate 1 ngpts (stiffnessIntegrand elem shpFcn)
    massMat      = integrate 1 ngpts (massIntegrand elem shpFcn)

assembleSubMatrix :: FrElNuFi a =>

-- Function which assembles the global stiffness and mass matrices
assembleGlobalMatrices :: (E.Element e, ShapeFcns.ShapeFcn s,Basis.Basis b, FrElNuFi a) => Mesh e a -> s b -> Int -> a -> [[((Int,Int),a)]]
assembleGlobalMatrices grid shpFcn ngpts advSpd = [globalK, globalM, globalF]
  where
    globalK = []
    globalM = []
    globalF = []

-- Function for applying boundary conditions
applyBCs _ = []


{- |
Module      :  Numeric.GSL.ODE
Copyright   :  (c) Alberto Ruiz 2010
License     :  GPL

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

Solution of ordinary differential equation (ODE) initial value problems.

<http://www.gnu.org/software/gsl/manual/html_node/Ordinary-Differential-Equations.html>

A simple example:

@import Numeric.GSL
import Numeric.LinearAlgebra
import Graphics.Plot

xdot t [x,v] = [v, -0.95*x - 0.1*v]

ts = linspace 100 (0,20 :: Double)

sol = odeSolve xdot [10,0] ts

main = mplot (ts : toColumns sol)@

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

module Numeric.GSL.ODE (
    odeSolve, odeSolveV, ODEMethod(..), Jacobian
) where

import Data.Packed.Internal
import Numeric.GSL.Internal

import Foreign.Ptr(FunPtr, nullFunPtr, freeHaskellFunPtr)
import Foreign.C.Types
import System.IO.Unsafe(unsafePerformIO)

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

type Jacobian = Double -> Vector Double -> Matrix Double

-- | Stepping functions
data ODEMethod = RK2 -- ^ Embedded Runge-Kutta (2, 3) method.
               | RK4 -- ^ 4th order (classical) Runge-Kutta. The error estimate is obtained by halving the step-size. For more efficient estimate of the error, use the embedded methods.
               | RKf45 -- ^ Embedded Runge-Kutta-Fehlberg (4, 5) method. This method is a good general-purpose integrator.
               | RKck -- ^ Embedded Runge-Kutta Cash-Karp (4, 5) method.
               | RK8pd -- ^ Embedded Runge-Kutta Prince-Dormand (8,9) method.
               | RK2imp Jacobian -- ^ Implicit 2nd order Runge-Kutta at Gaussian points.
               | RK4imp Jacobian -- ^ Implicit 4th order Runge-Kutta at Gaussian points.
               | BSimp Jacobian -- ^ Implicit Bulirsch-Stoer method of Bader and Deuflhard. The method is generally suitable for stiff problems.
               | RK1imp Jacobian -- ^ Implicit Gaussian first order Runge-Kutta. Also known as implicit Euler or backward Euler method. Error estimation is carried out by the step doubling method.
               | MSAdams -- ^ A variable-coefficient linear multistep Adams method in Nordsieck form. This stepper uses explicit Adams-Bashforth (predictor) and implicit Adams-Moulton (corrector) methods in P(EC)^m functional iteration mode. Method order varies dynamically between 1 and 12.
               | MSBDF Jacobian -- ^ A variable-coefficient linear multistep backward differentiation formula (BDF) method in Nordsieck form. This stepper uses the explicit BDF formula as predictor and implicit BDF formula as corrector. A modified Newton iteration method is used to solve the system of non-linear equations. Method order varies dynamically between 1 and 5. The method is generally suitable for stiff problems.

-- | A version of 'odeSolveV' with reasonable default parameters and system of equations defined using lists.
odeSolve
    :: (Double -> [Double] -> [Double])        -- ^ xdot(t,x)
    -> [Double]        -- ^ initial conditions
    -> Vector Double   -- ^ desired solution times
    -> Matrix Double   -- ^ solution
odeSolve xdot xi ts = odeSolveV RKf45 hi epsAbs epsRel (l2v xdot) (fromList xi) ts
    where hi = (ts@>1 - ts@>0)/100
          epsAbs = 1.49012e-08
          epsRel = 1.49012e-08
          l2v f = \t -> fromList  . f t . toList

-- | Evolution of the system with adaptive step-size control.
odeSolveV
    :: ODEMethod
    -> Double -- ^ initial step size
    -> Double -- ^ absolute tolerance for the state vector
    -> Double -- ^ relative tolerance for the state vector
    -> (Double -> Vector Double -> Vector Double)   -- ^ xdot(t,x)
    -> Vector Double     -- ^ initial conditions
    -> Vector Double     -- ^ desired solution times
    -> Matrix Double     -- ^ solution
odeSolveV RK2 = odeSolveV' 0 Nothing
odeSolveV RK4 = odeSolveV' 1 Nothing
odeSolveV RKf45 = odeSolveV' 2 Nothing
odeSolveV RKck = odeSolveV' 3 Nothing
odeSolveV RK8pd = odeSolveV' 4 Nothing
odeSolveV (RK2imp jac) = odeSolveV' 5 (Just jac)
odeSolveV (RK4imp jac) = odeSolveV' 6 (Just jac)
odeSolveV (BSimp jac) = odeSolveV' 7 (Just jac)
odeSolveV (RK1imp jac) = odeSolveV' 8 (Just jac)
odeSolveV MSAdams = odeSolveV' 9 Nothing
odeSolveV (MSBDF jac) = odeSolveV' 10 (Just jac)

odeSolveV'
    :: CInt
    -> Maybe (Double -> Vector Double -> Matrix Double)   -- ^ optional jacobian
    -> Double -- ^ initial step size
    -> Double -- ^ absolute tolerance for the state vector
    -> Double -- ^ relative tolerance for the state vector
    -> (Double -> Vector Double -> Vector Double)   -- ^ xdot(t,x)
    -> Vector Double     -- ^ initial conditions
    -> Vector Double     -- ^ desired solution times
    -> Matrix Double     -- ^ solution
odeSolveV' method mbjac h epsAbs epsRel f  xiv ts = unsafePerformIO $ do
    let n   = dim xiv
    fp <- mkDoubleVecVecfun (\t -> aux_vTov (checkdim1 n . f t))
    jp <- case mbjac of
        Just jac -> mkDoubleVecMatfun (\t -> aux_vTom (checkdim2 n . jac t))
        Nothing  -> return nullFunPtr
    sol <- vec xiv $ \xiv' ->
            vec (checkTimes ts) $ \ts' ->
             createMIO (dim ts) n
              (ode_c (method) h epsAbs epsRel fp jp // xiv' // ts' )
              "ode"
    freeHaskellFunPtr fp
    return sol

foreign import ccall safe "ode"
    ode_c :: CInt -> Double -> Double -> Double -> FunPtr (Double -> TVV) -> FunPtr (Double -> TVM) -> TVVM

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

checkdim1 n v
    | dim v == n = v
    | otherwise = error $ "Error: "++ show n
                        ++ " components expected in the result of the function supplied to odeSolve"

checkdim2 n m
    | rows m == n && cols m == n = m
    | otherwise = error $ "Error: "++ show n ++ "x" ++ show n
                        ++ " Jacobian expected in odeSolve"

checkTimes ts | dim ts > 1 && all (>0) (zipWith subtract ts' (tail ts')) = ts
              | otherwise = error "odeSolve requires increasing times"
    where ts' = toList ts


{-# LANGUAGE DeriveGeneric #-}

{-|
Module      : HABQTlib.Data

This module contains data types and helper functions for working with quantum
state vectors and density matrices.
-}
module HABQTlib.Data
  ( Dim
  , Rank
  , NumberOfParticles
  , QBitNum
  , Weight
  , MHMCiter
  , OptIter
  , OutputVerb(..)
  , DensityMatrix(..)
  , truncateRank
  , PureStateVector(..)
  , pureStateLikelihood
  , svToDM
  , WeighedDensityMatrix(..)
  , mkWDM
  , mkWDM1
  , WeighedPureStateVector(..)
  , (<+>)
  , fidelity
  , fidelityDM
  , validSV
  , validDM
  , validPartNum
  , validRank
  , validMHMCiter
  , validOptIter
  , validQBitN
  ) where

import Control.Newtype.Generics (Newtype, unpack)
import Data.Bool.HT (select)
import Data.Complex
import Data.Validation
import GHC.Generics (Generic)
import qualified Numeric.LinearAlgebra as LA
import Numeric.LinearAlgebra (Matrix)

-- | Dimension of Hilbert space.
type Dim = Int

-- | Rank of mixed state.
type Rank = Int

-- | Number of particles per rank.
type NumberOfParticles = Int

-- | Number of quantum bits.
type QBitNum = Int

-- | Number of MHMC iterations to perform when resampling.
type MHMCiter = Int

-- | Number of optimisation steps to perform when searching for optimal
-- measurment.
type OptIter = Int

-- | Weight associated with a particle.
type Weight = Double

-- | Output verbosity settings.
data OutputVerb
  = NoOutput -- ^ No stdout output
  | FidOutput -- ^ Only output fidelities and weights of hierarchical mean estimates
  | FullOutput -- ^ Full output, including resampling diagnostic information
  deriving (Eq, Show, Ord)

-- | Density matrix are stored as hmatrix matrices of complex doubles.
newtype DensityMatrix = DensityMatrix
  { getDensityMatrix :: Matrix (Complex Double)
  } deriving (Eq, Show, Generic)

-- | Pure state vectors are stored as hmatrix matrices of complex doubles.
-- Such matrices only have one column.
newtype PureStateVector = PureStateVector
  { getStateVector :: Matrix (Complex Double)
  } deriving (Eq, Show, Generic)

instance Newtype DensityMatrix

instance Newtype PureStateVector

-- | Check whether a pure state vector is properly normed.
validSV :: PureStateVector -> Validation [String] PureStateVector
validSV =
  validate
    ["State vector must have unit norm."]
    (\x -> abs (1 - LA.norm_2 (unpack x)) < 1e-12)

-- | Verify that density matrix is Hermitian and has trace 1.
validDM :: DensityMatrix -> Validation [String] DensityMatrix
validDM =
  let traceU :: LA.Matrix (Complex Double) -> Bool
      traceU dm =
        (abs (1 - (magnitude . LA.sumElements . LA.takeDiag) dm) < 1e-12)
      hermU dm = (LA.norm_2 (dm - LA.tr dm) < 1e-6)
      both = ((&&) <$> traceU <*> hermU) . unpack
      dmM = ["Density matrix must be Hermitian and have trace of 1."]
   in validate dmM both

qnM :: [String]
qnM = ["Number of quantum bits must be a positive integer."]

-- | Verify that number of quantum bits is positive.
validQBitN :: QBitNum -> Validation [String] QBitNum
validQBitN = validate qnM (> 0)

miM :: [String]
miM = ["Number of MHMC iterations must be a positive integer."]

-- | Verify that number of MHMC iterations is a positive integer.
validMHMCiter :: MHMCiter -> Validation [String] MHMCiter
validMHMCiter = validate miM (> 0)

pnM :: [String]
pnM = ["Number of particles per rank must be a positive integer."]

-- | Verify that particle number is a positive integer.
validPartNum :: NumberOfParticles -> Validation [String] NumberOfParticles
validPartNum = validate pnM (> 0)

rM :: [String]
rM = ["Rank must be a positive integer."]

-- | Verify that rank is a positive integer. Setting rank to be higher than
-- the dimension of space creates poinless performance overhead, but isn't
-- prevented by validation.
validRank :: Rank -> Validation [String] Rank
validRank = validate rM (> 0)

oiM :: [String]
oiM = ["Number of POVM optimisation iterations must be a positive integer."]

-- | Verify that number of POVM optimisation iterations is positive.
validOptIter :: OptIter -> Validation [String] OptIter
validOptIter = validate oiM (> 0)

-- | Weighed density matrix where weight is stored separately as first
-- coordinate of a tuple.
newtype WeighedDensityMatrix = WeighedDensityMatrix
  { getWDM :: (Weight, DensityMatrix)
  } deriving (Eq, Show, Generic)

-- | A shorter alias for curried 'WeighedDensityMatrix' constructor.
mkWDM :: Weight -> DensityMatrix -> WeighedDensityMatrix
mkWDM w dm = WeighedDensityMatrix (w, dm)

-- | Alias for @'mkWDM' 1@.
mkWDM1 :: DensityMatrix -> WeighedDensityMatrix
mkWDM1 = mkWDM 1

-- | Weighed state vector where weight is stored separately as first coordinate
-- of a tuple.
newtype WeighedPureStateVector = WeighedPureStateVector
  { getWSV :: (Weight, PureStateVector)
  } deriving (Eq, Show, Generic)

instance Newtype WeighedDensityMatrix

instance Newtype WeighedPureStateVector

-- | Fidelity (probability of measurement) between pure states.
fidelity :: PureStateVector -> PureStateVector -> Double
fidelity (PureStateVector sv1) (PureStateVector sv2) =
  let ips = magnitude (LA.atIndex (LA.tr sv1 LA.<> sv2) (0, 0)) ^ (2 :: Int)
   in select ips [(ips < 0, 0), (ips > 1, 1)]

-- | Fidelity (probability of measurement) between mixed states.
fidelityDM :: DensityMatrix -> DensityMatrix -> Double
fidelityDM (DensityMatrix dm1) (DensityMatrix dm2) =
  let (u1, s1) = LA.leftSV dm1
      (u2, s2) = LA.leftSV dm2
      ss1 = LA.cmap (\x -> sqrt x :+ 0) s1
      ss2 = LA.cmap (\x -> sqrt x :+ 0) s2
   in LA.norm_nuclear
        (u1 LA.<> LA.diag ss1 LA.<> LA.tr u1 LA.<> u2 LA.<> LA.diag ss2 LA.<>
         LA.tr u2) ^
      (2 :: Int)

-- | Calculate the density matrix of a given pure state.
svToDM :: PureStateVector -> DensityMatrix
svToDM (PureStateVector sv) = DensityMatrix $ sv LA.<> LA.tr sv

infix 8 <+>

-- | Given two weighed density matrixes, compute their mixture. Associative
-- operation.
(<+>) :: WeighedDensityMatrix -> WeighedDensityMatrix -> WeighedDensityMatrix
wdm0 <+> wdm1 =
  WeighedDensityMatrix
    (w0 + w1, DensityMatrix $ LA.scale c0 dm0 + LA.scale c1 dm1)
  where
    up = fmap unpack . unpack
    (w0, dm0) = up wdm0
    (w1, dm1) = up wdm1
    cs = LA.fromList [w0 :+ 0, w1 :+ 0]
    csn = LA.scale (1 / LA.sumElements cs) cs
    c0 = csn LA.! 0
    c1 = csn LA.! 1

-- | Probability of obtaining a measurement result when projecting a system in
-- mixed state determined by a density matrix onto a pure state.
pureStateLikelihood :: PureStateVector -> DensityMatrix -> Double
pureStateLikelihood (PureStateVector sv) (DensityMatrix dm) =
  let p =
        LA.magnitude . LA.sumElements . LA.takeDiag $ LA.tr sv LA.<> dm LA.<> sv
   in select p [(p < 0, 0), (p > 1, 1)]

-- | Set smallest eigenvalues of a weighed density matrix to zero until
-- specified rank is reached.
truncateRank :: Rank -> WeighedDensityMatrix -> WeighedDensityMatrix
truncateRank targetRank (WeighedDensityMatrix (w, DensityMatrix dm)) =
  let (u, s, _) = LA.svd dm
      st = LA.real $ LA.subVector 0 targetRank s
      ut = u LA.¿ [0 .. (targetRank - 1)]
      stn = LA.scale (1 / LA.sumElements st) st
   in WeighedDensityMatrix
        (w, DensityMatrix $ ut LA.<> LA.diag stn LA.<> LA.tr ut)


{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE TemplateHaskell        #-}

module DBPnet.ReadCount
    ( readCount
    , ReadCountOpt
    , binSize
    , pValue
    , chromSize
    , varFilter
    ) where

import           Bio.Data.Bed
import Bio.Data.Bed.Utils
import           Bio.Utils.Misc                    (readDouble, readInt)
import           Conduit
import Lens.Micro ((.~), (^.))
import Lens.Micro.TH (makeFields)
import           Control.Monad                     (forM, forM_)
import           Control.Monad.Base                (liftBase)
import           Control.Monad.Morph               (hoist)
import qualified Data.ByteString.Char8             as B
import qualified Data.Conduit.Zlib                 as Zlib
import           Data.Default
import           Data.Double.Conversion.ByteString (toFixed)
import           Data.Int                          (Int32)
import           Data.List
import qualified Data.Matrix.Unboxed               as MU
import qualified Data.Text                         as T
import qualified Data.Vector.Unboxed               as U
import           Shelly                            hiding (FilePath, withTmpDir)
import           Statistics.Distribution           (complCumulative)
import           Statistics.Distribution.Poisson   (poisson)
import           Statistics.Sample
import           System.IO

import           DBPnet.Type
import           DBPnet.Utils

data ReadCountOpt = ReadCountOpt
    { readCountOptBinSize   :: !Int
    , readCountOptPValue    :: !Double
    , readCountOptChromSize :: ![(B.ByteString, Int)]
    , readCountOptVarFilter :: !Double   -- ^ remove constant signal
    } deriving (Show, Read)

makeFields ''ReadCountOpt

instance Default ReadCountOpt where
    def = ReadCountOpt
        { readCountOptBinSize = 1000
        , readCountOptPValue = 1e-2
        , readCountOptChromSize = []
        , readCountOptVarFilter  = 0.1
        }

readCount :: [Experiment] -> FilePath -> ReadCountOpt -> IO [(String, FilePath)]
readCount es outDir opt = withTmpDir outDir $ \tmp -> do
    -- count reads for each experiment
    rs <- forM es $ \e -> do
        let fls = e^.files
            targetName = e^.eid
            output = tmp ++ "/" ++ targetName
        shelly $ mkdir_p $ fromText $ T.pack output
        rc fls output
        return (targetName, output)

    combineAndFilter rs outDir
  where
    rc inputs output = do
        readcounts <- forM inputs $ \input -> do
            let fl = input^.location
                fileFormat = input^.format
            case fileFormat of
                Bed -> runResourceT $ runConduit $ streamBed fl .| countTagsBinBed (opt^.binSize) regions
                BedGZip -> runResourceT $ runConduit $ streamBedGzip fl .| countTagsBinBed (opt^.binSize) regions
                _ -> undefined

        forM_ (zip (opt^.chromSize) $ merge readcounts) $ \((chr,_), v) -> do
            let outFile = output ++ "/" ++ B.unpack chr
                l = U.length v
                bg_glob = estimateBG v
            withFile outFile WriteMode $ \handle ->
                forM_ [0..l-1] $ \i -> do
                    let getBG x = let len = x `div` 2
                                      vec = U.map (v U.!) $ U.fromList $
                                            filter (\x -> x >= 0 && x < l) $
                                            [i-len..i-1] ++ [i+1,i+len]
                                  in estimateBG vec
                        bg_local = maximum $ bg_glob : map getBG [14, 24]
                        c = v U.! i
                    case () of
                        _ | c == 0 -> B.hPutStrLn handle "0"
                          | complCumulative (poisson bg_local) c <= (opt^.pValue) ->
                                B.hPutStrLn handle $ toFixed 4 $ c / bg_local
                          | otherwise -> B.hPutStrLn handle "0"
      where
        regions = map (\(chr,s) -> BED3 chr 0 s) $ opt^.chromSize
        estimateBG xs = let (m, var) = meanVarianceUnb xs
                        in mean $ U.filter (< (m + 2 * sqrt var)) xs
        merge rs = map f $ transpose counts
          where
            f = foldl1' (\acc x -> U.zipWith (+) acc x)
            counts = flip map rs $ \(values, _) ->
                     map (U.map (fromIntegral :: Int32 -> Double)) values
-- we do not need to normalize or average because we don't use input/control
--            n = fromIntegral $ length rs

    combineAndFilter xs output = do
        shelly $ mkdir_p $ fromText $ T.pack output
        let (ids, dirs)  = unzip xs

        dat <- forM (opt^.chromSize) $ \(chr', _) -> do
            let chr = B.unpack chr'
            rs <- forM dirs $ \dir -> do
                c <- B.readFile $ dir ++ "/" ++ chr
                return $ U.fromList $ map readDouble $ B.lines c
            let (idx, rc) = unzip $ filter (highCV . snd) $
                            zip [0, opt^.binSize ..] $
                            MU.toRows $ MU.fromColumns rs
            return (zip (repeat chr') idx, rc)

        let idx = concat $ fst $ unzip dat
            dat' = MU.fromColumns $ concat $ snd $ unzip dat
        forM (zip ids $ MU.toRows dat') $ \(i, v) -> do
            let outFile = output ++ "/" ++ i ++ ".bed"
            writeBed outFile $ zipWith toBed idx $ U.toList v
            return (i, outFile)
      where
        highCV v = let (_,var) = meanVarianceUnb v in sqrt var >= opt^.varFilter
        toBed (chr,i) x = BEDGraph chr i (i+(opt^.binSize)) x


module Seed
  ( Seed
  , createSeed
  , arrowsAt
  , drawSeed
  )
where

import           Arrow                          ( Arrow
                                                , arrange
                                                , endpoint
                                                , updateArrow
                                                )
import qualified Fourier
import           Data.Complex
import           Graphics.Gloss

-- A seed represents an initial state of arrow frequencies, directions, and magnitudes
-- Any complex function can be traced out by changing this initial state.
-- It also contains some drawing and scaling information.
data Seed = Seed { _arrows :: [(Arrow, Integer)], _spaceScale :: Float, _timeScale :: Float, _trailLength :: Float }

createSeed :: (Float -> Complex Float) -> Int -> Float -> Float -> Float -> Seed
createSeed f n spaceScale timeScale trailLength = Seed
  { _arrows      = arrows
  , _spaceScale  = spaceScale
  , _timeScale   = timeScale
  -- measure trail length by percentage of a time-scaled second
  , _trailLength = trailLength
  }
 where
  -- order arrow frequencies 0, 1, -1, 2, -2, 3, -3, etc.
  freqs             = take n (0 : concat [ [x, -x] | x <- [1 ..] ])
  startingPositions = map (Fourier.coefficient f) freqs
  arrows            = zip startingPositions freqs

arrowsAt :: Seed -> Float -> [Arrow]
arrowsAt seed t = map (\(arr, freq) -> updateArrow arr freq t) (_arrows seed)

drawSeed :: Seed -> Float -> Picture
drawSeed seed seconds = scale s s $ Pictures [vectors, tip, trail]
 where
  s         = _spaceScale seed
  t         = _timeScale seed * seconds
  positions = arrange $ arrowsAt seed t
  (x, y)    = last positions
  -- draw stuff
  vectors   = color (light aquamarine) . line $ positions
  tip       = color red . translate x y $ circleSolid (5 / _spaceScale seed)
  trail     = color white . line $ map (endpoint . arrowsAt seed) ts
  -- the trail draws through points with a step size of 1/1000 of a (time-scaled) second
  tf        = truncateTo 3 t
  ti        = max 0 (tf - _trailLength seed)
  ts        = [ti, ti + 0.001 .. t]

-- truncate a real number to the given number of decimal places
truncateTo :: (RealFrac a) => Integer -> a -> a
truncateTo n = (/ 10 ^ n) . fromIntegral . truncate . (* 10 ^ n)


module PatternRecogn.Lina(
	Matrix, Vector,
	MatrixOf, VectorOf,
	module Lina
) where

import Numeric.LinearAlgebra as Lina hiding( Matrix, Vector )
import qualified Numeric.LinearAlgebra as LinaIntern

type Matrix = LinaIntern.Matrix Double
type Vector = LinaIntern.Vector Double

type MatrixOf = LinaIntern.Matrix
type VectorOf = LinaIntern.Vector


-- | Internal utilities.

module Math.Probably.Utils where

import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Vector.Storable as V
import Math.Probably.Types
import Numeric.LinearAlgebra
import Statistics.Distribution
import Statistics.Distribution.Normal

lookupDefault  :: Ord k => a -> k -> Map k a -> a
lookupDefault d k m = fromMaybe d (Map.lookup k m)

-- | A spherical Gaussian distribution.
sphereGauss :: ContinuousParams -> ContinuousParams -> Double -> Double
sphereGauss xs m sd = product $ zipWith density normalDists xsAsList where
  xsAsList    = toList xs
  meanAsList  = toList m
  normalDists = map (`normalDistr` sd) meanAsList

-- | Scalar-vector multiplication.
(.*) :: Double -> ContinuousParams -> ContinuousParams
z .* xs = mapVector (* z) xs

-- | Scalar-vector subtraction.
(.-) :: ContinuousParams -> ContinuousParams -> ContinuousParams
xs .- ys = zipVectorWith (-) xs ys

-- | Scalar-vector addition.
(.+) :: ContinuousParams -> ContinuousParams -> ContinuousParams
xs .+ ys = zipVectorWith (+) xs ys

-- | The leapfrog integrator.
leapfrog :: Gradient -> Particle -> Double -> Particle
leapfrog glTarget (q, r) e = (qf, rf) where
  rm = adjustMomentum glTarget e (q, r)
  qf = adjustPosition e (rm, q)
  rf = adjustMomentum glTarget e (qf, rm)

-- | Adjust momentum according to a half-leapfrog step.
adjustMomentum :: Gradient -> Double -> Particle -> ContinuousParams
adjustMomentum glTarget e (t, r) = r .+ ((e / 2) .* glTarget t)

-- | Adjust position according to a half-leapfrog step.
adjustPosition :: Double -> Particle -> ContinuousParams
adjustPosition e (r, t) = t .+ (e .* r)

-- | A target augmented by momentum auxilliary variables.
auxilliaryTarget :: (ContinuousParams -> Double) -> Particle -> Double
auxilliaryTarget lTarget (t, r) =
  lTarget t - 0.5 * innerProduct r r

innerProduct :: ContinuousParams -> ContinuousParams -> Double
innerProduct xs ys = V.sum $ V.zipWith (*) xs ys

indicate :: Integral a => Bool -> a
indicate True  = 1
indicate False = 0

fi :: (Integral a, Num b) => a -> b
fi = fromIntegral


{-# LANGUAGE FlexibleContexts #-}
module Legacy.QuantumCircuit where

import Data.Complex
import Data.Either
import Data.List
import Data.Function
import System.Random
import Control.Monad.IO.Class

import Helper

import Tensor

-- applyGate :: (QuantumRegister q Num RealFloat, RealFloat a) => q (Complex a) -- ^ Gate tensor
--   -> Int -- ^ Index
--   -> q (Complex a) -- ^ State vector
--   -> Either String (q (Complex a))
-- applyGate x i y
--     | not (isSquare x) = Left "Invalid Gate Tensor"
--     | not (isSquare y) = Left "Invalid Statevector"
--     | i < 0 || i >= rank y = Left "Index out of bounds"
--     | otherwise = Right $ norm $ build (rank y) [(i, x)] pauliId * y

-- applyGateAll :: (QuantumRegister q Num RealFloat, RealFloat a) => q (Complex a) -> q (Complex a) -> Either String (q (Complex a))
-- applyGateAll x y
--     | not (isSquare x) = Left "Invalid Gate Tensor"
--     | not (isSquare y) = Left "Invalid Statevector"
--     | otherwise = Right $ norm $ build (rank y) [] x * y

-- applyControl :: (QuantumRegister q, RealFloat a) => q (Complex a) -- ^ Gate tensor
--   -> Int -- ^ Control qubit index
--   -> Int -- ^ Apply qubit index
--   -> q (Complex a) -- ^ State vector
--   -> Either String (q (Complex a))
-- applyControl x ctl i y
--     | not (isSquare x) = Left "Invalid gate tensor"
--     | not (isSquare y) = Left "Invalid state vector"
--     | i < 0 || i >= rank y = Left "Application qubit index out of bounds"
--     | ctl < 0 || ctl >= rank y = Left "Control qubit index out of bounds"
--     | ctl == i = Left "Control and application qubit cannot be the same"
--     | otherwise = Right $ norm $ (build (rank y) [(ctl, mask0)] pauliId
--         + build (rank y) (sortBy (compare `on` fst) [(ctl, mask1), (i, x)]) pauliId) * y

-- collapse :: (RealFloat a, QuantumRegister q) => Int -- ^ Index of the qubit
--         -> Bool -- ^ Collapsed State
--         -> q (Complex a) -- ^ Qubits to collapse
--         -> Either String (q (Complex a)) -- ^ Resulting Tensor
-- collapse i state q
--     | i < 0 || i >= rank q = Left "Index out of bounds"
--     | not (isSquare q) = Left "Invalid state vector"
--     | state = norm <$> applyGate mask1 i q
--     | otherwise = norm <$> applyGate mask0 i q

-- measure i v = do
--     a <- randomRIO (0.0, 1.0)
--     if a < fst p then
--         return $ fmap (\x -> (False, x)) (collapse i False =<< v)
--     else
--         return $ fmap (\x -> (True, x)) (collapse i True =<< v)
--     where
--         prob = getProb i =<< v
--         p = fromRight (0.0, 0.0) prob


{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
-- |
-- Module    : Statistics.Distribution.Gamma
-- Copyright : (c) 2009, 2011 Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- The gamma distribution.  This is a continuous probability
-- distribution with two parameters, /k/ and ϑ. If /k/ is
-- integral, the distribution represents the sum of /k/ independent
-- exponentially distributed random variables, each of which has a
-- mean of ϑ.

module Statistics.Distribution.Gamma
    (
      GammaDistribution
    -- * Constructors
    , gammaDistr
    , improperGammaDistr
    -- * Accessors
    , gdShape
    , gdScale
    ) where

import Data.Aeson (FromJSON, ToJSON)
import Control.Applicative ((<$>), (<*>))
import Data.Binary (Binary)
import Data.Binary (put, get)
import Data.Data (Data, Typeable)
import GHC.Generics (Generic)
import Numeric.MathFunctions.Constants (m_pos_inf, m_NaN, m_neg_inf)
import Numeric.SpecFunctions (incompleteGamma, invIncompleteGamma, logGamma, digamma)
import Statistics.Distribution.Poisson.Internal as Poisson
import qualified Statistics.Distribution as D
import qualified System.Random.MWC.Distributions as MWC

-- | The gamma distribution.
data GammaDistribution = GD {
      gdShape :: {-# UNPACK #-} !Double -- ^ Shape parameter, /k/.
    , gdScale :: {-# UNPACK #-} !Double -- ^ Scale parameter, ϑ.
    } deriving (Eq, Read, Show, Typeable, Data, Generic)

instance FromJSON GammaDistribution
instance ToJSON GammaDistribution

instance Binary GammaDistribution where
    put (GD x y) = put x >> put y
    get = GD <$> get <*> get

-- | Create gamma distribution. Both shape and scale parameters must
-- be positive.
gammaDistr :: Double            -- ^ Shape parameter. /k/
           -> Double            -- ^ Scale parameter, ϑ.
           -> GammaDistribution
gammaDistr k theta
  | k     <= 0 = error $ msg ++ "shape must be positive. Got " ++ show k
  | theta <= 0 = error $ msg ++ "scale must be positive. Got " ++ show theta
  | otherwise  = improperGammaDistr k theta
    where msg = "Statistics.Distribution.Gamma.gammaDistr: "

-- | Create gamma distribution. This constructor do not check whether
--   parameters are valid
improperGammaDistr :: Double            -- ^ Shape parameter. /k/
                   -> Double            -- ^ Scale parameter, ϑ.
                   -> GammaDistribution
improperGammaDistr = GD

instance D.Distribution GammaDistribution where
    cumulative = cumulative

instance D.ContDistr GammaDistribution where
    density    = density
    logDensity (GD k theta) x
      | x <= 0    = m_neg_inf
      | otherwise = log x * (k - 1) - (x / theta) - logGamma k - log theta * k
    quantile   = quantile

instance D.Variance GammaDistribution where
    variance (GD a l) = a * l * l

instance D.Mean GammaDistribution where
    mean (GD a l) = a * l

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

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

instance D.MaybeEntropy GammaDistribution where
  maybeEntropy (GD a l)
    | a > 0 && l > 0 =
      Just $
      a
      + log l
      + logGamma a
      + (1-a) * digamma a
    | otherwise = Nothing

instance D.ContGen GammaDistribution where
    genContVar (GD a l) = MWC.gamma a l

density :: GammaDistribution -> Double -> Double
density (GD a l) x
  | a < 0 || l <= 0   = m_NaN
  | x <= 0            = 0
  | a == 0            = if x == 0 then m_pos_inf else 0
  | x == 0            = if a < 1 then m_pos_inf else if a > 1 then 0 else 1/l
  | a < 1             = Poisson.probability (x/l) a * a / x
  | otherwise         = Poisson.probability (x/l) (a-1) / l

cumulative :: GammaDistribution -> Double -> Double
cumulative (GD k l) x
  | x <= 0    = 0
  | otherwise = incompleteGamma k (x/l)

quantile :: GammaDistribution -> Double -> Double
quantile (GD k l) p
  | p == 0         = 0
  | p == 1         = 1/0
  | p > 0 && p < 1 = l * invIncompleteGamma k p
  | otherwise      =
    error $ "Statistics.Distribution.Gamma.quantile: p must be in [0,1] range. Got: "++show p


{-# LANGUAGE NoImplicitPrelude #-}
module LinearRegression1 where

import Protolude
import Data.Vector as V
import Numeric.LinearAlgebra as H


-- {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds, GADTs, TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}

module HBLAS.BLAS.Level3Spec(main, spec) where

import Data.Complex

import Numerical.HBLAS.MatrixTypes as Matrix
import Numerical.HBLAS.BLAS.Level3 as BLAS

import Test.Hspec

main :: IO ()
main = hspec spec

spec :: Spec
spec = do
  gemmSpec
  hemmSpec
  herkSpec
  her2kSpec
  symmSpec
  syrkSpec
  syr2kSpec
  trmmSpec
  trsmSpec

gemmSpec :: Spec
gemmSpec =
  context "?GEMM" $ do
    describe "SGEMM" $ do
      it "2x2 all 1's" $ do
        matmatTest1SGEMM
    describe "DGEMM" $ do
      it "2x2 all 1's" $ do
        matmatTest1DGEMM Matrix.SRow
      it "3x2 and 5x3 all 1's" $ do
        matmatTest2DGEMM Matrix.SRow
      it "2x3^T and 5x3 all 1's" $ do
        matmatTest3DGEMM Matrix.SRow
      it "2x3 and 2x3^T all 1's" $ do
        matmatTest3aDGEMM Matrix.SRow
      it "3x2 and 3x5^T all 1's" $ do
        matmatTest4DGEMM Matrix.SRow
      it "2x3^T and 3x5^T all 1's" $ do
        matmatTest5DGEMM Matrix.SRow
      it "3x2^T and 3x2 all 1's" $ do
        matmatTest6DGEMM Matrix.SRow
      it "2x64^T and 2x64 all 1's" $ do
        matmatTest7DGEMM Matrix.SRow
      it "2x9^T and 2x9 all 1's" $ do
        matmatTest8DGEMM Matrix.SRow
      it "2x2 all 1's (column oriented)" $ do
        matmatTest1DGEMM Matrix.SColumn
      it "3x2 and 5x3 all 1's (column oriented)" $ do
        matmatTest2DGEMM Matrix.SColumn
      it "2x3^T and 5x3 all 1's (column oriented)" $ do
        matmatTest3DGEMM Matrix.SColumn
      it "2x3 and 2x3^T all 1's (column oriented)" $ do
        matmatTest3aDGEMM Matrix.SColumn
      it "3x2 and 3x5^T all 1's (column oriented)" $ do
        matmatTest4DGEMM Matrix.SColumn
      it "2x3^T and 3x5^T all 1's (column oriented)" $ do
        matmatTest5DGEMM Matrix.SColumn
      it "3x2^T and 3x2 all 1's (column oriented)" $ do
        matmatTest6DGEMM Matrix.SColumn
      it "2x64^T and 2x64 all 1's (column oriented)" $ do
        matmatTest7DGEMM Matrix.SColumn
      it "2x9^T and 2x9 all 1's (column oriented)" $ do
        matmatTest8DGEMM Matrix.SColumn
    describe "CGEMM" $ do
      it "2x2 all 1's " $ do
        matmatTest1CGEMM
    describe "ZGEMM" $ do
      it "2x2 all 1's " $ do
        matmatTest1ZGEMM

matmatTest1SGEMM:: IO ()
matmatTest1SGEMM = do
    left  <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const (1.0 :: Float))
    right <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const (1.0 :: Float))
    res   <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const (0.0 :: Float))
    BLAS.sgemm Matrix.NoTranspose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList `shouldBe` [2,2,2,2]

matmatTest1DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest1DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (2,2) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (2,2) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (2,2) (const 0.0)
    BLAS.dgemm Matrix.NoTranspose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList `shouldBe` [2.0,2.0,2.0,2.0]

matmatTest2DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest2DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (3,2) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (5,3) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (5,2) (const 0.0)
    BLAS.dgemm Matrix.NoTranspose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList `shouldBe` replicate 10 3

matmatTest3DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest3DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (2,3) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (5,3) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (5,2) (const 0.0)
    BLAS.dgemm Matrix.Transpose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList `shouldBe` replicate 10 3

matmatTest3aDGEMM :: Matrix.SOrientation x -> IO ()
matmatTest3aDGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (2,3) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (2,3) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (3,3) (const 0.0)
    BLAS.dgemm Matrix.NoTranspose Matrix.Transpose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList `shouldBe` replicate 9 2

matmatTest4DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest4DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (3,2) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (3,5) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (5,2) (const 0.0)
    BLAS.dgemm Matrix.NoTranspose Matrix.Transpose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList `shouldBe` replicate 10 3

matmatTest5DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest5DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or  (2,3) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or  (3,5) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or  (5,2) (const 0.0)
    BLAS.dgemm Matrix.Transpose Matrix.Transpose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList `shouldBe` replicate 10 3

matmatTest6DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest6DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (3,2) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (3,2) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (3,3) (const 0.0)
    BLAS.dgemm Matrix.Transpose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList `shouldBe` replicate 9 2

matmatTest7DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest7DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (2,64) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (2,64) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (2,2) (const 0.0)
    BLAS.dgemm Matrix.Transpose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList `shouldBe` replicate 4 64

matmatTest8DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest8DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (2,9) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (2,9) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (2,2) (const 0.0)
    BLAS.dgemm Matrix.Transpose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList `shouldBe` replicate 4 9

matmatTest1CGEMM:: IO ()
matmatTest1CGEMM = do
    left  <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 0.0)
    BLAS.cgemm Matrix.NoTranspose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList `shouldBe` [2.0,2.0,2.0,2.0]

matmatTest1ZGEMM:: IO ()
matmatTest1ZGEMM = do
    left  <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 0.0)
    BLAS.zgemm Matrix.NoTranspose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList `shouldBe` [2.0,2.0,2.0,2.0]

hemmSpec :: Spec
hemmSpec =
  context "?HEMM" $ do
    describe "CHEMM" $ do
      it "3x3 and 2x3 with leftside upper (row oriented)" $ do
        matmatTest1CHEMM
    describe "ZHEMM" $ do
      it "3x3 and 3x2 with rightside lower (column oriented)" $ do
        matmatTest1ZHEMM

-- [1:+0    1:+1    1:+1]   [1 1]   [3:+2    3:+2   ]
-- [1:+(-1) 1:+0    2:+2] * [1 1] = [4:+1    4:+1   ]
-- [1:+(-1) 2:+(-2) 1:+0]   [1 1]   [4:+(-3) 4:+(-3)]
matmatTest1CHEMM :: IO ()
matmatTest1CHEMM = do
    left  <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (3,3) (\(x, y) -> [1:+0, 1:+1, 1:+1, 0:+0, 1:+0, 2:+2, 0:+0, 0:+0, 1:+0] !! (x + y * 3))
    right <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (2,3) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (2,3) (const 0.0)
    BLAS.chemm Matrix.LeftSide Matrix.MatUpper 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList `shouldBe` [3:+2, 3:+2, 4:+1, 4:+1, 4:+(-3), 4:+(-3)]

-- [1 1 1]   [1:+0 1:+(-1) 1:+(-1)]    [3:+2 4:+1 4:+(-3)]
-- [1 1 1] * [1:+1 1:+0    2:+(-2)]  = [3:+2 4:+1 4:+(-3)]
--           [1:+1 2:+2    1:+0   ]
matmatTest1ZHEMM :: IO ()
matmatTest1ZHEMM = do
    left  <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3,3) (\(x, y) -> [1:+0, 0:+0, 0:+0, 1:+1, 1:+0, 0:+0, 1:+1, 2:+2, 1:+0] !! (x + y * 3))
    right <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3,2) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3,2) (const 0.0)
    BLAS.zhemm Matrix.RightSide Matrix.MatLower 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList `shouldBe` [3:+2, 3:+2, 4:+1, 4:+1, 4:+(-3), 4:+(-3)]

herkSpec :: Spec
herkSpec = do
  context "?HERK" $ do
    describe "CHERK" $ do
      it "3x3 and 2x3 with upper no transpose (row oriented)" $ do
        matmatTest1CHERK
    describe "ZHERK" $ do
      it "3x3 and 3x2 with lower conjtranspose (column oriented)" $ do
        matmatTest1ZHERK

-- [1 2]   [1 3 5]   [1:+0    1:+1    1:+1]   [6:+0 12:+1 18:+1]
-- [3 4] * [2 4 6] + [1:+(-1) 1:+0    2:+2] = [0:+0 26:+0 41:+2]
-- [5 6]             [1:+(-1) 2:+(-2) 1:+0]   [0:+0 0:+0  62:+0]
matmatTest1CHERK :: IO ()
matmatTest1CHERK = do
    a <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (2,3) (\(x, y) -> [1, 2, 3, 4, 5, 6] !! (x + y * 2))
    c <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (3,3) (\(x, y) -> [1:+0, 1:+1, 1:+1, 0:+0, 1:+0, 2:+2, 0:+0, 0:+0, 1:+0] !! (x + y * 3))
    BLAS.cherk Matrix.MatUpper Matrix.NoTranspose 1.0 1.0 a c
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat c
    resList `shouldBe` [6:+0, 12:+1, 18:+1, 0:+0, 26:+0, 41:+2, 0:+0, 0:+0, 62:+0]

-- [1:-1 2]   [1:+1 3 5]   [1:+0 1:+(-1) 1:+(-1)]   [7:+0  0:+0  0:+0]
-- [3    4] * [2    4 6] + [1:+1 1:+0    2:+(-2)] = [12:+4 26:+0 0:+0]
-- [5    6]                [1:+1 2:+2    1:+0   ]   [18:+6 41:+2 62:+0]
matmatTest1ZHERK :: IO ()
matmatTest1ZHERK = do
    a <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3,2) (\(x, y) -> [1:+1, 3, 5, 2, 4, 6] !! (x + y * 3))
    c <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3,3) (\(x, y) -> [1:+0, 0:+0, 0:+0, 1:+1, 1:+0, 0:+0, 1:+1, 2:+2, 1:+0] !! (x + y * 3))
    BLAS.zherk Matrix.MatLower Matrix.ConjTranspose 1.0 1.0 a c
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat c
    resList `shouldBe` [7:+0, 12:+4, 18:+6, 0:+0, 26:+0, 41:+2, 0:+0, 0:+0, 62:+0]

her2kSpec :: Spec
her2kSpec =
  context "?HER2K" $ do
    describe "CHER2K" $ do
      it "3x3 and 2x3 with upper no transpose (row oriented)" $ do
        matmatTest1CHER2K
    describe "ZHER2k" $ do
      it "3x3 and 3x2 with lower conjtranspose (column oriented)" $ do
        matmatTest1ZHER2K

-- [1 2]   [1 3 5]       [1:+0    1:+1    1:+1]   [11:+0 23:+1  35:+1]
-- [3 4] * [2 4 6] * 2 + [1:+(-1) 1:+0    2:+2] = [0:+0  51:+0  80:+2]
-- [5 6]                 [1:+(-1) 2:+(-2) 1:+0]   [0:+0  0:+0  123:+0]
matmatTest1CHER2K :: IO ()
matmatTest1CHER2K = do
    a <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (2,3) (\(x, y) -> [1, 2, 3, 4, 5, 6] !! (x + y * 2))
    b <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (2,3) (\(x, y) -> [1, 2, 3, 4, 5, 6] !! (x + y * 2))
    c <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (3,3) (\(x, y) -> [1:+0, 1:+1, 1:+1, 0:+0, 1:+0, 2:+2, 0:+0, 0:+0, 1:+0] !! (x + y * 3))
    BLAS.cher2k Matrix.MatUpper Matrix.NoTranspose 1.0 1.0 a b c
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat c
    resList `shouldBe` [11:+0, 23:+1, 35:+1, 0:+0, 51:+0, 80:+2, 0:+0, 0:+0, 123:+0]

-- [1:-1 2]   [1:+1 3 5]       [1:+0 1:+(-1) 1:+(-1)]   [13:+0  0:+0    0:+0]
-- [3    4] * [2    4 6] * 2 + [1:+1 1:+0    2:+(-2)] = [23:+7  51:+0   0:+0]
-- [5    6]                    [1:+1 2:+2    1:+0   ]   [35:+11 80:+2 123:+0]
matmatTest1ZHER2K :: IO ()
matmatTest1ZHER2K = do
    a <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3,2) (\(x, y) -> [1:+1, 3, 5, 2, 4, 6] !! (x + y * 3))
    b <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3,2) (\(x, y) -> [1:+1, 3, 5, 2, 4, 6] !! (x + y * 3))
    c <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3,3) (\(x, y) -> [1:+0, 0:+0, 0:+0, 1:+1, 1:+0, 0:+0, 1:+1, 2:+2, 1:+0] !! (x + y * 3))
    BLAS.zher2k Matrix.MatLower Matrix.ConjTranspose 1.0 1.0 a b c
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat c
    resList `shouldBe` [13:+0, 23:+7, 35:+11, 0:+0, 51:+0, 80:+2, 0:+0, 0:+0, 123:+0]

symmSpec :: Spec
symmSpec =
  context "?SYMM" $ do
    describe "SSYMM" $ do
      it "2x2 upper all 1's" $ do
        matmatTest1SSYMM
    describe "DSYMM" $ do
      it "2x2 upper all 1's" $ do
        matmatTest1DSYMM Matrix.SRow Matrix.MatUpper
      it "2x2 and 3x2 upper all 1's" $ do
        matmatTest2DSYMM Matrix.SRow Matrix.MatUpper
      it "2x5 and 2x2 upper all 1's" $ do
        matmatTest3DSYMM Matrix.SRow Matrix.MatUpper
      it "2x2 lower all 1's" $ do
        matmatTest1DSYMM Matrix.SRow Matrix.MatLower
      it "2x2 and 3x2 lower all 1's" $ do
        matmatTest2DSYMM Matrix.SRow Matrix.MatLower
      it "2x5 and 2x2 lower all 1's" $ do
        matmatTest3DSYMM Matrix.SRow Matrix.MatLower
      it "2x2 upper all 1's (column oriented)" $ do
        matmatTest1DSYMM Matrix.SColumn Matrix.MatUpper
      it "2x2 and 3x2 upper all 1's (column oriented)" $ do
        matmatTest2DSYMM Matrix.SColumn Matrix.MatUpper
      it "2x5 and 2x2 upper all 1's (column oriented)" $ do
        matmatTest3DSYMM Matrix.SColumn Matrix.MatUpper
      it "2x2 lower all 1's (column oriented)" $ do
        matmatTest1DSYMM Matrix.SColumn Matrix.MatLower
      it "2x2 and 3x2 lower all 1's (column oriented)" $ do
        matmatTest2DSYMM Matrix.SColumn Matrix.MatLower
      it "2x5 and 2x2 lower all 1's (column oriented)" $ do
        matmatTest3DSYMM Matrix.SColumn Matrix.MatLower
    describe "CSYMM" $ do
      it "2x2 all 1's" $ do
        matmatTest1CSYMM
    describe "ZSYMM" $ do
      it "2x2 all 1's" $ do
        matmatTest1ZSYMM

matmatTest1SSYMM:: IO ()
matmatTest1SSYMM = do
    left  <- Matrix.generateMutableUpperTriangular (Matrix.SRow)  (2,2) (const (1.0 :: Float))
    right <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const (1.0 :: Float))
    res   <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const (0.0 :: Float))
    BLAS.ssymm Matrix.LeftSide Matrix.MatUpper 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList `shouldBe` [2,2,2,2]

matmatTest1DSYMM :: Matrix.SOrientation x -> Matrix.MatUpLo -> IO ()
matmatTest1DSYMM or uplo = do
    left  <- (if uplo == Matrix.MatUpper then Matrix.generateMutableUpperTriangular or (2,2) (const 1.0)
                else Matrix.generateMutableLowerTriangular or (2,2) (const 1.0))
    right <- Matrix.generateMutableDenseMatrix or (2,2) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (2,2) (const 0.0)
    BLAS.dsymm Matrix.LeftSide uplo 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList `shouldBe` [2.0,2.0,2.0,2.0]

matmatTest2DSYMM :: Matrix.SOrientation x -> Matrix.MatUpLo -> IO ()
matmatTest2DSYMM or uplo = do
    left  <- (if uplo == Matrix.MatUpper then Matrix.generateMutableUpperTriangular or (2,2) (const 1.0)
                else Matrix.generateMutableLowerTriangular or (2,2) (const 1.0))
    right <- Matrix.generateMutableDenseMatrix or (3,2) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (3,2) (const 0.0)
    BLAS.dsymm Matrix.LeftSide uplo 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList `shouldBe` [2.0,2.0,2.0,2.0,2.0,2.0]

matmatTest3DSYMM :: Matrix.SOrientation x -> Matrix.MatUpLo -> IO ()
matmatTest3DSYMM or uplo = do
    left  <- (if uplo == Matrix.MatUpper then Matrix.generateMutableUpperTriangular or (2,2) (const 1.0)
                else Matrix.generateMutableLowerTriangular or (2,2) (const 1.0))
    right <- Matrix.generateMutableDenseMatrix or (2,5) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (2,5) (const 0.0)
    BLAS.dsymm Matrix.RightSide uplo 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList `shouldBe` replicate 10 2

matmatTest1CSYMM:: IO ()
matmatTest1CSYMM = do
    left  <- Matrix.generateMutableUpperTriangular (Matrix.SRow)  (2,2) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 0.0)
    BLAS.csymm Matrix.LeftSide Matrix.MatUpper 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList `shouldBe` [2.0,2.0,2.0,2.0]

matmatTest1ZSYMM:: IO ()
matmatTest1ZSYMM = do
    left  <- Matrix.generateMutableUpperTriangular (Matrix.SRow)  (2,2) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 0.0)
    BLAS.zsymm Matrix.LeftSide Matrix.MatUpper 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList `shouldBe` [2.0,2.0,2.0,2.0]

syrkSpec :: Spec
syrkSpec =
  context "?SYRK" $ do
    describe "SSYRK" $ do
      it "3x3 and 2x3 with upper no transpose (row oriented)" $ do
        matmatTest1SSYRK
    describe "DSYRK" $ do
      it "3x3 and 3x2 with lower transpose (column oriented)" $ do
        matmatTest1DSYRK
    describe "CSYRK" $ do
      it "3x3 and 2x3 with upper no transpose (row oriented)" $ do
        matmatTest1CSYRK
    describe "ZSYRK" $ do
      it "3x3 and 3x2 with lower transpose (column oriented)" $ do
        matmatTest1ZSYRK

-- [1 2]   [1 3 5]   [1 1 1]   [6 12 18]
-- [3 4] * [2 4 6] + [1 1 2] = [0 26 41]
-- [5 6]             [1 2 1]   [0 0  62]
matmatTest1SSYRK :: IO ()
matmatTest1SSYRK = do
    a <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (2,3) (\(x, y) -> [1, 2, 3, 4, 5, 6] !! (x + y * 2))
    c <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (3,3) (\(x, y) -> [1, 1, 1, 0, 1, 2, 0, 0, 1] !! (x + y * 3))
    BLAS.ssyrk Matrix.MatUpper Matrix.NoTranspose 1.0 1.0 a c
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat c
    resList `shouldBe` [6, 12, 18, 0, 26, 41, 0, 0, 62]

-- [1 2]   [1 3 5]   [1 1 1]   [6  0  0 ]
-- [3 4] * [2 4 6] + [1 1 2] = [12 26 0 ]
-- [5 6]             [1 2 1]   [18 41 62]
matmatTest1DSYRK :: IO ()
matmatTest1DSYRK = do
    a <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3,2) (\(x, y) -> [1, 3, 5, 2, 4, 6] !! (x + y * 3))
    c <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3,3) (\(x, y) -> [1, 0, 0, 1, 1, 0, 1, 2, 1] !! (x + y * 3))
    BLAS.dsyrk Matrix.MatLower Matrix.Transpose 1.0 1.0 a c
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat c
    resList `shouldBe` [6, 12, 18, 0, 26, 41, 0, 0, 62]

-- [1 2]   [1 3 5]   [1:+0 1:+1 1:+1]   [6:+0 12:+1 18:+1]
-- [3 4] * [2 4 6] + [1:+1 1:+0 2:+2] = [0:+0 26:+0 41:+2]
-- [5 6]             [1:+1 2:+2 1:+0]   [0:+0 0:+0  62:+0]
matmatTest1CSYRK :: IO ()
matmatTest1CSYRK = do
    a <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (2,3) (\(x, y) -> [1, 2, 3, 4, 5, 6] !! (x + y * 2))
    c <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (3,3) (\(x, y) -> [1:+0, 1:+1, 1:+1, 0:+0, 1:+0, 2:+2, 0:+0, 0:+0, 1:+0] !! (x + y * 3))
    BLAS.csyrk Matrix.MatUpper Matrix.NoTranspose 1.0 1.0 a c
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat c
    resList `shouldBe` [6:+0, 12:+1, 18:+1, 0:+0, 26:+0, 41:+2, 0:+0, 0:+0, 62:+0]

-- [1:+1 2]   [1:+1 3 5]   [1:+0 1:+1 1:+1]   [6:+0  0:+0  0:+0]
-- [3    4] * [2    4 6] + [1:+1 1:+0 2:+2] = [12:+1 26:+0 0:+0]
-- [5    6]                [1:+1 2:+2 1:+0]   [18:+1 41:+2 62:+0]
matmatTest1ZSYRK :: IO ()
matmatTest1ZSYRK = do
    a <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3,2) (\(x, y) -> [1:+1, 3, 5, 2, 4, 6] !! (x + y * 3))
    c <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3,3) (\(x, y) -> [1:+0, 0:+0, 0:+0, 1:+1, 1:+0, 0:+0, 1:+1, 2:+2, 1:+0] !! (x + y * 3))
    BLAS.zsyrk Matrix.MatLower Matrix.Transpose 1.0 1.0 a c -- TODO: Matrix.ConjTranspose is invalid to pass to cblas_zsyrk
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat c
    resList `shouldBe` [5:+2, 12:+4, 18:+6, 0:+0, 26:+0, 41:+2, 0:+0, 0:+0, 62:+0]

syr2kSpec :: Spec
syr2kSpec =
  context "?SYR2K" $ do
    describe "SSYR2K" $ do
      it "3x3 and 2x3 with upper no transpose (row oriented)" $ do
        matmatTest1SSYR2K
    describe "DSYR2K" $ do
      it "3x3 and 3x2 with lower transpose (column oriented)" $ do
        matmatTest1DSYR2K
    describe "CSYR2K" $ do
      it "3x3 and 2x3 with upper no transpose (row oriented)" $ do
        matmatTest1CSYR2K
    describe "ZSYR2K" $ do
      it "3x3 and 3x2 with lower conjtranspose (column oriented)" $ do
        matmatTest1ZSYR2K

-- [1 2]   [1 3 5]       [1 1 1]   [11 23  35]
-- [3 4] * [2 4 6] * 2 + [1 1 2] = [0  51  80]
-- [5 6]                 [1 2 1]   [0  0  123]
matmatTest1SSYR2K :: IO ()
matmatTest1SSYR2K = do
    a <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (2,3) (\(x, y) -> [1, 2, 3, 4, 5, 6] !! (x + y * 2))
    b <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (2,3) (\(x, y) -> [1, 2, 3, 4, 5, 6] !! (x + y * 2))
    c <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (3,3) (\(x, y) -> [1, 1, 1, 0, 1, 2, 0, 0, 1] !! (x + y * 3))
    BLAS.ssyr2k Matrix.MatUpper Matrix.NoTranspose 1.0 1.0 a b c
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat c
    resList `shouldBe` [11, 23, 35, 0, 51, 80, 0, 0, 123]

-- [1 2]   [1 3 5]       [1 1 1]   [11 0  0  ]
-- [3 4] * [2 4 6] * 2 + [1 1 2] = [23 51 0  ]
-- [5 6]                 [1 2 1]   [35 80 123]
matmatTest1DSYR2K :: IO ()
matmatTest1DSYR2K = do
    a <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3,2) (\(x, y) -> [1, 3, 5, 2, 4, 6] !! (x + y * 3))
    b <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3,2) (\(x, y) -> [1, 3, 5, 2, 4, 6] !! (x + y * 3))
    c <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3,3) (\(x, y) -> [1, 0, 0, 1, 1, 0, 1, 2, 1] !! (x + y * 3))
    BLAS.dsyr2k Matrix.MatLower Matrix.Transpose 1.0 1.0 a b c
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat c
    resList `shouldBe` [11, 23, 35, 0, 51, 80, 0, 0, 123]

-- [1 2]   [1 3 5]       [1:+0 1:+1 1:+1]   [11:+0 23:+1 35:+1 ]
-- [3 4] * [2 4 6] * 2 + [1:+1 1:+0 2:+2] = [0:+0  51:+0 80:+2 ]
-- [5 6]                 [1:+1 2:+2 1:+0]   [0:+0  0:+0  123:+0]
matmatTest1CSYR2K :: IO ()
matmatTest1CSYR2K = do
    a <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (2,3) (\(x, y) -> [1, 2, 3, 4, 5, 6] !! (x + y * 2))
    b <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (2,3) (\(x, y) -> [1, 2, 3, 4, 5, 6] !! (x + y * 2))
    c <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (3,3) (\(x, y) -> [1:+0, 1:+1, 1:+1, 0:+0, 1:+0, 2:+2, 0:+0, 0:+0, 1:+0] !! (x + y * 3))
    BLAS.csyr2k Matrix.MatUpper Matrix.NoTranspose 1.0 1.0 a b c
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat c
    resList `shouldBe` [11:+0, 23:+1, 35:+1, 0:+0, 51:+0, 80:+2, 0:+0, 0:+0, 123:+0]

-- [1:+1 2]   [1:+1 3 5]       [1:+0 1:+1 1:+1]   [9:+4   0:+0  0:+0  ]
-- [3    4] * [2    4 6] * 2 + [1:+1 1:+0 2:+2] = [23:+7  51:+0 0:+0  ]
-- [5    6]                    [1:+1 2:+2 1:+0]   [35:+11 80:+2 123:+0]
matmatTest1ZSYR2K :: IO ()
matmatTest1ZSYR2K = do
    a <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3,2) (\(x, y) -> [1:+1, 3, 5, 2, 4, 6] !! (x + y * 3))
    b <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3,2) (\(x, y) -> [1:+1, 3, 5, 2, 4, 6] !! (x + y * 3))
    c <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3,3) (\(x, y) -> [1:+0, 0:+0, 0:+0, 1:+1, 1:+0, 0:+0, 1:+1, 2:+2, 1:+0] !! (x + y * 3))
    BLAS.zsyr2k Matrix.MatLower Matrix.Transpose 1.0 1.0 a b c -- TODO: Matrix.ConjTranspose is invalid to pass to cblas_zsyr2k
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat c
    resList `shouldBe` [9:+4, 23:+7, 35:+11, 0:+0, 51:+0, 80:+2, 0:+0, 0:+0, 123:+0]

trmmSpec :: Spec
trmmSpec =
  context "?TRMM" $ do
    describe "STRMM" $ do
      it "3x3 and 2x3 with upper no transpose (row oriented)" $ do
        matmatTest1STRMM
    describe "DTRMM" $ do
      it "3x3 and 3x2 with lower transpose (column oriented)" $ do
        matmatTest1DTRMM
    describe "CTRMM" $ do
      it "3x3 and 2x3 with upper no transpose (row oriented)" $ do
        matmatTest1CTRMM
    describe "ZTRMM" $ do
      it "3x3 and 3x2 with lower conjtranspose (column oriented)" $ do
        matmatTest1ZTRMM

-- [1 1 1]   [1 4]   [6 15]
-- [0 1 2] * [2 5] = [8 17]
-- [0 0 1]   [3 6]   [3 6 ]
matmatTest1STRMM :: IO ()
matmatTest1STRMM = do
    a <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (3, 3) (\(x, y) -> [1, 1, 1, 0, 1, 2, 0, 0, 1] !! (x + y * 3))
    c <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (2, 3) (\(x, y) -> [1, 4, 2, 5, 3, 6] !! (x + y * 2))
    BLAS.strmm Matrix.LeftSide Matrix.MatUpper Matrix.NoTranspose Matrix.MatUnit 1.0 a c
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat c
    resList `shouldBe` [6, 15, 8, 17, 3, 6]

-- [1 2 3]   [2 1 1]   [2 5  11]
-- [4 5 6] * [0 2 2] = [8 14 26]
--           [0 0 2]
matmatTest1DTRMM :: IO ()
matmatTest1DTRMM = do
    a <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3, 3) (\(x, y) -> [2, 0, 0, 1, 2, 0, 1, 2, 2] !! (x + y * 3))
    c <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3, 2) (\(x, y) -> [1, 2, 3, 4, 5, 6] !! (x + y * 3))
    BLAS.dtrmm Matrix.RightSide Matrix.MatLower Matrix.Transpose Matrix.MatNonUnit 1.0 a c
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat c
    resList `shouldBe` [2, 8, 5, 14, 11, 26]

-- [1:+0 1:+1 1:+1]   [1 2]   [9:+8   12:+10]
-- [0:+0 1:+0 2:+2] * [3 4] = [13:+10 16:+12]
-- [0:+0 0:+0 1:+0]   [5 6]   [5:+0   6:+0  ]
matmatTest1CTRMM :: IO ()
matmatTest1CTRMM = do
    a <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (3, 3) (\(x, y) -> [1:+0, 1:+1, 1:+1, 0:+0, 1:+0, 2:+2, 0:+0, 0:+0, 1:+0] !! (x + y * 3))
    c <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (2, 3) (\(x, y) -> [1, 2, 3, 4, 5, 6] !! (x + y * 2))
    BLAS.ctrmm Matrix.LeftSide Matrix.MatUpper Matrix.NoTranspose Matrix.MatUnit 1.0 a c
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat c
    resList `shouldBe` [9:+8, 12:+10, 13:+10, 16:+12, 5:+0, 6:+0]

-- [1:+1 3 5]   [1:+0 1:+1 1:+1]   [1:+1 3:+2 11:+8 ]
-- [2    4 6] + [0:+0 1:+0 2:+2] = [2:+0 6:+2 16:+10]
--              [0:+0 0:+0 1:+0]
matmatTest1ZTRMM :: IO ()
matmatTest1ZTRMM = do
    a <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3, 3) (\(x, y) -> [1:+0, 0:+0, 0:+0, 1:+(-1), 1:+0, 0:+0, 1:+(-1), 2:+(-2), 1:+0] !! (x + y * 3))
    c <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3, 2) (\(x, y) -> [1:+1, 3, 5, 2, 4, 6] !! (x + y * 3))
    BLAS.ztrmm Matrix.RightSide Matrix.MatLower Matrix.ConjTranspose Matrix.MatNonUnit 1.0 a c -- TODO: Matrix.ConjTranspose is invalid to pass to cblas_zsyr2k
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat c
    resList `shouldBe` [1:+1, 2:+0, 3:+2, 6:+2, 11:+8, 16:+10]

trsmSpec :: Spec
trsmSpec =
  context "?TRSM" $ do
    describe "STRSM" $ do
      it "3x3 and 2x3 with upper no transpose (row oriented)" $ do
        matmatTest1STRSM
    describe "DTRSM" $ do
      it "3x3 and 3x2 with lower transpose (column oriented)" $ do
        matmatTest1DTRSM
    describe "CTRSM" $ do
      it "3x3 and 2x3 with upper no transpose (row oriented)" $ do
        matmatTest1CTRSM
    describe "ZTRSM" $ do
      it "3x3 and 3x2 with lower conjtranspose (column oriented)" $ do
        matmatTest1ZTRSM

-- [1 1 1]   [1 4]   [6 15]
-- [0 1 2] * [2 5] = [8 17]
-- [0 0 1]   [3 6]   [3 6 ]
matmatTest1STRSM :: IO ()
matmatTest1STRSM = do
    a <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (3, 3) (\(x, y) -> [1, 1, 1, 0, 1, 2, 0, 0, 1] !! (x + y * 3))
    c <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (2, 3) (\(x, y) -> [6, 15, 8, 17, 3, 6] !! (x + y * 2))
    BLAS.strsm Matrix.LeftSide Matrix.MatUpper Matrix.NoTranspose Matrix.MatUnit 1.0 a c
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat c
    resList `shouldBe` [1, 4, 2, 5, 3, 6]

-- [1 2 3]   [2 1 1]   [2 5  11]
-- [4 5 6] * [0 2 2] = [8 14 26]
--           [0 0 2]
matmatTest1DTRSM :: IO ()
matmatTest1DTRSM = do
    a <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3, 3) (\(x, y) -> [2, 0, 0, 1, 2, 0, 1, 2, 2] !! (x + y * 3))
    c <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3, 2) (\(x, y) -> [2, 5, 11, 8, 14, 26] !! (x + y * 3))
    BLAS.dtrsm Matrix.RightSide Matrix.MatLower Matrix.Transpose Matrix.MatNonUnit 1.0 a c
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat c
    resList `shouldBe` [1, 4, 2, 5, 3, 6]

-- [1:+0 1:+1 1:+1]   [1 2]   [9:+8   12:+10]
-- [0:+0 1:+0 2:+2] * [3 4] = [13:+10 16:+12]
-- [0:+0 0:+0 1:+0]   [5 6]   [5:+0   6:+0  ]
matmatTest1CTRSM :: IO ()
matmatTest1CTRSM = do
    a <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (3, 3) (\(x, y) -> [1:+0, 1:+1, 1:+1, 0:+0, 1:+0, 2:+2, 0:+0, 0:+0, 1:+0] !! (x + y * 3))
    c <- Matrix.generateMutableDenseMatrix (Matrix.SRow) (2, 3) (\(x, y) -> [9:+8, 12:+10, 13:+10, 16:+12, 5:+0, 6:+0] !! (x + y * 2))
    BLAS.ctrsm Matrix.LeftSide Matrix.MatUpper Matrix.NoTranspose Matrix.MatUnit 1.0 a c
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat c
    resList `shouldBe` [1, 2, 3, 4, 5, 6]

-- [1:+1 3 5]   [1:+0 1:+1 1:+1]   [1:+1 3:+2 11:+8 ]
-- [2    4 6] + [0:+0 1:+0 2:+2] = [2:+0 6:+2 16:+10]
--              [0:+0 0:+0 1:+0]
matmatTest1ZTRSM :: IO ()
matmatTest1ZTRSM = do
    a <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3, 3) (\(x, y) -> [1:+0, 0:+0, 0:+0, 1:+(-1), 1:+0, 0:+0, 1:+(-1), 2:+(-2), 1:+0] !! (x + y * 3))
    c <- Matrix.generateMutableDenseMatrix (Matrix.SColumn) (3, 2) (\(x, y) -> [1:+1, 3:+2, 11:+8, 2:+0, 6:+2, 16:+10] !! (x + y * 3))
    BLAS.ztrsm Matrix.RightSide Matrix.MatLower Matrix.ConjTranspose Matrix.MatNonUnit 1.0 a c -- TODO: Matrix.ConjTranspose is invalid to pass to cblas_zsyr2k
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat c
    resList `shouldBe` [1:+1, 2, 3, 4, 5, 6]