module Read (
  readExpr,
  readExprList
) where

import           Control.Monad
import           Control.Monad.Error
import           Data.Complex
import           Data.Ratio
import           Numeric
import           Text.ParserCombinators.Parsec
import           Types

symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=>?@^_~"

escapedChar :: Parser Char
escapedChar = char '\\' >> oneOf "\\\"nrt"

parseString :: Parser LispVal
parseString = do
  char '"'
  x <- many $ escapedChar <|> noneOf "\"\\"
  char '"'
  return $ String x

parseBool :: Parser LispVal
parseBool = do
  string "#"
  x <- oneOf "tf"
  return $ case x of
    't' -> Bool True
    'f' -> Bool False

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

parseHex :: Parser LispVal
parseHex = do
  try $ string "#x"
  x <- many1 hexDigit
  return $ Number $ fst $ head $ readHex x

parseDigits :: Parser LispVal
parseDigits = do
  try $ char '#'
  second <- oneOf "odb"
  rest <- many1 digit
  return $ Number $ case second of
    'o' -> fst $ head $ readOct rest
    'd' -> read rest
    'b' -> parseBin 0 rest

parseBin :: Integer -> String -> Integer
parseBin acc ""     = acc
parseBin acc (x:xs) = parseBin (acc * 2 + (if x == '0' then 0 else 1)) xs

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

parseNumber :: Parser LispVal
parseNumber = try $ parseHex <|> parseDecimal <|> parseDigits
-- tryを外すと、 #t を解釈できずに落ちるので注意

parseCharacter :: Parser LispVal
parseCharacter = do
  try $ string "#\\"
  value <- try (string "newline" <|> string "space")
    <|> do
      x <- anyChar
      notFollowedBy alphaNum
      return [x]
  return $ Character $ case value of
    "newline" -> '\n'
    "space"   -> ' '
    _         -> head value

parseFloat :: Parser LispVal
parseFloat = do
  x <- many1 digit
  char '.'
  y <- many1 digit
  return $ Float $ fst . head $ readFloat (x ++ "." ++ y)

parseRatio :: Parser LispVal
parseRatio = do
  x <- many1 digit
  char '/'
  y <- many1 digit
  return $ Ratio $ read x % read y

parseComplex :: Parser LispVal
parseComplex = do
  x <- try parseFloat <|> parseDecimal
  char '+'
  y <- try parseFloat <|> parseDecimal
  char 'i'
  return $ Complex (toDouble x :+ toDouble y)

toDouble :: LispVal -> Double
toDouble(Float f)  = f
toDouble(Number n) = fromIntegral n

parseList ::Parser LispVal
parseList = List <$> sepBy parseExpr spaces

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

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

parseExpr :: Parser LispVal
parseExpr = parseAtom
  <|> parseString
  <|> try parseComplex
  <|> try parseFloat
  <|> try parseRatio
  <|> try parseNumber
  <|> parseQuoted
  <|> do
    char '('
    x <- try parseList <|> parseDottedList
    char ')'
    return x
  <|> try parseBool
  <|> try parseCharacter

readOrThrow :: Parser a -> String -> ThrowsError a
readOrThrow parser input = case parse parser "lisp" input of
  Left err  -> throwError $ Parser err
  Right val -> return val

readExpr :: String -> ThrowsError LispVal
readExpr = readOrThrow parseExpr

readExprList :: String -> ThrowsError [LispVal]
readExprList = readOrThrow (endBy parseExpr spaces)


{-|
Module      : GMM
Description : Definition of the Gaussian Mixture Model and Metropolis hatings sampler.
Copyright   : (c) Julian Kopka Larsen, 2015
Stability   : experimental

-}
module GMM (
    X,
    getElement
) where

