{-# LANGUAGE RankNTypes                               #-}
{-# LANGUAGE RecordWildCards                          #-}
{-# LANGUAGE ScopedTypeVariables                      #-}
{-# LANGUAGE TypeApplications                         #-}
{-# LANGUAGE TypeFamilies                             #-}
{-# LANGUAGE TypeInType                               #-}
{-# LANGUAGE TypeOperators                            #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}

module Tests.Util (
    groupTree
  , CloseEnough(..)
  , generateData
  , withSize
  , dot
  ) where

import           Data.Complex
import           Data.Proxy
import           Data.Type.Equality
import           GHC.TypeLits.Compare
import           GHC.TypeNats
import           Hedgehog
import           Hedgehog.Internal.Property
import           Numeric.Natural
import           Statistics.Transform
import           Test.Tasty
import           Test.Tasty.Hedgehog
import qualified Data.Vector.Sized          as V
import qualified Hedgehog.Gen               as Gen
import qualified Hedgehog.Range             as Range

groupTree :: Group -> TestTree
groupTree Group{..} = testGroup (unGroupName groupName)
                                (map (uncurry go) groupProperties)
  where
    go :: PropertyName -> Property -> TestTree
    go n = testProperty (mkName (unPropertyName n))
    mkName = map deUnderscore . drop (length @[] @Char "prop_")
    deUnderscore '_' = ' '
    deUnderscore c   = c

newtype CloseEnough n = CE { getCE :: V.Vector n Double }
  deriving Show

instance KnownNat n => Eq (CloseEnough n) where
    CE x == CE y = ((d `dot` d) / sqrt ((x `dot` x) * (y `dot` y))) < 0.0001
      where
        d = V.zipWith (-) x y

dot :: Num a => V.Vector n a -> V.Vector n a -> a
dot a b = sum $ V.zipWith (*) a b

withSize
    :: Monad m
    => Range Natural
    -> (forall n. (KnownNat n, 1 <= 2^n) => Proxy n -> PropertyT m a)
    -> PropertyT m a
withSize r f = do
    n <- forAll $ Gen.integral r
    case someNatVal n of
      SomeNat (p :: Proxy n) -> do
        LE Refl <- pure $ Proxy @1 %<=? Proxy @(2^n)
        f p

generateData
    :: KnownNat n
    => Gen (V.Vector (2^n) Double)
generateData = fmap (fmap realPart . ifftSized) . V.generateM $ \i ->
    let i' = recip . (+ 1) . fromIntegral $ i
    in  mkPolar <$> Gen.double (Range.exponentialFloat (i' / 10) i')
                <*> Gen.double (Range.constant (-pi) pi)

ifftSized
    :: V.Vector (2^n) (Complex Double)
    -> V.Vector (2^n) (Complex Double)
ifftSized = V.withVectorUnsafe ifft


{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DataKinds, TypeFamilies #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}

module DelayedSamplingPure where

import Prelude hiding ((<>))

import Control.Exception.Base (assert)
import Control.Monad (forM_, when)

import Data.List (delete)
import Data.Maybe (isJust)
import Data.Proxy
import Data.IORef

import Debug.Trace

import GHC.TypeLits

import Numeric.AD
import Numeric.AD.Rank1.Tower (Tower)

import Numeric.LinearAlgebra.Static hiding (M)

import Unsafe.Coerce (unsafeCoerce)

import Distributions
import MVDistributions
import Inference

data Node' b where
  NMarginalized :: Maybe (CDistr b c, Node' c) -> [InitTree b] -> Node' b

data RootNode a where
  RootNode :: MDistr a -> Node' a -> RootNode a

data InitTree b where
  InitTree :: CDistr b c -> [InitTree c] -> InitTree b

data MPath where
  Root :: MPath
  Child :: MPath -> MPath

data IPath = IPath [Int]

data AnyPath where
  AMPath :: MPath -> AnyPath
  AIPath :: IPath -> AnyPath

data MarginalT = MGaussianT | MBetaT | MBernoulliT | forall (n :: Nat). MMVGaussianT (Proxy n)

data SMarginalT (m :: MarginalT) where
  SMGaussianT :: SMarginalT MGaussianT
  SMBetaT :: SMarginalT MBetaT
  SMBernoulliT :: SMarginalT MBernoulliT
  SMMVGaussianT :: forall (n :: Nat) (p :: Proxy n). SMarginalT (MMVGaussianT p)

type family MType (m :: MarginalT) where
  MType MGaussianT = Double
  MType MBetaT = Double
  MType MBernoulliT = Bool
  MType (MMVGaussianT (p :: Proxy n)) = R n

data MDistr (m :: MarginalT) where
  MGaussian :: !Double -> !Double -> MDistr MGaussianT
  MBeta :: !Double -> !Double -> MDistr MBetaT
  MBernoulli :: !Double -> MDistr MBernoulliT
  MMVGaussian :: forall (n :: Nat) (p :: Proxy n). KnownNat n => !(R n) -> !(Sym n) -> MDistr (MMVGaussianT p)

--deriving instance Eq (MDistr m)
deriving instance Show (MDistr m)

data CDistr (m :: MarginalT) (m' :: MarginalT) where
  AffineMeanGaussian :: !Double -> !Double -> !Double -> CDistr MGaussianT MGaussianT
  CBernoulli :: CDistr MBetaT MBernoulliT
  MVAffineMeanGaussian :: forall (n :: Nat) (m :: Nat) (pn :: Proxy n) (pm :: Proxy m).
    (KnownNat n, KnownNat m) => (L m n) -> (R m) -> (Sym m) -> CDistr (MMVGaussianT pn) (MMVGaussianT pm)

gaussianConditioning :: Double -> Double -> Double -> Double -> (Double, Double)
gaussianConditioning mu var obs obsvar = (mu', var')
  where
  ivar = recip var
  iobsvar = recip obsvar
  inf = ivar + iobsvar
  var' = recip inf
  mu' = (ivar * mu + iobsvar * obs) / inf

gaussianMeanGaussian :: Double -> CDistr MGaussianT MGaussianT
gaussianMeanGaussian = AffineMeanGaussian 1 0

mdistrToDistr :: MDistr a -> Distr (MType a)
mdistrToDistr (MGaussian mu var) = normal mu var
mdistrToDistr (MMVGaussian mu var) = mvNormal mu var
mdistrToDistr (MBeta a b) = beta a b
mdistrToDistr (MBernoulli p) = bernoulli p

cdistrToDistr :: CDistr m m' -> MType m -> MDistr m'
cdistrToDistr (AffineMeanGaussian m b obsvar) mu = MGaussian (m * mu + b) obsvar
cdistrToDistr (MVAffineMeanGaussian f b obsvar) mu = MMVGaussian (f #> mu + b) obsvar
cdistrToDistr CBernoulli p = MBernoulli p

makeMarginal :: MDistr a -> CDistr a b -> MDistr b
makeMarginal (MGaussian mu var) (AffineMeanGaussian m b obsvar) =
  MGaussian (m * mu + b) (m^2 * var + obsvar)
makeMarginal (MMVGaussian mu var) (MVAffineMeanGaussian f b obsvar) =
  MMVGaussian (f #> mu + b) (conjugate f var + obsvar)
makeMarginal (MBeta a b) CBernoulli = MBernoulli (a / (a + b))
makeMarginal (MBernoulli _) _ = error "impossible"

makeConditional :: MDistr a -> CDistr a b -> MType b -> MDistr a
makeConditional (MGaussian mu var) (AffineMeanGaussian m b obsvar) obs =
  MGaussian mu' var'
  where (mu', var') = gaussianConditioning mu var ((obs - b) / m) (obsvar / m^2)
makeConditional (MMVGaussian mu var) (MVAffineMeanGaussian f b obsvar) obs =
  MMVGaussian mu' var'
  where (mu', var') = fst (kalmanUpdate obs f obsvar (mu, var))
makeConditional (MBeta a b) CBernoulli tf =
  if tf then MBeta (a + 1) b else MBeta a (b + 1)
makeConditional (MBernoulli _) _ _ = error "impossible"

data State b where
  Initialized :: State b
  Marginalized :: MDistr b -> State b

deriving instance Show (State MGaussianT)
deriving instance Show (State MBetaT)

isMarginalized :: State b -> Bool
isMarginalized (Marginalized _) = True
isMarginalized _ = False

data DSDistr a b where
   UDistr :: !(MDistr b) -> DSDistr a b
   CDistr :: !(IORef (Node z a)) -> !(CDistr a b) -> DSDistr a b

typeOfMDistr :: MDistr b -> SMarginalT b
typeOfMDistr (MGaussian _ _) = SMGaussianT
typeOfMDistr (MBeta _ _) = SMBetaT
typeOfMDistr (MBernoulli _) = SMBernoulliT
typeOfMDistr (MMVGaussian _ _) = SMMVGaussianT

typeOfCDistr :: CDistr m m' -> SMarginalT m'
typeOfCDistr (AffineMeanGaussian _ _ _) = SMGaussianT
typeOfCDistr CBernoulli = SMBernoulliT
typeOfCDistr (MVAffineMeanGaussian _ _ _) = SMMVGaussianT

typeOfDSDistr :: DSDistr a b -> SMarginalT b
typeOfDSDistr (UDistr d) = typeOfMDistr d
typeOfDSDistr (CDistr _ c) = typeOfCDistr c

data Node a b = Node
  { name :: !String
  , children :: [RefNodeFrom b]
  , state :: !(State b)
  , distr :: !(DSDistr a b)
  }
  | RealizedNode (MType b)

data Path e (a :: MarginalT) (b :: MarginalT) where
  PNil :: Path e a a
  PSnoc :: e b c -> Path e a b -> Path e a c

data PathTo e b where
  PathTo :: !(Path e a b) -> PathTo e b

data RefNodeTo b where
  RefNodeTo :: !(IORef (Node a b)) -> RefNodeTo b

data RefNodeFrom a where
  RefNodeFrom :: !(IORef (Node a b)) -> RefNodeFrom a

instance Eq (RefNodeFrom a) where
  RefNodeFrom x == RefNodeFrom y = x == unsafeCoerce y

instance Eq (RefNodeTo a) where
  RefNodeTo x == RefNodeTo y = x == unsafeCoerce y

-- initialize without parent node
constant' :: MDistr a -> RootNode a
constant' d = RootNode d (NMarginalized Nothing [])

-- mModifyChildren :: ([InitTree a] -> [InitTree a]) -> MPath -> Node' x -> Node' x
-- mModifyChildren f Root (NMarginalized c t) = NMarginalized c (f t)
-- mModifyChildren f (Child p) (NMarginalized (Just (cdistr, c)) t) = NMarginalized (Just (cdistr, mModifyChildren f p c)) t

-- modifyChildren :: ([InitTree a] -> [InitTree a]) -> AnyPath -> Node' x -> Node' x
-- modifyChildren f (AMPath p) = mModifyChildren f p

-- -- initialize with parent node
-- newConditional' :: AnyPath -> CDistr a b -> Node' x -> (Node' x, AnyPath)
-- newConditional' par cdistr = do
--   childRef <- newIORef child
--   modifyIORef' par $ \n -> n { children = (RefNodeFrom childRef) : children n }
--   --childRef' <- mkWeakIORef childRef $ putStrLn ("deleted " ++ str)
--   pure childRef
--   where
--   child = Node
--     { name = str
--     , children = []
--     , state = Initialized
--     , distr = CDistr par cdistr }


module STCR2Z2T0S0 where

import           Control.Monad             as M
import           Control.Monad.Parallel    as MP
import           Data.Array.Repa           as R
import           Data.Binary
import           Data.Complex
import           Data.List                 as L
import           DFT.Plan
import           Filter.Utils
import           FokkerPlanck.DomainChange
import           FokkerPlanck.MonteCarlo
import           FokkerPlanck.Pinwheel
import           Image.IO
import           STC
import           System.Directory
import           System.Environment
import           System.FilePath
import           Text.Printf
import           Types
import           Utils.Array

main = do
  args@(numPointStr:numOrientationStr:numScaleStr:thetaSigmaStr:scaleSigmaStr:maxScaleStr:taoStr:numTrailStr:maxTrailStr:theta0FreqsStr:thetaFreqsStr:scale0FreqsStr:scaleFreqsStr:initDistStr:histFilePath:alphaStr:radialFlagStr: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]
      initDist = read initDistStr :: [R2S1RPPoint]
      scale0Freq = read scale0FreqsStr :: Double
      scaleFreq = read scaleFreqsStr :: Double
      scale0Freqs = [-scale0Freq .. scale0Freq]
      scaleFreqs = [-scaleFreq .. scaleFreq]
      alpha = read alphaStr :: Double
      radialFlag = read radialFlagStr :: Bool
      numThread = read numThreadStr :: Int
      sourceDist = L.take 1 initDist
      sinkDist = L.drop 1 initDist
      folderPath = "output/test/STCR2Z2T0S0"
      dirName = takeDirectory histFilePath
      fileName = takeFileName histFilePath
      newHistFilePath =
        if radialFlag
          then dirName </> ("Radial_" L.++ fileName)
          else histFilePath
      (R2S1RPPoint (_, _, _, s)) = L.head sourceDist
  createDirectoryIfMissing True folderPath
  arrR2Z2T0S0 <-
    if radialFlag
      then do
        flag <- doesFileExist newHistFilePath
        radialArr <-
          if flag
            then R.map magnitude . getNormalizedHistogramArr <$>
                 decodeFile newHistFilePath
            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
                newHistFilePath
                (emptyHistogram
                   [ if maxScale >= 2
                        then round maxScale + 1
                        else (round . sqrt . fromIntegral $ 2 * (div numPoint 2) ^ 2)
                   , L.length scale0Freqs
                   , L.length theta0Freqs
                   , L.length scaleFreqs
                   , L.length thetaFreqs
                   ]
                   0)
        computeUnboxedP $
          computeR2Z2T0S0ArrayRadial
            Pinwheel
            radialArr
            numPoint
            numPoint
            1
            maxScale
            thetaFreqs
            scaleFreqs
            theta0Freqs
            scale0Freqs
      else do
        flag <- doesFileExist newHistFilePath
        hist <-
          if flag
            then decodeFile newHistFilePath
            else return $
                 emptyHistogram
                   [ numPoint
                   , numPoint
                   , L.length scale0Freqs
                   , L.length theta0Freqs
                   , L.length scaleFreqs
                   , L.length thetaFreqs
                   ]
                   0
        solveMonteCarloR2Z2T0S0
          numThread
          numTrail
          maxTrail
          numPoint
          numPoint
          thetaSigma
          scaleSigma
          maxScale
          tao
          theta0Freqs
          thetaFreqs
          scale0Freqs
          scaleFreqs
          newHistFilePath
          hist
  plan <- makeR2Z2T0S0Plan emptyPlan False "" arrR2Z2T0S0
  sourceDistArr <-
    computeInitialDistributionR2T0S0
      plan
      numPoint
      numPoint
      theta0Freqs
      scale0Freqs
      maxScale
      -- initDist
      sourceDist
  sinkDistArr <-
    computeInitialDistributionR2T0S0
      plan
      numPoint
      numPoint
      theta0Freqs
      scale0Freqs
      maxScale
      sinkDist
  arrR2Z2T0S0F <- dftR2Z2T0S0 plan . computeS . makeFilter2D $ arrR2Z2T0S0
  -- Source field
  sourceArr <- convolveR2T0S0 plan arrR2Z2T0S0F sourceDistArr
  sourceR2Z2 <- R.sumP . R.sumS . rotateR2Z2T0S0Array $ sourceArr
  sourceField <-
    fmap (computeS . R.extend (Z :. (1 :: Int) :. All :. All)) .
    R.sumP .
    R.sumS .
    rotate4D2 .
    r2z2Tor2s1rp numOrientation thetaFreqs numScale scaleFreqs maxScale $
    sourceR2Z2
  plotImageRepaComplex (folderPath </> printf "Source%.0f.png" s) . ImageRepa 8 $
    sourceField
  -- Sink field
  sinkArr' <- convolveR2T0S0 plan arrR2Z2T0S0F sinkDistArr
  let sinkArr = computeSinkFromSourceR2Z2T0S0 thetaFreqs theta0Freqs sinkArr'
  sinkR2Z2 <- R.sumP . R.sumS . rotateR2Z2T0S0Array $ sinkArr
  sinkField <-
    fmap (computeS . R.extend (Z :. (1 :: Int) :. All :. All)) .
    R.sumP .
    R.sumS .
    rotate4D2 .
    r2z2Tor2s1rp numOrientation thetaFreqs numScale scaleFreqs maxScale $
    sinkR2Z2
  plotImageRepaComplex (folderPath </> printf "Sink%.0f.png" s) . ImageRepa 8 $
    sinkField
  -- Completion Filed
  completionFiled <- convolveR2Z2 plan sourceR2Z2 sinkR2Z2
  completionFiledR2 <-
    R.sumP .
    R.sumS .
    rotate4D2 .
    r2z2Tor2s1rp numOrientation thetaFreqs numScale scaleFreqs maxScale $
    completionFiled
  plotImageRepaComplex (folderPath </> printf "Completion%.0f.png" s) .
    ImageRepa 8 . computeS . R.extend (Z :. (1 :: Int) :. All :. All) $
    completionFiledR2
  plotImageRepa (folderPath </> printf "CompletionMagnitude%.0f.png" s) .
    ImageRepa 8 .
    computeS . R.extend (Z :. (1 :: Int) :. All :. All) . R.map magnitude $
    completionFiledR2


{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase          #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Test.Grenade.Layers.Nonlinear where

import           Data.Singletons

import           Grenade

import           Hedgehog

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

import           Numeric.LinearAlgebra.Static ( norm_Inf )

prop_sigmoid_grad :: Property
prop_sigmoid_grad = property $
    forAllWith rss genShape >>= \case
        (SomeSing (r :: Sing s)) ->
            withSingI r $
                blindForAll genOfShape >>= \(ds :: S s) ->
                    let (tape, f  :: S s)  = runForwards Logit ds
                        ((), ret  :: S s)  = runBackwards Logit tape (1 :: S s)
                        (_, numer :: S s)  = runForwards Logit (ds + 0.0001)
                        numericalGradient  = (numer - f) * 10000
                    in assert ((case numericalGradient - ret of
                           (S1D x) -> norm_Inf x < 0.0001
                           (S2D x) -> norm_Inf x < 0.0001
                           (S3D x) -> norm_Inf x < 0.0001) :: Bool)

prop_tanh_grad :: Property
prop_tanh_grad = property $
    forAllWith rss genShape >>= \case
        (SomeSing (r :: Sing s)) ->
            withSingI r $
                blindForAll genOfShape >>=  \(ds :: S s) ->
                    let (tape, f  :: S s)  = runForwards Tanh ds
                        ((), ret  :: S s)  = runBackwards Tanh tape (1 :: S s)
                        (_, numer :: S s)  = runForwards Tanh (ds + 0.0001)
                        numericalGradient  = (numer - f) * 10000
                    in assert ((case numericalGradient - ret of
                           (S1D x) -> norm_Inf x < 0.001
                           (S2D x) -> norm_Inf x < 0.001
                           (S3D x) -> norm_Inf x < 0.001) :: Bool)

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


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Day13 where

import Control.Lens
import Control.Lens.TH

import qualified Data.ByteString as BS
import Data.Attoparsec.ByteString (Parser, (<?>))
import qualified Data.Attoparsec.ByteString as DAB
import qualified Data.Attoparsec.ByteString.Char8 as DABC8
import Data.Attoparsec.ByteString.Char8 (decimal, inClass, digit, endOfLine, char, anyChar, letter_ascii, notChar)

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

import qualified Data.List as DL
import qualified Data.List.Split as DLS

import Debug.Trace

import Control.Arrow

import Data.Array.IArray (Array)
import qualified Data.Array.IArray as IA

import Data.Set (Set)
import qualified Data.Set as Set
import Data.Either (isRight)
import Data.Maybe (isJust, mapMaybe, catMaybes)
import Data.Bool (bool)

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

import Data.Function (on)

import Control.Monad.State.Strict (State)
import qualified Control.Monad.State.Strict as State

import qualified Control.Monad as CM

import qualified Control.Foldl as L

import Data.Complex
import Data.Functor
import Data.Bifunctor (bimap)

-- Each input is the id of a bus line. Nothing means that the line, whatever its
-- id was, is out of service.
type Input = Maybe BusId

newtype BusId = BusId { getBusId :: Integer } deriving Show

-- Parases an unsigned decimal number
parseBusId :: Parser BusId
parseBusId = (BusId <$> decimal) <?> "BusId"

newtype Timestamp = Timestamp { getTimestamp :: Integer } deriving Show

parseTimestamp :: Parser Timestamp
parseTimestamp = (Timestamp <$> decimal) <?> "Timestamp"

-- Solve part 1
--
-- forall n m : int,
--
-- 	start + n = bus_id * m
--
-- n is the waiting time for the m-th departure of `bus_id`. This can be
-- rearranged as:
--
-- 	(1)	n = bus_id * m - start
--
-- `start` can be rewriten in terms of `bus_id`:
--
-- 	start = bus_id * q + r
--
-- where
--
-- 	q = start / bus_id
-- 	r = start % bus_id
--
-- with
--
-- 	r < bus_id
--
-- replacing in (1)
--
-- 	n = bus_id * (m - q) - r
--
-- So the smallest positive n happens when (m - q) == 1 and is thus equal to
--
-- 	n_min = bus_id - r
--
-- Returns Norhing in case there are no bus lines.
solver :: Timestamp -> [Input] -> Maybe Integer
solver start input = do
	-- Find the bus line with the earliest departure time.
	(busId, departureTime) <-
		L.fold ( L.minimumBy (compare `on` snd) ) $
		(id &&& mapper) <$> catMaybes input

	pure (getBusId busId * departureTime)
	where
	-- Compute the earliest departure time after `start` for a bus line.
	mapper :: BusId -> Integer
	mapper bid = getBusId bid - ( getTimestamp start `mod` getBusId bid )

-- Write equations for part 2
--
-- For each bus_id, n_i is the departure time for the m_i-th departure
--
-- n_1 = bus_id_1 * m_1
-- n_2 = bus_id_2 * m_2
-- ...
-- n_i = bus_id_i * m_i
--
-- Those departure times have to be consecutive so:
--
-- n_2 = n_1 + (ord_2 - ord_1)
-- ...
-- n_(i+1) = n_i + (ord_(i+1) - ord_i)
--
-- where ord_i is the order of the bus_id on the list. With ord_(i+1) > ord_i.
--
-- Applying this constrain we get:
--
-- n_1 = bus_id_1 * m_1
-- n_1 + (ord_2 - ord_1) = bus_id_2 * m_2
-- n_2 + (ord_3 - ord_2) = bus_id_3 * m_3
-- ...
-- n_i + (ord_(i+1) - ord_i) = bus_id_(i+1) * m_(i+1)
--
-- Leaving only n_1 we get:
--
-- n_1 = bus_id_1 * m_1
-- n_1 + (ord_2 - ord_1) = bus_id_2 * m_2
-- (n_1 + (ord_2 - ord_1)) + (ord_3 - ord_2) = bus_id_3 * m_3
-- ...
--
-- The last equation becomes
--
-- n_1 + (ord_3 - ord_1) = bus_id_3 * m_3
--
-- So all the equations become
--
-- n_1 = bus_id_1 * m_1
-- n_1 + (ord_2 - ord_1) = bus_id_2 * m_2
-- n_1 + (ord_3 - ord_1) = bus_id_3 * m_3
-- ...
-- n_1 + (ord_i - ord_1) = bus_id_i * m_i
--
-- Next I rewrite them like:
--
-- n_1 - bus_id_1 * m_1 = 0
-- n_1 + (ord_2 - ord_1) - bus_id_2 * m_2 = 0
-- ...
-- n_1 + (ord_i - ord_1) - bus_id_i * m_i = 0
--
-- Finally I replace n_1 in all the equations
--
-- bus_id_1 * m_1 + (ord_i - ord_1) - bus_id_i * m_i = 0
--
-- This equations can be stored using a 4-tuple
--
--	(bus_id_1, bus_id_i, (ord_i - ord_1), ord_i)
--
-- This functions just creates those 4-tuples to be further processed.
solver' input = case catMaybes (zipWith (\x -> fmap (x,)) [1..] input) of
	( (ord1, busId1) : rest) ->
		(busId1, busId1, 0, ord1) : fmap mapper rest
		where
		mapper (ordi, busIdi) = (busId1, busIdi, ordi - ord1, ordi)

-- Sample input
--
-- 939
-- 7,13,x,x,59,x,31,19
--
-- The x's represent lines that are out of service.
parseInput :: Parser (Timestamp, [Input])
parseInput =
	( (,) <$>
		(parseTimestamp <* endOfLine) <*>
		(DAB.choice
			[ Just <$> parseBusId
			, char 'x' $> Nothing ] `DAB.sepBy1'` char ',') ) <* endOfLine

runSolution :: FilePath -> IO ()
runSolution filePath = do
	putStrLn "**Day 13**"
	contents <- BS.readFile filePath
	let parseResult = DAB.parseOnly parseInput contents
	case parseResult of
		Left err -> putStrLn $ "Error :" ++ err
		Right (start, input) -> do

			putStrLn "Part 1"
			print $ solver start input

			putStrLn "\nPart 2"
			mapM_ (putStrLn . printEq) $ solver' input
	where
	-- Prints an equation to be solved.
	printEq (flid, bid, delta, ordi) =
		show (getBusId flid) ++ " * x[1] - " ++
		show (getBusId bid) ++ " * x[" ++ show ordi ++ "] + " ++
		show delta

-- Wrong
-- 1258

-- Part 1:
-- Answer = Just 410


module Proginduction where

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

-- A grammar for a simple expression language
data BinOp = Add | Multiply
data UnOp = Neg
data Expr = BinOp BinOp Expr Expr
          | UnOp UnOp Expr
          | Number Double
          | Var
          | Cond BoolExpr Expr Expr
data BoolExpr = Leq Expr Expr

-- Simple evaluation function for expressions
eval :: Expr -> Double -> Double
eval (BinOp Add e1 e2) x = (eval e1 x) + (eval e2 x)
eval (BinOp Multiply e1 e2) x = (eval e1 x) * (eval e2 x)
eval (UnOp Neg e ) x = - (eval e x)
eval (Number r) x = r
eval (Cond (Leq e1 e2) e3 e4) x = if (eval e1 x) <= (eval e2 x) then (eval e3 x) else (eval e4 x)
eval Var x = x

-- a probabilistic context free grammar
pcfgbinop :: Meas BinOp
pcfgbinop = do n <- categorical [0.5,0.5]
               case n of 0 -> return Add
                         1 -> return Multiply

pcfgexpr :: Meas Expr
pcfgexpr = do n <- categorical [0.2,0.1,0.3,0.39,0.01]
              case n of 0 -> do {o <- pcfgbinop ; e1 <- pcfgexpr ; e2 <- pcfgexpr ; return $ BinOp o e1 e2 }
                        1 -> do {e <- pcfgexpr ; return $ UnOp Neg e }
                        2 -> do {r <- normal 0 3 ; return $ Number r }
                        3 -> return $ Var
                        4 -> do {e1 <- return Var ; r <- normal 0 4 ; e3 <- pcfgexpr ; e4 <- pcfgexpr ; return $ Cond (Leq e1 (Number r)) e3 e4 }

-- length of an expression
len :: Expr -> Integer
len (BinOp _ e1 e2) = len e1 + len e2 + 1
len (UnOp _ e1) = len e1 + 1
len (Number r) = 1
len Var = 1
len (Cond (Leq e1 e2) e3 e4) = len e1 + len e2 + len e3 + len e4 + 1

-- a random expression is drawn from the context free grammar,
-- but then we weight to get a more reasonable length
randexpr :: Meas (Double -> Double)
randexpr = do { e <- pcfgexpr ;
                score ((normalPdf 25 5) (fromIntegral $ len e)) ;
                return $ \x -> eval e x }

-- functions for plotting a histogram
totalweight :: [(Integer,Double)] -> Double
totalweight rxs = sum $ map (\(_,r) -> r) rxs

toHistogram :: [(Integer,Double)] -> Integer -> Integer -> [Double]
toHistogram rxs from to = if from > to then [] else
  ((sum $ map (\(x,r) -> if x == from then r else 0) rxs) / (totalweight rxs)) : (toHistogram rxs (from + 1) to)

chart :: [Double] -> Renderable ()
chart rs = toRenderable layout
 where
  layout =
        layout_title .~ "Sample Bars" ++ btitle
      $ layout_title_style . font_size .~ 10
      $ layout_x_axis . laxis_generate .~ autoIndexAxis alabels
      $ layout_y_axis . laxis_override .~ axisGridHide
      $ layout_left_axis_visibility . axis_show_ticks .~ False
      $ layout_plots .~ [ plotBars bars2 ]
      $ def :: Layout PlotIndex Double

  bars2 = plot_bars_titles .~ [""]
      $ plot_bars_values .~ addIndexes (map (\x -> [x]) rs) -- [45,30],[30,20],[70,25]]
--      $ plot_bars_style .~ BarsClustered
      $ plot_bars_spacing .~ BarsFixGap 30 5
      $ plot_bars_item_styles .~ map mkstyle (cycle defaultColorSeq)
      $ def

  alabels = map show [0 .. ((length rs)-1)]

  btitle = ""
  bstyle = Just (solidLine 1.0 $ opaque black)
  mkstyle c = (solidFillStyle c, bstyle)

-- plot a histogram of lengths when the weighted pcfg grammar is used
test1 =
  let test =
        do
          e <- pcfgexpr
          -- score ((density $ normalDistr 25 5) (fromIntegral $ len e))
          return $ len e
  in
  do
    rxs' <- weightedsamples test
    let rxs = map (\(x,r) -> (x,r)) rxs'
    _ <- renderableToFile def "histogram.svg" (chart (toHistogram (take 100000 rxs) 0 40))
    return ()

sample_fun f =
  [ (x, f x) | x <- [(-0.25),(-0.25+0.1)..6.2]]

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

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

fit prior dataset = do f <- prior
                       mapM (\(x,y) -> score $ (density $ normalDistr (f x) 0.3) y) dataset
                       return f

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

-- Plot some fitted expressions
test3 =
  do
    fs' <- mh $ fit randexpr dataset
    let fs = map (\(f,_)->f) $ take 10 $ every 1000 $ drop 1000000 $ fs'
    plot_funs "prog-ind.svg" dataset fs
    return ()

-- Histogram of the posterior length
test4 =
  do
    let posteriorLength =
          do e <- pcfgexpr
             mapM (\(x,y) -> score $ (density $ normalDistr (eval e x) 0.3) y) dataset
             return (len e)
    ls <- mh $ posteriorLength
    let rxs = map (\(x,r) -> (x,getProduct r)) ls
    _ <- renderableToFile def "histogram.svg" (chart (toHistogram (take 100000 $ drop 100000 rxs) 0 40))
    return ()


{-# LANGUAGE CPP #-}
{- MatInv.hs
 - 4x4 Matrix invert function.
 - Direct implementation obtained from Maple's CodeGeneration
 -
 - Timothy A. Chagnon
 - CS 636 - Spring 2009
 -}
module MatInv where

#ifdef USING_HMATRIX
import MathHmatrix
import Numeric.LinearAlgebra
inverse4f :: Mat4f -> Mat4f
inverse4f = inv

#else
import MathDirect

-- Analytical solution via Maple (see minv.mw)
inverse4f :: Mat4f -> Mat4f
inverse4f   (Mat4f  (Vec4f m11 m12 m13 m14)
                    (Vec4f m21 m22 m23 m24)
                    (Vec4f m31 m32 m33 m34)
                    (Vec4f m41 m42 m43 m44)) =
    let t1 = m22 * m43 in
    let t3 = m22 * m44 in
    let t5 = m42 * m24 in
    let t7 = m44 * m32 in
    let t9 = m43 * m32 in
    let t11 = m42 * m23 in
    let t14 = m11 * m22 in
    let t15 = m43 * m34 in
    let t17 = m44 * m33 in
    let t19 = m11 * m42 in
    let t20 = m24 * m33 in
    let t22 = m11 * m44 in
    let t23 = m32 * m23 in
    let t25 = m11 * m43 in
    let t26 = m32 * m24 in
    let t28 = m23 * m34 in
    let t30 = m31 * m14 in
    let t32 = m22 * m41 in
    let t33 = m13 * m34 in
    let t35 = m14 * m33 in
    let t37 = m31 * m13 in
    let t39 = m43 * m31 in
    let t40 = m12 * m24 in
    let t42 = m21 * m12 in
    let t44 = -t14 * t15 + t14 * t17 - t19 * t20 - t22 * t23 + t25 * t26 + t19 * t28 + t1 * t30 + t32 * t33 - t32 * t35 - t3 * t37 - t39 * t40 - t17 * t42 in
    let t46 = m42 * m21 in
    let t50 = m41 * m12 in
    let t52 = m21 * m13 in
    let t54 = m41 * m14 in
    let t57 = m44 * m31 in
    let t58 = m12 * m23 in
    let t60 = m41 * m13 in
    let t62 = m21 * m14 in
    let t65 = t5 * t37 - t46 * t33 + t46 * t35 + t15 * t42 + t50 * t20 + t7 * t52 + t54 * t23 - t50 * t28 + t57 * t58 - t60 * t26 - t9 * t62 - t11 * t30 in
    let t67 = 1.0 / (t44 + t65) in
    let t121 = m44 * m21 in
    let t125 = m43 * m21 in
    let t146 = m41 * m32 in
    let t152 = m42 * m31 in
    let t172 = m32 * m11 in
    let t174 = m32 * m21 in
    let t176 = m31 * m12 in
    let r00 = (-t1 * m34 + t3 * m33 - t5 * m33 - t7 * m23 + t9 * m24 + t11 * m34) * t67 in
    let r01 = -(t17 * m12 + m42 * m13 * m34 - m42 * m14 * m33 - t15 * m12 - t7 * m13 + t9 * m14) * t67 in
    let r02 = (t1 * m14 - t3 * m13 - m43 * m12 * m24 + t5 * m13 + m44 * m12 * m23 - t11 * m14) * t67 in
    let r03 = -(-m22 * m13 * m34 + m22 * m14 * m33 - t40 * m33 - m14 * m32 * m23 + t58 * m34 + m13 * m32 * m24) * t67 in
    let r10 = -(t17 * m21 + m41 * m23 * m34 - t15 * m21 - t57 * m23 + t39 * m24 - m41 * m24 * m33) * t67 in
    let r11 = (-t25 * m34 + t22 * m33 + t39 * m14 + t60 * m34 - t54 * m33 - t57 * m13) * t67 in
    let r12 = -(t22 * m23 - t25 * m24 - t121 * m13 - t54 * m23 + t60 * m24 + t125 * m14) * t67 in
    let r13 = (-m11 * m24 * m33 + m11 * m23 * m34 + m24 * m31 * m13 - t52 * m34 + t62 * m33 - m23 * m31 * m14) * t67 in
    let r20 = (t32 * m34 - t3 * m31 + t5 * m31 - t46 * m34 + t7 * m21 - t146 * m24) * t67 in
    let r21 = -(t22 * m32 - t19 * m34 + t152 * m14 + t50 * m34 - t54 * m32 - t57 * m12) * t67 in
    let r22 = (t22 * m22 - t121 * m12 - t54 * m22 - t19 * m24 + t46 * m14 + t50 * m24) * t67 in
    let r23 = -(m34 * m11 * m22 - m34 * m21 * m12 - t30 * m22 - t172 * m24 + t174 * m14 + t176 * m24) * t67 in
    let r30 = -(-t1 * m31 + t32 * m33 - t46 * m33 + t11 * m31 - t146 * m23 + t9 * m21) * t67 in
    let r31 = (-t19 * m33 + t25 * m32 - t39 * m12 + t152 * m13 + t50 * m33 - t60 * m32) * t67 in
    let r32 = -(t25 * m22 - t125 * m12 - t60 * m22 - t19 * m23 + t46 * m13 + t50 * m23) * t67 in
    let r33 = t67 * (m33 * m11 * m22 - m33 * m21 * m12 - t37 * m22 - t172 * m23 + t174 * m13 + t176 * m23) in
    Mat4f   (Vec4f r00 r01 r02 r03)
            (Vec4f r10 r11 r12 r13)
            (Vec4f r20 r21 r22 r23)
            (Vec4f r30 r31 r32 r33)

#endif


-- stack bench --ba "--output bench.html"

import Criterion.Main
import Numeric.LinearAlgebra
import Linear.Matrix
import Linear.V4

-- the function to benchmark
fib m | m < 0     = error "negative!"
      | otherwise = go m
  where
    go 0 = 0
    go 1 = 1
    go n = go (n-1) + go (n-2)

hmatrixMult :: Double -> Matrix R
hmatrixMult m =
  let m1 = matrix 4 [m..(m + 15)] * ident 4
      m2 = (4><4) [m..] + row [1, 2, 3, 4]
  in m1 Numeric.LinearAlgebra.<> m2

linearMult :: Double -> V4 (V4 Double)
linearMult m =
  let m1 = V4 (V4 (m + 1) m m m) (V4 m (m + 6) m m) (V4 m m (m + 11) m) (V4 m m m (m + 16))
      m2 = (V4 (V4 (m + 1) (m + 3) (m + 5) (m + 7))
               (V4 (m + 5) (m + 7) (m + 9) (m + 11))
               (V4 (m + 9) (m + 11) (m + 13) (m + 15))
               (V4 (m + 13) (m + 15) (m + 17) (m + 19)))
  in m1 !*! m2

--data Row4 = Row4 [Double]
--data Matrix44 = Matrix44 [Row4]

matMult :: [[Double]] -> [[Double]] -> [[Double]]
matMult a b =
  let r0 = getRow a 0
      r1 = getRow a 1
      r2 = getRow a 2
      r3 = getRow a 3
      c0 = getColumn b 0
      c1 = getColumn b 1
      c2 = getColumn b 2
      c3 = getColumn b 3
  in [ [dotProduct r0 c0, dotProduct r0 c1, dotProduct r0 c2, dotProduct r0 c3]
     , [dotProduct r1 c0, dotProduct r1 c1, dotProduct r1 c2, dotProduct r1 c3]
     , [dotProduct r2 c0, dotProduct r2 c1, dotProduct r2 c2, dotProduct r2 c3]
     , [dotProduct r3 c0, dotProduct r3 c1, dotProduct r3 c2, dotProduct r3 c3]
     ]

getRow :: [[Double]] -> Int -> [Double]
getRow m i = m !! i

getColumn :: [[Double]] -> Int -> [Double]
getColumn m i = [ getRow m 0 !! i
                , getRow m 1 !! i
                , getRow m 2 !! i
                , getRow m 3 !! i
                ]

dotProduct :: [Double] -> [Double] -> Double
dotProduct row col = sum $ zipWith (*) row col

-- Matrix44 [(Row4 [1, 2, 3, 4]), (Row4 [1,2,3,4]), (Row4 [1,2,3,5]), (Row4 [1,2,3,6])]

naiveMult :: Double -> [[Double]]
naiveMult m =
  let m1 = [ [m + 1, m, m, m]
           , [m, m + 6, m, m]
           , [m, m, m + 11, m]
           , [m, m, m, m + 16]
           ]
      m2 = [ [m + 1, m + 3, m + 5, m + 7]
           , [m + 5, m + 7, m + 9, m + 11]
           , [m + 9, m + 11, m + 13, m + 15]
           , [m + 13, m + 15, m + 17, m + 19]
           ]
  in m1 `matMult` m2

-- Our benchmark harness.
main :: IO()
main = defaultMain [ bgroup "hmatrix" [ bench "mult 1" $ nf hmatrixMult 1.0
                                      ]
                   , bgroup "linear" [ bench "mult 1" $ nf linearMult 1.0
                                     ]
                   , bgroup "naive" [ bench "mult 1" $ nf naiveMult 1.0
                                     ]
                   ]


import Mandelbrot
import Data.Complex (Complex((:+)))
import Data.Array.MArray
import Data.Array.Storable
import Data.Word (Word32)
import Control.Monad
import Foreign.Ptr
import Foreign.Storable
import Criterion.Measurement
import Criterion.Types (Benchmarkable(..))
import Data.Int (Int64)

mandelbrotI = mandelbrot 10

mandelbrotArray :: Int -> Int -> IO ()
mandelbrotArray height width = do
    let widthF = fromIntegral width :: Double
        heightF = fromIntegral height :: Double
    array <- newArray_ (0, height*width-1) :: IO (StorableArray Int Word32)
    withStorableArray array (\pixels ->
        forM_ [0..height-1] (\y_ -> do
            forM_ [0..width-1] (\x_ -> do
                let x = 3/widthF * (fromIntegral x_) - 2
                    y = -2/heightF * (fromIntegral y_) + 1
                    mand = mandelbrotI (x :+ y)
                    color = if mand == 100 then 0 else 0xffffff
                pokeElemOff pixels (x_ + y_*width) color)))

simpleBenchmark :: Benchmarkable
simpleBenchmark = Benchmarkable (\tries ->
    forM_ [1..tries] (\_ ->
        mandelbrotArray 100 100))

main :: IO ()
main = secs <$> snd <$> measure simpleBenchmark 1 >>= printLn


{-# LANGUAGE FlexibleContexts #-}

import           AI.Layer
import           AI.Neuron

import           AI.Network
import           AI.Network.FeedForwardNetwork

import           AI.Trainer
import           AI.Trainer.BackpropTrainer

--import Network.Visualizations
import           Numeric.LinearAlgebra
import           System.IO
import           System.Random

main :: IO ()
main = do

  -- Convolutional Settings
  let field = 3
  let stride = 0
  let padding = 0
  let filters = 2
  let dimensions = 1
  let widthIn = 4
  let heightIn = 4
  let widthOut = 2
  let heightOut = 2
  let connectivity = connectLocally field stride padding filters dimensions widthIn heightIn widthOut heightOut
  let randomization = randomizeLocally field stride padding filters dimensions widthIn heightIn widthOut heightOut

  g <- newStdGen
  let l = LayerDefinition sigmoidNeuron (16 * dimensions) connectFully randomizeFully
  let l' = LayerDefinition sigmoidNeuron (4 * filters) connectivity randomization

  let n = createNetwork uniforms g [l, l'] :: FeedForwardNetwork

  print $ predict (fromList [0..15]) n


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
module Main where

import Lib
import Numeric.Vector.Sized
import Numeric.Layer.Affine
import Numeric.Network
import Numeric.Layer.Affine
import Numeric.Layer.Sigmoid
import Numeric.Loss.MeanSquaredError
import qualified Data.Array.Accelerate.Interpreter as AI
import qualified Data.Array.Accelerate.LLVM.Native as Native

v :: SizedVector 3
v = use (fromList [1, 2, 3]) .+. use (fromList [2, 3, 4])

xs :: SizedMatrix 2 3
xs = use (fromList [1 .. 6])
-- 1 2 3
-- 4 5 6

ys :: SizedMatrix 3 4
ys = use (fromList [1 .. 12])
-- 1 2 3 4
-- 5 6 7 8
-- 9 10 11 12
--
u = use (fromList [1, 2]) :: SizedVector 2
zs = use (fromList [1, 2, 3, 4]) :: SizedMatrix 2 2

aff = affine xs v u

net :: Network '[Affine 3 2, Sigmoid 2, Affine 2 2, Sigmoid 2]
net = Affine ws b :~> Sigmoid () :~> Affine ws' b' :~> Last (Sigmoid ())
  where
    ws  = fromList [1, 2, 3, 4, 5, 6]
    b   = fromList [1, 2]
    ws' = fromList [-2, 2, 0, 1]
    b'  = fromList [0, 1]

main :: IO ()
main = do
  print net'
  where
    net' = train
      net
      (MeanSquaredError () :: MeanSquaredError 2)
      (use $ fromList [-1, -2, -3])
      (use $ fromList [1, 2])

  -- print (runUsing Native.run v)
  -- print (runUsing Native.run (xs >< ys))
  -- print (runUsing Native.run (xs #> v))
  -- print (runUsing Native.run (u <# zs))
  -- print (runUsing Native.run aff)


-- | Hamiltonian Monte Carlo.  See, ex: Neal (2012)
--   http://arxiv.org/pdf/1206.1901.pdf.

module Strategy.Hamiltonian (hamiltonian) where

import Control.Monad.State.Strict
import Data.Maybe
import qualified Data.Vector.Storable as V
import Math.Probably.Sampler
import Math.Probably.Types
import Math.Probably.Utils
import Numeric.LinearAlgebra

-- | A Hamiltonian transition with step size and leapfrog increment tunables.
hamiltonian :: Maybe Double -> Maybe Int -> Transition (Double, Int)
hamiltonian e l = do
  Chain (ds, q0) target _ (te, tl) <- get
  let stepSize = fromMaybe te e
      nDisc    = fromMaybe tl l
      lTarget  = curry (logObjective target) ds
      glTarget = handleGradient $ gradient target

  r0 <- V.replicateM (dim q0) (lift unormal)
  zc <- lift unit
  let (q, r) = leapfrogIntegrator glTarget (q0, r0) stepSize nDisc
      next   = (ds, nextState lTarget (q0, q) (r0, r) zc)

  put $ Chain next target (logObjective target next) (stepSize, nDisc)
  return next

-- | The leapfrog or Stormer-Verlet integrator.
leapfrogIntegrator :: Gradient -> Particle -> Double -> Int -> Particle
leapfrogIntegrator glTarget (q0, r0) e = go q0 r0 where
  go q r 0 = (q, r)
  go q r n = let (q1, r1) = leapfrog glTarget (q, r) e
             in  go q1 r1 (pred n)

-- | The acceptance probability of a move.
acceptProb :: (Vector Double -> Double) -> Particle -> Particle -> Double
acceptProb lTarget (q0, q1) (r0, r1) = exp . min 0 $
  auxilliaryTarget lTarget (q1, r1) - auxilliaryTarget lTarget (q0, r0)

-- | The next state, given a proposal and random value from (0, 1).
nextState
  :: (Vector Double -> Double)
  -> Particle
  -> Particle
  -> Double
  -> ContinuousParams
nextState lTarget position momentum z
    | z < pAccept = snd position
    | otherwise   = fst position
  where
    pAccept = acceptProb lTarget position momentum


-- meanframe.hs
-- Compiles to executable.
-- We are passed a directory. We find any images in that directory,
-- average them, and save the average as average/average.png.
-- This tool is not used in the training or analysis of images.
import ImageToVector (loadImagesToVectors, vectorToImage)
import System.Environment (getArgs)
import Data.Maybe (catMaybes)
import System.Directory (getDirectoryContents)
import Data.Packed.Vector
import Numeric.LinearAlgebra.HMatrix (scale)
import Vision.Primitive.Shape (ix2)
import Vision.Image.Storage.DevIL
import Data.List (foldl')

main = do
  dir:_ <- getArgs
  let f = loadImagesToVectors 1280 720 . fmap ((dir++)"/"++)
  imgs <- fmap catMaybes $ f =<< getDirectoryContents dir
  let avgimg = vectorToImage (ix2 1280 720) $ avg imgs
  save PNG (dir ++ "/average/average.png") avgimg

avg :: [Vector Double] -> Vector Double
avg xs = scale (1 / fromIntegral num) sum
  where
  (num, sum) = foldl' f zero xs
  zero = (0, fromList . take (1280*720*3) . repeat $ 0)
  f (n,s) v = n `seq` s `seq` (n+1,v+s)


{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-}
{-# LANGUAGE MultiParamTypeClasses, NoMonomorphismRestriction      #-}
{-# LANGUAGE OverloadedStrings, PolyKinds, TypeFamilies            #-}
{-# LANGUAGE UndecidableInstances                                  #-}
{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans -Wall #-}
module Main where
import           Algebra.Bridge.Singular
import           Algebra.Prelude.Core
import           Control.Monad                   (void)
import           Control.Parallel.Strategies
import qualified Data.Text                       as T
import qualified Data.Vector.Unboxed             as V
import           Numeric.Field.Fraction          (Fraction)
import           Prelude                         (read)
import           Statistics.Resampling
import           Statistics.Resampling.Bootstrap
import           Statistics.Types
import qualified System.Random.MWC               as Rand

i2 :: [OrderedPolynomial (Fraction Integer) Grevlex 5]
i2 =  [35 * y^4 - 30*x*y^2 - 210*y^2*z + 3*x^2 + 30*x*z - 105*z^2 +140*y*t - 21*u
      ,5*x*y^3 - 140*y^3*z - 3*x^2*y + 45*x*y*z - 420*y*z^2 + 210*y^2*t -25*x*t + 70*z*t + 126*y*u
      ]
     where [t,u,x,y,z] = vars

i3 :: [OrderedPolynomial (Fraction Integer) Grevlex 4]
i3 = [ x^31 - x^6 - x- y, x^8 - z, x^10 -t]
  where
    [t,x,y,z] = vars

i4 :: [OrderedPolynomial (Fraction Integer) Grevlex 4]
i4 = [ w+x+y+z, w*x+x*y+y*z+z*w, w*x*y + x*y*z + y*z*w + z*w*x, w*x*y*z - 1]
  where
    [x,y,z,w] = vars

benchIdeal :: IsSingularPolynomial poly => Text -> Ideal poly -> IO Double
benchIdeal fun i = fmap ((/1000) . read . T.unpack) $ singular $
  toProg fun i

toProg :: (SingularOrder (Arity poly) (MOrder poly), SingularCoeff (Coefficient poly), IsOrderedPolynomial poly) => Text -> Ideal poly -> Text
toProg fun i =
  let expr = funE fun [idealE' i]
  in prettySingular $ do
    directC "system(\"--ticks-per-sec\", 1000000)"
    void $ ringC "R" expr
    declOnlyC IdealT "G"
    directC "timer=1"
    directC "int t=rtimer"
    letC "G" expr
    directC "print(rtimer-t)"
    directC "exit"

analyse :: (IsSingularPolynomial poly) => String -> Text -> Ideal poly -> IO ()
analyse lab fun ideal = do
  gen <- Rand.create
  i2Gr <- V.replicateM 200 $ benchIdeal fun ideal
  res  <- resample gen [Mean, StdDev] 1000 i2Gr
  let [Estimate mn (ConfInt lbmn ubmn _) ,Estimate dv _]
        = bootstrapBCA cl95 i2Gr res
  putStrLn lab
  putStrLn $ unlines $ map ('\t':)
    ["Mean:\t" ++ show mn ++ "(ms)"
    ,"MeanLB:\t" ++ show lbmn
    ,"MeanUB:\t" ++ show ubmn
    ,"StdDev:\t" ++ show dv
    ]

runTestCases :: (IsMonomialOrder n o, SingularCoeff k, KnownNat n)
             => String -> Ideal (OrderedPolynomial k o n) -> IO ()
runTestCases lab i = do
  analyse (lab ++ " (Lex, Sing(gr))") "groebner" $ fmap (changeOrder Lex) i
  analyse (lab ++ " (Lex, Sing(sba))") "sba" $ fmap (changeOrder Lex) i
  analyse (lab ++ " (Grevlex, Sing(gr))") "groebner" $ fmap (changeOrder Grevlex) i
  analyse (lab ++ " (Grevlex, Sing(sba))") "sba" $ fmap (changeOrder Grevlex) i

main :: IO ()
main = do
  ideal2 <- return $! (toIdeal i2 `using` rdeepseq)
  ideal3 <- return $! (toIdeal i3 `using` rdeepseq)
  ideal4 <- return $! (toIdeal i4 `using` rdeepseq)

  runTestCases "I1" ideal2
  runTestCases "Cyclic4" ideal4
  analyse "I3 (Grevlex, Sing(gr))" "groebner" ideal3
  analyse "I3 (Grevlex, Sing(sba))" "sba" ideal3
  -- analyse "groebner" ideal4
  -- analyse "sba" ideal4
  -- analyse "groebner" ideal3
  -- analyse "sba" ideal3
  -- defaultMainWith defaultConfig $
  --      mkTestCases (Left 1) ideal2
  --   ++ mkTestCases (Right "Cyclic-4") ideal4
  --   ++ [mkTC "grevlex03" ideal3]


#!/usr/bin/env stack
-- stack runghc --resolver lts-16 --package ad --package hmatrix-vector-sized-0.1.3.0 --package vector-sized --package hmatrix --package comonad --package free

-- | Source file accompanying
-- https://blog.jle.im/entry/hamiltonian-dynamics-in-haskell.html

{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns        #-}

import           Data.Foldable
import           Data.Maybe
import           GHC.TypeLits
import           Numeric.AD
import           Numeric.LinearAlgebra.Static
import           Numeric.LinearAlgebra.Static.Vector
import qualified Control.Comonad                     as C
import qualified Control.Comonad.Cofree              as C
import qualified Data.Vector.Sized                   as V

-- | A @'System' m n@ represents a system parameterized by @n@ generalized
-- coordinates, moving in an "underlying" @m@-dimensional cartesian
-- coordinate system.
data System m n = System
    { sysInertia       :: R m                         -- ^ 'm' vector
    , sysCoords        :: R n -> R m                  -- ^ f
    , sysJacobian      :: R n -> L m n                -- ^ J_f
    , sysHessian       :: R n -> V.Vector n (L m n)   -- ^ H_f
    , sysPotential     :: R n -> Double               -- ^ U
    , sysPotentialGrad :: R n -> R n                  -- ^ grad U
    }

-- | A system's position in configuration space
data Config n = Config
    { confPositions  :: R n
    , confVelocities :: R n
    }
  deriving Show

-- | A system's position in phase space
data Phase n = Phase
    { phasePositions :: R n
    , phaseMomenta   :: R n
    }
  deriving Show

-- | Given a position in @n@-dimensional generalized coordinates, return
-- the position in the underlying @m@-dimensional cartesian coordinate
-- system.
underlyingPosition
    :: System m n
    -> R n
    -> R m
underlyingPosition = sysCoords

-- | Give the system's generalized momenum, given its position in
-- configuration space.
momenta
    :: (KnownNat n, KnownNat m)
    => System m n
    -> Config n
    -> R n
momenta s (Config q v) = tr j #> mHat #> j #> v
  where
    j    = sysJacobian s q
    mHat = diag (sysInertia s)

-- | Convert a position in configuration space to a position in phase space
toPhase
    :: (KnownNat n, KnownNat m)
    => System m n
    -> Config n
    -> Phase n
toPhase s c = Phase (confPositions c) (momenta s c)

-- | Shift around the Hessian into the shape expected
tr2 :: (KnownNat m, KnownNat n)
    => V.Vector m (L n n)
    -> V.Vector n (L m n)
tr2 = fmap rowsL . traverse lRows
{-# INLINE tr2 #-}

-- | Vector of vectors to matrix
vec2l
    :: KnownNat n
    => V.Vector m (V.Vector n Double)
    -> L m n
vec2l = rowsL . fmap gvecR
{-# INLINE vec2l #-}

-- | Make a system given its inertias, coordinate functions, and potential
-- energy function
mkSystem
    :: (KnownNat m, KnownNat n)
    => R m
    -> (forall a. RealFloat a => V.Vector n a -> V.Vector m a)
    -> (forall a. RealFloat a => V.Vector n a -> a)
    -> System m n
mkSystem m f u = System
                    -- < convert from      | actual thing | convert to >
    { sysInertia       =                     m
    , sysCoords        =        gvecR      . f            . grVec
    , sysJacobian      = tr   . vec2l      . jacobianT f  . grVec
    , sysHessian       = tr2  . fmap vec2l . hessianF f   . grVec
    , sysPotential     =                     u            . grVec
    , sysPotentialGrad =        gvecR      . grad u       . grVec
    }

-- | Equations of motion for a system at a given position in phase space
hamilEqns
    :: (KnownNat n, KnownNat m)
    => System m n
    -> Phase n
    -> (R n, R n)       -- dq/dt and dp/dt
hamilEqns s (Phase q p) = (dqdt, dpdt)
  where
    j       = sysJacobian s q
    trj     = tr j
    mHat    = diag (sysInertia s)
    kHat    = trj `mul` mHat `mul` j
    kHatInv = inv kHat
    dqdt    = kHatInv #> p
    dpdt    = gvecR bigUglyThing - sysPotentialGrad s q
      where
        bigUglyThing =
          fmap (\j2 -> -p <.> kHatInv #> trj #> mHat #> j2 #> kHatInv #> p)
               (sysHessian s q)

-- | Step a system's position through phase space using Euler integration
stepEuler
    :: (KnownNat n, KnownNat m)
    => System m n       -- ^ the system
    -> Double           -- ^ dt
    -> Phase n          -- ^ q(t) and p(t)
    -> Phase n          -- ^ q(t + dt) and p(t + dt)
stepEuler s dt ph@(Phase q p) = Phase (q + konst dt * dq) (p + konst dt * dp)
  where
    (dq, dp) = hamilEqns s ph

-- | Iterate Euler's method to repeatedly step a system through phase space
runSystem
    :: (KnownNat n, KnownNat m)
    => System m n       -- ^ the system
    -> Double           -- ^ dt
    -> Phase n          -- ^ initial phase
    -> [Phase n]        -- ^ progression of the system using Euler integration
runSystem s dt = go
  where
    go p0 = p0 : go (stepEuler s dt p0)

-- | A simple particle in 2D cartesian space under gravity
simpleSystem :: System 2 2
simpleSystem = mkSystem (vec2 5 5) id pot
  where
    -- potential energy of a gravity field
    -- U(x,y) = 9.8 * y
    pot :: RealFloat a => V.Vector 2 a -> a
    pot xy = 9.8 * (xy `V.index` 1)

-- | An initial position in configuration space, representing a particle
-- at <0,0> with initial velocity <1,3>
simpleConfig0 :: Config 2
simpleConfig0 = Config
    { confPositions  = vec2 0 0
    , confVelocities = vec2 1 3
    }

simpleMain :: IO ()
simpleMain =
    mapM_ (disp 2 . phasePositions)  -- position with 2 digits of precision
  . take 25                          -- 25 steps
  $ runSystem simpleSystem 0.1 (toPhase simpleSystem simpleConfig0)

-- | A pendulum system, parameterized by its angle clockwise from
-- equilibrium
pendulum :: System 2 1
pendulum = mkSystem (vec2 5 5) coords pot      -- 5kg particle
  where
    -- <x,y> = <-0.5 sin(theta), -0.5 cos(theta)>
    -- pendulum of length 0.25
    coords :: RealFloat a => V.Vector 1 a -> V.Vector 2 a
    coords (V.head->theta) = V.fromTuple (- 0.25 * sin theta, - 0.25 * cos theta)
    -- potential energy of gravity field
    -- U(x,y) = 9.8 * y
    pot :: RealFloat a => V.Vector 1 a -> a
    pot q = 9.8 * (coords q `V.index` 1)

-- | An initial pendulum position in configuration space, representing
-- a pendulum at equilibrium with initial angular velocity 0.1 rad/sec
-- clockwise
pendulumConfig0 :: Config 1
pendulumConfig0 = Config
    { confPositions  = 0
    , confVelocities = 0.1
    }

pendulumMain :: IO ()
pendulumMain =
    mapM_ (disp 3 . phasePositions)  -- position with 2 digits of precision
  . take 25                          -- 25 steps
  $ runSystem pendulum 0.1 (toPhase pendulum pendulumConfig0)

main :: IO ()
main = pendulumMain


{-# LANGUAGE ScopedTypeVariables #-}
--
{-# OPTIONS_GHC -fno-warn-orphans #-}
import Data.Monoid
import Data.Typeable
import Numeric.Sum
import Test.Tasty
import Test.Tasty.QuickCheck

import Statistics.Monoid
import Statistics.Monoid.Extra

data T a = T

p_memptyIsNeutral
  :: forall m. (Monoid m, Arbitrary m, Show m, Eq m)
  => T m -> TestTree
p_memptyIsNeutral _
  = testProperty "mempty is neutral" $ \(m :: m) ->
       (m <> mempty) == m
    && (mempty <> m) == m

p_associativity
  :: forall m. (Monoid m, Arbitrary m, Show m, Eq m)
  => T m -> TestTree
p_associativity _
  = testProperty "associativity" $ \(a :: m) b c ->
    let val1 = (a <> b) <> c
        val2 = a <> (b <> c)
    in counterexample ("left : " ++ show val1)
     $ counterexample ("right: " ++ show val2)
     $ val1 == val2

p_commutativity
  :: forall m. (Monoid m, Arbitrary m, Show m, Eq m)
  => T m -> TestTree
p_commutativity _
  = testProperty "commutativity" $ \(a :: m) b ->
    (a <> b) == (b <> a)

p_addValue1
  :: forall a m. ( StatMonoid m a
                 , Arbitrary m, Show m, Eq m
                 , Arbitrary a, Show a, Eq a)
  => T a -> T m -> TestTree
p_addValue1 _ _
  = testProperty "addValue x mempty == singletonMonoid" $ \(a :: a) ->
    singletonMonoid a == addValue (mempty :: m) a

p_addValue2
  :: forall a m. ( StatMonoid m a
                 , Arbitrary m, Show m, Eq m
                 , Arbitrary a, Show a, Eq a)
  => T a -> T m -> TestTree
p_addValue2 _ _
  = testProperty "addValue law" $ \(x :: a) (y :: a) ->
    let val1 = addValue (addValue mempty y) x
        val2 = (addValue mempty x <> addValue (mempty :: m) y)
    in counterexample ("left : " ++ show val1)
     $ counterexample ("right: " ++ show val2)
     $ val1 == val2

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

testType :: forall m. Typeable m => T m -> [T m -> TestTree] -> TestTree
testType t props = testGroup (show (typeOf (undefined :: m)))
                             (fmap ($ t) props)

main :: IO ()
main = defaultMain $ testGroup "monoid-statistics"
  [ testType (T :: T (CountG Int))
      [ p_memptyIsNeutral
      , p_associativity
      , p_commutativity
      , p_addValue1 (T :: T Int)
      , p_addValue2 (T :: T Int)
      ]
  , testType (T :: T (Min Int))
      [ p_memptyIsNeutral
      , p_associativity
      , p_commutativity
      , p_addValue1 (T :: T Int)
      , p_addValue2 (T :: T Int)
      ]
  , testType (T :: T (Max Int))
      [ p_memptyIsNeutral
      , p_associativity
      , p_commutativity
      , p_addValue1 (T :: T Int)
      , p_addValue2 (T :: T Int)
      ]
  , testType (T :: T MinD)
      [ p_memptyIsNeutral
      , p_associativity
      , p_commutativity
      , p_addValue1 (T :: T Double)
      , p_addValue2 (T :: T Double)
      ]
  , testType (T :: T MaxD)
      [ p_memptyIsNeutral
      , p_associativity
      , p_commutativity
      , p_addValue1 (T :: T Double)
      , p_addValue2 (T :: T Double)
      ]
  , testType (T :: T BinomAcc)
      [ p_memptyIsNeutral
      , p_associativity
      , p_commutativity
      , p_addValue1 (T :: T Bool)
      , p_addValue2 (T :: T Bool)
      ]
  , testType (T :: T WelfordMean)
      [ p_memptyIsNeutral
      -- , p_associativity
      , p_commutativity
      , p_addValue1 (T :: T Double)
      -- , p_addValue2 (T :: T Double)
      ]
  , testType (T :: T MeanKBN)
      [ p_memptyIsNeutral
      -- , p_associativity
      -- , p_commutativity
      , p_addValue1 (T :: T Double)
      , p_addValue2 (T :: T Double)
      ]
  , testType (T :: T MeanKahan)
      [ p_memptyIsNeutral
      -- , p_associativity
      -- , p_commutativity
      , p_addValue1 (T :: T Double)
      -- , p_addValue2 (T :: T Double)
      ]
  , testType (T :: T Variance)
      [ p_memptyIsNeutral
      -- , p_associativity
      , p_commutativity
      , p_addValue1 (T :: T Double)
      , p_addValue2 (T :: T Double)
      ]
  ]

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

instance (Arbitrary a, Num a, Ord a) => Arbitrary (CountG a) where
  arbitrary = do
    NonNegative n <- arbitrary
    return (CountG n)

instance (Arbitrary a) => Arbitrary (Max a) where
  arbitrary = fmap Max arbitrary

instance (Arbitrary a) => Arbitrary (Min a) where
  arbitrary = fmap Min arbitrary

instance Arbitrary MinD where
  arbitrary = frequency [ (1, return mempty)
                        , (4, fmap MinD arbitrary)
                        ]

instance Arbitrary MaxD where
  arbitrary = frequency [ (1, return mempty)
                        , (4, fmap MaxD arbitrary)
                        ]

instance Arbitrary BinomAcc where
  arbitrary = do
    NonNegative nSucc <- arbitrary
    NonNegative nFail <- arbitrary
    return $ BinomAcc nSucc (nFail + nSucc)

instance Arbitrary WelfordMean where
  arbitrary = arbitrary >>= \x -> case x of
    NonNegative 0 -> return mempty
    NonNegative n -> do m <- arbitrary
                        return (WelfordMean n m)

instance Arbitrary Variance where
  arbitrary = arbitrary >>= \x -> case x of
    NonNegative 0 -> return mempty
    NonNegative n -> do
      m             <- arbitrary
      NonNegative s <- arbitrary
      return $ Variance n m s

instance Arbitrary MeanKBN where
  arbitrary = arbitrary >>= \x -> case x of
    NonNegative 0 -> return mempty
    NonNegative n -> do
      x1 <- arbitrary
      x2 <- arbitrary
      x3 <- arbitrary
      return $ MeanKBN n (((zero `add` x1) `add` x2) `add` x3)

instance Arbitrary MeanKahan where
  arbitrary = arbitrary >>= \x -> case x of
    NonNegative 0 -> return mempty
    NonNegative n -> do
      x1 <- arbitrary
      x2 <- arbitrary
      x3 <- arbitrary
      return $ MeanKahan n (((zero `add` x1) `add` x2) `add` x3)


{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric #-}
-- |
-- Module    : Statistics.Distribution.Normal
-- Copyright : (c) 2009 Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- The normal distribution.  This is a continuous probability
-- distribution that describes data that cluster around a mean.

module Statistics.Distribution.Normal
    (
      NormalDistribution
    -- * Constructors
    , normalDistr
    , normalFromSample
    , standard
    ) where

import Data.Aeson (FromJSON, ToJSON)
import Control.Applicative ((<$>), (<*>))
import Data.Binary (Binary)
import Data.Binary (put, get)
import Data.Data (Data, Typeable)
import GHC.Generics (Generic)
import Numeric.MathFunctions.Constants (m_sqrt_2, m_sqrt_2_pi)
import Numeric.SpecFunctions (erfc, invErfc)
import qualified Statistics.Distribution as D
import qualified Statistics.Sample as S
import qualified System.Random.MWC.Distributions as MWC

-- | The normal distribution.
data NormalDistribution = ND {
      mean       :: {-# UNPACK #-} !Double
    , stdDev     :: {-# UNPACK #-} !Double
    , ndPdfDenom :: {-# UNPACK #-} !Double
    , ndCdfDenom :: {-# UNPACK #-} !Double
    } deriving (Eq, Read, Show, Typeable, Data, Generic)

instance FromJSON NormalDistribution
instance ToJSON NormalDistribution

instance Binary NormalDistribution where
    put (ND w x y z) = put w >> put x >> put y >> put z
    get = ND <$> get <*> get <*> get <*> get

instance D.Distribution NormalDistribution where
    cumulative      = cumulative
    complCumulative = complCumulative

instance D.ContDistr NormalDistribution where
    logDensity = logDensity
    quantile   = quantile

instance D.MaybeMean NormalDistribution where
    maybeMean = Just . D.mean

instance D.Mean NormalDistribution where
    mean = mean

instance D.MaybeVariance NormalDistribution where
    maybeStdDev   = Just . D.stdDev
    maybeVariance = Just . D.variance

instance D.Variance NormalDistribution where
    stdDev = stdDev

instance D.Entropy NormalDistribution where
  entropy d = 0.5 * log (2 * pi * exp 1 * D.variance d)

instance D.MaybeEntropy NormalDistribution where
  maybeEntropy = Just . D.entropy

instance D.ContGen NormalDistribution where
    genContVar d = MWC.normal (mean d) (stdDev d)

-- | Standard normal distribution with mean equal to 0 and variance equal to 1
standard :: NormalDistribution
standard = ND { mean       = 0.0
              , stdDev     = 1.0
              , ndPdfDenom = log m_sqrt_2_pi
              , ndCdfDenom = m_sqrt_2
              }

-- | Create normal distribution from parameters.
--
-- IMPORTANT: prior to 0.10 release second parameter was variance not
-- standard deviation.
normalDistr :: Double            -- ^ Mean of distribution
            -> Double            -- ^ Standard deviation of distribution
            -> NormalDistribution
normalDistr m sd
  | sd > 0    = ND { mean       = m
                   , stdDev     = sd
                   , ndPdfDenom = log $ m_sqrt_2_pi * sd
                   , ndCdfDenom = m_sqrt_2 * sd
                   }
  | otherwise =
    error $ "Statistics.Distribution.Normal.normalDistr: standard deviation must be positive. Got " ++ show sd

-- | Create distribution using parameters estimated from
--   sample. Variance is estimated using maximum likelihood method
--   (biased estimation).
normalFromSample :: S.Sample -> NormalDistribution
normalFromSample xs
  = normalDistr m (sqrt v)
  where
    (m,v) = S.meanVariance xs

logDensity :: NormalDistribution -> Double -> Double
logDensity d x = (-xm * xm / (2 * sd * sd)) - ndPdfDenom d
    where xm = x - mean d
          sd = stdDev d

cumulative :: NormalDistribution -> Double -> Double
cumulative d x = erfc ((mean d - x) / ndCdfDenom d) / 2

complCumulative :: NormalDistribution -> Double -> Double
complCumulative d x = erfc ((x - mean d) / ndCdfDenom d) / 2

quantile :: NormalDistribution -> Double -> Double
quantile d p
  | p == 0         = -inf
  | p == 1         = inf
  | p == 0.5       = mean d
  | p > 0 && p < 1 = x * ndCdfDenom d + mean d
  | otherwise      =
    error $ "Statistics.Distribution.Normal.quantile: p must be in [0,1] range. Got: "++show p
  where x          = - invErfc (2 * p)
        inf        = 1/0


{-# LANGUAGE FlexibleContexts #-}

module Network.Visualizations
( networkHistogram
, weightList
, biasList
) where

import Numeric.LinearAlgebra
import Network.Neuron
import Network.Layer
import Network.Network
import Network.Network.FeedForwardNetwork

import Network.Trainer
import Data.Foldable (foldMap, )
import Graphics.Histogram
import GHC.Float

weightList :: FeedForwardNetwork -> [Double]
weightList n = concat $ map (toList . flatten . weightMatrix) (layers n)

biasList :: FeedForwardNetwork -> [Double]
biasList n = concat $ map (toList . biasVector) (layers n)

networkHistogram :: FilePath -> (FeedForwardNetwork -> [Double]) -> FeedForwardNetwork -> IO ()
networkHistogram filename listFunction n = do
  let hist = histogram binSturges (listFunction n)
  plot filename hist
  return ()


module Chapter08 where

import Numeric.LinearAlgebra.Data
--import Numeric.LinearAlgebra.Algorithms
import Numeric.LinearAlgebra.HMatrix
import Data.List as L

import Chapter04
import Chapter06
import Chapter07

stopWords :: [String]
stopWords = ["a", "about", "above", "above", "across", "after",
    "afterwards", "again", "against", "all", "almost", "alone", "along",
    "already", "also", "although", "always", "am", "among", "amongst",
    "amoungst", "amount", "an", "and", "another", "any", "anyhow",
    "anyone", "anything", "anyway", "anywhere", "are", "around", "as",
    "at", "back", "be", "became", "because", "become", "becomes",
    "becoming", "been", "before", "beforehand", "behind", "being",
    "below", "beside", "besides", "between", "beyond", "bill", "both",
    "bottom", "but", "by", "call", "can", "cannot", "cant", "co", "con",
    "could", "couldnt", "cry", "de", "describe", "detail", "do", "done",
    "dont", "down", "due", "during", "each", "eg", "eight", "either",
    "eleven", "else", "elsewhere", "empty", "enough", "etc", "even",
    "ever", "every", "everyone", "everything", "everywhere", "except",
    "few", "fifteen", "fifty", "fill", "find", "fire", "first", "five",
    "for", "former", "formerly", "forty", "found", "four", "from",
    "front", "full", "further", "get", "give", "go", "got", "had", "has",
    "hasnt", "have", "he", "hence", "her", "here", "hereafter", "hereby",
    "herein", "hereupon", "hers", "herself", "him", "himself", "his",
    "how", "however", "hundred", "i", "ie", "if", "im", "in", "inc",
    "indeed", "interest", "into", "is", "it", "its", "itself", "just",
    "keep", "last", "latter", "latterly", "least", "less", "ltd", "made",
    "many", "may", "me", "meanwhile", "might", "mill", "mine", "more",
    "moreover", "most", "mostly", "move", "much", "must", "my", "myself",
    "name", "namely", "neither", "need", "never", "nevertheless",
    "next", "nine", "no", "nobody", "none", "noone", "nor", "not",
    "nothing", "now", "nowhere", "of", "off", "often", "on", "once",
    "one", "only", "onto", "or", "other", "others", "otherwise", "our",
    "ours", "ourselves", "out", "over", "own", "part", "per", "perhaps",
    "please", "put", "rather", "re", "same", "see", "seem", "seemed",
    "seeming", "seems", "serious", "several", "she", "should", "show",
    "side", "since", "sincere", "six", "sixty", "so", "some", "somehow",
    "someone", "something", "sometime", "sometimes", "somewhere", "still",
    "such", "system", "take", "ten", "than", "that", "the", "their",
    "them", "themselves", "then", "thence", "there", "thereafter",
    "thereby", "therefore", "therein", "thereupon", "these", "they",
    "thick", "thin", "third", "this", "those", "though", "three",
    "through", "throughout", "thru", "thus", "to", "together", "too",
    "top", "toward", "towards", "twelve", "twenty", "two", "un", "under",
    "until", "up", "upon", "us", "very", "via", "want", "was", "we",
    "well", "were", "what", "whatever", "when", "whence", "whenever",
    "where", "whereafter", "whereas", "whereby", "wherein", "whereupon",
    "wherever", "whether", "which", "while", "whither", "who", "whoever",
    "whole", "whom", "whose", "why", "will", "with", "within", "without",
    "would", "yet", "you", "your", "youre", "yours", "yourself",
    "yourselves", "rt", "mt", "u"]

principalComponentAnalysis :: [[Double]] -> Integer -> Matrix Double
principalComponentAnalysis records top =
    tr $ mul (tr topOrderedEvectors) (tr featureVectors)
  where featureVectors = fromLists records
        (_, covMatrix) = meanCov featureVectors
        (_, evectors) = eigSH covMatrix
        topOrderedEvectors = takeColumns (fromInteger top) evectors

euclidianDistanceSqrdFromRow :: Matrix Double -> Integer -> Vector Double
euclidianDistanceSqrdFromRow records row =
    sumOfSquaresVector
  where d = cols records
        copyMatrix = repmat (subMatrix (fromIntegral row, 0) (1,d) records) (rows records) 1
        diffMatrix = records - copyMatrix
        diffSqrdMatrix = diffMatrix * diffMatrix
        sumOfSquaresVector = sum $ toColumns diffSqrdMatrix

order :: Eq a => [a] -> [a] -> [Integer]
order unsorted nubSorted =
    concatMap
        (\x -> L.map toInteger $ L.elemIndices x unsorted)
        nubSorted

findClosestFeaturesToRow :: Matrix Double -> Integer -> Integer -> [Integer]
findClosestFeaturesToRow records row knn =
    take (fromIntegral knn) orderOfFeatures
  where sumOfSquares = toList $ euclidianDistanceSqrdFromRow records row
        orderOfFeatures = order sumOfSquares . nub $ sort sumOfSquares


{-# LANGUAGE FlexibleContexts, NamedFieldPuns #-}

module School.Train.SimpleDescentUpdate
( simpleDescentUpdate ) where

import Numeric.LinearAlgebra (Container, Vector, add, scale)
import School.Train.TrainState (TrainState(..))
import School.Train.UpdateParams (UpdateParams)
import School.Types.PingPong (pingPongList, toPingPong)
import School.Unit.UnitParams (UnitParams(..))

update :: (Container Vector a, Num a)
       => a
       -> UnitParams a
       -> UnitParams a
       -> UnitParams a
update rate
       AffineParams { affineBias = bias
                    , affineWeights = weights}
       AffineParams { affineBias = biasGrad
                    , affineWeights = weightGrad } =
  AffineParams { affineBias, affineWeights } where
    affineBias = add bias (scale (-rate) biasGrad)
    affineWeights = add weights (scale (-rate) weightGrad)
update _ _ _ = EmptyParams

simpleDescentUpdate :: (Container Vector a, Num a)
                    => UpdateParams a
simpleDescentUpdate state@TrainState { paramDerivs
                                     , paramList
                                     , learningRate
                                     } = do
  newParamList <- toPingPong $
         zipWith (update learningRate)
                 (pingPongList paramList)
                 paramDerivs
  return state { paramList = newParamList }


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Main where

import qualified Prelude as P
import Data.Array.Accelerate.Data.Complex as A
import Data.Array.Accelerate as A
-- import qualified Data.Array.Accelerate.Fourier.Adhoc as A
import qualified Data.Array.Accelerate.Interpreter as I
import Data.Array.Accelerate.Interpreter as I
import Data.Array.Accelerate.Data.Fold
import Data.Array.Accelerate.Data.Monoid
import qualified Data.List as L
import qualified Data.Array.Accelerate.LLVM.PTX as PTX

import qualified Data.Csv as CSV
import qualified Data.ByteString.Lazy as BS
import qualified Statistics.Sample as S
import qualified Data.Vector as V

type Arr a = Acc (Vector a)

mean :: (Floating a, FromIntegral Int a) => Arr a -> Acc (Scalar a)
mean xs = unit $ the (fold (+) 0 xs) / (fromIntegral $ length xs)

smooth :: (Floating a, FromIntegral Int a) => Arr a -> Exp Int -> Arr a
smooth xs res = error "LOL"

sumF :: (Elt a, Lift Exp a, P.Num (Exp a)) => Fold (Exp a) (Exp a)
sumF = Fold (lift . Sum) (getSum . unlift)

lengthF :: (Elt a, Lift Exp a, P.Num (Exp a)) => Fold (Exp a) (Exp a)
lengthF = Fold (\_ -> 1) (getSum . unlift)

meanF :: (Elt a, Lift Exp a, P.Fractional (Exp a)) => Fold (Exp a) (Exp a)
meanF = sumF / lengthF

valF :: (Elt a, Monoid (Exp a)) => Fold (Exp a) (Exp a)
valF = Fold P.id P.id

-- | E(X^2)
sumOfSquaresF :: (Elt a, Lift Exp a, P.Num (Exp a)) => Fold (Exp a) (Exp a)
sumOfSquaresF = Fold (lift . Sum . (^(2 :: Exp Int))) (getSum . unlift)

-- | sqrt (E(X^2) - E(X) ^ 2)
standardDeviationF :: (Elt a, Lift Exp a, P.Floating (Exp a)) => Fold (Exp a) (Exp a)
standardDeviationF = sqrt $ (sumOfSquaresF / lengthF) - (meanF * meanF)

-- | E(X - mu) ^ 4
-- differenceQuadsF :: (Elt a, Lift Exp a, P.Fractional (Exp a), Monoid (Exp a)) => Fold (Exp a) (Exp a)
-- differenceQuadsF = (\m -> Fold (\x -> lift $ Sum ((x - m) ^ e)) (getSum . unlift)) P.<$> meanF
--   where
--     e = 4 :: Exp Int

-- | E((X - u)^2)^2
-- otherThing :: (Elt a, Lift Exp a, P.Fractional (Exp a), Monoid (Exp a)) => Fold (Exp a) (Exp a)
-- otherThing = Fold (lift . Sum . (^(2 :: Exp Int))) (getSum . unlift)

-- kurtosisF :: (Elt a, Lift Exp a, P.Fractional (Exp a), Monoid (Exp a)) => Fold (Exp a) (Exp a)
-- kurtosisF = (valF - meanF)

-- | Kurt(X) = E(X - u)^4/(E((X - u)^2)^2)
-- (mean (map (\x -> x - u) xs)) ^ four / ((mean (map (\x -> (x - u) ^ two) xs))^two)
kurtosis :: (Floating a, Elt a, FromIntegral Int a) => Arr a -> Exp a
kurtosis xs = (u4 / (variance P.^ 2))
  where
    u4 = the $ compute $ mean $ map (\x -> (x - u) ^ (4 :: Exp Int)) xs
    variance = the $ compute $ mean $ map (\x -> (x - u) ^ (2 :: Exp Int)) xs
    u = the $ compute $ mean xs

diffs :: (Elt a, P.Num (Exp a)) => Arr a -> Arr a
diffs xs = zipWith (-) (tail xs) xs

roughness :: (Elt a, P.Floating (Exp a), FromIntegral Int a, Lift Exp a) => Arr a -> Acc (Scalar a)
roughness xs = compute $ runFold standardDeviationF $ diffs xs

-- smoothSimple :: (Elt a, Floating a, FromIntegral Int a, Ord a) => Arr a -> Exp Int -> Arr a
-- smoothSimple xs resolution =
--   ifThenElse (resolution < length xs)
--     smaLargeResolution
--     (sma bestWindowSize 1 xs)
--   where
--     -- THIS IS WRONG. IT NEEDS TO MINIMIZE THE ROUGHNESS
--     bestWindowSize =  the $ minimum $ map fst $ afst $ filter acceptableWindow $ map (go xs) ws
--     acceptableWindow b =
--       (r < originalRoughness) && (k >= originalKurt)
--       where
--         r = fst $ snd b
--         k = snd $ snd b
--     smaLargeResolution = sma (length xs `div` resolution) (length xs `div` resolution) xs
--     originalKurt = kurtosis xs
--     originalRoughness = the $ roughness xs
--     end :: Exp Int
--     end = length xs `div` 10
--     ws :: Arr Int
--     ws = enumFromN (index1 $ end - 2) 2

-- smoothSimple' :: (Elt a, Floating a, FromIntegral Int a, Ord a) => Arr a -> Exp Int -> Arr a
-- smoothSimple' xs resolution = sma bestWindowSize 1 xs
--   where
--     bestWindowSize =
--       fst $ while (\a -> fst a >= 2) godude $ lift ((length xs `div` resolution), (originalRoughness, 1 :: Exp Int))
--     originalKurt = kurtosis xs
--     originalRoughness = the $ roughness xs
--     godude a =
--       let
--         w = fst a
--         minObj = fst $ snd a
--         smoothed = sma w 1 xs
--         r = the $ roughness smoothed
--         kurt = kurtosis smoothed
--       in ifThenElse (r < minObj && kurt >= originalKurt) (lift (w-1, (r, w))) (lift (w-1, snd a))

-- go :: (Elt a, P.Floating (Exp a), FromIntegral Int a) => Arr a -> Exp Int -> Exp (Int, (a, a))
-- go xs w = lift (w,(the $ roughness smoothed, kurtosis smoothed))
--   where
--     smoothed = sma w 1 xs

sma :: (Floating a, FromIntegral Int a) => Exp Int -> Exp Int -> Arr a -> Arr a
sma range slide xs = mavg range xs
  where
    skip ys =
      map snd. afst
        $ filter (\y -> fst y `mod` slide == 0)
          $ imap (\i y -> lift (unindex1 i, y)) ys

computeStuff :: (Floating a, FromIntegral Int a, Lift Exp a) => Exp Int -> Exp Int -> Arr a -> Exp (a, a)
computeStuff resolution window xs = lift (the $ roughness smoothed, kurtosis smoothed)
  where
    smoothed = sma window resolution xs

kurtAndRoughness :: (Floating a, FromIntegral Int a, Lift Exp a) => Arr a -> Exp (a, a)
kurtAndRoughness xs = lift (the $ roughness xs, kurtosis xs)

mavg :: (Floating a, FromIntegral Int a) => Exp Int -> Arr a -> Arr a
mavg k xs =
  map (/ fromIntegral k)
    $ scanl (+) (the $ sum h)
      $ zipWith (-) t xs
  where
    h = take k xs
    t = drop k xs

-- transform :: Arr (Complex Double) -> Arr (Complex Double)
-- transform = A.transform A.forward

-- inverseTransform :: Arr (Complex Double) -> Arr (Complex Double)
-- inverseTransform = A.transform A.inverse

binarySearch :: Int -> Int -> Arr (Complex Double) -> a -> a -> a -> ()
binarySearch h t xs minObj originalKurt windowSize = ()

main :: P.IO ()
main = do
  P.Right xs <- CSV.decode CSV.HasHeader P.<$> BS.readFile "data.csv" :: P.IO (P.Either P.String (V.Vector (P.String, Double)))

  let
    -- use accelerate-io
    v = V.toList $ P.snd P.<$> xs :: [Double]
    vec = use $ fromList (Z :. (V.length xs)) v
    ws = P.reverse [2..V.length xs `div` 10]
    [(minObj, originalKurt)] = toList $ PTX.runN $ unit $ kurtAndRoughness vec
    runOnWindow w = P.head $ toList $ PTX.runN $ unit $ computeStuff 1 (constant w) vec
    roughsAndKurts = (\w -> (w, runOnWindow w)) P.<$> ws
    bestWindow@(_, w) = L.foldl' goman (minObj, 1) roughsAndKurts
    goman old@(obj, _) (w,(r, k)) = if (r P.< obj P.&& k P.>= originalKurt) then (r,w) else old
    smoothed = PTX.run $ sma (constant w) 1 vec
  P.print $ L.take 100 roughsAndKurts
  P.print $ (minObj, originalKurt)
  P.print $ V.length xs
  P.print smoothed
  -- P.print $ S.kurtosis $ (V.fromList v :: V.Vector Double)
    -- bestWindowSize =  the $ minimum $ map fst $ afst $ filter acceptableWindow $ map (go xs) ws
    -- acceptableWindow b =
    --   (r < originalRoughness) && (k >= originalKurt)
    --   where
    --     r = fst $ snd b
    --     k = snd $ snd b
    -- smaLargeResolution = sma (length xs `div` resolution) (length xs `div` resolution) xs
    -- originalKurt = kurtosis xs
    -- originalRoughness = the $ roughness xs
    -- end :: Exp Int
    -- end = length xs `div` 10
    -- ws :: Arr Int
    -- ws = enumFromN (index1 $ end - 2) 2

mavg' :: P.Fractional b => Int -> [b] -> [b]
mavg' k lst = P.map (/ P.fromIntegral k) $ L.scanl' (+) (P.sum h) $ P.zipWith (-) t lst
  where (h, t) = L.splitAt k lst


-- {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds, GADTs, TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}

module UnitBLAS.Level3(unitTestLevel3BLAS) where

import Test.HUnit
--import Numerical.Array.Shape as S
import Prelude as P
import Test.Tasty
import Test.Tasty.HUnit

import qualified Data.Vector.Storable as SV
import qualified Data.Vector.Storable.Mutable as SMV

import Data.Complex

import  Numerical.HBLAS.MatrixTypes as Matrix
import  Numerical.HBLAS.BLAS as BLAS

matmatTest1SGEMM:: IO ()
matmatTest1SGEMM = do
    left  <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const (1.0 :: Float))
    right <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const (1.0 :: Float))
    res   <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const (0.0 :: Float))
    BLAS.sgemm Matrix.NoTranspose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= [2,2,2,2]

matmatTest1DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest1DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (2,2) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (2,2) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (2,2) (const 0.0)
    BLAS.dgemm Matrix.NoTranspose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= [2.0,2.0,2.0,2.0]

matmatTest2DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest2DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (3,2) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (5,3) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (5,2) (const 0.0)
    BLAS.dgemm Matrix.NoTranspose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= replicate 10 3

matmatTest3DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest3DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (2,3) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (5,3) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (5,2) (const 0.0)
    BLAS.dgemm Matrix.Transpose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= replicate 10 3

matmatTest3aDGEMM :: Matrix.SOrientation x -> IO ()
matmatTest3aDGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (2,3) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (2,3) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (3,3) (const 0.0)
    BLAS.dgemm Matrix.NoTranspose Matrix.Transpose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= replicate 9 2

matmatTest4DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest4DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (3,2) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (3,5) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (5,2) (const 0.0)
    BLAS.dgemm Matrix.NoTranspose Matrix.Transpose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= replicate 10 3

matmatTest5DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest5DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or  (2,3) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or  (3,5) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or  (5,2) (const 0.0)
    BLAS.dgemm Matrix.Transpose Matrix.Transpose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= replicate 10 3

matmatTest6DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest6DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (3,2) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (3,2) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (3,3) (const 0.0)
    BLAS.dgemm Matrix.Transpose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= replicate 9 2

matmatTest7DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest7DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (2,64) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (2,64) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (2,2) (const 0.0)
    BLAS.dgemm Matrix.Transpose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= replicate 4 64

matmatTest8DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest8DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (2,9) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (2,9) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (2,2) (const 0.0)
    BLAS.dgemm Matrix.Transpose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= replicate 4 9

matmatTest1CGEMM:: IO ()
matmatTest1CGEMM = do
    left  <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 0.0)
    BLAS.cgemm Matrix.NoTranspose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= [2.0,2.0,2.0,2.0]

matmatTest1ZGEMM:: IO ()
matmatTest1ZGEMM = do
    left  <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 0.0)
    BLAS.zgemm Matrix.NoTranspose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= [2.0,2.0,2.0,2.0]

unitTestLevel3BLAS = testGroup "BLAS Level 3 tests " [
    testCase "sgemm on 2x2 all 1s"    matmatTest1SGEMM
    ,testCase "dgemm on 2x2 all 1s" $ matmatTest1DGEMM Matrix.SRow
    ,testCase "dgemm on 3x2 and 5x3 all 1s" $ matmatTest2DGEMM Matrix.SRow
    ,testCase "dgemm on 2x3^T and 5x3 all 1s" $ matmatTest3DGEMM Matrix.SRow
    ,testCase "dgemm on 2x3 and 2x3^T all 1s" $ matmatTest3aDGEMM Matrix.SRow
    ,testCase "dgemm on 3x2 and 3x5^T all 1s" $ matmatTest4DGEMM Matrix.SRow
    ,testCase "dgemm on 2x3^T and 3x5^T all 1s" $ matmatTest5DGEMM Matrix.SRow
    ,testCase "dgemm on 3x2^T and 3x2 all 1s" $ matmatTest6DGEMM Matrix.SRow
    ,testCase "dgemm on 2x64^T and 2x64 all 1s" $ matmatTest7DGEMM Matrix.SRow
    ,testCase "dgemm on 2x9^T and 2x9 all 1s" $ matmatTest8DGEMM Matrix.SRow
    ,testCase "dgemm on 2x2 all 1s (column oriented)" $ matmatTest1DGEMM Matrix.SColumn
    ,testCase "dgemm on 3x2 and 5x3 all 1s (column oriented)" $ matmatTest2DGEMM Matrix.SColumn
    ,testCase "dgemm on 2x3^T and 5x3 all 1s (column oriented)" $ matmatTest3DGEMM Matrix.SColumn
    ,testCase "dgemm on 2x3 and 2x3^T all 1s (column oriented)" $ matmatTest3aDGEMM Matrix.SColumn
    ,testCase "dgemm on 3x2 and 3x5^T all 1s (column oriented)" $ matmatTest4DGEMM Matrix.SColumn
    ,testCase "dgemm on 2x3^T and 3x5^T all 1s (column oriented)" $ matmatTest5DGEMM Matrix.SColumn
    ,testCase "dgemm on 3x2^T and 3x2 all 1s (column oriented)" $ matmatTest6DGEMM Matrix.SColumn
    ,testCase "dgemm on 2x64^T and 2x64 all 1s (column oriented)" $ matmatTest7DGEMM Matrix.SColumn
    ,testCase "dgemm on 2x9^T and 2x9 all 1s (column oriented)" $ matmatTest8DGEMM Matrix.SColumn
    ,testCase "cgemm on 2x2 all 1s" matmatTest1CGEMM
    ,testCase "zgemm on 2x2 all 1s" matmatTest1ZGEMM
    ]

----unitTestShape = testGroup "Shape Unit tests"
----    [ testCase "foldl on shape" $ ( S.foldl (+) 0 (1:* 2:* 3 :* Nil )  @?=  ( P.foldl   (+) 0  [1,2,3])  )
----    , testCase "foldr on shape" $ ( S.foldr (+) 0 (1:* 2:* 3 :* Nil )  @?=  ( P.foldr  (+) 0  [1,2,3])  )
----    , testCase "scanr1 on shape" (S.scanr1 (+) 0 (1:* 1 :* 1:* Nil )   @?=  (3:* 2:* 1 :* Nil ) )
----    , testCase "scanl1 on shape" (S.scanl1 (+) 0 (1:* 1 :* 1:* Nil )   @?=  (1:* 2:* 3:* Nil ) )
----    ]

--turn the following into the first level 2 test

---- {-# LANGUAGE ScopedTypeVariables, DataKinds, CPP #- }
--import Numerical.HBLAS.BLAS.FFI
--import Numerical.HBLAS.BLAS
--import Numerical.HBLAS.MatrixTypes
--import Data.Vector.Storable.Mutable as M
--import qualified Data.Vector.Storable as S

--main :: IO ()
--main = do
--  -- Just test that the symbol resolves
--  --openblas_set_num_threads_unsafe 7
--  v  :: IOVector Double <- M.replicate 10 1.0
-- #if defined(__GLASGOW_HASKELL_) && (__GLASGOW_HASKELL__ <= 704)
--  --this makes 7.4 panic!
--  (leftMat :: IODenseMatrix Row Float) <-  generateMutableDenseMatrix SRow (5,5) (const 1.0 ::Float )
--  (rightMat :: IODenseMatrix Row Float) <-  generateMutableDenseMatrix SRow (5,5) (const 1.0 ::Float )
--  (resMat :: IODenseMatrix Row Float) <-  generateMutableDenseMatrix SRow (5,5) (const 1.0 ::Float )
--  sgemm NoTranspose NoTranspose 1.0 1.0 leftMat rightMat resMat
--  --(MutableDenseMatrix _ _ _ _ buff) <- return resMat
--  theRestMat <- unsafeFreezeDenseMatrix resMat
--  putStrLn $ show theRestMat
-- #endif
----DenseMatrix SRow  5 5 5(fromList [11.0,11.0,11.0,11.0,11.0,11.0,11.0,11.0,11.0,11.0,51.0,51.0,51.0,51.0,51.0,51.0,51.0,51.0,51.0,51.0,251.0,251.0,251.0,251.0,251.0])
---- THAT IS WRONG
----Need to figure what whats going on here

--  putStrLn $ show res
--  putStrLn "it works!"


module Main where

import Criterion.Main

import Data.List as L
import Data.Set as Set

testlist :: [Int]
testlist = [0..9]

naiveSubseq :: Int -> [Int] -> [[Int]]
naiveSubseq n = L.filter ((==n) . length) . subsequences

yanaiveSubseq :: Int -> [Int] -> [[Int]]
yanaiveSubseq n []
  | n == 0    = [[]]
  | otherwise = []
yanaiveSubseq 0 (_:_) = [[]]
yanaiveSubseq n (x:xs) = yanaiveSubseq n xs ++ fmap (x:) (yanaiveSubseq (n-1) xs)

setSubseq :: Int -> [Int] -> [[Int]]
setSubseq n = Set.toList . Set.mapMonotonic Set.toList . Set.filter ((==n) . Set.size) . powerSet . fromList

main :: IO ()
main = defaultMain [
  bgroup "subseq" [
      bench "L.subsequences" $ nf (naiveSubseq 5) testlist,
      bench "yanaiveSubseq" $ nf (yanaiveSubseq 5) testlist,
      bench "Set.powerSet" $ nf (setSubseq 5) testlist] ]

{-- Benchmark for matrix normal forms.
import Data.List as L
import Data.Matrix as Mat

import Numeric.LinearAlgebra

import Numeric.Algebra.FreeModule
import Numeric.Algebra.Frobenius
import qualified Numeric.Algebra.IntMatrix.HNFLLL as HASKHNF
import qualified Numeric.Algebra.IntMatrix.NormalForms as FFIHNF

import qualified Numeric.Algebra.IntMatrix.SmithNF as HASKSMITH

testmat1 = (100 >< 100) $ cycle [-2,-1,0,1,2,3,4]

hasIntersection :: Eq a => [a] -> [a] -> Bool
hasIntersection x y = not $ L.null (x `L.intersect` y)

testSL2B :: Int -> [(Int,SL2B)]
testSL2B n = zip [1..n] (cycle [SLI,SLI,SLX])

divides :: Int -> Int -> Bool
divides m n = n `rem` m == 0

main :: IO ()
main = defaultMain [
  bgroup "hermiteNF" [
      bench "pure Haskell" $ nf HASKHNF.hnfLLL testmat1,
      bench "ffi" $ nf FFIHNF.hermiteNF testmat1 ],
  bgroup "smithNF" [
      bench "Haskell" $ nf HASKSMITH.smithNF testmat1,
      bench "ffi" $ nf FFIHNF.smithNF testmat1 ],
  bgroup "TQFT operation" [
      bench "tqftZ" $ nf (genMatrixAR (tqftZ divides (testSL2B 200))) (subsequences [1..11]) ] ]
--}


{-# LANGUAGE AllowAmbiguousTypes                      #-}
{-# LANGUAGE ConstraintKinds                          #-}
{-# LANGUAGE DataKinds                                #-}
{-# LANGUAGE DefaultSignatures                        #-}
{-# LANGUAGE FlexibleContexts                         #-}
{-# LANGUAGE FlexibleInstances                        #-}
{-# LANGUAGE GADTs                                    #-}
{-# LANGUAGE RankNTypes                               #-}
{-# LANGUAGE ScopedTypeVariables                      #-}
{-# LANGUAGE TypeApplications                         #-}
{-# LANGUAGE TypeFamilies                             #-}
{-# LANGUAGE TypeOperators                            #-}
{-# LANGUAGE UndecidableInstances                     #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}

module Backprop.Learn.Initialize (
    Initialize(..)
  , gInitialize
  , initializeNormal
  , initializeSingle
  ) where

import           Control.Monad.Primitive
import           Data.Complex
import           Data.Type.Length
import           Data.Type.NonEmpty
import           Data.Type.Tuple
import           GHC.TypeNats
import           Generics.OneLiner
import           Numeric.LinearAlgebra.Static.Vector
import           Statistics.Distribution
import           Statistics.Distribution.Normal
import           Type.Class.Known
import           Type.Family.List
import qualified Data.Vector.Generic                 as VG
import qualified Data.Vector.Generic.Sized           as SVG
import qualified Numeric.LinearAlgebra.Static        as H
import qualified System.Random.MWC                   as MWC

-- | Class for types that are basically a bunch of 'Double's, which can be
-- initialized with a given identical and independent distribution.
class Initialize p where
    initialize
        :: (ContGen d, PrimMonad m)
        => d
        -> MWC.Gen (PrimState m)
        -> m p

    default initialize
        :: (ADTRecord p, Constraints p Initialize, ContGen d, PrimMonad m)
        => d
        -> MWC.Gen (PrimState m)
        -> m p
    initialize = gInitialize

-- | 'initialize' for any instance of 'Generic'.
gInitialize
    :: (ADTRecord p, Constraints p Initialize, ContGen d, PrimMonad m)
    => d
    -> MWC.Gen (PrimState m)
    -> m p
gInitialize d g = createA' @Initialize (initialize d g)

initializeNormal
    :: (Initialize p, PrimMonad m)
    => Double                               -- ^ standard deviation
    -> MWC.Gen (PrimState m)
    -> m p
initializeNormal = initialize . normalDistr 0

-- | 'initialize' definition if @p@ is a single number.
initializeSingle
    :: (ContGen d, PrimMonad m, Fractional p)
    => d
    -> MWC.Gen (PrimState m)
    -> m p
initializeSingle d = fmap realToFrac . genContVar d

instance Initialize Double where
    initialize = initializeSingle
instance Initialize Float where
    initialize = initializeSingle

-- | Initializes real and imaginary components identically
instance Initialize a => Initialize (Complex a) where

instance Initialize T0
instance (Initialize a, Initialize b) => Initialize (T2 a b)
instance (Initialize a, Initialize b, Initialize c) => Initialize (T3 a b c)

instance (ListC (Initialize <$> as), Known Length as) => Initialize (T as) where
    initialize d g = constTA @Initialize (initialize d g) known

instance (Initialize a, ListC (Initialize <$> as), Known Length as) => Initialize (NETup (a ':| as)) where
    initialize d g = NET <$> initialize d g
                         <*> initialize d g

instance Initialize ()
instance (Initialize a, Initialize b) => Initialize (a, b)
instance (Initialize a, Initialize b, Initialize c) => Initialize (a, b, c)

instance (VG.Vector v a, KnownNat n, Initialize a) => Initialize (SVG.Vector v n a) where
    initialize d = SVG.replicateM . initialize d

instance KnownNat n => Initialize (H.R n) where
    initialize d = fmap vecR . initialize d
instance KnownNat n => Initialize (H.C n) where
    initialize d = fmap vecC . initialize d

instance (KnownNat n, KnownNat m) => Initialize (H.L n m) where
    initialize d = fmap vecL . initialize d
instance (KnownNat n, KnownNat m) => Initialize (H.M n m) where
    initialize d = fmap vecM . initialize d

constTA
    :: forall c as f. (ListC (c <$> as), Applicative f)
    => (forall a. c a => f a)
    -> Length as
    -> f (T as)
constTA x = go
  where
    go :: forall bs. ListC (c <$> bs) => Length bs -> f (T bs)
    go LZ     = pure TNil
    go (LS l) = (:&) <$> x <*> go l


{-# LANGUAGE Strict, StrictData #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}

------------------------------------------------
-- |
-- Module    :  Numeric.Algebra.Homology
-- Copyright :  (c) Jun Yoshida 2019
-- License   :  BSD3
--
-- Chain complexes over integers
--
------------------------------------------------

module Numeric.Algebra.Homology
  (ChainEliminable, Homology(..), homology) where

import GHC.Generics (Generic, Generic1)
import Control.DeepSeq (NFData, force, deepseq)

import Control.Parallel.Strategies

import Control.Monad
import Control.Monad.ST

import Control.Applicative

import Data.STRef

import Data.Bifunctor
import Data.Traversable
import Data.Tuple (swap)
import Data.Maybe
import Data.List

import qualified Numeric.LinearAlgebra as LA
import qualified Numeric.LinearAlgebra.Devel as LA

import qualified Data.Vector as V
import qualified Data.Vector.Mutable as MV

import Numeric.Algebra.FreeModule
import Numeric.Algebra.Presentation
import Numeric.Matrix.Integral
import Numeric.Matrix.Integral.NormalForms
import Numeric.F2 (F2)
import qualified Numeric.Matrix.F2 as F2
import qualified Numeric.Matrix.F2.Mutable as F2

{-- for Debug
import Debug.Trace

traceCond :: Bool -> String -> a -> a
traceCond False _  = id
traceCond True msg = trace msg
--}

--------------
-- * Classes
--------------
class (Normalized a) => ChainEliminable a where
  elimChainHead :: Mat a -> Mat a -> (NormalForm a, Mat a)
  -- ^ If
  -- @ let (a',v) = elimChainHead u a @
  -- Then
  -- @ a' == toNF (a <> u^{-1}) @
  -- and the vectors of v (i.e. toVecs v) induces a basis for the cokernel of a⊗ℚ.

-------------------------------------
-- * Computation of homology groups
-------------------------------------
data Homology a = Homology {
  freeCycs :: [Vec a],
  torsions :: [(a,Vec a)],
  bndries :: [Vec a]
  } deriving (Generic)

deriving instance (Coefficient a, Show a, Show (Vec a)) => Show (Homology a)
deriving instance (Coefficient a) => NFData (Homology a)

-- | Compute the kernel and the image of a matrix from its normal form.
homologyOfNF :: (Normalized a) => NormalForm a -> (Homology a, Homology a)
homologyOfNF nf
  = let invs = invariants nf ++ repeat 0
        cycs = map snd $ filter ((==0) . fst) $ zip invs (toVecs (basisDom nf))
        img = filter ((/=0) . fst) $ zip invs (toVecs (basisCod nf))
        (tors,bnds') = partition ((/=1) . fst) img
        bnds = map (uncurry scale) bnds'
    in (Homology [] tors bnds, Homology cycs [] [])

-- | Decompose complexes into two-term complexes with differential in a Smith normal form.
chainToNormals :: (ChainEliminable a, Traversable t) => t (Mat a) -> (Mat a,t (NormalForm a))
chainToNormals = first (maybe (ident 0) id) . mapAccumL chainToNormals' Nothing
  where
    chainToNormals' mayU mat
      = let (u,mat') = case mayU of
                         Just u -> (u, mat <> u)
                         Nothing -> (ident (rankDom mat), mat)
            !(!matNF, !coker) = force (elimChainHead u mat')
        in (Just coker, matNF)

-- | Compute homology group with integral coefficient.
homology :: (ChainEliminable a, Traversable t, Alternative t, NFData (t (NormalForm a)), NFData (t (Homology a, Homology a))) => t (Mat a) -> t (Homology a)
homology diffs =
  let !(!coker, !nfs) = force (chainToNormals diffs)
      !hs = force (fmap homologyOfNF nfs `using` parTraversable (rparWith rdeepseq))
  in (uncurry ((<|>) . pure)) (mapAccumR pile (Homology (toVecs coker) [] []) hs)
  where
    pile (Homology cycs _ _) (thisH, nextCycH) =
      (nextCycH, thisH {freeCycs = cycs})

-----------------
-- * Instances
-----------------
-- | Enables chain-level Gaussian eliminations on integer matrices.
instance ChainEliminable LA.Z where
  elimChainHead basis matA = runST $ do
    stMatA <- LA.thawMatrix matA
    stBasis <- LA.thawMatrix basis
    stU <- LA.thawMatrix (LA.ident (LA.rows matA))
    -- Compute the Smith normal form
    smithRepST stU stMatA stBasis
    -- Write the new basis of the source
    resBasis <- LA.unsafeFreezeMatrix stBasis
    -- Take the invariant factor.
    invFs <- LA.takeDiag <$!> LA.unsafeFreezeMatrix stMatA
    let rkQ = length (takeWhile (/=0) (LA.toList invFs)) -- rank over the field of fractions; e.g. Q for Z
    -- Free closure of the image of matA & its orthogonal.
    fimage <- if LA.rows matA > 0 && rkQ > 0
              then LA.extractMatrix stU LA.AllRows (LA.ColRange 0 (rkQ-1))
              else return $ (LA.rows matA LA.>< 0) []
    fcoker <- if LA.rows matA > 0 && rkQ < LA.rows matA
              then LA.extractMatrix stU LA.AllRows (LA.FromCol rkQ)
              else return $ (LA.rows matA LA.>< 0) []
    return (SmithNF invFs resBasis fimage, fcoker)

instance ChainEliminable F2 where
  elimChainHead basis matA = runST $ do
    stMatA <- F2.thawMatrixF2 matA
    stBasis <- F2.thawMatrixF2 basis
    stU <- F2.newIdentF2 (F2.rows matA)
    -- Compute the Smith normal form
    rk <- F2.mdiagRepF2 stU stMatA stBasis
    -- Write the new basis of the source
    resBasis <- F2.unsafeFreezeMatrixF2 stBasis
    (fimage,fcoker) <- F2.splitColumnsAt rk <$> F2.unsafeFreezeMatrixF2 stU
    return (DiagNF rk resBasis fimage, fcoker)