module Lib where

import Codec.Picture
import System.Directory
import System.IO
import Data.Array.Repa as R
import Data.Array.Repa.Repr.Vector
import Data.Array.Repa.FFTW
import Data.Complex (Complex(..), realPart, magnitude)
import Prelude as P
import Control.Monad

normalize :: Monad m => Array U DIM2 Double -> m (Array D DIM2 Double)
normalize arr = do
    minn <- foldAllP min 1 arr
    let arrmin = R.map (+ (-minn)) arr
    maxx <- foldAllP max 0 arrmin
    let arrnorm = R.map (/maxx) arrmin
    return arrnorm

myfilter tresh v
    | v < tresh = fromIntegral v * 0.6
    | otherwise = 0

rowFilter :: Monad m => Array D DIM1 Double -> m (Array D DIM1 Double)
rowFilter row = do
    rowComplex <- computeP $ R.map (\x -> x :+ 0 ) row
    let fftF = fft $ rowComplex
        (Z :. w) = extent fftF
        barier = round (fromIntegral w/2)
        filtered = fromListUnboxed (Z :. w) $ (P.map (myfilter barier) [1..w])
        fftFilt = R.zipWith (*) fftF filtered
    ifftF <- fmap ifft $ computeP fftFilt
    return $ R.map realPart ifftF

getRow :: Array D DIM2 Double -> Int -> Array D DIM1 Double
getRow array n = slice array (Any :. n :. All)

mapRows :: Monad m => (Array D DIM1 Double -> m (Array D DIM1 Double)) -> Array D DIM2 Double -> m (Array U DIM2 Double)
mapRows func array = do
    let (Z :. w :. h) = extent array
    rows <- mapM (\num -> do
        let row = getRow array num
        func row) [0,1..(w-1)]
    let hugeRow = toList $ foldr1 append rows
    return $ fromListUnboxed (Z :. w :. h) hugeRow

reconstruct :: Array D DIM2 Double -> Double -> Int -> IO ()
reconstruct img p orgW = do
    let (Z :. w :. h) = extent img
        angleStep = pi / fromIntegral h
        anglesList = takeWhile (<pi) [a * angleStep | a <- [0..]]
        orgWNum = fromIntegral orgW

        listOfIndicies (x, y) = let
            list = P.map (\a -> round $ (x * sin a + y * cos a)/p + orgWNum/2) anglesList
            list_zip = zip list [0..(h-1)]
            in [(a,b) | (a,b) <- list_zip, a >= 0, a < w]

        render (x, y) = let
            list = listOfIndicies (x, y)
            pixelList = P.map (\(p, h) -> img ! (Z :. p :. h)) list
            pixelSum = sum pixelList
            avg = pixelSum / (fromIntegral $ length pixelList)
            in if avg > 0 then avg else 0

    let imageIndicies = [orgWNum/(-2)..orgWNum/2-1]
        img' = fromListUnboxed (Z :. orgW :. orgW) (P.map render [(a,b) | a <- imageIndicies , b <- imageIndicies])
    img <- normalize img'
    writePng "res/reconstruct.png" $ generateImage (\x y -> dToPx (img ! (Z :. x :. y))) orgW orgW

getY a p r x = (x, round ((p - (fromIntegral (x - r) * (cos a))) / (sin a)) + r)
getX a p r y = (round ((p - (fromIntegral (y - r) * (sin a))) / (cos a)) + r, y)

filterCoords r (x, y) = ((fromIntegral x - r)**2 + (fromIntegral y - r)**2) < r**2