import GHC.Arr (range)
import Data.List (foldl')
import Data.Array
import System.Random
import Numeric.LinearAlgebra
import Numeric.LinearAlgebra.Util hiding ((!))
import Debug.Trace

import Distributions -- (lnormalInvWishart, lMixNormWish, delta, Expr)
import Partition (Partition, Component, Move, naivefromNk, genMoves, applyMove, group)

import Math (X)

type Chain = [Partition]

type Likelihood = (X -> Double)

type Proposal = (Move, Double)

props :: Int -> Int -> Int -> [Proposal]
props seed n k = zip moves rand_accepts
                where rand_accepts = randomRs (0.0,1.0) (mkStdGen seed) :: [Double]
                      moves = genMoves seed n k

sample :: (Partition -> Move -> Double) -> Partition -> Proposal -> Partition
sample f prev_state (m, accept_prop)
    | accept_prop < f prev_state m = new_state -- trace ("(" ++ (show $ a!(node m)) ++ "->" ++ (show $ comp m) ++   ")" ++ "Accepted: " ++ show (f a m)) b
    | otherwise                    = prev_state -- trace ("(" ++ (show $ a!(node m)) ++ "->" ++ (show $ comp m) ++   ")" ++ "Rejected: " ++ show (f a m)) a
                                    where new_state = applyMove prev_state m

getElement :: X -> Int -> Int -> Int -> Partition
getElement x seed k nSamples = foldl' sampler start $ take nSamples (props seed n k)
                      where n = length x
                            start = naivefromNk n k
                            sampler = sample $ acceptanceRatio dq
                            dq = dlNormW x

acceptanceRatio :: (Partition -> Partition -> Double) -> Partition -> Move -> Double
acceptanceRatio dq x m = exp (dq x' x)
                        where x' = applyMove x m


module CategoricDefinitions where

import Prelude hiding (id, (.))
import qualified Prelude as P
import GHC.Exts
import Data.Kind (Type)
import Data.NumInstances.Tuple

import Numeric.LinearAlgebra.Array
import Numeric.LinearAlgebra.Array.Util

{-
Unfortunately, there is a known bug which prevents quantifying constraints involving type families.
https://gitlab.haskell.org/ghc/ghc/issues/14860
This results in all the functions below having a list of constraints AllAllowed k [...]
-}

-- Standard haskell way to define a category
class Category (k :: Type -> Type -> Type) where
    type Allowed k a :: Constraint
    type Allowed k a = ()

    id  :: Allowed k a => a `k` a
    (.) :: AllAllowed k [a, b, c] => b `k` c -> a `k` b -> a `k` c

-- By monoidal here we mean symmetric monoidal category
class Category k => Monoidal (k :: Type -> Type -> Type) where
    -- unit object in haskell is ()
    x :: AllAllowed k [a, b, c, d, (a, b), (c, d)]
      => (a `k` c) -> (b `k` d) -> ((a, b) `k` (c, d))
    assocL :: AllAllowed k [a, b, c, (a, b), ((a, b), c), (b, c), (a, (b, c))]
           => ((a, b), c) `k` (a, (b, c))
    assocR :: AllAllowed k [a, b, c, (a, b), ((a, b), c), (b, c), (a, (b, c))]
           => (a, (b, c)) `k` ((a, b), c)
    unitorL :: Allowed k a
            => ((), a) `k` a
    unitorL' :: Allowed k a -- inverse of unitorL
            => a `k` ((), a)
    -- could also potentially add right unitor and their inverses
    swap :: AllAllowed k [a, b, (a, b), (b, a)]
         => (a, b) `k` (b, a)

class Monoidal k => Cartesian k where
    type AllowedCar k a :: Constraint
    type AllowedCar k a = ()

    exl :: AllowedCar k b => (a, b) `k` a
    exr :: AllowedCar k a => (a, b) `k` b
    dup :: AllowedCar k a => a `k` (a, a)
    counit :: AllowedCar k a => a `k` ()

class Category k => Cocartesian k where
    type AllowedCoCar k a :: Constraint
    type AllowedCoCar k a = Allowed k a

    inl :: AllowedCoCar k b => a `k` (a, b)
    inr :: AllowedCoCar k a => b `k` (a, b)
    jam :: AllowedCoCar k a => (a, a) `k` a
    unit :: AllowedCoCar k a => () `k` a

{-
This is a hacky way of modelling a weak 2-category which is needed for Para.
Notice the tick' after class name
(.*) corresponds to id
(.-) corresponds to . (sequential comp)
(.|) corresponds to `x` (parallel comp)

Ideally, we'd like to specify in code that given any symmetric monoidal category C we can construct _another_ symmetric monoidal category called Para(C), but sometimes dreams will have to be dreams.
-}

class Category' (k :: Type -> Type -> Type -> Type) where
    type Allowed' k a :: Constraint
    type Allowed' k a = ()

    (.*) :: (Allowed' k a) => k () a a
    (.-) :: AllAllowed' k [p, q, a, b, c, (q, p), (p, q), ((p, q), a), ((q, p), a), (q, (p, a)), (q, b), (p, a)]
          => k q b c -> k p a b -> k (p, q) a c

-- the constraints are unfortunately very ugly
class Category' k => Monoidal' (k :: Type -> Type -> Type -> Type) where
    (.|) :: AllAllowed' k [a, b, c, d, p, q, ((p, q), (a, b)), ((p, a), (q, b)), (c, d), (p, a), (q, b), (p, (q, (a, b))), (p, ((q, a), b)), (p, ((a, q), b)), (p, (a, (q, b))), (a, (q, b)), ((a, q), b), (a, q), ((q, a), b), (q, a), (q, (a, b)), (a, b), (p, q)]
      => k p a c -> k q b d -> k (p, q) (a, b) (c, d)

-- Sequential composition of parametrized functions
(.--) :: (Monoidal k, _)
    => (q, b) `k` c
    -> (p, a) `k` b
    -> ((p, q), a) `k` c
g .-- f = g . (id `x` f) . assocL . (swap `x` id)

-- Parallel composition of parametrized functions
(.||) :: (Monoidal k, _)
    => (p, a) `k` b
    -> (q, c) `k` d
    -> ((p, q), (a, c)) `k` (b, d)
f .|| g = f `x` g . swapParam

{-
Swap map for monoidal product of parametrized functions, basically bracket bookkeeping.
Read from top to bottom
(a b) (c d)
a (b, (c, d))
a ((b, c), d)
a ((c, b), d)
a (c, (b, d))
(a c) (b d)
-}
swapParam :: (Monoidal k, _) => ((a, b), (c, d)) `k` ((a, c), (b, d))
swapParam = assocR . (id `x` assocL) . (id `x` (swap `x` id)) . (id `x` assocR) . assocL

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

class Additive a where
    zero :: a
    (^+) :: a -> a -> a

class NumCat (k :: Type -> Type -> Type) a where
    negateC :: a `k` a
    addC :: (a, a) `k` a
    mulC :: (a, a) `k` a
    increaseC :: a -> a `k` a -- curried add, add a single number

class FloatCat (k :: Type -> Type -> Type) a where
    expC :: a `k` a

class FractCat (k :: Type -> Type -> Type) a where
    recipC :: a `k` a

class Scalable (k :: Type -> Type -> Type) a where
    scale :: a -> (a `k` a)

type Tensor = NArray None Double

-------------------------------------
-- Instances
-------------------------------------

instance Category (->) where
    id    = \a -> a
    g . f = \a -> g (f a)

instance Monoidal (->) where
    f `x` g = \(a, b) -> (f a, g b)
    assocL = \((a, b), c) -> (a, (b, c))
    assocR = \(a, (b, c)) -> ((a, b), c)
    unitorL = \((), a) -> a
    unitorL' = \a -> ((), a)
    swap = \(a, b) -> (b, a)

instance Cartesian (->) where
    exl = \(a, _) -> a
    exr = \(_, b) -> b
    dup = \a -> (a, a)
    counit = \_ -> ()

instance Num a => NumCat (->) a where
    negateC = negate
    addC = uncurry (+)
    mulC = uncurry (*)
    increaseC a = (+a)

instance Floating a => FloatCat (->) a where
    expC = exp

instance Fractional a => FractCat (->) a where
    recipC = recip

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

instance Additive () where
    zero = ()
    () ^+ () = ()

instance {-# OVERLAPPABLE #-} Num a => Additive a where
    zero = 0
    (^+) = (+)

instance (Additive a, Additive b) => Additive (a, b) where
    zero = (zero, zero)
    (a1, b1) ^+ (a2, b2) = (a1 ^+ a2, b1 ^+ b2)

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

(/\) :: (Cartesian k, _) => b `k` c -> b `k` d -> b `k` (c, d)
f /\ g = (f `x` g) . dup

(\/) :: (Monoidal k, Cocartesian k, _) => a `k` c -> b `k` c -> (a, b) `k` c
f \/ g = jam . (f `x` g)

fork :: (Cartesian k, _) => (b `k` c,  b `k` d) -> b `k` (c, d)
fork (f, g) = f /\ g

unfork :: (Cartesian k, _) => b `k` (c, d) -> (b `k` c, b `k` d)
unfork h = (exl . h, exr . h)

join :: (Monoidal k, Cocartesian k, _) => (a `k` c, b `k` c) -> (a, b) `k` c
join (f, g) = f \/ g

unjoin :: (Cocartesian k, _) => (a, b) `k` c -> (a `k` c, b `k` c)
unjoin h = (h . inl, h . inr)

divide :: (Monoidal k, FractCat k a, _) => k (a, a) a
divide = mulC . (id `x` recipC)
-------------------------------------

type family AllAllowed k xs :: Constraint where
    AllAllowed k '[] = ()
    AllAllowed k (x : xs) = (Allowed k x, AllAllowed k xs)

type family AllAllowed' k xs :: Constraint where
    AllAllowed' k '[] = ()
    AllAllowed' k (x : xs) = (Allowed' k x, AllAllowed' k xs)


{-# LANGUAGE FlexibleContexts,
             MultiParamTypeClasses #-}

module Network.Trainer
( Trainer(..)
, CostFunction
, CostFunction'
, TrainingData
, Selection
, StopCondition

, quadraticCost
, quadraticCost'
, minibatch
, online

, trainNTimes
, trainUntilErrorLessThan
, trainUntil
) where

import Network.Network
import Network.Neuron
import Network.Layer

import System.Random
import System.Random.Shuffle (shuffle')
import Data.List.Split (chunksOf)
import Numeric.LinearAlgebra

-- | Trainer is a typeclass for all trainer types - a trainer will take in
--   an instance of itself, a network, a list of training data, and return a
--   new network trained on the data.
class (Network n) => Trainer a n where
  fit :: Selection -> a -> n -> [TrainingData] -> n
  evaluate :: a -> n -> TrainingData -> Double

-- | A CostFunction is used for evaluating a network's performance on a given
--   input
type CostFunction = Vector Double -> Vector Double -> Double

-- | A CostFunction' (derivative) is used in backPropagation
type CostFunction' = Vector Double -> Vector Double -> Vector Double

-- | A tuple of (input, expected output)
type TrainingData = (Vector Double, Vector Double)

-- | A selection function for performing gradient descent
type Selection = [TrainingData] -> [[TrainingData]]

-- | A predicate (given a network, trainer, a list of training
--   data, and the number of [fit]s performed) that
--   tells the trainer to stop training
type StopCondition t n = n -> t -> [TrainingData] -> Int -> Bool

-- | The quadratic cost function (1/2) * sum (y - a) ^ 2
quadraticCost :: Vector Double -> Vector Double -> Double
quadraticCost y a = sumElements $ 0.5 * (a - y) ** 2

-- | The derivative of the quadratic cost function sum (y - a)
quadraticCost' :: Vector Double -> Vector Double -> Vector Double
quadraticCost' y a = a - y

-- | The minibatch function becomes a Selection when partially applied
--   with the minibatch size
minibatch :: Int -> [TrainingData] -> [[TrainingData]]
minibatch size = chunksOf size

-- | If we want to train the network online
online :: [TrainingData] -> [[TrainingData]]
online = minibatch 1

-- | This function returns true if the error of the network is less than
--   a given error value, given a network, a trainer, a list of
--   training data, and a counter (should start with 0)
--   Note: Is there a way to have a counter with a recursive function
--         without providing 0?
networkErrorLessThan :: (Trainer t n) => Double -> n -> t -> [TrainingData] -> Int -> Bool
networkErrorLessThan err network trainer dat _ = meanError < err
  where meanError = (sum errors) / fromIntegral (length errors)
        errors = map (evaluate trainer network) dat

-- | Given a network, a trainer, a list of training data,
--   and N, this function trains the network with the list of
--   training data N times
trainNTimes :: (Trainer t n, RandomGen g) => g -> n -> t -> Selection -> [TrainingData] -> Int -> n
trainNTimes g network trainer s dat n =
  trainUntil g network trainer s dat completion 0
  where completion _ _ _ n' = (n == n')

-- | Given a network, a trainer, a list of training data,
--   and an error value, this function trains the network with the list of
--   training data until the error of the network (calculated
--   by averaging the errors of each training data) is less than
--   the given error value
trainUntilErrorLessThan :: (Trainer t n, RandomGen g) => g -> n -> t -> Selection -> [TrainingData] -> Double -> n
trainUntilErrorLessThan g network trainer s dat err =
  trainUntil g network trainer s dat (networkErrorLessThan err) 0

-- | This function trains a network until a given TrainCompletionPredicate
--   is satisfied.
trainUntil :: (Trainer t n, RandomGen g) => g -> n -> t -> Selection -> [TrainingData] -> StopCondition t n -> Int -> n
trainUntil g network trainer s dat completion n =
  if completion network trainer dat n
    then network
    else trainUntil g' network' trainer s (shuffle' dat (length dat) g'') completion (n+1)
    where network' = fit s trainer network dat
          (g', g'') = split g


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE QuantifiedConstraints #-}

module MLP.Network (
   AllCon,
   ArrList(..),
   arrLast,
   Weights(..),
   Net(..),
   scalarR,
   scalarL,
   MLP(..),
   Learn(..),
   NetInstance
) where

import GHC.TypeLits ( KnownNat, Nat, natVal )
import Numeric.LinearAlgebra.Static
    ( R,
      L,
      (#>),
      (<·>),
      matrix,
      uniformSample,
      unrow,
      vector,
      tr,
      Domain(outer) )
import Fcf ( Eval )
import Fcf.Data.List (Snoc, Last)
import Data.Singletons
    ( Proxy(Proxy), SingI(sing), SingKind(fromSing) )
import Data.Kind (Constraint, Type)
import Control.Monad.Random.Class (MonadRandom(..))
import Numeric.Natural ( Natural )
import Unsafe.Coerce ( unsafeCoerce )
import Data.Proxy ( Proxy(Proxy) )

type family AllCon (f :: k -> Constraint) (ks :: [k]) :: Constraint where
   AllCon _1 '[] = () :: Constraint
   AllCon f (k ': ks) = (f k, AllCon f ks) :: Constraint

data ArrList (e :: Nat -> Type) (a :: [Nat]) where
   Nil :: ArrList e '[]
   Cons :: (KnownNat o, Show (e o)) => e o -> ArrList e os -> ArrList e (o ': os)

arrLast :: forall (o :: Nat) (e :: Nat -> Type) (a :: [Nat]). (AllCon KnownNat a, KnownNat o)
           => ArrList e a -> Maybe (e o)
arrLast Nil = Nothing
arrLast (Cons a as@(Cons _ _)) = arrLast as
arrLast (Cons (a :: e o1) Nil)
   | natVal (Proxy @o1) == natVal (Proxy @o) = Just (unsafeCoerce a)
   | otherwise = Nothing

instance Show (ArrList e a) where
   show Nil = "Nil"
   show (Cons a x) = "Cons " ++ show a ++ show x

data Weights (i :: Nat) (o :: Nat) = Weights {
   inputs :: !(L o i),
   bias :: !(R o)
}

instance (KnownNat i, KnownNat  o) => Show (Weights i o) where
   show (Weights i b) = "\n[ Weights \n" ++ show i ++ "\n, Bias \n" ++ show b ++ "]\n"

rndWeights :: (KnownNat i, KnownNat o, MonadRandom m) => m (Weights i o)
rndWeights = do
   (s1,s2) <- (,) <$> getRandom <*> getRandom

   let w = uniformSample s1 (-1) 1
       b = unrow $ uniformSample s2 (-1) 1

   pure (Weights w b)

data Net (i :: Nat) (hs :: [Nat]) (o :: Nat) where
   SLayer :: !(Weights i o) -> Net i '[] o
   MLayers :: !(Weights i h) -> !(Net h hs o) -> Net i (h ': hs) o

instance AllCon KnownNat (i ': o ': hs) => Show (Net i hs o) where
   show (SLayer l) = "SLayer ->" ++ show l ++ "\n"
   show (MLayers l n) = "MLayers ->" ++ show l ++ "\n" ++ show n

scalarR :: forall n. KnownNat n => Double -> R n
scalarR d = vector (replicate numElems d)
   where
      numElems = fromIntegral . natVal $ Proxy @n

scalarL :: forall n m. (KnownNat n, KnownNat m) => Double -> L n m
scalarL d = matrix (replicate numElems d)
   where
      numElems = product . map fromIntegral . fromSing $ sing @'[n, m]

class MLP a where
   type Topo a :: [Nat]
   type Arr a :: Nat -> Type
   type DimI a :: Nat
   type DimO a :: Nat
   type Layer a :: Nat -> Nat -> Type

   layerOut :: (KnownNat i, KnownNat o)
            => Layer a i o -> Arr a i -> Arr a o

   newLayer :: (KnownNat i, KnownNat o)
               => Double -> Arr a i -> Arr a o -> Layer a i o -> Layer a i o

   netError :: Arr a (DimO a) -> Arr a (DimO a) -> Double

class MLP a => Learn a where
   create :: MonadRandom m => m a

   topo :: a -> [Natural]

   netOut :: Arr a (DimI a) -> a -> ArrList (Arr a) (Topo a)

   mkDeltas :: ArrList (Arr a) (Topo a) -> Arr a (DimO a) -> a -> ArrList (Arr a) (Topo a)

   newNet :: Double -> Arr a (DimI a) -> ArrList (Arr a) (Topo a) -> ArrList (Arr a) (Topo a) -> a -> a

instance AllCon KnownNat (i ': o ': hs)
         => MLP (Net i hs o) where

   type Topo  (Net i hs o) = Eval (Snoc hs o)
   type Arr   (Net i hs o) = R
   type DimI  (Net i hs o) = i
   type DimO  (Net i hs o) = o
   type Layer (Net i hs o) = Weights

   layerOut :: (KnownNat w, KnownNat n) => Weights w n -> R w -> R n
   layerOut l i = sigmoid $ (inputs l #> i) + bias l
      where
         sigmoid x = 1 / (1 + exp (-x))

   newLayer :: (KnownNat w, KnownNat n)
               => Double -> R w -> R n -> Weights w n -> Weights w n
   newLayer lr i delta l = Weights (w - errW) (b - errB)
      where
         w = inputs l
         b = bias l
         errW = scalarL lr * (delta `outer` i)
         errB = scalarR lr * delta

   netError :: KnownNat o => R o -> R o -> Double
   netError expOut actOut = 1 <·> ((expOut - actOut) ** 2)

-- this dummy type can be used to help find the correct MLP instance
-- in functions layerOut, newLayer
type NetInstance = Net 0 '[] 0

instance (KnownNat i, KnownNat o)
         => Learn (Net i '[] o) where

   create :: MonadRandom m => m (Net i '[] o)
   create = SLayer <$> rndWeights

   topo :: Net i '[] o -> [Natural]
   topo _ = [fromSing (sing @o)]

   netOut :: R i -> Net i '[] o -> ArrList R '[o]
   netOut i (SLayer l) = Cons (layerOut @NetInstance l i) Nil

   mkDeltas :: ArrList R '[o] -> R o -> Net i '[] o -> ArrList R '[o]
   mkDeltas (Cons lo Nil) expOut (SLayer l) = Cons (dsn * dso) Nil
      where
         dsn = lo * (1 - lo)
         dso = lo - expOut

   newNet :: Double -> R i -> ArrList R '[o] -> ArrList R '[o] -> Net i '[] o -> Net i '[] o
   newNet lr i (Cons delta Nil) _ (SLayer l) = SLayer (newLayer @NetInstance lr i delta l)

instance (AllCon KnownNat (i ': o ': h ': hs),
         Learn (Net h hs o))
         => Learn (Net i (h ': hs) o) where

   create :: forall i h hs o m. (MonadRandom m, KnownNat i, KnownNat h, Learn (Net h hs o))
             => m (Net i (h ': hs) o)
   create = MLayers <$> (rndWeights @i @h) <*> create @(Net h hs o)

   topo :: Net i (h ': hs) o -> [Natural]
   topo (MLayers _ n) = fromSing (sing @h) : topo n

   netOut :: hhs ~ (h ': hs) => R i -> Net i hhs o -> ArrList R (Topo (Net i hhs o))
   netOut i (MLayers l n) = Cons lo (netOut lo n)
      where
         lo = layerOut @NetInstance l i

   mkDeltas :: hhs ~ (h ': hs) =>
               ArrList R (Topo (Net i hhs o)) -> R o -> Net i hhs o -> ArrList R (Topo (Net i hhs o))
   mkDeltas (Cons lo lor) expOut (MLayers l nxt) =
      case nxt of
         SLayer lnxt -> let dd@(Cons d _) = mkDeltas lor expOut nxt
                            dso = tr (inputs lnxt) #> d
                          in Cons (dsn * dso) dd

         MLayers lnxt _ -> let dd@(Cons d _) = mkDeltas lor expOut nxt
                               dso = tr (inputs lnxt) #> d
                             in Cons (dsn * dso) dd
      where
         dsn = lo * (1 - lo)

   newNet :: Double ->
             R i ->
             ArrList R (Topo (Net i (h ': hs) o)) ->
             ArrList R (Topo (Net i (h ': hs) o)) ->
             Net i (h ': hs) o ->
             Net i (h ': hs) o
   newNet lr i (Cons d ds) (Cons lo los) (MLayers l n) =
      MLayers (newLayer @NetInstance lr i d l) (newNet lr lo ds los n)

layer1 :: Weights 2 3
layer1 = Weights (matrix [1..6]) (vector [1..3])

layer2 :: Weights 3 5
layer2 = Weights (matrix [1..15]) (vector [1..5])

network :: Net 2 '[3] 5
network = MLayers layer1 $ SLayer layer2


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

{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Test.Grenade.Layers.Internal.Pooling where

import           Grenade.Layers.Internal.Pooling

import           Numeric.LinearAlgebra hiding (uniformSample, konst, (===))

import           Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

import qualified Test.Grenade.Layers.Internal.Reference as Reference
import           Test.Hedgehog.Compat

prop_poolForwards_poolBackwards_behaves_as_reference =
  let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]
      output extent kernel stride = (extent - kernel) `div` stride + 1
  in  property $ do
        height   <- forAll $ choose 2 100
        width    <- forAll $ choose 2 100
        kernel_h <- forAll $ choose 1 (height - 1)
        kernel_w <- forAll $ choose 1 (width - 1)
        stride_h <- forAll $ Gen.element (ok height kernel_h)
        stride_w <- forAll $ Gen.element (ok width kernel_w)
        input    <- forAll $ (height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)

        let outFast       = poolForward 1 height width kernel_h kernel_w stride_h stride_w input
        let retFast       = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input outFast

        let outReference  = Reference.poolForward kernel_h kernel_w stride_h stride_w (output height kernel_h stride_h) (output width kernel_w stride_w) input
        let retReference  = Reference.poolBackward kernel_h kernel_w stride_h stride_w  input outReference

        outFast === outReference
        retFast === retReference

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


{-|
Module : Network
|-}
module Network
  ( Net(..)
  , createNet
  , saveNetwork
  , loadNetwork
  ) where

import Numeric.LinearAlgebra
import Specs
import System.Random

-- | data representing Network
data Net = Net {
    numLayers :: Int -- ^ Number of layers in Network
  , sizes :: [Int] -- ^ Sizes of each layer
  , biases :: [Matrix Double] -- ^ Bias Matrix's of each layer
  , weights :: [Matrix Double] -- ^ Weight Matrix's of each layer
  } deriving (Eq, Show)

-- | Generate random small numbers
smallRandoms :: Int -> [Double]
smallRandoms seed = map (/100) (randoms (mkStdGen seed))

-- | Create Matrix with random weigths
randomWeightMatrix :: Int -> Int -> Int -> Matrix Double
randomWeightMatrix numInputs numOutputs seed = (numOutputs><numInputs) weights
    where weights = take (numOutputs*numInputs) (smallRandoms seed)

-- | Create new Network for given sizes of layers
createNet :: [Int] -- ^ Sizes of each layer
          -> IO Net
createNet sizes = do
   let b = (\ x -> randomWeightMatrix 1 x 7) <$> tail sizes
   let w = (\ (x, y) -> randomWeightMatrix x y 7) <$> zip (init sizes) (tail sizes)
   let net = Net{numLayers = length sizes, sizes = sizes, biases = b, weights = w}
   return net

-- | Change Network to String for saving
toString :: Net -> String
toString net = nL ++ s ++ b ++ w
  where
    nL = show (numLayers net) ++ " \n"
    s = foldr ((\ a b -> a (' ' : b)) . shows) "\n" (sizes net)
    b = foldr1 (++) (foldr ((\ a b -> a (' ' : b)) . shows) "\n" <$> (foldr1 (++) <$> (toLists <$> biases net)))
    w = foldr1 (++) (foldr ((\ a b -> a (' ' : b)) . shows) "\n" <$> (foldr1 (++) <$> (toLists <$> weights net)))

-- | Save Network to file
saveNetwork :: Net -- ^ Network to save
            -> FilePath -- ^ FilePath for saving
            -> IO ()
saveNetwork net file = writeFile file (toString net)

-- | Change line from file to list of Doubles
lineToListDouble :: String -> [Double]
lineToListDouble line = (\ x -> read x :: Double) <$> words line

-- | Load Network from file
loadNetwork :: FilePath -- ^ FilePath to saved network
            -> IO Net
loadNetwork file = do
  content <- readFile file
  let contentLines = lines content
  let numLayers = (read (contentLines !! 0) :: Int)
  let sizes = (\x-> read x :: Int) <$> (words (contentLines !! 1))
  let ba = (contentLines !!) <$> [2..numLayers]
  let b = (\ (x, y) -> (y><1) x :: Matrix Double) <$> zip (lineToListDouble <$> ba) (tail sizes)
  let we = (contentLines !!) <$> [(numLayers+1)..(numLayers+numLayers-1)]
  let w  = (\ (x, y, z) -> (z><y) x :: Matrix Double) <$> zip3 (lineToListDouble <$> we) (init sizes) (tail sizes)
  return Net{numLayers = length sizes, sizes = sizes, biases = b, weights = w}


{- Assignment 1
 - Name: Talha Amjad
 - Date:
 -}
module Assign_1_ExtraCredit where

-- import Data.Complex -- TODO uncomment me to use built-in Complex type
-- see https://www.stackage.org/haddock/lts-8.24/base-4.9.1.0/Data-Complex.html

macid = "amjadt1"


{-# LANGUAGE AllowAmbiguousTypes                      #-}
{-# LANGUAGE DataKinds                                #-}
{-# LANGUAGE DefaultSignatures                        #-}
{-# LANGUAGE DeriveDataTypeable                       #-}
{-# LANGUAGE DeriveFoldable                           #-}
{-# LANGUAGE DeriveFunctor                            #-}
{-# LANGUAGE DeriveGeneric                            #-}
{-# LANGUAGE DeriveTraversable                        #-}
{-# LANGUAGE DerivingVia                              #-}
{-# LANGUAGE FlexibleContexts                         #-}
{-# LANGUAGE FlexibleInstances                        #-}
{-# LANGUAGE FunctionalDependencies                   #-}
{-# LANGUAGE GeneralizedNewtypeDeriving               #-}
{-# LANGUAGE MultiParamTypeClasses                    #-}
{-# LANGUAGE RankNTypes                               #-}
{-# LANGUAGE ScopedTypeVariables                      #-}
{-# LANGUAGE StandaloneDeriving                       #-}
{-# LANGUAGE TypeApplications                         #-}
{-# LANGUAGE TypeFamilies                             #-}
{-# LANGUAGE TypeOperators                            #-}
{-# LANGUAGE UndecidableInstances                     #-}
{-# OPTIONS_GHC -Wno-redundant-constraints            #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}

-- |
-- Module      : Numeric.Opto.Update
-- Copyright   : (c) Justin Le 2019
-- License     : BSD3
--
-- Maintainer  : justin@jle.im
-- Stability   : experimental
-- Portability : non-portable
--
-- A unified interface for values in vector spaces that can be added and
-- scaled (purely and also in-place), and measured.
module Numeric.Opto.Update (
    Linear(..), sumLinear, gAdd, gZeroL, gScale
  , Metric(..), gDot, gNorm_inf, gNorm_0, gNorm_1, gNorm_2, gQuadrance
  , LinearInPlace(..), sumLinearInPlace
  , linearWit
  ) where

import           Control.DeepSeq
import           Control.Monad.Primitive
import           Data.Coerce
import           Data.Complex
import           Data.Data
import           Data.Finite
import           Data.Foldable
import           Data.Function
import           Data.Maybe
import           Data.Mutable
import           Data.Semigroup
import           Data.Vinyl hiding                   ((:~:))
import           GHC.Generics                        (Generic)
import           GHC.TypeLits
import           Generics.OneLiner
import           Numeric.Opto.Ref
import           Unsafe.Coerce
import qualified Data.Vector.Generic                 as VG
import qualified Data.Vector.Generic.Mutable.Sized   as SVGM
import qualified Data.Vector.Generic.Sized           as SVG
import qualified Numeric.LinearAlgebra               as UH
import qualified Numeric.LinearAlgebra.Static        as H
import qualified Numeric.LinearAlgebra.Static.Vector as H

-- | If @a@ is an instance of @'Linear' c@, you can /add/ together values
-- of @a@, and /scale/ them using @c@s.
--
-- For example, if you have a vector of doubles, you can add them together
-- component-wise, and scale them by multiplying every item by the scalar.
--
-- Mathematically, this means that @a@ forms something like a module or
-- vector space over @c@, where @c@ can be any 'Num' instance.
class Num c => Linear c a | a -> c where
    -- | Add together @a@s.  Should be associative.
    --
    -- @
    -- x .+. (y .+. z) == (x .+. y) .+. z
    -- @
    --
    -- If @a@ is an instance of 'Num', this can be just 'Prelude.+'.
    (.+.) :: a -> a -> a

    -- | The "zero" @a@, meant to form an identity with '.+.'.
    --
    -- @
    -- x .+. zeroL == x
    -- zeroL .+. y == y
    -- @
    --
    -- If @a@ is an instance of 'Num', this can be just 0.
    zeroL :: a

    -- | Scale an @a@ by a factor @c@.  Should distribute over '.+.'.
    --
    -- @
    -- a .* (x .+. y) == (a .* x) .+. (a .* y)
    -- a .* (b .* c)  == (a * b) .* c
    -- @
    (.*)  :: c -> a -> a

    infixl 6 .+.
    infixl 7 .*

    default (.+.) :: (ADTRecord a, Constraints a (Linear c)) => a -> a -> a
    (.+.) = gAdd @c

    default zeroL :: (ADTRecord a, Constraints a (Linear c)) => a
    zeroL = gZeroL @c

    default (.*) :: (ADTRecord a, Constraints a (Linear c)) => c -> a -> a
    (.*)  = gScale

-- | Sum over a 'Foldable' container of @'Linear' c a@
sumLinear :: (Linear c a, Foldable t) => t a -> a
sumLinear = foldl' (.+.) zeroL

-- | An implementation of '.+.' that works for records where every field is
-- an instance of @'Linear' c@ (that is, every field is additive and can be
-- scaled by the same @c@).
gAdd :: forall c a. (ADTRecord a, Constraints a (Linear c)) => a -> a -> a
gAdd = binaryOp @(Linear c) (.+.)

-- | An implementation of 'zeroL' that works for records where every field
-- is an instance of @'Linear' c@ (that is, every field is additive and can
-- be scaled by the same @c@).
gZeroL :: forall c a. (ADTRecord a, Constraints a (Linear c)) => a
gZeroL = nullaryOp @(Linear c) zeroL

-- | An implementation of '.*' that works for records where every field
-- is an instance of @'Linear' c@ (that is, every field is additive and can
-- be scaled by the same @c@).
gScale :: forall c a. (ADTRecord a, Constraints a (Linear c)) => c -> a -> a
gScale c = unaryOp @(Linear c) (c .*)

-- | Class for values supporting an inner product and various norms.
class Linear c a => Metric c a where
    infixl 7 <.>
    -- | Sum of component-wise product
    (<.>)    :: a -> a -> c
    -- | Maximum absolute component.  Is undefined if no components exist.
    norm_inf :: a -> c
    -- | Number of non-zero components
    norm_0   :: a -> c
    -- | Sum of absolute components
    norm_1   :: a -> c
    -- | Square root of sum of squared components
    norm_2    :: a -> c
    -- | Sum of squared components
    quadrance :: a -> c

    default (<.>) :: (ADT a, Constraints a (Metric c)) => a -> a -> c
    (<.>) = gDot
    default norm_inf :: (ADT a, Constraints a (Metric c), Ord c) => a -> c
    norm_inf = gNorm_inf
    default norm_0 :: (ADT a, Constraints a (Metric c)) => a -> c
    norm_0 = gNorm_0
    default norm_1 :: (ADT a, Constraints a (Metric c)) => a -> c
    norm_1 = gNorm_1
    default norm_2 :: Floating c => a -> c
    norm_2 = sqrt . quadrance
    default quadrance :: (ADT a, Constraints a (Metric c)) => a -> c
    quadrance = gQuadrance

-- | An implementation of 'gDot' that works for records where every field
-- is an instance of @'Metric' c@.
gDot :: forall c a. (ADT a, Constraints a (Metric c), Num c) => a -> a -> c
gDot x = getSum . mzipWith @(Metric c) (\x' -> Sum . (x' <.>)) x

-- | An implementation of 'norm_inf' that works for records where every
-- field is an instance of @'Metric' c@.
gNorm_inf :: forall c a. (ADT a, Constraints a (Metric c), Ord c) => a -> c
gNorm_inf = getMax
          . fromMaybe (error "norm_inf: Divergent infinity norm")
          . getOption
          . gfoldMap @(Metric c) (Option . Just . Max . abs . norm_inf)

-- | An implementation of 'norm_0' that works for records where every field
-- is an instance of @'Metric' c@.
gNorm_0 :: forall c a. (ADT a, Constraints a (Metric c), Num c) => a -> c
gNorm_0 = getSum . gfoldMap @(Metric c) (Sum . norm_0)

-- | An implementation of 'norm_1' that works for records where every field
-- is an instance of @'Metric' c@.
gNorm_1 :: forall c a. (ADT a, Constraints a (Metric c), Num c) => a -> c
gNorm_1 = getSum . gfoldMap @(Metric c) (Sum . norm_1)

-- | An implementation of 'norm_2' that works for records where every field
-- is an instance of @'Metric' c@.
gNorm_2 :: forall c a. (ADT a, Constraints a (Metric c), Floating c) => a -> c
gNorm_2 = sqrt . gQuadrance

-- | An implementation of 'quadrance' that works for records where every
-- field is an instance of @'Metric' c@.
gQuadrance :: forall c a. (ADT a, Constraints a (Metric c), Num c) => a -> c
gQuadrance = getSum . gfoldMap @(Metric c) (Sum . quadrance)

-- | Instaces of 'Linear' that support certain in-place mutations.
-- Inspired by the BLAS Level 1 API.  A @'LinearInPlace' m v c a@ means
-- that @v@ is a mutable reference to an @a@ that can be updated as an
-- action in monad @m@.
class (Mutable s a, Linear c a) => LinearInPlace s c a where
    -- | Add a value in-place.
    (.+.=) :: (PrimMonad m, PrimState m ~ s) => Ref s a -> a -> m ()

    -- | Scale a value in-place.
    (.*=)  :: (PrimMonad m, PrimState m ~ s) => Ref s a -> c -> m ()

    -- | Add a scaled value in-place.
    (.*+=) :: (PrimMonad m, PrimState m ~ s) => Ref s a -> (c, a) -> m ()

    r .+.= x      = modifyRef' r (.+. x)
    r  .*= c      = modifyRef' r (c .*)
    r .*+= (c, x) = modifyRef' r ((c .* x) .+.)

    infix 4 .+.=
    infix 4 .*=
    infix 4 .*+=

-- | Given some starting reference @v@, add every item in a foldable
-- container into that reference in-place.
sumLinearInPlace :: (LinearInPlace s c a, Foldable t, PrimMonad m, PrimState m ~ s) => Ref s a -> t a -> m ()
sumLinearInPlace v = mapM_ (v .+.=)

-- | Newtype wrapper that gives "simple" 'Linear', 'Metric', and
-- 'LinearInPlace' instances for instances of 'Num'.
--
-- This can be used with the /-XDerivingVia/ extension:
--
-- @
-- deriving via (LinearNum Double) instance Linear Double Double
-- deriving via (LinearNum Double) instance Metric Double Double
-- instance Ref s Double v => LinearInPlace s v Double Double
-- @
newtype LinearNum a = LinearNum { getLinearNum :: a }
  deriving ( Show, Eq, Ord
           , Functor, Foldable, Traversable
           , Enum, Bounded
           , Num, Fractional, Floating, Real, Integral, RealFrac, RealFloat
           , Generic, Typeable, Data
           )
instance NFData a => NFData (LinearNum a)

instance Num a => Linear a (LinearNum a) where
    (.+.) = (+)
    zeroL = 0
    (.*)  = coerce ((*) :: a -> a -> a)
instance Num a => Metric a (LinearNum a) where
    (<.>)     = coerce ((*) :: a -> a -> a)
    norm_inf  = coerce (abs :: a -> a)
    norm_0    = coerce (abs . signum :: a -> a)
    norm_1    = coerce (abs :: a -> a)
    norm_2    = coerce (abs :: a -> a)
    quadrance = coerce ((^ (2 :: Int)) :: a -> a)

deriving via (LinearNum Int)         instance Linear Int Int
deriving via (LinearNum Integer)     instance Linear Integer Integer
deriving via (LinearNum Rational)    instance Linear Rational Rational
deriving via (LinearNum Float)       instance Linear Float Float
deriving via (LinearNum Double)      instance Linear Double Double
deriving via (LinearNum (Complex a)) instance RealFloat a => Linear (Complex a) (Complex a)

deriving via (LinearNum Int)         instance Metric Int Int
deriving via (LinearNum Integer)     instance Metric Integer Integer
deriving via (LinearNum Rational)    instance Metric Rational Rational
deriving via (LinearNum Float)       instance Metric Float Float
deriving via (LinearNum Double)      instance Metric Double Double
deriving via (LinearNum (Complex a)) instance RealFloat a => Metric (Complex a) (Complex a)

instance Mutable s Int                        => LinearInPlace s Int Int
instance Mutable s Integer                    => LinearInPlace s Integer Integer
instance Mutable s Rational                   => LinearInPlace s Rational Rational
instance Mutable s Float                      => LinearInPlace s Float Float
instance Mutable s Double                     => LinearInPlace s Double Double
instance (Mutable s (Complex a), RealFloat a) => LinearInPlace s (Complex a) (Complex a)

instance (Num a, VG.Vector v a, KnownNat n) => Linear a (SVG.Vector v n a) where
    (.+.)    = (+)
    zeroL    = 0
    c .* xs  = SVG.map (c *) xs

instance (Floating a, Ord a, VG.Vector v a, KnownNat n) => Metric a (SVG.Vector v n a) where
    xs <.> ys = SVG.sum (xs * ys)
    norm_inf  = SVG.foldl' (\x y -> max (abs x) y) 0
    norm_0    = fromIntegral . SVG.length
    norm_1    = SVG.sum . abs
    quadrance = SVG.sum . (^ (2 :: Int))

instance (Num a, mv ~ VG.Mutable v, VG.Vector v a, KnownNat n)
      => LinearInPlace s a (SVG.Vector v n a) where
    r .+.= xs = flip SVG.imapM_ xs $ \i x ->
      SVGM.modify r (+ x) i
    r .*= c = forM_ finites $ \i ->
      SVGM.modify r (c *) i
    r .*+= (c, xs) = flip SVG.imapM_ xs $ \i x ->
      SVGM.modify r (+ (c * x)) i

instance KnownNat n => Linear Double (H.R n) where
    (.+.)   = (+)
    zeroL   = 0
    c .* xs = H.konst c * xs
instance KnownNat n => Metric Double (H.R n) where
    (<.>)     = (H.<.>)
    norm_inf  = H.norm_Inf
    norm_0    = H.norm_0
    norm_1    = H.norm_1
    norm_2    = H.norm_2
    quadrance = (**2) . H.norm_2
instance KnownNat n => LinearInPlace s Double (H.R n) where
    MR v .+.= x = v .+.= H.rVec x
    MR v  .*= c = v  .*= c
    MR v .*+= (c, x) = v .*+= (c, H.rVec x)

instance (KnownNat n, KnownNat m) => Linear Double (H.L n m) where
    (.+.)   = (+)
    zeroL   = 0
    c .* xs = H.konst c * xs
instance (KnownNat n, KnownNat m) => Metric Double (H.L n m) where
    (<.>)     = (UH.<.>) `on` UH.flatten . H.extract
    norm_inf  = UH.maxElement . H.extract . abs
    norm_0    = sum . map norm_0 . H.toRows
    norm_1    = UH.sumElements . H.extract
    norm_2    = UH.norm_2 . UH.flatten . H.extract
    quadrance = (**2) . norm_2
instance (KnownNat n, KnownNat k) => LinearInPlace s Double (H.L n k) where
    ML v .+.= x = v .+.= H.lVec x
    ML v  .*= c = v  .*= c
    ML v .*+= (c, x) = v .*+= (c, H.lVec x)

instance (Linear c a, Linear c b) => Linear c (a, b) where
instance (Linear c a, Linear c b, Linear c d) => Linear c (a, b, d) where
instance (Linear c a, Linear c b, Linear c d, Linear c e) => Linear c (a, b, d, e) where
instance (Linear c a, Linear c b, Linear c d, Linear c e, Linear c f) => Linear c (a, b, d, e, f) where

instance (Metric c a, Metric c b, Ord c, Floating c) => Metric c (a, b)
instance (Metric c a, Metric c b, Metric c d, Ord c, Floating c) => Metric c (a, b, d)
instance (Metric c a, Metric c b, Metric c d, Metric c e, Ord c, Floating c) => Metric c (a, b, d, e)
instance (Metric c a, Metric c b, Metric c d, Metric c e, Metric c f, Ord c, Floating c) => Metric c (a, b, d, e, f)

instance (Mutable s (a, b), Linear c a, Linear c b) => LinearInPlace s c (a, b)
instance (Mutable s (a, b, d), Linear c a, Linear c b, Linear c d) => LinearInPlace s c (a, b, d)
instance (Mutable s (a, b, d, e), Linear c a, Linear c b, Linear c d, Linear c e) => LinearInPlace s c (a, b, d, e)
instance (Mutable s (a, b, d, e, f), Linear c a, Linear c b, Linear c d, Linear c e, Linear c f) => LinearInPlace s c (a, b, d, e, f)

instance Linear c (f a) => Linear c (Rec f '[a]) where
    x :& RNil .+. y :& RNil = (x .+. y) :& RNil
    zeroL = zeroL :& RNil
    c .* (x :& RNil) = (c .* x) :& RNil

instance (Linear c (f a), Linear c (Rec f (b ': bs))) => Linear c (Rec f (a ': b ': bs)) where
    x :& xs .+. y :& ys = (x .+. y) :& (xs .+. ys)
    zeroL = zeroL :& zeroL
    c .* (x :& xs) = (c .* x) :& (c .* xs)

instance Metric c (f a) => Metric c (Rec f '[a]) where
    (x :& RNil) <.> (y :& RNil) = x <.> y
    norm_inf (x :& RNil) = norm_inf x
    norm_0 (x :& RNil) = norm_0 x
    norm_1 (x :& RNil) = norm_1 x
    norm_2 (x :& RNil) = norm_2 x
    quadrance (x :& RNil) = quadrance x

instance (Floating c, Ord c, Metric c (f a), Metric c (Rec f (b ': bs))) => Metric c (Rec f (a ': b ': bs)) where
    (<.>) = undefined
    norm_inf (x :& xs) = norm_0 x `max` norm_0 xs
    norm_0 (x :& xs) = norm_0 x + norm_0 xs
    norm_1 (x :& xs) = norm_1 x + norm_1 xs
    norm_2 = sqrt . quadrance
    quadrance (x :& xs) = quadrance x + quadrance xs

instance LinearInPlace s c (f a) => LinearInPlace s c (Rec f '[a]) where
    (RecRef v :& RNil) .+.= (x :& RNil)    = v .+.= x
    (RecRef v :& RNil) .*=  c              = v .*=  c
    (RecRef v :& RNil) .*+= (c, x :& RNil) = v .*+= (c, x)

instance ( LinearInPlace s c (f a)
         , LinearInPlace s c (Rec f (b ': bs))
         )
        => LinearInPlace s c (Rec f (a ': b ': bs)) where
    (RecRef v :& vs) .+.= (x :& xs)    = do v .+.= x; vs .+.= xs
    (RecRef v :& vs) .*=  c            = do v .*=  c; vs .*=  c
    (RecRef v :& vs) .*+= (c, x :& xs) = do v .*+= (c, x); vs .*+= (c, xs)

-- | If @a@ and @b@ are both 'Linear' instances, then if @a@ is equal to
-- @b@, their scalars @c@ and @d@ must also be equal.  This is necessary
-- because GHC isn't happy with the functional dependency for some reason.
linearWit
    :: forall a c d. (Linear c a, Linear d a)
    => (c :~: d)
linearWit = unsafeCoerce Refl


module Parser (readExpr, readExprList) where

import Types

import Numeric
import Data.Ratio
import Data.Complex
import Control.Monad.Error
import Text.ParserCombinators.Parsec hiding (spaces)

----------
-- Helpers
----------
symbol :: Parser Char
symbol = oneOf "!#$%&|*+-/:<=>?@^_~"

spaces :: Parser ()
spaces = skipMany1 space

escapedChar :: Parser String
escapedChar = do backslash <- char '\\'
                 escaped <- oneOf "nrt\"\\"
                 return [backslash, escaped]

----------------
-- Token parsers
----------------
parseString :: Parser LispVal
parseString = do _ <- char '"'
                 x <- many (noneOf "\"") <|> escapedChar
                 _ <- char '"'
                 return $ String x

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

parseNumber :: Parser LispVal
parseNumber = fmap (Number . read) (many1 digit)

parseHashPrefix :: Parser LispVal
parseHashPrefix = char '#' >> (parseOctal
                               <|> parseDec
                               <|> parseHex
                               <|> parseBin
                               <|> parseChar
                               <|> parseBool)

-- Simple types parsing
parseNumberHelper prefix filter reader = do char prefix
                                            number <- many1 filter
                                            return $ (Number . reader) number

parseOctal :: Parser LispVal
parseOctal = parseNumberHelper 'o' octDigit (fst . head . readOct)

parseHex :: Parser LispVal
parseHex = parseNumberHelper 'h' hexDigit (fst . head . readHex)

parseDec :: Parser LispVal
parseDec = parseNumberHelper 'd' digit read

parseBin :: Parser LispVal
parseBin = parseNumberHelper 'b' (oneOf "01") binToDec
  where binToDec = foldl (\acc x -> acc * 2 + (if x == '0' then 0 else 1)) 0

parseChar :: Parser LispVal
parseChar = fmap Character (char '\\' >> anyChar)

parseBool :: Parser LispVal
parseBool = fmap (Bool . (== 't')) (oneOf "ft")

parseFloat :: Parser LispVal
parseFloat = do whole <- many1 digit
                _ <- char '.'
                rest <- many1 digit
                return $ Float $ read (whole ++ "." ++ rest)

parseComplex :: Parser LispVal
parseComplex = do real <- parseNumber <|> parseFloat
                  _ <- char '+'
                  imag <- parseNumber <|> parseFloat
                  _ <- char 'i'
                  return $ Complex (toDouble real :+ toDouble imag)
              where toDouble (Float d) = d
                    toDouble (Number n) = fromInteger n
                    toDouble n = error $ "Expected a number, received: " ++ show n

parseRational :: Parser LispVal
parseRational = do nom <- parseNumber
                   _ <- char '/'
                   den <- parseNumber
                   return $ Rational (toNum nom % toNum den)
                where toNum (Number n) = n
                      toNum n = error $ "Expected a number, received: " ++ show n

-- Recursive type parsing
parseList :: Parser LispVal
parseList = fmap List $ sepBy parseExp spaces

parseDottedList :: Parser LispVal
parseDottedList = do car <- endBy parseExp spaces
                     cdr <- char '.' >> spaces >> parseExp
                     return $ DottedList car cdr

parseLists :: Parser LispVal
parseLists = do _ <- char '('
                x <- try parseList <|> parseDottedList
                _ <- char ')'
                return x

parseQuoted :: Parser LispVal
parseQuoted = char '\'' >> parseExp >>= (\e -> return $ List [Atom "quote", e])

parseExp :: Parser LispVal
parseExp = parseHashPrefix
           <|> parseAtom
           <|> parseString
           <|> try parseFloat
           <|> try parseComplex
           <|> try parseRational
           <|> parseNumber
           <|> parseQuoted
           <|> parseLists

readOrThrow :: Parser a -> String -> ThrowsError a
readOrThrow parser input = case parse parser "lisp" input of
  Left  err -> throwError $ Parser err
  Right val -> return val

readExpr = readOrThrow parseExp
readExprList = readOrThrow (endBy parseExp spaces)


{-# LANGUAGE OverloadedStrings #-}

module Releaser.Demand.Ops
  ( demandUniformIn3To15FixedDds
  , demandConst9FixedDds
  , demandConst10FixedDds
  , demandConst11FixedDds
  , demandUnif95_175
  , demandUnif78_158
  , demandExp135
  , demandExp118
  , demandExp105
  ) where

import           Statistics.Distribution.Exponential
import           Statistics.Distribution.Uniform

import           SimSim

import           Releaser.Demand.Type
import           Releaser.SettingsPeriod
import           Releaser.Util

dds :: Integer
dds = 7

dueDateSlack :: Time
dueDateSlack = fromInteger dds * periodLength

demandUniformIn3To15FixedDds :: ConfigDemand
demandUniformIn3To15FixedDds = ConfigDemand ("U(3,15) with DDS=" <> tshow dueDateSlack) dds (\sim -> generateOrdersUniform sim 3 15 dueDateSlack)

demandConst9FixedDds :: ConfigDemand
demandConst9FixedDds = ConfigDemand ("Const(9) with DDS=" <> tshow dueDateSlack) dds (\sim -> generateOrdersUniform sim 9 9 dueDateSlack)

demandConst10FixedDds :: ConfigDemand
demandConst10FixedDds = ConfigDemand ("Const(10) with DDS=" <> tshow dueDateSlack) dds (\sim -> generateOrdersUniform sim 10 10 dueDateSlack)

demandConst11FixedDds :: ConfigDemand
demandConst11FixedDds = ConfigDemand ("Const(11) with DDS=" <> tshow dueDateSlack) dds (\sim -> generateOrdersUniform sim 11 11 dueDateSlack)

demandUnif95_175 :: ConfigDemand
demandUnif95_175 =
  ConfigDemand
    ("Uniform interarrival-time w/ Unif(95,175) with DDS=" <> tshow dueDateSlack)
    dds
    (\sim ->
       let pts = productTypes sim
        in generateOrdersFixedDueDateSlack sim (uniformDistr 0.098958333 0.182291667) (uniformDistr 0.5001 (fromIntegral (length pts) + 0.4999)) dueDateSlack)

demandUnif78_158 :: ConfigDemand
demandUnif78_158 =
  ConfigDemand
    ("Uniform interarrival-time w/ Unif(78,158) with DDS=" <> tshow dueDateSlack)
    dds
    (\sim ->
       let pts = productTypes sim
        in generateOrdersFixedDueDateSlack sim (uniformDistr (78 / 960) (158 / 960)) (uniformDistr 0.5001 (fromIntegral (length pts) + 0.4999)) dueDateSlack)

demandExp118 :: ConfigDemand
demandExp118 =
  ConfigDemand
    ("Exponential interarrival-time w/ Exp(118) with DDS=" <> tshow dueDateSlack)
    dds
    (\sim ->
       let pts = productTypes sim
        in generateOrdersFixedDueDateSlack sim (exponential (960 / 118)) (uniformDistr 0.5001 (fromIntegral (length pts) + 0.4999)) dueDateSlack)

demandExp135 :: ConfigDemand
demandExp135 =
  ConfigDemand
    ("Exponential interarrival-time w/ Exp(135) with DDS=" <> tshow dueDateSlack)
    dds
    (\sim ->
       let pts = productTypes sim
        in generateOrdersFixedDueDateSlack sim (exponential (960 / 135)) (uniformDistr 0.5001 (fromIntegral (length pts) + 0.4999)) dueDateSlack)

demandExp105 :: ConfigDemand
demandExp105 =
  ConfigDemand
    ("Exponential interarrival-time w/ Exp(105) with DDS=" <> tshow dueDateSlack)
    dds
    (\sim ->
       let pts = productTypes sim
           -- test :: IO ()
           -- test = do
           --   nrs <- foldM (\xs _ -> do
           --                  x <- generateOrdersFixedDueDateSlack sim (exponential (960 / 105)) (uniformDistr 0.5001 (fromIntegral (length pts) + 0.4999)) dueDateSlack
           --                  return $ length x : xs
           --              ) [] [0..10000]
           --   putStrLn $ "res: " ++ show (fromIntegral (sum nrs) / fromIntegral (length nrs))
        in generateOrdersFixedDueDateSlack sim (exponential (960 / 105)) (uniformDistr 0.5001 (fromIntegral (length pts) + 0.4999)) dueDateSlack)

-- interArrivalTimeDistribution :: UniformDistribution
-- interArrivalTimeDistribution = uniformDistr (61.935483871/960) (274.285714286/960)

-- productTypeDistribution :: UniformDistribution
-- productTypeDistribution = uniformDistr 1 2

-- demandExponential

  -- generateOrdersFixedDueDateSlack sim interArrivalTimeDistribution productTypeDistribution dueDateSlack


{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module :
-- Copyright : (c) 2013 Boyun Tang
-- License : BSD-style
-- Maintainer : tangboyun@hotmail.com
-- Stability : experimental
-- Portability : ghc
--
--
--
-----------------------------------------------------------------------------
module Main where

import           Control.Arrow
import           Data.Colour.Names
import           Data.Colour.Palette.BrewerSet
import qualified Data.HashMap.Strict           as H
import qualified Data.List                     as L
import qualified Data.Text                     as T
import qualified Data.Text.IO                  as T
import qualified Data.Text.Read                as T
import qualified Data.Vector                   as V
import qualified Data.Vector.Unboxed           as UV
import           Diagrams.Backend.Cairo
import           Diagrams.HeatMap
import           Diagrams.HeatMap.Type
import           Diagrams.Prelude
import           Statistics.Quantile
import           Statistics.Sample
import           System.Environment
import           System.FilePath

cluDiffOpt :: ClustOpt
cluDiffOpt = ClustOpt
  { colorOpt = color2
  , rowCluster = Nothing -- Just (eucDis,UPGMA,LeftTree)
  , colCluster = Just (eucDis,UPGMA,BottomTree)}

color1 = let cSet = brewerSet RdBu 11
         in Three (cSet !! 9) white (cSet !! 1)

color2 = Three green black red

mkPara w h i j (a,b,c) = Para
  { clustOpt = cluDiffOpt
  , colorVal = ColorVal a b c
  , matrixHeight = h
  , matrixWidth = w
  , rowTreeHeight = 0.2 * min w h
  , colTreeHeight = 0.2 * min w h
  , rowFontSize = 0.8 * h / i
  , colFontSize = 0.6 * w / j
  , legendFontSize = 0.5 * w * 0.1
  , fontName = "Arial"
  , colorBarPos = Horizontal
  , tradeOff = Quality
  , colTreeLineWidth = 0.5
  , rowTreeLineWidth = 0.5
  }

eucDis :: (UV.Unbox a, Num a) => UV.Vector a -> UV.Vector a -> a
eucDis vec1 vec2 = UV.sum $ UV.zipWith (\v1 v2 -> (v1-v2)*(v1-v2)) vec1 vec2

toZscore :: UV.Vector Double -> UV.Vector Double
toZscore vec =
    let (m,v) = meanVarianceUnb vec
    in UV.map (\e -> (e - m) / sqrt v ) vec

parseTSV :: Bool -> FilePath -> FilePath -> IO Dataset
parseTSV doNormalization datFile labelFile = do
    sampleHash <- T.readFile labelFile >>=
                  return . H.fromList .
                  map (((!! 0) &&& (!! 1)) . T.split (== '\t')) .
                  T.lines .
                  T.filter (/= '\r')
    T.readFile datFile >>=
        return .
        (\(h:ts) ->
          let sIDs = V.fromList $ tail h
              grIDs = V.map (sampleHash `myIdx`) sIDs
              gIDs = V.fromList $ map head ts
              j = V.length sIDs
              i = V.length gIDs
              func = if doNormalization
                     then toZscore
                     else id
              datum = UV.concat $ map (func . UV.fromList . map (fst . fromRight . T.double) . tail) ts
              m = Matrix i j RowMajor datum
          in Dataset (Just gIDs) (Just sIDs) (Just grIDs) m
        ) . map (T.split (== '\t')) . T.lines . T.filter (/= '\r')
  where
    myIdx h k = if k `H.member` h
                then h H.! k
                else error $ show k
    fromRight :: Show a => Either a b -> b
    fromRight (Right b) = b
    fromRight (Left a) = error $ show a

main :: IO ()
main = do
   doNormal:w:h:datFile:labelFile:_ <- getArgs
   dataset <- parseTSV (read doNormal) datFile labelFile
   let vMin = continuousBy medianUnbiased 1 100 $ dat $ datM $ dataset
       vMean = if (read doNormal)
               then 0
               else continuousBy medianUnbiased 50 100 $ dat $ datM $ dataset
       vMax = continuousBy medianUnbiased 99 100 $ dat $ datM $ dataset
       j = fromIntegral $ nCol $ datM dataset
       i = fromIntegral $ nRow $ datM dataset
       para = mkPara (read w) (read h) i j (vMin,vMean,vMax)
   renderCairo (replaceExtension datFile "pdf") (mkWidth 600) $ pad 1.03 $ fst $ plotHeatMap para dataset


{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances #-}

module MyVectorType (module MyVectorType
#ifdef VECTOR_HMATRIX
 , Matrix.toLists, Matrix.fromLists
 , Matrix.trans
 , Vector.toList, Vector.fromList
 , Vector.dim
 , Numeric.Container.vXm, Numeric.Container.sumElements
#endif
)
where

#ifdef VECTOR_HMATRIX
import qualified Data.Packed.Vector as Vector
import qualified Data.Packed.Matrix as Matrix
import qualified Numeric.Container
import Numeric.Container (Element, Container)
import Numeric.LinearAlgebra () -- instances
type Vector = Vector.Vector
type Matrix = Matrix.Matrix
instance Ord (Matrix Double) where
    compare a b = compare (Matrix.toLists a) (Matrix.toLists b)
cmap :: (Element b, Container c e) => (e -> b) -> c e -> c b
cmap a  = Numeric.Container.cmap a

add :: Container c e => c e -> c e -> c e
add a = Numeric.Container.add a

transFix :: Matrix Double -> Matrix Double
transFix = id

-- concat :: (Storable a) => [Vector a] -> Vector a
concat :: [Vector Double] -> Vector Double
concat = Vector.join
#endif

#ifdef VECTOR_VECTOR
import Data.Vector.Binary () -- instances
import Data.List (transpose)
#ifdef VECTOR_DDOT
import Foreign.C.Types
import Foreign
import qualified Data.Vector.Storable as V
import qualified Data.Vector.Storable.Internal as VI
#else
import qualified Data.Vector as V
#endif

type Vector a = V.Vector a
type Matrix a = [Vector a]

#ifdef VECTOR_DDOT
foreign import ccall "cblas_ddot" cblas_ddot :: CInt -> Ptr CDouble -> CInt -> Ptr CDouble -> CInt -> CDouble
vDOTv :: Vector Double -> Vector Double -> Double
vDOTv v1 v2 = let (fptr'1,len1) = V.unsafeToForeignPtr0 (V.unsafeCast v1)
                  (fptr'2,len2) = V.unsafeToForeignPtr0 (V.unsafeCast v2)
                  ptr'v1 = VI.getPtr fptr'1
                  ptr'v2 = VI.getPtr fptr'2
                  r = (cblas_ddot (fromIntegral len1) ptr'v1 1 ptr'v2 1)
              in realToFrac r
vXm :: Vector Double -> Matrix Double -> Vector Double
vXm v m = V.fromList $ map (vDOTv v) m
#else
vXm :: Vector Double -> Matrix Double -> Vector Double
vXm v m = V.fromList $ map (\ vm -> V.sum $ V.zipWith (*) v vm) m
#endif

add :: Vector Double -> Vector Double -> Vector Double
add = V.zipWith (+)

cmap :: (Double -> Double) -> Vector Double -> Vector Double
cmap = V.map

toLists :: Matrix Double -> [[Double]]
toLists = map V.toList
fromLists :: [[Double]] -> Matrix Double
fromLists = map V.fromList
trans :: Matrix Double -> Matrix Double
trans = fromLists . transpose . toLists

transFix :: Matrix Double -> Matrix Double
transFix = trans

toList :: Vector Double -> [Double]
toList = V.toList
fromList :: [Double] -> Vector Double
fromList = V.fromList

sumElements :: Vector Double -> Double
sumElements = V.sum

dim :: Vector Double -> Int
dim = V.length

concat :: [Vector a] -> Vector a
concat = V.concat
#endif

-- #ifdef VECTOR_DPH
-- import qualified Prelude
-- import Prelude ((.), ($))
-- -- import Data.Array.Parallel
-- -- import Data.Array.Parallel.Prelude
-- import Data.Array.Parallel.Prelude.Double
-- import Data.Array.Parallel.Prelude.Int (Int)
-- import Data.Array.Parallel.Unlifted as V
-- import Data.List (transpose)
--
-- type Vector a = V.Array a
-- type Matrix a = [Vector a]
--
-- vXm :: Vector Double -> Matrix Double -> Vector Double
-- vXm v m = Prelude.map (\ vm -> V.sum $ V.zipWith (*) v vm) m
--
-- add :: Vector Double -> Vector Double -> Vector Double
-- add = V.zipWith (+)
--
-- cmap :: (Double -> Double) -> Vector Double -> Vector Double
-- cmap = V.map
--
-- toLists :: Matrix Double -> [[Double]]
-- toLists = V.toList . V.map V.toList
-- fromLists :: [[Double]] -> Matrix Double
-- fromLists = V.map V.fromList . V.fromList
-- trans :: Matrix Double -> Matrix Double
-- trans = fromLists . transpose . toLists
--
-- transFix :: Matrix Double -> Matrix Double
-- transFix = trans
--
-- toList :: Vector Double -> [Double]
-- toList = V.toList
-- fromList :: [Double] -> Vector Double
-- fromList = V.fromList
--
-- sumElements :: Vector Double -> Double
-- sumElements = V.sum
--
-- dim :: Vector Double -> Int
-- dim = V.length
--
-- #endif


{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Strict            #-}
{-# LANGUAGE StrictData        #-}
module Utils.BLAS where

import           Data.Complex
import           Data.Vector.Storable            as VS
import           Foreign.CUDA.BLAS               as BLAS
import           Foreign.CUDA.Driver             as CUDA
import           Foreign.Marshal
import           Numerical.HBLAS.BLAS.FFI
import           Numerical.HBLAS.BLAS.FFI.Level1
import           Numerical.HBLAS.BLAS.FFI.Level3

type BLASMMT e
   = Int -> Int -> Int -> VS.Vector e -> VS.Vector e -> IO (VS.Vector e)

type BLASDOTU e = VS.Vector e -> VS.Vector e -> IO e

class BLAS a where
  gemmBLAS :: BLASMMT a
  dotuBLAS :: BLASDOTU a

instance BLAS Double where
  {-# INLINE gemmBLAS #-}
  gemmBLAS m' n' k' a b = do
    let output = VS.replicate (m' * n') 0
        !m = fromIntegral m'
        !n = fromIntegral n'
        !k = fromIntegral k'
    unsafeWith a $ \aPtr ->
      unsafeWith b $ \bPtr ->
        unsafeWith output $ \cPtr ->
          cblas_dgemm_safe
            (encodeOrder BLASRowMajor)
            (encodeTranspose BlasNoTranspose)
            (encodeTranspose BlasNoTranspose)
            m
            n
            k
            1
            aPtr
            k
            bPtr
            n
            0
            cPtr
            n
    return output
  {-# INLINE dotuBLAS #-}
  dotuBLAS vec1 vec2 =
    unsafeWith vec1 $ \ptr1 ->
      unsafeWith vec2 $ \ptr2 ->
        cblas_ddot_safe (fromIntegral . VS.length $ vec1) ptr1 1 ptr2 1

instance BLAS (Complex Double) where
  {-# INLINE gemmBLAS #-}
  gemmBLAS m' n' k' a b = do
    let output = VS.replicate (m' * n') 0
        !m = fromIntegral m'
        !n = fromIntegral n'
        !k = fromIntegral k'
    with 1 $ \alphaPtr ->
      with 0 $ \betaPtr ->
        unsafeWith a $ \aPtr ->
          unsafeWith b $ \bPtr ->
            unsafeWith output $ \cPtr ->
              cblas_zgemm_safe
                (encodeOrder BLASRowMajor)
                (encodeTranspose BlasNoTranspose)
                (encodeTranspose BlasNoTranspose)
                m
                n
                k
                alphaPtr
                aPtr
                k
                bPtr
                n
                betaPtr
                cPtr
                n
    return output
  {-# INLINE dotuBLAS #-}
  dotuBLAS vec1 vec2 = do
    let output = VS.singleton 0
    unsafeWith vec1 $ \ptr1 ->
      unsafeWith vec2 $ \ptr2 ->
        unsafeWith output $ \outPtr ->
          cblas_zdotu_safe
            (fromIntegral . VS.length $ vec1)
            ptr1
            1
            ptr2
            1
            outPtr
    return . VS.head $ output

type CUBLASMMT a b e
   = Handle -> Int -> Int -> Int -> a e -> b e -> IO (VS.Vector e)

class CUBLAS a where
  gemmCuBLAS :: CUBLASMMT DevicePtr DevicePtr a

instance CUBLAS Float where
  {-# INLINE gemmCuBLAS #-}
  gemmCuBLAS handle !m !n !k matA matB = do
    let !sizeC = m * n
        output = VS.replicate sizeC 0
    with 1 $ \alpha ->
      with 0 $ \beta ->
        CUDA.allocaArray sizeC $ \matC ->
          unsafeWith output $ \outputPtr -> do
            sgemm handle N N n m k alpha matB n matA k beta matC n
            CUDA.peekArray sizeC matC outputPtr
    return output

instance CUBLAS Double where
  {-# INLINE gemmCuBLAS #-}
  gemmCuBLAS handle !m !n !k matA matB = do
    let !sizeC = m * n
        output = VS.replicate sizeC 0
    with 1 $ \alpha ->
      with 0 $ \beta ->
        CUDA.allocaArray sizeC $ \matC ->
          unsafeWith output $ \outputPtr -> do
            dgemm handle N N n m k alpha matB n matA k beta matC n
            CUDA.peekArray sizeC matC outputPtr
    return output

instance CUBLAS (Complex Float) where
  {-# INLINE gemmCuBLAS #-}
  gemmCuBLAS handle !m !n !k matA matB = do
    let !sizeC = m * n
        output = VS.replicate sizeC 0
    with 1 $ \alpha ->
      with 0 $ \beta ->
        CUDA.allocaArray sizeC $ \matC ->
          unsafeWith output $ \outputPtr -> do
            cgemm handle N N n m k alpha matB n matA k beta matC n
            CUDA.peekArray sizeC matC outputPtr
    return output

instance CUBLAS (Complex Double) where
  {-# INLINE gemmCuBLAS #-}
  gemmCuBLAS handle !m !n !k matA matB = do
    let !sizeC = m * n
        output = VS.replicate sizeC 0
    with 1 $ \alpha ->
      with 0 $ \beta ->
        CUDA.allocaArray sizeC $ \matC ->
          unsafeWith output $ \outputPtr -> do
            zgemm handle N N n m k alpha matB n matA k beta matC n
            CUDA.peekArray sizeC matC outputPtr
    return output

{-# INLINE unsafeWithGPU #-}
unsafeWithGPU :: (Storable e) => VS.Vector e -> (DevicePtr e -> IO b) -> IO b
unsafeWithGPU vec f = do
  let !len = VS.length vec
  CUDA.allocaArray len $ \devPtr -> do
    unsafeWith vec $ \ptr -> CUDA.pokeArray len ptr devPtr
    f devPtr

{-# INLINE gemmCuBLAS10 #-}
gemmCuBLAS10 :: (CUBLAS e, Storable e) => CUBLASMMT VS.Vector DevicePtr e
gemmCuBLAS10 handle m n k a matB =
  unsafeWithGPU a $ \matA -> gemmCuBLAS handle m n k matA matB

{-# INLINE gemmCuBLAS01 #-}
gemmCuBLAS01 :: (CUBLAS e, Storable e) => CUBLASMMT DevicePtr VS.Vector e
gemmCuBLAS01 handle m n k matA b =
  unsafeWithGPU b $ \matB -> gemmCuBLAS handle m n k matA matB

{-# INLINE gemmCuBLAS11 #-}
gemmCuBLAS11 :: (CUBLAS e, Storable e) => CUBLASMMT VS.Vector VS.Vector e
gemmCuBLAS11 handle m n k a b =
  unsafeWithGPU a $ \matA ->
    unsafeWithGPU b $ \matB -> gemmCuBLAS handle m n k matA matB


{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE FlexibleContexts      #-}
{-|
Module      : Grenade.Layers.Deconvolution
Description : Deconvolution layer
Copyright   : (c) Huw Campbell, 2016-2017
License     : BSD2
Stability   : experimental

A deconvolution layer is in many ways a convolution layer in reverse.
It learns a kernel to apply to each pixel location, spreading it out
into a larger layer.

This layer is important for image generation tasks, such as GANs on
images.
-}
module Grenade.Layers.Deconvolution (
    Deconvolution (..)
  , Deconvolution' (..)
  ) where

import           Data.Maybe
import           Data.Proxy
import           Data.Serialize
import           Data.Singletons.TypeLits hiding (natVal)

import           GHC.TypeLits

import Control.DeepSeq (NFData (..))

import           Numeric.LinearAlgebra hiding ( uniformSample, konst )
import qualified Numeric.LinearAlgebra as LA
import           Numeric.LinearAlgebra.Static hiding ((|||), build, toRows)

import           Grenade.Core
import           Grenade.Layers.Internal.Convolution
import           Grenade.Layers.Internal.Update

-- | A Deconvolution layer for a neural network.
--   This uses the im2col Convolution trick popularised by Caffe.
--
--   The Deconvolution layer is a way of spreading out a single response
--   into a larger image, and is useful in generating images.
--
data Deconvolution :: Nat -- Number of channels, for the first layer this could be RGB for instance.
                   -> Nat -- Number of filters, this is the number of channels output by the layer.
                   -> Nat -- The number of rows in the kernel filter
                   -> Nat -- The number of column in the kernel filter
                   -> Nat -- The row stride of the Deconvolution filter
                   -> Nat -- The columns stride of the Deconvolution filter
                   -> * where
  Deconvolution :: ( KnownNat channels
                   , KnownNat filters
                   , KnownNat kernelRows
                   , KnownNat kernelColumns
                   , KnownNat strideRows
                   , KnownNat strideColumns
                   , KnownNat kernelFlattened
                   , kernelFlattened ~ (kernelRows * kernelColumns * filters))
                 => !(L kernelFlattened channels) -- The kernel filter weights
                 -> !(L kernelFlattened channels) -- The last kernel update (or momentum)
                 -> Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns

instance NFData (Deconvolution c f k k' s s') where
  rnf (Deconvolution a b) = rnf a `seq` rnf b `seq` ()

data Deconvolution' :: Nat -- Number of channels, for the first layer this could be RGB for instance.
                    -> Nat -- Number of filters, this is the number of channels output by the layer.
                    -> Nat -- The number of rows in the kernel filter
                    -> Nat -- The number of column in the kernel filter
                    -> Nat -- The row stride of the Deconvolution filter
                    -> Nat -- The columns stride of the Deconvolution filter
                    -> * where
  Deconvolution' :: ( KnownNat channels
                  , KnownNat filters
                  , KnownNat kernelRows
                  , KnownNat kernelColumns
                  , KnownNat strideRows
                  , KnownNat strideColumns
                  , KnownNat kernelFlattened
                  , kernelFlattened ~ (kernelRows * kernelColumns * filters))
               => !(L kernelFlattened channels) -- The kernel filter gradient
               -> Deconvolution' channels filters kernelRows kernelColumns strideRows strideColumns

instance NFData (Deconvolution' c f k k' s s') where
  rnf (Deconvolution' a) = rnf a `seq` ()

instance Show (Deconvolution c f k k' s s') where
  show (Deconvolution a _) = renderConv a
    where
      renderConv mm =
        let m  = extract mm
            ky = fromIntegral $ natVal (Proxy :: Proxy k)
            rs = LA.toColumns m
            ms = map (take ky) $ toLists . reshape ky <$> rs

            render n'  | n' <= 0.2  = ' '
                       | n' <= 0.4  = '.'
                       | n' <= 0.6  = '-'
                       | n' <= 0.8  = '='
                       | otherwise =  '#'

            px = (fmap . fmap . fmap) render ms
        in unlines $ foldl1 (zipWith (\a' b' -> a' ++ "   |   " ++ b')) $ px

instance ( KnownNat c
         , KnownNat f
         , KnownNat k
         , KnownNat k'
         , KnownNat s
         , KnownNat s'
         , KnownNat ((k * k') * f)
         , KnownNat ((k * k') * c)
         , KnownNat (c * ((k * k') * f))) => RandomLayer (Deconvolution c f k k' s s') where
  createRandomWith m gen = do
    wN <- getRandomMatrix i i m gen
    let mm = konst 0
    return $ Deconvolution wN mm
    where i = natVal (Proxy :: Proxy ((k * k') * c))

instance ( KnownNat channels
         , KnownNat filters
         , KnownNat kernelRows
         , KnownNat kernelColumns
         , KnownNat strideRows
         , KnownNat strideColumns
         , KnownNat (kernelRows * kernelColumns * filters)
         ) => UpdateLayer (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) where
  type Gradient (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) = (Deconvolution' channels filters kernelRows kernelColumns strideRows strideColumns)
  runUpdate LearningParameters {..} (Deconvolution oldKernel oldMomentum) (Deconvolution' kernelGradient) =
    let (newKernel, newMomentum) = descendMatrix learningRate learningMomentum learningRegulariser oldKernel kernelGradient oldMomentum
    in Deconvolution newKernel newMomentum

instance ( KnownNat channels
         , KnownNat filters
         , KnownNat kernelRows
         , KnownNat kernelColumns
         , KnownNat strideRows
         , KnownNat strideColumns
         , KnownNat (kernelRows * kernelColumns * filters)
         ) => Serialize (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) where
  put (Deconvolution w _) = putListOf put . toList . flatten . extract $ w
  get = do
      let f  = fromIntegral $ natVal (Proxy :: Proxy channels)
      wN    <- maybe (fail "Vector of incorrect size") return . create . reshape f . LA.fromList =<< getListOf get
      let mm = konst 0
      return $ Deconvolution wN mm

-- | A two dimentional image may have a Deconvolution filter applied to it
instance ( KnownNat kernelRows
         , KnownNat kernelCols
         , KnownNat filters
         , KnownNat strideRows
         , KnownNat strideCols
         , KnownNat inputRows
         , KnownNat inputCols
         , KnownNat outputRows
         , KnownNat outputCols
         , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)
         , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)
         , KnownNat (kernelRows * kernelCols * filters)
         , KnownNat (outputRows * filters)
         ) => Layer (Deconvolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) where
  type Tape (Deconvolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols 1)
  runForwards c (S2D input) =
    runForwards c (S3D input :: S ('D3 inputRows inputCols 1))

  runBackwards c tape grads =
    case runBackwards c tape grads of
      (c', S3D back :: S ('D3 inputRows inputCols 1)) ->  (c', S2D back)

-- | A two dimentional image may have a Deconvolution filter applied to it
instance ( KnownNat kernelRows
         , KnownNat kernelCols
         , KnownNat strideRows
         , KnownNat strideCols
         , KnownNat inputRows
         , KnownNat inputCols
         , KnownNat outputRows
         , KnownNat outputCols
         , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)
         , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)
         , KnownNat (kernelRows * kernelCols * 1)
         , KnownNat (outputRows * 1)
         ) => Layer (Deconvolution 1 1 kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D2 outputRows outputCols) where
  type Tape (Deconvolution 1 1 kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D2 outputRows outputCols) = S ('D3 inputRows inputCols 1)
  runForwards c (S2D input) =
    case runForwards c (S3D input :: S ('D3 inputRows inputCols 1)) of
      (tps, S3D fore :: S ('D3 outputRows outputCols 1)) ->  (tps, S2D fore)

  runBackwards c tape (S2D grads) =
    case runBackwards c tape (S3D grads :: S ('D3 outputRows outputCols 1)) of
      (c', S3D back :: S ('D3 inputRows inputCols 1)) ->  (c', S2D back)

-- | A two dimentional image may have a Deconvolution filter applied to it
instance ( KnownNat kernelRows
         , KnownNat kernelCols
         , KnownNat strideRows
         , KnownNat strideCols
         , KnownNat inputRows
         , KnownNat inputCols
         , KnownNat outputRows
         , KnownNat outputCols
         , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)
         , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)
         , KnownNat (kernelRows * kernelCols * 1)
         , KnownNat (outputRows * 1)
         , KnownNat channels
         ) => Layer (Deconvolution channels 1 kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D2 outputRows outputCols) where
  type Tape (Deconvolution channels 1 kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D2 outputRows outputCols) = S ('D3 inputRows inputCols channels)
  runForwards c input =
    case runForwards c input of
      (tps, S3D fore :: S ('D3 outputRows outputCols 1)) ->  (tps, S2D fore)

  runBackwards c tape (S2D grads) =
    runBackwards c tape (S3D grads :: S ('D3 outputRows outputCols 1))

-- | A three dimensional image (or 2d with many channels) can have
--   an appropriately sized Deconvolution filter run across it.
instance ( KnownNat kernelRows
         , KnownNat kernelCols
         , KnownNat filters
         , KnownNat strideRows
         , KnownNat strideCols
         , KnownNat inputRows
         , KnownNat inputCols
         , KnownNat outputRows
         , KnownNat outputCols
         , KnownNat channels
         , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)
         , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)
         , KnownNat (kernelRows * kernelCols * filters)
         , KnownNat (outputRows * filters)
         ) => Layer (Deconvolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) where

  type Tape (Deconvolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols channels)

  runForwards (Deconvolution kernel _) (S3D input) =
    let ex = extract input
        ek = extract kernel
        ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
        iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)
        kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
        ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)
        sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
        sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)
        ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
        oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

        c  = vid2col 1 1 1 1 ix iy ex

        mt = c LA.<> tr ek

        r  = col2vid kx ky sx sy ox oy mt
        rs = fromJust . create $ r
    in  (S3D input, S3D rs)
  runBackwards (Deconvolution kernel _) (S3D input) (S3D dEdy) =
    let ex = extract input
        ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
        iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)
        kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
        ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)
        sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
        sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)
        ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
        oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

        c  = vid2col 1 1 1 1 ix iy ex

        eo = extract dEdy
        ek = extract kernel

        vs = vid2col kx ky sx sy ox oy eo

        kN = fromJust . create . tr $ tr c LA.<> vs

        dW = vs LA.<> ek

        xW = col2vid 1 1 1 1 ix iy dW
    in  (Deconvolution' kN, S3D . fromJust . create $ xW)

-------------------- GNum instances --------------------

instance (KnownNat strideCols,KnownNat strideRows,KnownNat kernelCols,KnownNat kernelRows,KnownNat filters,KnownNat channels,KnownNat ((kernelRows * kernelCols) * filters),KnownNat
                          ((kernelRows * kernelCols) * channels)) => GNum (Deconvolution channels filters kernelRows kernelCols strideRows strideCols) where
  n |* (Deconvolution w m) = Deconvolution (fromRational n * w) m
  (Deconvolution w m) |+ (Deconvolution w2 m2)  = Deconvolution (fromRational 0.5 * (w+w2)) (fromRational 0.5 * (m+m2))
  gFromRational r = Deconvolution (fromRational r) (fromRational r)

instance (KnownNat strideCols,KnownNat strideRows,KnownNat kernelCols,KnownNat kernelRows,KnownNat filters,KnownNat channels,KnownNat ((kernelRows * kernelCols) * filters),KnownNat
                          ((kernelRows * kernelCols) * channels)) => GNum (Deconvolution' channels filters kernelRows kernelCols strideRows strideCols) where
  _ |* (Deconvolution' g) = Deconvolution' g
  (Deconvolution' g) |+ (Deconvolution' g2)  = Deconvolution' (fromRational 0.5 * (g+g2))
  gFromRational r = Deconvolution' (fromRational r)


module SchemeParser
  (readExpr,
   readExprList) where

import Text.ParserCombinators.Parsec hiding (spaces)
import Control.Monad
import Numeric
import Data.Ratio
import Data.Complex
import qualified Data.Vector as V
import CommonTypes
import Control.Monad.Except

symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=>?@^_~"

spaces :: Parser ()
spaces = skipMany space

escapedCharacters :: Parser Char
escapedCharacters = do
                      char '\\'
                      x <- oneOf "\\\"nrt"
                      return $ case x of
                                 '\\' -> x
                                 '"'  -> x
                                 'n'  -> '\n'
                                 't'  -> '\t'
                                 'r'  -> '\r'

parseString :: Parser LispVal
parseString = do
               char '"'
               x <- many $ escapedCharacters <|> noneOf "\\\""
               char '"'
               return $ String x

parseBool :: Parser LispVal
parseBool = try $ do
              char '#'
              (char 't' >> return (Bool True)) <|> (char 'f' >> return (Bool False))

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

parseDecimal :: Parser LispVal
parseDecimal = Number . read <$> many1 digit

myParseDecimal :: Parser LispVal
myParseDecimal = many1 digit >>= (return . Number . read)

parseDecimal2 :: Parser LispVal
parseDecimal2 = do
                  try $ string "#d"
                  x <- many1 digit
                  (return . Number . read) x

parseOct :: Parser LispVal
parseOct = do
              try $ string "#o"
              x <- many1 octDigit
              (return . Number . oct2dig) x

parseHex :: Parser LispVal
parseHex = do
            try $ string "#x"
            x <- many1 hexDigit
            (return . Number . hex2dig) x

parseBin :: Parser LispVal
parseBin = do
            try $ string "#b"
            x <- many1 $ oneOf "10"
            (return . Number . bin2dig) x

oct2dig x = fst $ head $ readOct x

hex2dig x = fst $ head $ readHex x

bin2dig  = bin2dig' 0
bin2dig' digint "" = digint
bin2dig' digint (x:xs) = let old = 2 * digint + (if x == '0' then 0 else 1)
                            in bin2dig' old xs

parseNumber :: Parser LispVal
parseNumber = myParseDecimal
              <|> parseDecimal2
              <|> parseHex
              <|> parseBin
              <|> parseOct

parseCharacter :: Parser LispVal
parseCharacter = do
                  try $ string "#\\"
                  value <- try (string "newline" <|> string "space")
                    <|> do { x <- anyChar; notFollowedBy alphaNum ; return [x]}
                  return $ Character $ case value of
                                         "space"    -> ' '
                                         "newline"  -> '\n'
                                         otherwise  -> (head value)

parseFloat :: Parser LispVal
parseFloat = do
              x <- many1 digit
              char '.'
              y <- many1 digit
              return $ Float (fst.head $ readFloat (x++"."++y))

parseRatio :: Parser LispVal
parseRatio = do
              x <- many1 digit
              char '/'
              y <- many1 digit
              return $ Ratio (read x % read y)

toDouble :: LispVal -> Double
toDouble (Float d) = d
toDouble (Number n) = fromInteger n

parseComplex :: Parser LispVal
parseComplex = do
                x <- (try parseFloat <|> parseDecimal)
                char '+'
                y <- (try parseFloat <|> parseDecimal)
                char 'i'
                return $ Complex (toDouble x :+ toDouble y)

parseList :: Parser LispVal
parseList = liftM List $ sepBy parseExpr spaces

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

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

parseQuasiQuoted :: Parser LispVal
parseQuasiQuoted = do
                    char '`'
                    x <- parseExpr
                    return $ List [Atom "quasiquote", x]

parseUnQuote :: Parser LispVal
parseUnQuote = do
                char ','
                x <- parseExpr
                return $ List [Atom "unquote", x]

parseVector :: Parser LispVal
parseVector = do
                vectorValues <- sepBy parseExpr spaces
                return $ Vector (V.fromList vectorValues)

parseExpr :: Parser LispVal
parseExpr = parseAtom
            <|> parseString
            <|> try parseComplex
            <|> try parseFloat
            <|> try parseRatio
            <|> try parseNumber
            <|> try parseBool
            <|> try parseCharacter
            <|> parseQuoted
            <|> parseQuasiQuoted
            <|> parseUnQuote
            <|> try  (do
                        string "#("
                        x <- parseVector
                        char ')'
                        return x)
            <|> do
                  char '('
                  x <- try parseList <|> parseDottedList
                  char ')'
                  return x

readOrThrow :: Parser a -> String -> ThrowsError a
readOrThrow parser input = case parse parser "lisp" input of
                   Left err  -> throwError $ Parser err
                   Right val -> return val

readExpr = readOrThrow parseExpr
readExprList = readOrThrow (endBy parseExpr spaces)


{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs        #-}
{-# LANGUAGE MultiParamTypeClasses, NoMonomorphismRestriction             #-}
{-# LANGUAGE OverloadedStrings, PolyKinds, TypeApplications, TypeFamilies #-}
{-# LANGUAGE UndecidableInstances                                         #-}
{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans -Wall #-}
module Main where
import Cases

import           Algebra.Bridge.Singular
import           Algebra.Field.Prime
import           Algebra.Prelude.Core
import           Control.Monad                   (void)
import qualified Data.Text                       as T
import qualified Data.Vector.Unboxed             as V
import           Prelude                         (read)
import           Statistics.Resampling
import           Statistics.Resampling.Bootstrap
import           Statistics.Types
import qualified System.Random.MWC               as Rand

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 50 $ benchIdeal fun ideal
  res  <- resample gen [Mean, StdDev] 1000 i2Gr
  let [Estimate mn (ConfInt lbmn ubmn _) ,Estimate dv _]
        = bootstrapBCA cl95 i2Gr res
  putStrLn lab
  mapM_ (putStrLn . ('\t':))
    ["Mean:\t" ++ show mn ++ "(ms)"
    ,"MeanLB:\t" ++ show lbmn
    ,"MeanUB:\t" ++ show ubmn
    ,"StdDev:\t" ++ show dv
    ]

runTestCases :: (IsMonomialOrder n o, KnownNat n)
             => String -> Ideal (OrderedPolynomial Rational o n) -> IO ()
runTestCases lab i = do
  analyse (lab ++ " (Q, Lex, Sing(gr))") "groebner" $ fmap (changeOrder Lex) i
  analyse (lab ++ " (Q, Lex, Sing(sba))") "sba" $ fmap (changeOrder Lex) i
  analyse (lab ++ " (Q, Grevlex, Sing(gr))") "groebner" $ fmap (changeOrder Grevlex) i
  analyse (lab ++ " (Q, Grevlex, Sing(sba))") "sba" $ fmap (changeOrder Grevlex) i
  analyse (lab ++ " (F_65521, Lex, Sing(gr))") "groebner" $ fmap (mapCoeff ratToF . changeOrder Lex) i
  analyse (lab ++ " (F_65521, Lex, Sing(sba))") "sba" $ fmap (mapCoeff ratToF . changeOrder Lex) i
  analyse (lab ++ " (F_65521, Grevlex, Sing(gr))") "groebner" $ fmap (mapCoeff ratToF . changeOrder Grevlex) i
  analyse (lab ++ " (F_65521, Grevlex, Sing(sba))") "sba" $ fmap (mapCoeff ratToF . changeOrder Grevlex) i

main :: IO ()
main = do
  runTestCases "Cyclic-4" $ cyclic (sing :: Sing 4)
  runTestCases "Cyclic-5" $ cyclic (sing :: Sing 5)
  runTestCases "Cyclic-6" $ cyclic (sing :: Sing 6)
  runTestCases "Katsura-5" $ katsura (sing :: Sing 5)
  runTestCases "Katsura-6" $ katsura (sing :: Sing 6)
  runTestCases "Katsura-7" $ katsura (sing :: Sing 7)

ratToF :: Rational -> F 65521
ratToF = modRat'


{-# LANGUAGE Strict, OverloadedStrings #-}
module GradeParser (
    outOf
  , outOfSafe
  , eachOutOf
  , eachOutOfSafe
  , stats
  , histOutput
  , printStats
  , printStatsHist
  ) where

import qualified Data.ByteString as B
import Grade
import qualified Data.Vector as T
import Data.Csv hiding ((.=))
import ShowByteString
import qualified Data.HashMap.Strict as M
import Control.Monad.Reader
import Control.Applicative
import Histogram
import Data.List
import Statistics.Sample
import CSVmonad
import System.Process

outOf :: Field -> Double -> CSVmonad Grade
outOf s o = ReaderT (\v -> ((/. o) <$> v .: s) <|> pure (absent o))

eachOutOf s o = ReaderT (\v -> sequence (map (parseGrade o) $ M.elems $ M.filterWithKey (\k _ -> B.isPrefixOf s k) v))

outOfSafe :: Field -> Double -> CSVmonad Grade
outOfSafe s o = ReaderT (\v -> (chkGrade o <$> v .: s) <|> pure (absent o))

eachOutOfSafe s o = ReaderT (\v -> sequence (map (parseGradeSafe o) $ M.elems $ M.filterWithKey (\k _ -> B.isPrefixOf s k) v))

chkGrade :: Double -> Double -> Grade
chkGrade o n = if n <= o && n >= 0 then n /. o else  outoferror

chkGrade' :: Double -> Double -> Grade
chkGrade' _ _ = outoferror

parseGrade o g = ((/.o) <$> parseField g) <|> pure (absent o)

parseGradeSafe o g = (chkGrade o <$> parseField g) <|> pure (absent o)

getRight (Right x) = x
getRight (Left e) = error $ show e

stats :: (T.Vector Double -> b) -> CSVmonad Grade -> T.Vector NamedRecord -> Either GradeErrors b
stats f l v = fmap f $ sequence $ T.filter isNotAbsent $ fmap (marksEither . getRight . runParser .  runReaderT l ) v
  where isNotAbsent (Left (Absent _)) = False
        isNotAbsent _ = True

histOutput :: Double -> FilePath -> CSVmonad Grade -> T.Vector NamedRecord -> IO ()
histOutput m s l v = case stats (histogram (assignBin m) . T.toList) l v of
                        Right a -> histToChart s a >> writeHist "distribution.txt" a >> callCommand "perl -lane 'print $F[0], \"\t\", \"=\" x ($F[1] / 1)' distribution.txt" >> return ()
                        --Right a -> histToChart s a >> writeHist "distribution.txt" a >> createProcess (shell "perl -lane 'print $F[0], \"\t\", \"=\" x ($F[1] / 1)' distribution.txt") >> return ()
                        Left e -> print e

eitherPrintDouble (Right x) = print $ roundTo 1 x
eitherPrintDouble (Left x) = print x

printStat n s l y = putStrLn n >> eitherPrintDouble (stats s l y) >> putStrLn ""

--printStats l y = do printStat "The Mean" mean l y
--                    printStat "The Standard deviation" stdDev l y
--                    printStat "The Median" median l y
--                    histOutput 10 "histogram.png" l y
--
--printStats l y = do let m = getRight $ stats mean l y
--                    let s = getRight $ stats stdDev l y
--                    let me = getRight $ stats median l y
--                    printStat "The Mean" mean l y
--                    printStat "The Standard deviation" stdDev l y
--                    printStat "The Median" median l y
--                    histOutput 5 "histogram.png" l y
--                    let sugg= ("      O: " ++ show (roundTo 1 $ m + 1.65*s) ++"\n      "++ "A: " ++ show (roundTo 1 $ m + 0.85*s) ++"\n      "++ "B: " ++ show (roundTo 1 $ m) ++"\n      "++ "C: " ++ show (roundTo 1 $ m - s) ++"\n      "++ "D: " ++ show (roundTo 1 $ me / 2))
--                    putStrLn sugg
--                    writeFile "suggested" sugg

printStats = printStatsHist 10
printStatsHist  h l y = do let m = getRight $ stats mean l y
                           let s = getRight $ stats stdDev l y
                           let me = getRight $ stats median l y
                           printStat "The Mean" mean l y
                           printStat "The Standard deviation" stdDev l y
                           printStat "The Median" median l y
                           histOutput h "histogram.png" l y
                           let sugg= ("      O: " ++ show (roundTo 1 $ m + 1.65*s) ++"\n      "++ "A: " ++ show (roundTo 1 $ m + 0.85*s) ++"\n      "++ "B: " ++ show (roundTo 1 $ m) ++"\n      "++ "C: " ++ show (roundTo 1 $ m - s) ++"\n      "++ "D: " ++ show (roundTo 1 $ me / 2))
                           putStrLn "  "
                           putStrLn "Suggested grades:"
                           putStrLn sugg
                           writeFile "suggested" sugg

round' x | f < 0.5 = i
         | otherwise = i + 1
         where i = floor x
               f = x - fromIntegral i

roundTo n f = fromInteger (round' $ f * (10^n)) / (10.0^^n)

median :: T.Vector Double -> Double
median xs = sort (T.toList xs) !! n
  where n = T.length xs `div` 2