import qualified System.Environment as SE
import qualified Data.ByteString.Lazy.Char8 as LC
import qualified Data.ByteString.Char8 as BC
import qualified Data.List as DL
import qualified Data.Map as DM
import qualified Data.Vector as DV
import qualified Statistics.Sample as SS
import qualified Statistics.Quantile as SQ
import Text.Printf

main :: IO()
main = do
    input <- LC.getContents
    output (nums $ LC.lines input)

-- clean input into a list of numbers
nums :: [LC.ByteString] -> [Double]
nums llns = floats $ map BC.unpack $ slns llns
    where
        slns = map (BC.concat . LC.toChunks)
        floats [] = []
        floats [x] = [read x :: Double]
        floats (x:xs) = [read x :: Double] ++ floats xs

-- | calculate the frequency of items in a set
-- [ [(number, frequency), ....
freqs xs = DM.toList $ DM.fromListWith (+) [(c, 1) | c <- xs]

-- | calculate the mode of a list of numbers
mode xs = (fst . DL.head) $ DL.sortBy sortGT $ freqs xs
    where
        sortGT (a1, b1) (a2, b2)
            | b1 < b2 = GT
            | b1 > b2 = LT
            | b1 == b2 = compare b1 b2

-- | calculate a quantile point
qtile q t xs = (SQ.continuousBy SQ.medianUnbiased q t) $ DV.fromList xs

-- | calculate the midhinge
midhinge xs = (qtile 1 4 xs + qtile 3 4 xs) / 2

-- | calculate the trimean
trimean xs = (qtile 2 4 xs + midhinge xs) / 2

h :: (Floating a, Ord t) => [t] -> a
-- | calculate Shannon Entropy
h xs = negate . sum . map (\(i,j) -> (p j xs) * (logBase 2 $ p j xs)) $ freqs xs
    where
        p n lst = (/) n tot_len
	tot_len = (fromIntegral $ length xs)

-- | string formatter: round to 4 decimal places
format f n = printf "%.4f" (f $ DV.fromList n)

-- | display output formatting
display xs = sequence_ [putStrLn (a++" : "++b) | (a,b) <- xs]

output :: [Double] -> IO ()
output xs = display table
    where table = [("Length", show $ length xs)
                  ,("Min", show $ minimum xs)
                  ,("Max", show $ maximum xs)
                  ,("Range", printf "%.4f" $ maximum xs - minimum xs)
                  ,("Q1", format (SQ.continuousBy SQ.medianUnbiased 1 4) xs)
                  ,("Q2", format (SQ.continuousBy SQ.medianUnbiased 2 4) xs)
                  ,("Q3", format (SQ.continuousBy SQ.medianUnbiased 3 4) xs)
                  ,("IQR", format (SQ.midspread SQ.medianUnbiased 4) xs)
                  ,("Trimean", printf "%.4f" $ trimean xs)
                  ,("Midhinge", printf "%.4f" $ midhinge xs)
                  ,("Mean", format SS.mean xs)
                  ,("Mode", show $ mode xs)
                  ,("Kurtosis", format SS.kurtosis xs)
                  ,("Skewness", format SS.skewness xs)
                  ,("Entropy", printf "%.4f" ((h xs) :: Float))]


module ComplexPlotter where

import Data.Complex
import System.IO()
import System.Process

-- Converts a number to a complex number
toComplex n = n :+ 0

-- Adds two complex numbers
cadd (a :+ b) (c :+ d) = (a + c) :+ (b + d)

-- Subtracts two complex numbers
csub (a :+ b) (c :+ d) = (a - c) :+ (b - d)

-- Multiplies two complex numbers
cmul (a :+ b) (c :+ d) = (a*c - b*d) :+ (a*d + b*c)

---- Complex numbers
i = 0.0 :+ 1.0
zero = 0.0 :+ 0.0
one = 1.0 :+ 0.0
two = 2.0 :+ 0.0

-- Complex functions
-- x^2
square z = cmul z z

-- Uses partial application to return a function g(x, c) = c + f(x)
cPlus c = cadd (c :+ 0.0)

-- x^2 + 25
squarePlus25 z = cadd (25 :+ 0) $ cmul z z

-- x = i
imagPlane _ = i

-- 2x**2 + 2x + 2
complexPoly z = cadd ((two `cmul` z) `cadd` two) (cmul two (square z))

format (a, b, c, d) = show a ++"\t" ++ show b ++"\t" ++ show c ++ "\t" ++ show d ++ "\n\n"

plot f ss a b = do
          let axis = [a, a+ss..b]
          let graph = [(x, y, magnitude $ f (x :+ y), phase $ f (x :+ y)) | x <- axis, y <- axis]

          writeFile "data.txt" $ foldr (++) "" $ map format graph

          gnuplot <- callCommand "gnuplot \"Surface-Magnitude.plt\""
          return gnuplot

{--
Changes the parameter c of a complex function f(x) + c in the interval [a, b] with a given
stepsize ss.

The method returns a list all functions where c is set according to the interval above.
--}

functionList ss a b = [cPlus c | c <- [a, a+ss..b]]

{--

This method gets a lists of functions and from that generates frames that get encoded into a video

Default parameters:
Function: square
Step Size: 0.125
Interval: [-10, 10]

Change according to your needs in the function below.

Example of how to run the function:

*> animate $ functionList 1 (-25) 25

This will create a file "plot.mp4" showing the complex function z^2 + 0 ... z^2 + 25

--}

animate fx = animate' fx 0 where
  animate' [] n = do
                  video <- callCommand $ "ffmpeg -r 30 -f image2 -s 1920x1080 -start_number 0 -i ./pics/frame%d.png -vframes " ++ show (n-1) ++ " -vcodec libx264 -crf 15  -pix_fmt yuv420p plot.mp4"
                  return video

  animate' (f:fs) n = do
                    current <- plot (f . square) 0.125 (-10) (10)
                    return current

                    rename <- callCommand $ "ren \"pics\\output.png\" \"frame" ++ show n ++ ".png"
                    return rename

                    animate' fs (n+1)


{-# LANGUAGE TypeOperators   #-}

module Main where

import Data.Complex
import Data.Word8
import Codec.Picture
import qualified Data.Array.Repa as R
import Data.Array.Repa (Array, DIM1, DIM2, U, D, Z (..), (:.)(..), (!))

-- Type that represents a single Pixel that will be used by Repa
type RGB8 = (Pixel8, Pixel8, Pixel8)

maxIterations :: Int
maxIterations = 255

imgWidth :: Int
imgWidth = 1920

imgHeight :: Int
imgHeight = 1080

imgPath :: String
imgPath = "./mandel.png"

f :: RealFloat a => Complex a -> Complex a -> Complex a
f c z = z^2 + c

fractal :: RealFloat a => Complex a -> Complex a -> Int
fractal c init = length . takeWhile (\x -> magnitude x <= 2) . take maxIterations $ iterated
    where iterated = iterate (f c) init

scaleInterval :: Fractional a => (a, a) -> (a, a) -> a -> a
scaleInterval (a, b) (c, d) t = c + (((d - c) * (t - a)) / (b - a))

main :: IO ()
main = do
    putStrLn $ "Writing mandelbrot set in " ++ imgPath ++ ", please wait."
    repaVectorImage <- R.computeUnboxedP generateImgRepa
    let mandelbrotImage = repaArrayToImage repaVectorImage
    writePng imgPath mandelbrotImage
    putStrLn "Image successfully written."

generatePixel :: (Z :. Int :. Int) -> RGB8
generatePixel (Z :. x :. y) = (iters, iters, iters)
    where
        iters = fromIntegral $ fractal (scX :+ scY) (0 :+ 0)
        scY = scaleInterval (0.0, fromIntegral imgHeight) (-1.0, 1.0) $ fromIntegral y
        scX = scaleInterval (0.0, fromIntegral imgWidth) (-2.0, 0.5) $ fromIntegral x

generateImgRepa :: Array D DIM2 RGB8
generateImgRepa = R.fromFunction (Z :. imgWidth :. imgHeight) generatePixel

repaArrayToImage :: Array U DIM2 RGB8 -> Image PixelRGB8
repaArrayToImage a = generateImage gen imgWidth imgHeight
  where
    gen x y =
      let (r, g, b) = a ! (Z :. x :. y)
      in PixelRGB8 r g b


module Data.MyPolynomial (
	Monomial ((:*^:))
	, (*^)
	, Equation(Eq)
	, getEq
	, getL
	, getR
	, Polynomial
	, Roots
	, mbrCoeff
	, mbrPower
	, discriminantQuadratic
	, roots
	, canonify
	, degree
	, handleNegativePowers
	, getABC
	, toMap
	, absurd
	, divergent
	, BroadSol(Absurd, Real)
	, Solution(Quadratic, Simple, Broad)
	, solveEquation
	) where

import Data.Complex (Complex((:+)))
import Data.List
import qualified Data.IntMap.Lazy as M
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State

import Data.MyPolynomial.Type
import Data.MyPolynomial.Parser
import Data.MyPolynomial.Print

type ComplexF = Complex Float
type Roots = (ComplexF, ComplexF)
type NonRoots = [ComplexF]

 -- Sums every Monomial of equal power.
squeeze :: Polynomial -> Polynomial
squeeze poly = runReader (doSqueeze poly) (powers poly)
	where
		 -- Build an unique list of represented powers in @pl@
		powers pl = nub $ fmap mbrPower pl

		-- Every @mn@ in @pl@ whose power is equal to the provided @pw@.
		samePower pw pl = partition (\ (_ :*^: mp) -> mp == pw) pl

		-- For each the provided power @pw@, partition out bros of power p, sum them, add them back to the other partition.
		foldPower pw pl = let	(bros, others) = samePower pw pl
					brogogo = foldr (\ m macc -> head $ macc +^+ m) (zeroP pw) bros
					in (brogogo:others)

		-- Pseudo type annotation :
		-- doSequeeze :: Polynomial -> Reader Env@[Power] Polynomial
		doSqueeze pl = do
			e:es <- ask
			let pl' = foldPower e pl
			  in case es of	[] -> return pl'
					_ -> local (\ (_:en) -> en ) (doSqueeze pl')

 -- Returns a, b, c coefficients as in the canonical expression aX^2 + bX + c
getABC :: M.IntMap Float -> (Float, Float, Float)
getABC mmap = (mmap M.! 2, mmap M.! 1, mmap M.! 0)

 -- Takes a condensed quadratic list polynomial; calls error otherwise.
toMap :: Polynomial -> M.IntMap Float
toMap pl = mapIt (squeeze pl) (M.singleton 0 0)
	where
	  mapIt ((c :*^: p):mn) map = mapIt mn (M.insert p c map)
	  mapIt [] map = map

 -- Calls error if the polynomial degree is out of bounds ([0 <-> 2]).
assertMap :: M.IntMap Float -> ()
assertMap mmap = let d = degree mmap
		   in if d > 2 || d < 0
		   	then	error "Uncondensed or non-quadratic list polynomial."
		   	else	()

 -- Expects a canonical quadratic representation
discriminantQuadratic :: M.IntMap Float -> Float
discriminantQuadratic mmap = let  (a, b, c) = getABC mmap
				in (b ^ 2 - 4.0 * a * c)

data BroadSol = Absurd | Real
data Solution = Quadratic Roots | Simple Float | Broad BroadSol

solveEquation :: Equation -> Solution
solveEquation eq = (doSolve . toMap . getL . canonify) eq
  where
    doSolve mmap = let 	a = mmap M.! 2
    			b = mmap M.! 1
			c = mmap M.! 0
		    in dispatch a b c mmap
    quadratic m = Quadratic ( roots m )
    simple m = Simple ( solveDeg1 m )
    broad m = Broad ( broadSolve m )
    dispatch a b c m	| a /= 0 = quadratic m
			| a == 0 && b /= 0 = simple m
			| a == 0 && b == 0 = broad m

broadSolve :: M.IntMap Float -> BroadSol
broadSolve mmap	= case mmap M.! 0 of	0 -> Real
					_ -> Absurd

solveDeg1 :: M.IntMap Float -> Float
solveDeg1 mmap = let	b = mmap M.! 1
			c = mmap M.! 0
		   in (-c) / b

roots :: M.IntMap Float -> Roots
roots mmap
	| delta < 0 = (cr1, cr2)
	| delta == 0 = (rr0, rr0)
	| delta > 0 = (rr1, rr2)
	where
	 (a, b, c) = getABC mmap
	 delta = discriminantQuadratic mmap
	 cr1 = (-b / (2 * a)) :+ (sqrt(-delta) / (2 * a))
	 cr2 = (-b / (2 * a)) :+ (-sqrt(-delta) / (2 * a))
	 rr1 = ((-b - sqrt(delta)) / (2 * a)) :+ 0
	 rr2 = ((-b + sqrt(delta)) / (2 * a)) :+ 0
	 rr0 = rr1

yankLeft :: Equation -> Equation
yankLeft (Eq (lp, rp)) = Eq (lp ++ (move rp), [zero])
  where
    move [] = []
    move ((c :*^: p):rpn) = ((-c) :*^: p):move(rpn)

canonify :: Equation -> Equation
canonify (Eq (l,r)) = let l' = zero : zeroP 1 : zeroP 2 : l
			  Eq (l'', r') = yankLeft $ Eq (l', r)
			  l''' = squeeze l''
			 in Eq (l''', r')

canonifyP :: Polynomial -> Polynomial
canonifyP pl = let pl' = zero : zeroP 1 : zeroP 2 : pl
		 in squeeze pl'

degree :: M.IntMap Float -> Int
degree mmap = highest 0
	where
	  highest k = case M.lookupGT k mmap of { Nothing -> smaller k;	Just (kn, _) -> highest kn; }
	  smaller k = case M.lookupLE k mmap of { Nothing -> k;		Just (kn, v) -> check kn v; }
	  check kn v = if ( v == 0 && kn > 0 )	then	smaller (kn - 1)
				   		else	kn

cutHighZeroes :: Equation -> Equation
cutHighZeroes (Eq (l, r)) = Eq (skim l, skim r)
	where skim = filter (\(c :*^: p) -> c /= 0 || (c == 0 && p == 0))

absurd :: Equation -> Bool
absurd eq	| Eq ([cl :*^: 0], [cr :*^: 0]) <- eq'  = cl /= cr
		| otherwise = False
	where
	  Eq (l, r) = yankLeft eq
	  eq' = cutHighZeroes $ Eq (squeeze l, squeeze r)

divergent :: Equation -> Bool
divergent eq	| Eq ([cl :*^: 0], [cr :*^: 0]) <- eq'  = cl == cr
		| otherwise = False
	where
	  Eq (l, r) = yankLeft eq
	  eq' = cutHighZeroes $ Eq (squeeze l, squeeze r)

-- Monomial multiplication
infix 5 *^*
(*^*) :: Monomial -> Monomial -> Monomial
c1 :*^: p1 *^* c2 :*^: p2 = (c1 * c2) :*^: (p1 + p2)

infixr 5 /^/
(/^/) :: Monomial -> Monomial -> Monomial
c1 :*^: p1 /^/ c2 :*^: p2 = (c1 * (1.0 / c2)) :*^: (p1 - p2)

-- Monomial sum
infix 4 +^+
(+^+) :: Monomial -> Monomial -> Polynomial
m1@(c1 :*^: p1) +^+ m2@(c2 :*^: p2) | p1 == p2 = [(c1 + c2) :*^: p1]
				    | otherwise = m1:m2:[]

infix 4 -^-
(-^-) :: Monomial -> Monomial -> Polynomial
m1 -^- (c2 :*^: p2) = m1 +^+ ((-c2) :*^: p2)

-- Transforms negative power monomes away and adds forbidden roots to the State.
handleNegativePowers :: Polynomial -> State NonRoots Polynomial
handleNegativePowers p = case (findNeg p) of	Nothing -> get >>= (\s -> state (\_ -> (p, s)))
						Just mn -> handleNext mn p
  where
    bundle (a, b) = nub [a, b]
    addForbidden st nr = nub $ st ++ nr

    handleNext :: Monomial -> Polynomial -> State NonRoots Polynomial
    handleNext mx pl = do
    	get >>= (\s -> put $ addForbidden s (badRoots mx))
	handleNegativePowers ( applyRcp mx pl )

    applyRcp :: Monomial -> Polynomial -> Polynomial
    applyRcp negmn pl = canonifyP $ fmap (/^/ negmn) pl

    badRoots :: Monomial -> [ComplexF]
    badRoots (_ :*^: 0) = [] -- Should not happen.
    badRoots (c :*^: p)	| (-p) == 1 = ((:[]) . (:+ 0) . solveDeg1) $ toMap [zero, (c :*^: 1), zeroP 2]
			| (-p) == 2 = bundle $ roots $ toMap [(c :*^: 2), zeroP 1, zeroP 0]
			| otherwise = error $ "Will not solve: monomial of a higher absolute degree than 2:\n" ++ prettyMonomial (c :*^: p)

    findNeg = find (\(c :*^: p) -> p < 0 && c /= 0)


module Regression where

import Control.Monad.State
import Numeric.LinearAlgebra                         (col, disp, Matrix, R, rand, scale, toLists, tr, Vector, (><))
import Numeric.LinearAlgebra.HMatrix                 (mul, sumElements)

meanMatrix :: Matrix R -> Int -> Double
meanMatrix inputs batchSize = (sumElements inputs) / (fromIntegral batchSize)

variance :: [Double] -> Double -> Double
variance inputs mean = sum [(x - mean)**2 | x <- inputs]

sigmoid :: Matrix R -> Matrix R
sigmoid inputs = 1.0 / (1.0 + exp (-1 * inputs))

forward :: Matrix R -> Matrix R -> Matrix R
forward inputs weights = sigmoid (mul inputs weights)

criterion :: Matrix R -> Matrix R -> Matrix R
criterion targets logits = (-1 * targets) * (log logits) - (1 - targets) * (log $ 1 - logits)

loss :: Matrix R -> Matrix R -> Int -> Double
loss targets logits batchSize = meanMatrix (criterion targets logits) batchSize

getGradient :: Matrix R -> Matrix R -> Matrix R -> Int -> Matrix R
getGradient inputs targets logits batchSize = (mul (tr inputs) (logits - targets)) / (fromIntegral batchSize)

updateWeights :: Double -> Matrix R -> Matrix R -> Matrix R
updateWeights learningRate gradient weights = (weights - (learningRate `scale` gradient))

getNewWeights :: Matrix R -> Matrix R -> Matrix R -> Int -> Matrix R
getNewWeights inputs targets weights batchSize =
    updateWeights 0.001 (getGradient inputs targets (forward inputs weights) batchSize) weights

runTrain :: Matrix R -> Matrix R -> Int -> State (Matrix R) (Matrix R)
runTrain inputs targets batchSize = do
    weights <- get
    forM_ [0..500] $ \e -> do
        put (getNewWeights inputs targets weights batchSize)
    return weights

activate :: [Double] -> [Double]
activate predictions = [if x > 0.5 then 1.0 else 0.0 | x <- predictions ]


{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

{-|
Module      : Grenade.Core.WeightInitialization
Description : Defines the Weight Initialization methods of Grenade.
Copyright   : (c) Manuel Schneckenreither, 2018
License     : BSD2
Stability   : experimental

This module defines the weight initialization methods.

-}

module Grenade.Core.WeightInitialization
    ( getRandomVector
    , getRandomMatrix
    , WeightInitMethod (..)
    ) where

import           Control.Monad
import           Control.Monad.Primitive         (PrimBase, PrimState)
import           Data.Proxy
import           Data.Singletons.TypeLits
import           GHC.TypeLits                    hiding (natVal)
import           Numeric.LinearAlgebra.Static
import           System.Random.MWC
import           System.Random.MWC.Distributions

-- ^ Weight initialization method.
data WeightInitMethod
  = UniformInit -- ^ W_l,i ~ U(-1/sqrt(n_l),1/sqrt(n_l))                   where n_l is the number of nodes in layer l
  | Xavier      -- ^ W_l,i ~ U(-sqrt (6/n_l+n_{l+1}),sqrt (6/n_l+n_{l+1})) where n_l is the number of nodes in layer l
  | HeEtAl      -- ^ W_l,i ~ N(0,sqrt(2/n_l))                              where n_l is the number of nodes in layer l

-- | Get a random vector initialized according to the specified method.
getRandomVector ::
     forall m n. (PrimBase m, KnownNat n)
  => Integer
  -> Integer
  -> WeightInitMethod
  -> Gen (PrimState m)
  -> m (R n)
getRandomVector i o method gen = do
  unifRands <- vector <$> replicateM n (uniformR (-1, 1) gen)
  gaussRands <- vector <$> replicateM n (realToFrac <$> standard gen)
  return $
    case method of
      UniformInit -> (1 / sqrt (fromIntegral i)) * unifRands
      Xavier      -> (sqrt 6 / sqrt (fromIntegral i + fromIntegral o)) * unifRands
      HeEtAl      -> sqrt (2 / fromIntegral i) * gaussRands
  where
    n = fromIntegral $ natVal (Proxy :: Proxy n)

-- | Get a matrix with weights initialized according to the specified method.
getRandomMatrix ::
     forall m r n. (PrimBase m, KnownNat r, KnownNat n, KnownNat (n * r))
  => Integer
  -> Integer
  -> WeightInitMethod
  -> Gen (PrimState m)
  -> m (L r n)
getRandomMatrix i o method gen = do
  unifRands <- matrix <$> replicateM nr (uniformR (-1, 1) gen)
  gaussRands <- matrix <$> replicateM nr (realToFrac <$> standard gen)
  return $
    case method of
      UniformInit -> (1 / sqrt (fromIntegral i)) * unifRands
      Xavier      -> (sqrt 6 / sqrt (fromIntegral i + fromIntegral o)) * unifRands
      HeEtAl      -> sqrt (2 / fromIntegral i) * gaussRands
  where
    nr = fromIntegral $ natVal (Proxy :: Proxy (n * r))


{-# LANGUAGE ParallelListComp #-}

module Lib
    ( showC,
      printC,
      bitReverseMap,
      generationFFT,
      generationIFFT,
      decimationFFT,
      decimationIFFT
    ) where

import Data.Complex

-- |Shows the list of complex numbers in a nice way, without reimplementing show itself.
showC :: Show a => [Complex a] -> String
showC [] = "[]"
showC xs = "[\n" ++ (unlines $ map (\i -> "  " ++ show i ++ ",") xs) ++ "]\n"

-- |Print complex numbers easily.
printC :: Show a => [Complex a] -> IO ()
printC xs = putStrLn $ showC xs

-- |Moves the last item to the front. O(n)
-- (a, b, c, d) => (d, a, b, c)
translateBack :: Num a => [Complex a] -> [Complex a]
translateBack [] = []
translateBack xs = last xs : init xs

-- |Fourier transform of translating back. It's just multiplying by e^{-2 \pi i
-- x / N} This will be the meat of the forward calculation.
--
-- (a, b, c, d) => (a, omega * b, omega^2 * c, omega^3 * d)
modulateForward :: RealFloat a => Int -> [Complex a] -> [Complex a]
modulateForward n xs =
    let twiddles = map (\i -> cis (-2 * pi * fromIntegral i / fromIntegral n)) [0..] in
        [w * i | i <- xs | w <- twiddles]

-- |Fourier transform of translating forward. This will be the meat of the
-- inverse calculation. Uses +2 instead of -2 as the coefficient. Equivalent to
-- moving forward one.
--
-- (a, b, c, d) => (a, omega * b, omega^2 * c, omega^3 * d)
modulateReverse :: RealFloat a => Int -> [Complex a] -> [Complex a]
modulateReverse n xs =
    let twiddles = map (\i -> cis (2 * pi * fromIntegral i / fromIntegral n)) [0..] in
        [w * i | i <- xs | w <- twiddles]

-- |Pad adds a zero between every other zero. It's Fourier transform is decompress.
--
-- (a, b, c, d) => (a, 0, b, 0, c, 0, d, 0)
pad :: Num a => [Complex a] -> [Complex a]
pad [] = []
pad (x:xs) = x:(0 :+ 0):(pad xs)

-- |Opposite of pad. Takes adjacent numbers and adds them together.
--
-- (a, b, c, d) => (1/2) * (a + b, c + d)
unpad :: RealFloat a => [Complex a] -> [Complex a]
unpad [] = []
unpad (x:[]) = [x]
unpad (x:y:xs) = (x + y):xs

-- |Fourier transform of pad. Unfolds the list, and divides by two.
--
-- (A, B, C, D) => (1/2) * (A, B, C, D, A, B, C, D)
decompress :: RealFloat a => [Complex a] -> [Complex a]
decompress xs = map (/ 2) (xs ++ xs)

-- |Fourier transform of the unpad, where you remove "zeros", by
-- squishing adjacent values. But fold would conflict with the standard Haskell
-- syntax.
--
-- (A, B, C, D) => (1/2) * (A + C, B + D)
compress :: RealFloat a => Int -> [Complex a] -> [Complex a]
compress n xs =
    let (a, b) = splitAt (div n 2) xs in
        map (/2) $ zipWith (+) a b

-- | Inverse version without 1/2 so that it adds to 1/N at the end.
--
-- (A, B, C, D) => (A + C, B + D)
compress' :: RealFloat a => Int -> [Complex a] -> [Complex a]
compress' n xs =
    let (a, b) = splitAt (div n 2) xs in
        zipWith (+) a b

-- |Small helper to simplify generator function.
--
-- (A, B, C) + (a, b, c) => (A + a, B + b, C + c)
add :: Num a => [a] -> [a] -> [a]
add x y = zipWith (+) x y

-- |One unit of a generative fast Fourier transform. See book for more details
-- and explanation.
generationUnit :: RealFloat a => Int -> [Complex a] -> [Complex a] -> [Complex a]
generationUnit n x y =
    (decompress x) `add` (modulateForward n . decompress $ y)

-- |Inverse (note that this version is basically off by a sign and a constant)
-- |Note that (x ++ x) is used instead of decompress since it only lacks a 2.
generationIUnit :: RealFloat a => Int -> [Complex a] -> [Complex a] -> [Complex a]
generationIUnit n x y =
    (x ++ x) `add` (modulateReverse n $ y ++ y) -- uses ++ so it avoids 1/2 on
                                                -- fold

-- |Decimation version. See book for more details and explanation.
decimationUnit :: RealFloat a => Int -> [Complex a] -> ([Complex a], [Complex a])
decimationUnit n x = (compress n x, compress n . modulateForward n $ x)

-- |Inverse operation off by a factor and a sign. Uses compress' which doesn't
-- have the 2.
decimationIUnit :: RealFloat a => Int -> [Complex a] -> ([Complex a], [Complex a])
decimationIUnit n x = (compress' n x, compress' n . modulateReverse n $ x)

-- |Nice little feature in case you try to make this imperative (or remove the
-- alternating costs more likely). Bit reverse doesn't improve the algorithmic
-- complexity in this case, so I did not include it in the base program.
--
-- It is based on the "Bracewell-Buneman algorithm", but Haskell's linked lists
-- may make it algorithmically worse than an imperative version.
--
-- 4 => (0, 3, 1, 2)
bitReverseMap :: Int -> [Int]
bitReverseMap 1 = [0]
bitReverseMap n =
    let x = map (*2) $ bitReverseMap (div n 2) in
        x ++ map (+1) x

-- |Alternate is the little cousin of a bit reverse. You take too lists and
-- alternate between the elements. This is used in the decimationFFT to combine
-- the two results into one.
--
-- (a, b), (c, d) => (a, c, b, d)
alternate :: [a] -> [a] -> [a]
alternate [] _ = []
alternate _ [] = []
alternate (x:xs) (y:ys) = x:y:(alternate xs ys)

-- |Unalternate is the inverse of the alternate, where it splits up the list the
-- exact same way. This is used in the generationFFT to feed the recursive FFTs.
--
-- (a, b, c, d) => ((a, c), (b, d))
unalternate :: [a] -> ([a], [a])
unalternate [] = ([], [])
unalternate (x:[]) = ([x], [])
unalternate (x:y:xs) = (x:a, y:b)
    where (a, b) = unalternate xs

-- |This puts all the above functions together in a assembly-based Fourier
-- transform. Very elegant! Note that I don't do any checks on n-size, and it
-- fail unexpectedly and silently for those values, since the Fourier transforms
-- depend on it being divisible by 2.
generationFFT :: RealFloat a => Int -> [Complex a] -> [Complex a]
generationFFT 1 x = x
generationFFT n x =
    generationUnit n (generationFFT halfn a) (generationFFT halfn b)
    where (a, b) = unalternate x
          halfn = div n 2

-- |Inverse of the above (really just the same with name changes). (off by a
-- factor and a sign in the process).
generationIFFT :: RealFloat a => Int -> [Complex a] -> [Complex a]
generationIFFT 1 x = x
generationIFFT n x =
    generationIUnit n (generationIFFT halfn a) (generationIFFT halfn b)
    where (a, b) = unalternate x
          halfn = div n 2

-- |Disassembly version of the above. Note how similar it is to the version
-- above, but with a small difference in how it proceeds in computation. This
-- one breaks up lists into smaller values, while the generative goes
-- recursively down first.
decimationFFT :: RealFloat a => Int -> [Complex a] -> [Complex a]
decimationFFT 1 x = x
decimationFFT n x =
    alternate (decimationFFT halfn a) (decimationFFT halfn b)
    where (a, b) = decimationUnit n x
          halfn = div n 2

-- |Decimation inverse. Off by a constant and sign in the process.
decimationIFFT :: RealFloat a => Int -> [Complex a] -> [Complex a]
decimationIFFT 1 x = x
decimationIFFT n x =
    alternate (decimationIFFT halfn a) (decimationIFFT halfn b)
    where (a, b) = decimationIUnit n x
          halfn = div n 2

-- TODO: Add testing features to show that it works.


module Lib.Practice.P5
    (
        f5
    ) where

import Numeric.LinearAlgebra
import Lib.Utility

f5 = do
    let sigmoid x = 1 / (1 + exp(-x))
    let calcA x w b = add b $ x <> w
    let x = (1><2) [1,0.5 :: Double]
    let w1 = (2><3) [0.1,0.3,0.5,0.2,0.4,0.6]
    let b1 = (1><3) [0.1,0.2,0.3]
    let a1 = calcA x w1 b1
    let z1 = cmap sigmoid a1
    print z1

    let w2 = (3><2) [0.1,0.4,0.2,0.5,0.3,0.6]
    let b2 = (1><2) [0.1,0.2]
    let a2 = calcA z1 w2 b2
    let z2 = cmap sigmoid a2
    print z2

    let w3 = (2><2) [0.1,0.3,0.2,0.4]
    let b3 = (1><2) [0.1,0.2]
    let a3 = calcA z2 w3 b3
    let y = a3
    print y

    let a4 = (1><3) [1010,1000,990 :: Double]
    print $ softmax' a4

softmax' :: Matrix Double -> Matrix Double
softmax' a = expA / sumExpA
    where (r, c) = size a
          maxs = col $ map maxElement $ toRows a
          expA = cmap exp $ a - maxs
          sumExpA = row $ map sumElements $ toRows expA


-- ch1 ex.1.23

import Statistics.Distribution.Normal
import qualified Statistics.Distribution as S

normalD :: NormalDistribution
normalD = normalDistr mean stdD
  where
    mean = 75
    stdD = 20

main :: IO ()
main = do
  -- ratio greater than 95 sec:
  putStrLn $ "the ratio of longer than 95 second: "
          ++ show (S.complCumulative normalD 95)

  putStrLn $ "Between 35 sec and 115 sec:         "
          ++ show ((S.complCumulative normalD 35) - (S.complCumulative normalD 115))

  putStrLn $ "more than 2 min:                    "
          ++ show (S.complCumulative normalD 120)


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}

{-|
Module      : Numeric.QuadraticProgramming.PQP.Static
Description : Implementation of PQP QP solver using type level naturals
Copyright   : (c) Ryan Orendorff, 2020
License     : BSD3
Stability   : experimental

Solve a QP with positive definite hessian using the method known as Parallel
Quadratic Programming (PQP).

Reference: Brand, Matthew, et al. "A parallel quadratic programming algorithm for model predictive control." IFAC Proceedings Volumes 44.1 (2011): 1031-1039.

Link: https://www.merl.com/publications/docs/TR2011-056.pdf
-}
module Numeric.QuadraticProgramming.PQP.Static
    ( pqp
    , dualToPrimalQPPoint
    )
where

import           GHC.TypeLits
import           Numeric.LinearAlgebra.Static
import           Prelude                 hiding ( (<>) )

-- | Solves the following quadratic program
--
-- \[
-- \begin{aligned}
-- \min_x\ \ & \tfrac{1}{2} x^TAx + c^Tx \\
-- \textrm{s.t}\ \ & B x \leq d
-- \end{aligned}
-- \]
--
-- where \(A\) is positive definite and the primal problem above is feasible.
--
-- by solving the dual program with the following simple iterative update step.
--
-- \[
-- y_i \leftarrow y_i \left[\frac{h_i^- + (Q^-y)_i}{h_i^+ + (Q^+y)_i}\right]
-- \]
--
-- where
--
-- - \(i\) references the ith element of a vector.
-- - \(Q^+\) is the positive elements of the hessian of the dual quadratic
--   program (ie \(Q^+ = \textrm{max}(Q, 0) + diag(r), r \succeq 0\)).
--   Similar statement for \(Q^-\) but with an absolute value.
--   The \(r\) vector guarantees that the dual quadratic program is positive
--   semidefinite after the thresholding, bounding the solution away from
--   zero and infinity.
-- - \(h^+\) is the positive elements of the dual linear cost component
--   (\(h^+ = \textrm{max}(Q, 0)\))
pqp
    :: (KnownNat m, KnownNat n)
    => L n n -- ^ Hessian of the quadratic program cost, \(A\)
    -> R n   -- ^ Linear component of the quadratic program cost \(c\)
    -> L m n -- ^ Constraint matrix \(B\)
    -> R m   -- ^ Constraint vector \(d\)
    -> [(R m, R n)] -- ^ Dual and primal iterations

-- Initial guess must be > 0. Absent a better heuristic we use 1.
pqp a c b d = iterate update (konst 1, toPrimal (konst 1))
  where
    -- Lift max functions from operating on doubles to operating on vectors
    -- and matrices
    -- TODO: extract out into top level definition
    max0v  = dvmap (max 0)
    max0m  = dmmap (max 0)

    -- Convert to dual QP
    q      = b <> (inv a) <> (tr b)
    h      = d + (b <> (inv a)) #> c

    -- Need any r >= 0 in order to make the dual update step positive
    -- semidefinite.
    r      = max0m (-q) #> konst 1

    hPlus  = max0v h
    hMinus = max0v (-h)

    qPlus  = max0m q + diag r
    qMinus = max0m (-q) + diag r

    toPrimal = dualToPrimalQPPoint a c b

    -- Normally this is written out for each element index individually,
    -- which makes this problem embarassingly parallel. However, we are not
    -- concerned about the parallelizability but that the algorithm is
    -- implemented correctly. There is a part that is not parallel (Q⁺y,
    -- Q⁻y), but ideally the matrix-vector multiply is fast.
    update (y, _) = let y' = y * ((hMinus + (qMinus #> y)) /
                                  (hPlus + (qPlus #> y)))
                    in (y', toPrimal y')

-- | Convert a point in the dual space to the primal space using the formula
--
-- \[
-- x = A^{-1} (c + B^T y)
-- \]
dualToPrimalQPPoint
    :: (KnownNat m, KnownNat n)
    => L n n -- ^ Hessian of the quadratic program cost, \(A\)
    -> R n   -- ^ Linear cost \(c\)
    -> L m n -- ^ Constraint matrix \(B\)
    -> R m   -- ^ Dual value \(y\)
    -> R n   -- ^ Primal value
dualToPrimalQPPoint a c b y = (-(inv a #> (c + (tr b) #> y)))

-- TODO: Define other direction (I suppose not as useful in this case)


{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf            #-}
{-# LANGUAGE PatternSynonyms       #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeInType            #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE ViewPatterns          #-}

module Backprop.Learn.Model.Function (
  -- * Statistics
    meanModel
  , varModel
  , stdevModel
  , rangeModel
  -- * Activation functions
  -- | See <https://en.wikipedia.org/wiki/Activation_function>
  --
  -- ** Maps
  -- *** Unparameterized
  , step
  , logistic
  , softsign
  , reLU
  , softPlus
  , bentIdentity
  , siLU
  , softExponential
  , sinc
  , gaussian
  , tanh
  , atan
  , sin
  , vmap
  , vmap'
  -- *** Parameterized
  , liftUniform
  , isru
  , preLU
  , sreLU
  , sreLUPFP
  , eLU
  , isrLU
  , apl
  , aplPFP
  -- ** Mixing
  , softMax
  , maxout
  , kSparse
  ) where

import           Control.Category
import           Data.Foldable
import           Data.Profunctor
import           Data.Proxy
import           Data.Type.Tuple
import           GHC.TypeNats
import           Numeric.Backprop
import           Numeric.LinearAlgebra.Static.Backprop hiding (tr)
import           Prelude hiding                               ((.), id)
import qualified Control.Foldl                                as F
import qualified Data.Vector.Sized                            as SV
import qualified Data.Vector.Storable.Sized                   as SVS
import qualified Numeric.LinearAlgebra                        as HU
import qualified Numeric.LinearAlgebra.Static                 as H
import qualified Numeric.LinearAlgebra.Static.Vector          as H

meanModel
    :: (Backprop (t a), Foldable t, Functor t, Fractional a, Reifies s W)
    => BVar s (t a)
    -> BVar s a
meanModel = liftOp1 . op1 $ \xs ->
    let x :# n = F.fold ((:#) <$> F.sum <*> F.length) xs
    in  (x / fromIntegral n, \d -> (d / fromIntegral n) <$ xs)

varModel
    :: (Backprop (t a), Foldable t, Functor t, Fractional a, Reifies s W)
    => BVar s (t a)
    -> BVar s a
varModel = liftOp1 . op1 $ \xs ->
    let x2 :# x1 :# x0 = F.fold ((\x2' x1' x0' -> x2' :# x1' :# x0') <$> lmap (^(2::Int)) F.sum <*> F.sum <*> F.length) xs
        meanx  = x1 / fromIntegral x0
        subAll = 2 * x1 / (fromIntegral x0 ^ (2 :: Int))
    in  ( (x2 / fromIntegral x0) - meanx * meanx
        , \d -> let subAllD = d * subAll
                in  (\x -> d * 2 * x / fromIntegral x0 - subAllD) <$> xs
        )

stdevModel
    :: (Backprop (t a), Foldable t, Functor t, Floating a, Reifies s W)
    => BVar s (t a)
    -> BVar s a
stdevModel = sqrt . varModel

rangeModel
    :: (Backprop (t a), Foldable t, Functor t, Ord a, Num a, Reifies s W)
    => BVar s (t a)
    -> BVar s a
rangeModel = liftOp1 . op1 $ \xs ->
    let mn :# mx = F.fold ((:#) <$> F.minimum <*> F.maximum) xs
    in  case (:#) <$> mn <*> mx of
          Nothing           -> errorWithoutStackTrace "Backprop.Learn.Model.Function.range: empty range"
          Just (mn' :# mx') ->
            ( mx' - mn'
            , \d -> (\x -> if | x == mx'  -> d
                              | x == mn'  -> -d
                              | otherwise -> 0
                    ) <$> xs
            )

-- | Softmax normalizer
softMax
    :: (KnownNat i, Reifies s W)
    => BVar s (R i)
    -> BVar s (R i)
softMax x = expx / konst (norm_1V expx)
  where
    expx = exp x

-- | Logistic function
--
-- \[
-- \sigma(x) = \frac{1}{1 + e^{-x}}
-- \]
logistic :: Floating a => a -> a
logistic x = 1 / (1 + exp (-x))

-- | Binary step / heaviside step
--
-- To use with vectors ('R'), use 'vmap''.
--
-- \[
-- \begin{cases}
-- 0 & \text{for } x < 0 \\
-- 1 & \text{for } x \ge 0
-- \end{cases}
-- \]
step :: (Ord a, Num a) => a -> a
step x | x < 0     = 0
       | otherwise = 1

-- | Softsign activation function
--
-- \[
-- \frac{x}{1 + \lvert x \rvert}
-- \]
softsign :: Fractional a => a -> a
softsign x = x / (1 + abs x)

-- | Inverse square root unit
--
-- \[
-- \frac{x}{\sqrt{1 + \alpha x^2}}
-- \]
--
-- See 'liftUniform' to make this compatible with 'PFP'.
--
-- You can also just use this after partially applying it, to fix the
-- parameter (and not have it trained).
isru
    :: Floating a
    => a        -- ^ α (scaling parameter)
    -> a        -- ^ x
    -> a
isru α x = x / sqrt (1 + α * x * x)

-- | Rectified linear unit.
--
-- To use with vectors ('R'), use 'vmap''.
--
--
-- \[
-- \max(0,x)
-- \]
--
-- @
-- 'reLU' = 'preLU' 0
-- @
--
reLU :: (Num a, Ord a) => a -> a
reLU x | x < 0     = 0
       | otherwise = x

-- | Parametric rectified linear unit
--
-- To use with vectors ('R'), use 'vmap''.
--
-- If scaling parameter is a fixed (and not learned) parameter, this is
-- typically called a leaky recitified linear unit (typically with
-- α = 0.01).
--
-- To use as a learned parameter:
--
-- @
-- 'vmap' . 'preLU' :: 'BVar' s Double -> 'BVar' s ('R' n) -> BVar s (R n)
-- @
--
-- This can be give directly to 'PFP'.
--
-- To fix the paramater ("leaky"), just partially apply a parameter:
--
-- @
-- 'preLU' 0.01           :: 'BVar' s ('R' n) -> BVar s (R n)
-- preLU ('realToFrac' α) :: BVar s (R n) -> BVar s (R n)
-- @
--
-- See also 'rreLU'.
--
-- \[
-- \begin{cases}
-- \alpha x & \text{for } x < 0 \\
-- x        & \text{for } x \ge 0
-- \end{cases}
-- \]
preLU
    :: (Num a, Ord a)
    => a        -- ^ α (scaling parameter)
    -> a        -- ^ x
    -> a
preLU α x | x < 0     = α * x
          | otherwise = x

-- | Exponential linear unit
--
-- To use with vectors ('R'), use 'vmap''.
--
-- To use as a learned parameter:
--
-- @
-- 'vmap' . 'eLU' :: 'BVar' s Double -> 'BVar' s ('R' n) -> BVar s (R n)
-- @
--
-- This can be give directly to 'PFP'.
--
-- To fix the paramater, just partially apply a parameter:
--
-- @
-- 'vmap'' ('eLU' 0.01) :: 'BVar' s ('R' n) -> BVar s (R n)
-- @
--
-- \[
-- \begin{cases}
-- \alpha (e^x - 1) & \text{for } x < 0 \\
-- x                & \text{for } x \ge 0
-- \end{cases}
-- \]
eLU :: (Floating a, Ord a)
    => a        -- ^ α (scaling parameter)
    -> a        -- ^ x
    -> a
eLU α x | x < 0     = α * (exp x - 1)
        | otherwise = x

-- | S-shaped rectified linear activiation unit
--
-- See 'sreLUPFP' for an uncurried and uniformly lifted version usable with
-- 'PFP'.
--
-- \[
-- \begin{cases}
-- t_l + a_l (x - t_l) & \text{for } x \le t_l  \\
-- x                   & \text{for } t_l < x < t_r  \\
-- t_r + a_r (x - t_r) & \text{for } x \ge t_r
-- \end{cases}
-- \]
sreLU
    :: (Num a, Ord a)
    => a        -- ^ @t_l@
    -> a        -- ^ @a_l@
    -> a        -- ^ @t_r@
    -> a        -- ^ @a_l@
    -> a        -- ^ @x@
    -> a
sreLU tl al tr ar x
    | x < tl    = tl + al * (x - tl)
    | x > tr    = tr + ar * (x - tr)
    | otherwise = x

-- | An uncurried and uniformly lifted version of 'sreLU' directly usable
-- with 'PFP'.
sreLUPFP
    :: (KnownNat n, Reifies s W)
    => BVar s ((Double :# Double) :# (Double :# Double))
    -> BVar s (R n)
    -> BVar s (R n)
sreLUPFP ((tl :## al) :## (tr :## ar)) = vmap (sreLU tl al tr ar)

-- | Inverse square root linear unit
--
-- To use with vectors ('R'), use 'vmap''.
--
-- \[
-- \begin{cases}
-- \frac{x}{1 + \alpha x^2} & \text{for } x < 0 \\
-- x                        & \text{for } x \ge 0
-- \end{cases}
-- \]
isrLU
    :: (Floating a, Ord a)
    => a        -- ^ α
    -> a        -- ^ x
    -> a
isrLU α x
    | x < 0     = x / sqrt (1 + α * x * x)
    | otherwise = x

-- | Adaptive piecewise linear activation unit
--
-- See 'aplPFP' for an uncurried version usable with 'PFP'.
--
-- \[
-- \max(0, x_i) + \sum_j^M a_i^j \max(0, -x_i + b_i^j)
-- \]
apl :: (KnownNat n, KnownNat m, Reifies s W)
    => BVar s (L n m)     -- ^ a
    -> BVar s (L n m)     -- ^ b
    -> BVar s (R m)       -- ^ x
    -> BVar s (R m)
apl as bs x = vmap' (max 0) x
            + sum (toRows (as * (bs - fromRows (SV.replicate x))))

-- | 'apl' uncurried, to be directly usable with 'PFP'.
aplPFP
    :: (KnownNat n, KnownNat m, Reifies s W)
    => BVar s (L n m :# L n m)
    -> BVar s (R m)
    -> BVar s (R m)
aplPFP (a :## b) = apl a b

-- | SoftPlus
--
-- \[
-- \ln(1 + e^x)
-- \]
softPlus :: Floating a => a -> a
softPlus x = log (1 + exp x)

-- | Bent identity
--
-- \[
-- \frac{\sqrt{x^2 + 1} - 1}{2} + x
-- \]
bentIdentity :: Floating a => a -> a
bentIdentity x = (sqrt (x * x + 1) - 1) / 2 + x

-- | Sigmoid-weighted linear unit.  Multiply 'logistic' by its input.
--
-- \[
-- x \sigma(x)
-- \]
siLU :: Floating a => a -> a
siLU x = x * logistic x

-- | SoftExponential
--
-- To use with vectors ('R'), use 'vmap''.
--
-- \[
-- \begin{cases}
-- - \frac{\ln(1 - \alpha (x + \alpha))}{\alpha} & \text{for } \alpha < 0  \\
-- x                                             & \text{for } \alpha = 0  \\
-- \frac{e^{\alpha x} - 1}{\alpha} + \alpha      & \text{for } \alpha > 0
-- \end{cases}
-- \]
softExponential
    :: (Floating a, Ord a)
    => a            -- ^ α
    -> a            -- ^ x
    -> a
softExponential α x = case compare α x of
    LT -> - log (1 - α * (x + α)) / α
    EQ -> x
    GT -> (exp (α * x) - 1) / α + α

-- | Sinc
--
-- \[
-- \begin{cases}
-- 1                 & \text{for } x = 0  \\
-- \frac{\sin(x)}{x} & \text{for } x \ne 0
-- \end{cases}
-- \]
sinc :: (Floating a, Eq a) => a -> a
sinc 0 = 1
sinc x = sin x / x

-- | Gaussian
--
-- \[
-- e^{-x^2}
-- \]
gaussian :: Floating a => a -> a
gaussian x = exp (- (x * x))

-- | Maximum of vector.
--
-- Compare to 'norm_InfV', which gives the maximum absolute value.
maxout :: (KnownNat n, Reifies s W) => BVar s (R n) -> BVar s Double
maxout = liftOp1 . op1 $ \x ->
    let n = HU.maxElement . H.extract $ x
    in  ( n
        , \d -> H.vecR . SVS.map (\e -> if e == n then d else 0) . H.rVec $ x
        )

-- | Usable with functions like '*', 'isru', etc. to turn them into a form
-- usable with 'PFP':
--
-- @
-- 'liftUniform' ('*')  :: 'BVar' s 'Double' -> BVar s ('R' n) -> BVar s (R n)
-- liftUniform 'isru' :: BVar s Double -> BVar s (R n) -> BVar s (R n)
-- @
--
-- Basically turns a parmaeterized function on individual elements of
-- into one that shares the same parameter across all elements of the
-- vector.
liftUniform
    :: (Reifies s W, KnownNat n)
    => (BVar s (R n) -> r)
    -> BVar s Double
    -> r
liftUniform f = f . konst

-- -- TODO: vmap can do better.

-- | Keep only the top @k@ values, and zero out all of the rest.
--
-- Useful for postcomposing in between layers (with a logistic function
-- before) to encourage the number of "activated" neurons is kept to be
-- around @k@.  Used in k-Sprase autoencoders (see 'KAutoencoder').
--
-- <http://www.ericlwilkinson.com/blog/2014/11/19/deep-learning-sparse-autoencoders>
kSparse
    :: forall n s. (Reifies s W, KnownNat n)
    => Int                      -- ^ number of items to keep
    -> BVar s (R n)
    -> BVar s (R n)
kSparse k = liftOp1 . op1 $ \xs ->
    let xsSort = HU.sortVector (H.extract xs)
        thresh = xsSort `HU.atIndex` (n - k)
        mask   = H.dvmap (\x -> if x >= thresh then 1 else 0) xs
    in  ( H.dvmap (\x -> if x >= thresh then x else 0) xs
        , (* mask)
        )
  where
    n = fromIntegral $ natVal (Proxy @n)


{-# LANGUAGE FlexibleContexts #-}
---------------------------------------------------------------------------------
-- |
-- Module       : Amby.Numeric
-- Copyright    : (C) 2016 Justin Sermeno
-- License      : BSD3
-- Maintainer   : Justin Sermeno
--
-- Functions for working with numerical ranges and statistics.
---------------------------------------------------------------------------------
module Amby.Numeric
  ( -- * Ranges
    contDistrDomain
  , contDistrRange
  , linspace
  , arange
  , random

  -- * Frequencies
  , scoreAtPercentile
  , interquartileRange
  , freedmanDiaconisBins

  ) where

import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector as V

import Statistics.Distribution
import qualified Statistics.Quantile as Stats
import System.Random.MWC (withSystemRandom, asGenST)

-- $setup
-- >>> let demoData = V.fromList $ concat $ zipWith replicate [5, 4, 3, 7] [0..3]

---------------------
-- Ranges
---------------------

-- | @contDistrDomain d n@ generates a domain of 'n' evenly spaced points
-- for the continuous distribution 'd'.
contDistrDomain :: (ContDistr d) => d -> Int -> U.Vector Double
contDistrDomain d num = linspace (quantile d 0.0001) (quantile d 0.9999) num

-- | @contDistrRange d xs@ generates the pdf value of the continious distribution
-- 'd' for each value in 'xs'.
contDistrRange :: (ContDistr d) => d -> U.Vector Double -> U.Vector Double
contDistrRange d x = U.map (density d) x

-- | @linspace s e n@ generates 'n' evenly spaced values between ['s', 'e'].
linspace :: Double -> Double -> Int -> U.Vector Double
linspace start stop num
  | num < 0 = error ("Number of samples, " ++ show num ++ ", must be non-negative.")
  | num == 0 || num == 1 = addStart $ U.generate num ((* delta) . fromIntegral)
  | otherwise = addStart $ U.generate num ((* step) . fromIntegral)
  where
    delta = stop - start
    step = delta / fromIntegral (num - 1)
    addStart = U.map (realToFrac . (+ start))

-- | @arange s e i@ generates numbers between ['s', 'e'] spaced by amount 'i'.
-- 'arange' is the equivalent of haskell's range notation except that it generates
-- a 'Vector'. As a result, the last element may be greater than less than, or
-- greater than the stop point.
arange :: Double -> Double -> Double -> U.Vector Double
arange start stop step = U.fromList [start,(start + step)..stop]

-- | Generates an unboxed vectors of random numbers from a distribution
-- that is an instance of 'ContGen'. This function is meant for ease of use
-- and is expensive.
random :: (ContGen d) => d -> Int -> IO (U.Vector Double)
random d n = withSystemRandom . asGenST $ \gen ->
  U.replicateM n $ genContVar d gen

---------------------
-- Frequencies
---------------------

-- | @scoreAtPercentile xs p@ calculates the score at percentile 'p'.
--
-- Examples:
--
-- >>> let a = arange 0 99 1
--
-- >>> scoreAtPercentile a 50
-- 49.5
scoreAtPercentile :: (G.Vector v Double) => v Double -> Int -> Double
scoreAtPercentile xs p
  | G.length xs == 0 =
    modErr "scoreAtPercentile" "Cannot find percentile of empyt list"
  | otherwise = Stats.weightedAvg p 100 xs

-- | Calculate the interquartile range.
--
-- Examples:
--
-- >>> interquartileRange demoData
-- 2.5
interquartileRange :: (G.Vector v Double) => v Double -> Double
interquartileRange xs = scoreAtPercentile xs 75 - scoreAtPercentile xs 25
{-# SPECIALIZE interquartileRange :: U.Vector Double -> Double #-}
{-# SPECIALIZE interquartileRange :: V.Vector Double -> Double #-}

-- | Estimate a good default bin size.
--
-- Examples:
--
-- >>> freedmanDiaconisBins demoData
-- 2
freedmanDiaconisBins :: (G.Vector v Double) => v Double -> Int
freedmanDiaconisBins xs =
    if h == 0
      then floor $ sqrt $ (fromIntegral n :: Double)
      else ceiling $ (G.maximum xs - G.minimum xs) / h
  where
    n = G.length xs
    h = 2 * interquartileRange xs / fromIntegral n ** (1 / 3)

modErr :: String -> String -> a
modErr f err = error
  $ showString "Amby.Numeric."
  $ showString f
  $ showString ": " err


module Main where

import System.IO
import Graphics.Gnuplot.Simple
import Numeric.LinearAlgebra

data DefIntegral a = DefIntegral (a->a) a a

--instance Show DefIntegral where
--  show (DefIntegral _ start end) = "Integral from" ++ show a ++ "to" ++ show b

--mixed :: (Enum a, Field a) => DefIntegral a -> a -> a -> a
--mixed (DefIntegral f start end) alpha steps =
--  sum $ map (\x -> x) (intervals start end steps)

aitken :: (Enum a, Field a, RealFrac a, Num a)
  => DefIntegral a
  -> a
  -> (DefIntegral a -> a -> a -> a)
  -> a
  -> (a, (a, a, a))
aitken integral@(DefIntegral _ a b) alpha method initial_step =
  let [s1, s2, s3] = map (method integral alpha) [1, 2, 4]
      error = 10**(-6)
      l = 2
      m = - log (abs $ (s3 - s2)/(s2 - s1)) / log l
      optimal_step = (b-a) * (abs (error * (1 - (b-a)**(-m) / (s2 - s1))))**(1/m)
  in (optimal_step, residue integral alpha method optimal_step)

residue1 :: (Enum a, Field a, RealFrac a, Ord a)
  => DefIntegral a
  -> a
  -> (DefIntegral a -> a -> a -> a)
  -> (a, a, a)
residue1 defintegral alpha method = residue defintegral alpha method 1

-- richardson method with r=2
-- returns tuple of integral value, residue and required step
residue :: (Enum a, Field a, RealFrac a, Ord a)
  => DefIntegral a
  -> a
  -> (DefIntegral a -> a -> a -> a)
  -> a
  -> (a, a, a)
residue (DefIntegral f start end) alpha method initial_step =
  let steps_from_step step = fromIntegral . floor $ (end - start) / step + 1
      quadrature step = method (DefIntegral f start end) alpha (steps_from_step step)
      find_m [s1, s2, s3] = - log (abs $ (s3 - s2)/(s2 - s1)) / log l
      error = 10**(-6)
      l = 2.0
      steps_ = [initial_step / l**i | i<-[0..]]

      iter steps =
        -- find vector (J, Cm, Cm+1, ...) and take J from it
        let steps' = (3><1) $ take 3 steps
            rhs = cmap quadrature steps'
            m = find_m . toList . flatten $ rhs
            lhs = (3><1) [1, 1, 1] ||| cmap (**m) steps' ||| cmap (**(m+1)) steps'
            integral = (lhs <\> rhs) `atIndex` (0, 0)
            res = integral - (rhs `atIndex` (2, 0))
        in (integral, res)
      find_residue steps =
        if abs res < error
        then (integral, res, steps !! 2)
        else find_residue (tail steps)
        where (integral, res) = iter steps
  in find_residue steps_

cardano :: (Field a) => a -> a -> a -> a -> [a]
cardano a b c d =
  let p = c/a - b**2/(3*a**2)
      q = 2*b**3 / (27*a**3) - b*c/(3*a**2) + d/a
      phi = acos(3*q/(2*p) * sqrt(-3/p))
      y1 = 2*sqrt(-p/3) * cos(phi/3)
      y2 = 2*sqrt(-p/3) * cos(phi/3 + 2*pi/3)
      y3 = 2*sqrt(-p/3) * cos(phi/3 - 2*pi/3)
  in [y1 - b/(3*a), y2 - b/(3*a), y3 - b/(3*a)]

gauss_helper :: (Enum a, Field a) => DefIntegral a -> a -> (a, a) -> a
gauss_helper (DefIntegral f start end) alpha (left, right) =
  let -- 0) substition
      left' = end - left
      right' = end - right
      avg' = (right' + left') / 2
      f' x = f $ end - x

      -- 1) find weights
      weight n = - (right'**(n-alpha+1) - left'**(n-alpha+1)) / (n-alpha+1)

      --2) solve linear system for a's
      ws_lhs = (3><3)
        [ weight 0, weight 1, weight 2
        , weight 1, weight 2, weight 3
        , weight 2, weight 3, weight 4]

      ws_rhs = (3><1)
        [ -weight 3
        , -weight 4
        , -weight 5]

      coefs_a = ws_lhs <\> ws_rhs

      -- 3) solve 3-order equation for xs
      [d, c, b] = toList . flatten $ coefs_a
      xs = (1><3) $ cardano 1 b c d

      -- 4) solve linear system for A's
      helper_lhs = (1><3) [1, 1, 1] === xs === cmap (**2) xs
      helper_rhs = (3><1)
        [ weight 0
        , weight 1
        , weight 2]
      coefs_A = helper_lhs <\> helper_rhs

      -- then sum Ai*fi
      fs = cmap f' xs
      result_vector = fs <> coefs_A
      [[result]] = toLists result_vector
  in result

gauss :: (Enum a, Field a) => DefIntegral a -> a -> a -> a
gauss integral@(DefIntegral f start end) alpha steps =
  sum $ map (gauss_helper integral alpha) (intervals start end steps)

general_nc_helper :: (Enum a, Field a) => Int -> DefIntegral a -> a -> (a, a) -> a
general_nc_helper order (DefIntegral f start end) alpha (left, right) =
  let  -- substitution
      left' = end - left
      right' = end - right
      f' x = f $ end - x

      xs = linspace order (end-left, end-right)
      fs = asColumn $ cmap f' xs

      weight n = - (right'**(n-alpha+1) - left'**(n-alpha+1)) / (n-alpha+1)

      weights = cmap weight $ (order><1) [0..toEnum order-1]

      xs_matrix = (order><order) [x^p | p<-[0..order-1], x<-toList xs]

      a_coefs = tr $ xs_matrix <\> weights
      result_vector = a_coefs <> fs

      [[result]] = toLists result_vector
  in result

newton_cotes_helper :: (Enum a, Field a) => DefIntegral a -> a -> (a, a) -> a
newton_cotes_helper (DefIntegral f start end) alpha (left, right) =
  let -- substitution
      left' = end - left
      right' = end - right
      avg' = (right' + left') / 2
      f' x = f $ end - x

      weight n = - (right'**(n-alpha+1) - left'**(n-alpha+1)) / (n-alpha+1)

      weights = (3><1) [weight 0, weight 1, weight 2]

      xs = (3><3)
        [ 1, 1, 1
        , left', avg', right'
        , left'**2, avg'**2, right'**2]

      fs = (3><1) [f' left', f' avg', f' right']

      a_coefs = tr $ xs <\> weights

      result_vector = a_coefs <> fs
  in result_vector `atIndex` (0, 0)

--alpha is power of p(x)
newton_cotes :: (Enum a, Field a) => DefIntegral a -> a -> a -> a
newton_cotes integral@(DefIntegral f start end) alpha steps =
  sum $ map (general_nc_helper 3 integral alpha) (intervals start end steps)

-- mixed with same degree=5
mixed1 :: (Enum a, Field a) => DefIntegral a -> a -> a -> a
mixed1 integral@(DefIntegral f start end) alpha steps =
  sum . map (\(interval, i) -> helper interval i) $ zip (intervals start end steps) [1..]
  where helper interval i = if odd i
                            then general_nc_helper 6 integral alpha interval
                            else gauss_helper integral alpha interval

-- mixed with different degrees: gauss with 5 and nc with 2
mixed2 :: (Enum a, Field a) => DefIntegral a -> a -> a -> a
mixed2 integral@(DefIntegral f start end) alpha steps =
  sum . map (\(interval, i) -> helper interval i) $ zip (intervals start end steps) [1..]
  where helper interval i = if odd i
                            then general_nc_helper 3 integral alpha interval
                            else gauss_helper integral alpha interval

left_sum :: (Fractional a, Num a, Enum a) => DefIntegral a -> a -> a
left_sum (DefIntegral f start end) steps =
  sum . map (\(left, right) -> (right - left) * (f left)) $ intervals start end steps

average_sum :: (Fractional a, Num a, Enum a) => DefIntegral a -> a -> a
average_sum (DefIntegral f start end) steps =
  sum . map (\(left, right) -> (right - left) * (f $ (left + right) / 2)) $ intervals start end steps

trapezoid_sum :: (Fractional a, Num a, Enum a) => DefIntegral a -> a -> a
trapezoid_sum (DefIntegral f start end) steps =
  sum . map (\(left, right) -> (right - left) * (f right + f left) / 2) $ intervals start end steps

simpson_sum :: (Fractional a, Num a, Enum a) => DefIntegral a -> a -> a
simpson_sum (DefIntegral f start end) steps =
  halfstep / 3 * (sum . map (\(left, middle, right) -> f left + 4 * f middle +  f right) $ interv)
  where step = (end - start) / steps
        halfstep = step / 2
        segment = [start + halfstep, start + 3*halfstep .. end - halfstep]
        interv = map (\x -> (x - halfstep, x, x + halfstep)) segment

simpsons :: (Fractional a, Num a) => DefIntegral a -> a
simpsons (DefIntegral f start end) =
  (end - start) / 6 * (f start + 4 * f ((start + end) / 2) + f end)

intervals :: (Fractional a, Num a, Enum a) => a -> a -> a -> [(a, a)]
intervals start end n_intervals =
  zip intervals' (tail intervals')
  where intervals' = [start, start + step .. end - step] ++ [end]
        -- add end to the end to escape problems with floating point arithmetics
        step  = (end - start) / n_intervals

tests :: IO ()
tests = do
  putStrLn "hello world"
  -- let a = 0 :: Double
  -- let b = 10
  -- let func = \x -> x
  let func = \x -> 3.7 * cos(1.5 * x) * exp(-4*x / 3) + 2.4 * sin(4.5 * x) * exp(2*x / 3) + 4
  let a = 1.8 :: Double
  let b = 2.3

  let integral = DefIntegral func a b
  let test_input = [2, 3, 5, 10, 50, 100, 200]

  let test method = map (method integral) test_input
  let test2 method = map (method integral 0.6) test_input

  putStrLn $ "steps: " ++ show test_input
  putStrLn $ "newton-cotes: " ++ show (test2 newton_cotes)
  putStrLn $ "gauss: " ++ show (test2 gauss)
  putStrLn $ "mixed1: " ++ show (test2 mixed1)
  putStrLn $ "mixed2: " ++ show (test2 mixed2)
  putStrLn "------------------------------\n"
  -- should be 1.18515
  putStrLn $ "left_sum: " ++ show (test left_sum)
  putStrLn $ "avg_sum: " ++ show  (test average_sum)
  putStrLn $ "trap_sum: " ++ show (test trapezoid_sum)
  putStrLn $ "simpsons: " ++ show (test simpson_sum)

  putStrLn $ "\n##########################\n"

  let residue_test method = residue1 integral 0.6 method

  putStrLn $ "residue newton_cotes: " ++ show (residue_test newton_cotes)
  putStrLn $ "residue gauss: " ++ show (residue_test gauss)
  putStrLn $ "residue mixed1: " ++ show (residue_test mixed1)
  putStrLn $ "residue mixed2: " ++ show (residue_test mixed2)

  let aitken_gauss_test = aitken integral 0.6 gauss 0.1
  let (opt_step, aitken_result) = aitken_gauss_test
  putStrLn $ "optimal step = " ++ show opt_step
  putStrLn $ "aitken gauss: " ++ show aitken_result

plots :: IO()
plots = do
  let func = \x -> 3.7 * cos(1.5 * x) * exp(-4*x / 3) + 2.4 * sin(4.5 * x) * exp(2*x / 3) + 4
  let a = 1.8 :: Double
  let b = 2.3
  let integral = DefIntegral func a b
  let steps = [3.0,4.0..500]

  let integral_value = 2.37880192961486
  --let integral_value = 1.18515

  let map_left = map (left_sum integral) steps
  let map_avg = map (average_sum integral) steps
  let map_trap = map (trapezoid_sum integral) steps
  let map_simps = map (simpson_sum integral) steps

  let map_nc = map (newton_cotes integral 0.6) steps
  let map_gauss = map (gauss integral 0.6) steps

  let left = zip steps $ map (-integral_value+) map_left
  let avg = zip steps $ map (-integral_value+) map_avg
  let trap = zip steps $ map (-integral_value+) map_trap
  let simps = zip steps $ map (-integral_value+) map_simps
  --plotList [] $ zip steps $ map (-integral_value+) map_nc
  --plotList [] $ zip steps $ map (-integral_value+) map_gauss

  let helper values name = (defaultStyle {lineSpec = CustomStyle [LineTitle name]}, values)
  plotListsStyle [Title "Comparacent of different quadrature methods"]
    [ helper left "left"
    , helper avg "avg"
    , helper trap "trapezoid"
    , helper simps "simpson"]

outputToFile :: IO()
outputToFile = do
  let func = \x -> 3.7 * cos(1.5 * x) * exp(-4*x / 3) + 2.4 * sin(4.5 * x) * exp(2*x / 3) + 4
  let a = 1.8 :: Double
  let b = 2.3
  let integral = DefIntegral func a b
  let steps = [3.0,4.0..500]

  let integral_value = 2.37880192961486

  let map_left = map (left_sum integral) steps
  let map_avg = map (average_sum integral) steps
  tests

  file <- openFile "outputnc.txt" WriteMode
  --hPutStrLn file ("integral_result = " ++ show integral_value ++ "\n")
  --hPutStrLn file ("steps = " ++ (show steps) ++ "\n")
  --hPutStrLn file ("left_sum = " ++ (show $ map (left_sum integral) steps) ++ "\n")
  --hPutStrLn file ("avg_sum = " ++ (show $ map (average_sum integral) steps) ++ "\n")
  --hPutStrLn file ("trap_sum = " ++ (show $ map (trapezoid_sum integral) steps) ++ "\n")
  hPutStrLn file ("simpson_sum = " ++ (show $ map (simpson_sum integral) steps) ++ "\n")
  --hPutStrLn file ("newton_cotes_sum = " ++ (show $ map (newton_cotes integral 0.6) steps) ++ "\n")
  hClose file

main :: IO ()
main = do
  --outputToFile
  tests


{-# LANGUAGE OverloadedStrings #-}
module Numeric.Clustering.Perplexity where

import qualified Data.Massiv.Array as MA
import qualified Numeric.NLOPT as NLOPT
import qualified Numeric.LinearAlgebra as LA
import qualified Control.Monad.Catch as X
import qualified Data.Text as Text
import Numeric (log)

pGivenBeta :: MA.Source r MA.Ix1 Double => MA.Ix1 -> MA.Vector r Double -> Double -> MA.Vector MA.D Double
pGivenBeta rowIndex distances beta =
  let scale ci d = if (ci == rowIndex) then 0 else exp (-d * beta)
      raw = MA.imap scale distances
      sumRaw = MA.sum raw
  in raw MA..* (1 / sumRaw)

safe_xLogx :: Double -> Double
safe_xLogx x = if x > 1e-7 then x * log x else 0

entropy :: MA.Source r MA.Ix1 Double => MA.Vector r Double -> MA.Ix1 -> Double -> Double
entropy distances rowIndex beta = MA.sum $ MA.map (\x -> negate $ safe_xLogx x) $ pGivenBeta rowIndex distances beta

findBeta :: MA.Source r MA.Ix1 Double => Double -> MA.Ix1 -> MA.Vector r Double -> Either Text.Text Double
findBeta perplexity rowIndex distances =
  let targetEntropy = log perplexity
      obj x = abs (targetEntropy - entropy distances rowIndex (x `LA.atIndex` 0))
      algo = NLOPT.NELDERMEAD obj [] Nothing
      stopWhenAny = NLOPT.ObjectiveAbsoluteTolerance 1e-4 NLOPT.:|
                    [NLOPT.MaximumEvaluations 50
                    ]
      problem = NLOPT.LocalProblem 1 stopWhenAny algo
      optimizedE = NLOPT.minimizeLocal problem (LA.fromList [1])
      textError sol = (Text.pack $ show $ NLOPT.solutionResult sol)
                      <> ": x = "
                      <> (Text.pack $ show $ NLOPT.solutionParams sol)
                      <> "; obj(x) = "
                      <> (Text.pack $ show $ NLOPT.solutionCost sol)
  in case optimizedE of
    Left r -> Left $ Text.pack $ show r
    Right s -> case NLOPT.solutionResult s of
      NLOPT.FTOL_REACHED -> Right $ (`LA.atIndex` 0) $ NLOPT.solutionParams s
      _ -> Left $ textError s

data SolveException = SolveException Text.Text deriving (Show)
instance X.Exception SolveException

probabilities :: MA.MonadThrow m => Double -> MA.Matrix MA.U Double -> m (MA.Matrix MA.U Double)
probabilities perplexity distances = do
  let distanceRows = MA.computeAs MA.B $ MA.outerSlices distances
      betaSolsE :: Either Text.Text (MA.Vector MA.U Double)
      betaSolsE = MA.itraverseA (\ix v -> findBeta perplexity ix v) distanceRows
  betas <- case betaSolsE of
    Left err -> X.throwM (SolveException err)
    Right x -> return x
  fmap MA.compute $ MA.stackOuterSlicesM $ MA.izipWith pGivenBeta distanceRows betas


module FinancialTimeseries.Statistics.Statistics where

import qualified Data.Vector as Vec
import Data.Vector (Vector)

import qualified Data.Vector.Algorithms.Merge as Merge

import qualified Statistics.Sample as Sample

import FinancialTimeseries.Type.Chart (Chart(..), LChart)
import FinancialTimeseries.Type.Labeled (Labeled)
import FinancialTimeseries.Type.Table (Table(..), Cell(..), Row, row)

data Quantiles a = Quantiles {
  q05 :: Maybe a
  , q25 :: Maybe a
  , q50 :: Maybe a
  , q75 :: Maybe a
  , q95 :: Maybe a
  } deriving (Show)

instance Row Quantiles where
  row (Quantiles a b c d e) = map (CString . maybe "n/a" show) [a, b, c, d, e]

data Probabilities a = Probabilities {
  p0'50 :: a
  , p0'75 :: a
  , p1'00 :: a
  , p1'25 :: a
  , p1'50 :: a
  , p1'75 :: a
  , p2'00 :: a
  } deriving (Show)

instance Row Probabilities where
  row (Probabilities a b c d e f g) = map Cell [a, b, c, d, e, f, g]

data TradeMoments a = TradeMoments {
  trMaxYield :: a
  , trMinYield :: a
  , trMeanYield :: a
  , trStdDevYield :: a
  } deriving (Show)

instance Row TradeMoments where
  row (TradeMoments a b c d) = map Cell [a, b, c, d]

data TimeseriesMoments a = TimeseriesMoments {
  tsMaxYield :: a
  , tsMinYield :: a
  , tsMeanYield :: a
  , tsStdDevYield :: a
  } deriving (Show)

instance Row TimeseriesMoments where
  row (TimeseriesMoments a b c d) = map Cell [a, b, c, d]

data Stats moments a = Stats {
  sampleSize :: Int
  , quantiles :: Quantiles a
  , probabilities :: Probabilities a
  , moments :: moments a
  , cdf :: Vector (Double, a)
  } deriving (Show)

tradeMoments ::
  (Real a, Fractional a) =>
  Vector a -> TradeMoments a
tradeMoments sorted =
  let sortedFrac = Vec.map realToFrac sorted
  in TradeMoments {
    trMaxYield = Vec.last sorted
    , trMinYield = Vec.head sorted
    , trMeanYield = realToFrac $ exp (Sample.mean (Vec.map log sortedFrac))
    , trStdDevYield = realToFrac $ exp (Sample.stdDev (Vec.map log sortedFrac))
    }

timeseriesMoments ::
  (Real a, Fractional a) =>
  Vector a -> TimeseriesMoments a
timeseriesMoments sorted =
  let sortedFrac = Vec.map realToFrac sorted
  in TimeseriesMoments {
    tsMaxYield = Vec.last sorted
    , tsMinYield = Vec.head sorted
    , tsMeanYield = realToFrac $ Sample.mean sortedFrac
    , tsStdDevYield = realToFrac $ Sample.stdDev sortedFrac
    }

stats2list ::
  (Row moments, Show a) =>
  [Labeled params (Stats moments a)] -> [Table params a]
stats2list xs =
  let qheaders = map CString ["Q05", "Q25", "Q50", "Q75", "Q95", "Sample Size"]
      pheaders = map CString ["P(X < 0.5)", "P(X < 0.75)", "P(X < 1.0)", "P(X < 1.25)", "P(X < 1.5)", "P(X < 1.75)", "P(X < 2.0)", "Sample Size"]
      mheaders = map CString ["Max.", "Min.", "Mean", "StdDev.", "Sample Size"]
      mkRow g x = row (g x) ++ [CInt (sampleSize x)]
  in Table "Quantiles" qheaders (map (fmap (mkRow quantiles)) xs)
     : Table "Moments" mheaders (map (fmap (mkRow moments)) xs)
     : Table "Probabilities" pheaders (map (fmap (mkRow probabilities)) xs)
     : []

stats2cdfChart :: [Labeled params (Stats moments a)] -> LChart params Double a
stats2cdfChart = Chart "CDF" . map (fmap ((:[]) . cdf))

statisticsWithMoments ::
  (Ord a, Num a, Fractional a, Real a) =>
  (Vector a -> moments a) -> Vector a -> Stats moments a
statisticsWithMoments mms vs =
  let noe = fromIntegral (Vec.length vs)
      sorted = Vec.modify Merge.sort vs

      quart s = sorted Vec.!? (round (s * noe :: Double))
      q = Quantiles {
        q05 = quart 0.05
        , q25 = quart 0.25
        , q50 = quart 0.50
        , q75 = quart 0.75
        , q95 = quart 0.95
        }

      prob s = fromIntegral (Vec.length (Vec.takeWhile (<s) sorted)) / noe
      p = Probabilities {
        p0'50 = prob 0.5
        , p0'75 = prob 0.75
        , p1'00 = prob 1.0
        , p1'25 = prob 1.25
        , p1'50 = prob 1.5
        , p1'75 = prob 1.75
        , p2'00 = prob 2.00
        }

  in Stats {
    sampleSize = Vec.length vs
    , quantiles = q
    , probabilities = p
    , moments = mms sorted
    , cdf = Vec.imap (\i x -> (fromIntegral i / noe, x)) sorted
    }

timeseriesStatistics ::
  (Real a, Fractional a) =>
  Vector a -> Stats TimeseriesMoments a
timeseriesStatistics = statisticsWithMoments timeseriesMoments

tradeStatistics ::
  (Real a, Fractional a) =>
  Vector a -> Stats TradeMoments a
tradeStatistics = statisticsWithMoments tradeMoments

yield :: (Fractional a) => Vector a -> a
yield v = Vec.last v / Vec.head v

absoluteDrawdown :: (Ord a, Fractional a) => Vector a -> a
absoluteDrawdown v = Vec.minimum v / Vec.head v

relativeDrawdown :: (Ord a, Num a, Fractional a) => Vector a -> a
relativeDrawdown v = Vec.minimum (Vec.zipWith (/) v (Vec.postscanl max 0 v))


module Net
  (
    repTrain
  , buildNetwork
  , forward
  , mse
  , sigmoid
  , sigmoid'
  , tanh'
  , printNet
  , NN
  ) where

import Numeric.LinearAlgebra
import Data.Traversable

type ActivationF = Double -> Double
type ActivationD = Double -> Double
type Activation = (ActivationF, ActivationD)
type Bias = Matrix R
type Weights = Matrix R
type Layer = (Weights, Bias, Activation)
type NN = [Layer]

type Input = Matrix R
type Output = Matrix R
type Deriv = Matrix R
type Error = Matrix R
type LearningRate = Double

repTrain :: Int -> LearningRate -> Input -> Output -> NN -> NN
repTrain 0 _ _ _ nn = nn
repTrain n lr x y nn = repTrain (n-1) lr x y (backprop lr x y nn)

buildNetwork :: Activation -> [Int] -> IO NN
buildNetwork act (a:b:xs) = do
  weights <- randn a b
  bias    <- randn 1 b
  rest    <- buildNetwork act (b:xs)
  return $ (weights, bias, act):rest
buildNetwork _ _ = return []

forward :: NN -> Input -> Output
forward = (fst .) . flip feedForward

feedForward :: Input -> NN -> (Output, [(Input, Deriv)])
feedForward = mapAccumL activateLayer

activateLayer :: Input -> Layer -> (Output, (Input, Deriv))
activateLayer input (wh, bh, act) = (output, (input, deriv))
  where
    output = cmap (fst act) ((input <> wh + bh))
    deriv  = cmap (snd act) output

backprop :: LearningRate -> Input -> Output -> NN -> NN
backprop lr input y net = backpropLayers lr error inpDs net
   where
     (output, inpDs) = feedForward input net
     error = y - output

mse :: NN -> Input -> Output -> Error
mse net x y = let (output, _) = feedForward x net in y - output

backpropLayers :: LearningRate -> Error -> [(Input, Deriv)] -> NN -> NN
backpropLayers lr error inpDs = snd . mapAccumR (backpropMatrix lr) error . zip inpDs
--  = ((snd . mapAccumR (backpropMatrix lr) error .) . zip) inpDs

backpropMatrix :: LearningRate -> Matrix R -> ((Matrix R, Matrix R), Layer) -> (Error, Layer)
backpropMatrix lr error (inputInfo, layer) = (prev_error, new_layer)
  where
    (layer_weights, layer_bias, act) = layer
    (layer_inp, layer_deriv) = inputInfo
    new_layer = (new_weights, new_bias, act)

    d_layer = layer_deriv * error
    new_weights = (+) layer_weights $ cmap (* lr) $ (tr layer_inp) <> d_layer
    new_bias = (+) layer_bias $ cmap (* lr) $ asRow $ vector $ map sumElements $ toColumns d_layer

    prev_error = d_layer <> (tr layer_weights)

sigmoid :: Double -> Double
sigmoid x = 1.0 / (1 + exp (-x))

sigmoid' :: Double -> Double
sigmoid' x = x * (1 - x)

tanh' :: Double -> Double
tanh' x = let fx = tanh x in 1 - fx * fx

printNet :: NN -> IO ()
printNet layers = do
  mapM_ (\(w,b,_) -> do
            disp 3 w
            disp 3 b) layers


module Regression where

import MHMonad
import Distr
import Data.Monoid
import Graphics.Rendering.Chart
import Graphics.Rendering.Chart.Backend.Diagrams
import Graphics.Rendering.Chart.State
import Data.Colour
import Data.Colour.Names
import Data.Default.Class
import Control.Lens
import Statistics.Distribution
import Statistics.Distribution.Normal (normalDistr)
import Statistics.Distribution.Beta (betaDistr)

-- A random linear function
linear :: Meas (Double -> Double)
linear =
  do a <- normal 0 3
     b <- normal 0 3
     let f = \x -> a*x + b
     return f

-- Weight a function to some data points
fit :: Meas (a -> Double) -> [(a,Double)] -> Meas (a -> Double)
fit prior dataset = do f <- prior
                       mapM (\(x,y) ->
                               score $ normalPdf (f x) 0.3 y)
                            dataset
                       return f

dataset :: [(Double, Double)]
dataset = [(0,0.6), (1, 0.7), (2,1.2), (3,3.2), (4,6.8), (5, 8.2), (6,8.4)]

example :: Meas (Double -> Double)
example = fit linear dataset

-- Some graphing routines
plotWeightedPoints :: String -> [(Double,Double,Double)] -> Double -> Double -> Double -> Double -> IO ()
plotWeightedPoints filename dataset xmin xmax ymin ymax =
  let plots = map (\(x,y,w) -> toPlot $ plot_points_style .~ filledCircles 4 ((blend w blue red) `withOpacity` w)
                      $ plot_points_values .~ [(x,y)]
                      $ def) dataset in
  let my_layout = layout_plots .~ plots
                $ layout_x_axis .
                  laxis_generate .~ scaledAxis def (xmin,xmax)
                $ layout_y_axis . laxis_generate .~ scaledAxis def (ymin,ymax)
                $ def in
  let graphic =  toRenderable my_layout in
  do
     putStr ("Generating " ++ filename ++ "...")
     renderableToFile def filename graphic;
     putStrLn (" Done!")
     return ()

plotWeightedLines :: String -> [(Double,Double,Double)] -> IO ()
plotWeightedLines filename points =
  let plots = map (\(x,y,w) -> toPlot $ plot_lines_style . line_color .~ (blend w blue red) `withOpacity` (w)
                      $ plot_lines_values .~ [[ (0.0 :: Double,x) , (10.0 :: Double ,y*10+x) ]]
                      $ def) points in
  let my_dots = plot_points_style .~ filledCircles 4 (opaque black)
              $ plot_points_values .~ dataset
              $ def in
  let my_layout = layout_plots .~  (toPlot my_dots : plots)
                $ layout_x_axis .
                  laxis_generate .~ scaledAxis def (-10,10)
                $ layout_y_axis . laxis_generate .~ scaledAxis def (-10,10)
                $ def in
  let graphic =  toRenderable my_layout in
  do
     putStr ("Generating " ++ filename ++ "...")
     renderableToFile def filename graphic;
     putStrLn (" Done!")
     return ()

maxlist :: [Double] -> Double
maxlist (x:xs) = max x (maxlist xs)

minlist :: [Double] -> Double
minlist (x:xs) = min x (minlist xs)

-- Plot the points drawn from weighted samples
test1 = do
        samples <- weightedsamples example
        let xyw's = map (\(f,w) -> (f 0, f 1 - f 0, w)) $ take 10000 samples
        let m = maximum (map (\(_,_,w) -> w) xyw's)
        let xyws = map (\(x,y,w) -> (x,y, max (w/m) (1/255))) xyw's
        putStr $ show $ m
        putStr $ show $ take 20 xyws
        plotWeightedPoints "weightedpoints.svg" xyws (-6) 6 (-6) 6
        --        plotWeightedLines "weightedtest.svg" xyws
        let xyw's = map (\(f,w) -> (f 0, f 1 - f 0, w)) $ take 100000 samples
        let m = maximum (map (\(_,_,w) -> w) xyw's)
        let xyws = filter (\(x,y,_) -> x > -1 && x < 0 && y > 1 && y < 2) $ map (\(x,y,w) -> (x,y, max (w / m) 0.1)) xyw's
        plotWeightedPoints "weightedpointszoom.svg" xyws (-1) 0 1 2

-- Plot the result of MH
test2 = do
        samples <- mh example
        let xyw's = map (\(f,w) -> (f 0, f 1 - f 0, getProduct w)) $ take 10000 samples
        let m = maximum (map (\(_,_,w) -> w) xyw's)
        let xyws = map (\(x,y,w) -> (x,y, max (w / m) 0.05)) xyw's
        plotWeightedPoints "weightedpointsmh.svg" xyws (-6) 6 (-6) 6
        let xyws = filter (\(x,y,_) -> x > -1 && x < 0 && y > 1 && y < 2) $ map (\(x,y,w) -> (x,y, max (w / m) 0.1)) xyw's
        plotWeightedPoints "weightedpointszoommh.svg" xyws (-1) 0 1 2

every n xs = case drop (n-1) xs of
              (y:ys) -> y : every n ys
              [] -> []

-- More graphing routines
-- epsilon: smallest y axis difference to worry about
-- delta: smallest x axis difference to worry about
interesting_points :: (Double -> Double) -> Double -> Double -> Double -> Double -> [Double] -> [Double]
interesting_points f lower upper epsilon delta acc =
  if abs(upper - lower) < delta then acc
  else
    let mid = (upper - lower) / 2 + lower in
    if abs((f(upper) - f(lower)) / 2 + f(lower) - f(mid)) < epsilon
    then acc
    else interesting_points f lower mid epsilon delta (mid : (interesting_points f mid upper epsilon delta acc))

sample_fun f =
--  [ (x, f x) | x <- [(-0.25),(-0.25+0.1)..6.2]]
  let xs = ((-0.25) : (interesting_points f (-0.25) 6.2 0.3 0.001 [6.2])) in
  map (\x -> (x,f x)) xs

plot_funs :: String -> [(Double,Double)] -> [Double -> Double] -> IO ()
plot_funs filename dataset funs =
  let graphs  = map sample_fun funs                 in
  let my_lines  = plot_lines_style . line_color .~ blue `withOpacity` 0.01
                $ plot_lines_values .~ graphs $ def in
  let my_dots = plot_points_style .~ filledCircles 4 (opaque black)
              $ plot_points_values .~ dataset
              $ def in
  let my_layout = layout_plots .~ [toPlot my_lines , toPlot my_dots]
                $ layout_x_axis .
                  laxis_generate .~ scaledAxis def (0,6)
                $ layout_y_axis . laxis_generate .~ scaledAxis def (-2,10)
                $ def in
  let graphic =  toRenderable my_layout in
  do
     putStr ("Generating " ++ filename ++ "...")
     renderableToFile def filename graphic;
     putStrLn (" Done!")
     return ()

-- plot the results of linear regression
test3 =
  do
    fs' <- mh $ fit linear dataset
    let fs = map (\(f,_)->f) $ take 500 $ every 100 $ drop 1000 $ fs'
    plot_funs "lin-reg.svg" dataset fs

-- plot the linear regression prior
test3b =
  do
    fs' <- mh $ linear
    let fs = map (\(f,_)->f) $ take 500 $ every 100 $ drop 1000 $ fs'
    plot_funs "lin-reg-prior.svg" dataset fs

-- poissonPP lower upper rate returns a random list of points between lower and upper coming from a Poisson process with given rate
poissonPP :: Double -> Double -> Double -> Meas [Double]
poissonPP lower upper rate =
  do gap <- exponential rate
     if (lower + gap > upper)
     then return []
     else do rest <- poissonPP (lower + gap) upper rate
             return ((lower + gap) : rest)

-- Splice takes a random list of points, a random function,
-- and returns a new random function that is a piecewise version of the
-- first one.
splice :: Meas [Double] -> Meas (Double -> Double) -> Meas (Double -> Double)
splice pointProcess randomFun =
  do xs <- pointProcess
     fs <- mapM (\_ -> randomFun) xs
     default_f <- randomFun
     let h :: [(Double, Double -> Double)] -> Double -> Double
         h [] x = default_f x
         h ((a,f):xfs) x | x <= a = f x
         h ((a,f):xfs) x | x > a = h xfs x
     return (h (zip xs fs) )

test4 =
  do
    fs' <- mh $ fit (splice (poissonPP 0 6 0.1) linear) dataset
    let fs = map (\(f,_)->f) $ take 500 $ every 1000 $ drop 100000 $ fs'
    plot_funs "piecewise-lin-reg.svg" dataset fs


module Quadratic_Formula (csqrt, quadratic) where

import Data.Complex

csqrt z@(a :+ b) = let (mag, ph) = polar z in mkPolar (sqrt mag) (ph/2)

quadratic a b c = (
    quad (conjugate a) (conjugate b) (conjugate c) (+),
    quad (conjugate a) (conjugate b) (conjugate c) (-)
    ) where quad a b c op = (-b `op` csqrt ( b^2 - 4 * a * c))/(2 * a)


module Numeric.MixtureModel.Beta ( -- * General data types
                                   Sample
                                 , SampleIdx
                                 , Samples
                                 , ComponentIdx
                                 , Assignments
                                 , Weight
                                 -- * Beta parameters
                                 , BetaParam (..)
                                 , BetaParams
                                 , ComponentParams
                                 , paramFromMoments
                                 , paramToMoments
                                 , paramsFromAssignments
                                 , paramToMode
                                 -- * Beta distribution
                                 , Prob
                                 , betaProb
                                 -- * Gibbs sampling
                                 , estimateWeights
                                 , updateAssignments
                                 , updateAssignments'
                                 -- * Likelihood
                                 , likelihood
                                 -- * Classification
                                 , classify
                                 ) where

import           Data.Function (on)
import qualified Data.Vector as VB
import qualified Data.Vector.Generic as V
import qualified Data.Vector.Unboxed as VU
import qualified Data.Vector.Unboxed.Mutable as MV
import           Control.Monad.ST

import           Numeric.Log hiding (sum)
import           Numeric.SpecFunctions (logBeta)
import           Statistics.Sample (meanVarianceUnb)

import           Data.Random
import           Data.Random.Distribution.Categorical

type Prob = Log Double
type Sample = Double
type SampleIdx = Int
type ComponentIdx = Int
type Weight = Double
data BetaParam = BetaParam { bpAlpha :: !Double -- ^ Alpha
                           , bpBeta  :: !Double -- ^ Beta
                           }
               deriving (Show, Eq, Ord)

-- k refers to number of components
-- N refers to number of samples
type Samples = VU.Vector Sample                         -- length == N
type Assignments = VU.Vector ComponentIdx               -- length == N
type BetaParams = VB.Vector BetaParam                   -- length == K
type ComponentParams = VB.Vector (Weight, BetaParam)    -- length == K

beta :: Double -> Double -> Log Double
beta a b = Exp $ logBeta a b

-- | `betaProb (a,b) x` is the probability of `x` under Beta
-- distribution defined by parameters `a` and `b`
betaProb :: BetaParam -> Sample -> Prob
betaProb (BetaParam a b) x =
    1/beta a b * realToFrac (x**(a-1)) * realToFrac ((1-x)**(b-1))

-- | Beta parameter from sample mean and variance
paramFromMoments :: Double            -- ^ mean
                 -> Double            -- ^ variance
                 -> Maybe BetaParam
paramFromMoments xbar v
  | c < 0      = Nothing
  | otherwise  = Just $ BetaParam (xbar * c) ((1 - xbar) * c)
  where c = xbar * (1 - xbar) / v - 1

-- | Mean and variance of the given beta parameter
paramToMoments :: BetaParam -> (Double, Double)
paramToMoments (BetaParam a b) =
  let mean = a / (a+b)
      var  = a*b / (a+b)^2 / (a+b+1)
  in (mean, var)

-- | The mode of the given beta parameter
paramToMode :: BetaParam -> Double
paramToMode (BetaParam a b) = (a - 1) / (a + b - 2)

-- | Beta parameter from samples
paramFromSamples :: VU.Vector Sample -> BetaParam
paramFromSamples v | V.null v = error "Numeric.MixtureModel.Beta: Can't estimate priors from no samples"
paramFromSamples v =
    case uncurry paramFromMoments $ meanVarianceUnb v of
      Just a  -> a
      Nothing -> error "Numeric.MixtureModel.Beta: Somehow we have a negative variance"

-- | Beta parameter for component given samples and their component assignments
paramFromAssignments :: Samples -> Assignments -> ComponentIdx -> BetaParam
paramFromAssignments samples assignments k =
  paramFromSamples $ V.map snd $ V.filter (\(k',_)->k==k') $ V.zip assignments samples

-- | Beta parameters for all components given samples and their component assignments
paramsFromAssignments :: Samples -> Int -> Assignments -> BetaParams
paramsFromAssignments samples ncomps assignments =
  V.fromList $ map (paramFromAssignments samples assignments) [0..ncomps-1]

-- | Draw a new assignment for a sample given beta parameters
drawAssignment :: ComponentParams -> Sample -> RVar ComponentIdx
drawAssignment params x =
  let probs = map (\(w,p)->realToFrac w * betaProb p x) $ V.toList params
  in case filter (isInfinite . ln . fst) $ zip probs [0..] of
        (x:_)     -> return $ snd x
        otherwise -> categorical
                     $ map (\(p,k)->(realToFrac $ p / sum probs :: Double, k))
                     $ zip probs [0..]

countIndices :: Int -> VU.Vector Int -> VU.Vector Int
countIndices n v = runST $ do
    accum <- V.thaw $ VU.replicate n 0
    V.forM_ v $ \k -> do n' <- MV.read accum k
                         MV.write accum k $! n'+1
    V.freeze accum

-- | Estimate the component weights of a given set of parameters
estimateWeights :: Assignments -> BetaParams -> ComponentParams
estimateWeights assignments params =
  let counts = countIndices (V.length params) assignments
      norm = realToFrac $ V.length assignments
      weights = V.map (\n->realToFrac n / norm) counts
  in V.zip (V.convert weights) params

-- | Sample assignments for samples under given parameters
updateAssignments' :: Samples -> ComponentParams -> RVar Assignments
updateAssignments' samples params =
  V.mapM (drawAssignment params) samples

-- | Gibbs update of sample assignments
updateAssignments :: Samples -> Int -> Assignments -> RVar Assignments
updateAssignments samples ncomps assignments =
  updateAssignments' samples
  $ estimateWeights assignments
  $ paramsFromAssignments samples ncomps assignments

-- | Likelihood of samples assignments under given model parameters
likelihood :: Samples -> ComponentParams -> Assignments -> Prob
likelihood samples params assignments =
    V.product ( V.map (\(k,x)->betaProb (snd $ params V.! k) x)
              $ V.zip assignments samples
              )
  * V.product (V.map (\k->realToFrac $ fst $ params V.! k) assignments)

-- | Maximum likelihood classification
classify :: ComponentParams -> Sample -> ComponentIdx
classify params x =
  fst
  $ V.maximumBy (compare `on` \(_,(w,p))->realToFrac w * betaProb p x)
  $ V.indexed params


import Data.Complex

import Lib

func c z = z^2 + c

diverge maxIters f x0 = (any (\x -> magnitude x > 4) . take maxIters) (iterate f x0)

points = [a :+ b | a <- [-2.5,-2.495..1], b <- [-1,-0.995..1]]

mset = filter (\x -> not (diverge 1000 (func x) 0)) points

main = plotPoints' "mandelbrot.svg" "Mandelbrot Set" 1.4 (map c2t mset)


module Main where
import Layer
import Models
import Numeric.LinearAlgebra
import ImageProcess
import Optimization
import Trainer
import Data.Vector.Storable (Vector, length, toList)

main :: IO()
main =
  do
    let inputLayer = linearLayerInit 2 2
    let sigmoidLayer = sigmoidLayerInit 2 2
    let outputLayer = linearLayerInit 2 1 in
      let model = Model [inputLayer, sigmoidLayer, outputLayer] in
      let input = (1><2)[1.0, 2.0]::Matrix R in
      let output = forward input model in
      print output

testImageRegression :: FilePath -> IO()
testImageRegression filepath = do
  imageM <- getImageInfo filepath
  case imageM of
    Nothing -> putStrLn "Nohthing ! Guess what happened ? :) " >> return ()
    Just imagePixel8 ->
      let rgbs = getImageRGBs imagePixel8
          w = getImageWidth imagePixel8
          h =  getImageHeight imagePixel8
          rgbsList = Data.Vector.Storable.toList rgbs
          (rlist, glist, blist) = genRGBList rgbsList
          Just rMat = genMatrixFromList rlist w h
          Just gMat = genMatrixFromList glist w h
          Just bMat = genMatrixFromList blist w h in
          --- test
          print "prepare the model!" >>
          let rinputLayer = linearLayerInit w h
              rreluLayer1 = reluLayerInit w h
              rreluLayer2 = reluLayerInit w h
              rreluLayer3 = reluLayerInit w h
              routputLayer=  linearLayerInit w h
              rmodel = Model [rinputLayer, rreluLayer1, rreluLayer2, rreluLayer3, routputLayer]
              ginputLayer = linearLayerInit w h
              greluLayer1 = reluLayerInit w h
              greluLayer2 = reluLayerInit w h
              greluLayer3 = reluLayerInit w h
              goutputLayer=  linearLayerInit w h
              gmodel = Model [ginputLayer, greluLayer1, greluLayer2, greluLayer3, goutputLayer]
              binputLayer = linearLayerInit w h
              breluLayer1 = reluLayerInit w h
              breluLayer2 = reluLayerInit w h
              breluLayer3 = reluLayerInit w h
              boutputLayer=  linearLayerInit w h
              bmodel = Model [binputLayer, breluLayer1, breluLayer2, breluLayer3, boutputLayer] in
              print "begin to train the model" >>
              let trainConfig = TrainConfig {
                    trainConfigRowNum=w,
                    trainConfigColNum=h,
                    trainConfigLearningRate=0.95,
                    trainConfigMomentum=1.0,
                    trainConfigDecay=0.95,
                    trainConfigEpsilon=0.00001,
                    trainConfigBatchSize=100,
                    trainConfigOptimization="adadelta"
                    } in
              trainSingleData rmodel trainConfig rMat


import Statistics.Distribution.Uniform
import Statistics.Distribution

ud :: UniformDistribution
ud = uniformDistr 0.0 30.0

main = do
  putStrLn $ "the probability that the customer arrived within the very last 5 min:"
          ++ show (cumulative ud 30 - cumulative ud 25)
  putStrLn $ "this is 1/6: " ++ show (1/6)


{-# LANGUAGE FlexibleContexts #-}

-- |
-- Module    : Statistics.Sample.Normalize
-- Copyright : (c) 2017 Gregory W. Schwartz
-- License   : BSD3
--
-- Maintainer  : gsch@mail.med.upenn.edu
-- Stability   : experimental
-- Portability : portable
--
-- Functions for normalizing samples.

module Statistics.Sample.Normalize
    (
      standardize
    ) where

import Statistics.Sample
import qualified Data.Vector.Generic  as G
import qualified Data.Vector          as V
import qualified Data.Vector.Unboxed  as U
import qualified Data.Vector.Storable as S

-- | /O(n)/ Normalize a sample using standard scores:
--
--   \[ z = \frac{x - \mu}{\sigma} \]
--
--   Where μ is sample mean and σ is standard deviation computed from
--   unbiased variance estimation. If sample to small to compute σ or
--   it's equal to 0 @Nothing@ is returned.
standardize :: (G.Vector v Double) => v Double -> Maybe (v Double)
standardize xs
  | G.length xs < 2 = Nothing
  | sigma == 0      = Nothing
  | otherwise       = Just $ G.map (\x -> (x - mu) / sigma) xs
  where
    mu    = mean   xs
    sigma = stdDev xs
{-# INLINABLE  standardize #-}
{-# SPECIALIZE standardize :: V.Vector Double -> Maybe (V.Vector Double) #-}
{-# SPECIALIZE standardize :: U.Vector Double -> Maybe (U.Vector Double) #-}
{-# SPECIALIZE standardize :: S.Vector Double -> Maybe (S.Vector Double) #-}


-----------------------------------------------------------------------------
-- |
-- Module      :  Numeric.Statistics.PCA
-- Copyright   :  (c) A. V. H. McPhail 2010, 2014, 2017
-- License     :  BSD3
--
-- Maintainer  :  haskell.vivian.mcphail <at> gmail <dot> com
-- Stability   :  provisional
-- Portability :  portable
--
-- Principal Components Analysis
--
-----------------------------------------------------------------------------

module Numeric.Statistics.PCA (
                               pca, pcaN, pcaTransform, pcaReduce, pcaReduceN
                          ) where

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

import qualified Data.Array.IArray as I

import Prelude hiding ((<>))
import Data.List(sortBy)
import Data.Ord(comparing)
import Numeric.LinearAlgebra
import Numeric.GSL.Statistics

--import Numeric.Statistics

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

-- | find the principal components of multidimensional data greater than
--    the threshhold
pca :: I.Array Int (Vector Double)     -- the data
    -> Double                         -- eigenvalue threshold
    -> (Vector Double, Matrix Double) -- Eignevalues, Principal components
pca d q = let d' = fmap (\x -> x - (scalar $ mean x)) d -- remove the mean from each dimension
              d'' = fromColumns $ I.elems d'
              (_,vec',uni') = svd d''
              vec = toList vec'
              uni = toColumns uni'
              v' = zip vec uni
              v = filter (\(x,_) -> x > q) v'  -- keep only eigens > than parameter
              (eigs,vs) = unzip v
          in (fromList eigs,fromColumns vs)

-- | find N greatest principal components of multidimensional data
--    according to size of the eigenvalue
pcaN :: I.Array Int (Vector Double)    -- the data
     -> Int                            -- number of components to return
     -> (Vector Double, Matrix Double) -- Eignevalues, Principal components
pcaN d n = let d' = fmap (\x -> x - (scalar $ mean x)) d -- remove the mean from each dimension
               d'' = fromColumns $ I.elems d'
               (_,vec',uni') = svd d''
               vec = toList vec'
               uni = toColumns uni'
               v' = zip vec uni
               v = take n $ reverse $ sortBy (comparing fst) v'
               (eigs,vs) = unzip v
           in (fromList eigs,fromColumns vs)

v1 = fromList [1,2,3,4,5,6::Double]
v2 = fromList [2,3,4,5,6,7::Double]
v3 = fromList [3,4,5,6,7,8::Double]

a = fromColumns [v1,v2,v3]
b = I.listArray (1,3::Int) [v1,v2,v3] :: I.Array Int (Vector Double)

-- | perform a PCA transform of the original data (remove mean)
-- |     Final = M^T Data^T
pcaTransform :: I.Array Int (Vector Double)    -- ^ the data
             -> Matrix Double                  -- ^ the principal components
             -> I.Array Int (Vector Double)    -- ^ the transformed data
pcaTransform d m = let d' = fmap (\x -> x - (scalar $ mean x)) d -- remove the mean from each dimension
                   in I.listArray (1,cols m) $ toRows $ (tr' m) <> (fromRows $ I.elems d')

-- | perform a dimension-reducing PCA modification,
--     using an eigenvalue threshhold
pcaReduce :: I.Array Int (Vector Double)      -- ^ the data
          -> Double                           -- ^ eigenvalue threshold
          -> I.Array Int (Vector Double)      -- ^ the reduced data
pcaReduce d q = let u = fmap (scalar . mean) d
                    d' = zipWith (-) (I.elems d) (I.elems u)
                    d'' = fromColumns d'
                    (_,vec',uni') = svd d''
                    vec = toList vec'
                    uni = toColumns uni'
                    v' = zip vec uni
                    v = filter (\(x,_) -> x > q) v'  -- keep only eigens > than parameter
                    m = fromColumns $ snd $ unzip v
                 in I.listArray (I.bounds d) $ zipWith (+) (toRows $ m <> (tr' m) <> fromRows d') (I.elems u)

-- | perform a dimension-reducing PCA modification, using N components
pcaReduceN :: I.Array Int (Vector Double)      -- ^ the data
           -> Int                              -- ^ N, the number of components
           -> I.Array Int (Vector Double)      -- ^ the reduced data, with n principal components
pcaReduceN d n = let u = fmap (scalar . mean) d
                     d' = zipWith (-) (I.elems d) (I.elems u)
                     d'' = fromColumns d'
                     (_,vec',uni') = svd d''
                     vec = toList vec'
                     uni = toColumns uni'
                     v' = zip vec uni
                     v = take n $ reverse $ sortBy (comparing fst) v'
                     m = fromColumns $ snd $ unzip v
                  in I.listArray (I.bounds d) $ zipWith (+) (toRows $ m <> (tr' m) <> fromRows d') (I.elems u)

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


import Data.Complex
import System.Environment
import System.Process

import Lib

func c z = z^2 + c

phi = (1 + sqrt 5) / 2

main = do
    args <- getArgs

    let real:imag:_ = if null args then [1 - phi, 0] else read <$> args

        points = (:+) <$> [-1.5,-1.495..1.5] <*>  [-1.2,-1.195..1.2]
        jset = c2t <$> filter (not . diverges 50 (func (real :+ imag))) points

        fileName = "julia" ++ show real ++ "-" ++ show imag ++ ".svg"
        title = "Julia Set for z^2 + " ++ show real ++ " + " ++ show imag ++ "i"

    plotPoints fileName title 1.7 jset
    callCommand $ "inkview " ++ fileName


{-
 - Module containing a few functions about rendering the fractals.
-}
module Rendering where

import Data.Complex
import Data.List

-- RENDERING ----
escape :: (RealFloat a, Fractional a) => [Complex a] -- list of samples
    -> (a -> a) -- Intensity mapping function
    -> a -- pixel brightness
escape samples mapFunc = sum $ zipWith (\x y -> mapFunc (magnitude (y - x)))
     samples (tail samples)

follow :: (RealFloat a, Fractional a) => [Complex a] -- list of samples
    -> (Complex a -> a) -- itensity function
    -> a
follow [] func = 0
follow samples func = func $ last samples

smooth :: (RealFloat a, Fractional a) => [Complex a]
    -> a
smooth samples = foldl' (+) 0 (map (exp . ((-1)*) . magnitude) samples)

-- to get all values from iterating Julia
sample :: (RealFloat a, Fractional a) => Int  -- nbSamples
    -> (Complex a -> Bool) -- stopping condition
    -> (Complex a -> Complex a) -- how to get next point in serie
    -> Complex a -- starting point of serie (z0)
    -> [Complex a] -- list of samples
sample nbsamples isValid funct start = ((takeWhile isValid).(take nbsamples).(iterate (funct))) start

sampleIFS :: (RealFloat a, Fractional a) => Int -- nbSamples
    -> (Complex a -> Bool) -- stop condition
    -> [(Complex a -> Complex a)] -- list of functions to apply
    -> Complex a -- starting point
    -> [Complex a]
sampleIFS nbSamples isValid functions start = (takeWhile isValid).(take nbSamples).
    (iterateList functions) $ start

iterateList :: [(a -> a)] -> a -> [a]
iterateList functions x = x : iterateList fs (f x)
    where (f:fs) = cycle functions


-- vectorized boolean operations defined in terms of step or cond

import Numeric.LinearAlgebra

infix  4  .==., ./=., .<., .<=., .>=., .>.
infixr 3  .&&.
infixr 2  .||.

a .<.  b = step (b-a)
a .<=. b = cond a b 1 1 0
a .==. b = cond a b 0 1 0
a ./=. b = cond a b 1 0 1
a .>=. b = cond a b 0 1 1
a .>.  b = step (a-b)

a .&&. b  = step (a*b)
a .||. b  = step (a+b)
no a      = 1-a
xor a b   = a ./=. b
equiv a b = a .==. b
imp a b   = no a .||. b

taut x = minElement x == 1

minEvery a b = cond a b a a b
maxEvery a b = cond a b b b a

-- examples

clip a b x = cond y b y y b where y = cond x a a x x

disp = putStr . dispf 3

eye n = ident n :: Matrix Double
row = asRow . fromList    :: [Double] -> Matrix Double
col = asColumn . fromList :: [Double] -> Matrix Double

m = (3><4) [1..] :: Matrix Double

p = row [0,0,1,1]
q = row [0,1,0,1]

main = do
    print $ find (>6) m
    disp $ assoc (6,8) 7 $ zip (find (/=0) (eye 5)) [10..]
    disp $ accum (eye 5) (+) [((0,2),3), ((3,1),7), ((1,1),1)]
    disp $ m .>=. 10  .||.  m .<. 4
    (disp . fromColumns . map flatten) [p, q, p.&&.q, p .||.q, p `xor` q, p `equiv` q, p `imp` q]
    print $ taut $ (p `imp` q ) `equiv` (no q `imp` no p)
    print $ taut $ (xor p q) `equiv` (p .&&. no q .||. no p .&&. q)
    disp $ clip 3 8 m
    disp $ col [1..7] .<=. row [1..5]
    disp $ cond (col [1..3]) (row [1..4]) m 50 (3*m)


-- example 3.22

import Statistics.Distribution
import Statistics.Distribution.Poisson

-- three accidents per month means six accidents per two-months:
pd :: PoissonDistribution
pd = poisson 6.0

p :: Int -> Double
p = probability pd

main = do
  putStrLn $ "the mean =   " ++ show (mean pd)
  putStrLn $ "the stdDev = " ++ show (stdDev pd)
  putStrLn $ "the probability of ten accidents in two months: " ++ show (p 10)


{-# LANGUAGE NamedFieldPuns #-}

module School.Unit.Affine
( affine ) where

import Numeric.LinearAlgebra ((<>), R, add, tr')
import School.Unit.Unit (Unit(..))
import School.Unit.UnitActivation (UnitActivation(..))
import School.Unit.UnitParams (UnitParams(..))
import School.Unit.UnitGradient (UnitGradient(..))
import School.Utils.LinearAlgebra (mapRows, sumRows)

affine :: Unit Double
affine = Unit
  { apply = affineApply
  , deriv = affineDeriv
  }

affineApply :: UnitParams R
            -> UnitActivation R
            -> UnitActivation R
affineApply AffineParams { affineBias, affineWeights }
            (BatchActivation inMatrix) =
  BatchActivation $ mapRows (add affineBias) (inMatrix <> tr' affineWeights)
affineApply _ (ApplyFail msg) = ApplyFail msg
affineApply _ _ = ApplyFail "Failure when applying affine unit"

failure :: String
        -> ( UnitGradient R
           , UnitParams R
           )
failure msg = (GradientFail msg, EmptyParams)

affineDeriv :: UnitParams R
            -> UnitGradient R
            -> UnitActivation R
            -> ( UnitGradient R
               , UnitParams R
               )
affineDeriv AffineParams { affineWeights }
            (BatchGradient inGrad)
            (BatchActivation input) =
  (outGrad, paramDerivs) where
    outGrad = BatchGradient $ inGrad <> affineWeights
    bias = sumRows inGrad
    weights = tr' inGrad <> input
    paramDerivs = AffineParams { affineBias = bias
                               , affineWeights = weights
                               }
affineDeriv _ (GradientFail msg) _ = failure msg
affineDeriv _ _ (ApplyFail msg) = failure msg
affineDeriv _ _ _ = failure "Failure when differentiating affine unit"