-- ch1 figure 1.1
-- https://stackoverflow.com/a/48212667

import Statistics.Sample

import qualified Statistics.Sample.Histogram as S
import qualified Data.Vector as V

vs :: V.Vector Double
vs = V.fromList xs

xs :: [Double]
xs = [2.1, 2.4, 2.2, 2.3, 2.7, 2.5, 2.4, 2.6, 2.6, 2.9]

hs :: V.Vector Int
hs = S.histogram_ bins lowerBound upperBound vs
  where
    bins = 5
    lowerBound = 2.05
    upperBound = 3.05

main :: IO ()
main = do
   putStrLn "Let us show the histgram, which corresponds to Figure1.1:"
   putStrLn $ "The date is:           " ++ show vs
   putStrLn $ "The number of smple is " ++ show (V.length vs)
   putStrLn $ "The histogram is:      " ++ show hs

   let m = mean vs
       s = stdDev vs
   putStrLn $ "The mean is: " ++ show m ++ " and the standard deviation is: " ++ show s


import Numeric.Container hiding (linspace)
import Numeric.LinearAlgebra.Util
import Numeric.LinearAlgebra.Data hiding (linspace)
import Numeric.LinearAlgebra.Algorithms
import Numeric.LinearAlgebra.Devel
import Data.List hiding (find)
import DSP.Basic

--For Charts
import Graphics.Rendering.Chart hiding (Matrix, Vector)
import Data.Colour
import Data.Colour.Names
import Data.Default.Class
import Graphics.Rendering.Chart.Backend.Cairo
import Control.Lens