getLineAvg :: Double -> Double -> Int -> (Double -> Double -> Int -> Int -> (Int, Int)) -> Array U DIM2 Double -> Double
getLineAvg a p w getCoord img =
    let pixelList = P.map (getCoord a p (div w 2)) [0..w-1]
        r = (fromIntegral w) / 2
        pixelList' = filter (filterCoords r) pixelList
        len = length pixelList'
        ret = (sum $ P.map (\(x, y) -> img ! (Z :. x :. y)) pixelList') / fromIntegral len
    in if isNaN ret then 0 else ret

getDetectorValue :: Double -> Double -> Int -> Array U DIM2 Double -> Double
getDetectorValue a p w img
    | a < pi/4 || a > (3 * pi)/4 = getLineAvg a p w getX img
    | otherwise = getLineAvg a p w getY img

processImage :: String -> Int -> Int -> Int -> IO ()
processImage fname nsteps nrays opening' = do
    (w, h, img) <- imageToArray fname
    putStrLn "Image loaded"
    let opening = (fromIntegral opening'/ 180) * pi
        r = fromIntegral w/2
        tresh = sin (opening/2) * r
        p = (sin (opening/2) * r) * 2 / (fromIntegral nrays)
        step = pi / fromIntegral nsteps
        angle = takeWhile (<pi) [x * step | x <- [0..]]
    putStrLn "Calculating projections"
    let listOfP = P.map (\v -> ((fromIntegral v) * p) - tresh) [0..nrays-1]
        rest = P.map (\a -> P.map (\p -> getDetectorValue a p w img) listOfP) angle
        trans = fromListUnboxed (Z :. length rest :. length (head rest)) $ concat $ rest
        trans' = transpose trans
    x <- computeUnboxedP trans'
    nofilter <- normalize x
    arraySaveToImage nofilter "nofilter"
    result' <- mapRows rowFilter nofilter
    result <- normalize result'
    arraySaveToImage result "filter"
    reconstruct result p w

dToPx x
    | x < 0 = PixelYA8 0 255
    | x > 1 = PixelYA8 255 255
    | otherwise = PixelYA8 (round (x * 255)) 255

arraySaveToImage :: Array D DIM2 Double -> String -> IO ()
arraySaveToImage arr fname = do
    let (Z :. w :. h) = extent arr
    writePng ("res/" P.++ fname P.++ ".png") $ generateImage (\x y -> dToPx $ arr ! (Z :. x :. y)) w h

rgbToGrey :: PixelRGB8 -> Double
rgbToGrey (PixelRGB8 r g b) =
  let rgb = P.zipWith (*) [0.2126, 0.7152, 0.0722] $ P.map (fromIntegral) [r, g, b]
  in fromInteger . round . sum $ rgb :: Double

imageToArray :: String -> IO (Int, Int, Array U DIM2 Double)
imageToArray fname = do
    Right imgRGB <- readImage fname
    let (imgGray@(Image w h _)) = convertRGB8 imgRGB
        arr = fromFunction (Z :. w :. h) (\(Z :. x :. y) -> rgbToGrey $ pixelAt imgGray x y)
    img <- computeUnboxedP arr
    return (w, h, img)


{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE BangPatterns #-}
{- # OPTIONS_GHC -ddump-simpl # -}
module Img where

import Data.Complex
import Data.Colour.SRGB
import qualified Data.ByteString.Lazy as BS

import Codec.Picture

import RNA

-- Functional evaluator

-- more efficient than Data.Fixed.fmod (I believe)
foreign import ccall unsafe "math.h fmod" c_fmod :: Double -> Double -> Double

fmod :: Double -> Double -> Double
x `fmod` y =
  let z = c_fmod x y in
  if z < 0 then z + y else z

data C = C {-# UNPACK #-} !Double {-# UNPACK #-} !Double {-# UNPACK #-} !Double

type Img = Complex Double -> Maybe C
type Pattern = Complex Double -> C

toImg :: RNA -> Img
toImg r pos =
    if magnitude pos > 1.0
    then Nothing
    else Just (i pos)
  where
    i = go r

tween :: Double -> C -> C -> C
tween x (C a1 b1 c1) (C a2 b2 c2) = C
  ((1 - x) * a1 + x * a2)
  ((1 - x) * b1 + x * b2)
  ((1 - x) * c1 + x * c2)

go :: RNA -> Pattern
go _ (!_pos) | False = undefined

go (Solid color) _pos = C r g b
  where
    RGB r g b = color

go Blend{} _pos = error "blend"

go (Checker x r1 r2) pos = do
    let !(tmpx :+ tmpy) = realToFrac x * ((1.0 :+ 0.0) + pos)
    if abs ((tmpx + 1) `fmod` 2 - 1) + abs (tmpy `fmod` 2 - 1) < 1
      then i2 pos
      else i1 pos
  where
    i1 = go r1
    i2 = go r2

go (Rotate x r1) pos = do
    let p' = phase pos + x
    let pos' = mkPolar (magnitude pos) p'
    i1 pos'
  where
    i1 = go r1

go (Invert r1) pos = do
    let mag = magnitude pos
    let mag' = 1 - mag
    let pos' = mkPolar mag' (phase pos)
    i1 pos'
  where
    i1 = go r1

go (Swirl x r1) pos = do
    let mag = magnitude pos
    let phase' = phase pos + (1.0 - mag) * x
    let pos' = mkPolar mag phase'
    i1 pos'
  where
    i1 = go r1

go (Dilated r r1) pos = do
    let p = phase pos
    let mag = magnitude pos
    let phase' = p + 1/fromIntegral r * sin (p * fromIntegral r)
    let pos' = mkPolar mag phase'
    i1 pos'
  where
    i1 = go r1

go (Rays r r1 r2) pos =
    if (phase pos / pi * fromIntegral r + 0.5) `fmod` 2 < 1
    then i2 pos
    else i1 pos
  where
    i1 = go r1
    i2 = go r2

go (Gradient r1 r2) pos =
    tween (magnitude pos) (i1 pos) (i2 pos)
  where
    i1 = go r1
    i2 = go r2

go (Ontop x r1 r2) pos = do
    let pos1 = realToFrac (1/x) * pos
    if magnitude pos < x
    then i1 pos1 else i2 pos
  where
    i1 = go r1
    i2 = go r2

img2Png :: Img -> BS.ByteString
img2Png i = encodePng $ generateImage colorAt w h
  where
    w = 1000
    h = 1000
    colorAt :: Int -> Int -> PixelRGBA8
    colorAt x y = do
      let x' = 2 * fromIntegral x / fromIntegral w - 1
      let y' = 2 * fromIntegral y / fromIntegral h - 1
      case i (y' :+ x') of
        Nothing -> PixelRGBA8 0 0 0 0
        Just (C r g b) -> PixelRGBA8 (clamp r) (clamp g) (clamp b) 255

    clamp :: Double -> Pixel8
    clamp = fromIntegral . max (0::Int) . min 255 . round . (* 256)


{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}

module Year2021.Day11 where

import Safe
import Numeric.LinearAlgebra
import System.FilePath

run :: Matrix Z -> Matrix Z
run grid = findJust ((<= 9) . maxElement) $ iterate f (grid + 1) where
  f grid = (grid + conv) * cond grid 0 1 0 1 * cond grid 9 1 1 0 where
    conv = conv2 (konst 1 (3, 3)) (cond grid 9 0 0 1)
      ?? (Drop 1, Drop 1) ?? (DropLast 1, DropLast 1)

part1, part2 :: [Matrix Z] -> Z
part1 = sum . map (sumElements . (1 -) . step) . take 100 . tail
part2 = fromIntegral . findIndexJust ((== 0) . sumElements)

main = readFile (replaceExtension __FILE__ ".in") >>=
  print . part2 . iterate run . fromLists . map (map (read . pure)) . lines


{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

{-# LANGUAGE CPP                 #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeOperators       #-}

module Test.Grenade.Layers.LeakyRelu where

import           Data.Proxy

import           GHC.TypeLits

import           Grenade.Core
import           Grenade.Layers.LeakyRelu

import qualified Numeric.LinearAlgebra        as LA
import           Numeric.LinearAlgebra.Static (L)
import qualified Numeric.LinearAlgebra.Static as H

import           Hedgehog
import qualified Hedgehog.Range               as Range

import           Test.Hedgehog.Compat
import           Test.Hedgehog.Hmatrix

prop_leaky_relu_correct_on_one_element = property $ do
  input :: S ('D1 1) <- forAll genOfShape
  alpha              <- forAll $ genRealNum (Range.constant 0 0.9)

  let layer   = LeakyRelu alpha :: LeakyRelu
      S1D out = snd $ runForwards layer input :: S ('D1 1)
      x       = (\(S1D a) -> H.extract a LA.! 0) input

  H.extract out LA.! 0 === if x >= 0 then x else x * alpha

prop_leaky_relu_correct_on_3D_array = property $ do
  height   :: Int <- forAll $ choose 2 100
  width    :: Int <- forAll $ choose 2 100
  channels :: Int <- forAll $ choose 2 100
  alpha           <- forAll $ genRealNum (Range.constant 0 0.9)

  case (someNatVal (fromIntegral height), someNatVal (fromIntegral width), someNatVal (fromIntegral channels)) of
    (Just (SomeNat (Proxy :: Proxy h)), Just (SomeNat (Proxy :: Proxy w)), Just (SomeNat (Proxy :: Proxy c))) -> do
      input :: S ('D3 h w c) <- forAll genOfShape

      let layer    = LeakyRelu alpha :: LeakyRelu
          S3D out  = snd $ runForwards layer input :: S ('D3 h w c)
          inp' = (\(S3D x) -> H.dmmap (\a -> if a >= 0 then a else a * alpha) x) input :: L (h * c) w

      H.extract inp' === H.extract out

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


module Trade.Example.Correlation where

import Control.Applicative (liftA2)

import qualified Data.Set as Set

import qualified Data.Map as Map
import Data.Map (Map)

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

import qualified Data.ByteString.Lazy.Char8 as BSL

import Data.Time.Clock (getCurrentTime)

import qualified Statistics.Sample as Sample

import Trade.Type.BarLength (BarLength(..))

import Trade.Type.OHLC (Close(..))

import qualified Trade.Timeseries.Binance.Binance as Bin
import qualified Trade.Timeseries.Binance.Database as Bin
import qualified Trade.Timeseries.Binance.Interval as Bin
import qualified Trade.Timeseries.Binance.Symbol as Bin

import qualified Trade.Report.Heatmap as Heat

import Trade.Report.HtmlReader (render)

barLength :: BarLength
barLength = Min 1

ts :: [Bin.Symbol]
-- ts = map Bin.ETH [ Bin.ADAETH .. Bin.ZRXETH]
ts = map Bin.ETH [ Bin.BNBETH, Bin.ENJETH, Bin.HOTETH, Bin.FUELETH, Bin.XRPETH, Bin.ADAETH, Bin.EOSETH, Bin.VETETH, Bin.TRXETH, Bin.DENTETH]

getSymbols :: [Bin.Symbol] -> IO (Map Bin.Symbol (Vector Double))
getSymbols syms = do

  now <- getCurrentTime

  let req sym = Bin.RequestParams {
        Bin.baseUrl = Bin.binanceBaseUrl
        , Bin.symbol = sym
        , Bin.interval = Bin.Interval barLength
        , Bin.limit = Just 1000
        , Bin.from = Nothing
        , Bin.to = Just now
        }

      toSignal row = (Bin.toDate row, unClose (Bin.close row))

  tickers <- fmap (fmap (Vec.map toSignal)) (Bin.getTickers req syms)

  let
      tmsTickers = fmap (Set.fromList . Vec.toList . Vec.map fst) tickers
      allTimes = foldMap id tmsTickers
      tms = Map.foldr (\vs acc -> Set.intersection acc vs) allTimes tmsTickers

      res = fmap (Vec.map snd . Vec.filter ((`Set.member` tms) . fst)) tickers

 -- error (show res)
  return res

example :: IO ()
example = do
  ms <- getSymbols ts

  let xs = Map.toList ms
      f (Bin.ETH u, us) (Bin.ETH v, vs) = ((u, v), Sample.correlation (Vec.zip us vs))
      as = filter (\((x, y), _) -> x /= y) (liftA2 f xs xs)

  t <- render (Heat.heatmap 0 (fmap Just (Map.fromList as)))

  BSL.putStrLn t


{-# LANGUAGE Rank2Types, FlexibleContexts #-}
module Numeric.AD.Lagrangian.Internal where
import Numeric.Optimization.Algorithms.HagerZhang05
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Storable as S
import Numeric.AD
import GHC.IO                   (unsafePerformIO)
import Numeric.AD.Types
import Numeric.AD.Internal.Classes
import Numeric.LinearAlgebra.Algorithms
import qualified Data.Packed.Vector as V
import qualified Data.Packed.Matrix as M
import Numeric.AD.Internal.Tower

infixr 1 <=>
-- | Build a 'Constraint' from a function and a constant
(<=>) :: (forall s r. (Mode s, Mode r) => [AD2 s r a] -> AD2 s r a) -> a -> Constraint a
g <=> c = (FU g,c)

-- | A constraint of the form @g(x, y, ...) = c@. See '<=>' for constructing a 'Constraint'.
type Constraint a = (FU a, a)

type AD2 s r a = AD s (AD r a)

-- | A newtype wrapper for working with the rank 2 types constraint functions.
newtype FU a = FU {unFU :: forall s r. (Mode s, Mode r) => [AD2 s r a] -> AD2 s r a}

-- | This is the lagrangian multiplier solver. It is assumed that the
--   objective function and all of the constraints take in the
--   same amount of arguments.
minimize :: Double
      -> (forall s r. (Mode s, Mode r) => [AD2 s r Double] -> AD2 s r Double)
        -- ^ The function to minimize
      -> [Constraint Double]
      -- ^ The constraints as pairs @g \<=\> c@ which represent equations
      --   of the form @g(x, y, ...) = c@
      -> Int
      -- ^ The arity of the objective function which should equal the arity of
      --   the constraints.
      -> Either (Result, Statistics) (S.Vector Double, S.Vector Double)
      -- ^ Either an explanation of why the gradient descent failed or a pair
      --   containing the arguments at the minimum and the lagrange multipliers
minimize tolerance toMin constraints argCount = result where
    -- The function to minimize for the langrangian is the squared gradient
    obj argsAndLams =
        squaredGrad (lagrangian toMin constraints argCount) argsAndLams

    constraintCount = length constraints

    -- perhaps this should be exposed
    guess = U.replicate (argCount + constraintCount) (1.0 :: Double)

    result = case unsafePerformIO $
                    optimize
                        (defaultParameters { printFinal = False })
                        tolerance
                        guess
                        (VFunction (lowerFU obj . U.toList))
                        (VGradient (U.fromList . grad obj . U.toList))
                        Nothing of
       (vs, ToleranceStatisfied, _) -> Right (S.take argCount vs,
                                              S.drop argCount vs)
       (_, x, y) -> Left (x, y)

-- | Finding the maximum is the same as the minimum with the objective function inverted
maximize :: Double
      -> (forall s r. (Mode s, Mode r) => [AD2 s r Double] -> AD2 s r Double)
        -- ^ The function to maximize
      -> [Constraint Double]
      -- ^ The constraints as pairs @g \<=\> c@ which represent equations
      --   of the form @g(x, y, ...) = c@
      -> Int
      -- ^ The arity of the objective function which should equal the arity of
      --   the constraints.
      -> Either (Result, Statistics) (S.Vector Double, S.Vector Double)
      -- ^ Either an explanation of why the gradient descent failed or a pair
      --   containing the arguments at the minimum and the lagrange multipliers
maximize tolerance toMax constraints argCount =
    minimize tolerance (negate1 . toMax) constraints argCount

lagrangian :: (Num a, Mode s, Mode r)
           => (forall s r. (Mode s, Mode r) => [AD2 s r a] -> AD2 s r a)
           -> [Constraint a]
           -> Int
           -> [AD2 s r a]
           -> AD2 s r a
lagrangian f constraints argCount argsAndLams = result where
    args = take argCount argsAndLams
    lams = drop argCount argsAndLams

    -- g(x, y, ...) = c <=> g(x, y, ...) - c = 0
    appliedConstraints = fmap (\(FU f, c) -> f args - (auto . auto) c) constraints

    -- L(x, y, ..., lam0, ...) = f(x, y, ...) + lam0 * (g0 - c0) ...
    result = f args + (sum . zipWith (*) lams $ appliedConstraints)

squaredGrad :: Num a
            => (forall s. Mode s => [AD s a] -> AD s a)
            -> [a] -> a
squaredGrad f vs = sum . fmap (\x -> x*x) . grad f $ vs

-- | WARNING. Experimental.
--   This is not a true feasibility test for the function. I am not sure
--   exactly how to implement that. This just checks the feasiblility at a point.
--   If this ever returns false, 'solve' can fail.
feasible :: (forall s r. (Mode s, Mode r) => [AD2 s r Double] -> AD2 s r Double)
         -> [Constraint Double]
         -> [Double]
         -> Bool
feasible toMin constraints points = result where
    obj argsAndLams =
        squaredGrad (lagrangian toMin constraints $ length points) argsAndLams

    hessianMatrix = M.fromLists . hessian obj $ points

    -- make sure all of the eigenvalues are positive
    result = all (>0) . V.toList . eigenvaluesSH $ hessianMatrix


{-# LANGUAGE ScopedTypeVariables #-}

module Main (main) where

import Control.Monad.IO.Class (liftIO)
import Data.Complex
import Text.PrettyPrint.Mainland
import Text.PrettyPrint.Mainland.Class

import Spiral
import Spiral.Config
import Spiral.Exp
import Spiral.SPL

main :: IO ()
main = defaultMain $ \_args ->
    genTransform (text "Page 35") $ (I 5 ⊗ F2) × Pi (L 10 5)

genTransform :: Doc -> SPL (Exp (Complex Double)) -> Spiral ()
genTransform doc t = do
    liftIO $ putDocLn $ doc </> ppr t
    useComplex <- asksConfig (testDynFlag UseComplex)
    if useComplex
      then codegenC "t" t
      else codegenC "t" (Re t)


module STCR2Z2T0S0PointSet where

import           Data.Array.Repa         as R
import           Data.Binary             (decodeFile)
import           Data.Complex
import           Data.List               as L
import           DFT.Plan
import           FokkerPlanck.MonteCarlo
import           FokkerPlanck.Pinwheel
import           Image.IO
import           STC.PowerMethod
import           System.Directory
import           System.Environment
import           System.FilePath
import           Types
import Text.Printf

main = do
  args@(numPointStr:numOrientationStr:numScaleStr:thetaSigmaStr:scaleSigmaStr:maxScaleStr:taoStr:numTrailStr:maxTrailStr:theta0FreqsStr:thetaFreqsStr:scale0FreqsStr:scaleFreqsStr:histFilePath:numIterationStr:writeSourceFlagStr:rStr:numThreadStr:_) <-
    getArgs
  print args
  let numPoint = read numPointStr :: Int
      numOrientation = read numOrientationStr :: Int
      numScale = read numScaleStr :: Int
      thetaSigma = read thetaSigmaStr :: Double
      scaleSigma = read scaleSigmaStr :: Double
      maxScale = read maxScaleStr :: Double
      tao = read taoStr :: Double
      numTrail = read numTrailStr :: Int
      maxTrail = read maxTrailStr :: Int
      theta0Freq = read theta0FreqsStr :: Double
      theta0Freqs = [-theta0Freq .. theta0Freq]
      thetaFreq = read thetaFreqsStr :: Double
      thetaFreqs = [-thetaFreq .. thetaFreq]
      scale0Freq = read scale0FreqsStr :: Double
      scaleFreq = read scaleFreqsStr :: Double
      scale0Freqs = [-scale0Freq .. scale0Freq]
      scaleFreqs = [-scaleFreq .. scaleFreq]
      numIteration = read numIterationStr :: Int
      writeSourceFlag = read writeSourceFlagStr :: Bool
      numThread = read numThreadStr :: Int
      folderPath = "output/test/STCR2Z2T0S0PointSet"
  createDirectoryIfMissing True folderPath
  flag <- doesFileExist histFilePath
  radialArr <-
    if flag
      then R.map magnitude . getNormalizedHistogramArr <$>
           decodeFile histFilePath
      else do
        putStrLn "Couldn't find a Green's function data. Start simulation..."
        solveMonteCarloR2Z2T0S0Radial
          numThread
          numTrail
          maxTrail
          numPoint
          numPoint
          thetaSigma
          scaleSigma
          maxScale
          tao
          theta0Freqs
          thetaFreqs
          scale0Freqs
          scaleFreqs
          histFilePath
          (emptyHistogram
             [ (round . sqrt . fromIntegral $ 2 * (div numPoint 2) ^ 2)
             , L.length scale0Freqs
             , L.length theta0Freqs
             , L.length scaleFreqs
             , L.length thetaFreqs
             ]
             0)
  arrR2Z2T0S0 <-
    computeUnboxedP $
    computeR2Z2T0S0ArrayRadial
      (cutoff 8 radialArr)
      numPoint
      numPoint
      1
      maxScale
      thetaFreqs
      scaleFreqs
      theta0Freqs
      scale0Freqs
  plan <- makeR2Z2T0S0Plan emptyPlan arrR2Z2T0S0
  let n = 30
      m = round $ (fromIntegral n) * (sqrt 2) / 2
      a = 20
      b = 7
      c = 50
      a' = round $ (fromIntegral a) * (sqrt 2) / 2
      b' = round $ (fromIntegral b) * (sqrt 2) / 2
      c' = round $ (fromIntegral c) * (sqrt 2) / 2
      r = read rStr :: Double
      numTheta = 8
      deltaTheta = (2 * pi) / numTheta
      xs = -- [R2S1RPPoint (i,0,0,1) | i <- [-30,-20..30]]
        -- ((L.map
        --     (\(i, j) -> R2S1RPPoint (round i, round j, 0, 1))
        --     [ (r * cos (k * deltaTheta) + 0, r * sin (k * deltaTheta) + 0)
        --     | k <- [0 .. numTheta-1]
        --     ]) -- L.++
         -- (L.map
         --    (\(i, j) -> R2S1RPPoint (round i, round j, 0, 1))
         --    [ ((r + 2) * cos (k * deltaTheta), (r + 2) * sin (k * deltaTheta))
         --    | k <- [0 .. numTheta - 1]
         --    ]) L.++
         -- (L.map
         --    (\(i, j) -> R2S1RPPoint (round i, round j, 0, 1))
         --    [ ( (r + 5) * cos (k * deltaTheta)
         --      , (r + 5) * sin (k * deltaTheta))
         --    | k <- [0 .. numTheta - 1]
         --    ])
               -- L.++ [R2S1RPPoint (3, 5, 0, 1)]
         -- )
               ([R2S1RPPoint (i, i, 0, 0) | i <- [a',a' + b' .. c']] L.++
                [R2S1RPPoint (i, -i, 0, 0) | i <- [-a',-(a' + b') .. -c']] L.++
                [R2S1RPPoint (i, i, 0, 0) | i <- [-a',-(a' + b') .. -c']] L.++
                [R2S1RPPoint (i, -i, 0, 0) | i <- [a',a' + b' .. c']] L.++
                [R2S1RPPoint (i, 0, 0, 0) | i <- [a,a + b .. c]] L.++
                [R2S1RPPoint (0, i, 0, 0) | i <- [-a,-(a + b) .. -c]] L.++
                [R2S1RPPoint (i, 0, 0, 0) | i <- [-a,-(a + b) .. -c]] L.++
                [R2S1RPPoint (0, i, 0, 0) | i <- [a,a + b .. c]] -- L.++
                -- [R2S1RPPoint (3, 5, 0, 1)]
               )
                -- [ r2s1rppoint (n, 0, 0, 1)
                -- , R2S1RPPoint (0, n, 0, 1)
                -- , R2S1RPPoint (-n, 0, 0, 1)
                -- , R2S1RPPoint (0, -n, 0, 1)
                -- , R2S1RPPoint (m, m, 0, 1)
                -- , R2S1RPPoint (-m, m, 0, 1)
                -- , R2S1RPPoint (m, -m, 0, 1)
                -- , R2S1RPPoint (-m, -m, 0, 1)
                -- ]
  let bias = computeBiasR2T0S0 numPoint numPoint theta0Freqs scale0Freqs xs
      eigenVec =
        computeInitialEigenVectorR2T0S0
          numPoint
          numPoint
          theta0Freqs
          scale0Freqs
          thetaFreqs
          scaleFreqs
          xs
  powerMethodR2Z2T0S0Reversal
    plan
    folderPath
    numPoint
    numPoint
    numOrientation
    thetaFreqs
    theta0Freqs
    numScale
    scaleFreqs
    scale0Freqs
    arrR2Z2T0S0
    numIteration
    writeSourceFlag
    -- (printf "_%d" (round r :: Int))
    (printf
       "_%d_%d_%d_%d_%d_%.2f_%.2f"
       numPoint
       (round thetaFreq :: Int)
       (round scaleFreq :: Int)
       (round maxScale :: Int)
       (round tao :: Int)
       thetaSigma
       scaleSigma)
    0.5
    0.001
    bias
    eigenVec


-- | Functionality for graphing 2-dimensional matrices.
module System.Console.Ansigraph.Internal.Matrix (
    matShow
  , displayMat
  , displayCMat
) where

import System.Console.Ansigraph.Internal.Core

import Data.Complex
import Data.List (intersperse)
import Control.Monad.IO.Class (MonadIO, liftIO)
-- for GHC <= 7.8
import Control.Applicative

---- Matrices ----

mmap :: (a -> b) -> [[a]] -> [[b]]
mmap = map . map

mmax :: (Num a, Ord a) => [[a]] -> a
mmax = maximum . map maximum . mmap abs

densityChars = "█▓▒░"

densityVals :: [Double]
densityVals = (+ 0.125) . (/4) <$> [3,2,1,0]
         -- = [7/8, 5/8, 3/8, 1/8]

blocks :: [(Double,Char)]
blocks = zip densityVals densityChars

data MatElement = MatElement !Bool {-# UNPACK #-} !Char

elemChar :: MatElement -> Char
elemChar (MatElement _ c) = c

putRealElement :: MonadIO m => GraphSettings -> MatElement -> m ()
putRealElement s (MatElement b c) = colorStr clring (c : " ")
  where clr    = if b then realNegColor s else realColor s
        clring = mkColoring clr (realBG s)

putImagElement :: MonadIO m => GraphSettings -> MatElement -> m ()
putImagElement s (MatElement b c) = colorStr clring $ c : " "
  where clr    = if b then imagNegColor s else imagColor s
        clring = mkColoring clr (imagBG s)

selectMatElement :: Double -> MatElement
selectMatElement x = let l = filter (\p -> fst p < abs x) blocks in case l of
  []    -> MatElement False   ' '
  (p:_) -> MatElement (x < 0) (snd p)

matElements :: [[Double]] -> [[MatElement]]
matElements m = let mx = mmax m
                in  mmap (selectMatElement . (/ mx)) m

-- | Given a matrix of Doubles, return the list of strings illustrating the absolute value
--   of each entry relative to the largest, via unicode chars that denote a particular density.
--   Used for testing purposes.
matShow :: [[Double]] -> [String]
matShow = mmap elemChar . matElements

newline = putStrLn' ""

intersperse' x l = intersperse x l ++ [x]

-- | Use ANSI coloring (specified by an 'GraphSettings') to visually display a Real matrix.
displayMat :: MonadIO m => GraphSettings -> [[Double]] -> m ()
displayMat s = liftIO . sequence_ . concat . intersperse' [newline] . displayRealMat s

-- | Use ANSI coloring (specified by a 'GraphSettings') to visually display a Real matrix.
displayRealMat :: MonadIO m => GraphSettings -> [[Double]] -> [[m ()]]
displayRealMat s = mmap (putRealElement s) . matElements

-- | Use ANSI coloring (specified by a 'GraphSettings') to visually display a Real matrix.
displayImagMat :: MonadIO m => GraphSettings -> [[Double]] -> [[m ()]]
displayImagMat s = mmap (putImagElement s) . matElements

-- | Use ANSI coloring (specified by an 'GraphSettings') to visually display a Complex matrix.
displayCMat :: MonadIO m => GraphSettings -> [[Complex Double]] -> m ()
displayCMat s m = liftIO . sequence_ . concat . intersperse' [newline] $
  zipWith (\xs ys -> xs ++ putStr " " : ys)
          (displayRealMat s $ mmap realPart m)
          (displayImagMat s $ mmap imagPart m)


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, BangPatterns #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass, RankNTypes #-}

module Optimizations(
   processVectorsBV
 , fusionOnListFoldl
 , fusionOnListFoldl'
 , fusionOnListFoldr
 , fusedOnListFoldl
 , fusedOnListFoldl'
 , fusionOnStream
 , fusedOnListFoldr
 , fusedOnStream
 , sumOnStream
 , sumOnChan
 , sumOnVector
 , sumOnUnagi
 , sumUsingTasks
             ) where

import Common
import Process

import Data.List as L
import Control.Concurrent.Async
import Control.Concurrent.MVar
import Control.Concurrent (forkIO)
import qualified Data.Vector.Unboxed as BV
import Control.DeepSeq
import Control.Exception.Safe (catch, catchAny, onException, finally, handleAny, bracket
                              , SomeException, throwIO, throw, Exception, MonadMask
                              , withException, displayException)
import Criterion.Main
import Criterion.Main.Options
import Criterion.Types
import Statistics.Types
import Data.Hashable
import System.Random
import qualified Data.Vector.Unboxed as BV
import qualified System.IO.Streams as S
import qualified System.IO.Streams.Combinators as S
import qualified System.IO.Streams.List as S
import qualified System.IO.Streams.Vector as S
import qualified Control.Concurrent.Chan.Unagi as UStream

-- --------------------------------
-- Bench lazy vs strict

-- process-begin
processVectorsBV :: Int -> Int -> Int -> Bool -> Int -> Int
processVectorsBV !seed !vectorDimension !numberOfVectors !useStrictAlgo !lastSum
  = case numberOfVectors of
      0 -> lastSum
      _ -> let bv = randomBV seed vectorDimension
               !h = case useStrictAlgo of
                     True -> slowComputationOnVector bv seed
                     False -> slowComputationOnVector2 bv seed
               !r = processVectorsBV (seed + 1) vectorDimension (numberOfVectors - 1) useStrictAlgo (lastSum + h)
           in r
-- process-end

-- -------------------------------
-- Bench stream fusion

-- fusion-list-begin
fusionOnListFoldl :: [Int] -> Int
fusionOnListFoldl l = L.foldl (+) 0 $ map (* 2) $ filter odd l

fusionOnListFoldl' :: [Int] -> Int
fusionOnListFoldl' l = L.foldl' (+) 0 $ map (* 2) $ filter odd l

fusionOnListFoldr :: [Int] -> Int
fusionOnListFoldr l = L.foldr (+) 0 $ map (* 2) $ filter odd l

fusedCalcOnFoldl :: Int -> Int -> Int
fusedCalcOnFoldl s x
  = case odd x of
      True -> s + (x * 2)
      False -> s
{-# INLINE fusedCalcOnFoldl #-}

fusedCalcOnFoldr :: Int -> Int -> Int
fusedCalcOnFoldr x s = fusedCalcOnFoldl s x
{-# INLINE fusedCalcOnFoldr #-}

fusedOnListFoldl' :: [Int] -> Int
fusedOnListFoldl' l = L.foldl' fusedCalcOnFoldl 0 l

fusedOnListFoldl :: [Int] -> Int
fusedOnListFoldl l = L.foldl fusedCalcOnFoldl 0 l

fusedOnListFoldr :: [Int] -> Int
fusedOnListFoldr l = L.foldr fusedCalcOnFoldr 0 l
-- fusion-list-end

-- fusion-stream-begin
fusionOnStream :: [Int] -> IO Int
fusionOnStream l = do
  inS1 <- S.fromList l
  inS2 <- S.filter odd inS1
  inS3 <- S.map (* 2) inS2
  S.fold (+) 0 inS3

fusedOnStream :: [Int] -> IO Int
fusedOnStream l = do
  inS1 <- S.fromList l
  S.fold fusedCalcOnFoldl 0 inS1
-- fusion-stream-end

-- -----------------------------------
-- Bench channels vs stream vs vector

-- sumOnStream-begin
sumOnStream :: BV.Vector Int -> IO Int
sumOnStream l = do
  inS1 <- S.fromVector l
  S.fold fusedCalcOnFoldl 0 inS1
-- sumOnStream-end

-- sumOnVector-begin
sumOnVector :: BV.Vector Int -> Int
sumOnVector l = BV.foldl' fusedCalcOnFoldl 0 l
-- sumOnVector-end

-- sumOnChan-begin
sumOnChan :: BV.Vector Int -> IO Int
sumOnChan l = do
  ch <- newChan

  (_, r) <- concurrently
              (do BV.mapM_ (writeChan ch) l
                  writeEOFChan ch)
              (sumOnChan' ch 0)
  return r
 where

   sumOnChan' ch !s = do
     mx <- readChan ch
     case mx of
       Nothing -> return s
       Just x -> sumOnChan' ch (fusedCalcOnFoldl s x)
-- sumOnChan-end

-- sumOnUnagi-begin
sumOnUnagi :: BV.Vector Int -> IO Int
sumOnUnagi l = do
  (inCh, outCh) <- UStream.newChan

  (_, r) <- concurrently
              (do BV.mapM_ (\i -> UStream.writeChan inCh (Just i)) l
                  UStream.writeChan inCh Nothing)
              (sumOnChan' outCh 0)
  return r
 where

   sumOnChan' ch !s = do
     mx <- UStream.readChan ch
     case mx of
       Nothing -> return s
       Just x -> sumOnChan' ch (fusedCalcOnFoldl s x)
-- sumOnUnagi-end

-- ---------------------------
-- Threads as Task

-- sumUsingTasks-begin
sumUsingTasks :: BV.Vector Int -> IO Int
sumUsingTasks l = do

  finalResult :: MVar Int <- newEmptyMVar

  currentState :: MVar (Int, Int) <- newEmptyMVar

  nrOfElements <- BV.foldM (\i x -> do forkIO $ sumTask x finalResult currentState
                                       return $ i + 1) 0 l

  putMVar currentState (0, nrOfElements)

  takeMVar finalResult

 where

   sumTask :: Int -> MVar Int -> MVar (Int, Int) -> IO ()
   sumTask x finalResult currentState = do
     (s1, leftSums) <- takeMVar currentState
     let !currentState2@(!s2, !leftSums2) = (fusedCalcOnFoldl s1 x, leftSums - 1)
     case leftSums2 of
       0 -> putMVar finalResult s2
       _ -> putMVar currentState currentState2

-- sumUsingTasks-end


{-# LANGUAGE CPP                   #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RebindableSyntax      #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeSynonymInstances  #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE ViewPatterns          #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module      : Data.Array.Accelerate.Data.Complex
-- Copyright   : [2015..2017] Trevor L. McDonell
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--
-- Complex numbers, stored in the usual C-style array-of-struct representation,
-- for easy interoperability.
--
module Data.Array.Accelerate.Data.Complex (

  -- * Rectangular from
  Complex(..),
  real,
  imag,

  -- * Polar form
  mkPolar,
  cis,
  polar,
  magnitude,
  phase,

  -- * Conjugate
  conjugate,

) where

import Data.Array.Accelerate.Array.Sugar
import Data.Array.Accelerate.Classes
import Data.Array.Accelerate.Data.Functor
import Data.Array.Accelerate.Prelude
import Data.Array.Accelerate.Product
import Data.Array.Accelerate.Smart
import Data.Array.Accelerate.Type

import Prelude                                                      ( ($) )
import Data.Complex                                                 ( Complex(..) )
import qualified Data.Complex                                       as C
import qualified Prelude                                            as P

-- Use an array-of-structs representation for complex numbers. This matches the
-- standard C-style layout, but means that we can define instances only at
-- specific types (not for any type 'a') as we can only have vectors of
-- primitive type.
--

instance Elt (Complex Half) where
  type EltRepr (Complex Half) = V2 Half
  {-# INLINE eltType     #-}
  {-# INLINE [1] toElt   #-}
  {-# INLINE [1] fromElt #-}
  eltType          = TypeRscalar scalarType
  toElt (V2 r i)   = r :+ i
  fromElt (r :+ i) = V2 r i

instance Elt (Complex Float) where
  type EltRepr (Complex Float) = V2 Float
  {-# INLINE eltType     #-}
  {-# INLINE [1] toElt   #-}
  {-# INLINE [1] fromElt #-}
  eltType          = TypeRscalar scalarType
  toElt (V2 r i)   = r :+ i
  fromElt (r :+ i) = V2 r i

instance Elt (Complex Double) where
  type EltRepr (Complex Double) = V2 Double
  {-# INLINE eltType     #-}
  {-# INLINE [1] toElt   #-}
  {-# INLINE [1] fromElt #-}
  eltType          = TypeRscalar scalarType
  toElt (V2 r i)   = r :+ i
  fromElt (r :+ i) = V2 r i

instance Elt (Complex CFloat) where
  type EltRepr (Complex CFloat) = V2 Float
  {-# INLINE eltType     #-}
  {-# INLINE [1] toElt   #-}
  {-# INLINE [1] fromElt #-}
  eltType                        = TypeRscalar scalarType
  toElt (V2 r i)                 = CFloat r :+ CFloat i
  fromElt (CFloat r :+ CFloat i) = V2 r i

instance Elt (Complex CDouble) where
  type EltRepr (Complex CDouble) = V2 Double
  {-# INLINE eltType     #-}
  {-# INLINE [1] toElt   #-}
  {-# INLINE [1] fromElt #-}
  eltType                          = TypeRscalar scalarType
  toElt (V2 r i)                   = CDouble r :+ CDouble i
  fromElt (CDouble r :+ CDouble i) = V2 r i

instance cst a => IsProduct cst (Complex a) where
  type ProdRepr (Complex a) = ProdRepr (a,a)
  fromProd (r :+ i) = fromProd @cst (r,i)
  toProd p          = let (r,i) = toProd @cst p in (r :+ i)
  prod              = prod @cst @(a,a)

instance (Lift Exp a, Elt (Plain a), Elt (Complex (Plain a))) => Lift Exp (Complex a) where
  type Plain (Complex a) = Complex (Plain a)
  lift (r :+ i)          = Exp $ Tuple (NilTup `SnocTup` lift r `SnocTup` lift i)

instance (Elt a, Elt (Complex a)) => Unlift Exp (Complex (Exp a)) where
  unlift e
    = let r     = Exp $ SuccTupIdx ZeroTupIdx `Prj` e
          i     = Exp $ ZeroTupIdx `Prj` e
      in
      r :+ i

instance (Eq a, Elt (Complex a)) => Eq (Complex a) where
  x == y = let r1 :+ c1 = unlift x
               r2 :+ c2 = unlift y
           in  r1 == r2 && c1 == c2
  x /= y = let r1 :+ c1 = unlift x
               r2 :+ c2 = unlift y
           in  r1 /= r2 || c1 /= c2

instance (RealFloat a, Elt (Complex a)) => P.Num (Exp (Complex a)) where
  (+)           = lift2 ((+) :: Complex (Exp a) -> Complex (Exp a) -> Complex (Exp a))
  (-)           = lift2 ((-) :: Complex (Exp a) -> Complex (Exp a) -> Complex (Exp a))
  (*)           = lift2 ((*) :: Complex (Exp a) -> Complex (Exp a) -> Complex (Exp a))
  negate        = lift1 (negate :: Complex (Exp a) -> Complex (Exp a))
  signum z      = if z == 0
                    then z
                    else let x :+ y = unlift z
                             r      = magnitude z
                         in
                         lift (x/r :+ y/r)
  abs z         = lift (magnitude z :+ 0)
  fromInteger n = lift (fromInteger n :+ 0)

instance (RealFloat a, Elt (Complex a)) => P.Fractional (Exp (Complex a)) where
  fromRational x  = lift (fromRational x :+ 0)
  z / z'          = lift ((x*x''+y*y'') / d :+ (y*x''-x*y'') / d)
    where
      x  :+ y   = unlift z
      x' :+ y'  = unlift z'
      --
      x'' = scaleFloat k x'
      y'' = scaleFloat k y'
      k   = - max (exponent x') (exponent y')
      d   = x'*x'' + y'*y''

instance (RealFloat a, Elt (Complex a)) => P.Floating (Exp (Complex a)) where
  pi                      = lift $ pi :+ 0

  exp (unlift -> x :+ y)  = let expx = exp x
                            in  complex $ expx * cos y :+ expx * sin y

  log z                   = lift $ log (magnitude z) :+ phase z

  sqrt z@(unlift -> x :+ y) =
    if z == 0
      then 0
      else lift $ u :+ (y < 0 ? (-v, v))
    where
      (u,v) = unlift (x < 0 ? (lift (v',u'), lift (u',v')))
      v'    = abs y / (u'*2)
      u'    = sqrt ((magnitude z + abs x) / 2)

  x ** y =
    if y == 0 then 1 else
    if x == 0 then if exp_r > 0 then 0 else
                   if exp_r < 0 then lift (inf :+ 0)
                                else lift (nan :+ nan)
              else if isInfinite r || isInfinite i
                     then if exp_r > 0 then lift (inf :+ 0) else
                          if exp_r < 0 then 0
                                       else lift (nan :+ nan)
                     else exp (log x * y)
    where
      r     :+ i  = unlift x
      exp_r :+ _  = unlift y
      --
      inf = 1 / 0
      nan = 0 / 0

  sin (unlift -> x :+ y)  = complex $ sin x * cosh y :+ cos x * sinh y
  cos (unlift -> x :+ y)  = complex $ cos x * cosh y :+ (- sin x * sinh y)
  tan (unlift -> x :+ y)  = (complex $ sinx*coshy :+ cosx*sinhy) / (complex $ cosx*coshy :+ (-sinx*sinhy))
    where
      sinx  = sin x
      cosx  = cos x
      sinhy = sinh y
      coshy = cosh y

  sinh (unlift -> x :+ y) = complex $ cos y * sinh x :+ sin  y * cosh x
  cosh (unlift -> x :+ y) = complex $ cos y * cosh x :+ sin y * sinh x
  tanh (unlift -> x :+ y) = (complex $ cosy*sinhx :+ siny*coshx) / (complex $ cosy*coshx :+ siny*sinhx)
    where
      siny  = sin y
      cosy  = cos y
      sinhx = sinh x
      coshx = cosh x

  asin z@(unlift -> x :+ y) = complex $ y' :+ (-x')
    where
      x' :+ y' = unlift $ log ((complex ((-y):+x)) + sqrt (1 - z*z))

  acos z                    = complex $ y'' :+ (-x'')
    where
      x'' :+ y''  = unlift $ log (z + (complex ((-y') :+ x')))
      x'  :+ y'   = unlift $ sqrt (1 - z*z)

  atan z@(unlift -> x :+ y) = complex $ y' :+ (-x')
    where
      x' :+ y' = unlift $ log ((complex ((1-y):+x)) / sqrt (1+z*z))

  asinh z =  log (z + sqrt (1+z*z))
  acosh z =  log (z + (z+1) * sqrt ((z-1)/(z+1)))
  atanh z =  0.5 * log ((1.0+z) / (1.0-z))

instance (FromIntegral a b, Num b, Elt (Complex b)) => FromIntegral a (Complex b) where
  fromIntegral x = lift (fromIntegral x :+ 0)

-- | @since 1.2.0.0
instance Functor Complex where
  fmap f (unlift -> r :+ i) = lift (f r :+ f i)

-- Helper function to fix the types for lift (ugh)
--
complex :: (Elt a, Elt (Complex a)) => Complex (Exp a) -> Exp (Complex a)
complex = lift

-- | The non-negative magnitude of a complex number
--
magnitude :: (RealFloat a, Elt (Complex a)) => Exp (Complex a) -> Exp a
-- magnitude (unlift -> r :+ i) = sqrt (r*r + i*i)
magnitude (unlift -> r :+ i) = scaleFloat k (sqrt (sqr (scaleFloat mk r) + sqr (scaleFloat mk i)))
  where
    k     = max (exponent r) (exponent i)
    mk    = -k
    sqr z = z * z

-- | The phase of a complex number, in the range @(-'pi', 'pi']@. If the
-- magnitude is zero, then so is the phase.
--
phase :: (RealFloat a, Elt (Complex a)) => Exp (Complex a) -> Exp a
phase z@(unlift -> r :+ i) =
  if z == 0
    then 0
    else atan2 i r

-- | The function 'polar' takes a complex number and returns a (magnitude,
-- phase) pair in canonical form: the magnitude is non-negative, and the phase
-- in the range @(-'pi', 'pi']@; if the magnitude is zero, then so is the phase.
--
polar :: (RealFloat a, Elt (Complex a)) => Exp (Complex a) -> Exp (a,a)
polar z =  lift (magnitude z, phase z)

-- | Form a complex number from polar components of magnitude and phase.
--
#if __GLASGOW_HASKELL__ <= 708
mkPolar :: forall a. (RealFloat a, Elt (Complex a)) => Exp a -> Exp a -> Exp (Complex a)
#else
mkPolar :: forall a. (Floating a,  Elt (Complex a)) => Exp a -> Exp a -> Exp (Complex a)
#endif
mkPolar = lift2 (C.mkPolar :: Exp a -> Exp a -> Complex (Exp a))

-- | @'cis' t@ is a complex value with magnitude @1@ and phase @t@ (modulo
-- @2*'pi'@).
--
#if __GLASGOW_HASKELL__ <= 708
cis :: forall a. (RealFloat a, Elt (Complex a)) => Exp a -> Exp (Complex a)
#else
cis :: forall a. (Floating a,  Elt (Complex a)) => Exp a -> Exp (Complex a)
#endif
cis = lift1 (C.cis :: Exp a -> Complex (Exp a))

-- | Return the real part of a complex number
--
real :: (Elt a, Elt (Complex a)) => Exp (Complex a) -> Exp a
real (unlift -> r :+ _) = r

-- | Return the imaginary part of a complex number
--
imag :: (Elt a, Elt (Complex a)) => Exp (Complex a) -> Exp a
imag (unlift -> _ :+ i) = i

-- | Return the complex conjugate of a complex number, defined as
--
-- > conjugate(Z) = X - iY
--
conjugate :: (Num a, Elt (Complex a)) => Exp (Complex a) -> Exp (Complex a)
conjugate z = lift $ real z :+ (- imag z)


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

import NumHask.Array
import NumHask.Prelude
import Options.Generic
import Perf
import Perf.Analysis
import qualified Data.Matrix as Matrix
import qualified Numeric.LinearAlgebra as H
import qualified Data.Vector as V

data Opts = Opts
  { runs :: Maybe Int -- <?> "number of runs"
  , size :: Maybe Int -- <?> "size of matrix"
  } deriving (Generic, Show)

instance ParseRecord Opts

main :: IO ()
main = do
  o :: Opts <- getRecord "benchmarking numhask array"
  let !n = fromMaybe 1000 (runs o)
  let !sz = fromMaybe 10 (size o)

  _ <- warmup 100

  let aa = [1 ..] :: Array [] '[10, 10] Int
  let ab = [0 ..] :: Array [] '[10, 10] Int

  let ha = (sz H.>< sz) [1 :: H.Z ..]
  let hb = (sz H.>< sz) [1 :: H.Z ..]

  let ma = Matrix.matrix sz sz (\(i, j) -> i + sz * j)
  let mb = Matrix.matrix sz sz (\(i, j) -> i + sz * j)

  let va = [1 ..] :: Array V.Vector '[10, 10] Int
  let vb = [0 ..] :: Array V.Vector '[10, 10] Int

  (tcreatea, aa') <- tickIO $ pure aa
  (tcreateha, ha') <- tickIO $ pure ha
  (tcreatema, ma') <- tickIO $ pure ma
  (tcreateva, va') <- tickIO $ pure va
  (rmmult, _) <- ticks n (NumHask.Array.mmult aa') ab
  (rmmulth, _) <- ticks n (ha' H.<>) hb
  (rmmultm, _) <- ticks n (ma' `Matrix.multStd2`) mb
  (rmmultv, _) <- ticks n (NumHask.Array.mmult va') vb

  writeFile "other/array.md" $ code
    [ "square matrix size: " <> show sz
    , ""
    , "creation"
    , formatInt "hmatrix:" 2 tcreateha
    , formatInt "matrix:" 2 tcreatema
    , formatInt "Array []:" 2 tcreatea
    , formatInt "Array Vector(Boxed):" 2 tcreateva
    , ""
    , "mmult"
    , formatRunHeader
    , ""
    , formatRun "hmatrix" 2 rmmulth
    , formatRun "matrix" 2 rmmultm
    , formatRun "[]" 2 rmmult
    , formatRun "Boxed" 2 rmmultv
    ]

  (rrow, _) <- ticks n (NumHask.Array.row (Proxy :: Proxy 4)) ab
  (rcol, _) <- ticks n (NumHask.Array.col (Proxy :: Proxy 4)) ab
  (runsaferow, _) <- ticks n (NumHask.Array.unsafeRow 0) ab
  (runsafecol, _) <- ticks n (NumHask.Array.unsafeCol 0) ab
  (runsafeindex, _) <- ticks n (NumHask.Array.unsafeIndex ab) [2, 3]
  (rconcat, _) <- ticks n (concatenate (Proxy :: Proxy 2) aa) aa
  (rtranspose, _) <- ticks n NumHask.Array.transpose aa

  writeFile "other/ops.md" $ code
    [ "square matrix size: " <> show sz
    , formatRunHeader
    , ""
    , formatRun "row" 2 rrow
    , formatRun "col" 2 rcol
    , formatRun "unsafeRow" 2 runsaferow
    , formatRun "unsafeCol" 2 runsafecol
    , formatRun "unsafeIndex" 2 runsafeindex
    , formatRun "concat" 2 rconcat
    , formatRun "transpose" 2 rtranspose
    ]

  pure ()


module Math.IRT.Model.OnePLM
  ( OnePLM (..)
  ) where

import Statistics.Distribution

import Math.IRT.Internal.Distribution
import Math.IRT.Internal.LogLikelihood
import Math.IRT.Model.FourPLM ( FourPLM(..) )
import Math.IRT.Model.Generic

data OnePLM = OnePLM { difficulty :: !Double
                     } deriving (Show)

instance Distribution OnePLM where
    cumulative = cumulative . toFourPLM

instance ContDistr OnePLM where
    density    = density . toFourPLM
    quantile _ = error "This shouldn't be needed"

instance DensityDeriv OnePLM where
    densityDeriv = densityDeriv . toFourPLM

instance GenericModel OnePLM where
    fromRasch           = OnePLM
    fromOnePLM          = OnePLM
    fromTwoPLM      _ b = OnePLM b
    fromThreePLM  _ b _ = OnePLM b
    fromFourPLM _ b _ _ = OnePLM b

instance LogLikelihood OnePLM where
    logLikelihood b = logLikelihood b . toFourPLM

toFourPLM :: OnePLM -> FourPLM
toFourPLM (OnePLM sb) = FourPLM 1.7 sb 0.0 1.0


{-|
Module: Numeric.Morpheus
Description: Low-level machine learning auxiliary functions
Copyright: (c) Alexander Ignatyev, 2017
License: BSD-3
Stability: experimental
Portability: POSIX

Purely functional interface to morpheus based on hmatrix. Morpheus library contains a bunch of cache line aware numerical algorithms suitable for using as a low-level primitives to build machine learning applications.

Naive implementations, which do not take into account cache lines, would suffer order of magnitude performance degradation if tried to traverse a row major matrix in column order.

The library functions take into account CPU cache and work well for both row major and column major matrices, as you can see from the benchmark below which measure time for finding indices of max elements for every column and every row in comparison with naive approach:

@
| Benchmark                           | Morheus   | Naive    |
+-------------------------------------+-----------+----------+
| max index in columns - row major    | 0.9077 ms | 12.93 ms |
+-------------------------------------+-----------+----------+
| max index in columns - column major | 0.8778 ms | 1.490 ms |
+-------------------------------------+-----------+----------+
| max index in rows - row major       | 0.8622 ms | 1.504 ms |
+-------------------------------------+-----------+----------+
| max index in rows - column major    | 0.8913 ms | 12.80 ms |
+-------------------------------------+-----------+----------+
@

== Examples

@
import Numeric.LinearAlgebra
import Numeric.Morpheus

a = matrix 5 [
  71, 11, 3,  -9, -7,
  21, -7,  -2,  23, 11,
  -11, 32, 53, -49, 37,
  1,  -24, 78, 90, 17
  ]

main :: IO ()
main = do
  putStrLn "\nNumeric.Morpheus.MatrixReduce functions: "

  putStr "sum of elements of rows: "
  print $ rowSum a

  putStr "product of elements of rows: "
  print $ rowPredicate (*) a

  putStr "max values of columns: "
  print $ fst $ columnMaxIndex a

  putStr "indices of max values of columns: "
  print $ snd $ columnMaxIndex a

  putStrLn "\n\nNumeric.Morpheus.Activation functions: "

  putStrLn "\nSigmoid:"
  disp 3 (sigmoid a)

  putStrLn "ReLu:"
  disp 3 (relu a)

  putStrLn "ReLu gradient:"
  disp 3 (reluGradient a)

  putStrLn "\n\nNumeric.Morpheus.Statistics functions: "

  putStrLn "\nColumn Means:"
  let colmeans = columnMean a
  print colmeans

  putStrLn "Column Standard Deviations: "
  print (columnStddev_m colmeans a)
@
-}

module Numeric.Morpheus
(
  module Numeric.Morpheus.Activation
  , module Numeric.Morpheus.MatrixReduce
  , module Numeric.Morpheus.Statistics
)

where

import Numeric.Morpheus.Activation
import Numeric.Morpheus.MatrixReduce
import Numeric.Morpheus.Statistics


module Parser
  ( readExpr
  ) where

import           Control.Monad.Except
import           Data.Char                     (toLower)
import           Data.Complex                  (Complex (..), realPart)
import           Data.Ratio
import           Eval
import           Numeric                       (readHex, readOct)
import           Prelude                       hiding (toRational)
import           Syntax
import           Text.ParserCombinators.Parsec hiding (spaces)

-- parse toma: Un Parser como primer parametro
--             Un String como nombre de la entrada, para los errores.
--             La entrada
readExpr :: String -> ThrowsError LispVal
readExpr input = case parse parseExpr "lisp" input of
                   Left err -> throwError $ Parser err
                   Right value  -> return value

parseExpr :: Parser LispVal
parseExpr = try parseNumber
            <|> try parseString
            <|> try  parseBool
            <|> try parseCharacter
            <|> try parseAtom
            <|> try parseQuoted
            <|> try parseListLike

-- Parseo de atomos
parseAtom :: Parser LispVal
parseAtom = do first <- letter <|> symbol
               rest  <- many (letter <|> digit <|> symbol)
               let atom = first:rest
               return $ Atom atom

parseBool :: Parser LispVal
parseBool = do _ <- char '#'
               c <- oneOf "tf"
               (return . Bool) $ case c of
                                   't' -> True
                                   'f' -> False
-- Parseo de strings
parseString :: Parser LispVal
parseString = do _ <- char '"'
                 x <- many (parseEscapedChar <|> noneOf ['\\', '"'])
                 _ <- char '"'
                 return (String x)

parseEscapedChar :: Parser Char
parseEscapedChar = do _ <- char '\\'
                      c <- oneOf ['\\', '"', 'n', 'r', 't']
                      return $ case c of
                                 '\\' -> c
                                 '"'  -> c
                                 'n'  -> '\n'
                                 'r'  -> '\r'
                                 't'  -> '\t'

-- Parseo de caracteres
parseCharacter :: Parser LispVal
parseCharacter = do _ <- string "#\\"
                    s <- many letter
                    (return . Character) $ case map toLower s of
                                             "spaces"  -> ' '
                                             ""        -> ' '
                                             "newline" -> '\n'
                                             [x]       -> x

-- Parseo de tipos numericos
parseNumber :: Parser LispVal
parseNumber = try parseComplexNumber
           <|> try parseFloat
           <|> try parseRationalNumber
           <|> try parseInteger

parseInteger :: Parser LispVal
parseInteger = try parseIntWithPrefix <|> try parsePlainInt

parseIntWithPrefix :: Parser LispVal
parseIntWithPrefix = do _ <- char '#'
                        try parseBin <|> try parseDec <|> try parseOct <|> try parseHex

parsePlainInt :: Parser LispVal
parsePlainInt = (Number . read) <$> many1 digit

parseFloat :: Parser LispVal
parseFloat = do int <- many1 digit
                _       <- char '.'
                decimal <- many1 digit
                let number = int ++ "." ++ decimal
                return $ (Float . read) number

-- Toma un numero de lisp y devuelve un numero de haskell
-- asumo que ese numero puede es real (un double)
fromNumber :: LispVal -> Double
fromNumber (Number x)  = fromIntegral x
fromNumber (Float x)    = x
fromNumber (Rational x) = fromRational x
fromNumber (Complex x)  = realPart x

parseComplexNumber :: Parser LispVal
parseComplexNumber = do real <- fromNumber <$> (try parseFloat <|> try parseRationalNumber <|> try parseInteger)
                        _ <- oneOf "+-"
                        imag <- fromNumber <$> (try parseFloat <|> try parseRationalNumber <|> try parseInteger)
                        return $ Complex (real :+ imag)

parseRationalNumber :: Parser LispVal
parseRationalNumber = do p <- read <$> many1 digit
                         _ <- char '/'
                         q <- read <$> many1 digit
                         return $ Rational (p % q)

-- Parseo de numeros en diferentes bases numericas
readBin :: Char -> Int
readBin '0' = 0
readBin '1' = 1

fromBinary :: String -> Int
fromBinary s = sum $ map (\(i,x) -> i*(2^x)) $ zip [0..] $ map readBin (reverse s)

parseBin :: Parser LispVal
parseBin = do _ <- char 'b'
              number <- many1 (oneOf "01")
              return $ (Number . fromBinary) number

parseDec :: Parser LispVal
parseDec = do _ <- char 'd'
              number <- many1 digit
              return $ (Number . read) number

parseOct :: Parser LispVal
parseOct = do _ <- char 'o'
              number <- many1 (oneOf "01234567")
              return $ (Number . fst . head . readOct) number

parseHex :: Parser LispVal
parseHex = do _ <- char 'x'
              number <- many1 (oneOf "0123456789abcdefABCDEF")
              return $ (Number . fst . head . readHex) number

-- Parseo de listas y listas puntuadas
parseListLike :: Parser LispVal
parseListLike = do _ <- char '('
                   x <- try parseList <|> parseDottedList
                   _ <- char ')'
                   return x

-- parsea una serie de expresiones separadas por espacios y luego aplica el constructor List.
parseList :: Parser LispVal
parseList =  List <$> sepBy parseExpr spaces

parseDottedList :: Parser LispVal
parseDottedList = do hd <- endBy parseExpr spaces
                     tl <- char '.' >> spaces >> parseExpr
                     return $ DottedList hd tl

parseQuoted :: Parser LispVal
parseQuoted = do _ <- char '\''
                 x <- parseExpr
                 return $ List [Atom "quote", x]

-- Funciones Auxiliares
-- parser que reconoce uno de los simbolos permitidos
-- en los identificadores de Scheme
symbol :: Parser Char
symbol = oneOf "!#$%&|*+-/:<=>?@^_~"

-- parser que reconoce espacios
spaces :: Parser ()
spaces = skipMany1 space


module Histogram (
  histogram
) where

import qualified Data.Set as Set
import qualified Data.Vector.Generic as VG
import           Data.Vector.Unboxed ((!))
import qualified Statistics.Sample.Histogram as SSH
import           Statistics.Test.ApproxRand
import           Statistics.Types (Sample)

histogram ::
     Int
  -> TestResult
  -> Either String [(Double, Int)]
histogram prefBins (TestResult _ _ randomizedStats)
  | bins < 2  = Left "Cannot make a histogram - data cannot be divided in more than one bin."
  | otherwise = Right $ VG.toList $ VG.zip ticks numSamples
  where
    bins = numBins prefBins randomizedStats
    (lowerBounds, numSamples) =
      SSH.histogram prefBins randomizedStats

    -- Compute the middle values of the bins.
    bucketSize = (lowerBounds ! 1) - (lowerBounds ! 0)
    bucketHalf = bucketSize / 2
    ticks = VG.map ((+) bucketHalf) lowerBounds

numBins :: Int -> Sample -> Int
numBins pref =
  min pref . Set.size . VG.foldl' (flip Set.insert) Set.empty


{-# LANGUAGE CPP                #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable     #-}
{-# LANGUAGE DeriveFunctor      #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE ViewPatterns       #-}
-- |
-- Module    : Statistics.Quantile
-- Copyright : (c) 2009 Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- Functions for approximating quantiles, i.e. points taken at regular
-- intervals from the cumulative distribution function of a random
-- variable.
--
-- The number of quantiles is described below by the variable /q/, so
-- with /q/=4, a 4-quantile (also known as a /quartile/) has 4
-- intervals, and contains 5 points.  The parameter /k/ describes the
-- desired point, where 0 ≤ /k/ ≤ /q/.

module Statistics.Quantile
    (
    -- * Quantile estimation functions
    -- $cont_quantiles
      ContParam(..)
    , Default(..)
    , quantile
    , quantiles
    , quantilesVec
    -- ** Parameters for the continuous sample method
    , cadpw
    , hazen
    , spss
    , s
    , medianUnbiased
    , normalUnbiased
    -- * Other algorithms
    , weightedAvg
    -- * Median & other specializations
    , median
    , mad
    , midspread
    -- * Deprecated
    , continuousBy
    -- * References
    -- $references
    ) where

import           Data.Binary            (Binary)
import           Data.Aeson             (ToJSON,FromJSON)
import           Data.Data              (Data,Typeable)
import           Data.Default.Class
import           Data.Functor
import qualified Data.Foldable        as F
import           Data.Vector.Generic ((!))
import qualified Data.Vector          as V
import qualified Data.Vector.Generic  as G
import qualified Data.Vector.Unboxed  as U
import qualified Data.Vector.Storable as S
import GHC.Generics (Generic)

import Statistics.Function (partialSort)

----------------------------------------------------------------
-- Quantile estimation
----------------------------------------------------------------

-- | O(/n/·log /n/). Estimate the /k/th /q/-quantile of a sample,
-- using the weighted average method. Up to rounding errors it's same
-- as @quantile s@.
--
-- The following properties should hold otherwise an error will be thrown.
--
--   * the length of the input is greater than @0@
--
--   * the input does not contain @NaN@
--
--   * k ≥ 0 and k ≤ q
weightedAvg :: G.Vector v Double =>
               Int        -- ^ /k/, the desired quantile.
            -> Int        -- ^ /q/, the number of quantiles.
            -> v Double   -- ^ /x/, the sample data.
            -> Double
weightedAvg k q x
  | G.any isNaN x   = modErr "weightedAvg" "Sample contains NaNs"
  | n == 0          = modErr "weightedAvg" "Sample is empty"
  | n == 1          = G.head x
  | q < 2           = modErr "weightedAvg" "At least 2 quantiles is needed"
  | k == q          = G.maximum x
  | k >= 0 || k < q = xj + g * (xj1 - xj)
  | otherwise       = modErr "weightedAvg" "Wrong quantile number"
  where
    j   = floor idx
    idx = fromIntegral (n - 1) * fromIntegral k / fromIntegral q
    g   = idx - fromIntegral j
    xj  = sx ! j
    xj1 = sx ! (j+1)
    sx  = partialSort (j+2) x
    n   = G.length x
{-# SPECIALIZE weightedAvg :: Int -> Int -> U.Vector Double -> Double #-}
{-# SPECIALIZE weightedAvg :: Int -> Int -> V.Vector Double -> Double #-}
{-# SPECIALIZE weightedAvg :: Int -> Int -> S.Vector Double -> Double #-}

----------------------------------------------------------------
-- Quantiles continuous algorithm
----------------------------------------------------------------

-- $cont_quantiles
--
-- Below is family of functions which use same algorithm for estimation
-- of sample quantiles. It approximates empirical CDF as continuous
-- piecewise function which interpolates linearly between points
-- \((X_k,p_k)\) where \(X_k\) is k-th order statistics (k-th smallest
-- element) and \(p_k\) is probability corresponding to
-- it. 'ContParam' determines how \(p_k\) is chosen. For more detailed
-- explanation see [Hyndman1996].
--
-- This is the method used by most statistical software, such as R,
-- Mathematica, SPSS, and S.

-- | Parameters /α/ and /β/ to the 'continuousBy' function. Exact
--   meaning of parameters is described in [Hyndman1996] in section
--   \"Piecewise linear functions\"
data ContParam = ContParam {-# UNPACK #-} !Double {-# UNPACK #-} !Double
  deriving (Show,Eq,Ord,Data,Typeable,Generic)

-- | We use 's' as default value which is same as R's default.
instance Default ContParam where
  def = s

instance Binary   ContParam
instance ToJSON   ContParam
instance FromJSON ContParam

-- | O(/n/·log /n/). Estimate the /k/th /q/-quantile of a sample /x/,
--   using the continuous sample method with the given parameters.
--
--   The following properties should hold, otherwise an error will be thrown.
--
--     * input sample must be nonempty
--
--     * the input does not contain @NaN@
--
--     * 0 ≤ k ≤ q
quantile :: G.Vector v Double
         => ContParam  -- ^ Parameters /α/ and /β/.
         -> Int        -- ^ /k/, the desired quantile.
         -> Int        -- ^ /q/, the number of quantiles.
         -> v Double   -- ^ /x/, the sample data.
         -> Double
quantile param q nQ xs
  | nQ < 2         = modErr "continuousBy" "At least 2 quantiles is needed"
  | badQ nQ q      = modErr "continuousBy" "Wrong quantile number"
  | G.any isNaN xs = modErr "continuousBy" "Sample contains NaNs"
  | otherwise      = estimateQuantile sortedXs pk
  where
    pk       = toPk param n q nQ
    sortedXs = psort xs $ floor pk + 1
    n        = G.length xs
{-# INLINABLE quantile #-}
{-# SPECIALIZE
    quantile :: ContParam -> Int -> Int -> U.Vector Double -> Double #-}
{-# SPECIALIZE
    quantile :: ContParam -> Int -> Int -> V.Vector Double -> Double #-}
{-# SPECIALIZE
    quantile :: ContParam -> Int -> Int -> S.Vector Double -> Double #-}

-- | O(/k·n/·log /n/). Estimate set of the /k/th /q/-quantile of a
--   sample /x/, using the continuous sample method with the given
--   parameters. This is faster than calling quantile repeatedly since
--   sample should be sorted only once
--
--   The following properties should hold, otherwise an error will be thrown.
--
--     * input sample must be nonempty
--
--     * the input does not contain @NaN@
--
--     * for every k in set of quantiles 0 ≤ k ≤ q
quantiles :: (G.Vector v Double, F.Foldable f, Functor f)
  => ContParam
  -> f Int
  -> Int
  -> v Double
  -> f Double
quantiles param qs nQ xs
  | nQ < 2             = modErr "quantiles" "At least 2 quantiles is needed"
  | F.any (badQ nQ) qs = modErr "quantiles" "Wrong quantile number"
  | G.any isNaN xs     = modErr "quantiles" "Sample contains NaNs"
  -- Doesn't matter what we put into empty container
  | fnull qs           = 0 <$ qs
  | otherwise          = fmap (estimateQuantile sortedXs) ks'
  where
    ks'      = fmap (\q -> toPk param n q nQ) qs
    sortedXs = psort xs $ floor (F.maximum ks') + 1
    n        = G.length xs
{-# INLINABLE quantiles #-}
{-# SPECIALIZE quantiles
      :: (Functor f, F.Foldable f) => ContParam -> f Int -> Int -> V.Vector Double -> f Double #-}
{-# SPECIALIZE quantiles
      :: (Functor f, F.Foldable f) => ContParam -> f Int -> Int -> U.Vector Double -> f Double #-}
{-# SPECIALIZE quantiles
      :: (Functor f, F.Foldable f) => ContParam -> f Int -> Int -> S.Vector Double -> f Double #-}

-- COMPAT
fnull :: F.Foldable f => f a -> Bool
#if !MIN_VERSION_base(4,8,0)
fnull = F.foldr (\_ _ -> False) True
#else
fnull = null
#endif

-- | O(/k·n/·log /n/). Same as quantiles but uses 'G.Vector' container
--   instead of 'Foldable' one.
quantilesVec :: (G.Vector v Double, G.Vector v Int)
  => ContParam
  -> v Int
  -> Int
  -> v Double
  -> v Double
quantilesVec param qs nQ xs
  | nQ < 2             = modErr "quantilesVec" "At least 2 quantiles is needed"
  | G.any (badQ nQ) qs = modErr "quantilesVec" "Wrong quantile number"
  | G.any isNaN xs     = modErr "quantilesVec" "Sample contains NaNs"
  | G.null qs          = G.empty
  | otherwise          = G.map (estimateQuantile sortedXs) ks'
  where
    ks'      = G.map (\q -> toPk param n q nQ) qs
    sortedXs = psort xs $ floor (G.maximum ks') + 1
    n        = G.length xs
{-# INLINABLE quantilesVec #-}
{-# SPECIALIZE quantilesVec
      :: ContParam -> V.Vector Int -> Int -> V.Vector Double -> V.Vector Double #-}
{-# SPECIALIZE quantilesVec
      :: ContParam -> U.Vector Int -> Int -> U.Vector Double -> U.Vector Double #-}
{-# SPECIALIZE quantilesVec
      :: ContParam -> S.Vector Int -> Int -> S.Vector Double -> S.Vector Double #-}

-- Returns True if quantile number is out of range
badQ :: Int -> Int -> Bool
badQ nQ q = q < 0 || q > nQ

-- Obtain k from equation for p_k [Hyndman1996] p.363.  Note that
-- equation defines p_k for integer k but we calculate it as real
-- value and will use fractional part for linear interpolation. This
-- is correct since equation is linear.
toPk
  :: ContParam
  -> Int        -- ^ /n/ number of elements
  -> Int        -- ^ /k/, the desired quantile.
  -> Int        -- ^ /q/, the number of quantiles.
  -> Double
toPk (ContParam a b) (fromIntegral -> n) q nQ
  = a + p * (n + 1 - a - b)
  where
    p = fromIntegral q / fromIntegral nQ

-- Estimate quantile for given k (including fractional part)
estimateQuantile :: G.Vector v Double => v Double -> Double -> Double
{-# INLINE estimateQuantile #-}
estimateQuantile sortedXs k'
  = (1-g) * item (k-1) + g * item k
  where
    (k,g) = properFraction k'
    item  = (sortedXs !) . clamp
    --
    clamp = max 0 . min (n - 1)
    n     = G.length sortedXs

psort :: G.Vector v Double => v Double -> Int -> v Double
psort xs k = partialSort (max 0 $ min (G.length xs - 1) k) xs
{-# INLINE psort #-}

-- | California Department of Public Works definition, /α/=0, /β/=1.
-- Gives a linear interpolation of the empirical CDF.  This
-- corresponds to method 4 in R and Mathematica.
cadpw :: ContParam
cadpw = ContParam 0 1

-- | Hazen's definition, /α/=0.5, /β/=0.5.  This is claimed to be
-- popular among hydrologists.  This corresponds to method 5 in R and
-- Mathematica.
hazen :: ContParam
hazen = ContParam 0.5 0.5

-- | Definition used by the SPSS statistics application, with /α/=0,
-- /β/=0 (also known as Weibull's definition).  This corresponds to
-- method 6 in R and Mathematica.
spss :: ContParam
spss = ContParam 0 0

-- | Definition used by the S statistics application, with /α/=1,
-- /β/=1.  The interpolation points divide the sample range into @n-1@
-- intervals.  This corresponds to method 7 in R and Mathematica and
-- is default in R.
s :: ContParam
s = ContParam 1 1

-- | Median unbiased definition, /α/=1\/3, /β/=1\/3. The resulting
-- quantile estimates are approximately median unbiased regardless of
-- the distribution of /x/.  This corresponds to method 8 in R and
-- Mathematica.
medianUnbiased :: ContParam
medianUnbiased = ContParam third third
    where third = 1/3

-- | Normal unbiased definition, /α/=3\/8, /β/=3\/8.  An approximately
-- unbiased estimate if the empirical distribution approximates the
-- normal distribution.  This corresponds to method 9 in R and
-- Mathematica.
normalUnbiased :: ContParam
normalUnbiased = ContParam ta ta
    where ta = 3/8

modErr :: String -> String -> a
modErr f err = error $ "Statistics.Quantile." ++ f ++ ": " ++ err

----------------------------------------------------------------
-- Specializations
----------------------------------------------------------------

-- | O(/n/·log /n/) Estimate median of sample
median :: G.Vector v Double
       => ContParam  -- ^ Parameters /α/ and /β/.
       -> v Double   -- ^ /x/, the sample data.
       -> Double
{-# INLINE median #-}
median p = quantile p 1 2

-- | O(/n/·log /n/). Estimate the range between /q/-quantiles 1 and
-- /q/-1 of a sample /x/, using the continuous sample method with the
-- given parameters.
--
-- For instance, the interquartile range (IQR) can be estimated as
-- follows:
--
-- > midspread medianUnbiased 4 (U.fromList [1,1,2,2,3])
-- > ==> 1.333333
midspread :: G.Vector v Double =>
             ContParam  -- ^ Parameters /α/ and /β/.
          -> Int        -- ^ /q/, the number of quantiles.
          -> v Double   -- ^ /x/, the sample data.
          -> Double
midspread param k x
  | G.any isNaN x = modErr "midspread" "Sample contains NaNs"
  | k <= 0        = modErr "midspread" "Nonpositive number of quantiles"
  | otherwise     = let Pair x1 x2 = quantiles param (Pair 1 (k-1)) k x
                    in  x2 - x1
{-# INLINABLE  midspread #-}
{-# SPECIALIZE midspread :: ContParam -> Int -> U.Vector Double -> Double #-}
{-# SPECIALIZE midspread :: ContParam -> Int -> V.Vector Double -> Double #-}
{-# SPECIALIZE midspread :: ContParam -> Int -> S.Vector Double -> Double #-}

data Pair a = Pair !a !a
  deriving (Functor, F.Foldable)

-- | O(/n/·log /n/). Estimate the median absolute deviation (MAD) of a
--   sample /x/ using 'continuousBy'. It's robust estimate of
--   variability in sample and defined as:
--
--   \[
--   MAD = \operatorname{median}(| X_i - \operatorname{median}(X) |)
--   \]
mad :: G.Vector v Double
    => ContParam  -- ^ Parameters /α/ and /β/.
    -> v Double   -- ^ /x/, the sample data.
    -> Double
mad p xs
  = median p $ G.map (abs . subtract med) xs
  where
    med = median p xs
{-# INLINABLE  mad #-}
{-# SPECIALIZE mad :: ContParam -> U.Vector Double -> Double #-}
{-# SPECIALIZE mad :: ContParam -> V.Vector Double -> Double #-}
{-# SPECIALIZE mad :: ContParam -> S.Vector Double -> Double #-}

----------------------------------------------------------------
-- Deprecated
----------------------------------------------------------------

continuousBy :: G.Vector v Double =>
                ContParam  -- ^ Parameters /α/ and /β/.
             -> Int        -- ^ /k/, the desired quantile.
             -> Int        -- ^ /q/, the number of quantiles.
             -> v Double   -- ^ /x/, the sample data.
             -> Double
continuousBy = quantile
{-# DEPRECATED continuousBy "Use quantile instead" #-}

-- $references
--
-- * Weisstein, E.W. Quantile. /MathWorld/.
--   <http://mathworld.wolfram.com/Quantile.html>
--
-- * [Hyndman1996] Hyndman, R.J.; Fan, Y. (1996) Sample quantiles in statistical
--   packages. /American Statistician/
--   50(4):361–365. <http://www.jstor.org/stable/2684934>


module NeuralNet.ExampleSpec (exampleSpec) where

import Test.Hspec
import Numeric.LinearAlgebra
import NeuralNet.Example
import Control.Exception (evaluate)

exampleSpec :: SpecWith ()
exampleSpec =
  describe "NeuralNet.Example" $ do
    describe "createExampleSet" $ do
      it "creates x correctly" $
        let
          examples = [([1, 2, 3], 4), ([5, 6, 7], 8)]
          set = createExampleSet examples
        in exampleSetX set `shouldBe` (fromLists [[1, 5], [2, 6], [3, 7]])

      it "creates y correctly" $
        let
          examples = [([1, 2, 3], 4), ([5, 6, 7], 8)]
          set = createExampleSet examples
        in exampleSetY set `shouldBe` (fromLists [[4, 8]])

      it "throws error for misaligned example sizes" $
        let examples = [([1..10], 4), ([1..2], 8)]
        in evaluate (createExampleSet examples) `shouldThrow` anyErrorCall

      it "throws error for empty example" $
        let examples = [([], 4)]
        in evaluate (createExampleSet examples) `shouldThrow` anyErrorCall

      it "throws error for empty examples" $
        evaluate (createExampleSet []) `shouldThrow` anyErrorCall


{-
  Programa em haskell para gerar Mandelbrot
  Trabalho 1 de Paradigmas de Programação
  Autoria: Natã Schmitt
-}

import Codec.Picture
import Text.Printf ( printf )
import Codec.FFmpeg.Juicy ( imageWriter )
import Codec.FFmpeg.Encode
import System.IO
import System.Exit ( exitFailure, exitSuccess )
import Data.WAVE
import Math.FFT ( dftRC )
import Data.Array.CArray
import qualified Data.Array.IArray
import Data.Complex
import Data.Maybe ( fromMaybe )
import Data.Char ( toLower )
import System.Process ( shell, callCommand )

type CComplex = (Double, Double)

-----------------------------------------------------------
-- Variáveis pré-definidas
-----------------------------------------------------------
musicPath, videoPath, imagesPath :: FilePath
width, height, maxIter, hueOffset, sensitivity, dropped :: Int
coordY, coordX, maxZoom, framerate, fixedZoom :: Double

musicPath = "./mandeloso.wav"
videoPath = "./mandelbrot.mp4"
imagesPath = "./anim/%d.png"

width = 1920          -- largura
height = 1080        -- altura
maxIter = 90        -- numero maximo de iterações
hueOffset = -150       -- caso queira que a cor inicial seja diferente

maxZoom = 1.6519276269095182e16     --Zoom maximo suportado

coordX =  0.36024044343761436323612524444954530848260780795858575048837581474019534605  -- Coordenadas X
coordY = -0.64131306106480317486037501517930206657949495228230525955617754306444857417  -- Coordenadas Y

framerate = 60        -- Framerate do vídeo

sensitivity = 20      -- Sensibilidade ao grave maior = menos sensível

estático :: Bool
estático = False       -- Quando True ele não fará zoom e se manterá estático em fixedZoom

fixedZoom = 17.5        -- Zoom caso estático for True

dropped = 0       -- Se quiser retomar uma animação pelo numero da imagem, use aqui

-----------------------------------------------------------
-- Funções diversas
-----------------------------------------------------------
fst3, snd3, thr :: (a, a, a) -> a
fst3 (x, _, _) = x
snd3 (_, x, _) = x
thr (_, _, x)  = x

genPath :: Int -> FilePath
genPath = printf imagesPath

exitFalha :: String -> IO ()
exitFalha s = do
  a <- putStrLn s
  exitFailure

toFloat :: Int -> Double
toFloat i = fromIntegral i :: Double

status :: Int -> Int -> IO ()
status total n = do
  putStr (printf "\r%.f%%\t- %d/%d Frames" (toFloat n/toFloat total*100) n total)

-----------------------------------------------------------
-- Criação de paletas de cor
-----------------------------------------------------------
filterPallete :: [(Double, Double, Double)] -> [(Pixel8,Pixel8,Pixel8)]
filterPallete = map (\(r,g,b) -> (round r, round g, round b))

laranja, azul, roxo, verde :: [(Pixel8, Pixel8, Pixel8)]
laranja = filterPallete $ zip3 [0..254.0] [0,0.72..184] (replicate 254 0.0)

verde = filterPallete $ zip3 [0,0.46..120] [0..255.0] (replicate 254 0.0)

azul = filterPallete $ zip3 (replicate 254 0.0) (replicate 254 0.0) [0..255.0]

roxo = filterPallete $ zip3 [0..254] (replicate 254 0.0) [0,0.59..150.0]

pallete :: [(Pixel8,Pixel8,Pixel8)]
pallete = azulInOut ++ laranjaInOut ++ verdeInOut ++ roxoInOut
  where laranjaInOut = laranja ++ reverse laranja
        verdeInOut = verde ++ reverse verde
        azulInOut  = azul ++ reverse azul
        roxoInOut  = roxo ++ reverse roxo

palleteR, palleteG, palleteB :: CArray Int Pixel8
(palleteR, palleteG, palleteB) = ( palVec [fst3 x | x <- pallete],
                                   palVec [snd3 x | x <- pallete],
                                   palVec [thr x | x <- pallete]
                                 )

maxi :: Int
maxi = length laranja*2 + length verde*2 + length azul*2 + length roxo*2

-----------------------------------------------------------
-- Cálculo do Mandelbrot
-----------------------------------------------------------
calcPoint :: CComplex -> CComplex -> Int -> (Int, Double)
calcPoint (cx,cy) (zx,zy) iter
  | iter < maxIter && sqrt(zx^2 + zy^2) < 4 = calcPoint (cx,cy) newZ (iter+1)
  | otherwise = (iter, magnitude (zx:+zy) )
  where newZ = (zx^2 - zy^2 + cx , 2*zx*zy + cy)

colorFromIter :: Int -> (Int, Double) -> PixelRGB8
colorFromIter hue iterPoint
  | iter == maxIter = PixelRGB8 0 0 0
  | otherwise = PixelRGB8 (palleteR!i) (palleteG!i) (palleteB!i)
  where (iter,mag) = iterPoint
        i = mod (truncate (color * toFloat maxi)) maxi
        color = toFloat ix / toFloat points -- Entre 0 e 1, representa um ciclo de cores
        ix = truncate (sqrt (toFloat iter + 1 - logBase 2 (logBase 2 mag))*200 + toFloat hue*4 + toFloat hueOffset ) `mod` points
        points = 2048

genIter :: Int -> Int -> Int -> Int -> (Int, Double)
genIter  x y frame db = calcPoint (xPos, yPos) (0,0) 0
  where xPos = (x'-w/2)/size+coordX
        yPos = (y'-h/2)/size+coordY
        (w, h) = (fromIntegral width, fromIntegral height)
        (x', y') = (fromIntegral x, fromIntegral y)
        size = 2** if frame == -1 then fixedZoom else exponent
        exponent = if exp > maxZoom then maxZoom else exp
        exp = fromIntegral (frame + db `div` 160)/(framerate*10)+7

-----------------------------------------------------------
-- Funções de matrizes/vetores
-----------------------------------------------------------
carray :: [Double] -> CArray (Int, Int) Double
carray = listArray ((0, 0), (1024,0))

cMatrix :: [Int] -> CArray (Int, Int) Int
cMatrix = listArray ((0, 0), (width,height))

cMatrixDouble :: [Double] -> CArray (Int, Int) Double
cMatrixDouble = listArray ((0, 0), (width,height))

matrixIter :: CArray (Int, Int) Int
matrixIter = cMatrix [fst $ genIter x y (-1) 0 | x <- [0..width], y <- [0..height]]

matrixMag :: CArray (Int, Int) Double
matrixMag = cMatrixDouble [snd $ genIter x y (-1) 0 | x <- [0..width], y <- [0..height]]

readIter :: Int -> Int -> Int
readIter x y = matrixIter ! (x,y)

readMag :: Int -> Int -> Double
readMag x y = matrixMag ! (x,y)

palVec :: [Pixel8] -> CArray Int Pixel8
palVec = listArray (0,maxi)

-----------------------------------------------------------
-- Funções FFT
-----------------------------------------------------------
cleanComplex :: CArray (Int,Int) (Complex Double) -> Int
cleanComplex c = sum stripped `div` 10
  where stripped = take 7 cleaned
        cleaned = map (\comp -> round (magnitude comp) `div` 100)  $ elems c

getAnimationTimings :: [Double] -> [Int] -> Int -> Int -> [((Int, Int), Int)]
getAnimationTimings samples rangeFrames spf dur = map (\(sz, db) -> ((sz, db), foldl1 (\n x -> n + x `div` 15) $ take sz [snd t | t <- newSt])) newSt
  where st = map (\x -> cleanComplex $ dftRC $ carray $ drop (spf*x+1) samples) rangeFrames
        newSt = map (\sz -> (sz, foldl1 (\n x -> n - (n-x) `div` 4) $ take sz st)) [2..dur * round framerate]

-----------------------------------------------------------
-- Criação da imagem
-----------------------------------------------------------
doAnim :: ((Int, Int),Int) -> Bool -> Maybe (Image PixelRGB8)
doAnim info static = Just $ generateImage genPixel width height
  where genPixel x y = colorFromIter hue $ if static then (readIter x y, readMag x y) else genIter x y frameN hueDB
        h = hueDB `div` (10*sensitivity)
        hue = mod (db `div` (20*sensitivity) + h + frameN `div` 60) maxi
        (path, frameN, db) = (genPath $ fst s, fromIntegral $ fst s, snd s)
        (s, hueDB) = info

doAnimSave :: ((Int, Int),Int) -> FilePath -> Bool -> IO ()
doAnimSave info path static = do

  let image = fromMaybe (generateImage (\x y -> PixelRGB8 0 0 0) 2 2 ) $ doAnim info static

  if imageWidth image < 3 then putStrLn "" else writePng path image

writeVideo :: [((Int, Int), Int)] -> Int -> Int -> Int ->  IO ()
writeVideo dbList spf sr total = do
  let listOfImage = map (`doAnim` estático) dbList ++ [Nothing]

  save <- imageWriter (EncodingParams (fromIntegral width) (fromIntegral height) (round framerate) Nothing Nothing "medium" Nothing) videoPath

  mapM_ (\(n,z) -> status total n >> save z) $ zip [1..] listOfImage

  callCommand $ printf "ffmpeg -i %s -i %s -map 0:v -map 1:a -c:v copy -shortest %s -y" videoPath musicPath ( reverse (drop 4 $ reverse videoPath) ++ "_audio.mp4")

-----------------------------------------------------------
-- Main
-----------------------------------------------------------
main :: IO ()
main = do
  _ <- hSetBuffering stdout NoBuffering

  p <- getWAVEFile musicPath --Lendo nosso arquivo

  let header = waveHeader p

  -- Esse número 32768 é quando estamos lendo word8 signed como unsigned
  -- então o que deveria ser 0 signed se torna 32768 unsigned (10000000 = -32768 signed but 10000000 unsiged = 32768)
  -- o FFT não se importa mt, math is beautiful
  let waveSmpAll = [fromIntegral (head l) /32768 | l <- waveSamples p] --todas nossas samples

  let sampleRate = waveFrameRate header  --Numero de samples e.g 44100

  let waveSmp = drop (sampleRate `div` 9) waveSmpAll -- Isso irá colocar nosso vídeo 100ms adiantado, melhor sincronismo

  let samples = fromMaybe 0 $ waveFrames header     -- Total de samples da nossa música

  _ <- if samples == 0 then exitFalha "Falha na leitura de samples do arquivo." else putStrLn "\nFile OK."

  let duração = samples `div` waveFrameRate header

  let samplesPerFrame = sampleRate `div` round framerate

  let total = duração * round framerate

  let rangeFrames = [0..total]

  _ <- putStrLn $ printf "%dx%d - %.f fps" width height framerate
  _ <- putStrLn $ printf "Sample Count: %d" samples
  _ <- putStrLn $ printf "SampleRate: %d\nduracao em segundos: %d\nNumero de frames: %d" sampleRate duração total

  {- Chamamos essa função para retornar uma lista de informações úteis para
     desenharmos o mandelbrot reagindo a música.
     [((a, b), c)] onde a é o numero do frame
     b é quantidade de grave que o fft disse que tem no frame atual
     c é a versão suavizada de b, objetivo dela é não ter picos extremos -}
  let dbList = drop dropped $ getAnimationTimings waveSmp rangeFrames samplesPerFrame duração

  _ <- putStr "Deseja salvar em vídeo? [Y/N] "
  opt <- getLine

  _ <- if null opt || 'y' /= toLower (head opt) && 'n' /= toLower (head opt)
    then exitFalha "Não entendi. Abortando."
    else putStrLn (if 'y' == toLower (head opt) then "Saída de vídeo" else "Saída em imagens")

  if 'n' == toLower (head opt)
    then mapM_ (\(n, x) -> status total n >> doAnimSave x (genPath n) estático) $ zip [dropped..] dbList

    else writeVideo dbList samplesPerFrame sampleRate total

  putStrLn "\nDone"


{-# LANGUAGE DataKinds #-}

import Math.Tensor
import Math.Tensor.LorentzGenerator
import Math.Tensor.Examples.Gravity
import Math.Tensor.Examples.Gravity.DiffeoSymEqns
import Math.Tensor.Examples.Gravity.Schwarzschild

import Math.Tensor.Internal.LinearAlgebra

import Numeric.LinearAlgebra (rank)
import Numeric.LinearAlgebra.Data (toLists, fromLists, size, cmap, (===), Matrix, Z)
import Data.List (nub, nubBy, findIndex, sort)

import Data.Maybe (mapMaybe)

import Data.Int (Int64)
import Data.Ratio

import Control.Parallel.Strategies (parList, runEvalIO, rdeepseq)

import qualified Data.IntMap.Strict as I

main = do

  let ans0 = fromListT6 [((Empty, Empty, Empty, Empty, Empty, Empty), AnsVar $ I.singleton 1 (SField 1))] :: ATens 0 0 0 0 0 0 AnsVarR
--  let (eta4,eps4,ans4) = mkAnsatzTensorFastAbs 4 symList4 areaList4 :: (AnsatzForestEta, AnsatzForestEpsilon, ATens 1 0 0 0 0 0 AnsVarR)
  let ans4 = ZeroTensor :: ATens 1 0 0 0 0 0 AnsVarR
  let (eta6,eps6,ans6) = mkAnsatzTensorFastAbs 6 symList6 areaList6 :: (AnsatzForestEta, AnsatzForestEpsilon, ATens 1 0 1 0 0 0 AnsVarR)
  let (eta8,eps8,ans8) = mkAnsatzTensorFastAbs 8 symList8 areaList8 :: (AnsatzForestEta, AnsatzForestEpsilon, ATens 2 0 0 0 0 0 AnsVarR)
  let (eta10_1,eps10_1,ans10_1) = mkAnsatzTensorFastAbs 10 symList10_1 areaList10_1 :: (AnsatzForestEta, AnsatzForestEpsilon, ATens 2 0 0 0 2 0 AnsVarR)
  let (eta10_2,eps10_2,ans10_2) = mkAnsatzTensorFastAbs 10 symList10_2 areaList10_2 :: (AnsatzForestEta, AnsatzForestEpsilon, ATens 2 0 1 0 0 0 AnsVarR)

  let r0    = tensorRank6' ans0
  let r4    = tensorRank6' ans4
  let r6    = tensorRank6' ans6
  let r8    = tensorRank6' ans8
  let r10_1 = tensorRank6' ans10_1
  let r10_2 = tensorRank6' ans10_2

  let ans0'    = ans0
  let ans4'    = shiftLabels6 r0 ans4
  let ans6'    = shiftLabels6 (r0 + r4) ans6
  let ans8'    = shiftLabels6 (r0 + r4 + r6) ans8
  let ans10_1' = shiftLabels6 (r0 + r4 + r6 + r8) ans10_1
  let ans10_2' = shiftLabels6 (r0 + r4 + r6 + r8 + r10_1) ans10_2

  let ansaetze = ans0' &.&>
                 ans4' &.&>
                 ans6' &.&>
                 ans8' &.&>
                 ans10_1' &.&>
                 (singletonTList6 ans10_2')

  putStrLn $ "dimension of ansatz space   : " ++ show (tensorRank6 ansaetze)

  let two = SField (2 :: Rational)

  let e1 = eqn1 ans0' ans4'
  let e2 = eqn3 ans6'
  let e3 = eqn1A ans4' (two &. ans8')
  let e4 = eqn1AI ans6' ans10_2'
  let e5 = eqn2Aa ans6' (two &. ans10_1')
  let e6 = eqn3A ans6' ans10_2'

  let system = e1 &.&>
               e2 &.&>
               e3 &.&>
               e4 &.&>
               e5 &.&>
               (singletonTList6 e6)

  putStrLn $ "rank of system              : " ++ show (tensorRank6 system)

  let solution = redefineVarsSystem6 $ solveSystem6 system ansaetze

  case solution of
    (t1 `AppendTList6` (
     t2 `AppendTList6` (
     t3 `AppendTList6` (
     t4 `AppendTList6` (
     t5 `AppendTList6` (
     t6 `AppendTList6` (
     EmptyTList6)))))))
      -> do
          let Just ans0'' = tryAsATens ans0 t1
          let Just ans4'' = tryAsATens ans4 t2
          let Just ans6'' = tryAsATens ans6 t3
          let Just ans8'' = tryAsATens ans8 t4
          let Just ans10_1'' = tryAsATens ans10_1 t5
          let Just ans10_2'' = tryAsATens ans10_2 t6

          let e1' = removeZeros6 $ eqn1 ans0'' ans4''
          let e2' = removeZeros6 $ eqn3 ans6''
          let e3' = removeZeros6 $ eqn1A ans4'' (two &. ans8'')
          let e4' = removeZeros6 $ eqn1AI ans6'' ans10_2''
          let e5' = removeZeros6 $ eqn2Aa ans6'' (two &. ans10_1'')
          let e6' = removeZeros6 $ eqn3A ans6'' ans10_2''

          putStrLn $ "dimension of solution space : " ++ show (tensorRank6 solution)
          putStrLn ""
          putStrLn "Equations on solution space :"

          print e1'
          print e2'
          print e3'
          print e4'
          print e5'
          print e6'

          let kin' = ans10_2'' &- (contrATens3 (0,0) $ contrATens3 (1,1) $ interI2 &* ans10_1'')
          let kin = kin' &+ (tensorTrans1 (0,1) kin')

          putStrLn ""
          putStrLn $ "number of parameters in kinetic part of EOM : " ++ show (tensorRank6' kin)
          putStrLn $ "number of parameters in mass part of EOM    : " ++ show (tensorRank6' ans8'')

          let n1 = removeZeros6 $ (delta3A &* ans4'') &+ (contrATens1 (1,0) $ interArea &* ans4'') &+ (contrATens1 (0,0) $ contrATens1 (1,1) $ two &. flatArea &* interArea &* ans8'')

          let n2_1 = contrATens1 (0,0) $ contrATens1 (1,1) $ contrATens2 (0,0) $ flatArea &* interArea &* interJ2 &* ans10_2''
          let n2_2 = contrATens1 (0,0) $ contrATens1 (2,1) $ contrATens2 (0,0) $ flatArea &* interArea &* interJ2 &* ans10_2''
          let n2_3 = contrATens1 (0,0) $ contrATens1 (1,1) $ flatArea &* interArea &* ans10_1''

          let n2 = removeZeros6 $ cyclicSymATens5 [0,1,2] $ n2_1 &+ n2_2 &- (two &. n2_3)

          putStrLn ""
          putStrLn "Noether identity 1 :"
          print n1

          putStrLn ""
          putStrLn "Noether identity 2 :"
          print n2

  return ()


{-# LANGUAGE DataKinds  #-}
{-# LANGUAGE RankNTypes #-}

module Main where

import qualified Data.Vector.Sized as V
import           GHC.TypeLits (KnownNat)
import           Graphics.Gloss
import           Numeric.Hamilton
import           Numeric.LinearAlgebra.Static
import           Pendulum.Model
import           Pendulum.View

toVector :: forall a m. KnownNat m => [a] -> V.Vector m a
toVector = (\(Just x) -> x) . V.fromList

pdConfig :: Config 4
pdConfig =
  let th = 0.5 * pi
   in Cfg (vector (replicate 4 th)) (vector (replicate 4 0))

pendulum :: Pendulum 4
pendulum = Pendulum
  { _lengthes = toVector (replicate 4 0.8)
  , _masses   = toVector (replicate 4 0.8)
  , _config   = pdConfig
  }

pdSystem :: System 8 4
pdSystem = mkPendlumSystem pendulum

main :: IO ()
main = do
  let display = InWindow "Multi Pendulum Simulation" (800, 800) (10, 10)
  simulate display white 30 pendulum drawPendulum (\_ dt pd -> stepPendulum (realToFrac dt) pdSystem pd)


module Proxy.PotentialFields.Internal.Fields where
import Proxy.Types.Game
import Proxy.Server.Messages
import Proxy.Query.Unit
import Data.Complex
import Data.List (foldl')
import Control.Applicative ((<*>))
import System.Random
import Control.DeepSeq
import Data.Array

--REALISTICALLY IT WOULD BE NICE TO GO IN AND CHANGE ALL OF THESE DEFINITIONS TO BE MUCH MORE ABSTRACT -IE REMOVE REFERENCES TO THE HSBWAPI

type PotCalc a = a -> UnitData -> Vector
type Vector = (Double,Double)

lOfTrap :: Int
lOfTrap = 5

sOfTrap :: Double
sOfTrap = 3

trapped :: [Location] -> [(Int,Location)]
trapped [] = []
trapped (x:xs) = if l > lOfTrap
                 then (l,centroid as) : trapped bs
                 else trapped bs
  where (as,bs) = span ((<3).(d x)) (x:xs)
        l = length as

passAvSize :: PotCalc (Int,Location)
passAvSize (i,l) u = mult (fromIntegral i) (passAv l u)

avoidTrappedOld :: PotCalc [Location]
avoidTrappedOld hs u =  foldr g nullVector (trapped hs)
  where g l v = passAvSize l u `add` v

avoidAllTrapped :: PotCalc [[Location]]
avoidAllTrapped lss u = vSum (map (flip avoidTrappedOld u) lss)

randMag :: Double
randMag = 0.5

nullVector :: Num a => (a,a)
nullVector = (0,0)

randomField :: RandomGen g => PotCalc g
randomField g _ = randMag `mult` (x,y)
  where x:y:_ = randomRs (-1,1) g

avoidAllOld :: PotCalc [Location]
avoidAllOld hs u = foldr g nullVector hs
  where g l v = passAv l u `add` v

nofield :: PotCalc a
nofield _ _ = nullVector

peaApp :: PotCalc Location
peaApp h fu = mult (-1) (grad h f)
 where f = unitLocation fu

agApp :: PotCalc UnitData
agApp hu fu = (2*di*(di - far)*(2*di - far)) `mult` grad h f
  where di = d h f
        h = unitLocation hu
        f = unitLocation fu
        far = fromIntegral $ if isFlyer.unitType $ hu
                             then airRange.unitType $ fu
                             else groundMaxRange.unitType $ fu

passAv :: PotCalc Location
passAv h fu = ((recip (d h f)) ^ 2) `mult` grad h f
  where f = unitLocation fu

passAvU :: PotCalc UnitData
passAvU = passAv.unitLocation

actAv :: PotCalc UnitData
actAv hu fu = (2*(di+har)*(di - hsr)*(di - har - hsr)) `mult` grad h f
  where di = d h f
        h = unitLocation hu
        f = unitLocation fu
        hsr = fromIntegral.(+1).sightRange.unitType $ hu
        har = fromIntegral.(+1) $ if isFlyer.unitType $ fu
                                  then airRange.unitType $ hu
                                  else groundMaxRange.unitType $ hu

mapData :: PotCalc [Location]
mapData xs = vSum . (([passAv] <*> xs) <*>) . (flip (:) [])

grad :: Location -> Location -> Vector
grad h@(hx,hy) f@(fx,fy) = (recip (d f h)) `mult` (fromIntegral $ fx-hx,fromIntegral $ fy-hy)

centroid :: [Location] -> Location
centroid xs = vmap round $ (recip . fromIntegral . length) xs `mult` (vmap fromIntegral . vSum) xs

mult :: (Num a) => a -> (a,a) -> (a,a)
mult x (v,w) = (x*v,x*w)

add :: (Num a) => (a,a) -> (a,a) -> (a,a)
add (x,y) (z,v) = (z+x,y+v)

vSum :: (Num a) => [(a,a)] -> (a,a)
vSum = foldl' add (0,0)

vmap :: (a -> b) -> (a,a) -> (b,b)
vmap f (x,y) = (f x, f y)

d ::(Floating a) => Location -> Location -> a
d (x,y) (z,w) = sqrt.fromIntegral $ ((x-z) ^ 2) + ((y-w) ^ 2)

{-
f :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> [[(a,c)]] -> [Array a b]
f g base bounds baselist xs = foldr h [] xs
  where arr y = accumArray g base bounds (baselist ++ y)
        h a b = arr a : b

test = f (\x y -> y) 0 (1,100000) (zip [1..100000] (repeat 1)) [[(100000,2)],[(1,1)],[],[],[(3,10)]]
-}


module Numeric.RBM where

import Control.Monad
import Control.Monad.IO.Class
import Math.Probable hiding (vector)
import Numeric.LinearAlgebra
import Numeric.LinearAlgebra.Data
import Numeric.LinearAlgebra.HMatrix (norm_2)

data RBM = RBM
  { weights  :: !(Matrix Double)
  , weightsT :: !(Matrix Double)
  } deriving (Eq, Show)

pp :: RBM -> IO ()
pp (RBM w _) = disp 2 w

randMat :: Int -> Int -> RandT IO Double -> IO (Matrix Double)
randMat n p = mwc . fmap fromLists . replicateM n . listOf p

new :: Int -- ^ nb of visible units
    -> Int -- ^ nb of hidden units
    -> IO RBM
new nvisible nhidden = do
  w      <- randMat nvisible nhidden (normal 0 0.1)
  let w'  = asColumn (konst 0 nvisible) ||| w
      w'' = asRow (konst 0 (nhidden + 1)) === w'
  return $ RBM w'' (tr w'')

trainOnce :: Matrix Double -- ^ training data
          -> Double        -- ^ learning rate
          -> RBM
          -> IO RBM
trainOnce trainingData learningRate (RBM w wt) = do
  let dat            = asColumn (konst 1 n) ||| trainingData
      pos_hidden_act = dat <> w
      pos_hidden_p   = cmap logistic pos_hidden_act

  pos_hidden_st <- do
    randomM <- randMat n p (uniform 0 1)
    return $ step (pos_hidden_p - randomM)

  let pos_assocs = tr dat <> pos_hidden_p

      neg_visible_act = pos_hidden_st <> wt
      neg_visible_p   = cmap logistic neg_visible_act
      n'              = rows neg_visible_p
      neg_visible_p'  = asColumn (konst 1 n') ||| dropColumns 1 neg_visible_p
      neg_hidden_act  = neg_visible_p' <> w
      neg_hidden_p    = cmap logistic neg_hidden_act
      neg_assocs      = tr neg_visible_p' <> neg_hidden_p

      new_w           = (w +) . cmap (\x -> learningRate * x / fromIntegral n) $
                          pos_assocs - neg_assocs

      err             = norm_2 (dat - neg_visible_p')

  putStrLn $ "Error: " ++ show err
  return $ RBM new_w (tr new_w)

  where n = rows trainingData
        p = cols w

logistic :: Double -> Double
logistic x = 1 / (1 + exp (negate x))

trainN :: Matrix Double -- ^ training data
       -> Double        -- ^ learning rate
       -> Int           -- ^ epochs
       -> RBM
       -> IO RBM
trainN dat learningRate epochs = go epochs

  where go 0 rbm = return rbm
        go n rbm = do
          rbm' <- trainOnce dat learningRate rbm
          go (n - 1) rbm'

runVisible :: RBM
           -> Matrix Double      -- ^ sample rows of values for visible units
           -> IO (Matrix Double) -- ^ values of hidden units for the given visible units
runVisible (RBM w wt) inputData = do
  let dat        = asColumn (konst 1 n) ||| inputData
      hidden_act = dat <> w
      hidden_p   = cmap logistic hidden_act

  hidden_st <- do
    randomM <- randMat n p (uniform 0 1)
    return $ step (hidden_p - randomM)

  return $ dropColumns 1 hidden_st

  where n = rows inputData
        p = cols w

runHidden :: RBM
          -> Matrix Double      -- ^ sample rows of hidden units values
          -> IO (Matrix Double) -- ^ values of visible units for the given hidden ones
runHidden (RBM w wt) hiddenData = do
  let dat         = asColumn (konst 1 n) ||| hiddenData
      visible_act = dat <> wt
      visible_p   = cmap logistic visible_act

  visible_st <- do
    randomM <- randMat n p (uniform 0 1)
    return $ step (visible_p - randomM)

  return $ dropColumns 1 visible_st

  where n = rows hiddenData
        p = cols wt

daydream :: RBM
         -> Int                -- ^ number of samples we want to extract
         -> IO [Vector Double] -- ^ each row is a sample of the visible units
                               --   that the RBM has "daydreamed"
daydream (RBM w wt) nsamples = do
  sample0 <- fmap (fromList . (1:) . tail) . mwc $ listOf n (uniform 0 1)

  go sample0 nsamples

  where n = rows w
        p = cols w

        go :: Vector Double -> Int -> IO [Vector Double]
        go _v 0 = return []
        go v i = do
          let hidden_act = asRow v <> w
              hidden_p   = cmap logistic hidden_act

          hidden_st <- do
            randomV <- fmap vector . mwc $ listOf p (uniform 0 1)
            return $ step (head (toRows hidden_p) - randomV)

          let hidden_st' = asRow . vector . (1:) . tail . toList $ hidden_st
              visible_act = hidden_st' <> wt
              visible_p   = cmap logistic visible_act

          visible_st <- do
            randomV <- fmap vector . mwc $ listOf n (uniform 0 1)
            return $ step (head (toRows visible_p) - randomV)

          let res = vector . tail . toList $ visible_st
          fmap (res:) $ go visible_st (i - 1)

-- EXAMPLE

-- data given in:
-- http://blog.echen.me/2011/07/18/introduction-to-restricted-boltzmann-machines/

-- Harry Potter, Avatar, LOTR, Gladiator, Titanic, Glitter
samples :: Matrix Double
samples = fromLists
  [ [ 1, 1, 1, 0, 0, 0 ]
  , [ 1, 0, 1, 0, 0, 0 ]
  , [ 1, 1, 1, 0, 0, 0 ]
  , [ 0, 0, 1, 1, 1, 0 ]
  , [ 0, 0, 1, 1, 0, 0 ]
  , [ 0, 0, 1, 1, 1, 0 ]
  ]

new_user :: Matrix Double
new_user = fromLists [ [ 0, 0, 0, 1, 1, 0 ] ]

hiddens :: Matrix Double
hiddens = fromLists
  [ [0, 0]
  , [0, 1]
  , [1, 0]
  , [1, 1]
  ]

test :: Double -> Int -> IO ()
test rate k = do
  rbm <- new 6 2

  pp rbm
  trained <- trainN samples rate k rbm
  pp trained
  putStrLn "-------"
  putStrLn "VISIBLE"
  res <- runVisible trained new_user
  disp 2 res
  putStrLn "-------"
  putStrLn "HIDDEN"
  res' <- runHidden trained hiddens
  disp 2 res'

  putStrLn "-------"
  putStrLn "DAYDREAM"
  daydream trained 10 >>= mapM_ print

main :: IO ()
main = test 0.1 10000