{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE BangPatterns, DeriveDataTypeable, RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module      : Gauge.Analysis
-- Copyright   : (c) 2009-2014 Bryan O'Sullivan
--
-- License     : BSD-style
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : GHC
--
-- Analysis code for benchmarks.

-- XXX Do we really want to expose this module to users? This is all internal.
-- Most of the exports are not even used by Gauge itself outside of this
-- module.

module Gauge.Analysis
    ( Outliers(..)
    , OutlierEffect(..)
    , OutlierVariance(..)
    , Report
    , SampleAnalysis(..)
    , analyseSample
    , scale
    , analyseBenchmark
    , analyseMean
    , countOutliers
    , classifyOutliers
    , noteOutliers
    , outlierVariance
    , regress
    , benchmark'
    , benchmarkWith'
    ) where

import Control.Applicative
import Control.Arrow (second)
import Control.DeepSeq (NFData(rnf))
import Control.Monad (forM_, when)
import Gauge.Benchmark (Benchmark (..), BenchmarkAnalysis(..), Benchmarkable, runBenchmark)
import Gauge.IO.Printf (note, printError, prolix, rewindClearLine)
import Gauge.Main.Options (defaultConfig, Config(..), Verbosity (..),
                           DisplayMode (..))
import Gauge.Measurement (Measured(measTime), secs, rescale, measureKeys,
                          measureAccessors_, validateAccessors, renderNames)
import Gauge.Monad (Gauge, askConfig, gaugeIO, Crit(..), askCrit, withConfig)
import Gauge.Format
import qualified Gauge.CSV as CSV
import Data.Data (Data, Typeable)
import Data.Int (Int64)
import Data.IORef (IORef, readIORef, writeIORef)
import Gauge.ListMap (Map)
import Data.Maybe (fromJust, isJust)
import Data.Traversable
import GHC.Generics (Generic)
import Statistics.Function (sort)
import Statistics.Quantile (weightedAvg, Sorted(..))
import Statistics.Regression (bootstrapRegress, olsRegress)
import Statistics.Resampling (Estimator(..),resample)
import Statistics.Sample (mean)
import Statistics.Sample.KernelDensity (kde)
import Statistics.Types (Sample, Estimate(..),ConfInt(..),confidenceInterval
                        ,cl95,confidenceLevel)
import System.Random.MWC (GenIO, createSystemRandom)
import Text.Printf (printf)
import qualified Gauge.ListMap as Map
import qualified Data.Vector as V
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U
import qualified Statistics.Resampling.Bootstrap as B
import qualified Statistics.Types                as B
import qualified Statistics.Types as St
import Prelude hiding (sequence, mapM)

-- | Outliers from sample data, calculated using the boxplot
-- technique.
data Outliers = Outliers {
      samplesSeen :: !Int64
    , lowSevere   :: !Int64
    -- ^ More than 3 times the interquartile range (IQR) below the
    -- first quartile.
    , lowMild     :: !Int64
    -- ^ Between 1.5 and 3 times the IQR below the first quartile.
    , highMild    :: !Int64
    -- ^ Between 1.5 and 3 times the IQR above the third quartile.
    , highSevere  :: !Int64
    -- ^ More than 3 times the IQR above the third quartile.
    } deriving (Eq, Show, Typeable, Data, Generic)

instance NFData Outliers

-- | A description of the extent to which outliers in the sample data
-- affect the sample mean and standard deviation.
data OutlierEffect = Unaffected -- ^ Less than 1% effect.
                   | Slight     -- ^ Between 1% and 10%.
                   | Moderate   -- ^ Between 10% and 50%.
                   | Severe     -- ^ Above 50% (i.e. measurements
                                -- are useless).
                     deriving (Eq, Ord, Show, Typeable, Data, Generic)

instance NFData OutlierEffect

outliersEmpty :: Outliers
outliersEmpty = Outliers 0 0 0 0 0

addOutliers :: Outliers -> Outliers -> Outliers
addOutliers (Outliers s a b c d) (Outliers t w x y z) =
    Outliers (s+t) (a+w) (b+x) (c+y) (d+z)
{-# INLINE addOutliers #-}

-- | Analysis of the extent to which outliers in a sample affect its
-- standard deviation (and to some extent, its mean).
data OutlierVariance = OutlierVariance {
      ovEffect   :: OutlierEffect
    -- ^ Qualitative description of effect.
    , ovDesc     :: String
    -- ^ Brief textual description of effect.
    , ovFraction :: Double
    -- ^ Quantitative description of effect (a fraction between 0 and 1).
    } deriving (Eq, Show, Typeable, Data, Generic)

instance NFData OutlierVariance where
    rnf OutlierVariance{..} = rnf ovEffect `seq` rnf ovDesc `seq` rnf ovFraction

-- | Results of a linear regression.
data Regression = Regression {
    regResponder  :: String
    -- ^ Name of the responding variable.
  , regCoeffs     :: Map String (St.Estimate St.ConfInt Double)
    -- ^ Map from name to value of predictor coefficients.
  , regRSquare    :: St.Estimate St.ConfInt Double
    -- ^ R² goodness-of-fit estimate.
  } deriving (Eq, Show, Typeable, Generic)

instance NFData Regression where
    rnf Regression{..} =
      rnf regResponder `seq` rnf regCoeffs `seq` rnf regRSquare

-- | Result of a bootstrap analysis of a non-parametric sample.
data SampleAnalysis = SampleAnalysis {
      anRegress    :: [Regression]
      -- ^ Estimates calculated via linear regression.
    , anMean       :: St.Estimate St.ConfInt Double
      -- ^ Estimated mean.
    , anStdDev     :: St.Estimate St.ConfInt Double
      -- ^ Estimated standard deviation.
    , anOutlierVar :: OutlierVariance
      -- ^ Description of the effects of outliers on the estimated
      -- variance.
    } deriving (Eq, Show, Typeable, Generic)

instance NFData SampleAnalysis where
    rnf SampleAnalysis{..} =
        rnf anRegress `seq` rnf anMean `seq`
        rnf anStdDev `seq` rnf anOutlierVar

-- | Data for a KDE chart of performance.
data KDE = KDE {
      kdeType   :: String
    , kdeValues :: U.Vector Double
    , kdePDF    :: U.Vector Double
    } deriving (Eq, Show, Typeable, Data, Generic)

instance NFData KDE where
    rnf KDE{..} = rnf kdeType `seq` rnf kdeValues `seq` rnf kdePDF

-- | Report of a sample analysis.
data Report = Report {
      reportName     :: String
      -- ^ The name of this report.
    , reportKeys     :: [String]
      -- ^ See 'measureKeys'.
    , reportMeasured :: V.Vector Measured
      -- ^ Raw measurements.
    , reportAnalysis :: SampleAnalysis
      -- ^ Report analysis.
    , reportOutliers :: Outliers
      -- ^ Analysis of outliers.
    , reportKDEs     :: [KDE]
      -- ^ Data for a KDE of times.
    } deriving (Eq, Show, Typeable, Generic)

instance NFData Report where
    rnf Report{..} =
      rnf reportName `seq` rnf reportKeys `seq`
      rnf reportMeasured `seq` rnf reportAnalysis `seq` rnf reportOutliers `seq`
      rnf reportKDEs

-- | Classify outliers in a data set, using the boxplot technique.
classifyOutliers :: Sample -> Outliers
classifyOutliers sa = U.foldl' ((. outlier) . addOutliers) outliersEmpty ssa
    where outlier e = Outliers {
                        samplesSeen = 1
                      , lowSevere = if e <= loS && e < hiM then 1 else 0
                      , lowMild = if e > loS && e <= loM then 1 else 0
                      , highMild = if e >= hiM && e < hiS then 1 else 0
                      , highSevere = if e >= hiS && e > loM then 1 else 0
                      }
          !loS = q1 - (iqr * 3)
          !loM = q1 - (iqr * 1.5)
          !hiM = q3 + (iqr * 1.5)
          !hiS = q3 + (iqr * 3)
          q1   = weightedAvg 1 4 (Sorted ssa)
          q3   = weightedAvg 3 4 (Sorted ssa)
          ssa  = sort sa
          iqr  = q3 - q1

-- | Compute the extent to which outliers in the sample data affect
-- the sample mean and standard deviation.
outlierVariance
  :: B.Estimate B.ConfInt Double -- ^ Bootstrap estimate of sample mean.
  -> B.Estimate B.ConfInt Double -- ^ Bootstrap estimate of sample
                                 --   standard deviation.
  -> Double                      -- ^ Number of original iterations.
  -> OutlierVariance
outlierVariance µ σ a = OutlierVariance effect desc varOutMin
  where
    ( effect, desc ) | varOutMin < 0.01 = (Unaffected, "no")
                     | varOutMin < 0.1  = (Slight,     "slight")
                     | varOutMin < 0.5  = (Moderate,   "moderate")
                     | otherwise        = (Severe,     "severe")
    varOutMin = (minBy varOut 1 (minBy cMax 0 µgMin)) / σb2
    varOut c  = (ac / a) * (σb2 - ac * σg2) where ac = a - c
    σb        = B.estPoint σ
    µa        = B.estPoint µ / a
    µgMin     = µa / 2
    σg        = min (µgMin / 4) (σb / sqrt a)
    σg2       = σg * σg
    σb2       = σb * σb
    minBy f q r = min (f q) (f r)
    cMax x    = fromIntegral (floor (-2 * k0 / (k1 + sqrt det)) :: Int)
      where
        k1    = σb2 - a * σg2 + ad
        k0    = -a * ad
        ad    = a * d
        d     = k * k where k = µa - x
        det   = k1 * k1 - 4 * σg2 * k0

-- | Count the total number of outliers in a sample.
countOutliers :: Outliers -> Int64
countOutliers (Outliers _ a b c d) = a + b + c + d
{-# INLINE countOutliers #-}

-- | Display the mean of a 'Sample', and characterise the outliers
-- present in the sample.
analyseMean :: Sample
            -> Int              -- ^ Number of iterations used to
                                -- compute the sample.
            -> Gauge Double
analyseMean a iters = do
  let µ = mean a
  _ <- note "mean is %s (%d iterations)\n" (secs µ) iters
  noteOutliers . classifyOutliers $ a
  return µ

-- | Multiply the 'Estimate's in an analysis by the given value, using
-- 'B.scale'.
scale :: Double                 -- ^ Value to multiply by.
      -> SampleAnalysis -> SampleAnalysis
scale f s@SampleAnalysis{..} = s {
                                 anMean = B.scale f anMean
                               , anStdDev = B.scale f anStdDev
                               }

-- | Return a random number generator, creating one if necessary.
--
-- This is not currently thread-safe, but in a harmless way (we might
-- call 'createSystemRandom' more than once if multiple threads race).
getGen :: Gauge GenIO
getGen = memoise gen createSystemRandom

getMeasurement :: (U.Unbox a) => (Measured -> a) -> V.Vector Measured -> U.Vector a
getMeasurement f v = U.convert . V.map f $ v

-- | Memoise the result of an 'IO' action.
--
-- This is not currently thread-safe, but hopefully in a harmless way.
-- We might call the given action more than once if multiple threads
-- race, so our caller's job is to write actions that can be run
-- multiple times safely.
memoise :: (Crit -> IORef (Maybe a)) -> IO a -> Gauge a
memoise ref generate = do
  r <- ref <$> askCrit
  gaugeIO $ do
    mv <- readIORef r
    case mv of
      Just rv -> return rv
      Nothing -> do
        rv <- generate
        writeIORef r (Just rv)
        return rv

toCL :: Maybe Double -> B.CL Double
toCL a =
    case a of
        Nothing -> B.cl95
        Just x -> B.mkCL x

-- | Perform an analysis of a measurement.
analyseSample :: String            -- ^ Experiment name.
              -> V.Vector Measured -- ^ Sample data.
              -> Gauge (Either String Report)
analyseSample name meas = do
  Config{..} <- askConfig
  let ests      = [Mean,StdDev]
      stime     = getMeasurement (measTime . rescale) $ meas
      n         = G.length meas
  _ <- prolix "bootstrapping with %d samples\n" n

  gen <- getGen
  ers <- (sequence <$>) . mapM (\(ps,r) -> regress gen ps r meas) $ ((["iters"],"time"):regressions)
  case ers of
    Left err -> pure $ Left err
    Right rs -> do
      resamps <- gaugeIO $ resample gen ests resamples stime
      let [estMean,estStdDev] = B.bootstrapBCA (toCL confInterval) stime
                                               resamps
          ov = outlierVariance estMean estStdDev (fromIntegral n)
          an = SampleAnalysis
                 { anRegress    = rs
                 , anMean       = estMean
                 , anStdDev     = estStdDev
                 , anOutlierVar = ov
                 }
      return $ Right $ Report
        { reportName     = name
        , reportKeys     = measureKeys
        , reportMeasured = meas
        , reportAnalysis = an
        , reportOutliers = classifyOutliers stime
        , reportKDEs     = [uncurry (KDE "time") (kde 128 stime)]
        }

-- | Regress the given predictors against the responder.
--
-- Errors may be returned under various circumstances, such as invalid
-- names or lack of needed data.
--
-- See 'olsRegress' for details of the regression performed.
regress :: GenIO
        -> [String]             -- ^ Predictor names.
        -> String               -- ^ Responder name.
        -> V.Vector Measured
        -> Gauge (Either String Regression)
regress gen predNames respName meas
    | G.null meas = pure $ Left "no measurements"
    | otherwise   = case validateAccessors predNames respName of
        Left err   -> pure $ Left err
        Right accs -> do
            let unmeasured = [n | (n, Nothing) <- map (second ($ G.head meas)) accs]
            if not (null unmeasured)
                then pure $ Left $ "no data available for " ++ renderNames unmeasured
                else do
                    let (r:ps) = map ((`getMeasurement` meas) . (fromJust .) . snd) accs
                    Config{..} <- askConfig
                    (coeffs,r2) <- gaugeIO $
                        bootstrapRegress gen resamples (toCL confInterval)
                                         olsRegress ps r
                    pure $ Right $ Regression
                        { regResponder = respName
                        , regCoeffs    = Map.fromList (zip (predNames ++ ["y"]) (G.toList coeffs))
                        , regRSquare   = r2
                        }

-- | Display a report of the 'Outliers' present in a 'Sample'.
noteOutliers :: Outliers -> Gauge ()
noteOutliers o = do
  let frac n = (100::Double) * fromIntegral n / fromIntegral (samplesSeen o)
      check :: Int64 -> Double -> String -> Gauge ()
      check k t d = when (frac k > t) $
                    note "  %d (%.1g%%) %s\n" k (frac k) d
      outCount = countOutliers o
  when (outCount > 0) $ do
    _ <- note "found %d outliers among %d samples (%.1g%%)\n"
         outCount (samplesSeen o) (frac outCount)
    check (lowSevere o) 0 "low severe"
    check (lowMild o) 1 "low mild"
    check (highMild o) 1 "high mild"
    check (highSevere o) 0 "high severe"

-- | Analyse a single benchmark.
analyseBenchmark :: String -> V.Vector Measured -> Gauge Report
analyseBenchmark desc meas = do
  Config{..} <- askConfig
  _ <- prolix "%sanalysing with %d resamples\n" rewindClearLine resamples
  -- XXX handle meas being empty
  erp <- analyseSample desc meas
  case erp of
    Left err -> printError "*** Error: %s\n" err
    Right rpt@Report{..} -> do
        let SampleAnalysis{..} = reportAnalysis
            OutlierVariance{..} = anOutlierVar
            wibble = printOverallEffect ovEffect
            (builtin, others) = splitAt 1 anRegress

        gaugeIO $ CSV.write csvFile $ CSV.Row
            [ CSV.string desc
            , CSV.float (estPoint anMean)
            , CSV.float (fst $ confidenceInterval anMean)
            , CSV.float (snd $ confidenceInterval anMean)
            , CSV.float (estPoint anStdDev)
            , CSV.float (fst $ confidenceInterval anStdDev)
            , CSV.float (snd $ confidenceInterval anStdDev)
            ]

        case displayMode of
            StatsTable -> do
              _ <- note "%sbenchmarked %s%s%s\n" rewindClearLine green desc reset
              let r2 n = printf "%.3f R\178" n
              forM_ builtin $ \Regression{..} ->
                case Map.lookup "iters" regCoeffs of
                  Nothing -> return ()
                  Just t  -> bs secs "time" t >> bs r2 "" regRSquare
              bs secs "mean" anMean
              bs secs "std dev" anStdDev
              forM_ others $ \Regression{..} -> do
                _ <- bs r2 (regResponder ++ ":") regRSquare
                forM_ (Map.toList regCoeffs) $ \(prd,val) ->
                  bs (printf "%.3g") ("  " ++ prd) val
              when (verbosity == Verbose || (ovEffect > Slight && verbosity > Quiet)) $ do
                when (verbosity == Verbose) $ noteOutliers reportOutliers
                _ <- note "variance introduced by outliers: %d%% (%s)\n"
                     (round (ovFraction * 100) :: Int) wibble
                return ()

              _ <- traverse
                    (\(k, (a, s, _)) -> reportStat Verbose a s k)
                    measureAccessors_
              _ <- note "\n"
              pure ()
            Condensed -> do
              _ <- note "%s%s%-40s%s " rewindClearLine green desc reset
              bsSmall secs "mean" anMean
              bsSmall secs "( +-" anStdDev
              _ <- note ")\n"
              pure ()

        return rpt
      where bs :: (Double -> String) -> String -> Estimate ConfInt Double -> Gauge ()
            bs f metric e@Estimate{..} =
              note "%s%-20s%s %s%-10s%s (%s .. %s%s)\n" yellow metric reset
                   red (f estPoint) reset
                   (f $ fst $ confidenceInterval e) (f $ snd $ confidenceInterval e)
                   (let cl = confIntCL estError
                        str | cl == cl95 = ""
                            | otherwise  = printf ", ci %.3f" (confidenceLevel cl)
                    in str
                   )
            bsSmall :: (Double -> String) -> String -> Estimate ConfInt Double -> Gauge ()
            bsSmall f metric Estimate{..} =
              note "%s %s%-10s%s" metric red (f estPoint) reset

            reportStat :: Verbosity
                       -> (Measured -> Maybe Double)
                       -> (Double -> String)
                       -> String -> Gauge ()
            reportStat lvl accessor sh msg = do
              let v0 = V.map (accessor . rescale) meas
              -- Print average only if all data points are present
              when (V.all isJust v0) $ do
                  let v = V.map fromJust v0
                      total = V.sum v
                      len = V.length v
                      avg = total / (fromIntegral len)
                  when (verbosity >= lvl && avg > 0.0) $ do
                    note "%-20s %-10s (%s .. %s)\n" msg (sh avg)
                      (sh (V.minimum v)) (sh (V.maximum v))

printOverallEffect :: OutlierEffect -> String
printOverallEffect Unaffected = "unaffected"
printOverallEffect Slight     = "slightly inflated"
printOverallEffect Moderate   = "moderately inflated"
printOverallEffect Severe     = "severely inflated"

-- XXX The original type of these types returned 'Report' type. But the
-- implementation was wrong as it was not running any environment settings on
-- the way to the benchmark. Now, we have used the correct function to do that
-- but unfortunately that function returns void. That can be fixed though if it
-- is important.

-- | Run a benchmark interactively and analyse its performance.
benchmarkWith' :: Config -> Benchmarkable -> IO ()
benchmarkWith' cfg bm = withConfig cfg $
    runBenchmark (const True) (Benchmark "function" bm) (BenchmarkNormal analyseBenchmark)

-- | Run a benchmark interactively and analyse its performanc.
benchmark' :: Benchmarkable -> IO ()
benchmark' = benchmarkWith' defaultConfig


{-# LANGUAGE TemplateHaskell #-}

-- | Inhabited types

module Data.Inhabited where

import Data.Complex
import Data.Int
import Data.Word

import Data.Inhabited.TH

-- | Inhabited types
class Inhabited a
  where
    -- | Example value. An example value does not have to be an agreed-upon
    -- default value. It can really be any value whatsoever.
    example :: a

instance Inhabited Bool             where example = False
instance Inhabited Int8             where example = 0
instance Inhabited Int16            where example = 0
instance Inhabited Int32            where example = 0
instance Inhabited Int64            where example = 0
instance Inhabited Word8            where example = 0
instance Inhabited Word16           where example = 0
instance Inhabited Word32           where example = 0
instance Inhabited Word64           where example = 0
instance Inhabited Float            where example = 0
instance Inhabited Double           where example = 0
instance Inhabited (Complex Float)  where example = 0
instance Inhabited (Complex Double) where example = 0

inhabitedTupleInstances 15


{-# LANGUAGE NoImplicitPrelude, TypeSynonymInstances, RankNTypes, StandaloneDeriving,
ScopedTypeVariables, TypeApplications, GADTs, TypeOperators, DeriveTraversable,
FlexibleInstances, AllowAmbiguousTypes, UndecidableInstances, TypeFamilies, LambdaCase #-}
module Lib
    where
import Numeric.LinearAlgebra
import Control.Category
import Prelude hiding ((.), id)
import Control.Arrow ((***))
someFunc :: IO ()
someFunc = putStrLn "someFunc"

{-
type V a = a -> Double
type D a = a -> Double
D (V a)
type V a  = ContT () Q a -- ContT b Q a = (a ->Q b) -> Q b. Has some way of dealing with a index. Some kind of
SelT -- takes a diag, unsummed?
-- (a -> Q b) -> Q a

newtype Dag a = Dag (a -> Q ())

class Dagger a where
    type Dual :: * -> * -- *?
    dag :: a -> Dual a
instance Dagger (D (Vec a)) where
    type Dual = Vec
    dag (D v) = join $ ContT ()
-- dagger needs to embed a search procedure?

instance Dagger (D (Vec Bool)) where
    type Dual = Vec Bool
    dag (D v) = join $ ContT ()
instance Dagger a b where
    dag :: a -> b
    dag' :: b -> a
instance Dagger k where
    type family Dual :: * -> *
    dag :: k a (Dual a) -- dag'?

-- also a kind of dot product
dag1 :: ((a -> Q ()) -> Q ()) -> (((a -> Q ()) -> Q ()) -> Q ()
dag1 f =

-- it's a kind of dot product.
lift :: f Double -> (a -> Double) -> Double
lift w f = fold (+) $ (mapWithIndex \k v -> (f k) * v) w

-- tensor is a_i b_i, mutiply out without summing
tensor :: f a ->  f a  -> f a
tensor = intersectWith (*)

type V' a = (a -> Q ()) -> Q ()
tensor :: V' a -> V' a -> V' a

dag :: (V' Bool -> Q ()) -> V' Bool
dag f = \g -> True False

dag :: (Bool -> Q ()) -> V' Bool
dag :: (Bool -> Q ()) -> (Bool -> Q ()) -> Q ()
dag f g = (f True) (g True) + (f False) (g False)

dag :: (Bool -> Q ()) -> Q Bool
dag f = (f True) >>= true + (f False) >>= false

dag :: Q Bool -> (Bool -> Q ())
dag xs b = lookup b xs
dag :: Eq a => Q a -> (a -> Q ()) -- maybe Ord
dag xs b = lookup b xs

-- If we mixed Hedges select sat solver with the Q monad?
-- (Bool -> Q Bool) -> Q Bool ? the unsummed trace? diag? Hedgest hing would come out weirder.

true :: () -> Q Bool
true _ = pure True
false :: () -> Q Bool
false _ = pure False

-- the seelect function.
-- (b -> m ()) -> m b

-}

type M = Matrix Double

{-

data BMatrix a b = BMatrix M M M M | Id -- A B C D

instance Category BMatrix where
    id = Id
    Id . x = x
    x . Id = x
    (BMatrix a b c d) . (BMatrix e f g h) = BMatrix <\> where
            q = d + e
            qlu = lupacked q
            qinv = lusolve qlu
            a' = a - (b <> (qinv c))
            b' =  b <> (qinv f)
            c' = g <> (qinv c)
            d' = h - g <> (qinv f)

par :: BMatrix a b -> BMatrix c d -> BMatrix (a,c) (b,d)
par (Matrix a b c d) (BMatrix e f g h) = BMatrix (diagBlock [a,e]) (diagBlock [b,f]) (diagBlock [c,g])  (diagBlock [d,h])
dup = BMatrix a (a,a)
dup = BMatrix (diagBlock [ident,ident]) (ident ||| ident) (ident === ident) (diagBlock [ident,ident])
id = BMatrix ident ident ident ident
avg =
-}
data QuadFun a b = QuadFun {mat :: M, vec :: Vector Double, c :: Double } deriving Show

--data QuadFun a b where
--   QuadFun :: (Bounded a, Bounded b, Enum a, Enum b) => M -> Vector Double -> Double -> QuadFun a b }

-- This is kron product.
instance (Enum a, Enum b, Bounded a) => Enum (a,b) where
  toEnum x =  let (a, b) = quotRem x (fromEnum (maxBound :: a)) in
                (toEnum a   , toEnum b)
  fromEnum (a,b) =  (fromEnum (maxBound :: a)) * (fromEnum a) + (fromEnum b)
  {-
instance (Enum a, Enum b, Bounded a) => Enum (Either a b) where
    toEnum x | x > (fromEnum (maxBound :: a)) = Left (toEnum x)
             | otherwise = Right $ toEnum (x - 1 - (fromEnum (maxBound :: a)))
    fromEnum (Left a) =  fromEnum a
    fromEnum (Right b) =  (fromEnum (maxBound :: a)) + 1 + (fromEnum b)
-}
-- deriving instance (Enum a, Enum b) => Enum (a,b)

count :: forall a. (Enum a, Bounded a) => Int
count = (fromEnum (maxBound @a)) - (fromEnum (minBound @a)) + 1

id ::forall a. (Enum a, Bounded a) => QuadFun a a
id = let s = 2 * (count @ a) in QuadFun (ident s) (konst 0 s) 0

--dup :: QuadFun a (a,a)
--dup  = QuadFun (ident

class (Bounded a, Enum a) => BEnum a where
instance (Bounded a, Enum a) => BEnum a where

t7 :: QuadFun () ()
t7 = QuadFun (konst 4 (2,2)) (konst 7 2) 3

t8 = (mat t7) <\> (vec t7)
t4 = par t7 t7
t9 = (mat t4) <\> (vec t4)

compose :: forall a b c. BEnum b => QuadFun b c -> QuadFun a b -> QuadFun a c
compose (QuadFun m' w' c') (QuadFun m w c) = QuadFun m'' w'' c'' where
   n = count @b
   k = rows m -- assuming square
   l = rows m'
   i = ident n
   q = konst 0 (k-n,n)  === i  -- I underneath zeros
   q' = -i === konst 0 (l-n,n)   -- -i above zeros
   m'' = fromBlocks [[m,    q, 0],
                     [tr q ,0, tr q'],
                     [0,    q', m']]
   w'' = vjoin [w, konst 0 n, w']
   c'' = c + c'

identOut :: forall a b. BEnum b => QuadFun a b -> M
identOut (QuadFun m w c) = konst 0 (k-n,n)  === i  where
    n = count @b
    k = rows m
    i = ident n
identIn :: forall a b. BEnum a => QuadFun a b -> M
identIn (QuadFun m w c) = -i === konst 0 (k-n,n)   where
    n = count @a
    k = rows m
    i = ident n
type a :+: b = Either a b
-- I kind of feel like our sign convention is flipped
par :: forall a b c d. (BEnum a, BEnum b, BEnum c, BEnum d) => QuadFun a c -> QuadFun b d -> QuadFun (a :+: b) (c :+: d)
par x@(QuadFun m w c) y@(QuadFun m' w' c') = QuadFun m'' w'' c'' where
    ia = ident (count @a)
    ib = ident (count @b)
    ia' = identIn x
    ib' = identIn y
    ia't = tr ia'
    ib't = tr ib'
    ic = - ident (count @c)
    id = - ident (count @d)
    ic' = identOut x
    id' = identOut y
    ic't = tr ic'
    id't = tr id'
    n = (count @a) + (count @b)
    n' = (count @c) + (count @d)
    --iab = fromBlocks [[0,0,ia,0], [0,0,0,ib], [ia, 0,0,0], [0,ib,0,0]]
    --iab' = fromBlocks [[tr (identIn x),0],  [0 , tr (identIn y)]]
    --zab = konst 0 (n,n)
    -- should be 2 ins + 2 langrange + 2 matr + 2lagarne + 2 outs = 10x10 block matrix
    m'' = fromBlocks [[0 ,0 , ia, 0, 0, 0, 0 ,0,0,0],
                    [0, 0,  0, ib, 0, 0, 0, 0,0,0 ] ,
                    [ia, 0, 0, 0,  ia't, 0,0,0,0, 0],
                    [0, ib, 0, 0,  0,ib't,0, 0,0 ,0],
                    [0, 0, ia',0,  m, 0 , ic',0,0,0],
                    [0, 0,  0, ib',0, m', 0,id',0,0],
                    [0, 0,  0, 0, ic't,0 ,0,0,ic,0],
                    [0, 0,  0, 0,  0,id't,0,0,0,id],
                    [0, 0,  0, 0,  0, 0,  ic,0,0,0],
                    [0, 0,  0, 0,  0, 0,  0,id,0,0]]
    w'' = vjoin [konst 0 (2*n), w,w', konst 0 (2*n')]
    c'' = c + c'

dup :: forall a. BEnum a => QuadFun a (a,a)
dup = QuadFun m 0 0 where -- 1 input, 2 lagrange mutipliers, and 2 outputs.
    ia = ident (count @a)
    m = fromBlocks [ [0, ia,ia, 0,0],
                     [ia, 0, 0, -ia,0],
                     [0, ia, 0, 0, -ia],
                     [0,-ia, 0, 0, 0 ],
                     [0, 0, -ia, 0,0]]

-- fst...?
-- for snd, we could just leave it alone
-- fuse?
-- swap.
data Void
fuse :: forall a. BEnum a => QuadFun (a,a) Void
fuse = QuadFun m 0 0 where -- 2 inputs, 1 lagrange multiplier.
    ia = ident (count @a)
    m = fromBlocks [[0,0,    ia],
                    [0 ,0 , -ia],
                    [ia, -ia, 0]]

-- The analog for this slicing for convex sets may be to slice the
-- dimensions into in and out dimensions. Then

data Cell a = Cell {phi :: Double, j :: Double, next :: a} deriving (Show, Traversable, Foldable, Functor) -- composition of cell is a statically sized vector. Derive applicative?

instance Applicative Cell where
    pure x = Cell 0 0 x
    (Cell phi1 j1 f) <*> (Cell phi2 j2 x) = Cell (phi1 + phi2) (j1 + j2) (f x) -- ? I doubt this makes any sense.
{-
data Cell a = Cell { phi :: a, j :: a}
type f :+: g = Product f g
gaussK :: Lens ((Cell :+: Cell) a) (Cell a)

gaussK :: -> Lens (Cell :*: f a) -- no Cell is very not this.

type Row = (Cell Cell Cell Cell Cell)

Lens (a, b, other) (b, other)

gaussK :: Lens

data Cell2 f a b = Cell2 {phi :: a , j :: a, next :: f b}
data Cell2 f a = Cell2 {phi :: f Double a , j ::f Double, next :: f a}

-- zipA :: f a -> f b -> f (a,b)
-- zipA x y = (,) <$> x <*> y
-- monProd

fmap2 = fmap . fmap
fmap4 = fmap2 . fmap2
fmap8 = fmap4 . fmap4

zipA x y = (,) <$> x <*> y
zip2 = zipA . (fmap zipA) -- hmm. Maybe we should be using Compose. we're going to need famp2. Compose will get us these instances for free.
zip4 = zip2 . (fmap2 zip2)
zip8 = zip4 . (fmap4 zip4)

parK :: Lens (f b) b -> Lens (g a) a -> Lens (f g a) a
parK :: forall b. Lens (f b) (f' b) -> Lens (g a) (g' a) -> Lens (f g a) (f' (g' a))
parK :: forall b. Lens (f g a) (f' g a) -> Lens (g a) (g' a) -> Lens (f g a) (f' (g' a))
parK = compose (fmap l2) l1

Do the y direction inductively

ydir :: Lens (Cell a, Cell a) (a,a)
ydir = \(Cell phi j x, Cell phi2 j2 y) -> ((x,y), \(x',y') -> (Cell phi j x, Cell phi2 j2 y)      )

ydir :: Lens (Cell a, Cell a) (a,a)
ydir = \(a,b) -> ((Cell phi j x) , f) = (gaussK a) in ((Cell phi j y) , g) = (gaussK b) in

Lens ( (X (), (X (), a) (X (), a)
ydir = \(r1, (r2, z) ->  zip8    )    -- = gaussK r1 in  = gaussK r2 in

Lens (f a) a -> Lens (f a) a -> Lens (f a, f a) a
Lens (Cell a) a -> Lens

Lens x y x' y'

-}

{-
can i just use regular lenses? I need to set in kind of a weird way though.
-}

data Lens a b = Lens (a -> (b, b -> a))
-- newtype Lens a b = Lens forall r. (a -> (b -> (b -> a) -> r) -> r) -- cpsify for speed? van Laarhoven?

-- SLens s a b = SLens (a -> ST s (b, b -> ST s a)) mutable update
-- MLens a b = MLens (a -> m (b , b -> m a)) -- monadic lens
-- KLens a b = KLens (a -> (b, k b a)) ---- this is sort of what Conal wrote.
comp :: Lens b c -> Lens a b -> Lens a c
comp (Lens f) (Lens g) = Lens $ \x -> let (y, g') = g x in
                                      let (z, f') = f y in
                                      (z, g' . f')

-- Gauss Seidel of the standard 1 -2 1 matrix
-- j1 is the effective source incliuding the influence from phi values up in the stack
-- Double Cell construction is rather wonky
-- gaussK :: Vec (S (S n)) Double -> Vec (S n)
-- we could also go for the lagrange mutiplier interface.
-- can also push the rho value needed for stability up and down.

-- -2 phi1 + 1 phi2 = ~j1
-- -1 phi1 + -2 phi2 + ...? = j2

{-
We are moving the lower diagonal to the right hand side as the splitting.
That ends up to claculating an effective j based on previous values.
We then triangular solve the upper diagonal, which we are able to find the new diagonal element in terms of the lower values.

-}
-- it's kind of weird that we mutate j on the way down but restore it on the way up.
-- But we do need a way to access j. (Phi (Phi a), J a) (Phi )

gaussK :: Lens (Cell (Cell a)) (Cell a) -- we need the context Cell
gaussK = Lens $ \case (Cell phi1 j1 (Cell phi2 j2 y)) -> (Cell phi2 (j2 - phi1) y , \case (Cell phi2' j2' z) -> let j1' = j1 - phi2' in  -- moving the triangular upsolve to the right hand side
                                                                                Cell (- j1' / 2) j1 (Cell phi2' j2 z))

-- interface in , internals, interface out. was the previous way of talking about it. But then the internals grow, which is fine
-- compose :: Lens in internal out -> Lens in' internal' out' -> Lens in (internal, out, in', internal') out
-- some ind of 2 category? Enriched? The morphisms have this internal structure.
-- this is more a containing relationship. The larger context can be converted into the smaller context.
--

g2 :: Lens (Cell (Cell (Cell a))) (Cell a)
g2 = gaussK `comp` gaussK
g4 = g2 `comp` g2
g8 = g4 `comp` g4
g16 = g8 `comp` g8
g32 = g16 `comp` g16

capZero :: Lens (Cell ()) () -- not even sure i really need this? does runGauss (f `comp` capZero) ~ runGauss f
capZero = Lens $ \case (Cell phi j _) -> ((), \_ -> Cell (- j / 2) j ())

-- runGauss ::  Lens a b -> a -> a -- removes the open ended nature of the thing.
runGauss ::  Lens a () -> a -> a -- this might make more sense as what you really want. This is some kind of cap operation.
runGauss (Lens f) x = let (y , trisolve)  = f x in trisolve y
startingVal :: Cell (Cell (Cell ()))
startingVal = (Cell 0 0 (Cell 0 1 (Cell 0 0 ())))

iters = iterate (runGauss (capZero `comp` g2)) startingVal
--iters' = iterate (runGauss g2) startingVal -- They are different.

sol = ((3><3) [-2,1,0,
               1,-2,1,
               0,1,-2])  <\> (vector [0,1,0])

-- can do inner block solves also (via an iterative method perhaps)
-- this is reminsecent of a multiscale attack.
parC :: Lens a a' -> Lens b b' -> Lens (a,b) (a',b')
parC (Lens f) (Lens g) = Lens $ \(x,y) -> let (x', f') = f x in
                                          let (y', g') = g y in
                                          ((x',y') , f' *** g')

-- profucntor optics paper
data FunList a b t = Done t | More a (FunList a b (b -> t))
-- contents and fill
-- contents (s -> a^n)
-- fill s -> b^n -> t
-- s -> exists n. (a^n, a^n -> s) is a traversal. Could use a Vec. But we already have a Vec. Cell is a Vec
-- s -> exists n, (Vec n a, Vec n a -> s)
-- maybe we do need an applicative. We sort of need to zip together two rows to start going 2d.

-- huh. A block wise schur is kind of the monoidal ppoduct here. No. monoidal product is pure dsum.
-- actually composition? is kind of what plays the game of block wise stuff.
{-

if we want this to be not the case,
comp :: Lens (a,a') a'

schur :: Lens a a' -> (a -> b) -> (b -> a) -> Lens b b' -> Lens (a,b) (a',b')
schur (Lens a) b c (Lens d) = Lens $ \(x,y) -> let (x', a') = a x in
                                               let (y', d') = d x in
                                               (       )
-}
-- Lens (f (g a)) (g a)

                                               -- we can change this all into a continuation form
--

{-
par :: forall a b c d. (BEnum a, BEnum b, BEnum c, BEnum d) => BMatrix a b ->
                         BMatrix c d -> BMatrix (a,c) (b,d)
par q@(QuadFun m w r) q'@(QuadFun m' w' r') = QuadFun q'' w'' r'' where
     a' = diagBlock [sliceA q, sliceA q']
     b' = diagBlock [sliceB q, sliceB q']
     c' = diagBlock [sliceC q, sliceC q']
     d' = diagBlock [sliceD q, sliceD q']
     q'' = fromBlocks [[a',b'], [c',d']]
     u' = vjoin [sliceU v, sliceU v']
     v' = vjoin [sliceV v, sliceV v']
     w'' = vjoin [u', v']
     r'' = r + r'

sliceA :: forall a b. (BEnum a, BEnum b) => QuadFun a b -> M
sliceA (QuadFun m v c) = subMatrix (0,0) (count @a, count @a)  m
sliceB :: forall a b. (BEnum a, BEnum b) => QuadFun a b -> M
sliceB (QuadFun m v c) = subMatrix (0,count @a) (count @a, count @b) m
sliceC :: forall a b. (BEnum a, BEnum b) => QuadFun a b -> M
sliceC (QuadFun m v c) = subMatrix (count @a,0) (count @b, count @a) m
sliceD :: forall a b. (BEnum a, BEnum b) => QuadFun a b -> M
sliceD (QuadFun m v c) = subMatrix (count @a,count @a) (count @b, count @b) m

sliceU :: forall a b. (BEnum a, BEnum b) => QuadFun a b -> Vector Double
sliceU (QuadFun m v c) = subVector 0 (count @a) v
sliceV :: forall a b. (BEnum a, BEnum b) => QuadFun a b -> Vector Double
sliceV (QuadFun m v c) = subVector (count @a) (count @b) v

n = count @a
m = count @b
q = rows m
p = q - m
a = subMatrix (0,0) (count @a, count @a)  m

a = subMatrix
--Other options
-- Keep a matrix with the end and the beginning are the

-- Keep Constraints too?

-- what in the world
-- stack build --ghc-options /usr/lib/libiconv.dylib

-- size
-- rows
-- cols

compose :: QuadFun b c -> QuadFun a b -> QuadFun a c
compose (QuadFun m w c) (QuadFun m' w' c') = QuadFun m'' w'' c'' where
    n = (count @b)
    corner =  fromBlocks [[ident n, 0],[0, -(ident n)]]
    corner' = fromBlocks [[0,0],[corner,0]]
    m'' = fromBlocks [[m ,corner'], [tr corner', m']]
    w'' = vjoin [w, const 0 n, w']
    c'' = c + c

par (QuadFun m w c) (QuadFun m' w' c') =

type a :+: b = Either a b
data QuadFun x = QuadFun

((a,b,c),
 (d,e,f),
 (g,h,i)) =

 data BMatrix' = BMatrix' M M M M M M M M M
 compose (BMatrix' a' b' c' d' e' f' g' h' i') (BMatrix' a b c d e f g h i) =
    BMatrix' a'' b'' c'' d'' e'' f'' g'' h'' i'' where
    a'' = a
    b'' = b ||| c ||| 0
    c'' = 0
    d'' = d === g === 0
    e'' = fromBlocks [[e,f,0], [h, i + a', b'], [0, d', e']]
    f'' = 0 === c' === f'
    g'' =  0
    h'' = 0 ||| g' ||| h'
    i'' = i'
compose' (BVec u' v' w') (BVec u v w) = BVec u (vjoin [v ,w + u', v']) w'

par :: QuadFun a b -> QuadFun c d -> QuadFun (Either a c) (Either b d)
par (BMatrix' a' b' c' d' e' f' g' h' i') (BMatrix' a b c d e f g h i) =
   BMatrix' a'' b'' c'' d'' e'' f'' g'' h'' i'' where
   a'' = diagBlock [a',a]
   b'' = diagBlock [b',b]
   c'' = diagBlock [c',c]
   d'' = diagBlock [d',d]
   e'' = diagBlock [e',e]
   f'' = diagBlock [f',f]
   g'' = diagBlock [g',g]
   h'' = diagBlock [h',h]
   i'' = diagBlock [i',i]

-- If we're just recording the entire program, we might as well just record it in a DSL
-- rather than directly building the matrix
-- data QuadFunDSL = Par QuadFun
-- FreeCat + (Lit HMatrix)

-- iterative matrix solution proximal method?
--
-- gauss seidel
type VBlock = [Vector Double]
-- (V, V)
-- Maybe schur solve works. But with possible splitting
-- Maybe unsolvable schur
-- could damp a little if the diagonal isn't dominant enough
-- (lusolve a (w - V <#| v', ) -- WHat I'm suggesting here is block Jacobi? No
-- No it isn't. Because we're passing back v' it is guass seidel.
-- in order to do block gauss seidel
-- type L = VBlock -> (VBlock, VBlock -> VBlock)

-- Writing in the monoidal categroy style makes parallelism more apparent.

-- [vjoin blocks] -> ([lesser blocks] , update [lesserblocks] -> [blocks]
-- \x:xs -> (a*x + xs, \b -> b )

-- storage in the lens?
-- In my AD lens, I had all the weights in the input. This was ungainly
-- Maybe a choice monad? Everyone could have access to a global state
-- forall s. (ActualLens s a, a -> (b, db -> da))
-- compsoe (ActualLens s a, a -> (b, db -> da))
-- par
-- ActualLens are functional references. Do they allow us to refiy sharing?
-- (ActualLens acc a,   )

-- alternative a -> State s (b, db -> State ds da)

-- Mutiple directions of composition. Horizontsl and vertical?
-- a 2-category?
-- ActualLens s a -> ActualLens s' s

-- Jules Hedges:
-- Lens sigma a b -> Lens sigm' b c -> Lens (sig,sig') a c
-- Lens :: Sigma -> (sigma,  ) -> Lens a b -- hides sigma, we'll never be able to get at it

-}


{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts      #-}
{-|
Module      : Grenade.Core.Pad
Description : Padding layer for 2D and 3D images
Copyright   : (c) Huw Campbell, 2016-2017
License     : BSD2
Stability   : experimental
-}
module Grenade.Layers.Pad (
    Pad (..)
  ) where

import           Data.Maybe
import           Data.Proxy
import           Data.Serialize
import           Data.Singletons.TypeLits
import           GHC.TypeLits

import           Grenade.Core
import           Grenade.Layers.Internal.Pad

import           Numeric.LinearAlgebra (konst, subMatrix, diagBlock)
import           Numeric.LinearAlgebra.Static (extract, create)

-- | A padding layer for a neural network.
--
--   Pads on the X and Y dimension of an image.
data Pad  :: Nat
          -> Nat
          -> Nat
          -> Nat -> * where
  Pad  :: Pad padLeft padTop padRight padBottom

instance Show (Pad padLeft padTop padRight padBottom) where
  show Pad = "Pad"

instance UpdateLayer (Pad l t r b) where
  type Gradient (Pad l t r b) = ()
  runUpdate _ x _ = x
  createRandom = return Pad

instance Serialize (Pad l t r b) where
  put _ = return ()
  get = return Pad

-- | A two dimentional image can be padded.
instance ( KnownNat padLeft
         , KnownNat padTop
         , KnownNat padRight
         , KnownNat padBottom
         , KnownNat inputRows
         , KnownNat inputColumns
         , KnownNat outputRows
         , KnownNat outputColumns
         , (inputRows + padTop + padBottom) ~ outputRows
         , (inputColumns + padLeft + padRight) ~ outputColumns
         ) => Layer (Pad padLeft padTop padRight padBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where
  type Tape (Pad padLeft padTop padRight padBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns)  = ()
  runForwards Pad (S2D input) =
    let padl  = fromIntegral $ natVal (Proxy :: Proxy padLeft)
        padt  = fromIntegral $ natVal (Proxy :: Proxy padTop)
        padr  = fromIntegral $ natVal (Proxy :: Proxy padRight)
        padb  = fromIntegral $ natVal (Proxy :: Proxy padBottom)
        m     = extract input
        r     = diagBlock [konst 0 (padt,padl), m, konst 0 (padb,padr)]
    in  ((), S2D . fromJust . create $ r)
  runBackwards Pad _ (S2D dEdy) =
    let padl  = fromIntegral $ natVal (Proxy :: Proxy padLeft)
        padt  = fromIntegral $ natVal (Proxy :: Proxy padTop)
        nrows = fromIntegral $ natVal (Proxy :: Proxy inputRows)
        ncols = fromIntegral $ natVal (Proxy :: Proxy inputColumns)
        m     = extract dEdy
        vs    = subMatrix (padt, padl) (nrows, ncols) m
    in  ((), S2D . fromJust . create $ vs)

-- | A two dimentional image can be padded.
instance ( KnownNat padLeft
         , KnownNat padTop
         , KnownNat padRight
         , KnownNat padBottom
         , KnownNat inputRows
         , KnownNat inputColumns
         , KnownNat outputRows
         , KnownNat outputColumns
         , KnownNat channels
         , KnownNat (inputRows * channels)
         , KnownNat (outputRows * channels)
         , (inputRows + padTop + padBottom) ~ outputRows
         , (inputColumns + padLeft + padRight) ~ outputColumns
         ) => Layer (Pad padLeft padTop padRight padBottom) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) where
  type Tape (Pad padLeft padTop padRight padBottom) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels)  = ()
  runForwards Pad (S3D input) =
    let padl  = fromIntegral $ natVal (Proxy :: Proxy padLeft)
        padt  = fromIntegral $ natVal (Proxy :: Proxy padTop)
        padr  = fromIntegral $ natVal (Proxy :: Proxy padRight)
        padb  = fromIntegral $ natVal (Proxy :: Proxy padBottom)
        outr  = fromIntegral $ natVal (Proxy :: Proxy outputRows)
        outc  = fromIntegral $ natVal (Proxy :: Proxy outputColumns)
        inr   = fromIntegral $ natVal (Proxy :: Proxy inputRows)
        inc   = fromIntegral $ natVal (Proxy :: Proxy inputColumns)
        ch    = fromIntegral $ natVal (Proxy :: Proxy channels)
        m     = extract input
        padded = pad ch padl padt padr padb inr inc outr outc m
    in  ((), S3D . fromJust . create $ padded)

  runBackwards Pad () (S3D gradient) =
    let padl  = fromIntegral $ natVal (Proxy :: Proxy padLeft)
        padt  = fromIntegral $ natVal (Proxy :: Proxy padTop)
        padr  = fromIntegral $ natVal (Proxy :: Proxy padRight)
        padb  = fromIntegral $ natVal (Proxy :: Proxy padBottom)
        outr  = fromIntegral $ natVal (Proxy :: Proxy outputRows)
        outc  = fromIntegral $ natVal (Proxy :: Proxy outputColumns)
        inr   = fromIntegral $ natVal (Proxy :: Proxy inputRows)
        inc   = fromIntegral $ natVal (Proxy :: Proxy inputColumns)
        ch    = fromIntegral $ natVal (Proxy :: Proxy channels)
        m     = extract gradient
        cropped = crop ch padl padt padr padb inr inc outr outc m
    in  ((), S3D . fromJust . create $ cropped)


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Strict           #-}
module FourierMethod.FourierSeries2D
  ( module FourierMethod.FourierSeries2D
  , module FourierMethod.BlockCudaMatrix
  , module FourierMethod.BlockMatrixAcc
  ) where

import           Control.DeepSeq
import           Control.Monad                               as M
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Resource
import qualified Data.Array.Accelerate                       as A
import           Data.Array.Accelerate.LLVM.PTX              as A
import           Data.Array.Accelerate.Numeric.LinearAlgebra as A
import           Data.Array.Repa                             as R
import           Data.Complex
import           Data.Conduit                                as C
import           Data.Conduit.List                           as CL
import           Data.List                                   as L
import           Data.Vector.Storable                        as VS
import           Data.Vector.Unboxed                         as VU
import           Foreign.CUDA.Driver                         as CUDA
import           FourierMethod.BlockCudaMatrix
import           FourierMethod.BlockMatrixAcc
import           FourierMethod.FourierSeries2DAcc
import           Utils.BLAS
import           Utils.Distribution
import           Utils.List
import           Utils.Parallel                              hiding ((.|))
import           Utils.Time

{-# INLINE harmonicMatPTX #-}
harmonicMatPTX ::
     ( Storable e
     , A.Elt (Complex e)
     , A.Elt e
     , Floating (A.Exp e)
     , A.FromIntegral Int e
     )
  => Int
  -> e
  -> e
  -> e
  -> PTX
  -> [(Int, Int)]
  -> CuMat (Complex e)
harmonicMatPTX numPoints period delta deltaFreq ptx r2Freqs =
  let rows = L.length r2Freqs
  in CuMat rows (numPoints ^ 2) .
     CuVecHost .
     VS.fromList .
     A.toList .
     run1With ptx (harmonicAcc numPoints period delta deltaFreq) .
     A.fromList (A.Z A.:. (L.length r2Freqs)) $
     r2Freqs

-- create column-major inverse harmonics
{-# INLINE inverseHarmonicMatPTX #-}
inverseHarmonicMatPTX ::
     ( Storable e
     , A.Elt (Complex e)
     , A.Elt e
     , Floating (A.Exp e)
     , A.FromIntegral Int e
     )
  => Int
  -> e
  -> e
  -> PTX
  -> [(Int, Int)]
  -> CuMat (Complex e)
inverseHarmonicMatPTX numFreqs period delta ptx r2Positions =
  let cols = L.length r2Positions
  in CuMat (numFreqs ^ 2) cols .
     CuVecHost .
     VS.fromList .
     A.toList .
     run1With ptx (inverseHarmonicAcc numFreqs period delta) .
     A.fromList (A.Z A.:. (L.length r2Positions)) $
     r2Positions

{-# INLINE inverseHarmonicMatPTX1 #-}
inverseHarmonicMatPTX1 ::
     ( Storable e
     , A.Elt (Complex e)
     , A.Elt e
     , Floating (A.Exp e)
     , A.FromIntegral Int e
     )
  => Int
  -> e
  -> e
  -> PTX
  -> [(Int, Int)]
  -> CuMat (Complex e)
inverseHarmonicMatPTX1 numFreqs period delta ptx r2Positions =
  let rows = L.length r2Positions
  in CuMat rows (numFreqs ^ 2) .
     CuVecHost .
     VS.fromList .
     A.toList .
     run1With ptx (inverseHarmonicAcc1 numFreqs period delta) .
     A.fromList (A.Z A.:. (L.length r2Positions)) $
     r2Positions

createHarmonicMatriesGPU ::
     ( Storable e
     , A.Elt (Complex e)
     , A.Elt e
     , Floating (A.Exp e)
     , A.FromIntegral Int e
     )
  => [PTX]
  -> Int
  -> Int
  -> Int
  -> e
  -> e
  -> e
  -> IO [[CuMat (Complex e)]]
createHarmonicMatriesGPU ptxs numBatch numPoints numFreqs period delta deltaFreq = do
  let idxs =
        L.map (divideListN numBatch) . divideListN (L.length ptxs) $
        [ (xFreq, yFreq)
        | xFreq <- getListFromNumber numFreqs
        , yFreq <- getListFromNumber numFreqs
        ]
  let output =
        parZipWith
          rdeepseq
          (\ptx -> L.map (harmonicMatPTX numPoints period delta deltaFreq ptx))
          ptxs $
        idxs
  return output

createInverseHarmonicMatriesGPU ::
     ( Storable e
     , A.Elt (Complex e)
     , A.Elt e
     , Floating (A.Exp e)
     , A.FromIntegral Int e
     )
  => [PTX]
  -> Int
  -> Int
  -> Int
  -> e
  -> e
  -> IO [[CuMat (Complex e)]]
createInverseHarmonicMatriesGPU ptxs numBatch numPoints numFreqs period delta = do
  let idxs =
        L.map (divideListN numBatch) . divideListN (L.length ptxs) $
        [ (x, y)
        | x <- getListFromNumber numPoints
        , y <- getListFromNumber numPoints
        ]
  return .
    parZipWith
      rdeepseq
      (\ptx -> L.map (inverseHarmonicMatPTX numFreqs period delta ptx))
      ptxs $
    idxs

computeFourierCoefficientsR2 ::
     ( Storable e
     , CUBLAS (Complex e)
     , Unbox e
     , RealFloat e
     , A.Elt e
     , A.Elt (Complex e)
     , Floating (A.Exp e)
     , A.FromIntegral Int e
     )
  => [Int]
  -> [PTX]
  -> Int
  -> Int
  -> e
  -> e
  -> e
  -> Int
  -> [CuMat (Complex e)]
  -> IO (R.Array U DIM3 (Complex e))
computeFourierCoefficientsR2 deviceIDs ptxs numFreqs numPoints period delta deltaFreq numBatchR2Freqs xs = do
  let simpsonNorm = (delta / 3) ^ 2 :+ 0
      cols = L.foldl' (\s mat -> s + getColsCuMat mat) 0 xs
  harmonics <-
    createHarmonicMatriesGPU
      ptxs
      numBatchR2Freqs
      numPoints
      numFreqs
      period
      delta
      deltaFreq
  coefs <- blockMatrixMultiply2 True deviceIDs harmonics xs
  return .
    fromUnboxed (Z :. cols :. numFreqs :. numFreqs) .
    VU.map (* simpsonNorm) . VS.convert . getHostCuMat $
    coefs

computeFourierSeriesR2 ::
     ( Storable e
     , CUBLAS (Complex e)
     , Unbox e
     , RealFloat e
     , A.Elt e
     , A.Elt (Complex e)
     , Floating (A.Exp e)
     , A.FromIntegral Int e
     )
  => [Int]
  -> Int
  -> Int
  -> e
  -> [[CuMat (Complex e)]]
  -> [CuMat (Complex e)]
  -> IO (R.Array U DIM3 (Complex e))
computeFourierSeriesR2 deviceIDs numFreqs numPoints period inverseHarmonics xs = do
  let rows = L.foldl' (\s mat -> s + getRowsCuMat mat) 0 xs
  series <- blockMatrixMultiply1 False deviceIDs xs inverseHarmonics
  return .
    fromUnboxed (Z :. rows :. numPoints :. numPoints) .
    VS.convert . getHostCuMat $
    series

{-# INLINE applyGaussian #-}
applyGaussian ::
     (R.Source s (Complex e), Unbox e, RealFloat e)
  => e
  -> e
  -> R.Array s DIM3 (Complex e)
  -> R.Array D DIM3 (Complex e)
applyGaussian deltaFreq std arr =
  let (Z :. _ :. numFreq :. _) = extent arr
      freq = div numFreq 2
      gaussianCoefficients =
        computeUnboxedS . R.fromFunction (Z :. numFreq :. numFreq) $ \(Z :. xFreq :. yFreq) ->
          gaussian2D
            (deltaFreq * (fromIntegral $ xFreq - freq))
            (deltaFreq * (fromIntegral $ yFreq - freq))
            std :+
          0
  in R.traverse2 arr gaussianCoefficients const $ \fC fG idx@(Z :. _ :. i :. j) ->
       fC idx * fG (Z :. i :. j)

-- Stream
{-# INLINE indexSource #-}
indexSource :: Int -> Int -> ConduitT () [(Int, Int)] (ResourceT IO) ()
indexSource numIndex numBatch =
  let xs =
        divideListN numBatch $
        [ (xFreq, yFreq)
        | xFreq <- getListFromNumber numIndex
        , yFreq <- getListFromNumber numIndex
        ]
  in CL.sourceList xs

{-# INLINE fourierCoefficientsConduit #-}
fourierCoefficientsConduit ::
     ( Storable e
     , CUBLAS (Complex e)
     , Unbox e
     , RealFloat e
     , A.Elt e
     , A.Elt (Complex e)
     , Floating (A.Exp e)
     , A.FromIntegral Int e
     , Show e
     )
  => [Int]
  -> [PTX]
  -> Int
  -> e
  -> e
  -> e
  -> [CuMat (Complex e)]
  -> ConduitT [(Int, Int)] (CuMat (Complex e)) (ResourceT IO) ()
fourierCoefficientsConduit deviceIDs ptxs numPoints period delta deltaFreq xs =
  awaitForever $ \idx' -> do
    let idxs = divideListN (L.length deviceIDs) idx'
        harmonics =
          parMap
            rdeepseq
            (uncurry (harmonicMatPTX numPoints period delta deltaFreq)) $
          L.zip ptxs idxs
    liftIO $ printCurrentTime ""
    coefs <- liftIO $ blockMatrixMultiply3 False deviceIDs harmonics xs
    yield $!! coefs

{-# INLINE fourierCoefficientsSink #-}
fourierCoefficientsSink ::
     (Storable e, Unbox e, RealFloat e, Show e)
  => Int
  -> e
  -> ConduitT (CuMat (Complex e)) Void (ResourceT IO) ((R.Array U DIM3 (Complex e)))
fourierCoefficientsSink numR2Freqs delta = do
  xs <- CL.consume
  let cols = getColsCuMat . L.head $ xs
      simpsonNorm = (delta / 3) ^ 2 :+ 0
  return .
    fromUnboxed (Z :. cols :. numR2Freqs :. numR2Freqs) .
    VU.map (* simpsonNorm) .
    VS.convert . getHostCuMat . transposeCuMat . concatCuMat $
    xs

computeFourierCoefficientsR2Stream ::
     ( Storable e
     , CUBLAS (Complex e)
     , Unbox e
     , RealFloat e
     , A.Elt e
     , A.Elt (Complex e)
     , Floating (A.Exp e)
     , A.FromIntegral Int e
     )
  => [Int]
  -> [PTX]
  -> Int
  -> Int
  -> e
  -> e
  -> e
  -> Int
  -> [CuMat (Complex e)]
  -> IO (R.Array U DIM3 (Complex e))
computeFourierCoefficientsR2Stream deviceIDs ptxs numFreqs numPoints period delta deltaFreq numBatch xs =
  runConduitRes $
  indexSource numFreqs numBatch .|
  fourierCoefficientsConduit deviceIDs ptxs numPoints period delta deltaFreq xs .|
  fourierCoefficientsSink numFreqs delta

{-# INLINE fourierSeriesConduit #-}
fourierSeriesConduit ::
     ( Storable e
     , CUBLAS (Complex e)
     , Unbox e
     , RealFloat e
     , A.Elt e
     , A.Elt (Complex e)
     , Floating (A.Exp e)
     , A.FromIntegral Int e
     , Show e
     )
  => [Int]
  -> [PTX]
  -> Int
  -> e
  -> e
  -> [CuMat (Complex e)]
  -> ConduitT [(Int, Int)] (CuMat (Complex e)) (ResourceT IO) ()
fourierSeriesConduit deviceIDs ptxs numFreqs period delta xs =
  awaitForever $ \idx' -> do
    let idxs = divideListN (L.length deviceIDs) idx'
        harmonics =
          parMap
            rdeepseq
            (uncurry (inverseHarmonicMatPTX1 numFreqs period delta)) $
          L.zip ptxs idxs
    liftIO $ printCurrentTime "fourierSeriesConduit"
    coefs <- liftIO $ blockMatrixMultiply3 False deviceIDs harmonics xs
    yield $!! coefs

{-# INLINE fourierSeriesSink #-}
fourierSeriesSink ::
     (Storable e, Unbox e, RealFloat e, Show e)
  => Int
  -> ConduitT (CuMat (Complex e)) Void (ResourceT IO) ((R.Array U DIM3 (Complex e)))
fourierSeriesSink numPoints = do
  xs <- CL.consume
  let cols = getColsCuMat . L.head $ xs
  return .
    fromUnboxed (Z :. cols :. numPoints :. numPoints) .
    VS.convert . getHostCuMat . transposeCuMat . concatCuMat $
    xs

computeFourierSeriesR2Stream ::
     ( Storable e
     , CUBLAS (Complex e)
     , Unbox e
     , RealFloat e
     , A.Elt e
     , A.Elt (Complex e)
     , Floating (A.Exp e)
     , A.FromIntegral Int e
     )
  => [Int]
  -> [PTX]
  -> Int
  -> Int
  -> e
  -> e
  -> Int
  -> [CuMat (Complex e)]
  -> IO (R.Array U DIM3 (Complex e))
computeFourierSeriesR2Stream deviceIDs ptxs numFreqs numPoints period delta numBatch xs =
  runConduitRes $
    indexSource numPoints numBatch .|
    fourierSeriesConduit deviceIDs ptxs numFreqs period delta xs .|
    fourierSeriesSink numPoints

{-# INLINE fourierSeriesConduitAcc #-}
fourierSeriesConduitAcc ::
     ( A.Floating e
     , A.Elt (Complex e)
     , A.FromIntegral Int e
     , Numeric (Complex e)
     , Unbox e
     )
  => [PTX]
  -> Int
  -> e
  -> e
  -> A.Acc (Matrix (Complex e))
  -> ConduitT [(Int, Int)] (VU.Vector (Complex e)) (ResourceT IO) ()
fourierSeriesConduitAcc ptxs numFreqs period delta x =
  awaitForever $ \idx' -> do
    let idxs = divideListN (L.length ptxs) idx'
        harmonics =
          L.map
            (\r2Positions ->
               inverseHarmonicAcc2 numFreqs period delta .
               A.fromList (A.Z A.:. L.length r2Positions) $
               r2Positions) $
          idxs
    liftIO $ printCurrentTime "fourierSeriesConduit"
    yield $!! blockMatrixMultiply ptxs harmonics x

{-# INLINE fourierSeriesSinkAcc #-}
fourierSeriesSinkAcc ::
     (Unbox e)
  => Int
  -> Int
  -> ConduitT (VU.Vector (Complex e)) Void (ResourceT IO) (R.Array U DIM3 (Complex e))
fourierSeriesSinkAcc numPoints cols = do
  xs <- CL.consume
  computeP .
    R.backpermute
      (Z :. cols :. numPoints :. numPoints)
      (\(Z :. a :. b :. c) -> Z :. b :. c :. a) .
    fromUnboxed (Z :. numPoints :. numPoints :. cols) . VU.concat $
    xs

computeFourierSeriesR2StreamAcc ::
     ( A.Floating e
     , A.Elt (Complex e)
     , A.FromIntegral Int e
     , Numeric (Complex e)
     , Unbox e
     )
  => [PTX]
  -> Int
  -> Int
  -> Int
  -> e
  -> e
  -> Int
  -> Acc (Matrix (Complex e))
  -> IO (R.Array U DIM3 (Complex e))
computeFourierSeriesR2StreamAcc ptxs numFreqs numPoints cols period delta numBatch x =
  runConduitRes $
  indexSource numPoints numBatch .|
  fourierSeriesConduitAcc ptxs numFreqs period delta (A.compute x) .|
  fourierSeriesSinkAcc numPoints cols

{-# INLINE fourierSeriesConduitAcc' #-}
fourierSeriesConduitAcc' ::
     ( A.Floating e
     , A.Elt (Complex e)
     , A.FromIntegral Int e
     , Numeric (Complex e)
     , Unbox e
     , Prelude.Num e
     )
  => [PTX]
  -> Int
  -> e
  -> e
  -> A.Acc (Matrix (Complex e))
  -> ConduitT [(Int, Int)] (VU.Vector (Complex e)) (ResourceT IO) ()
fourierSeriesConduitAcc' ptxs numFreqs period delta x =
  awaitForever $ \idx' -> do
    let idxs = divideListN (L.length ptxs) idx'
        harmonics =
          L.map
            (\r2Positions ->
               inverseHarmonicAcc2' numFreqs period delta .
               A.fromList (A.Z A.:. L.length r2Positions) $
               r2Positions) $
          idxs
    liftIO $ printCurrentTime "fourierSeriesConduit"
    yield $ blockMatrixMultiply ptxs harmonics x

computeFourierSeriesR2StreamAcc' ::
     ( A.Floating e
     , A.Elt (Complex e)
     , A.FromIntegral Int e
     , Numeric (Complex e)
     , Unbox e
     , Prelude.Num e
     )
  => [PTX]
  -> Int
  -> Int
  -> Int
  -> e
  -> e
  -> Int
  -> Acc (Matrix (Complex e))
  -> IO (R.Array U DIM3 (Complex e))
computeFourierSeriesR2StreamAcc' ptxs numFreqs numPoints cols period delta numBatch x =
  runConduitRes $
  indexSource numPoints numBatch .|
  fourierSeriesConduitAcc' ptxs numFreqs period delta (A.compute x) .|
  fourierSeriesSinkAcc numPoints cols


import HackageBenchmark
import Statistics.Types (mkPValue)
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit (assertBool, testCase, (@?=))

main :: IO ()
main = defaultMain tests

tests :: TestTree
tests = testGroup "unit tests" [

    testGroup "isSignificantTimeDifference" [

        testCase "detect increase in distribution" $ assertBool "" $
            isSignificantTimeDifference (mkPValue 0.05) [1,2..7] [4,5..10]

      , testCase "detect decrease in distribution" $ assertBool "" $
            isSignificantTimeDifference (mkPValue 0.05) [1,2..7] [-2,-1..4]

      , testCase "ignore same data" $ assertBool "" $
            not $ isSignificantTimeDifference (mkPValue 0.05) [1,2..10] [1,2..10]

      , testCase "same data with high p-value is significant" $ assertBool "" $
            isSignificantTimeDifference (mkPValue 0.9) [1,2..10] [1,2..10]

      , testCase "ignore outlier" $ assertBool "" $
            not $ isSignificantTimeDifference (mkPValue 0.05) [1, 2, 1, 1, 1] [2, 1, 50, 1, 1]
      ]

  , testGroup "combineTrialResults" [

        testCase "convert unexpected difference to Unknown" $
            combineTrialResults [NoInstallPlan, BackjumpLimit] @?= Unknown

      , testCase "return one of identical errors" $
            combineTrialResults [NoInstallPlan, NoInstallPlan] @?= NoInstallPlan

      , testCase "return one of identical successes" $
            combineTrialResults [Solution, Solution] @?= Solution

      , testCase "timeout overrides other results" $
            combineTrialResults [Solution, Timeout, Solution] @?= Timeout

      , testCase "convert unexpected difference to Unknown, even with timeout" $
            combineTrialResults [Solution, Timeout, NoInstallPlan] @?= Unknown
    ]

  , testGroup "isSignificantResult" [

        testCase "different results are significant" $ assertBool "" $
            isSignificantResult NoInstallPlan BackjumpLimit

      , testCase "unknown result is significant" $ assertBool "" $
            isSignificantResult Unknown Unknown

      , testCase "PkgNotFound is significant" $ assertBool "" $
            isSignificantResult PkgNotFound PkgNotFound

      , testCase "same expected error is not significant" $ assertBool "" $
            not $ isSignificantResult NoInstallPlan NoInstallPlan

      , testCase "success is not significant" $ assertBool "" $
            not $ isSignificantResult Solution Solution
    ]

  , testGroup "shouldContinueAfterFirstTrial" [

        testCase "rerun when min difference is zero" $ assertBool "" $
                  shouldContinueAfterFirstTrial 0 1.0 1.0 Solution Solution

      , testCase "rerun when min difference is zero, even with timeout" $
                  assertBool "" $
                  shouldContinueAfterFirstTrial 0 1.0 1.0 Timeout Timeout

      , testCase "treat timeouts as the same time" $ assertBool "" $
            not $ shouldContinueAfterFirstTrial 0.000001 89.9 92.0 Timeout Timeout

      , testCase "skip when times are too close - 1" $ assertBool "" $
            not $ shouldContinueAfterFirstTrial 10 1.0 0.91  Solution Solution

      , testCase "skip when times are too close - 2" $ assertBool "" $
            not $ shouldContinueAfterFirstTrial 10 1.0 1.09  Solution Solution

      , testCase "rerun when times aren't too close - 1" $ assertBool "" $
                  shouldContinueAfterFirstTrial 10 1.0 0.905 Solution Solution

      , testCase "rerun when times aren't too close - 2" $ assertBool "" $
                  shouldContinueAfterFirstTrial 10 1.0 1.1   Solution Solution
    ]
  ]


{-# LANGUAGE FlexibleInstances #-}
module SchemeParser.Types where

import Data.IORef
import Data.Complex (Complex)
import Data.Ratio (Rational)

import Control.Monad.Reader
import Control.Monad.Except

import qualified Data.Map as M

import Text.Parsec

-- parser

type LispParser = Parsec String ()

data LispVal = LAtom String
             | LNil
             | LString String
             | LBool Bool
             | LChar Char
             | LNumber Integer
             | LFloat Float
             | LRatio Rational
             | LComplex (Complex Double)
             | LList [LispVal]
             | LDottedList [LispVal] LispVal
             | LVector [LispVal]
             | LPrimFunc ([LispVal] -> Scheme LispVal)
             | LFunc { params :: [String], vararg :: Maybe String,
                       closure :: M.Map String LispVal, body :: [LispVal]}
             deriving Eq

instance Eq ([LispVal] -> Scheme LispVal) where
  _ /= _ = False

-- errors

data LispError = NumArgs Integer [LispVal]
               | TypeMismatch String LispVal
               | Parser ParseError
               | BadSpecialForm String LispVal
               | NotFunction String String
               | UnboundVar String String
               | Default String

type ThrowsError = Either LispError

-- environment

type Env_ = IORef (M.Map String (IORef LispVal))

data Env a = Env
  { globalEnv :: a
  , localEnv  :: a
  }

data EnvType = GlobalEnv | LocalEnv

type SchemeEnv = Env Env_

getEnv :: EnvType -> SchemeEnv -> Env_
getEnv GlobalEnv = globalEnv
getEnv LocalEnv = localEnv

setEnv :: EnvType -> SchemeEnv -> Env_ -> SchemeEnv
setEnv GlobalEnv e e_ = e {globalEnv = e_}
setEnv LocalEnv e e_ = e {localEnv = e_}

pureEnv :: Env_ -> IO (M.Map String LispVal)
pureEnv envR = do
  env <- readIORef envR
  let m = M.toList env
  return $ M.empty

nullEnv :: IO SchemeEnv
nullEnv = Env <$> newIORef M.empty <*> newIORef M.empty

testEnv :: IO SchemeEnv
testEnv = do
  envR <- nullEnv
  let e = globalEnv envR
  env <- readIORef e
  valueRef <- newIORef (LNumber 1)
  writeIORef e (M.insert "foo" valueRef env)
  return envR

-- global type

type Scheme = ReaderT SchemeEnv (ExceptT LispError IO)

runScheme :: Scheme a -> SchemeEnv -> IO (Either LispError a)
runScheme sa env = runExceptT $ runReaderT sa env

testScheme :: Scheme a -> IO (Either LispError a)
testScheme sa = do
  e <- testEnv
  runScheme sa e


{-# LANGUAGE OverloadedStrings #-}

module Lib.Util where

import           Control.Arrow
import           Data.Aeson
import qualified Data.Complex           as C
import           Data.List              (foldl')
import qualified Data.Map.Strict        as Map
import qualified Data.Text              as T
import qualified Data.Vector            as V
import qualified Data.WAVE              as WAV
import           Database.Persist.Class
import           Database.Persist.Sql
import qualified Lib.STFT               as STFT
import qualified Lib.TWM                as TWM

-- Takes a vector of doubles, the sample frequency, and a name
-- and writes the audio file. Written in 32 bit.
writeWav :: STFT.Signal -> Int -> String -> IO ()
writeWav (STFT.MkSignal vec) sf name =
  let samples = fmap ((:[]) . WAV.doubleToSample . C.realPart) (V.toList vec)
      header = WAV.WAVEHeader 1 sf 32 Nothing
  in  WAV.putWAVEFile name (WAV.WAVE header samples)

-- Takes a Path and returns IO (sampling frequency, Vector signal).
readWav :: String -> IO (Int, V.Vector Double)
readWav path = do
  audio <- WAV.getWAVEFile path
  let header = WAV.waveHeader audio
      samples = WAV.waveSamples audio
      channels = WAV.waveNumChannels header
      sampRate = WAV.waveFrameRate header
  case channels of
    1 -> let sig = V.fromList $ fmap (WAV.sampleToDouble . Prelude.head) samples
          in return (sampRate, sig)
    _ -> error "Should be mono."

makeSignal :: (Int, V.Vector Double) -> (Int, STFT.Signal)
makeSignal (i, vec) = (i, makeSig vec)

makeSig :: V.Vector Double -> STFT.Signal
makeSig vec = STFT.MkSignal $ fmap (\x -> x C.:+ 0) vec

data Note = A | Bb | B | C | Db | D | Eb | E | F | Gb | G | Ab  deriving (Eq, Ord, Show, Enum)

fromChar :: Char -> Note
fromChar c = undefined

instance ToJSON Note where
    toJSON note = object ["note" .= (show note)]

instance PersistField Note where
  toPersistValue n = PersistText (T.pack $ show n)
  fromPersistValue (PersistText b) = undefined
  fromPersistValue x = Left $ "File.hs: When trying to deserialize a Note: expected PersistText, received: " <> (T.pack $ show x)

instance PersistFieldSql Note where
  sqlType _ = SqlString

data NoteCounter = MkCounter {
    counter :: Int,
    note    :: Note
}

twelthRoot :: Double
twelthRoot = 2 ** (1 / 12)

intToFreq :: Int -> TWM.Freq
intToFreq n = TWM.MkFreq $ 440 * twelthRoot ** fromIntegral n

intToNote :: Int -> Note
intToNote n = toEnum (abs $ n `mod` 12)

initCounter :: Note -> NoteCounter
initCounter n = MkCounter {
    counter = 0,
    note = n
}

closestFreq :: TWM.Freq -> [TWM.Freq] -> TWM.Freq
closestFreq f = snd . minimum . map (abs . subtract f &&& id)

type NoteMap = Map.Map TWM.Freq NoteCounter

-- |Look up table from frequency to note
-- Based on https://pages.mtu.edu/~suits/NoteFreqCalcs.html
freqToNoteTable :: NoteMap
freqToNoteTable = Map.fromList $ fmap (\i -> (intToFreq i, initCounter $ intToNote i)) [(-36)..24]

addToCounter :: NoteCounter -> NoteCounter
addToCounter noteCounter = MkCounter {
    counter = counter noteCounter + 1,
    note = note noteCounter
}

instance Eq NoteCounter where
    (MkCounter counter1 _) == (MkCounter counter2 _) = counter1 == counter2

instance Ord NoteCounter where
    (MkCounter counter1 _) `compare` (MkCounter counter2 _) = counter1 `compare` counter2

findf0 :: [TWM.Freq] -> Note
findf0 fs = note $ maximum $ Map.elems reduced
    where
        freqMap = flip closestFreq (Map.keys freqToNoteTable)
        hz = fmap freqMap (filter (/= 0) fs)
        adjust' = flip $ Map.adjust addToCounter
        reduced = foldl' adjust' freqToNoteTable hz


{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeOperators       #-}
{-# LANGUAGE TypeApplications    #-}

module Test.Grenade.Layers.Transpose where

import           Grenade.Core
import           Grenade.Layers.Transpose
import           Data.Serialize
import           Data.Either
import           Test.Utils.Rnf

import           Numeric.LinearAlgebra        hiding (R, konst, uniformSample,
                                               (===))
import           Numeric.LinearAlgebra.Static as H hiding ((===), create)
import           System.Random.MWC             (create)
import           Hedgehog

prop_transpose_layer_calls_transpose_correctly = withTests 1 $ property $ do
  -- TEST 1
  let input :: L 12 4 = H.fromList [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47 ]
      perms :: R 4    = H.fromList [ 2, 0, 1, 3 ]
      expected_output = (12 >< 4)  [ 0, 1, 2, 3, 12, 13, 14, 15, 24, 25, 26, 27, 36, 37, 38, 39, 4, 5, 6, 7, 16, 17, 18, 19, 28, 29, 30, 31, 40, 41, 42, 43, 8, 9, 10, 11, 20, 21, 22, 23, 32, 33, 34, 35, 44, 45, 46, 47 ]

      input' = S4D input :: S ('D4 2 2 3 4)
      layer = Transpose perms :: Transpose 4 ('D4 2 2 3 4) ('D4 3 2 2 4)

      S4D output = snd $ runForwards layer input' :: S ('D4 3 2 2 4)

  H.extract output === expected_output

  -- TEST 2
  let input :: L 12 4 = H.fromList [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47 ]
      perms :: R 4    = H.fromList [ 3, 2, 1, 0 ]
      expected_output = (24 >< 2)  [ 0, 24, 12, 36, 4, 28, 16, 40, 8, 32, 20, 44, 1, 25, 13, 37, 5, 29, 17, 41, 9, 33, 21, 45, 2, 26, 14, 38, 6, 30, 18, 42, 10, 34, 22, 46, 3, 27, 15, 39, 7, 31, 19, 43, 11, 35, 23, 47 ]

      input' = S4D input :: S ('D4 2 2 3 4)
      layer = Transpose perms :: Transpose 4 ('D4 2 2 3 4) ('D4 4 3 2 2)

      S4D output = snd $ runForwards layer input' :: S ('D4 4 3 2 2)

  H.extract output === expected_output

prop_transpose_can_update_and_batch = withTests 1 $ property $ do
  gen <- evalIO create
  layer :: Transpose 4 ('D4 1 2 3 4) ('D4 4 3 2 1) <- evalIO $ createRandomWith UniformInit gen
  runUpdate defSGD layer () `seq` success
  runUpdate defAdam layer () `seq` success
  reduceGradient @(Transpose 4 ('D4 1 2 3 4) ('D4 4 3 2 1)) [()] `seq` success

prop_can_show_transpose = withTests 1 $ property $ do
  gen <- evalIO create
  layer :: Transpose 4 ('D4 1 2 3 4) ('D4 4 3 2 1) <- evalIO $ createRandomWith UniformInit gen
  show layer `seq` success

prop_transpose_rnf = withTests 1 $ property $ do
  let layer  = Transpose (H.fromList [3, 2, 1, 0]) :: Transpose 4 ('D4 1 2 3 4) ('D4 4 3 2 1)
      layer' = Transpose (error expectedErrStr) :: Transpose 4 ('D4 1 2 3 4) ('D4 4 3 2 1)
  err0 <- evalIO $ tryEvalRnf layer'
  assert $ rnfRaisedErr err0

  noErrStr <- evalIO $ tryEvalRnf layer
  assert $ rnfNoError noErrStr

prop_transpose_is_serializable = withTests 1 $ property $ do
  gen <- evalIO create
  layer :: Transpose 4 ('D4 1 2 3 4) ('D4 4 3 2 1) <- evalIO $ createRandomWith UniformInit gen
  let Transpose perms = layer
      bs = encode layer
      dec = decode bs :: Either String (Transpose 4 ('D4 1 2 3 4) ('D4 4 3 2 1))
  assert $ isRight dec
  let Right (Transpose perms') = dec
  (H.extract perms') === (H.extract perms)

tests :: IO Bool
tests = checkParallel $$(discover)


{- |
Module      : UI.Tile
Description : Creation and execution of viewer tiles.
-}
module UI.Tile ( Tile()
               , renderTile
               , cancelTile
               , tileRect
               , ifModified
               , withSynchedTileBuffer
               ) where

import Task.Block
import Task.Concurrent
import Data.Planar

import Data.Color

import Control.Concurrent
import Control.Concurrent.Async

import Data.Complex
import Control.Monad (void)
import Data.Word
import Foreign.ForeignPtr
import Foreign.Ptr

newtype ImagePoint = ImagePoint (Double,Double)

instance Planar ImagePoint where
    toCoords (ImagePoint (x,y)) = (x, y)
    fromCoords = ImagePoint

-- | A tile in the image viewer.
data Tile = Tile
    { imageRect        :: Rectangle ImagePoint
      -- ^ The region in view space described by the tile.
    , tileBuffer       :: Synchronizable (ForeignPtr Word8)
      -- ^ The buffer into which the tile will draw.
    , tileWorker       :: Async ()
      -- ^ The worker thread which is drawing this tile.
    , shouldRedrawTile :: MVar ()
      -- ^ A value which signals that the tile needs to be redrawn.
    }

cancelTile :: Tile -> IO ()
cancelTile = void . forkIO . cancel . tileWorker -- cancel, but get on with life

withSynchedTileBuffer :: Tile -> (Ptr Word8 -> IO b) -> IO b
withSynchedTileBuffer tile action = synchedWith (tileBuffer tile) (`withForeignPtr` action)

-- | Unpack the width and height of a tile.
tileRect :: Tile -> (Int, Int)
tileRect tile = (floor w, floor h)
    where (w, h) = dimensions $ imageRect tile

-- | Perform an action, but only if the tile needs to be redrawn.
ifModified :: Tile -> IO () -> IO ()
ifModified tile f = do
    redraw <- tryTakeMVar $ shouldRedrawTile tile
    case redraw of
        Nothing -> return ()
        Just _  -> f

-- | Construct a tile from a dynamical system, and begin drawing to it.
renderTile :: (Word32 -> Word32 -> Complex Double -> Complex Double -> Ptr Word8 -> IO ()) -- ([(Double, Double)] -> IO [Color]) -- ^ The rendering action
           -> (Int, Int)   -- ^ The height and width of this tile.
           -> Rectangle (Double, Double)
              -- ^ The region of the dynamical plane corresponding
              --   to this tile.
           -> IO Tile      -- ^ An action which allocates the tile and
                           --   forks a task which draws into it.

renderTile renderingAction (width, height) mRect = do
    putStrLn ("renderTile at w=" ++ show width ++ " h=" ++ show height)

    buf <- mallocForeignPtrBytes (3 * (width + 16) * (height + 16))

    -- Initial fill of the image
    withForeignPtr buf $ \ptr ->
      sequence_ [ pokeColor ptr index grey | index <- [0 .. width * height - 1] ]

    let iRect = rectangle (ImagePoint (0,0))
                          (ImagePoint (fromIntegral width, fromIntegral height))

    redraw     <- newMVar ()  -- used to request a redraw
    managedBuf <- synchronized buf

    let (mRectWidth, mRectHeight) = dimensions mRect

    worker <- async $ progressively fillBlock
                    $ Block { coordToModel = convertRect iRect mRect . fromCoords
                            , compute = renderingAction
                            , logSampleRate = 1
                            , blockBuffer = managedBuf
                            , x0 = 0
                            , y0 = 0
                            , deltaX = mRectWidth / fromIntegral width
                            , deltaY = negate (mRectHeight / fromIntegral height)
                            , xStride = width
                            , xSize = width
                            , ySize = height
                            , shouldRedraw = redraw
                            }
    link worker

    return Tile { imageRect = iRect
                , tileBuffer = managedBuf
                , tileWorker = worker
                , shouldRedrawTile = redraw
                }


module Stats where

-- import Fraction
import Misc
import Maths
import Constants
import Distribution_Tables

import List
import Matrix
import Control.Monad
import System.Random
import Tuple
import Text.Printf

import qualified Data.ByteString.Lazy as BL
import qualified Data.List
import Control.Monad.Trans.State
import System.Process
import System.IO
import Statistics.Distribution.FDistribution
import Numeric.SpecFunctions (incompleteBeta,invIncompleteBeta )
import Data.List(foldl')
------------------------- VALUES

path_data_stats = "/home/mika/Documents/Cours/Stats/data/"

------------------------- DATA TYPES

-- readDF s =

data DataFrame α = DataFrame [Col α]
  -- deriving Show

-- data DFCell = C String

-- instance Show DFCell where
--   show (C s) = s

-- instance Eq DFCell where
--   (C s) == (C s') = s==s'

-- instance Ord DFCell where
--   compare (C s) (C s') = compare s s'

-- instance Show a => Show (DataFrame a) where
--   show (DataFrame cols) = unlines . map (concatWith "|") . transpose . map prepareColumn $ cols
--     where prepareColumn (Col h c) = all_same_size . (h:) . map show $ c
--             where all_same_size l = map (fix'size k) l
--                     where k = reduce max $ map count l

--   show'dataframe :: Matrix (Col String) -> String
-- show'dataframe (Matrix r c cells) =
--   showTable . transpose
--   . map (\(Col t c) -> [t]++c)
--   $ cells

------------------------- DATA CONSTRUCTORS

-- readTable sep = map (splitWhen sep) . lines

-- data DF = DF {
--   getStrings :: DFStr,
--   getNums    :: DFNum
--   }

-- data DFSth α = DFSth {getNames :: [String], getCols :: [C α]}
-- type DFStr = DFSth String
-- type DFNum = DFSth Double

-- data C α = C [Maybe α]

-- colToStrings :: C -> [String]
-- colToStrings (CStr values) = map jstr values
--   where jstr Nothing = "NA"
--         jstr (Just s) = s
-- colToStrings (CNb values) = map jnb values
--   where
--         jnb Nothing = "NA"
--         jnb (Just n) = show n

-- -- not gonna happen
-- -- instance Functor C where
-- --   fmap f (CStr c) = CStr $ f <$> c
-- --   fmap f (CNb c) = CNb $ f <$> c

-- instance Show DF where
-- --  show (DF cols) = ""
--   show (DF names cols) = unlines . map (concatWith "|")
--                          . transpose $ t
--     where scol (title, values) = title : horizbar
--             : colToStrings values
--           horizbar = take 99 (repeat '-')
--           namesbar = map (\t -> [t] ++ [horizbar]) names
--           t = map fixCol $ zipWith (++) namesbar $ map colToStrings cols
-- --          t = map (fixCol . scol) cols -- [[String]]
--           fixCol c = map (fixedLength ' ' k) c
--             where k = foldr max 0 . map length . dropwall $ c
--                   dropwall (x:y:zs) = x:zs

-- -- instance Functor DF where
-- --   fmap f (DF df) = DF . f $ df

-- -- list to fixed length
-- -- fill with e's if too short,
-- -- cut the end if too long
-- fixedLength e n l = (take k $ repeat e) ++ take k' l
--   where k = n - length l
--         k' = min (length l) n

-- -- column-first table from a <Char>-separated string
-- parsecsv :: Char -> String -> [[String]]
-- parsecsv csv_sep str = transpose $ p [] [] [] str False
--   where p table [] [] [] q = table
--         p table line [] [] q = p (table++[line]) [] [] [] q
--         p table line cell [] q = p table (line++[cell]) [] [] q
--         p table line cell s@(x:xs) False
--           | x=='\n'    = p (table ++ [line ++ [cell]]) [] [] xs False
--           | x==csv_sep = p table (line++[cell]) [] xs False
--         p table line cell ('"':'"':xs) quoted =
--           p table line (cell++"\"") xs quoted
--         p table line cell ('"':xs) quoted =
--           p table line cell xs (not quoted)
--         p table line cell (x:xs) quoted =
--           p table line (cell++[x]) xs quoted

-- csv_to_df :: [[String]] -> DF
-- csv_to_df t = DF (flatten names) cols
--   where (names, cols_str) = unzip . map (sliceN 1) $ t
--         cols = map p cols_str
--         p values
--           | all isNumber . concat $  values = CNb
--             $ map (\c -> if length c>0
--                          then Just (readDouble c)
--                          else Nothing) values
--           | otherwise = CStr . map Just $ values

-- -- R like subsetting with boolean vectors
-- -- subdf :: [Bool] -> [Bool] -> DF -> DF
-- -- subdf r c (DF df) = DF . fc . fr $ df

-- fc b (DF names cols) = DF (f names) (f cols)
--   where f = filterBool b
-- -- fc bs df = foldr (\(b,v) -> \vals -> if b then v:vals else vals)
-- --         [] $ zip bs df

-- -- fr b (DF names cols) = DF names $ map (filterBool b) cols
-- --   where fboolcol =

-- filter values by a boolean vector
filterBool b l = foldl f [] $ zip b l
  where f l (b,e) = if b then l++[e] else l

-- fr bs df =

-- table :: C -> T
-- table (CStr c) = 1
-- table (CNb c) = 1

-- weird function (similar to "by")
-- create DataFrame from a table [row]
-- by specifying how to get the factor
dataTableFromTable kfactor kdata l =
  cols
  where factorl = map (!!kfactor) l
        datal   = map (!!kdata) l
        tuples = zip factorl datal
        groups = groupBy comp tuples
          where comp a b = compare (fst a) (fst b)
        titles = map (fst . head) groups
        vals = map (map (readDouble . snd)) groups
        cols = zipWith Col titles vals

-- takes the first element as a header
-- assumes it is a list of columns, (not a list of rows)
tableToDF :: (String -> a) ->  [[String]] -> [Col a]
tableToDF f = map (\(h:c) -> Col h (map f c))

---------------- PROBABILITY

----- PRN

-- rollDie :: (Random a,Num a) => IO a
-- rollDie = randomRIO(1,6)

-- rollNdice n = mapM (\_ -> rollDie) [1..n]

-- rollNdice :: Int -> [Int]
-- rollNdice 0 = []
-- rollNdice n = rollDie

-- rollDie :: State StdGen Int
-- rollDie = state $ randomR (1, 6)

rollDie :: State StdGen Int
rollDie = do
  generator <- get
  let (value,newGen) = randomR (1,6) generator
  put newGen
  return value

-- frd :: (Monad m) => (State ((),s))
-- frd = do
--   a <- get
--   put $ a
--   return ()

-------

----------- Probability

-- choose :: Integral α => α -> α -> α
-- choose n k
--   | n < k     = error "Choose n k"
--   | otherwise = div a b
--   where α = [1..n]
--         β = [1..k] ++ [1..(n-k)]
--         a = foldr (*) 1 α
--         b = foldr (*) 1 β

choose :: Integral α => α -> α -> α
choose n k = reduce (*) α `div` reduce (*) β
  where α = [ max k (n-k) + 1 .. n ]
        β = [1 .. min k (n-k)]

showchooseInt :: Int -> Int -> [[Int]]
showchooseInt n k = showchooseList [0..n-1] k

showchooseList :: [α] -> Int -> [[α]]
showchooseList _ 0 = []
showchooseList l 1 = map (:[]) l
showchooseList l k = flatmap f [drop x l | x <- [0..n-k]]
  where n = count l
        f (x:xs) = map (x:) (showchooseList xs (k-1))

-- binom :: (Integral α) => α -> Fraction -> α -> Fraction
-- binom :: (Fractional b, Integral b) => b -> b -> b -> b
-- binom :: (Num a,Integral b) => b -> a -> b -> a
binom n p k = fromIntegral (choose n k) * p^k * (1-p)^(n-k)

-- dbinom :: (Integral b, Fractional b) => b -> b -> [b]
dbinom n p = map (binom n p) [0..n]

-- cloppearson
--   :: (Show t, Fractional t, Integral t) => t -> Fraction -> [(t, Fraction)]

-- cloppearson :: Fraction -> Fraction -> [(Fraction, Fraction)]
cloppearson n p = let
  dbin = dbinom n p
  props = map (/fromInteger n) [0..(fromInteger n)]
  risk = 0.025
  l = zip props dbin

  f (pacc, acc) (p,b) = if acc+b>risk then (pacc,acc) else (p, acc+b)

  min = foldr f (0,0) l
  max = foldr f (0,0) . reverse $ l

  in [min,max]

-- dbinom :: (Integral α,Real β) => α -> β -> [Fraction]
-- dbinom n p = la ++ middle ++ reverse la
--   where (a,b) = (\(a,b) -> (fromInteger a,b)) $ divMod (toInteger n) 2
--         q=1-p
--         la = map f [0..a-1]
--         middle = map f $ if b == 1 then [] else [a]
--         f = binom n p
        -- something m = (choose n m *) . toFraction $  p^m * q^(n-m)

-- graph'dbinom :: (Integral α,Real β) => α -> β -> IO ()
-- graph'dbinom a b = f $ dbinom a b
--   where f l = putStrLn . ("\n"++) . unlines . map g $ l
--           where m = reduce max l
--                 -- g :: Fraction -> String
--                 g e = ((++) (fix'size 6 ' ' $ printPrecision 2 (e * 100))) . take k . repeat $ '#'
--                   where k = fromInteger . round $ k'
--                         k' =  fromFraction $ 29 * e / m

-- pbinom :: (Integral α, Real β) => α -> β -> Fraction
-- pbinom

-- -- total = number of balls
-- -- goal  = number of "right" balls
-- data Lottery = Lottery {
--   total :: Integer,
--   goal  :: Integer}
--   deriving Show

-- -- compute the probability to get
-- -- k good balls
-- -- from a lottery
-- proba_lottery :: Lottery -> Integer -> Fraction
-- proba_lottery (Lottery n b) k =
--   choose b k * choose (n-b) (b-k) / choose n b

-- all_proba_lottery l = map (proba_lottery l) [0..g]
--   where g = goal l

-- pretty_all_proba_lottery l@(Lottery n b) =
--   putStrLn.unlines.map (printPrecision 15).all_proba_lottery $ l

random01 :: (RandomGen γ) => γ -> (Double, γ)
random01 = (\(a,b) -> (a :: Double, b)) . randomR (0,1)

-- for computation
sqrt2pi = sqrt $ 2 * pi
recipsqrt2pi = 1 / sqrt2pi

{- Normal Distribution -}

-- box-muller
-- normalr mean sd g = ([f cos, f sin],gb)
--   where (ra,ga) = random01 g
--         (rb,gb) = random01 ga
--         c = sqrt $ (-2) * log ra
--         f = (+mean) . (*sd) . (*c) . ($ 2 * pi * rb)

normalr :: (RandomGen g) => Double -> Double -> State g [Double]
normalr mean sd = do
  g <- get
  let (ra,g') = random01 g
      (rb,g'') = random01 g'
      c = sqrt $ (-2) * log ra
      f = (+mean) . (*sd) . (*c) . ($ 2 * pi * rb)
  put g''
  return [f cos, f sin]

-- rnorm mean sd k g
--   | k <= 0    = ([],g)
--   | otherwise = ((take n la) ++ lb ++ lc,g''')
--   where n = min k 2
--         (k',r) = (k-2) `divMod` 2
--         k'' = k' + r
--         ( la  ,g')   = normalr  mean sd     g
--         ( lb  ,g'')  = rnorm mean sd k'  g'
--         ( lc  ,g''') = rnorm mean sd k'' g''

rnorm :: (RandomGen g) => Double -> Double -> Int -> State g [Double]
rnorm mean sd k
  | k <= 0 = return []
  | otherwise = do
      let n = min k 2
          (k',r) = (k-2) `divMod` 2
          k'' = k' + r
      ns <- normalr mean sd
      la <- rnorm mean sd k'
      lb <- rnorm mean sd k''
      return $ take n ns ++ la ++ lb

-- density function
dnorm x mean sd =
  ( recipsqrt2pi / sd )
  * e ** (negate ((x-mean)^2) / (2*sd^2))

-- approximation of the error function
-- http://www.johndcook.com/blog/python_phi/
erf x = signum x * y
  where
    --  constants
    -- todo define out of function ? efficiency? no idea
    a1 =  0.254829592
    a2 = -0.284496736
    a3 =  1.421413741
    a4 = -1.453152027
    a5 =  1.061405429
    p  =  0.3275911

    x' = abs(x)

    -- A & S 7.1.26
    t = 1.0/(1.0 + p*x')
    y = 1.0 - (((((a5*t + a4)*t) + a3)*t + a2)*t + a1)*t* e ** (-x'*x')

-- Cody, W. D. (1993) Algorithm 715: SPECFUN – A portable FORTRAN package of special function routines and test drivers. ACM Transactions on Mathematical Software 19, 22–32
-- integral from -Inf
-- cumulative distribution of the normal function (cdf)
pnorm = (/2) . (+1) . erf . (/sqrt2)

-- Wichura, M. J. (1988) Algorithm AS 241: The percentage points of the normal distribution. Applied Statistics, 37, 477–484
qnorm = undefined

-- beta :: Double
-- beta x y = sqrt2pi * f x * f y / f (x+y)
--   where f e = e ^ (e-0.5)

-----------------------------
{-     TABLE GENERATOR     -}
-----------------------------

-- just like https://homes.cs.washington.edu/~jrl/normal_cdf.pdf
table_cumulative_normal_proba :: String
table_cumulative_normal_proba =
  unlines . addRowSep
  . map (concat . addColSep . intercal "\t" . map tfl)
  $ header : body
  where centi = (/100) <$> [0..9]
        range =  (/10) <$> [-34..34]
        header = ("z":) $ printPrecision 2 . toFraction <$> centi
        row x =
          (printPrecision 1 . toFraction $ x) :
          (printPrecision 4 . toFraction <$> (( pnorm . (add x))
                                              <$> centi))
        body = row <$> range
        add a b = signum a * (abs a + b)
        addColSep (x:y:xs) = x : "┃" : xs
        addRowSep (x:xs) = x : sep : xs
          where l = (`replicate` '━')
                sep = l 7 ++ ('╋' : l 80)
        -- toFixedLength 0 _      = []
        -- toFixedLength k ""     = toFixedLength (k-1) "" ++ " "
        -- toFixedLength k (x:xs) = x : toFixedLength (k-1) xs
        toFixedLength k s = (replicate (k - count s) ' ') ++ take (max k (count s)) s
        tfl = toFixedLength 7

-- Generate F-Distribution tables
-- from a call to Rscript, and R's "qf" function
table_qf_from_R_lol :: Fraction -> IO F_TABLE
table_qf_from_R_lol α =
  ((F_TABLE nums denoms α)<$>)
  $ sequence
  $ (`map`cmds)
  $ callRscript
  . combineLine

  where
        αstr = printPrecision 4 $ 1-α
        nums   = [1..10] ++ [12,15,20,24,30,40,60,120,infinint]
        denoms = [1..30] ++ [40,60,120,infinint]
        -- cmds = gen_cmd <$> nums <*> denoms
        cmds = cmd_generator nums denoms
        combineLine l = "cat(" ++ concatWith [',','"',' ','"',','] l ++ ")"

        gen_cmd num denom = "qf(" ++ αstr
                            ++ ", df1=" ++ show num
                            ++ ", df2=" ++ show denom
                            ++")"

        cmd_generator nums denoms =
          (<$>denoms) $ (\el -> fmap ($ e) (gen_cmd <$> nums))

--callRscript :: String -> IO [Double]
        callRscript s =
          ((\(_,Just hout,_,_) -> hout)
           <$> createProcess (proc "Rscript" ["-e",s]){std_out=CreatePipe})
          >>= ((convert <$>) . hGetContents)
          where convert = map readDouble . words

f_distrib_alphas = [0.1,0.05,0.025,0.01,0.001] :: [Fraction]
io_f_distrib_tables = sequence $ table_qf_from_R_lol <$> f_distrib_alphas

-- -- returns the F critical value
-- -- for a given set of α , df num and df denom
-- -- Nothing if not in pre-computed tables
-- f_stat_critical :: Fraction -> Int -> Int -> Maybe Double
-- f_stat_critical α num denom = safe_head t >>= lookup num denom
--   where t = filter ((==α) . alpha) f_distribution_tables
--         lookup num denom (F_TABLE n d α v) = do
--           ni <- safe_indexOf num   n
--           di <- safe_indexOf denom d
--           return (v !! di !! ni)

f_stat_critical :: Fraction -> Int -> Int -> Maybe Double
f_stat_critical α' n' d' =
  let α = fromFraction α'
      n = fromIntegral n'
      d = fromIntegral d'
      y = n * α
  -- in Just $ incompleteBeta (0.5 * n) (0.5 * d) (y/(d+y))
      x = invIncompleteBeta (0.5 * n) (0.5 * d) α
  in Just $ d * x / (n * (1 - x))

-----------------------------
{- DESCRIPTIVE STATISTICS  -}
-----------------------------

-- mean :: (Fractional α,Foldable t) => t α -> α
-- -- mean l = (/) (count l) (sum l)
-- mean = uncurry (/) . foldr (\a (s,c) -> (s+a,c+1) ) (0,0)

-- sumSq :: (Fractional α,Foldable t,Functor t) => t α -> α
-- sumSq = sum . fmap (^2)

-- varPop :: (Fractional α,Functor t,Foldable t) => t α -> α
-- -- varPop l = (/µ) . sumSq . fmap (µ-) $ l
-- varPop l = sumSq l - (µ^2)
--   where µ = mean l

-- var :: (Fractional α,Functor t,Foldable t) => t α -> α
-- var l = (/(n-1)) . sumSq . fmap (µ-) $ l
--   where n = count l
--         µ = (/n) $ sum l

-- std :: (Real α,Fractional α, Foldable t, Functor t,Floating β) => t α -> β
-- std = sqrt . fromFraction . var

median :: (Ord α,Fractional α) => [α] -> α
median l = (if r == 0
            then head
            else (µ.take 2))
           . drop (q-1) . Data.List.sort $ l
  where (q,r) = (`divMod`2) . count $ l

-- mean after applying function
-- offset to number of values (for n-1)
mean :: (Fractional α) => (α -> α) -> α -> [α] -> α
-- mean f offset values = (/ (count values + offset)) . sum . map f $ values
mean f offset = uncurry (/) . foldr (\ v (s,c) -> (s+f v,c+1) ) (0,offset)

-- µ :: (Fractional α) => [α] -> α
-- µ = (\(a,b)->a/b) . foldl (\(s,k) e->(s+e,k+1)) (0,0)

µ :: (Fractional α) => [α] -> α
µ = mean id 0

-- computes a list's deviations from it's mean
µdeviations :: (Fractional α) => [α] -> [α]
-- µdeviations l = map (subtract mean) l
--   where mean = µ l
µdeviations = (uncurry ((.(subtract.µ)) . (flip map))) . duplicate

-- mean deviation statistic = sum |xi-µx|
mean_deviation δ = mean abs  δ . µdeviations
variance δ       = mean (^2) δ . µdeviations

squares :: (Fractional α) => [α] -> [α]
squares = map (^2)
-- sumsquares = sum . squares

ss :: (Num α,Fractional α) => [α] -> α
ss = sum . squares . µdeviations

σ² :: Fractional c => [c] -> c
σ² = variance 0

σ²' :: Fractional c => [(c,c)] -> c
σ²' l = (sum . map (uncurry (*).applyToFst (^2)) $ l) - ((^2) . sum . map (uncurry (*)) $ l)

σ = sqrt . σ²

s² = variance (-1)
s = sqrt . s²

md_pop    = mean_deviation 0
md_sample = mean_deviation (-1)

-- anniversary :: Integer -> Fraction
-- anniversary k = 1 - reduce (*) [365-k+1..365] % (365^k)

-----------------------------
{- INFERENTIAL STATISTICS  -}
-----------------------------

-- unicode utf-8 utf8 characters
-- ∪∩∀∈

cov :: (Fractional α) => α -> [α] -> [α] -> α
-- cov x y = µ $ deviationsProducts x y
cov δ = ((mean id δ).) . deviationsProducts

-- population's covariance
σxy :: Fractional α => [α] -> [α] -> α
σxy = cov 0

-- sample's covariance
sxy :: Fractional α => [α] -> [α] -> α
sxy = cov (-1)

-- ∀i∈{1,n} (xi - µx) * (yi - µy)
deviationsProducts x y = zipWith (*) (µdeviations x) (µdeviations y)

-- Pearson's correlation coefficient
r :: (Fractional α,Real α) => [α] -> [α] -> Double
r x y =  ssxy / sqrt ( ss x * ss y )
  where ssxy = fromFraction $ sum $ deviationsProducts x y
        ss = fromFraction . sum . squares . µdeviations

r² :: (Fractional α,Real α) => [α] -> [α] -> Double
r² = ((^2).) . r

-- test = do
--   a <- getLine
--   b <- getLine
--   putStrLn $ a ++ b

data AnovaTable = AnovaTable {
                             df :: [Int],
                             ssq :: [Double],
                             ms :: [Double],
                             fStat :: Double,
                             fCritical :: Double,
                             isSignificant :: Bool,
                             significance:: Int}
--                  deriving Show

instance Show AnovaTable where
  show (AnovaTable df ssq ms fStat fCritical _ significance) =
    unlines . (++[show significance,legend]). map (concatWith "\t") $ [a,b,c,d,e]
    where f s f' l = ([s]++) $ map f' l
          f' s l = f s (printf "%.4f") l
          a = f "Df" show df
          b = f' "SS" ssq
          c = f' "MS" ms
          d = f' "F_value" [fStat] ++ [sl]
          e = f' "F_crit" [fCritical]
          sl = [" ",".","*","**","***"] !! significance
          legend = "Signif.codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1"
--oneWay_anova :: (Real α,Fractional α,) => Double -> [[α]] -> AnovaTable
oneWay_anova α cols =
  AnovaTable {
             df = [dfb,dfw,dft],
             ssq = [ssb,ssw,sst],
             ms = [msb,msw],
             fStat = fstat,
             fCritical = fcritical,
             isSignificant = fstat > fcritical,
             significance  = significanceLevel}
  where l = map (\(Col _ v) -> v) cols
        vs = concat l
        mean = µ vs
        n = count vs
        means = map µ l
        counts = map count l
        dfb = count l - 1
        dft = count vs - 1
        dfw = dft - dfb
        ssb = sum $ zipWith (\m c -> c*(m-mean)^2 ) means counts
        ssw = sum . map ss $ l
        sst = ssb + ssw
        msb = ssb / (fromIntegral dfb)
        msw = ssw / (fromIntegral dfw)
        (Just fcritical) = f_stat_critical α dfb dfw
        (Just criticalList) =
          sequence $ map (\a -> f_stat_critical a dfb dfw) ([0.9,0.95,0.99,0.999] :: [Fraction])
        fstat = msb / msw

        significanceLevel = count . filter (fstat>) $ criticalList

test_data_anova = [[7,4,6,8,6,6,2,9],
                   [5,5,3,4,4,7,2,2],
                   [2,4,7,1,2,1,5,5]] :: [[Double]]

-- example:
-- (oneWay_anova 0.95 . dataTableFromTable 4 3 . tail . readTable) <$> readFile (path_data_stats ++ "fisher_iris.txt")

--------------
{- SAMPLING -}
--------------

-- data Sampler = Sampler {
--   randomgen :: RandomGen,

--         --                }
-- pick1 :: (RandomGen γ) => State γ [α] -> State γ (α,[α])
-- pick1 ( (pop,γ)) = do
--   k <- random g
--   let n = count pop
--       (hd,(t:ts)) = splitAt (k `mod` n) pop
--   return (t,hd++ts)

-- pick1 :: (RandomGen γ) => State γ [α] -> State γ (α,[α])
-- pick1 pop = do
--   k <- random
--   let (hd,(t:ts)) = splitAt (k `mod` n) pop
--   return (t,hd++ts)

-- pick1 pop g = ((t,hd++ts),g')
--   where (k,g') = random g
--         n = count pop
--         (hd,(t:ts)) = splitAt (k `mod` n) pop

-- pick One element from pop at random
pick1 :: [α] -> State StdGen (α,[α])
pick1 pop = do
  g <- get
  let (k,g') = random g
      n = count pop
      (hd,(t:ts)) = splitAt (k `mod` n) pop
  put g'
  return (t,hd++ts)

-- get a sample from pop (without replacement)
-- sample :: (Integral β,RandomGen δ) => δ -> β -> [α] -> [α]
sample 0 pop = return ([],pop)
sample k pop = do
  (e,pop') <- pick1 pop
  (l, pop'') <- sample (k-1) pop'
  return (e:l, pop'')

-- get n samples of size k from pop
samples 0 _ pop = return []
samples n k pop = do
  (s, _) <- sample k pop
  l <- samples (n-1) k pop
  return $ s : l

freqs :: (Foldable f , Eq α) => f α -> [(α,Int)]
freqs = quickSortBy snd . foldl' f []
  where f [] e = [(e,1)]
        f (x@(e',k):xs) e | e' == e   = ((e,k+1):xs)
                          | otherwise = x : f xs e