{- 1.1.1 Method of Finite Differences
# Eigenvalue problem in one dimension. -}

--Create the tridiagonal differential matrix, with corresponding sparse matrix, if needed.
d :: Matrix Double
d = buildMatrix 100 100 (\(i,j) -> if (i,j) == (i,i) then 2 else if (i,j) == (i, i-1) then -1 else if (i,j) == (i,i+1) then -1 else 0)
d_Sparse = mkSparse [((i,j), (d @@> (i,j))) | (i,j) <- (find (/= 0) d)]

--Create the potential matrix with corresponding sparse matrix, if needed.
v :: Matrix Double
v = buildMatrix 100 100 (\(i,j) -> ((fromIntegral i)+50)^2)
v_Sparse = mkSparse [((i,j), (d @@> (i,j))) | (i,j) <- (find (/= 0) v)]

--The energy eigenvalues in a sorted List:
e = sort(toList(mapVector realPart (fst(eig(d_Sparse+v_Sparse)))))

--The corresponding eigenfunctions
psi = toColumns (mapMatrix realPart (snd(eig(d_Sparse+v_Sparse))))

--Plot
chart = toRenderable layout
  where

	--Grid for Visualization
	x = linspace 0.0 1.0 100
	--List of Tuples [(Grid, psi) ] for Plotting
	points1 = zip ( x) (map (\x -> abs(x)^2) (toList (psi !! 1)))
	points2 = zip ( x) (map (\x -> abs(x)^2) (toList (psi !! 2)))
	points3 = zip ( x) (map (\x -> abs(x)^2) (toList (psi !! 3)))
	points4 = zip ( x) (map (\x -> abs(x)^2) (toList (psi !! 4)))
	psi1 = plot_lines_values .~ [points1]
              $ plot_lines_style  . line_color .~ opaque blue
              $ plot_lines_title .~ "psi1"
              $ def
	psi2 = plot_lines_values .~ [points2]
              $ plot_lines_style  . line_color .~ opaque red
              $ plot_lines_title .~ "psi2"
              $ def

	psi3 = plot_lines_values .~ [points3]
              $ plot_lines_style  . line_color .~ opaque green
              $ plot_lines_title .~ "psi3"
              $ def

	psi4 = plot_lines_values .~ [points4]
              $ plot_lines_style  . line_color .~ opaque black
              $ plot_lines_title .~ "psi4"
              $ def

	layout = layout_title .~ "Eigenfunctions"
           $ layout_plots .~ [toPlot psi1,
                              toPlot psi2,
							  toPlot psi3,
							  toPlot psi4]
           $ def

main = renderableToFile def{_fo_format=PDF} "eigenfunctions_quadratic_v.pdf" chart


-- | Module providing definitions of basic quantum gates, including parametrized
-- rotation and controlled operations.
module Hoqus.Gates where

import Numeric.LinearAlgebra.Data

-- | Constant for pure imaginary unit
ii :: C
ii = 0:+1

-- | Pauli gate X, logical negation.
sx :: Matrix C
sx = (2><2) [0, 1, 1, 0] :: Matrix C

-- | Pauli gate Y.
-- sy = -ii ( sx <> sz )
sy :: Matrix C
sy = (2><2) [0, -ii, ii, 0] :: Matrix C

-- | Pauli gate Z.
sz :: Matrix C
sz = (2><2) [1, 0, 0, -1] :: Matrix C

-- | Hadamard gate.
h :: Matrix C
h = 1/sqrt(2) * (2><2) [1, 1, 1, -1] :: Matrix C


-- Jacobi's Method (Nonlinear Equation System Solution)
-- May 13th, 2016
import Data.Matrix
import Data.Complex

jacobiroots :: (RealFloat a) => (Matrix (Matrix a -> a))     -- F(x) vector
                             -> (Matrix a)                   -- initial state
                             -> a                            -- maximum epsilon
                             -> ((a -> a) -> a -> a -> a)    -- given solver (f, x0, emax)
                             -> (Matrix a)                   -- result
jacobiroots f x0 e sv = if abs (maximum (x1 - x0)) > e then jacobiroots f x1 e sv else x1 where
   n  = nrows x0
   x1 = foldl (\acc x -> setElem (sv (\y -> (f ! (x, 1)) $ matrix n 1 (\(z, _) -> if z /= x then x0 ! (z, 1) else y)) (x0 ! (x, 1)) e) (x, 1) acc) (matrix n 1 (\_ -> 0)) [1..n]

-- F(x) is formatted as follows
-- fns = fromList 2 1 [(\[x, y] -> x + y) . toList, (\[x, y] -> x - 2*y) . toList]

secroot :: (RealFloat a) => (a -> a)                -- f(x)
                         -> a                       -- initial state 1
                         -> a                       -- initial state 2
                         -> a                       -- maximum epsilon
                         -> a                       -- result
secroot f x1 x2 e = if abs ((-) x3 x2) > e then secroot f x2 x3 e else x3 where
    f1   = f x1
    f2   = f x2
    fpi  = if f2 /= f1 then (/) (x2 - x1) (f2 - f1) else 0
    x3   = if f2 /= f1 then x2 - f2 * fpi           else x2 + e -- reseed

-- F(x) is formatted as follows
-- fns = fromList 2 1 [(\[x, y] -> x + y) . toList, (\[x, y] -> x - 2*y) . toList]
-- complex counterparts
jacobiroots_c :: (RealFloat a) => (Matrix (Matrix (Complex a) -> (Complex a)))     -- F(x) vector
                             -> (Matrix (Complex a))                   -- initial state
                             -> (Complex a)                            -- maximum epsilon
                             -> (((Complex a) -> (Complex a)) -> (Complex a) -> (Complex a) -> (Complex a))    -- given solver (f, x0, emax)
                             -> (Matrix (Complex a))                   -- result
jacobiroots_c f x0 e sv = if (maximum (fmap magnitude (x1 - x0))) > magnitude e then jacobiroots_c f x1 e sv else x1 where
   n  = nrows x0
   x1 = foldl (\acc x -> setElem (sv (\y -> (f ! (x, 1)) $ matrix n 1 (\(z, _) -> if z /= x then x0 ! (z, 1) else y)) (x0 ! (x, 1)) e) (x, 1) acc) (matrix n 1 (\_ -> 0)) [1..n]

secroot_c :: (RealFloat a) => (Complex a -> Complex a)                -- f(x)
                         -> Complex a                       -- initial state 1
                         -> Complex a                       -- initial state 2
                         -> Complex a                       -- maximum epsilon (real, Complex for type only)
                         -> Complex a                       -- result
secroot_c f x1 x2 e = if magnitude ((-) x3 x2) > magnitude e then secroot_c f x2 x3 e else x3 where
    f1   = f x1
    f2   = f x2
    fpi  = if f2 /= f1 then (/) (x2 - x1) (f2 - f1) else 0
    x3   = if f2 /= f1 then x2 - f2 * fpi           else x2 + e -- reseed


import Statistics.LinearRegression
import Statistics.Sample
import qualified Data.Vector.Unboxed as U
import Control.Monad.Random
import Control.Monad
import Control.Applicative
import System.Random.MWC
import System.Random.MWC.Distributions
import qualified Data.Packed.Vector as V
import Graphics.Rendering.Plot

main = do
    mapM_ test [1..10]
    test_convergence
    test_robust
    test_variances

test k = do
    let n = 10000000
    let a = k*n + 1
    let b = (k+1)*n
    let xs = U.fromList [a..b]
    let ys = U.map (\x -> x*100 + 2000) xs
    putStrLn "linearRegression:"
    putStrLn . show $ linearRegression xs ys
    putStrLn "linearRegressionTLS:"
    putStrLn . show $ linearRegressionTLS xs ys

test_convergence = do
    let xs = U.fromList [1..10]
    let ys = U.fromList $ [1..5] ++ [0,0] ++ [8..10]
    let iter1 = linearRegression xs ys
    let ep = defaultEstimationParameters
    putStrLn "Initial iteration:"
    putStrLn . show $ iter1
    putStrLn "Successive iteration:"
    putStrLn . show $ converge ep xs ys iter1

getNormals :: Double -> Double -> Int -> IO [Double]
getNormals mean std n = do
    withSystemRandom . asGenIO $ \gen -> replicateM n (normal mean std gen)

testFigure :: U.Vector Double -> U.Vector Double -> (EstimatedRelation, EstimatedRelation, EstimatedRelation) -> Figure ()
testFigure xs ys (simple, non_robust, robust) = do
    let vxs = V.fromList . U.toList $ xs
    let vys = V.fromList . U.toList $ ys
    let dataset = (vxs, [   point vys Cross, line_func simple, line_func non_robust, line_func robust ])

    withTitle . setText $ "linreg test"
    setPlots 1 1
    withPlot (1,1) $ do
        addAxis XAxis (Side Lower) $ do
            setTicks Minor (TickNumber 5)
            withAxisLine $ do
                setLineWidth 1.0
        addAxis YAxis (Side Lower) $ do
            setTicks Minor (TickNumber 5)
            withAxisLine $ do
                setLineWidth 1.0
        setDataset dataset
        setRangeFromData XAxis Lower Linear
        setRangeFromData YAxis Lower Linear
        setLegend True NorthEast Inside
    where
        line_func (alpha,beta) = line ((\x -> alpha + beta*x) :: Function) (1.0 :: LineWidth)

test_robust = do
    putStrLn "generating random dataset for robust fit:"
    first_xs <- getNormals 0.0 10.0 800
    first_ys_errs <- getNormals  0.0 1.0 800
    let first_ys = zipWith (+) first_xs first_ys_errs
    last_xs <- getNormals  50.0 (sqrt 50) 200
    last_ys <- getNormals  0.0 (sqrt 50) 200
    let xs = U.fromList $ first_xs ++ last_xs
    let ys = U.fromList $ first_ys ++ last_ys
    putStrLn "robustFit test results:"
    (simple,non_robust,robust) <- evalRandIO (randTest xs ys)
    putStrLn "linearRegression on dataset:"
    putStrLn . show $ simple
    putStrLn "convergedRegression on dataset:"
    putStrLn . show $ non_robust
    putStrLn "robustFit on dataset:"
    putStrLn . show $ robust
    let filename = "test_robust.png"
    putStrLn $ "Image output is at " ++ filename
    writeFigure PNG filename (800,800) $ testFigure xs ys (simple,non_robust,robust)

randTest :: MonadRandom m => U.Vector Double -> U.Vector Double -> m (EstimatedRelation,EstimatedRelation,EstimatedRelation)
randTest xs ys = do
    robust <- robustFit defaultEstimationParameters xs ys
    let simple = linearRegression xs ys
    let non_robust = converge defaultEstimationParameters xs ys (0.0,0.001) -- simple
    return (simple, non_robust, robust)

test_variances :: IO ()
test_variances = do
    putStrLn "generating random dataset for variance test:"
    let xs = U.fromList [-100..100]
    offsets <- liftM U.fromList $ getNormals 0 10 (U.length xs)
    let ys = U.zipWith (+) xs offsets
    let ab = linearRegression xs ys
    putStrLn $ "estimated fit should be (0,1). It is:" ++ show ab
    let mse = linearRegressionMSE ab xs ys
    putStrLn $ "Calculated MSE of sampled data should be an estimate of 10. it is:" ++ (show . sqrt $ mse)
    let dsts = linearRegressionDistributions ab xs ys
    putStrLn $ "Calculated distributions of the linear fit are linear transformed StudentT distributions with scalings that are estimates of (0.5,1.4777-4). They are:" ++ show dsts


------------------------------------------------------------
--
-- Nums.hs
-- Code sample accompanying topic 1.3.2 "Types and type signatures"
-- See README.md for details
--
-- Fundamentals of Practical Haskell Programming
-- By Richard Cook
--
------------------------------------------------------------

import Data.Complex
import Data.Ratio

n0 :: Int
n0 = 5

n1 :: Double
n1 = 5.0

n2 :: Complex Double
n2 = 2 :+ 3

n3 :: Ratio Int
n3 = 2 % 3

main :: IO ()
main = do
    print n0
    print n1
    print n2
    print n3

haskell/original/Fundamentals of Practical Haskell Programming [Video]/Volume_01_Section_03_Topic_02/Nums.hs


module ActivFunc (
    sigmoidC,
    sigmoids,
    rampC,
    ramps,
    softmaxC
  ) where

import Numeric.LinearAlgebra

sigmoid x = 1 / (1 + exp (-x))
dsigmoid x = sigmoid x * (1 - sigmoid x)

sigmoidC :: Matrix R -> Matrix R
sigmoidC = cmap sigmoid

dsigmoidC :: Matrix R -> Matrix R
dsigmoidC = cmap dsigmoid

sigmoids = (sigmoidC, dsigmoidC)

ramp x = if x > 0 then x else 0
dramp x = if x > 0 then 1 else 0 -- as a matter of convenience

rampC :: Matrix R -> Matrix R
rampC = cmap ramp

drampC :: Matrix R -> Matrix R
drampC = cmap dramp

ramps = (rampC, drampC)

softmax :: Vector R -> Vector R
softmax us = cmap (/ (sum . toList) es) es
  where es = exp us

softmaxC :: Matrix R -> Matrix R
softmaxC = fromColumns . fmap softmax . toColumns


module Fuml.Base.LinearRegression where

import Numeric.LinearAlgebra

-- | Ordinary least squares
ols :: [(Vector Double, Double)] -> Vector Double
ols xys =
  let x = fromRows $ map fst xys
      y = col $ map snd xys
      betaMat = inv (tr' x <> x) <> tr' x <> y
  in tr' betaMat ! 0

-- | Weighted ordinary least squares
wols :: Vector Double -> [(Vector Double, Double)] -> Vector Double
wols wvs xys =
  let w = diag wvs
      x = fromRows $ map fst xys
      y = col $ map snd xys
      betaMat = inv (tr' x <> w <> x) <> tr' x <> w <> y
  in tr' betaMat ! 0

-- | Ridge regression
ridge :: Matrix Double -> [(Vector Double, Double)] -> Vector Double
ridge gamma xys =
  let x = fromRows $ map fst xys
      y = col $ map snd xys
      betaMat = inv (tr' x <> x + tr' gamma <> gamma) <> tr' x <> y
  in tr' betaMat ! 0


module ComplexFunctions where

import Data.Complex
import RealFunctions

fibonacci :: (Fractional a, Floating a, Num a) => a -> a
fibonacci z = ((phi ** z) - (cos (pi*z)) * (phi ** (-z))) / (sqrt 5)
    where phi = (1 + (sqrt 5)) / 2

weierstrass :: (Floating a) => Int -> a -> a -> a -> a
weierstrass limit a b x = sum $ map (\n -> (a^n) * cos (b^n * pi * x)) [0..limit]

foldPhase :: (RealFloat a) => a -> Complex a -> Complex a
foldPhase p z = mkPolar (magnitude z) (triangle (phase z) (p) (p))

foldMag :: (RealFloat a) => a -> Complex a -> Complex a
foldMag p z = mkPolar (triangle (magnitude z) p p) (phase z)

foldX :: (RealFloat a) => a -> Complex a -> Complex a
foldX p z = (x:+y)
    where x = triangle (realPart z) p p
          y = imagPart z

foldY :: (RealFloat a) => a -> Complex a -> Complex a
foldY p z = (x:+y)
    where x = realPart z
          y = triangle (imagPart z) p p

-- remaps x and y in [-1,1]
remap :: (RealFloat a) => Complex a -> a -> a -> Complex a
remap z w h = ((realPart z') / a) :+ ((imagPart z') / a)
    where a = 0.5 * (min w h)
          z'= z - (w/2 :+ h/2) -- centering

-- STOP CONDITIONS
isNotInfinite :: (RealFloat a, Fractional a ) => Complex a -> Bool
isNotInfinite z = not $ (isNaN . magnitude) z || (isInfinite . magnitude) z

magnitudeLimit :: (Ord a, RealFloat a, Fractional a) => a -> Complex a -> Bool
magnitudeLimit limit z = magnitude z < limit

diamond :: (RealFloat a, Fractional a) => Complex a -> a
diamond z = y + x
    where x = abs (realPart z)
          y = abs (imagPart z)

compareBy :: (Ord a, RealFloat a) => (Complex a -> a) ->  Complex a -> Complex a -> Ordering
compareBy func z1 z2 = compare (func z1) (func z2)
{--
hofstadterQ :: (Integral a) => a -> a
hofstadterQ 1 = 1
hofstadterQ 2 = 1
hofstadterQ n = (hofstadterQ (n - hofstadterQ (n - 1))) +
    (hofstadterQ (n - hofstadterQ (n - 2)))
--}


-- the multidimensional minimization example in the GSL manual
import Numeric.GSL
import Numeric.LinearAlgebra
import Graphics.Plot
import Text.Printf(printf)

-- the function to be minimized
f [x,y] = 10*(x-1)^2 + 20*(y-2)^2 + 30

-- exact gradient
df [x,y] = [20*(x-1), 40*(y-2)]

-- a minimization algorithm which does not require the gradient
minimizeS f xi = minimize NMSimplex2 1E-2 100 (replicate (length xi) 1) f xi

-- Numerical estimation of the gradient
gradient f v = [partialDerivative k f v | k <- [0 .. length v -1]]

partialDerivative n f v = fst (derivCentral 0.01 g (v!!n)) where
    g x = f (concat [a,x:b])
    (a,_:b) = splitAt n v

disp = putStrLn . format "  " (printf "%.3f")

allMethods :: (Enum a, Bounded a) => [a]
allMethods = [minBound .. maxBound]

test method = do
    print method
    let (s,p) = minimize method 1E-2 30 [1,1] f [5,7]
    print s
    disp p

testD method = do
    print method
    let (s,p) = minimizeD method 1E-3 30 1E-2 1E-4 f df [5,7]
    print s
    disp p

testD' method = do
    putStrLn $ show method ++ " with estimated gradient"
    let (s,p) = minimizeD method 1E-3 30 1E-2 1E-4 f (gradient f) [5,7]
    print s
    disp p

main = do
    mapM_ test [NMSimplex, NMSimplex2]
    mapM_ testD allMethods
    testD' ConjugateFR
    mplot $ drop 3 . toColumns . snd $ minimizeS f [5,7]


-- Improved PCA, including illustrative graphics

import Numeric.LinearAlgebra
import Graphics.Plot
import System.Directory(doesFileExist)
import System.Process(system)
import Control.Monad(when)

type Vec = Vector Double
type Mat = Matrix Double

-- Vector with the mean value of the columns of a matrix
mean a = constant (recip . fromIntegral . rows $ a) (rows a) <> a

-- covariance matrix of a list of observations stored as rows
cov x = (trans xc <> xc) / fromIntegral (rows x - 1)
    where xc = x - asRow (mean x)

type Stat = (Vec, [Double], Mat)
-- 1st and 2nd order statistics of a dataset (mean, eigenvalues and eigenvectors of cov)
stat :: Mat -> Stat
stat x = (m, toList s, trans v) where
    m = mean x
    (s,v) = eigSH' (cov x)

-- creates the compression and decompression functions from the desired reconstruction
-- quality and the statistics of a data set
pca :: Double -> Stat -> (Vec -> Vec , Vec -> Vec)
pca prec (m,s,v) = (encode,decode)
  where
    encode x = vp <> (x - m)
    decode x = x <> vp + m
    vp = takeRows n v
    n = 1 + (length $ fst $ span (< (prec'*sum s)) $ cumSum s)
    cumSum = tail . scanl (+) 0.0
    prec' = if prec <=0.0 || prec >= 1.0
                then error "the precision in pca must be 0<prec<1"
                else prec

shdigit :: Vec -> IO ()
shdigit v = imshow (reshape 28 (-v))

-- shows the effect of a given reconstruction quality on a test vector
test :: Stat -> Double -> Vec -> IO ()
test st prec x = do
    let (pe,pd) = pca prec st
    let y = pe x
    print $ dim y
    shdigit (pd y)

main = do
    ok <- doesFileExist ("mnist.txt")
    when (not ok)  $ do
        putStrLn "\nTrying to download test datafile..."
        system("wget -nv http://dis.um.es/~alberto/material/sp/mnist.txt.gz")
        system("gunzip mnist.txt.gz")
        return ()
    m <- loadMatrix "mnist.txt"
    let xs = takeColumns (cols m -1) m
    let x = toRows xs !! 4  -- an arbitrary test vector
    shdigit x
    let st = stat xs
    test st 0.90 x
    test st 0.50 x


-- ch1 ex 1.27

import Statistics.Distribution.Normal

import Statistics.Distribution ( cumulative )

normalD :: NormalDistribution
normalD = normalDistr mean stdD
  where
    mean = 72
    stdD = 8

sampleSize = 340

main = do
  let f low high = (cumulative normalD high) - (cumulative normalD low)
      f1 = f 64 80

  putStrLn $ "The percentage: " ++ show f1
  putStrLn $ "The number of students in the range [64, 80] is approximately: " ++ show (sampleSize * f1)

  let f2 = f 56 88

  putStrLn $ "The percentage: " ++ show f2
  putStrLn $ "The number of students in the range [56, 88] is approximately: " ++ show (sampleSize * f2)


module Main where

import qualified Statistics.Matrix as M
import qualified Statistics.Matrix.Fast as F
import qualified Statistics.Matrix.Fast.Algorithms as FA
import           Statistics.Matrix (Matrix (..))
import qualified Statistics.Matrix.Algorithms as A

import qualified Data.Vector.Unboxed         as U
import           Data.Vector.Unboxed         (Vector)

import qualified System.Random.MWC as Mwc

import qualified Weigh         as W

n :: Int
n = 100

testVector :: IO (Vector Double)
testVector = do
    gen <- Mwc.create
    Mwc.uniformVector gen (n*n)

testMatrix :: IO Matrix
testMatrix = do
    vec <- testVector
    return $ Matrix n n vec

weight :: Vector Double -> Matrix -> Matrix -> IO ()
weight v a b = do
    let
      v2 = U.take n v
    W.mainWith (do
        W.func "norm" M.norm v2
        W.func "Fast.norm" F.norm v2

        W.func "multiplyV" (M.multiplyV a) (v2)
        W.func "Fast.multiplyV" (F.multiplyV a) (v2)
        W.func "transpose" M.transpose a
        W.func "Fast.transpose" F.transpose a
        W.func "ident" M.ident n
        W.func "diag" M.diag v2

        W.func "multiply" (M.multiply a) b
        W.func "Fast.multiply" (F.multiply a) b

        W.func "qr" A.qr a
        W.func "Fast.qr" FA.qr a

        )

main :: IO ()
main = do
    v <- testVector
    a <- testMatrix
    b <- testMatrix

    putStrLn "---Benchmarking memory consumption---"
    weight v a b


module LU ( luFactor, luFactorM ) where

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

import Numeric.LinearAlgebra
import qualified Numeric.LinearAlgebra.Matrix as M
import qualified Numeric.LinearAlgebra.Vector as V

luFactor :: (BLAS3 e) => Matrix e -> Either Int (Matrix e, [Int])
luFactor a = runST $ do
    ma <- M.newCopy a
    luFactorM ma >>=
        either (return . Left) (\pivots -> do
            a' <- M.unsafeFreeze ma
            return $ Right (a',pivots)
        )

{-
 - Recursive LU factorization with row pivoting.  Takes a matrix
 - A and factors it as P A = L U, where P is a permutation matrix,
 - L is a lower triangular matrix with ones along the diagonal, and
 - U is an upper triangular matrix.  On successful return, the values of
 - L and U are stored in A, and a list of the row swaps are returned.
 - On failure, the index of the failing column is returned.
 -}
luFactorM :: (BLAS3 e) => STMatrix s e -> ST s (Either Int [Int])
luFactorM a = do
    (m,n) <- M.getDim a
    let mn = min m n
        nleft = mn `div` 2

    case undefined of
        _ | mn > 1 ->
            M.withSplitColsAtM nleft a $ \a_1 a_2 ->
            M.withSplitRowsAtM nleft a_1 $ \a11 a21 ->
            M.withSplitRowsAtM nleft a_2 $ \a12 a22 ->
            luFactorM a_1 >>=
                either (return . Left) (\pivots -> do
                    zipWithM_ (M.swapRows a_2) [ 0.. ] pivots
                    M.triSolvMatrixM_ LeftSide NoTrans (Tri Lower Unit a11) a12
                    M.addMulMatrixWithScalesM_ (-1) NoTrans a21 NoTrans a12 1 a22
                    luFactorM a22 >>=
                        either (return . Left . (nleft+)) (\pivots' -> do
                            zipWithM_ (M.swapRows a21) [ 0.. ] pivots'
                            return $ Right (pivots ++ map (nleft+) pivots')
                        )
                )

        _ | mn == 1 ->
            M.withColM a 0 $ \x ->
                V.getWhichMaxAbs x >>= \(i,e) ->
                    if (e /= 0)
                        then do
                            V.scaleM_ (1/e) x
                            V.read x 0 >>= V.write x i
                            V.write x 0 e
                            return $ Right [i]
                        else
                            return $ Left 0

        _ | otherwise ->
            return $ Right []


module Fractals (  iteratingFractal, mandelbrot, burningShip, tricorn, julia, flipForJulia, Formula, Parameters ) where

import Data.Complex ( Complex(..), conjugate, imagPart, magnitude, realPart )
import Data.Bool ( bool )
import Data.Tuple ( swap )

type Formula = Complex Float -> Complex Float -> Complex Float -- e.g z' = z^2 + c
type Parameters = (Complex Float, Complex Float) -- (z,c)

maxIter = 100

flipForJulia :: Parameters -> Bool -> Parameters
flipForJulia =  bool <*> swap

mandelbrot :: Formula
mandelbrot z c = z ^ 2 + c

burningShip :: Formula
burningShip z c = (abs (realPart z) :+ abs (imagPart z)) ^ 2 + c

tricorn :: Formula
tricorn z c = conjugate z ^ 2 + c

-- i think julia sets can be just our regular sets (mandelbrot for the classic ones) given a const c in reversed c z paremeter order.
-- for now let it be just a regular formula. for which we just reverse z and c
julia :: Formula
julia z _ = z ^ 2 + ((-0.835) :+ (-0.2321))

-- returns intensity in correspondence to a point on the complex plane
iteratingFractal :: Formula -> Parameters -> Int -> Int
iteratingFractal formula (z, c) iter
  | iter > maxIter = 0
  | otherwise = let z' = formula z c in
      if magnitude z' > 2 then iter
      else iteratingFractal formula (z', c) (iter + 1)


module DigitRecognitionSpec where

import Test.Hspec
import DigitRecognition
import Numeric.LinearAlgebra as LA

n :: Int
n = 3
d :: Int
d = 5
k :: Int
k = 7
x :: Matrix R
x = (n >< d) $ map fromIntegral [0..(n * d - 1)]
y :: Vector Int
y = fromList [0..(n - 1)]
zeros :: Matrix R
zeros = (k >< d) $ repeat 0.0
temp :: R
temp = 0.2
lambda :: R
lambda = 0.5

spec :: Spec
spec = do
    describe "Compute probabilities" $ do

        it "Compute probabilities 1" $ do
            let
                expected = (k >< n) $ repeat (1.0 / fromIntegral k)
                result1 = computeProbabilities x zeros temp
            result1 `shouldBe` expected

        it "Compute probabilities 2" $ do
            let
                theta = (k >< d) $ map fromIntegral [0..(k * d - 1)]
                temp = 0.2
                expected = ((k - 1) >< n) (repeat 0.0) === konst 1.0 (1, n)
                result2 = computeProbabilities x theta temp
            result2 `shouldBe` expected

    describe "Compute cost" $

        it "Compute cost 1" $ do
            let
                cost1 = computeCostFunction x y zeros lambda temp
            cost1 `shouldBe` 1.9459101490553135

    describe "Gradient descent" $

        it "Run gradient descent" $ do
            let
                alpha = 2
                expected = (k >< d) [ -7.142857142857142, -5.238095238095236, -3.333333333333332, -1.4285714285714273, 0.4761904761904778
                  ,  9.523809523809526, 11.428571428571429, 13.333333333333332, 15.238095238095239, 17.142857142857142
                  ,  26.19047619047619, 28.095238095238095, 29.999999999999996, 31.90476190476191, 33.80952380952381
                  , -7.142857142857142,  -8.57142857142857, -10.0, -11.428571428571427, -12.857142857142854
                  , -7.142857142857141,  -8.57142857142857, -10.0, -11.428571428571427, -12.857142857142854
                  , -7.142857142857141,  -8.57142857142857, -10.0, -11.428571428571427, -12.857142857142854
                  , -7.142857142857141,  -8.57142857142857, -10.0, -11.428571428571427, -12.857142857142854 ]
                m = runGradientDescentIteration x y zeros alpha lambda temp
            m `shouldBe` expected


module BuiltIn.Stats (builtInStats) where

import qualified Data.Map as M
import qualified Data.Vector as V
import           Numeric.SpecFunctions
import           Statistics.Distribution
import           Statistics.Distribution.Binomial
import           Statistics.Distribution.ChiSquared
import           Statistics.Distribution.Exponential
import           Statistics.Distribution.FDistribution
import           Statistics.Distribution.Gamma
import           Statistics.Distribution.Hypergeometric
import           Statistics.Distribution.StudentT
import qualified Statistics.Sample as SS

import           BuiltIn.Common
import           Type
import           Types

-- | Truncate a double back to a double
dTrunc :: Double -> Double
dTrunc x = fromIntegral (truncate x :: Integer)

biAveDev :: BuiltIn
biAveDev = BuiltIn
    { evalVal = aveDev
    , emitVal = const "AVEDEV"
    , typeSig = typeList typeNum :-> typeNum
    , argHelp = "[numbers]"
    , addHelp = Nothing
    }

aveDev :: [Value] -> Interpreter EvalError Value
aveDev [VList xs]
    | length xs > 255 = biErr "Too many arguments (>255)"
    | otherwise = do
        xs' <- vListToDbls xs
        let mn = SS.mean $ V.fromList xs'
        let var = fmap (\x -> abs (mn - x)) xs'
        return . VNum . SS.mean $ V.fromList var
aveDev _ = infError

biAvg :: BuiltIn
biAvg = BuiltIn
    { evalVal = avg
    , emitVal = const "AVERAGE"
    , typeSig = typeList typeNum :-> typeNum
    , argHelp = "[numbers]"
    , addHelp = Nothing
    }

avg :: [Value] -> Interpreter EvalError Value
avg [VList xs]
    | length xs > 255 = biErr "Too many arguments (>255)"
    | otherwise = do
        xs' <- vListToDbls xs
        return . VNum . SS.mean $ V.fromList xs'
avg _ = infError

biBinom :: BuiltIn
biBinom = BuiltIn
    { evalVal = binom
    , emitVal = const "BINOMDIST"
    , typeSig = typeNum :-> typeNum :-> typeNum :-> typeBool :-> typeNum
    , argHelp = "number_s trials probability_s cumulative"
    , addHelp = Nothing
    }

binom :: [Value] -> Interpreter EvalError Value
binom [VNum num, VNum trls, VNum prob, VBool cum]
    | prob < 0 || prob > 1 = biErr "Probability in binomdist must be between 0 and 1"
    | num  < 0 = biErr "Number of successes in binomdist cannot be negative"
    | num > trls = biErr "Successes > trials is not allowed in binomdist"
    | otherwise = if cum
        then return . VNum $ cumulative  dist (dTrunc num)
        else return . VNum $ probability dist (truncate num)
  where
    dist   = binomial (truncate trls) prob
binom _         = infError

biChiDist :: BuiltIn
biChiDist = BuiltIn
    { evalVal = chiDist
    , emitVal = const "CHIDIST"
    , typeSig = typeNum :-> typeNum :-> typeNum
    , argHelp = "x degrees_freedom"
    , addHelp = Nothing
    }

chiDist :: [Value] -> Interpreter EvalError Value
chiDist [VNum x, VNum df]
    | x < 0 = biErr "First argument to chidist must be a positive number"
    | df < 1  = biErr "Degrees of freedom for chidist must be 1 or greater"
    | df > 10**10 = biErr "Degrees of freedom for chidist too large"
    | otherwise = return . VNum $ complCumulative dist x
  where
    dist = chiSquared (truncate df)
chiDist _ = infError

{-
biChiInv :: BuiltIn
biChiInv = BuiltIn
    { evalVal = chiInv
    , emitVal = const "CHIINV""
    , typeSig = typeNum :-> typeNum :-> typeNum
    , argHelp = "probability degrees_freedom"
    , addHelp = Nothing
    }

chiInv :: [Value] -> Interpreter EvalError Value
chiInv [VNum prob, VNum df]
    | prob < 0 || prob > 1 = biErr "Probability in chiinv must be between 0 and 1"
    | df < 1  = biErr "Degrees of freedom for chiinv must be 1 or greater"
    | df > 10**10 = biErr "Degrees of freedom for chiinv too large"
    | otherwise = return . VNum $ cumulative dist prob
  where
    dist = chiSquared (truncate df)
chiInv _ = infError
-}

biConfd :: BuiltIn
biConfd = BuiltIn
    { evalVal = confd
    , emitVal = const "CONFIDENCE"
    , typeSig = typeNum :-> typeNum :-> typeNum :-> typeNum
    , argHelp = "alpha standard_dev size"
    , addHelp = Nothing
    }

confd :: [Value] -> Interpreter EvalError Value
confd [VNum alph, VNum std, VNum size]
    | alph <= 0 || alph >= 1 = biErr "Alpha for confidence must be between 0 and 1"
    | size < 1 = biErr "Sample size in confidence must be greater than one"
    | std <= 0 = biErr "Standard deviation for confidence must be >= 0"
    | otherwise = return $ VNum $ cv * se
  where
    se = std / sqrt (dTrunc size)
    df = size - 1
    cp = 1 - alph/2
    cv = quantile (studentT df) cp
confd _ = infError

biExpDist :: BuiltIn
biExpDist = BuiltIn
    { evalVal = expDist
    , emitVal = const "EXPONDIST"
    , typeSig = typeNum :-> typeNum :-> typeNum :-> typeNum
    , argHelp = "x lambda cumulative"
    , addHelp = Nothing
    }

expDist :: [Value] -> Interpreter EvalError Value
expDist [VNum x, VNum lam, VBool cum]
    | x < 0 = biErr "First paramter to expondist must be >= 0"
    | lam <= 0 = biErr "Lambda must be > 0 in expondist"
    | otherwise = if cum
        then return . VNum $ cumulative dist x
        else return . VNum $ density dist x
  where
    dist = exponential lam
expDist _ = infError

biFDist :: BuiltIn
biFDist = BuiltIn
    { evalVal = fDist
    , emitVal = const "FDIST"
    , typeSig = typeNum :-> typeNum :-> typeNum :-> typeNum
    , argHelp = "x degrees_freedom1 degrees_freedom2"
    , addHelp = Nothing
    }

fDist :: [Value] -> Interpreter EvalError Value
fDist [VNum x, VNum df1, VNum df2]
    | x < 0 = biErr "First argument to fdist must be positive"
    | df1 < 1 || df1 >= 10**10 = biErr "fdist numerator degrees of freedom out of range"
    | df2 < 1 || df2 >= 10**10 = biErr "fdist denominator degrees of freedom out of range"
    | otherwise = return . VNum $ complCumulative dist x
  where
    dist = fDistribution (truncate df1) (truncate df2)
fDist _ = infError

biFisher :: BuiltIn
biFisher = BuiltIn
    { evalVal = fisher
    , emitVal = const "FISHER"
    , typeSig = typeNum :-> typeNum
    , argHelp = "x"
    , addHelp = Nothing
    }

fisher :: [Value] -> Interpreter EvalError Value
fisher [VNum x]
    | x >= 1 || x <= -1 = biErr "fisher requires an argument between -1 and 1"
    | otherwise = return . VNum $ atanh x
fisher _ = infError

biFisherInv :: BuiltIn
biFisherInv = BuiltIn
    { evalVal = fisherinv
    , emitVal = const "FISHERINV"
    , typeSig = typeNum :-> typeNum
    , argHelp = "y"
    , addHelp = Nothing
    }

fisherinv :: [Value] -> Interpreter EvalError Value
fisherinv [VNum x] = return . VNum $ tanh x
fisherinv _ = infError

biGamDist :: BuiltIn
biGamDist = BuiltIn
    { evalVal = gamDist
    , emitVal = const "GAMMADIST"
    , typeSig = typeNum :-> typeNum :-> typeNum :-> typeBool :-> typeNum
    , argHelp = "x alpha beta cumulative"
    , addHelp = Nothing
    }

gamDist :: [Value] -> Interpreter EvalError Value
gamDist [VNum x, VNum alph, VNum beta, VBool cum]
    | x < 0 = biErr "gamma requires its first argument to be positive"
    | alph <= 0 = biErr "gammadist requires alpha > 0"
    | beta <= 0 = biErr "gammadist requires beta > 0"
    | otherwise = if cum
        then return . VNum $ cumulative dist x
        else return . VNum $ density dist x
  where
    dist = gammaDistr alph beta
gamDist _ = infError

biGamInv :: BuiltIn
biGamInv = BuiltIn
    { evalVal = gamInv
    , emitVal = const "GAMMAINV"
    , typeSig = typeNum :-> typeNum :-> typeNum :-> typeNum
    , argHelp = "probability alpha beta"
    , addHelp = Nothing
    }

gamInv :: [Value] -> Interpreter EvalError Value
gamInv [VNum p, VNum alph, VNum beta]
    | p < 0 || p > 1 = biErr "gammainv requires probability to be >= 0 and <= 1"
    | alph <= 0 = biErr "gammainv requires alpha > 0"
    | beta <= 0 = biErr "gammainv requires beta > 0"
    | otherwise = return . VNum $ quantile dist p
  where
    dist = gammaDistr alph beta
gamInv _ = infError

biGamLn :: BuiltIn
biGamLn = BuiltIn
    { evalVal = gamLn
    , emitVal = const "GAMMALN"
    , typeSig = typeNum :-> typeNum
    , argHelp = "x"
    , addHelp = Nothing
    }

gamLn :: [Value] -> Interpreter EvalError Value
gamLn [VNum x]
    | x <= 0 = biErr "gammaln requires its argument be > 0"
    | otherwise = return . VNum $ logGammaL x
gamLn _ = infError

biHGeoDist :: BuiltIn
biHGeoDist = BuiltIn
    { evalVal = hgeoDist
    , emitVal = const "HYPGEOMDIST"
    , typeSig = typeNum :-> typeNum :-> typeNum :-> typeNum :-> typeNum
    , argHelp = "sample_s number_sample population_s number_population"
    , addHelp = Nothing
    }

hgeoDist :: [Value] -> Interpreter EvalError Value
hgeoDist [VNum sam, VNum num, VNum pop, VNum psiz]
    | sam < 0 = biErr "hypgeomdist sample_s must be >=0"
    | sam > min num pop = biErr "hypgeomdist sample_s too large (> number_sample or population_s)"
    | num <= 0 = biErr "hypgeomdist number_sample must be > 0"
    | num > psiz = biErr "hypgeomdist number_sample too large (> number_population)"
    | pop <= 0 = biErr "hypgeomdist population_s must be > 0"
    | pop > psiz = biErr "hypgeomdist population_s too large (> number_population)"
    | psiz <= 0 = biErr "hypgeomdist number_population must be > 0"
    | otherwise = return . VNum $ probability dist $ truncate sam
  where
    dist = hypergeometric (truncate pop) (truncate psiz) (truncate num) -- psiz
hgeoDist _ = infError

builtInStats :: M.Map String BuiltIn
builtInStats = M.fromList
    [ ("avedev",      biAveDev)
    , ("average",     biAvg)
    , ("binomdist",   biBinom)
    , ("chidist",     biChiDist)
--  , ("chiinv",      biChiInv)
    , ("confidence",  biConfd)
    , ("expondist",   biExpDist)
    , ("fdist",       biFDist)
    , ("fisher",      biFisher)
    , ("fisherinv",   biFisherInv)
    , ("gammadist",   biGamDist)
    , ("gammainv",    biGamInv)
    , ("gammaln",     biGamLn)
    , ("hypgeomdist", biHGeoDist)
    ]


-----------------------------------------------------------------------------
-- |
-- Module      :  Math.Tensor.Internal.LinearAlgebra
-- Copyright   :  (c) 2019 Tobias Reinhart and Nils Alex
-- License     :  MIT
-- Maintainer  :  tobi.reinhart@fau.de, nils.alex@fau.de
--
-- Gaussian elimination algorithm based on hmatrix.
-----------------------------------------------------------------------------

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}

module Math.Tensor.Internal.LinearAlgebra (
-- * Gaussian Elimination
gaussianST, gaussianFFST,
gaussian, gaussianFF,
rrefST,
rref,
-- * Linearly Independent Columns
independentColumns, independentColumnsFF, independentColumnsRREF,
independentColumnsVerifiedFF,
independentColumnsMat, independentColumnsMatFF, independentColumnsMatRREF,
-- * Pivots
pivotsU, pivotsUFF,
findPivotMax, findPivotMaxFF, findRowPivot,
isref, isrref, isrref', verify)

where

import Numeric.LinearAlgebra
import Numeric.LinearAlgebra.Data
import Numeric.LinearAlgebra.Devel

import Debug.Trace (trace)

import Data.List (maximumBy)

import Control.Monad
import Control.Monad.ST

-- | Returns the pivot columns of an upper triangular matrix.
--
-- @
-- λ let mat = (3 >< 4) [1, 0, 2, -3, 0, 0, 1, 0, 0, 0, 0, 0]
-- λ mat
-- (3><4)
--  [ 1.0, 0.0, 2.0, -3.0
--  , 0.0, 0.0, 1.0,  0.0
--  , 0.0, 0.0, 0.0,  0.0 ]
-- λ pivotsU mat
-- [0,2]
-- @
--

pivotsU :: Matrix Double -> [Int]
pivotsU mat = go (0,0)
  where
    go (i,j)
      = case findPivot mat e (i,j) of
          Nothing       -> []
          Just (i', j') -> j' : go (i'+1, j'+1)
    maxAbs = maximum $ map (maximum . map abs) $ toLists mat
    e = eps * maxAbs

pivotsUFF :: Matrix Z -> [Int]
pivotsUFF mat = go (0,0)
  where
    go (i,j)
      = case findPivotFF mat (i,j) of
          Nothing       -> []
          Just (i', j') -> j' : go (i'+1, j'+1)

eps :: Double
eps = 1e-12

-- find next pivot in upper triangular matrix

findPivotFF :: Matrix Z -> (Int, Int) -> Maybe (Int, Int)
findPivotFF mat (i, j)
    | n == j = Nothing
    | m == i = Nothing
    | otherwise = case nonZeros of
                    []          -> if n == j+1
                                   then Nothing
                                   else findPivotFF mat (i, j+1)
                    (pi, pj):_  -> Just (pi, pj+j)
    where
        m = rows mat
        n = cols mat
        col = mat ¿ [j]
        nonZeros = filter (\(i', _) -> i' >= i) $ find (/= 0) col

findPivot :: Matrix Double -> Double -> (Int, Int) -> Maybe (Int, Int)
findPivot mat e (i, j)
    | n == j = Nothing
    | m == i = Nothing
    | otherwise = case nonZeros of
                    []          -> if n == j+1
                                   then Nothing
                                   else findPivot mat e (i, j+1)
                    (pi, pj):_  -> Just (pi, pj+j)
    where
        m = rows mat
        n = cols mat
        col = mat ¿ [j]
        nonZeros = filter (\(i', _) -> i' >= i) $ find (not . (< e) . abs) col

-- | Find pivot element below position (i, j) with greatest absolute value in the ST monad.

findPivotMaxFF :: Int -> Int -> Int -> Int -> STMatrix s Z -> ST s (Maybe (Int, Int))
findPivotMaxFF m n i j mat
    | n == j = return Nothing
    | m == i = return Nothing
    | otherwise =
        do
          col      <- mapM (\i' -> do
                                    x <- readMatrix mat i' j
                                    return (i', x))
                      [i..m-1]
          let nonZeros = filter ((/= 0) . snd) col
          case nonZeros of
            []        -> if n == j+1
                         then return Nothing
                         else findPivotMaxFF m n i (j+1) mat
            (pi,_):_  -> return $ Just (pi, j)

findPivotMax :: Int -> Int -> Int -> Int -> STMatrix s Double -> ST s (Maybe (Int, Int))
findPivotMax m n i j mat
    | n == j = return Nothing
    | m == i = return Nothing
    | otherwise =
        do
          col      <- mapM (\i' -> do
                                    x <- readMatrix mat i' j
                                    return (i', abs x))
                      [i..m-1]
          let nonZeros = filter (not . (<eps) . abs . snd) col
          let (pi, _) = maximumBy (\(_, x) (_, y) -> x `compare` y) nonZeros
          case nonZeros of
            [] -> if n == j+1
                  then return Nothing
                  else findPivotMax m n i (j+1) mat
            _  -> return $ Just (pi, j)

-- gaussian elimination of sub matrix below position (i, j)

findRowPivot :: Int -> Int -> Int -> Int -> STMatrix s Z -> ST s (Maybe Int)
findRowPivot m n i j mat
    | j + 1 > n       = error "out of bounds" -- return Nothing
    | i + 1 > min m n = error "out of bounds" -- return Nothing
    | otherwise =
        do
         row <- mapM (\j' -> do
                              x <- readMatrix mat i j'
                              return (j', x))
                [0 .. j]
         let nonZeros = filter ((/=0) . snd) row
         case nonZeros of
           []        -> return Nothing
           (pj, _):_ -> return $ Just pj

backwardFF' :: Int -> Int -> Int -> Int -> STMatrix s Z -> ST s ()
backwardFF' m n i j mat
      | i == 0 = return ()
      | otherwise = do
    mat' <- freezeMatrix mat
    iPivot' <- findRowPivot m n i j mat
    case iPivot' of
        Nothing -> backwardFF' m n (i-1) j mat
        Just pj -> do
                    pv <- readMatrix mat i pj
                    mapM_ (reduce pv pj) [0 .. i-1]
                    backwardFF' m n (i-1) (pj-1) mat
  where
    reduce pv pj r = do
                      Just pr <- findRowPivot m n r pj mat
                      -- prv <- readMatrix mat r pr
                      pjv <- readMatrix mat r pj
                      if pjv == 0
                        then return ()
                        else
                         let op1 = SCAL pv (Row r) (FromCol pr)
                             op2 = AXPY (-pjv) i r (FromCol pj)
                         in do
                             rowOper op1 mat
                             rowOper op2 mat
                             g <- foldM (\acc c -> fmap (fromIntegral . gcd acc . fromIntegral) $ readMatrix mat r c) 0 [pr .. n-1]
                             if g == 0
                               then return()
                               else mapM_ (\c -> modifyMatrix mat r c (`quot` g)) [pr .. n-1]

gaussianFF' :: Int -> Int -> Int -> Int -> STMatrix s Z -> ST s ()
gaussianFF' m n i j mat = do
    iPivot' <- findPivotMaxFF m n i j mat
    case iPivot' of
        Nothing     -> return ()
        Just (r, p) -> do
                          rowOper (SWAP i r (FromCol j)) mat
                          pv <- readMatrix mat i p
                          mapM_ (reduce pv p) [i+1 .. m-1]
                          gaussianFF' m n (i+1) (p+1) mat
  where
    reduce pv p r = do
                      rv <- readMatrix mat r p
                      if rv == 0
                        then return ()
                        else
                         let op1 = SCAL pv (Row r) (FromCol p)
                             op2 = AXPY (-rv) i r (FromCol p)
                         in do
                             rowOper op1 mat
                             rowOper op2 mat
                             g <- foldM (\acc c -> fmap (fromIntegral . gcd acc . fromIntegral) $ readMatrix mat r c) 0 [p .. n-1]
                             if g == 0
                               then return()
                               else mapM_ (\c -> modifyMatrix mat r c (`quot` g)) [p .. n-1]

gaussian' :: Int -> Int -> Int -> Int -> STMatrix s Double -> ST s ()
gaussian' m n i j mat = do
    iPivot' <- findPivotMax m n i j mat
    case iPivot' of
        Nothing     -> return ()
        Just (r, p) -> do
                          rowOper (SWAP i r (FromCol j)) mat
                          pv <- readMatrix mat i p
                          mapM_ (reduce pv p) [i+1 .. m-1]
                          gaussian' m n (i+1) (p+1) mat
  where
    reduce pv p r = do
                      rv <- readMatrix mat r p
                      if abs rv < eps
                        then return ()
                        else
                         let frac = -rv / pv
                             op = AXPY frac i r (FromCol p)
                         in do
                             rowOper op mat
                             mapM_ (\j' -> modifyMatrix mat r j' (\x -> if abs x < eps then 0 else x)) [p..n-1]

-- | Gaussian elimination perfomed in-place in the @'ST'@ monad.

gaussianFFST :: Int -> Int -> STMatrix s Z -> ST s ()
gaussianFFST m n = gaussianFF' m n 0 0

gaussianST :: Int -> Int -> STMatrix s Double -> ST s ()
gaussianST m n = gaussian' m n 0 0

rrefST :: Int -> Int -> STMatrix s Z -> ST s ()
rrefST m n mat = do
                    gaussianFF' m n 0 0 mat
                    backwardFF' m n (r'-1) (n-1) mat
    where
        r' = min m n

-- | Gaussian elimination as pure function. Involves a copy of the input matrix.
--
-- @
-- λ let mat = (3 >< 4) [1, 1, -2, 0, 0, 2, -6, -4, 3, 0, 3, 1]
-- λ mat
-- (3><4)
--  [ 1.0, 1.0, -2.0,  0.0
--  , 0.0, 2.0, -6.0, -4.0
--  , 3.0, 0.0,  3.0,  1.0 ]
-- λ gaussian mat
-- (3><4)
--  [ 3.0, 0.0,  3.0,                1.0
--  , 0.0, 2.0, -6.0,               -4.0
--  , 0.0, 0.0,  0.0, 1.6666666666666667 ]
-- @
--

isref :: (Element a, Num a, Ord a, Container Vector a) => Matrix a -> Bool
isref mat = case pivot of
              []      -> True
              (r,p):_ -> if r > 0
                         then False
                         else let leftMat  = mat ?? (Drop 1, Take (p+1))
                                  rightMat = mat ?? (Drop 1, Drop (p+1))
                                  leftZero = null $ find (/=0) leftMat
                                  rightRef = isref rightMat
                              in leftZero && rightRef
    where
        pivot = find (/=0) mat

isrref' :: (Element a, Num a, Ord a, Container Vector a) => Int -> Matrix a -> Bool
isrref' r mat = case pivot of
              []       -> True
              (r',p):_ -> if r' > 0
                          then False
                          else let leftMat  = subMat ?? (Drop 1, Take (p+1))
                                   col      = mat ¿ [p]
                                   colSingleton = case find (/=0) col of
                                                    [_] -> True
                                                    _   -> False
                                   leftZero = null $ find (/=0) leftMat
                                   nextRref = isrref' (r+1) mat
                               in leftZero && colSingleton && nextRref
    where
        subMat = mat ?? (Drop r, All)
        pivot  = find (/=0) subMat

isrref :: (Element a, Num a, Ord a, Container Vector a) => Matrix a -> Bool
isrref = isrref' 0

rref :: Matrix Z -> Matrix Z
rref mat = runST $ do
    matST <- thawMatrix mat
    rrefST m n matST
    freezeMatrix matST
  where
    m = rows mat
    n = cols mat

gaussianFF :: Matrix Z -> Matrix Z
gaussianFF mat = runST $ do
    matST <- thawMatrix mat
    gaussianFFST m n matST
    freezeMatrix matST
  where
    m = rows mat
    n = cols mat

gaussian :: Matrix Double -> Matrix Double
gaussian mat = runST $ do
    matST <- thawMatrix mat
    gaussianST m n matST
    freezeMatrix matST
  where
    m = rows mat
    n = cols mat

-- | Returns the indices of a maximal linearly independent subset of the columns
--   in the matrix.
--
-- @
-- λ let mat = (3 >< 4) [1, 1, -2, 0, 0, 2, -6, -4, 3, 0, 3, 1]
-- λ mat
-- (3><4)
--  [ 1.0, 1.0, -2.0,  0.0
--  , 0.0, 2.0, -6.0, -4.0
--  , 3.0, 0.0,  3.0,  1.0 ]
-- λ independentColumns mat
-- [0,1,3]
-- @
--

independentColumnsRREF :: Matrix Z -> [Int]
independentColumnsRREF mat = pivotsUFF mat'
    where
        mat' = rref mat

independentColumnsFF :: Matrix Z -> [Int]
independentColumnsFF mat = pivotsUFF mat'
    where
        mat' = gaussianFF mat

independentColumnsVerifiedFF :: Matrix Z -> [Int]
independentColumnsVerifiedFF mat
        | isref mat' && verify mat mat'
                     = pivotsUFF mat'
        | otherwise  = error "could not verify row echelon form"
    where
        mat' = gaussianFF mat

independentColumns :: Matrix Double -> [Int]
independentColumns mat = pivotsU mat'
    where
        mat' = gaussian mat

-- | Returns a sub matrix containing a maximal linearly independent subset of
--   the columns in the matrix.
--
-- @
-- λ let mat = (3 >< 4) [1, 1, -2, 0, 0, 2, -6, -4, 3, 0, 3, 1]
-- λ mat
-- (3><4)
--  [ 1.0, 1.0, -2.0,  0.0
--  , 0.0, 2.0, -6.0, -4.0
--  , 3.0, 0.0,  3.0,  1.0 ]
-- λ independentColumnsMat mat
-- (3><3)
--  [ 1.0, 1.0,  0.0
--  , 0.0, 2.0, -4.0
--  , 3.0, 0.0,  1.0 ]
-- @
--

verify :: Matrix Z -> Matrix Z -> Bool
verify mat ref = rank1 == rank2 && rank1 == rank3
    where
        matD = fromZ mat :: Matrix Double
        refD = fromZ ref :: Matrix Double
        rank1 = rank matD
        rank2 = rank refD
        rank3 = rank $ matD === refD

independentColumnsMatRREF :: Matrix Z -> Matrix Z
independentColumnsMatRREF mat =
  case independentColumnsRREF mat of
    [] -> (rows mat >< 1) $ repeat 0
    cs -> mat ¿ cs

independentColumnsMatFF :: Matrix Z -> Matrix Z
independentColumnsMatFF mat =
  case independentColumnsFF mat of
    [] -> (rows mat >< 1) $ repeat 0
    cs -> mat ¿ cs

independentColumnsMat :: Matrix Double -> Matrix Double
independentColumnsMat mat =
  case independentColumns mat of
    [] -> (rows mat >< 1) $ repeat 0
    cs -> mat ¿ cs


import Data.Complex (cis, phase)
import Data.List.Split (splitOn)
import Text.Printf (printf)

timeToRadians :: String -> Float
timeToRadians time =
        let hours:minutes:seconds:_ = splitOn ":" time
            s = fromIntegral (read seconds :: Int)
            m = fromIntegral (read minutes :: Int)
            h = fromIntegral (read hours :: Int)
        in  (2*pi)*(h+ (m + s/60.0 )/60.0 )/24.0

radiansToTime :: Float -> String
radiansToTime  r =
        let tau = pi*2
            (_,fDay) = properFraction (r / tau) :: (Int, Float)
            fDayPositive = if fDay < 0 then 1.0+fDay else fDay
            (hours, fHours) = properFraction $ 24.0 * fDayPositive
            (minutes, fMinutes) = properFraction $ 60.0 * fHours
            seconds = 60.0 * fMinutes
        in printf "%0d" (hours::Int) ++ ":" ++ printf "%0d" (minutes::Int) ++ ":" ++ printf "%0.0f" (seconds::Float)

meanAngle :: [Float] -> Float
meanAngle = phase . sum . map cis

main :: IO ()
main = putStrLn $ radiansToTime $ meanAngle $ map timeToRadians ["23:00:17", "23:40:20", "00:12:45", "00:17:19"]


module LossFunction
    ( meanSquaredError
    , crossEntropyError
    ) where

import Numeric.LinearAlgebra

meanSquaredError :: (Container c b, Num (c b), Floating b) => c b -> c b -> b
meanSquaredError x y = (*0.5) . sumElements $ (x-y)^2

crossEntropyError :: (Container c b, Num (c b), Floating b) => c b -> c b -> b
crossEntropyError x y = (*(-1)) . sumElements $ y * cmap (\x -> log(x+1e-7)) x