{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Chi-Squared test for uniformity.
module Uniformity (testUniformity) where

import Data.List                    (intercalate)
import Data.List                    (foldl')
import Numeric                      (showFFloat)
import Numeric.SpecFunctions        (incompleteGamma)
import Test.Framework.Providers.API (Test, TestName)

import qualified Data.Map as Map

import MiniQC as QC

-- | \( \lim_{n\to\infty} \mathrm{Pr}(V \le v) = \ldots \)
chiDist
    :: Int     -- ^ k, categories
    -> Double  -- ^ v, value
    -> Double
chiDist k x = incompleteGamma (0.5 * v) (0.5 * x) where
  v = fromIntegral (k - 1)

-- | When the distribution is uniform,
--
-- \[
-- \frac{1}{n} \sum_{s = 1}^k \frac{Y_s^2}{p_s} - n
-- \]
--
-- simplifies to
--
-- \[
-- \frac{k}{n} \sum_{s=1}^k Y_s^2 - n
-- \]
--
-- when \(p_s = \frac{1}{k} \), i.e. \(k\) is the number of buckets.
--
calculateV :: Int -> Map.Map k Int -> Double
calculateV k data_ = chiDist k v
  where
    v          = fromIntegral k * fromIntegral sumY2 / fromIntegral n - fromIntegral n
    V2 n sumY2 = foldl' sumF (V2 0 0) (Map.elems data_) where
        sumF (V2 m m2) x = V2 (m + x) (m2 + x * x)

-- Strict pair of 'Int's, used as an accumulator.
data V2 = V2 !Int !Int

countStream :: Ord a => Stream a -> Int -> Map.Map a Int
countStream = go Map.empty where
    go !acc s n
        | n <= 0    = acc
        | otherwise = case s of
            x :> xs -> go (Map.insertWith (+) x 1 acc) xs (pred n)

testUniformityRaw :: forall a. (Ord a, Show a) => Int -> Stream a -> Either String Double
testUniformityRaw k s
    | Map.size m > k = Left $ "Got more elements (" ++ show (Map.size m, take 5 $ Map.keys m) ++ " than expected (" ++ show k ++ ")"
    | p > 0.999999   = Left $
        "Too impropabable p-value: " ++ show p ++ "\n" ++ table
        [ [ show x, showFFloat (Just 3) (fromIntegral y / fromIntegral n :: Double) "" ]
        | (x, y) <- take 20 $ Map.toList m
        ]
    | otherwise      = Right p
  where
    -- each bucket to have roughly 128 elements
    n :: Int
    n = k * 128

    -- buckets from the stream
    m :: Map.Map a Int
    m = countStream s n

    -- calculate chi-squared value
    p :: Double
    p = calculateV k m

testUniformityQC :: (Ord a, Show a) => Int -> Stream a -> QC.Property
testUniformityQC k s = case testUniformityRaw k s of
    Left err -> QC.counterexample err False
    Right _  -> QC.property True

-- | Test that generator produces values uniformly.
--
-- The size is scaled to be at least 20.
--
testUniformity
    :: forall a b. (Ord b, Show b)
    => TestName
    -> QC.Gen a  -- ^ Generator to test
    -> (a -> b)    -- ^ Partitioning function
    -> Int         -- ^ Number of partittions
    -> Test
testUniformity name gen f k = QC.testMiniProperty name
    $ QC.forAllBlind (streamGen gen)
    $ testUniformityQC k . fmap f

-------------------------------------------------------------------------------
-- Infinite stream
-------------------------------------------------------------------------------

data Stream a = a :> Stream a deriving (Functor)
infixr 5 :>

streamGen :: QC.Gen a -> QC.Gen (Stream a)
streamGen g = gs where
    gs = do
        x <- g
        xs <- gs
        return (x :> xs)

-------------------------------------------------------------------------------
-- Table
-------------------------------------------------------------------------------

table :: [[String]] -> String
table cells = unlines rows
  where
    cols      :: Int
    rowWidths :: [Int]
    rows      :: [String]

    (cols, rowWidths, rows) = foldr go (0, repeat 0, []) cells

    go :: [String] -> (Int, [Int], [String]) -> (Int, [Int], [String])
    go xs (c, w, yss) =
        ( max c (length xs)
        , zipWith max w (map length xs ++ repeat 0)
        , intercalate "   " (take cols (zipWith fill xs rowWidths))
          : yss
        )

    fill :: String -> Int -> String
    fill s n = s ++ replicate (n - length s) ' '


module Math.Probably.Circular where

import Math.Probably.FoldingStats
import Numeric.LinearAlgebra
import Control.Applicative

--approximate method first mentioned http://en.wikipedia.org/wiki/Mean_of_circular_quantities
circularMean :: Fold Double Double
circularMean = before (after vmean getAngle) toCartesian where
  vmean = pure (scale) <*> after realLengthF recip <*> sumF
  getAngle v = atan2 (v@>1) (v@>0)
  toCartesian alpha = fromList [cos alpha, sin alpha]

--http://webspace.ship.edu/pgmarr/Geo441/Lectures/Lec%2016%20-%20Directional%20Statistics.pdf
circularDispersion :: Fold Double Double
circularDispersion = after (both xs ys) getR where
  xs = before sumF cos
  ys = before sumF sin
  getR (x,y) = sqrt (x*x + y*y)

--example for running statistic

runCircularMean :: [Double] -> Double
runCircularMean = runStat circularMean


module ActivationFunction
    ( step'
    , sigmoid
    , relu
    , softMax'
    ) where

import Numeric.LinearAlgebra

step' :: (Element b, Container c a, Ord a, Num a, Num b) => c a -> c b
step' = cmap (\x -> if x>0 then 1 else 0)

sigmoid :: (Container c b, Floating b) => c b -> c b
sigmoid = cmap (\x -> 1 / (1 + exp(-x)))

relu :: (Container c b, Ord b, Num b) => c b -> c b
relu = cmap (max 0)

-- This function is deprecated, causes overflow.
softMax :: (Container c b, Floating b) => c b -> c b
softMax xs = cmap (/sumCexp) $ cexp xs
    where sumCexp = (sumElements . cexp) xs

softMax' :: (Container c b, Floating b) => c b -> c b
softMax' xs = cmap (/sumCexp) $ cexp' xs
    where sumCexp = (sumElements . cexp') xs

cexp :: (Container c b, Floating b) => c b -> c b
cexp = cmap exp

cexp' :: (Container c b, Floating b) => c b -> c b
cexp' xs = cexp $ cmap (subtract $ maxElement xs) xs


module Math(hamming, preemphasis, sliding, toMesh, spectrogram) where

import RIO
import RIO.List (mapAccumL, zipWith)
import Control.Parallel.Strategies
import Data.Complex
import qualified Numeric.FFT as NF

sliding :: Int -> Int -> a -> [a] -> [[a]]
sliding step size padding xs
    | len < size = [xs ++ replicate (size - len) padding]
    | otherwise  = take size xs : sliding step size padding (drop step xs)
    where len = length xs

preemphasis :: Complex Double -> [Complex Double] -> [Complex Double]
preemphasis emph = snd . mapAccumL (\prev y -> (y, y - emph * prev)) 0.0

hamming :: [Complex Double] -> [Complex Double]
hamming signal = let len = length signal
                  in zipWith (*) signal $ hamming' len 0.53

hamming' :: Int -> Complex Double -> [Complex Double]
hamming' n alpha =
    let beta = 1 - alpha
     in [alpha - beta * cos(2 * pi * fromIntegral i / (fromIntegral n - 1)) | i <- [0..n - 1]]

toMesh :: (Num c) => [[c]] -> [[(c, c, c)]]
toMesh dd = do
    (x, fs) <- zip ([1..] :: [Integer]) dd
    return $ do
        (y, p) <- zip ([0..] :: [Integer]) fs
        return (fromIntegral x, fromIntegral y, p)

spectrogram :: Int -> Int -> [Complex Double] -> [[Complex Double]]
spectrogram step len signal = let ft = take (len `div` 2) . NF.fft . hamming
                                  windows = sliding step len 0 signal
                                  nWindows = length windows
                                  strat = parListChunk (nWindows `div` 4) rdeepseq
                              in ft <$> windows `using` strat


module Main where

import qualified Data.Attoparsec.Text as P
import Exercise
import Numeric.LinearAlgebra hiding ((<>))
import qualified Data.Map as M
import Data.List
import Text.Printf ( printf )

-- Parsing
--------------------------------------------------

type Input = [Int]

fishParser :: P.Parser [Int]
fishParser =
  P.decimal `P.sepBy` P.char ','

inputParser :: P.Parser Input
inputParser =
  fishParser <* P.skipSpace <* P.endOfInput

-- Linear Algebra
--------------------------------------------------

-- | Simple matrix powers.
-- Does not use repeated squaring.
pow :: Matrix R -> Int -> Matrix R
pow m n
  | n <= 0 = ident (rows m)
  | n == 1 = m
  | even n = pow (m <> m) (n `div` 2)
  | otherwise = m <> pow m (n - 1)

-- | Convert a list of numbers to a vector of counts
-- This could be more efficient by accumulating counts, but this is good enough.
toCounts :: [Int] -> Vector R
toCounts = fromList . toFrequencies . M.fromListWith (+) . flip zip (repeat 1)
  where
    toFrequencies m =
      map (maybe 0 id . flip M.lookup m) [0..8]

-- Main
--------------------------------------------------

main :: IO ()
main = do
  input <- parseInput inputParser
  numFish1 <- runExercise "Part 1" (countFish 7 2 80) input
  printf "Number of fish: %d\n" numFish1
  numFish2 <- runExercise "Part 2" (countFish 7 2 256) input
  printf "Number of fish: %d\n" numFish2

-- numFish2 <- runExercise "Part 2" part2 input
-- printf "Losing Score: %d\n" score2

countFish :: Int -> Int -> Int -> Input -> Int
countFish gestation adolescence generations fish =
  let fishVector = toCounts fish
      generationMatrix = makeGenerationMatrix gestation adolescence
   in truncate . sumElements $ pow generationMatrix generations #> fishVector

makeGenerationMatrix :: Int -> Int -> Matrix R
makeGenerationMatrix gestation adolescence =
  let size = gestation + adolescence
      modifyNth n f xs =
        let (a, b : c) = splitAt n xs
         in a ++ f b : c
      emptyRow = replicate size 0
      row n = modifyNth n (+ 1) emptyRow
      basic = map row [1 .. (size - 1)] ++ [row 0]
      withGestation = modifyNth (gestation - 1) (modifyNth 0 (+ 1)) basic
   in fromLists withGestation


-- File created: 2009-07-15 21:15:44

{-# LANGUAGE Rank2Types #-}

module Haschoo.Evaluator.Standard.Numeric
   (procedures, isNumeric, isExact, numEq, asInt) where

import Control.Arrow     ((&&&), (***))
import Control.Monad     (ap, foldM)
import Data.Array.IArray (elems)
import Data.Array.MArray (getElems)
import Data.Char         (intToDigit)
import Data.Complex      ( Complex((:+)), mkPolar
                         , imagPart, realPart, phase, magnitude)
import Data.Ratio        (numerator, denominator, approxRational)
import Data.Function     (on)
import Numeric           (showIntAtBase, showSigned)

import qualified Haschoo.Parser as Parser
import           Haschoo.Types           (ScmValue(..), toScmMString)
import           Haschoo.Utils           (ErrOr, allM, ($<), (.:))
import           Haschoo.Evaluator.Utils (tooFewArgs, tooManyArgs, notInt)

procedures :: [(String, ScmValue)]
procedures = map (\(a,b) -> (a, ScmFunc a (return . b)))
   [ ("number?",   fmap ScmBool . scmIsNumber)
   , ("complex?",  fmap ScmBool . scmIsNumber)
   , ("real?",     fmap ScmBool . scmIsReal)
   , ("rational?", fmap ScmBool . scmIsRational)
   , ("integer?",  fmap ScmBool . scmIsInteger)

   , "exact?"   $< id &&& fmap  ScmBool        .: scmIsExact
   , "inexact?" $< id &&& fmap (ScmBool . not) .: scmIsExact

   , ("=", fmap ScmBool . scmNumEq)
   , "<"  $< id &&& fmap ScmBool .: scmCompare (<)
   , ">"  $< id &&& fmap ScmBool .: scmCompare (>)
   , "<=" $< id &&& fmap ScmBool .: scmCompare (<=)
   , ">=" $< id &&& fmap ScmBool .: scmCompare (>=)

   , ("zero?",     fmap ScmBool . scmIsZero)
   , ("positive?", fmap ScmBool . scmIsPos)
   , ("negative?", fmap ScmBool . scmIsNeg)
   , "even?" $< id &&& fmap  ScmBool        .: scmIsEven
   , "odd?"  $< id &&& fmap (ScmBool . not) .: scmIsEven

   , ("max", scmMax)
   , ("min", scmMin)

   , ("+", scmPlus)
   , ("-", scmMinus)
   , ("*", scmMul)
   , ("/", scmDiv)

   , ("abs", scmAbs)

   , ("quotient",  scmQuot)
   , ("remainder", scmRem)
   , ("modulo",    scmMod)

   , ("gcd", scmGcd)
   , ("lcm", scmLcm)

   , ("numerator",   scmNumerator)
   , ("denominator", scmDenominator)

   , ("floor",    scmFloor)
   , ("ceiling",  scmCeil)
   , ("truncate", scmTrunc)
   , ("round",    scmRound)

   , ("rationalize", scmRationalize)

   , ("exp",  scmExp)
   , ("log",  scmLog)
   , ("sin",  scmSin)
   , ("cos",  scmCos)
   , ("tan",  scmTan)
   , ("asin", scmAsin)
   , ("acos", scmAcos)
   , ("atan", scmAtan)

   , ("sqrt", scmSqrt)
   , ("expt", scmExpt)

   , ("make-rectangular", scmMakeRectangular)
   , ("make-polar",       scmMakePolar)
   , ("real-part",        scmRealPart)
   , ("imag-part",        scmImagPart)
   , ("magnitude",        scmNorm)
   , ("angle",            scmAngle)

   , ("exact->inexact", scmToInexact)
   , ("inexact->exact", scmToExact) ]

   ++ map (\(a,b) -> (a, ScmFunc a b))
   [ ("number->string", scmToString)
   , ("string->number", scmToNumber) ]

---- Predicates

scmIsNumber, scmIsReal, scmIsRational, scmIsInteger :: [ScmValue] -> ErrOr Bool
scmIsNumber [x] = Right $ isNumeric x
scmIsNumber []  = tooFewArgs  "number?"
scmIsNumber _   = tooManyArgs "number?"

scmIsReal [x] = Right $ isReal x
scmIsReal []  = tooFewArgs  "real?"
scmIsReal _   = tooManyArgs "real?"

scmIsRational [ScmRat _] = Right True
scmIsRational [x]        = Right $ isInteger x
scmIsRational []         = tooFewArgs "rational?"
scmIsRational _          = tooManyArgs "rational?"

scmIsInteger [x] = Right $ isInteger x
scmIsInteger []  = tooFewArgs  "integer?"
scmIsInteger _   = tooManyArgs "integer?"

scmIsExact :: String -> [ScmValue] -> ErrOr Bool
scmIsExact _ [x] | isNumeric x = Right $ isExact x
scmIsExact s [_]               = notNum s
scmIsExact s []                = tooFewArgs s
scmIsExact s _                 = tooManyArgs s

isExact :: ScmValue -> Bool
isExact (ScmInt _) = True
isExact (ScmRat _) = True
isExact _          = False

---- Comparison

scmNumEq :: [ScmValue] -> ErrOr Bool
scmNumEq [] = tooFewArgs "="
scmNumEq xs = allM f . (zip`ap`tail) $ xs
 where
   f (a,b) = if isNumeric a && isNumeric b
                then Right $ numEq a b
                else notNum "="

numEq :: ScmValue -> ScmValue -> Bool
numEq x y =
   case pairScmComplex x y of
        Right (ScmInt     a, ScmInt     b) -> a == b
        Right (ScmRat     a, ScmRat     b) -> a == b
        Right (ScmReal    a, ScmReal    b) -> a == b
        Right (ScmComplex a, ScmComplex b) -> a == b
        _ -> error "numEq :: the impossible happened"

scmCompare :: (forall a. Real a => a -> a -> Bool)
           -> String -> [ScmValue] -> ErrOr Bool
scmCompare p s xs@(_:_:_) = allM f . (zip`ap`tail) $ xs
 where
   f (a,b) = case liftScmRealA2 p a b of
                  Left _ -> notReal s
                  x      -> x

scmCompare _ s _ = tooFewArgs s

scmIsZero :: [ScmValue] -> ErrOr Bool
scmIsZero [ScmInt     0]    = Right True
scmIsZero [ScmRat     0]    = Right True
scmIsZero [ScmReal    0]    = Right True
scmIsZero [ScmComplex 0]    = Right True
scmIsZero [x] | isNumeric x = Right False
scmIsZero [_]               = notNum "zero?"
scmIsZero _                 = tooManyArgs "zero?"

scmIsPos, scmIsNeg :: [ScmValue] -> ErrOr Bool
scmIsPos [x] = scmCompare (>) "positive?" [x, ScmInt 0]
scmIsPos _   = tooManyArgs "positive?"

scmIsNeg [x] = scmCompare (<) "negative?" [x, ScmInt 0]
scmIsNeg _   = tooManyArgs "negative?"

scmIsEven :: String -> [ScmValue] -> ErrOr Bool
scmIsEven s [x] = if isInteger x
                     then (scmIsZero.return) =<< scmMod [x, ScmInt 2]
                     else notInt s
scmIsEven s _   = tooManyArgs s

scmMax, scmMin :: [ScmValue] -> ErrOr ScmValue
scmMax = scmMinMax max "max"
scmMin = scmMinMax min "min"

scmMinMax :: (forall a. Real a => a -> a -> a) -> String
          -> [ScmValue] -> ErrOr ScmValue
scmMinMax _ s []     = tooFewArgs s
scmMinMax f s (x:xs) = if isNumeric x then foldM go x xs else notNum s
 where
   go n a = if isNumeric a
               then case liftScmReal2 f n a of
                         Left _ -> notReal s
                         m      -> m
               else notNum s

---- +-*/

scmPlus, scmMinus, scmMul, scmDiv :: [ScmValue] -> ErrOr ScmValue
scmPlus [] = Right $ ScmInt 0
scmPlus xs = foldM go (ScmInt 0) xs
 where
   go n x = if isNumeric x then liftScmNum2 (+) n x else notNum "+"

scmMinus []                        = tooFewArgs "-"
scmMinus (x:_) | not (isNumeric x) = notNum "-"
scmMinus [x]                       = liftScmNum negate x
scmMinus (x:xs)                    = foldM go x xs
 where
   go n a = if isNumeric a then liftScmNum2 (-) n a else notNum "-"

scmMul [] = Right $ ScmInt 1
scmMul xs = foldM go (ScmInt 1) xs
 where
   go n x = if isNumeric x then liftScmNum2 (*) n x else notNum "*"

scmDiv []     = tooFewArgs "/"
scmDiv (x:xs) =
   unint x >>= case xs of
                    []  -> liftScmFrac recip
                    _:_ -> flip (foldM go) xs
 where
   go n a = unint a >>= liftScmFrac2 (/) n

   unint (ScmInt n) = Right $ ScmRat (fromInteger n)
   unint n          = if isNumeric x then Right n else notNum "/"

---- abs

scmAbs :: [ScmValue] -> ErrOr ScmValue
scmAbs [x] =
   if isReal x
      then liftScmNum abs x
      else notReal "abs"
scmAbs [] = tooFewArgs  "abs"
scmAbs _  = tooManyArgs "abs"

---- quot rem mod

scmQuot, scmRem, scmMod :: [ScmValue] -> ErrOr ScmValue
scmQuot = scmQuotRemMod quot "quotient"
scmRem  = scmQuotRemMod rem "remainder"
scmMod  = scmQuotRemMod mod "modulo"

scmQuotRemMod :: (Integer -> Integer -> Integer) -> String
              -> [ScmValue] -> ErrOr ScmValue
scmQuotRemMod f s [x,y] = do
   (e1,a) <- asInt s x
   (e2,b) <- asInt s y
   return . (if e1 && e2 then ScmInt else ScmReal . fromInteger) $ f a b
scmQuotRemMod _ s (_:_:_) = tooManyArgs s
scmQuotRemMod _ s _       = tooFewArgs  s

---- gcd lcm

scmGcd, scmLcm :: [ScmValue] -> ErrOr ScmValue
scmGcd = scmGcdLcm (\a b -> if a == 0 && b == 0 then 0 else gcd a b) 0 "gcd"
scmLcm = scmGcdLcm lcm 1 "lcm"

scmGcdLcm :: (Integer -> Integer -> Integer) -> Integer -> String
          -> [ScmValue] -> ErrOr ScmValue
scmGcdLcm f i s = fmap fin . foldM go (True,i)
 where
   go  (exact, n) = fmap ((exact &&) *** f n) . asInt s
   fin (exact, n) = if exact then ScmInt n else ScmReal (fromInteger n)

---- numerator denominator

scmNumerator, scmDenominator :: [ScmValue] -> ErrOr ScmValue
scmNumerator   = scmNumerDenom numerator   "numerator"
scmDenominator = scmNumerDenom denominator "denominator"

scmNumerDenom :: (Rational -> Integer) -> String
              -> [ScmValue] -> ErrOr ScmValue
scmNumerDenom f s [n] =
   case n of
        ScmInt      x       -> Right . ScmInt  $ f (fromInteger x)
        ScmRat      x       -> Right . ScmInt  $ f x
        ScmReal     x       -> Right . ScmReal . fromInteger $ f (realToFrac x)
        ScmComplex (x :+ 0) -> Right . ScmReal . fromInteger $ f (realToFrac x)
        _                   -> notRat s

scmNumerDenom _ s [] = tooFewArgs s
scmNumerDenom _ s _  = tooManyArgs s

---- floor ceil trunc round

scmFloor, scmCeil, scmTrunc, scmRound :: [ScmValue] -> ErrOr ScmValue
scmFloor = scmGenericRound floor    "floor"
scmCeil  = scmGenericRound ceiling  "ceiling"
scmTrunc = scmGenericRound truncate "truncate"
scmRound = scmGenericRound round    "round"

scmGenericRound :: (forall a. RealFrac a => a -> Integer) -> String
                -> [ScmValue] -> ErrOr ScmValue
scmGenericRound _ _ [   ScmInt     x]  = Right . ScmInt                $ x
scmGenericRound f _ [   ScmRat     x]  = Right . ScmInt                $ f x
scmGenericRound f _ [   ScmReal    x]  = Right . ScmReal . fromInteger $ f x
scmGenericRound _ s [n@(ScmComplex _)] =
   case asInt s n of
        Right (_,x) -> Right . ScmInt $ x
        Left _      -> notReal s
scmGenericRound _ s [_]            = notNum s
scmGenericRound _ s []             = tooFewArgs s
scmGenericRound _ s _              = tooManyArgs s

---- rationalize

scmRationalize :: [ScmValue] -> ErrOr ScmValue
scmRationalize (_:_:_:_) = tooManyArgs "rationalize"
scmRationalize [x,y]     =
   case liftScmRealFracB2 approxRational x y of
        Left _           -> notReal "rationalize"
        Right (True , n) -> Right (ScmRat  n)
        Right (False, n) -> Right (ScmReal (fromRational n))

scmRationalize _         = tooFewArgs "rationalize"

---- exp log sin cos tan asin acos atan sqrt

scmExp, scmLog,
 scmSin,  scmCos,  scmTan,
 scmAsin, scmAcos, scmAtan,
 scmSqrt :: [ScmValue] -> ErrOr ScmValue

scmExp  = scmComplex1 exp  "exp"
scmLog  = scmComplex1 log  "log"
scmSin  = scmComplex1 sin  "sin"
scmCos  = scmComplex1 cos  "cos"
scmTan  = scmComplex1 tan  "tan"
scmAsin = scmComplex1 asin "asin"
scmAcos = scmComplex1 acos "acos"

scmAtan [y,x] =
   case pairScmReal x y of
        Left  _                      -> notReal "atan"
        Right (ScmReal a, ScmReal b) -> Right (ScmReal $ phase $ a :+ b)
        Right (ScmInt a, ScmInt b)   ->
           Right (ScmReal $ phase $ fromInteger a :+ fromInteger b)
        Right (ScmRat a, ScmRat b)   ->
           Right (ScmReal $ phase $ fromRational a :+ fromRational b)
        Right _                      -> error "scmAtan :: internal error"

scmAtan xs    = scmComplex1 atan "atan" xs

scmSqrt = scmComplex1 sqrt "sqrt"

scmComplex1 :: (Complex Double -> Complex Double) -> String
            -> [ScmValue] -> ErrOr ScmValue
scmComplex1 f _ [ScmInt     x] = Right . fromComplex $ f (fromInteger  x :+ 0)
scmComplex1 f _ [ScmRat     x] = Right . fromComplex $ f (fromRational x :+ 0)
scmComplex1 f _ [ScmReal    x] = Right . fromComplex $ f (x :+ 0)
scmComplex1 f _ [ScmComplex x] = Right . fromComplex $ f x
scmComplex1 _ s [_]            = notNum s
scmComplex1 _ s []             = tooFewArgs s
scmComplex1 _ s _              = tooManyArgs s

---- expt

scmExpt :: [ScmValue] -> ErrOr ScmValue
scmExpt [x,y] =
   case pairScmComplex x y of
        Left _                              -> notNum "expt"
        Right (ScmInt     a, ScmInt      b) ->
           if b < 0
              then Right . ScmReal $ fromInteger a ^^ b
              else Right . ScmInt  $ a ^ b
        Right (ScmReal    a, ScmReal     b) -> Right . ScmReal    $ a ** b
        Right (ScmComplex a, ScmComplex  b) -> Right . ScmComplex $ a ** b
        Right (ScmRat     a, ScmRat      b) ->
           Right . ScmReal $ fromRational a ** fromRational b
        Right _                             -> error "expt :: internal error"

scmExpt (_:_:_) = tooManyArgs "expt"
scmExpt _       = tooFewArgs  "expt"

---- make-rectangular make-polar real-part imag-part magnitude angle

scmMakeRectangular, scmMakePolar :: [ScmValue] -> ErrOr ScmValue
scmMakeRectangular = scmMakeComplex (:+)    "make-rectangular"
scmMakePolar       = scmMakeComplex mkPolar "make-polar"

scmMakeComplex :: (Double -> Double -> Complex Double) -> String
               -> [ScmValue] -> ErrOr ScmValue
scmMakeComplex f s [x,y] =
   case pairScmReal x y of
        Left _                       -> notReal s
        Right (ScmReal a, ScmReal b) -> Right . ScmComplex $ f a b
        Right (ScmRat  a, ScmRat  b) ->
           Right . ScmComplex $ (f `on` fromRational) a b
        Right (ScmInt  a, ScmInt  b) ->
           Right . ScmComplex $ (f `on` fromInteger) a b
        Right _                      ->
           error $ s ++ " :: internal error"

scmMakeComplex _ s (_:_:_) = tooManyArgs s
scmMakeComplex _ s _       = tooFewArgs  s

scmRealPart, scmImagPart, scmNorm, scmAngle :: [ScmValue] -> ErrOr ScmValue
scmRealPart = scmComplexPart realPart  Right                  "real-part"
scmImagPart = scmComplexPart imagPart  (liftScmNum $ const 0) "imag-part"
scmNorm     = scmComplexPart magnitude (liftScmNum abs)       "magnitude"
scmAngle    = scmComplexPart phase     (Right . angle)        "angle"
 where
   angle (ScmReal n) = f ScmReal n
   angle (ScmRat  n) = f ScmRat  n
   angle (ScmInt  n) = f ScmInt  n
   angle _           = error "angle :: the impossible happened"

   f c n = if n >= 0 then c 0 else ScmReal pi

scmComplexPart :: (Complex Double -> Double)
               -> (ScmValue -> ErrOr ScmValue)
               -> String
               -> [ScmValue] -> ErrOr ScmValue
scmComplexPart f _ _ [ScmComplex x]    = Right $ ScmReal (f x)
scmComplexPart _ g _ [x] | isNumeric x = g x
scmComplexPart _ _ s [_]               = notNum s
scmComplexPart _ _ s []                = tooFewArgs s
scmComplexPart _ _ s _                 = tooManyArgs s

---- exact->inexact inexact->exact

scmToInexact, scmToExact :: [ScmValue] -> ErrOr ScmValue
scmToInexact [ScmInt x]         = Right $ ScmReal (fromInteger  x)
scmToInexact [ScmRat x]         = Right $ ScmReal (fromRational x)
scmToInexact [x] | isNumeric x  = Right x
scmToInexact [_]                = notNum      "exact->inexact"
scmToInexact []                 = tooFewArgs  "exact->inexact"
scmToInexact _                  = tooManyArgs "exact->inexact"

scmToExact [ScmReal    x]     =
   let r = toRational x
    in Right $ if denominator r == 1
                  then ScmInt (numerator r)
                  else ScmRat r
scmToExact [ScmComplex x]     =
   case imagPart x of
        0 -> Right $ ScmReal (realPart x)
        _ -> fail $ "inexact->exact :: implementation restriction: " ++
                    "can't exactify complex numbers"
scmToExact [x] | isNumeric x  = Right x
scmToExact [_]                = notNum      "exact->inexact"
scmToExact []                 = tooFewArgs  "exact->inexact"
scmToExact _                  = tooManyArgs "exact->inexact"

---- number->string string->number

scmToString, scmToNumber :: [ScmValue] -> IO (ErrOr ScmValue)

-- TODO: scmShow should use this or vice versa
scmToString (x:xs) | isNumeric x =
   case xs of
        []             -> g x 10
        [ScmInt radix] ->
           if radix `elem` [2,8,10,16]
              then g x (fromInteger radix)
              else return. fail $
                      "number->string :: invalid radix " ++ show radix

        [_] -> return$ notInt      "number->string"
        _   -> return$ tooManyArgs "number->string"
 where
   g n radix = case f n radix of
                    Left  err -> return$ fail err
                    Right s   -> fmap Right $ toScmMString s

   f (ScmInt i) radix = Right $ showInt radix i
   f (ScmRat r) radix = Right $
      if denominator r == 1
         then showInt radix (numerator r)
         else concat [ showInt radix (numerator r)
                     , "/"
                     , showInt radix (denominator r) ]

   f (ScmReal r) radix =
      if radix == 10
         then Right $
                 case () of
                      _| isNaN      r -> "+nan.#"
                       | isInfinite r -> (if r < 0 then '-' else '+') : "inf.#"

                       -- R5RS 6.2.6 specifies that "the result contains a
                       -- decimal point" if inexact and a decimal-point
                       -- containing result can make it work
                       | otherwise    -> show r
         else fail "number->string :: nondecimal radix for inexact real"

   f (ScmComplex (a :+ b)) radix =
      -- As in the ScmReal case
      if radix == 10
         then Right . concat $ let bs = either undefined id $ f (ScmReal b) 10
                                in [ either undefined id $ f (ScmReal a) 10
                                   , if head bs `elem` "-+" then [] else "+"
                                   , bs
                                   , "i" ]

         else fail "number->string :: nondecimal radix for inexact complex"

   f _ _ = error "number->string :: the impossible happened"

   showInt radix i = showSigned (showIntAtBase radix intToDigit) 0 i ""

scmToString [] = return$ tooFewArgs "number->string"
scmToString _  = return$ notNum     "number->string"

scmToNumber (ScmString  s : xs) = return$ toNumHelper xs     (elems s)
scmToNumber (ScmMString s : xs) = fmap   (toNumHelper xs) (getElems s)
scmToNumber [] = return$ tooFewArgs "string->number"
scmToNumber _  = return$ fail "Nonstring argument to string->number"

toNumHelper :: [ScmValue] -> String -> ErrOr ScmValue
toNumHelper xs s =
   case xs of
        []             -> Right $ f s 10
        [ScmInt radix] ->
           if radix `elem` [2,8,10,16]
              then Right $ f s (fromInteger radix)
              else fail $ "string->number :: invalid radix " ++ show radix

        [_]            -> notInt       "string->number"
        _              -> tooManyArgs  "string->number"
 where
   f str radix =
       case Parser.runParser (Parser.number radix) "" str of
            Right n | isNumeric n -> n
            _                     -> ScmBool False

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

notNum, notReal, notRat :: String -> ErrOr a
notNum  = fail . ("Nonnumeric argument to " ++)
notReal = fail . ("Nonreal argument to " ++)
notRat  = fail . ("Nonrational argument to " ++)

isNumeric, isInteger, isReal :: ScmValue -> Bool
isNumeric (ScmInt     _) = True
isNumeric (ScmRat     _) = True
isNumeric (ScmReal    _) = True
isNumeric (ScmComplex _) = True
isNumeric _              = False

isInteger (ScmInt     _)      = True
isInteger (ScmRat     x)      = denominator x == 1
isInteger (ScmReal    x)      = x == fromInteger (round x)
isInteger (ScmComplex (a:+b)) = b == 0 && a == fromInteger (round a)
isInteger _                   = False

isReal (ScmComplex (_ :+ b)) = b == 0
isReal x                     = isNumeric x

asInt :: String -> ScmValue -> ErrOr (Bool, Integer)
asInt s x | not (isInteger x) = notInt s
asInt _ (ScmInt     x)        = Right (True,  x)
asInt _ (ScmRat     x)        = Right (True,  numerator x)
asInt _ (ScmReal    x)        = Right (False, round x)
asInt _ (ScmComplex (x:+0))   = Right (False, round x)
asInt _ _                     = error "This can't happen"

fromComplex :: Complex Double -> ScmValue
fromComplex (x :+ 0) = ScmReal x
fromComplex x        = ScmComplex x

-- Lift ScmValue's numeric types to a common type
--
-- Versions without 'A' at the end also return results in the correct
-- constructor of the two given. Versions with 'B' just return whether the
-- result should be exact or not.
--
-- Ugly and verbose... too lazy to metaize these {{{

--- Num
liftScmNum :: (forall a. Num a => a -> a) -> ScmValue -> ErrOr ScmValue
liftScmNum f (ScmInt     a) = Right . ScmInt     $ f a
liftScmNum f (ScmRat     a) = Right . ScmRat     $ f a
liftScmNum f (ScmReal    a) = Right . ScmReal    $ f a
liftScmNum f (ScmComplex a) = Right . ScmComplex $ f a
liftScmNum _ _ = fail "liftScmNum :: internal error"

liftScmNum2 :: (forall a. Num a => a -> a -> a)
            -> (ScmValue -> ScmValue -> ErrOr ScmValue)
liftScmNum2 f (ScmInt     a) (ScmInt     b) = Right . ScmInt    $ f a b
liftScmNum2 f (ScmRat     a) (ScmRat     b) = Right . ScmRat    $ f a b
liftScmNum2 f (ScmReal    a) (ScmReal    b) = Right . ScmReal   $ f a b
liftScmNum2 f (ScmComplex a) (ScmComplex b) = Right . ScmComplex$ f a b

-- Int+{Rat,Real,Complex}
liftScmNum2 f (ScmInt     a) (ScmRat     b) = Right . ScmRat    $ f (fInt a) b
liftScmNum2 f (ScmRat     a) (ScmInt     b) = Right . ScmRat    $ f a (fInt b)
liftScmNum2 f (ScmInt     a) (ScmReal    b) = Right . ScmReal   $ f (fInt a) b
liftScmNum2 f (ScmReal    a) (ScmInt     b) = Right . ScmReal   $ f a (fInt b)
liftScmNum2 f (ScmInt     a) (ScmComplex b) = Right . ScmComplex$ f (fInt a) b
liftScmNum2 f (ScmComplex a) (ScmInt     b) = Right . ScmComplex$ f a (fInt b)

-- Rat+{Real,Complex}
liftScmNum2 f (ScmRat     a) (ScmReal    b) = Right . ScmReal   $ f (fRat a) b
liftScmNum2 f (ScmReal    a) (ScmRat     b) = Right . ScmReal   $ f a (fRat b)
liftScmNum2 f (ScmRat     a) (ScmComplex b) = Right . ScmComplex$ f (fRat a) b
liftScmNum2 f (ScmComplex a) (ScmRat     b) = Right . ScmComplex$ f a (fRat b)

-- Real+Complex
liftScmNum2 f (ScmReal    a) (ScmComplex b) = Right . ScmComplex$ f (a :+ 0) b
liftScmNum2 f (ScmComplex a) (ScmReal    b) = Right . ScmComplex$ f a (b :+ 0)

liftScmNum2 _ _ _ = fail "liftScmNum2 :: internal error"

--- Frac
liftScmFrac :: (forall a. Fractional a => a -> a) -> ScmValue -> ErrOr ScmValue
liftScmFrac f (ScmRat     a) = Right . ScmRat     $ f a
liftScmFrac f (ScmReal    a) = Right . ScmReal    $ f a
liftScmFrac f (ScmComplex a) = Right . ScmComplex $ f a
liftScmFrac _ _ = fail "liftScmFrac :: internal error"

liftScmFrac2 :: (forall a. Fractional a => a -> a -> a)
             -> (ScmValue -> ScmValue -> ErrOr ScmValue)
liftScmFrac2 f (ScmRat     a) (ScmRat     b) = Right . ScmRat    $ f a b
liftScmFrac2 f (ScmReal    a) (ScmReal    b) = Right . ScmReal   $ f a b
liftScmFrac2 f (ScmComplex a) (ScmComplex b) = Right . ScmComplex$ f a b

-- Rat+{Real,Complex}
liftScmFrac2 f (ScmRat     a) (ScmReal    b) = Right . ScmReal   $ f (fRat a) b
liftScmFrac2 f (ScmReal    a) (ScmRat     b) = Right . ScmReal   $ f a (fRat b)
liftScmFrac2 f (ScmRat     a) (ScmComplex b) = Right . ScmComplex$ f (fRat a) b
liftScmFrac2 f (ScmComplex a) (ScmRat     b) = Right . ScmComplex$ f a (fRat b)

-- Real+Complex
liftScmFrac2 f (ScmReal    a) (ScmComplex b) = Right . ScmComplex$ f (a :+ 0) b
liftScmFrac2 f (ScmComplex a) (ScmReal    b) = Right . ScmComplex$ f a (b :+ 0)

liftScmFrac2 _ _ _ = fail "liftScmFrac2 :: internal error"

--- Real
liftScmReal2 :: (forall a. Real a => a -> a -> a)
             -> (ScmValue -> ScmValue -> ErrOr ScmValue)
liftScmReal2 f x y =
   case pairScmReal x y of
        Right (ScmReal a, ScmReal b) -> Right . ScmReal $ f a b
        Right (ScmRat  a, ScmRat  b) -> Right . ScmRat  $ f a b
        Right (ScmInt  a, ScmInt  b) -> Right . ScmInt  $ f a b
        Left s                       -> Left s
        Right _                      -> fail "liftScmReal2 :: internal error"

liftScmRealA2 :: (forall a. Real a => a -> a -> b)
              -> (ScmValue -> ScmValue -> ErrOr b)
liftScmRealA2 f x y =
   case pairScmReal x y of
        Right (ScmReal a, ScmReal b) -> Right $ f a b
        Right (ScmRat  a, ScmRat  b) -> Right $ f a b
        Right (ScmInt  a, ScmInt  b) -> Right $ f a b
        Left s                       -> Left s
        Right _                      -> fail "liftScmRealA2 :: internal error"

--- RealFrac
liftScmRealFracB2 :: (forall a. RealFrac a => a -> a -> b)
                  -> (ScmValue -> ScmValue -> ErrOr (Bool, b))
liftScmRealFracB2 f x y =
   case pairScmReal x y of
        Right (ScmReal a, ScmReal b) -> Right (False, f a b)
        Right (ScmRat  a, ScmRat  b) -> Right (True,  f a b)
        Right (ScmInt  a, ScmInt  b) ->
           Right (True,  f (fInt a) (fInt b :: Rational))
        Left s                       -> Left s
        Right _                      ->
           fail "liftScmRealFracB2 :: internal error"

pairScmReal :: ScmValue -> ScmValue -> ErrOr (ScmValue, ScmValue)
pairScmReal (ScmComplex a) _ | imagPart a /= 0 = fail "pairScmReal :: complex"
pairScmReal _ (ScmComplex b) | imagPart b /= 0 = fail "pairScmReal :: complex"

pairScmReal a@(ScmInt     _) b@(ScmInt     _) = Right (a,b)
pairScmReal a@(ScmRat     _) b@(ScmRat     _) = Right (a,b)
pairScmReal a@(ScmReal    _) b@(ScmReal    _) = Right (a,b)
pairScmReal   (ScmComplex a)   (ScmComplex b) =
   Right $ ((,) `on` ScmReal . realPart) a b

-- Int+{Rat,Real,Complex}
pairScmReal (ScmInt     a) (ScmRat     b) = Right $ ((,)`on`ScmRat)  (fInt a) b
pairScmReal (ScmRat     a) (ScmInt     b) = Right $ ((,)`on`ScmRat)  a (fInt b)
pairScmReal (ScmInt     a) (ScmReal    b) = Right $ ((,)`on`ScmReal) (fInt a) b
pairScmReal (ScmReal    a) (ScmInt     b) = Right $ ((,)`on`ScmReal) a (fInt b)
pairScmReal (ScmInt     a) (ScmComplex b) =
   Right $ ((,)`on`ScmReal) (fInt a) (realPart b)
pairScmReal (ScmComplex a) (ScmInt     b) =
   Right $ ((,)`on`ScmReal) (realPart a) (fInt b)

-- Rat+{Real,Complex}
pairScmReal (ScmRat     a) (ScmReal    b) = Right $ ((,)`on`ScmReal) (fRat a) b
pairScmReal (ScmReal    a) (ScmRat     b) = Right $ ((,)`on`ScmReal) a (fRat b)
pairScmReal (ScmRat     a) (ScmComplex b) =
   Right $ ((,)`on`ScmReal) (fRat a) (realPart b)
pairScmReal (ScmComplex a) (ScmRat     b) =
   Right $ ((,)`on`ScmReal) (realPart a) (fRat b)

-- Real+Complex
pairScmReal (ScmReal    a) (ScmComplex b) =
   Right $ ((,)`on`ScmReal) a (realPart b)
pairScmReal (ScmComplex a) (ScmReal    b) =
   Right $ ((,)`on`ScmReal) (realPart a) b

pairScmReal _ _ = fail "pairScmReal :: internal error"

pairScmComplex :: ScmValue -> ScmValue -> ErrOr (ScmValue, ScmValue)
pairScmComplex a@(ScmInt     _) b@(ScmInt     _) = Right (a,b)
pairScmComplex a@(ScmRat     _) b@(ScmRat     _) = Right (a,b)
pairScmComplex a@(ScmReal    _) b@(ScmReal    _) = Right (a,b)
pairScmComplex a@(ScmComplex _) b@(ScmComplex _) = Right (a,b)

-- Int+{Rat,Real,Complex}
pairScmComplex (ScmInt     a) (ScmRat     b) = Right$((,)`on`ScmRat) (fInt a) b
pairScmComplex (ScmRat     a) (ScmInt     b) = Right$((,)`on`ScmRat) a (fInt b)
pairScmComplex (ScmInt     a) (ScmReal    b) =
   Right $ ((,)`on`ScmReal) (fInt a) b
pairScmComplex (ScmReal    a) (ScmInt     b) =
   Right $ ((,)`on`ScmReal) a (fInt b)
pairScmComplex (ScmInt     a) (ScmComplex b) =
   Right $ ((,)`on`ScmComplex) (fInt a) b
pairScmComplex (ScmComplex a) (ScmInt     b) =
   Right $ ((,)`on`ScmComplex) a (fInt b)

-- Rat+{Real,Complex}
pairScmComplex (ScmRat     a) (ScmReal    b) =
   Right $ ((,)`on`ScmReal) (fRat a) b
pairScmComplex (ScmReal    a) (ScmRat     b) =
   Right $ ((,)`on`ScmReal) a (fRat b)
pairScmComplex (ScmRat     a) (ScmComplex b) =
   Right $ ((,)`on`ScmComplex) (fRat a) b
pairScmComplex (ScmComplex a) (ScmRat     b) =
   Right $ ((,)`on`ScmComplex) a (fRat b)

-- Real+Complex
pairScmComplex (ScmReal    a) (ScmComplex b) =
   Right $ ((,)`on`ScmComplex) (a:+0) b
pairScmComplex (ScmComplex a) (ScmReal    b) =
   Right $ ((,)`on`ScmComplex) a (b:+0)

pairScmComplex _ _ = fail "pairScmComplex :: internal error"

fInt :: Num a => Integer -> a
fInt = fromInteger

fRat :: Fractional a => Rational -> a
fRat = fromRational

-- }}}


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds   #-}

module Synapse
  ( sigmoid
  , sigmoidm
  , sigmoidBackward
  , relu
  , relum
  , relumBackward
  , softmax
  , softmaxm
  , softmaxWithCross
  , softmaxWithCrossBackward
  , crossEntropy
  , crossEntropym
  , affinem
  , affinemBackward
  ) where

import           Debug.Trace
import           Numeric.LinearAlgebra
import           Prelude               hiding ((<>))

sigmoid :: (Floating a) => a -> a
sigmoid a = 1 / (1 + exp (-a))

sigmoidm :: (Floating a, Container Matrix a) => Matrix a -> Matrix a
sigmoidm = cmap sigmoid

sigmoidBackward ::
     (Floating a, Num (Vector a), Container Matrix a)
  => Matrix a
  -> Matrix a
  -> Matrix a
sigmoidBackward y d = d * (1 - y) * y

relu :: (Ord a, Num a) => a -> a
relu = max 0

relum :: (Ord a, Num a, Container Matrix a) => Matrix a -> Matrix a
relum = cmap relu

relumBackward ::
     (Ord a, Num a, Num (Matrix a), Container Vector a, Container Matrix a)
  => Matrix a
  -> Matrix a
  -> Matrix a
relumBackward x d = d * mask
  where
    mask = cmap (fromIntegral . onoff) x
    onoff a
      | 0 < a = 1
      | otherwise = 0

softmax :: (Floating a, Container Vector a) => Vector a -> Vector a
softmax v = cmap (/ s) v'
  where
    m = maxElement v
    v' = cmap (\a -> exp (a - m)) v
    s = sumElements v'

softmaxm :: (Floating a, Container Vector a) => Matrix a -> Matrix a
softmaxm m = fromRows $ map softmax $ toRows m

crossEntropy ::
     (Floating a, Num (Vector a), Container Vector a)
  => Vector a
  -> Vector a
  -> a
crossEntropy t y = -(sumElements $ cmap log (y + d) * t)
  where
    d = 1e-10

crossEntropym ::
     (Floating a, Num (Vector a), Container Vector a)
  => Matrix a
  -> Matrix a
  -> a
crossEntropym t m = sum vs / batchSize
  where
    vs = zipWith crossEntropy (toRows t) (toRows m)
    batchSize = fromIntegral $ rows t

softmaxWithCross ::
     (Floating a, Num (Vector a), Container Vector a)
  => Matrix a
  -> Matrix a
  -> (Matrix a, a)
softmaxWithCross t x = (y, crossEntropym t y)
  where
    y = softmaxm x

softmaxWithCrossBackward ::
     (Floating a, Num (Vector a), Container Vector a)
  => Matrix a
  -> Matrix a
  -> Matrix a
softmaxWithCrossBackward t y = cmap (/ batchSize) $ y - t
  where
    batchSize = fromIntegral $ rows t

affinem ::
     (Floating a, Numeric a, Num (Vector a))
  => Matrix a
  -> Vector a
  -> Matrix a
  -> Matrix a
affinem w b x = (x <> w) + b'
  where
    b' = fromRows $ replicate (rows x) b

affinemBackward ::
     (Floating a, Numeric a)
  => Matrix a
  -> Matrix a
  -> Matrix a
  -> (Matrix a, Matrix a, Vector a)
affinemBackward w x d = (dx, dw, db)
  where
    dx = d <> tr w
    dw = tr x <> d
    db = fromList $ sumElements `map` toColumns d


-----------------------------------------------------------------------------
-- |
-- Module     : Numeric.LinearAlgebra.Packed.Cholesky
-- Copyright  : Copyright (c) 2010, Patrick Perry <patperry@gmail.com>
-- License    : BSD3
-- Maintainer : Patrick Perry <patperry@gmail.com>
-- Stability  : experimental
--
-- Cholesky factorizations of symmetric (Hermitian) positive-definite
-- matrices.
--

module Numeric.LinearAlgebra.Packed.Cholesky (
    -- * Immutable interface
    cholFactor,
    cholSolveVector,
    cholSolveMatrix,

    -- * Mutable interface
    cholFactorM,
    cholSolveVectorM_,
    cholSolveMatrixM_,
    ) where

import Control.Monad( when )
import Control.Monad.ST( ST, runST, unsafeIOToST )
import Text.Printf( printf )

import qualified Foreign.LAPACK as LAPACK

import Numeric.LinearAlgebra.Types

import Numeric.LinearAlgebra.Packed.Base( Packed, RPacked, STPacked )
import qualified Numeric.LinearAlgebra.Packed.Base as P

import Numeric.LinearAlgebra.Matrix( Matrix, STMatrix )
import qualified Numeric.LinearAlgebra.Matrix as M

import Numeric.LinearAlgebra.Vector( Vector, STVector )
import qualified Numeric.LinearAlgebra.Vector as V

-- | @cholFactor a@ tries to compute the Cholesky
-- factorization of @a@.  If @a@ is positive-definite then the routine
-- returns @Right@ with the factorization.  If the leading minor of order @i@
-- is not positive-definite then the routine returns @Left i@.
cholFactor :: (LAPACK e)
                 => Herm Packed e
                 -> Either Int (Chol Packed e)
cholFactor (Herm uplo a) = runST $ do
    ma <- P.newCopy a
    cholFactorM (Herm uplo ma)
        >>= either (return . Left) (\(Chol uplo' ma') -> do
                a' <- P.unsafeFreeze ma'
                return $ Right (Chol uplo' a')
                )

-- | @cholSolveVector a x@ returns @a \\ x@.
cholSolveVector :: (LAPACK e)
                      => Chol Packed e
                      -> Vector e
                      -> Vector e
cholSolveVector a x = V.create $ do
    x' <- V.newCopy x
    cholSolveVectorM_ a x'
    return x'

-- | @cholSolveMatrix a b@ returns @a \\ b@.
cholSolveMatrix :: (LAPACK e)
                      => Chol Packed e
                      -> Matrix e
                      -> Matrix e
cholSolveMatrix a c = M.create $ do
    c' <- M.newCopy c
    cholSolveMatrixM_ a c'
    return c'

-- | @cholFactorM a@ tries to compute the Cholesky
-- factorization of @a@ in place.  If @a@ is positive-definite then the
-- routine returns @Right@ with the factorization, stored in the same
-- memory as @a@.  If the leading minor of order @i@ is not
-- positive-definite then the routine returns @Left i@.
-- In either case, the original storage of @a@ is destroyed.
cholFactorM :: (LAPACK e)
             => Herm (STPacked s) e
             -> ST s (Either Int (Chol (STPacked s) e))
cholFactorM (Herm uplo a) = do
    n <- P.getDim a
    unsafeIOToST $
        P.unsafeWith a $ \pa -> do
            info <- LAPACK.pptrf uplo n pa
            return $ if info > 0 then Left info
                                 else Right (Chol uplo a)

-- | @cholSolveVectorM_ a x@ sets @x := a \\ x@.
cholSolveVectorM_ :: (LAPACK e, RPacked p)
                  => Chol p e
                  -> STVector s e
                  -> ST s ()
cholSolveVectorM_ a x =
    M.withFromColM x $ \x' ->
        cholSolveMatrixM_ a x'

-- | @cholSolveMatrixM_ a b@ sets @b := a \\ b@.
cholSolveMatrixM_ :: (LAPACK e, RPacked p)
                  => Chol p e
                  -> STMatrix s e
                  -> ST s ()
cholSolveMatrixM_ (Chol uplo a) b = do
    na <- P.getDim a
    (mb,nb) <- M.getDim b
    let (n,nrhs) = (mb,nb)

    when ((not . and) [ na == n
                      , (mb,nb) == (n,nrhs)
                      ]) $ error $
        printf ("cholSolveMatrixM_"
                ++ " (Chol _ <packed matrix with dim %d>)"
                ++ " <matrix with dim (%d,%d)>"
                ++ ": dimension mismatch")
               na mb nb

    unsafeIOToST $
        P.unsafeWith a $ \pa ->
        M.unsafeWith b $ \pb ldb ->
            LAPACK.pptrs uplo n nrhs pa pb ldb


{-# LANGUAGE OverloadedLists
           , TypeFamilies
           , FlexibleContexts #-}

module Utils.Quaternions where

import           Number.Quaternion hiding (normalize,norm)
import qualified Number.Quaternion as Q
import           Numeric.LinearAlgebra (Matrix, Vector, tr, cmap,(<>), inv,single,double)
import qualified Data.Vector.Storable as VS
import qualified Numeric.LinearAlgebra.Data as LD

import Utils (mat3ToMat4)

qvMul :: VS.Vector Float -> T Float -> T Float
qvMul v = quatConcat (0 +:: (VS.unsafeIndex v 0,VS.unsafeIndex v 1,VS.unsafeIndex v 2))

quatToLInv inertiaDiag quat =
  let orientation = quatToMat3 quat
  in tr orientation
   <> (single . inv . double) inertiaDiag
   <> orientation

rotateWithQuat :: T Float -> VS.Vector Float -> VS.Vector Float
rotateWithQuat quat [a,b,c] =
  (\(a,b,c) -> [a,b,c]) .
  imag .
  flip quatConcat (qInverse quat) $
  quatConcat quat (0 +:: (a,b,c))

addQuat q1 q2 =
  let r1 = real q1
      r2 = real q2
      i1 = imag q1
      i2 = imag q2
  in (r1 + r2) +:: sum3 i1 i2

quatToMatV :: T Float -> VS.Vector Float
quatToMatV q =
  let r = real q
      (i,j,k) = imag q
      r2 = r*r
      i2 = i*i;   j2 = j*j;   k2 = k*k;
      ri = 2*r*i; rj = 2*r*j; rk = 2*r*k;
      ij = 2*i*j; ki = 2*k*i; kj = 2*k*j;
  in [ r2+i2-j2-k2,       ij-rk,       ki+rj, 0
     ,       ij+rk, r2-i2+j2-k2,       kj-ri, 0
     ,       ki-rj,       kj+ri, r2-i2-j2+k2, 0
     ,           0,           0,           0, 1]

quatToMat = tr . LD.reshape 4 . quatToMatV

quatToMat3 :: T Float -> Matrix Float
quatToMat3 = LD.fromArray2D . toRotationMatrix

sum3 (a,b,c) (d,e,f) = (a+d,b+e,c+f)

scale3 n (a,b,c) = (n*a,n*b,n*c)

quatConcat q0 q1 =
  let w0 = real q0
      w1 = real q1
      v0 = imag q0
      v1 = imag q1
      wr = w1 * w0 - scalarProduct v1 v0
      vr = scale3 w1 v0 `sum3` scale3 w0 v1 `sum3` crossProduct v1 v0
  in wr +:: vr

qInverse :: T Float -> T Float
qInverse q =
  let w = real q
      v = (\(a,b,c) -> (negate a, negate b, negate c)) $ imag q
  in w +:: v

qZero :: T Float
qZero = 1 +:: (0,0,0)


module Main where

import Linear (
  V2(V2), V3(V3), (^+^), (^-^), (*^))
import Data.Complex (
  Complex((:+)))
import Codec.Picture (
  Image, Pixel8, generateImage, writePng)

data Edge2 a = Edge2 (V2 a) (V2 a)
  deriving (Show, Eq, Ord)

type ScalarField2 a = V2 a -> a

renderE0 :: Floating a => Ord a => ScalarField2 a
renderE0 (V2 x1 x2)
  | x1 < 0 = 0
  | x1 > 1 = 0
  | otherwise = x2 * exp (negate (sqr x2))

sqr :: Num a => a -> a
sqr x = x * x

cotransformScalarField2 :: (V2 a -> V2 a) -> ScalarField2 a -> ScalarField2 a
cotransformScalarField2 g f = \x -> f (g x)

translate2 :: Num a => V2 a -> V2 a -> V2 a
translate2 = (^+^)

rotate2 :: RealFloat a => Complex a -> V2 a -> V2 a
rotate2 r (V2 x1 x2) = do
  let y1 :+ y2 = r * (x1 :+ x2)
  V2 y1 y2

scale22 :: Num a => a -> V2 a -> V2 a
scale22 s (V2 x1 x2) = V2 x1 (s * x2)

renderEdge2 :: RealFloat a => Ord a => Edge2 a -> ScalarField2 a
renderEdge2 (Edge2 a b) = do
  let w = 0.1
  let V2 c1 c2 = b ^-^ a
  let r = c1 :+ c2
  cotransformScalarField2 (
    scale22 (recip w) . rotate2 (recip r) . translate2 (negate a)) renderE0

-- Write image

resolution :: Int
resolution = 600

imageToCameraSpace :: V2 Int -> V2 Double
imageToCameraSpace (V2 i1 i2) = do
  let x1 = fromIntegral i1 / fromIntegral resolution * 2 - 1
  let x2 = 1 - fromIntegral i2 / fromIntegral resolution * 2
  V2 x1 x2

discreteGrey :: Double -> Pixel8
discreteGrey a
  | a < -1 = 0
  | a > 1 = 255
  | otherwise = round ((0.5 + 0.5 * a) * 255)

manifestImage :: ScalarField2 Double -> Image Pixel8
manifestImage rendering = do
  let imageFunction i1 i2 = discreteGrey (rendering (imageToCameraSpace (V2 i1 i2)))
  generateImage imageFunction resolution resolution

main :: IO ()
main = do

  let testImage = renderEdge2 (Edge2 (V2 (-0.8) 0.3) (V2 0.4 0.8))

  writePng "out/testImage.png" (manifestImage testImage)


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

module LinearRegression
  ( trainLinReg
  , trainAndTestLinReg
  , trainLinRegWNoise
  , avError
  , linRegAsInitialForPLA
  , createVectorY
  , createRandomPoints
  , flipLabels
  , linearRegressionWeight
  , linRegClassificationError
  , testLinRegWNoise
  , createMatrixX
  , makeTargetFunction
  , y
  ) where

import           Control.Monad                 (replicateM)
import           Data.Maybe
import           Data.Traversable              (for)
import           Numeric.LinearAlgebra.Data
import           Numeric.LinearAlgebra.HMatrix
import           PLA
import           System.Random

--------------------------------------------------------------
-- Solutions to homework 2 of "Learning from data" question 5-6
--------------------------------------------------------------
---------------------------------------------
-- Creating the line for the target function
--------------------------------------------
-- | takes 2 points and returns the slope of the line connecting them
m :: (R, R) -> (R, R) -> R
m (x1, x2) (z1, z2) = (x2 - z2) / (x1 - z1)

-- | takes 2 points and returns the y-intercept of the line connecting them
b :: (R, R) -> (R, R) -> R
b (x1, x2) (z1, z2) = x2 - x1 * (x2 - z2) / (x1 - z1)

-- | Takes 2 Points and returns the function of a line connecting them
line point1 point2 = \x -> m point1 point2 * x + b point1 point2

-----------------------------------
-- Creating random data points
------------------------------------
-- |Creates a random Point between (-1,-1) and (1,1)
createRandomPoint :: IO (R, R)
createRandomPoint = do
  rand1 <- randomRIO (-1, 1)
  rand2 <- randomRIO (-1, 1)
  return (rand1, rand2)

-- |Creates a list of n random Points between (-1,-1) and (1,1)
createRandomPoints :: Int -> IO [(R, R)]
createRandomPoints n = do
  randList1 <- for [1 .. n] $ \_ -> randomRIO (-1, 1)
  randList2 <- for [1 .. n] $ \_ -> randomRIO (-1, 1)
  return $ zip randList1 randList2

-----------------------------------------------------
-- Preparing data for processing by Linear Regression
------------------------------------------------------
-- | looks up the label of the point by applying the target function
y :: (R -> R) -> (R, R) -> R
y yLine (x1, x2) =
  if yLine x1 < x2
    then (-1)
    else 1

-- | Creates the vector of labels using the target function 'yLine' and a list of data points
createVectorY :: ((R, R) -> R) -> [(R, R)] -> Vector R
createVectorY target listOfPoints = vector $ map target listOfPoints

-- | Creates the matrix X from a list of data points
createMatrixX :: [(R, R)] -> Matrix R
createMatrixX listOfPoints = matrix 3 listOfNumbers
  where
    listOfNumbers = concat [[1, a, b] | (a, b) <- listOfPoints]

flipLabels :: Float -> Vector R -> IO (Vector R)
flipLabels noiselevel labelvector = do
  gen <- getStdGen
  let numLabels = size labelvector
  let randnums :: [Int] = randomRs (1, numLabels) gen
  let toFlip = take (floor (noiselevel * fromIntegral numLabels)) randnums
  let flipVector =
        vector
          [ if x `elem` toFlip
            then (-1)
            else 1
          | x <- [1 .. numLabels]
          ]
  let flippedLabels = labelvector * flipVector
  return flippedLabels

--------------------------------------------------------
-- Linear Regression algorithm
--------------------------------------------------------
-- | returns the weights determined by linear regression on the training data
linearRegressionWeight :: Matrix R -> Vector R -> Vector R
linearRegressionWeight matrixOfInputData vectorOfLabels =
  pinv matrixOfInputData #> vectorOfLabels

-- | Squared error
squaredError :: Matrix R -> Vector R -> Vector R -> R
squaredError matrixOfInputData vectorOfLabels weight =
  1 / fromIntegral n * dot v v
  where
    v = signum (matrixOfInputData #> weight) - vectorOfLabels
    n = size vectorOfLabels

-- | Classification error for linear Regression (i.e. fraction of misclassified points)
linRegClassificationError :: Matrix R -> Vector R -> Vector R -> R
linRegClassificationError matrixOfInputData vectorOfLabels weight =
  numberMisclassified / totalDatapoints
  where
    numberMisclassified =
      norm_0 $ signum (matrixOfInputData #> weight) - vectorOfLabels
    totalDatapoints = fromIntegral $ size vectorOfLabels

--------------------------------------------------
-- training and testing the Linear Regression model
--------------------------------------------------
-- | create the target function
makeTargetFunction :: IO (R -> R)
makeTargetFunction = do
  point1 <- createRandomPoint
  point2 <- createRandomPoint
  let target = line point1 point2
  return target

-- | training linear Regression on random dataset of n noisy points and returning (weights, in-Sample error, trainingpoints)
trainLinRegWNoise ::
     ((R, R) -> R)
  -> Int
  -> Float
  -> ([(R, R)] -> Matrix R)
  -> IO (Vector R, R, [(R, R)])
trainLinRegWNoise target n noiselevel transformFunction = do
  trainpoints <- createRandomPoints n
  let trainX = transformFunction trainpoints
  let trainY = createVectorY target trainpoints
  trainYNoisy <- flipLabels noiselevel trainY
  let weights = linearRegressionWeight trainX trainYNoisy
  let inSampleError = linRegClassificationError trainX trainYNoisy weights
  return (weights, inSampleError, trainpoints)

-- | training linear Regression on random dataset of n noiseless points and returning (weights, in-Sample error, trainingpoints)
trainLinReg ::
     (R -> R) -> Int -> ([(R, R)] -> Matrix R) -> IO (Vector R, R, [(R, R)])
trainLinReg target n transformFunction =
  trainLinRegWNoise (y target) n 0 transformFunction

-- | evaluates linear Regression result on test data
testLinReg :: (R -> R) -> Int -> ([(R, R)] -> Matrix R) -> Vector R -> IO R
testLinReg target n transformFunction weights =
  testLinRegWNoise (y target) n 0 transformFunction weights

-- | training linear Regression on random dataset of n noisy points and returning (weights, in-Sample error, trainingpoints)
testLinRegWNoise ::
     ((R, R) -> R) -> Int -> Float -> ([(R, R)] -> Matrix R) -> Vector R -> IO R
testLinRegWNoise target n noiselevel transformFunction weights = do
  testpoints <- createRandomPoints n
  let testX = transformFunction testpoints
  let testY = createVectorY target testpoints
  testYNoisy <- flipLabels noiselevel testY
  let outOfSampleError = linRegClassificationError testX testYNoisy weights
  return outOfSampleError

-- | performs training and testing
trainAndTestLinReg :: IO (R, R)
trainAndTestLinReg = do
  target <- makeTargetFunction
  (weights, inSampleError, _) <- trainLinReg target 100 createMatrixX
  outOfSampleError <- testLinReg target 1000 createMatrixX weights
  return (inSampleError, outOfSampleError)

---------------------------------------------------------
-- averaging several runs of the algorithm
---------------------------------------------------------
-- | average in a list of numbers
average :: [R] -> R
average xs = sum xs / fromIntegral (length xs)

-- | average of in-sample and out-of-sample error, calculated from a list of pairs and returned as a pair.
averageErrors :: [(R, R)] -> (R, R)
averageErrors pairs = (avFst, avSnd)
  where
    avFst = average $ map fst pairs
    avSnd = average $ map snd pairs

-- |pair of average in-sample and out-of-sample error in n runs of linear Regression on n different sets of points
avError :: Int -> IO ()
avError n =
  putStrLn . ("In-sample error, out-of-sample error: " ++) . show =<<
  fmap averageErrors (replicateM n trainAndTestLinReg)

----------------------------------------------
-- Using linear regression to obtain initial weights for perceptron
--------------------------------------------------
listToTuple :: [a] -> Maybe (a, a, a)
listToTuple (x:y:z:xs) = Just (x, y, z)
listToTuple _          = Nothing

-- | trains a perceptron wiht initial weights obtained by linear Regression
linRegAsInitialForPLA :: IO ()
linRegAsInitialForPLA = do
  target <- makeTargetFunction
  (initialweightsVec, _, trainPoints) <- trainLinReg target 10 createMatrixX
  let maybeInitialWeights = listToTuple $ toList initialweightsVec
  let initialWeights = fromMaybe (0, 0, 0) maybeInitialWeights
  (finalWeights, epochs) <-
    trainPLAWithInitial initialWeights trainPoints target
  putStr "Weights: "
  print finalWeights
  putStr "Epochs: "
  print epochs


import Numeric.LinearAlgebra
import ActivationFunction
import Mnist
import SampleWeight

batchSize = 100

predict :: SampleWeight -> Vector R -> Vector R
predict ([w1,w2,w3],[b1,b2,b3]) x =
    softMax' . (\x'' -> sumInput x'' w3 b3) . sigmoid . (\x' -> sumInput x' w2 b2) . sigmoid $ sumInput x w1 b1

sumInput :: Vector R -> Weight -> Bias -> Vector R
sumInput x w b = (x <# w) + b

maxIndexPredict :: SampleWeight -> Vector R -> Double
maxIndexPredict sw x = fromIntegral . maxIndex $ predict sw x

take' :: Indexable c t => Int -> Int -> c -> [t]
take' n1 n2 x
    | n1 >= n2  = []
    | otherwise = (x ! n1) : take' (n1+1) n2 x

increment :: [Double] -> [Double] -> Double
increment ps l = fromIntegral . length . filter id $ zipWith (==) ps l

countAccuracy :: Double -> Int -> SampleWeight -> DataSet -> Double
countAccuracy a n sw ds@(i,l)
    | n <= 0    = a
    | otherwise =
      if maxIndexPredict sw (i ! (n-1)) == l ! (n-1)
        then countAccuracy (a+1) (n-1) sw ds
        else countAccuracy a (n-1) sw ds

-- For batch
countAccuracy' :: Double -> Int -> SampleWeight -> DataSet -> Double
countAccuracy' a n sw ds@(i,l)
    | n <= 0    = a
    | otherwise = countAccuracy' (a+cnt) (n-batchSize) sw ds
        where ps = maxIndexPredict sw <$> take' (n-batchSize) n i
              ls = take' (n-batchSize) n l
              cnt = increment ps ls

main = do
    [_, ds] <- loadMnist True
    sw <- loadSW
    let r = rows $ fst ds
        cnt = countAccuracy' 0 r sw ds

    putStrLn $ "Accuracy: " ++ show (cnt / fromIntegral r)


{-# LANGUAGE ViewPatterns #-}
-- |
-- Module    : Statistics.Test.WilcoxonT
-- Copyright : (c) 2010 Neil Brown
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- The Wilcoxon matched-pairs signed-rank test is non-parametric test
-- which could be used to test whether two related samples have
-- different means.
module Statistics.Test.WilcoxonT (
    -- * Wilcoxon signed-rank matched-pair test
    -- ** Test
    wilcoxonMatchedPairTest
    -- ** Building blocks
  , wilcoxonMatchedPairSignedRank
  , wilcoxonMatchedPairSignificant
  , wilcoxonMatchedPairSignificance
  , wilcoxonMatchedPairCriticalValue
  , module Statistics.Test.Types
    -- * References
    -- $references
  ) where

--
--
--
-- Note that: wilcoxonMatchedPairSignedRank == (\(x, y) -> (y, x)) . flip wilcoxonMatchedPairSignedRank
-- The samples are zipped together: if one is longer than the other, both are truncated
-- The value returned is the pair (T+, T-).  T+ is the sum of positive ranks (the
-- These values mean little by themselves, and should be combined with the 'wilcoxonSignificant'
-- function in this module to get a meaningful result.
-- ranks of the differences where the first parameter is higher) whereas T- is
-- the sum of negative ranks (the ranks of the differences where the second parameter is higher).
-- to the length of the shorter sample.

import Data.Function (on)
import Data.List (findIndex)
import Data.Ord (comparing)
import qualified Data.Vector.Unboxed as U
import Prelude hiding (sum)
import Statistics.Function (sortBy)
import Statistics.Sample.Internal (sum)
import Statistics.Test.Internal (rank, splitByTags)
import Statistics.Test.Types
import Statistics.Types -- (CL,pValue,getPValue)
import Statistics.Distribution
import Statistics.Distribution.Normal

-- | Calculate (n,T⁺,T⁻) values for both samples. Where /n/ is reduced
--   sample where equal pairs are removed.
wilcoxonMatchedPairSignedRank :: (Ord a, Num a, U.Unbox a) => U.Vector (a,a) -> (Int, Double, Double)
wilcoxonMatchedPairSignedRank ab
  = (nRed, sum ranks1, negate (sum ranks2))
  where
    -- Positive and negative ranks
    (ranks1, ranks2) = splitByTags
                     $ U.zip tags (rank ((==) `on` abs) diffs)
    -- Sorted list of differences
    diffsSorted = sortBy (comparing abs)    -- Sort the differences by absolute difference
                $ U.filter  (/= 0)          -- Remove equal elements
                $ U.map (uncurry (-)) ab    -- Work out differences
    nRed = U.length diffsSorted
    -- Sign tags and differences
    (tags,diffs) = U.unzip
                 $ U.map (\x -> (x>0 , x))   -- Attach tags to distribution elements
                 $ diffsSorted

-- | The coefficients for x^0, x^1, x^2, etc, in the expression
-- \prod_{r=1}^s (1 + x^r).  See the Mitic paper for details.
--
-- We can define:
-- f(1) = 1 + x
-- f(r) = (1 + x^r)*f(r-1)
--      = f(r-1) + x^r * f(r-1)
-- The effect of multiplying the equation by x^r is to shift
-- all the coefficients by r down the list.
--
-- This list will be processed lazily from the head.
coefficients :: Int -> [Integer]
coefficients 1 = [1, 1] -- 1 + x
coefficients r = let coeffs = coefficients (r-1)
                     (firstR, rest) = splitAt r coeffs
  in firstR ++ add rest coeffs
  where
    add (x:xs) (y:ys) = x + y : add xs ys
    add xs [] = xs
    add [] ys = ys

-- This list will be processed lazily from the head.
summedCoefficients :: Int -> [Double]
summedCoefficients n
  | n < 1     = error "Statistics.Test.WilcoxonT.summedCoefficients: nonpositive sample size"
  | n > 1023  = error "Statistics.Test.WilcoxonT.summedCoefficients: sample is too large (see bug #18)"
  | otherwise = map fromIntegral $ scanl1 (+) $ coefficients n

-- | Tests whether a given result from a Wilcoxon signed-rank matched-pairs test
-- is significant at the given level.
--
-- This function can perform a one-tailed or two-tailed test.  If the first
-- parameter to this function is 'TwoTailed', the test is performed two-tailed to
-- check if the two samples differ significantly.  If the first parameter is
-- 'OneTailed', the check is performed one-tailed to decide whether the first sample
-- (i.e. the first sample you passed to 'wilcoxonMatchedPairSignedRank') is
-- greater than the second sample (i.e. the second sample you passed to
-- 'wilcoxonMatchedPairSignedRank').  If you wish to perform a one-tailed test
-- in the opposite direction, you can either pass the parameters in a different
-- order to 'wilcoxonMatchedPairSignedRank', or simply swap the values in the resulting
-- pair before passing them to this function.
wilcoxonMatchedPairSignificant
  :: PositionTest          -- ^ How to compare two samples
  -> PValue Double         -- ^ The p-value at which to test (e.g. @mkPValue 0.05@)
  -> (Int, Double, Double) -- ^ The (n,T⁺, T⁻) values from 'wilcoxonMatchedPairSignedRank'.
  -> Maybe TestResult      -- ^ Return 'Nothing' if the sample was too
                           --   small to make a decision.
wilcoxonMatchedPairSignificant test pVal (sampleSize, tPlus, tMinus) =
  case test of
    -- According to my nearest book (Understanding Research Methods and Statistics
    -- by Gary W. Heiman, p590), to check that the first sample is bigger you must
    -- use the absolute value of T- for a one-tailed check:
    AGreater      -> do crit <- wilcoxonMatchedPairCriticalValue sampleSize pVal
                        return $ significant $ abs tMinus <= fromIntegral crit
    BGreater      -> do crit <- wilcoxonMatchedPairCriticalValue sampleSize pVal
                        return $ significant $ abs tPlus <= fromIntegral crit
    -- Otherwise you must use the value of T+ and T- with the smallest absolute value:
    --
    -- Note that in absence of ties sum of |T+| and |T-| is constant
    -- so by selecting minimal we are performing two-tailed test and
    -- look and both tails of distribution of T.
    SamplesDiffer -> do crit <- wilcoxonMatchedPairCriticalValue sampleSize (mkPValue $ p/2)
                        return $ significant $ t <= fromIntegral crit
  where
    t = min (abs tPlus) (abs tMinus)
    p = pValue pVal

-- | Obtains the critical value of T to compare against, given a sample size
-- and a p-value (significance level).  Your T value must be less than or
-- equal to the return of this function in order for the test to work out
-- significant.  If there is a Nothing return, the sample size is too small to
-- make a decision.
--
-- 'wilcoxonSignificant' tests the return value of 'wilcoxonMatchedPairSignedRank'
-- for you, so you should use 'wilcoxonSignificant' for determining test results.
--  However, this function is useful, for example, for generating lookup tables
-- for Wilcoxon signed rank critical values.
--
-- The return values of this function are generated using the method
-- detailed in the Mitic's paper. According to that paper, the results
-- may differ from other published lookup tables, but (Mitic claims)
-- the values obtained by this function will be the correct ones.
wilcoxonMatchedPairCriticalValue ::
     Int                -- ^ The sample size
  -> PValue Double      -- ^ The p-value (e.g. @mkPValue 0.05@) for which you want the critical value.
  -> Maybe Int          -- ^ The critical value (of T), or Nothing if
                        --   the sample is too small to make a decision.
wilcoxonMatchedPairCriticalValue n pVal
  | n < 100   =
      case subtract 1 <$> findIndex (> m) (summedCoefficients n) of
        Just k | k < 0     -> Nothing
               | otherwise -> Just k
        Nothing  -> error "Statistics.Test.WilcoxonT.wilcoxonMatchedPairCriticalValue: impossible happened"
  | otherwise =
     case quantile (normalApprox n) p of
       z | z < 0     -> Nothing
         | otherwise -> Just (round z)
  where
    p = pValue pVal
    m = (2 ** fromIntegral n) * p

-- | Works out the significance level (p-value) of a T value, given a sample
-- size and a T value from the Wilcoxon signed-rank matched-pairs test.
--
-- See the notes on 'wilcoxonCriticalValue' for how this is calculated.
wilcoxonMatchedPairSignificance
  :: Int           -- ^ The sample size
  -> Double        -- ^ The value of T for which you want the significance.
  -> PValue Double -- ^ The significance (p-value).
wilcoxonMatchedPairSignificance n t
  = mkPValue p
  where
    p | n < 100   = (summedCoefficients n !! floor t) / 2 ** fromIntegral n
      | otherwise = cumulative (normalApprox n) t

-- | Normal approximation for Wilcoxon T statistics
normalApprox :: Int -> NormalDistribution
normalApprox ni
  = normalDistr m s
  where
    m = n * (n + 1) / 4
    s = sqrt $ (n * (n + 1) * (2*n + 1)) / 24
    n = fromIntegral ni

-- | The Wilcoxon matched-pairs signed-rank test. The samples are
-- zipped together: if one is longer than the other, both are
-- truncated to the length of the shorter sample.
--
-- For one-tailed test it tests whether first sample is significantly
-- greater than the second. For two-tailed it checks whether they
-- significantly differ
--
-- Check 'wilcoxonMatchedPairSignedRank' and
-- 'wilcoxonMatchedPairSignificant' for additional information.
wilcoxonMatchedPairTest
  :: (Ord a, Num a, U.Unbox a)
  => PositionTest     -- ^ Perform one-tailed test.
  -> U.Vector (a,a)   -- ^ Sample of pairs
  -> Test ()          -- ^ Return 'Nothing' if the sample was too
                      --   small to make a decision.
wilcoxonMatchedPairTest test pairs =
  Test { testSignificance = pVal
       , testStatistics   = t
       , testDistribution = ()
       }
  where
    (n,tPlus,tMinus) = wilcoxonMatchedPairSignedRank pairs
    (t,pVal) = case test of
                 AGreater      -> (abs tMinus, wilcoxonMatchedPairSignificance n (abs tMinus))
                 BGreater      -> (abs tPlus,  wilcoxonMatchedPairSignificance n (abs tPlus ))
                 -- Since we take minimum of T+,T- we can't get more
                 -- that p=0.5 and can multiply it by 2 without risk
                 -- of error.
                 SamplesDiffer -> let t' = min (abs tMinus) (abs tPlus)
                                      p  = wilcoxonMatchedPairSignificance n t'
                                  in (t', mkPValue $ min 1 $ 2 * pValue p)

-- $references
--
-- * \"Critical Values for the Wilcoxon Signed Rank Statistic\", Peter
--   Mitic, The Mathematica Journal, volume 6, issue 3, 1996
--   (<http://www.mathematica-journal.com/issue/v6i3/article/mitic/contents/63mitic.pdf>)


module Grid
    ( Grid
    , standardInterval
    , makeInterval
    , startOfInterval
    , endOfInterval
    , elementSize
    , nElements
    ) where

import Numeric.LinearAlgebra (R)

data Grid = Grid R R R Int
  deriving (Eq, Show)

standardInterval :: Grid
standardInterval = makeInterval 0.0 1.0 10

-- | Specify a 1D Intervall [start, end]
makeInterval :: R -> R -> Int -> Grid
makeInterval start end n
  | start < end && n > 0 = Grid start end ((end - start) / fromIntegral n) n
  | otherwise = undefined

startOfInterval :: Grid -> R
startOfInterval (Grid start _ _ _) = start

endOfInterval :: Grid -> R
endOfInterval (Grid _ end _ _) = end

elementSize :: Grid -> R
elementSize (Grid _ _ h _) = h

nElements :: Grid -> Int
nElements (Grid _ _ _ n) = n


{-# OPTIONS_GHC -Wall #-}

-- | A magma heirarchy for multiplication. The basic magma structure is repeated and prefixed with 'Multiplicative-'.
module Plankton.Multiplicative
  ( MultiplicativeMagma(..)
  , MultiplicativeUnital(..)
  , MultiplicativeAssociative
  , MultiplicativeCommutative
  , MultiplicativeInvertible(..)
  , product
  , Multiplicative(..)
  , MultiplicativeRightCancellative(..)
  , MultiplicativeLeftCancellative(..)
  , MultiplicativeGroup(..)
  ) where

import Data.Complex (Complex(..))
import Plankton.Additive
import qualified Protolude as P
import Protolude (Bool(..), Double, Float, Int, Integer)

-- | 'times' is used as the operator for the multiplicative magam to distinguish from '*' which, by convention, implies commutativity
--
-- > ∀ a,b ∈ A: a `times` b ∈ A
--
-- law is true by construction in Haskell
class MultiplicativeMagma a where
  times :: a -> a -> a

instance MultiplicativeMagma Double where
  times = (P.*)

instance MultiplicativeMagma Float where
  times = (P.*)

instance MultiplicativeMagma Int where
  times = (P.*)

instance MultiplicativeMagma Integer where
  times = (P.*)

instance MultiplicativeMagma Bool where
  times = (P.&&)

instance (MultiplicativeMagma a, AdditiveGroup a) =>
         MultiplicativeMagma (Complex a) where
  (rx :+ ix) `times` (ry :+ iy) =
    (rx `times` ry - ix `times` iy) :+ (ix `times` ry + iy `times` rx)

-- | Unital magma for multiplication.
--
-- > one `times` a == a
-- > a `times` one == a
class MultiplicativeMagma a =>
      MultiplicativeUnital a where
  one :: a

instance MultiplicativeUnital Double where
  one = 1

instance MultiplicativeUnital Float where
  one = 1

instance MultiplicativeUnital Int where
  one = 1

instance MultiplicativeUnital Integer where
  one = 1

instance MultiplicativeUnital Bool where
  one = True

instance (AdditiveUnital a, AdditiveGroup a, MultiplicativeUnital a) =>
         MultiplicativeUnital (Complex a) where
  one = one :+ zero

-- | Associative magma for multiplication.
--
-- > (a `times` b) `times` c == a `times` (b `times` c)
class MultiplicativeMagma a =>
      MultiplicativeAssociative a

instance MultiplicativeAssociative Double

instance MultiplicativeAssociative Float

instance MultiplicativeAssociative Int

instance MultiplicativeAssociative Integer

instance MultiplicativeAssociative Bool

instance (AdditiveGroup a, MultiplicativeAssociative a) =>
         MultiplicativeAssociative (Complex a)

-- | Commutative magma for multiplication.
--
-- > a `times` b == b `times` a
class MultiplicativeMagma a =>
      MultiplicativeCommutative a

instance MultiplicativeCommutative Double

instance MultiplicativeCommutative Float

instance MultiplicativeCommutative Int

instance MultiplicativeCommutative Integer

instance MultiplicativeCommutative Bool

instance (AdditiveGroup a, MultiplicativeCommutative a) =>
         MultiplicativeCommutative (Complex a)

-- | Invertible magma for multiplication.
--
-- > ∀ a ∈ A: recip a ∈ A
--
-- law is true by construction in Haskell
class MultiplicativeMagma a =>
      MultiplicativeInvertible a where
  recip :: a -> a

instance MultiplicativeInvertible Double where
  recip = P.recip

instance MultiplicativeInvertible Float where
  recip = P.recip

instance (AdditiveGroup a, MultiplicativeInvertible a) =>
         MultiplicativeInvertible (Complex a) where
  recip (rx :+ ix) = (rx `times` d) :+ (negate ix `times` d)
    where
      d = recip ((rx `times` rx) `plus` (ix `times` ix))

-- | Idempotent magma for multiplication.
--
-- > a `times` a == a
class MultiplicativeMagma a =>
      MultiplicativeIdempotent a

instance MultiplicativeIdempotent Bool

-- | product definition avoiding a clash with the Product monoid in base
--
product :: (Multiplicative a, P.Foldable f) => f a -> a
product = P.foldr (*) one

-- | Multiplicative is commutative, associative and unital under multiplication
--
-- > one * a == a
-- > a * one == a
-- > (a * b) * c == a * (b * c)
-- > a * b == b * a
class ( MultiplicativeCommutative a
      , MultiplicativeUnital a
      , MultiplicativeAssociative a
      ) =>
      Multiplicative a where
  infixl 7 *
  (*) :: a -> a -> a
  a * b = times a b

instance Multiplicative Double

instance Multiplicative Float

instance Multiplicative Int

instance Multiplicative Integer

instance Multiplicative Bool

instance (AdditiveGroup a, Multiplicative a) => Multiplicative (Complex a)

-- | Non-commutative left divide
--
-- > recip a `times` a = one
class ( MultiplicativeUnital a
      , MultiplicativeAssociative a
      , MultiplicativeInvertible a
      ) =>
      MultiplicativeLeftCancellative a where
  infixl 7 ~/
  (~/) :: a -> a -> a
  a ~/ b = recip b `times` a

-- | Non-commutative right divide
--
-- > a `times` recip a = one
class ( MultiplicativeUnital a
      , MultiplicativeAssociative a
      , MultiplicativeInvertible a
      ) =>
      MultiplicativeRightCancellative a where
  infixl 7 /~
  (/~) :: a -> a -> a
  a /~ b = a `times` recip b

-- | Divide ('/') is reserved for where both the left and right cancellative laws hold.  This then implies that the MultiplicativeGroup is also Abelian.
--
-- > a / a = one
-- > recip a = one / a
-- > recip a * a = one
-- > a * recip a = one
class (Multiplicative a, MultiplicativeInvertible a) =>
      MultiplicativeGroup a where
  infixl 7 /
  (/) :: a -> a -> a
  (/) a b = a `times` recip b

instance MultiplicativeGroup Double

instance MultiplicativeGroup Float

instance (AdditiveGroup a, MultiplicativeGroup a) =>
         MultiplicativeGroup (Complex a)