{-# LANGUAGE FlexibleContexts #-}

module Primitives where

import Types
import Environment
import Parsing
import Evaluation

import qualified Data.Text as T

import System.IO
import Control.Monad.Except
import Data.Bifunctor

import Data.Complex
import Data.Ratio
import Data.Fixed

primitiveBindings :: IO Env
primitiveBindings = nullEnv >>= flip bindVars (map (second IOFunc) ioPrimitives
                                               ++ map (second PrimitiveFunc) primitives
                                               ++ primitiveVariables )

-------------------------
-- Default variables
-------------------------

primitiveVariables :: [(T.Text, LispVal)]
primitiveVariables = [("stdlib", String "lib/stdlib.scm")]

-------------------------
-- IO Primitive functions
-------------------------

ioPrimitives :: [(T.Text, [LispVal] -> IOThrowsError LispVal)]
ioPrimitives = [("apply", applyProc),
                ("open-input-file", makePort ReadMode),
                ("open-output-file", makePort WriteMode),
                ("close-input-port", closePort),
                ("close-output-port", closePort),
                ("read", readProc),
                ("write", writeProc),
                ("display", writeProc),
                ("newline", newline),
                ("read-contents", readContents),
                ("read-all", readAll)]

applyProc :: [LispVal] -> IOThrowsError LispVal
applyProc [func, List args] = apply func args
applyProc (func : args)     = apply func args
applyProc params            = throwError $ NumArgs 2 params -- TODO This is actually a min

makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal
makePort mode [String filename] = Port <$> liftIO (openFile (T.unpack filename) mode)
makePort _    [a]               = throwError $ TypeMismatch "port" a
makePort _    params            = throwError $ NumArgs 1 params

closePort :: [LispVal] -> IOThrowsError LispVal
closePort [Port port] = liftIO $ hClose port >> return (Bool True)
closePort [a]         = throwError $ TypeMismatch "port" a
closePort params      = throwError $ NumArgs 1 params

readProc :: [LispVal] -> IOThrowsError LispVal
readProc []          = readProc [Port stdin]
readProc [Port port] = liftIO (hGetLine port) >>= liftThrows . readExpr
readProc [a]         = throwError $ TypeMismatch "port" a
readProc params      = throwError $ VariableNumArgs [0, 1] params

writeProc :: [LispVal] -> IOThrowsError LispVal
writeProc [obj]            = writeProc [obj, Port stdout]
writeProc [obj, Port port] = liftIO $ hPrint port obj >> return (Bool True)
writeProc [_, a]           = throwError $ TypeMismatch "port" a
writeProc params           = throwError $ VariableNumArgs [1, 2] params

newline :: [LispVal] -> IOThrowsError LispVal
newline []            = writeProc [Char '\n', Port stdout]
newline [Port port]   = writeProc [Char '\n', Port port]
newline [a]           = throwError $ TypeMismatch "port" a
newline params           = throwError $ VariableNumArgs [0, 1] params

readContents :: [LispVal] -> IOThrowsError LispVal
readContents [String filename] = String . T.pack <$> liftIO (readFile $ T.unpack filename)
readContents [a]               = throwError $ TypeMismatch "string" a
readContents params            = throwError $ NumArgs 1 params

readAll :: [LispVal] -> IOThrowsError LispVal
readAll [String filename] = List <$> load filename
readAll [a]               = throwError $ TypeMismatch "string" a
readAll params            = throwError $ NumArgs 1 params

-------------------------
-- Primitive functions
-------------------------

primitives :: [(T.Text, [LispVal] -> ThrowsError LispVal)]
primitives =
  [ ("+", numAdd)
  , ("-", numSub)
  , ("*", numMul)
  , ("/", numDiv)
  , ("mod", numMod)

  , ("quotient", numericBinop quot)
  , ("remainder", numericBinop rem)

  , ("null?", unaryOp null')
  , ("not", unaryOp not')
  , ("symbol?", unaryOp symbolp)
  , ("string?", unaryOp stringp)
  , ("number?", unaryOp numberp)
  , ("bool?", unaryOp boolp)
  , ("pair?", unaryOp pair')
  , ("list?", unaryOp listp)
  , ("symbol->string", unaryOp symbol2string)
  , ("string->symbol", unaryOp string2symbol)

  , ("=", numBoolBinopEq)
  , (">", numBoolBinopGt)
  , (">=", numBoolBinopGte)
  , ("<", numBoolBinopLt)
  , ("<=", numBoolBinopLte)

  , ("&&", boolBoolBinop (&&))
  , ("||", boolBoolBinop (||))
  , ("string=?", strBoolBinop (==))
  , ("string<?", strBoolBinop (<))
  , ("string>?", strBoolBinop (>))
  , ("string<=?", strBoolBinop (<=))
  , ("string>=?", strBoolBinop (>=))
  , ("string-length", stringLen)
  , ("string-ref", stringRef)
  , ("car", car)
  , ("cdr", cdr)
  , ("cons", cons)
  , ("eq?", eqv)
  , ("eqv?", eqv)
  , ("equal?", eqv)
  ]

-- - Begin GenUtil - http://repetae.net/computer/haskell/GenUtil.hs
foldlM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a
foldlM f v (x : xs) = (f v x) >>= \ a -> foldlM f a xs
foldlM _ v [] = return v

foldl1M :: Monad m => (a -> a -> m a) -> [a] -> m a
foldl1M f (x : xs) = foldlM f x xs
foldl1M _ _ = error "Unexpected error in foldl1M"
-- end GenUtil

-- |Accept two numbers and cast one of them to the appropriate type, if necessary
numCast' :: (LispVal, LispVal) -> ThrowsError (LispVal, LispVal)
numCast' (a@(Number _), b@(Number _)) = return $ (a, b)
numCast' (a@(Float _), b@(Float _)) = return $ (a, b)
numCast' (a@(Ratio _), b@(Ratio _)) = return $ (a, b)
numCast' (a@(Complex _), b@(Complex _)) = return $ (a, b)
numCast' ((Number a), b@(Float _)) = return $ (Float $ fromInteger a, b)
numCast' ((Number a), b@(Ratio _)) = return $ (Ratio $ fromInteger a, b)
numCast' ((Number a), b@(Complex _)) = return $ (Complex $ fromInteger a, b)
numCast' (a@(Float _), (Number b)) = return $ (a, Float $ fromInteger b)
numCast' (a@(Float _), (Ratio b)) = return $ (a, Float $ fromRational b)
numCast' ((Float a), b@(Complex _)) = return $ (Complex $ a :+ 0, b)
numCast' (a@(Ratio _), (Number b)) = return $ (a, Ratio $ fromInteger b)
numCast' ((Ratio a), b@(Float _)) = return $ (Float $ fromRational a, b)
numCast' ((Ratio a), b@(Complex _)) = return $ (Complex $ (fromInteger $ numerator a) / (fromInteger $ denominator a), b)
numCast' (a@(Complex _), (Number b)) = return $ (a, Complex $ fromInteger b)
numCast' (a@(Complex _), (Float b)) = return $ (a, Complex $ b :+ 0)
numCast' (a@(Complex _), (Ratio b)) = return $ (a, Complex $ (fromInteger $ numerator b) / (fromInteger $ denominator b))
numCast' (a, b) = case a of
               Number _ -> doThrowError b
               Float _ -> doThrowError b
               Ratio _ -> doThrowError b
               Complex _ -> doThrowError b
               _ -> doThrowError a
  where doThrowError num = throwError $ TypeMismatch "number" num

-- |Accept two numbers and cast one of them to the appropriate type, if necessary
numCast :: [LispVal] -> ThrowsError LispVal
numCast [a, b] = do
  (a', b') <- numCast' (a, b)
  pure $ List [a', b']
numCast _ = throwError $ Default "Unexpected error in numCast"

-- |Add the given numbers
numAdd :: [LispVal] -> ThrowsError LispVal
numAdd [] = return $ Number 0
numAdd aparams = do
  foldl1M (\ a b -> doAdd =<< (numCast [a, b])) aparams
  where doAdd (List [(Number a), (Number b)]) = return $ Number $ a + b
        doAdd (List [(Float a), (Float b)]) = return $ Float $ a + b
        doAdd (List [(Ratio a), (Ratio b)]) = return $ Ratio $ a + b
        doAdd (List [(Complex a), (Complex b)]) = return $ Complex $ a + b
        doAdd _ = throwError $ Default "Unexpected error in +"

-- |Subtract the given numbers
numSub :: [LispVal] -> ThrowsError LispVal
numSub [] = throwError $ NumArgs 1 []
numSub [Number n] = return $ Number $ -1 * n
numSub [Float n] = return $ Float $ -1 * n
numSub [Ratio n] = return $ Ratio $ -1 * n
numSub [Complex n] = return $ Complex $ -1 * n
numSub aparams = do
  foldl1M (\ a b -> doSub =<< (numCast [a, b])) aparams
  where doSub (List [(Number a), (Number b)]) = return $ Number $ a - b
        doSub (List [(Float a), (Float b)]) = return $ Float $ a - b
        doSub (List [(Ratio a), (Ratio b)]) = return $ Ratio $ a - b
        doSub (List [(Complex a), (Complex b)]) = return $ Complex $ a - b
        doSub _ = throwError $ Default "Unexpected error in -"

-- |Multiply the given numbers
numMul :: [LispVal] -> ThrowsError LispVal
numMul [] = return $ Number 1
numMul aparams = do
  foldl1M (\ a b -> doMul =<< (numCast [a, b])) aparams
  where doMul (List [(Number a), (Number b)]) = return $ Number $ a * b
        doMul (List [(Float a), (Float b)]) = return $ Float $ a * b
        doMul (List [(Ratio a), (Ratio b)]) = return $ Ratio $ a * b
        doMul (List [(Complex a), (Complex b)]) = return $ Complex $ a * b
        doMul _ = throwError $ Default "Unexpected error in *"

-- |Divide the given numbers
numDiv :: [LispVal] -> ThrowsError LispVal
numDiv [] = throwError $ NumArgs 1 []
numDiv [Number 0] = throwError $ DivideByZero
numDiv [Ratio 0] = throwError $ DivideByZero
numDiv [Number n] = return $ Ratio $ 1 / (fromInteger n)
numDiv [Float n] = return $ Float $ 1.0 / n
numDiv [Ratio n] = return $ Ratio $ 1 / n
numDiv [Complex n] = return $ Complex $ 1 / n
numDiv aparams = do
  foldl1M (\ a b -> doDiv =<< (numCast [a, b])) aparams
  where doDiv (List [(Number a), (Number b)])
            | b == 0 = throwError $ DivideByZero
            | (mod a b) == 0 = return $ Number $ div a b
            | otherwise = -- Not an integer
                return $ Ratio $ (fromInteger a) / (fromInteger b)
        doDiv (List [(Float a), (Float b)])
            | b == 0.0 = throwError $ DivideByZero
            | otherwise = return $ Float $ a / b
        doDiv (List [(Ratio a), (Ratio b)])
            | b == 0 = throwError $ DivideByZero
            | otherwise = return $ Ratio $ a / b
        doDiv (List [(Complex a), (Complex b)])
            | b == 0 = throwError $ DivideByZero
            | otherwise = return $ Complex $ a / b
        doDiv _ = throwError $ Default "Unexpected error in /"

-- |Take the modulus of the given numbers
numMod :: [LispVal] -> ThrowsError LispVal
numMod [] = return $ Number 1
numMod aparams = do
  foldl1M (\ a b -> doMod =<< (numCast [a, b])) aparams
  where doMod (List [(Number a), (Number b)]) = return $ Number $ mod' a b
        doMod (List [(Float a), (Float b)]) = return $ Float $ mod' a b
        doMod (List [(Ratio a), (Ratio b)]) = return $ Ratio $ mod' a b
        doMod (List [(Complex _), (Complex _)]) = throwError $ Default "modulo not implemented for complex numbers"
        doMod _ = throwError $ Default "Unexpected error in modulo"

numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
numericBinop _           []  = throwError $ NumArgs 2 []
numericBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal
numericBinop op params        = Number . foldl1 op <$> mapM unpackNum params

unaryOp :: (LispVal -> LispVal) -> [LispVal] -> ThrowsError LispVal
unaryOp f [v] = return $ f v
unaryOp _ params = throwError $ NumArgs 1 params

not', null', pair', symbolp, numberp, stringp, boolp, listp, symbol2string, string2symbol :: LispVal -> LispVal

not' (Bool x) = (Bool . not) x
not' _ = Bool False

null' (List []) = Bool True
null' _ = Bool False

pair' (DottedList _ _) = Bool True
pair' _ = Bool False

symbolp (Atom _)   = Bool True
symbolp _          = Bool False

numberp (Number _) = Bool True
numberp _          = Bool False

stringp (String _) = Bool True
stringp _          = Bool False

boolp   (Bool _)   = Bool True
boolp   _          = Bool False

listp   (List _)   = Bool True
listp   (DottedList _ _) = Bool True
listp   _          = Bool False

symbol2string (Atom s)   = String s
symbol2string _          = String ""

string2symbol (String s) = Atom s
string2symbol _          = Atom ""

stringLen :: [LispVal] -> ThrowsError LispVal
stringLen [(String s)] = Right $ Number $ fromIntegral $ T.length s
stringLen [notString]  = throwError $ TypeMismatch "string" notString
stringLen badArgList   = throwError $ NumArgs 1 badArgList

stringRef :: [LispVal] -> ThrowsError LispVal
stringRef [(String s), (Number k)]
    | T.length s < k' + 1 = throwError $ Default "Out of bound error"
    | otherwise         = Right $ Char $ T.index s $ fromIntegral k
    where k' = fromIntegral k
stringRef [(String _), notNum] = throwError $ TypeMismatch "number" notNum
stringRef [notString, _]       = throwError $ TypeMismatch "string" notString
stringRef badArgList           = throwError $ NumArgs 2 badArgList

boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBinop unpacker op args =
  if length args /= 2
    then throwError $ NumArgs 2 args
    else do
      left <- unpacker $ head args
      right <- unpacker $ args !! 1
      return $ Bool $ left `op` right

numBoolBinop :: (Integer -> Integer -> Bool) -> [LispVal] -> ThrowsError LispVal
numBoolBinop  = boolBinop unpackNum
strBoolBinop :: (T.Text -> T.Text -> Bool) -> [LispVal] -> ThrowsError LispVal
strBoolBinop  = boolBinop unpackStr
boolBoolBinop :: (Bool -> Bool -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBoolBinop = boolBinop unpackBool

-- |Compare a series of numbers using a given numeric comparison
--  function and an array of lisp values
numBoolBinopCompare :: (LispVal
                    -> LispVal -> Either LispError LispVal)
                    -> LispVal -> [LispVal] -> Either LispError LispVal
numBoolBinopCompare cmp n1 (n2 : ns) = do
  (n1', n2') <- numCast' (n1, n2)
  result <- cmp n1' n2'
  case result of
    Bool True -> numBoolBinopCompare cmp n2' ns
    _ -> return $ Bool False
numBoolBinopCompare _ _ _ = return $ Bool True

-- |Numeric equals
numBoolBinopEq :: [LispVal] -> ThrowsError LispVal
numBoolBinopEq [] = throwError $ NumArgs 0 []
numBoolBinopEq (n : ns) = numBoolBinopCompare cmp n ns
  where
    f a b = a == b
    cmp (Number a) (Number b) = return $ Bool $ f a b
    cmp (Float a) (Float b) = return $ Bool $ f a b
    cmp (Ratio a) (Ratio b) = return $ Bool $ f a b
    cmp (Complex a) (Complex b) = return $ Bool $ f a b
    cmp _ _ = throwError $ Default "Unexpected error in ="

-- |Numeric greater than
numBoolBinopGt :: [LispVal] -> ThrowsError LispVal
numBoolBinopGt [] = throwError $ NumArgs 0 []
numBoolBinopGt (n : ns) = numBoolBinopCompare cmp n ns
  where
    f a b = a > b
    cmp (Number a) (Number b) = return $ Bool $ f a b
    cmp (Float a) (Float b) = return $ Bool $ f a b
    cmp (Ratio a) (Ratio b) = return $ Bool $ f a b
    cmp _ _ = throwError $ Default "Unexpected error in >"

-- |Numeric greater than equal
numBoolBinopGte :: [LispVal] -> ThrowsError LispVal
numBoolBinopGte [] = throwError $ NumArgs 0 []
numBoolBinopGte (n : ns) = numBoolBinopCompare cmp n ns
  where
    f a b = a >= b
    cmp (Number a) (Number b) = return $ Bool $ f a b
    cmp (Float a) (Float b) = return $ Bool $ f a b
    cmp (Ratio a) (Ratio b) = return $ Bool $ f a b
    cmp _ _ = throwError $ Default "Unexpected error in >="

-- |Numeric less than
numBoolBinopLt :: [LispVal] -> ThrowsError LispVal
numBoolBinopLt [] = throwError $ NumArgs 0 []
numBoolBinopLt (n : ns) = numBoolBinopCompare cmp n ns
  where
    f a b = a < b
    cmp (Number a) (Number b) = return $ Bool $ f a b
    cmp (Float a) (Float b) = return $ Bool $ f a b
    cmp (Ratio a) (Ratio b) = return $ Bool $ f a b
    cmp _ _ = throwError $ Default "Unexpected error in <"

-- |Numeric less than equal
numBoolBinopLte :: [LispVal] -> ThrowsError LispVal
numBoolBinopLte [] = throwError $ NumArgs 0 []
numBoolBinopLte (n : ns) = numBoolBinopCompare cmp n ns
  where
    f a b = a <= b
    cmp (Number a) (Number b) = return $ Bool $ f a b
    cmp (Float a) (Float b) = return $ Bool $ f a b
    cmp (Ratio a) (Ratio b) = return $ Bool $ f a b
    cmp _ _ = throwError $ Default "Unexpected error in <="

car :: [LispVal] -> ThrowsError LispVal
car [List (x : _)]         = return x
car [DottedList (x : _) _] = return x
car [badArg]                = throwError $ TypeMismatch "pair" badArg
car badArgList              = throwError $ NumArgs 1 badArgList

cdr :: [LispVal] -> ThrowsError LispVal
cdr [List (_ : xs)]         = return $ List xs
cdr [DottedList [_] x]      = return x
cdr [DottedList (_ : xs) x] = return $ DottedList xs x
cdr [badArg]                = throwError $ TypeMismatch "pair" badArg
cdr badArgList              = throwError $ NumArgs 1 badArgList

cons :: [LispVal] -> ThrowsError LispVal
cons [x1, List []] = return $ List [x1]
cons [x, List xs] = return $ List $ x : xs
cons [x, DottedList xs xlast] = return $ DottedList (x : xs) xlast
cons [x1, x2] = return $ DottedList [x1] x2
cons badArgList = throwError $ NumArgs 2 badArgList


-- This file is auto-generated.  Do not edit directly.
-- |
--   Stability: Experimental
--
--   Generic interface to Blas using safe foreign calls.  Refer to the GHC documentation
--   for more information regarding appropriate use of safe and unsafe foreign calls.
--
--   The functions here are named in a similar fashion to the original Blas interface, with
--   the type-dependent letter(s) removed.  Some functions have been merged with
--   others to allow the interface to work on both real and complex numbers.  If you can't a
--   particular function, try looking for its corresponding complex equivalent (e.g.
--   @symv@ is a special case of 'hemv' applied to real numbers).
--
--   Note: although complex versions of @rot@ and @rotg@ exist in many implementations,
--   they are not part of the official Blas standard and therefore not included here.  If
--   you /really/ need them, submit a ticket so we can try to come up with a solution.
--
--   The documentation here is still incomplete.  Consult the
--   <http://netlib.org/blas/#_blas_routines official documentation> for more
--   information.
--
--   Notation:
--
--     * @⋅@ denotes dot product (without any conjugation).
--     * @*@ denotes complex conjugation.
--     * @⊤@ denotes transpose.
--     * @†@ denotes conjugate transpose (Hermitian conjugate).
--
--   Conventions:
--
--     * All scalars are denoted with lowercase Greek letters
--     * All vectors are denoted with lowercase Latin letters and are
--       assumed to be column vectors (unless transposed).
--     * All matrices are denoted with uppercase Latin letters.
{-# LANGUAGE FlexibleInstances, TypeFamilies #-}
module Blas.Generic.Safe (
    Numeric(..)
  , RealNumeric(..)
  , D.dsdot
  , S.sdsdot
  ) where
import Prelude (Floating, Double, Float, Int, IO)
import Data.Complex (Complex)
import Foreign (Ptr, Storable)
import Blas.Primitive.Types (Order, Transpose, Uplo, Diag, Side)
import qualified Blas.Specialized.Float.Safe as S
import qualified Blas.Specialized.Double.Safe as D
import qualified Blas.Specialized.ComplexFloat.Safe as C
import qualified Blas.Specialized.ComplexDouble.Safe as Z

-- | Blas operations that are applicable to real and complex numbers.
--
--   Instances are defined for the 4 types supported by Blas: the single- and
--   double-precision floating point types and their complex versions.
class (Floating a, Storable a) => Numeric a where

  -- | The corresponding real type of @a@.
  --
  --   In other words, @'RealType' ('Complex' a)@ is an alias for @a@.  For everything
  --   else, @'RealType' a@ is simply @a@.
  type RealType a :: *
  -- | Swap two vectors:
  --
  --   > (x, y) ← (y, x)
  swap :: Int
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> IO ()

  -- | Multiply a vector by a scalar.
  --
  --   > x ← α x
  scal :: Int
       -> a
       -> Ptr a
       -> Int
       -> IO ()

  -- | Copy a vector into another vector:
  --
  --   > y ← x
  copy :: Int
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> IO ()

  -- | Add a scalar-vector product to a vector.
  --
  --   > y ← α x + y
  axpy :: Int
       -> a
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> IO ()

  -- | Calculate the bilinear dot product of two vectors:
  --
  --   > x ⋅ y ≡ ∑[i] x[i] y[i]
  dotu :: Int
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> IO a

  -- | Calculate the sesquilinear dot product of two vectors.
  --
  --   > x* ⋅ y ≡ ∑[i] x[i]* y[i]
  dotc :: Int
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> IO a

  -- | Calculate the Euclidean (L²) norm of a vector:
  --
  --   > ‖x‖₂ ≡ √(∑[i] x[i]²)
  nrm2 :: Int
       -> Ptr a
       -> Int
       -> IO (RealType a)

  -- | Calculate the Manhattan (L¹) norm, equal to the sum of the magnitudes of the elements:
  --
  --   > ‖x‖₁ = ∑[i] |x[i]|
  asum :: Int
       -> Ptr a
       -> Int
       -> IO (RealType a)

  -- | Calculate the index of the element with the maximum magnitude (absolute value).
  iamax :: Int
        -> Ptr a
        -> Int
        -> IO Int

  -- | Perform a general matrix-vector update.
  --
  --   > y ← α T(A) x + β y
  gemv :: Order
       -> Transpose
       -> Int
       -> Int
       -> a
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> a
       -> Ptr a
       -> Int
       -> IO ()

  -- | Perform a general banded matrix-vector update.
  --
  --   > y ← α T(A) x + β y
  gbmv :: Order
       -> Transpose
       -> Int
       -> Int
       -> Int
       -> Int
       -> a
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> a
       -> Ptr a
       -> Int
       -> IO ()

  -- | Perform a hermitian matrix-vector update.
  --
  --   > y ← α A x + β y
  hemv :: Order
       -> Uplo
       -> Int
       -> a
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> a
       -> Ptr a
       -> Int
       -> IO ()

  -- | Perform a hermitian banded matrix-vector update.
  --
  --   > y ← α A x + β y
  hbmv :: Order
       -> Uplo
       -> Int
       -> Int
       -> a
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> a
       -> Ptr a
       -> Int
       -> IO ()

  -- | Perform a hermitian packed matrix-vector update.
  --
  --   > y ← α A x + β y
  hpmv :: Order
       -> Uplo
       -> Int
       -> a
       -> Ptr a
       -> Ptr a
       -> Int
       -> a
       -> Ptr a
       -> Int
       -> IO ()

  -- | Multiply a triangular matrix by a vector.
  --
  --   > x ← T(A) x
  trmv :: Order
       -> Uplo
       -> Transpose
       -> Diag
       -> Int
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> IO ()

  -- | Multiply a triangular banded matrix by a vector.
  --
  --   > x ← T(A) x
  tbmv :: Order
       -> Uplo
       -> Transpose
       -> Diag
       -> Int
       -> Int
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> IO ()

  -- | Multiply a triangular packed matrix by a vector.
  --
  --   > x ← T(A) x
  tpmv :: Order
       -> Uplo
       -> Transpose
       -> Diag
       -> Int
       -> Ptr a
       -> Ptr a
       -> Int
       -> IO ()

  -- | Multiply an inverse triangular matrix by a vector.
  --
  --   > x ← T(A⁻¹) x
  trsv :: Order
       -> Uplo
       -> Transpose
       -> Diag
       -> Int
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> IO ()

  -- | Multiply an inverse triangular banded matrix by a vector.
  --
  --   > x ← T(A⁻¹) x
  tbsv :: Order
       -> Uplo
       -> Transpose
       -> Diag
       -> Int
       -> Int
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> IO ()

  -- | Multiply an inverse triangular packed matrix by a vector.
  --
  --   > x ← T(A⁻¹) x
  tpsv :: Order
       -> Uplo
       -> Transpose
       -> Diag
       -> Int
       -> Ptr a
       -> Ptr a
       -> Int
       -> IO ()

  -- | Perform an unconjugated rank-1 update of a general matrix.
  --
  --   > A ← α x y⊤ + A
  geru :: Order
       -> Int
       -> Int
       -> a
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> IO ()

  -- | Perform a conjugated rank-1 update of a general matrix.
  --
  --   > A ← α x y† + A
  gerc :: Order
       -> Int
       -> Int
       -> a
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> IO ()

  -- | Perform a rank-1 update of a Hermitian matrix.
  --
  --   > A ← α x y† + A
  her :: Order
      -> Uplo
      -> Int
      -> RealType a
      -> Ptr a
      -> Int
      -> Ptr a
      -> Int
      -> IO ()

  -- | Perform a rank-1 update of a Hermitian packed matrix.
  --
  --   > A ← α x y† + A
  hpr :: Order
      -> Uplo
      -> Int
      -> RealType a
      -> Ptr a
      -> Int
      -> Ptr a
      -> IO ()

  -- | Perform a rank-2 update of a Hermitian matrix.
  --
  --   > A ← α x y† + y (α x)† + A
  her2 :: Order
       -> Uplo
       -> Int
       -> a
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> IO ()

  -- | Perform a rank-2 update of a Hermitian packed matrix.
  --
  --   > A ← α x y† + y (α x)† + A
  hpr2 :: Order
       -> Uplo
       -> Int
       -> a
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> Ptr a
       -> IO ()

  -- | Perform a general matrix-matrix update.
  --
  --   > C ← α T(A) U(B) + β C
  gemm :: Order -- ^ Layout of all the matrices.
       -> Transpose -- ^ The operation @T@ to be applied to @A@.
       -> Transpose -- ^ The operation @U@ to be applied to @B@.
       -> Int -- ^ Number of rows of @T(A)@ and @C@.
       -> Int -- ^ Number of columns of @U(B)@ and @C@.
       -> Int -- ^ Number of columns of @T(A)@ and number of rows of @U(B)@.
       -> a -- ^ Scaling factor @α@ of the product.
       -> Ptr a -- ^ Pointer to a matrix @A@.
       -> Int -- ^ Stride of the major dimension of @A@.
       -> Ptr a -- ^ Pointer to a matrix @B@.
       -> Int -- ^ Stride of the major dimension of @B@.
       -> a -- ^ Scaling factor @β@ of the original @C@.
       -> Ptr a -- ^ Pointer to a mutable matrix @C@.
       -> Int -- ^ Stride of the major dimension of @C@.
       -> IO ()

  -- | Perform a symmetric matrix-matrix update.
  --
  --   > C ← α A B + β C    or    C ← α B A + β C
  --
  --   where @A@ is symmetric.  The matrix @A@ must be in an unpacked format, although the
  --   routine will only access half of it as specified by the @'Uplo'@ argument.
  symm :: Order -- ^ Layout of all the matrices.
       -> Side -- ^ Side that @A@ appears in the product.
       -> Uplo -- ^ The part of @A@ that is used.
       -> Int -- ^ Number of rows of @C@.
       -> Int -- ^ Number of columns of @C@.
       -> a -- ^ Scaling factor @α@ of the product.
       -> Ptr a -- ^ Pointer to a symmetric matrix @A@.
       -> Int -- ^ Stride of the major dimension of @A@.
       -> Ptr a -- ^ Pointer to a matrix @B@.
       -> Int -- ^ Stride of the major dimension of @B@.
       -> a -- ^ Scaling factor @α@ of the original @C@.
       -> Ptr a -- ^ Pointer to a mutable matrix @C@.
       -> Int -- ^ Stride of the major dimension of @C@.
       -> IO ()

  -- | Perform a Hermitian matrix-matrix update.
  --
  --   > C ← α A B + β C    or    C ← α B A + β C
  --
  --   where @A@ is Hermitian.  The matrix @A@ must be in an unpacked format, although the
  --   routine will only access half of it as specified by the @'Uplo'@ argument.
  hemm :: Order -- ^ Layout of all the matrices.
       -> Side -- ^ Side that @A@ appears in the product.
       -> Uplo -- ^ The part of @A@ that is used.
       -> Int -- ^ Number of rows of @C@.
       -> Int -- ^ Number of columns of @C@.
       -> a -- ^ Scaling factor @α@ of the product.
       -> Ptr a -- ^ Pointer to a Hermitian matrix @A@.
       -> Int -- ^ Stride of the major dimension of @A@.
       -> Ptr a -- ^ Pointer to a matrix @B@.
       -> Int -- ^ Stride of the major dimension of @B@.
       -> a -- ^ Scaling factor @α@ of the original @C@.
       -> Ptr a -- ^ Pointer to a mutable matrix @C@.
       -> Int -- ^ Stride of the major dimension of @C@.
       -> IO ()

  -- | Perform a symmetric rank-k update.
  --
  --   > C ← α A A⊤ + β C    or    C ← α A⊤ A + β C
  syrk :: Order
       -> Uplo
       -> Transpose
       -> Int
       -> Int
       -> a
       -> Ptr a
       -> Int
       -> a
       -> Ptr a
       -> Int
       -> IO ()

  -- | Perform a Hermitian rank-k update.
  --
  --   > C ← α A A† + β C    or    C ← α A† A + β C
  herk :: Order
       -> Uplo
       -> Transpose
       -> Int
       -> Int
       -> RealType a
       -> Ptr a
       -> Int
       -> RealType a
       -> Ptr a
       -> Int
       -> IO ()

  -- | Perform a symmetric rank-2k update.
  --
  --   > C ← α A B⊤ + α* B A⊤ + β C    or    C ← α A⊤ B + α* B⊤ A + β C
  syr2k :: Order
        -> Uplo
        -> Transpose
        -> Int
        -> Int
        -> a
        -> Ptr a
        -> Int
        -> Ptr a
        -> Int
        -> a
        -> Ptr a
        -> Int
        -> IO ()

  -- | Perform a Hermitian rank-2k update.
  --
  --   > C ← α A B† + α* B A† + β C    or    C ← α A† B + α* B† A + β C
  her2k :: Order
        -> Uplo
        -> Transpose
        -> Int
        -> Int
        -> a
        -> Ptr a
        -> Int
        -> Ptr a
        -> Int
        -> RealType a
        -> Ptr a
        -> Int
        -> IO ()

  -- | Perform a triangular matrix-matrix multiplication.
  --
  --   > B ← α T(A) B    or    B ← α B T(A)
  --
  --   where @A@ is triangular.
  trmm :: Order
       -> Side
       -> Uplo
       -> Transpose
       -> Diag
       -> Int
       -> Int
       -> a
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> IO ()

  -- | Perform an inverse triangular matrix-matrix multiplication.
  --
  --   > B ← α T(A⁻¹) B    or    B ← α B T(A⁻¹)
  --
  --   where @A@ is triangular.
  trsm :: Order
       -> Side
       -> Uplo
       -> Transpose
       -> Diag
       -> Int
       -> Int
       -> a
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> IO ()

-- | Blas operations that are only applicable to real numbers.
class Numeric a => RealNumeric a where

  -- | Generate a Givens rotation. (Only available for real floating-point types.)
  rotg :: Ptr a
       -> Ptr a
       -> Ptr a
       -> Ptr a
       -> IO ()

  -- | Generate a modified Givens rotation. (Only available for real floating-point
  --   types.)
  rotmg :: Ptr a
        -> Ptr a
        -> Ptr a
        -> a
        -> Ptr a
        -> IO ()

  -- | Apply a Givens rotation. (Only available for real floating-point types.)
  rot :: Int
      -> Ptr a
      -> Int
      -> Ptr a
      -> Int
      -> a
      -> a
      -> IO ()

  -- | Apply a modified Givens rotation. (Only available for real floating-point types.)
  rotm :: Int
       -> Ptr a
       -> Int
       -> Ptr a
       -> Int
       -> Ptr a
       -> IO ()

instance Numeric Float where
  type RealType Float = Float
  swap = S.swap
  scal = S.scal
  copy = S.copy
  axpy = S.axpy
  dotu = S.dotu
  dotc = S.dotc
  nrm2 = S.nrm2
  asum = S.asum
  iamax = S.iamax
  gemv = S.gemv
  gbmv = S.gbmv
  hemv = S.hemv
  hbmv = S.hbmv
  hpmv = S.hpmv
  trmv = S.trmv
  tbmv = S.tbmv
  tpmv = S.tpmv
  trsv = S.trsv
  tbsv = S.tbsv
  tpsv = S.tpsv
  geru = S.geru
  gerc = S.gerc
  her = S.her
  hpr = S.hpr
  her2 = S.her2
  hpr2 = S.hpr2
  gemm = S.gemm
  symm = S.symm
  hemm = S.hemm
  syrk = S.syrk
  herk = S.herk
  syr2k = S.syr2k
  her2k = S.her2k
  trmm = S.trmm
  trsm = S.trsm

instance Numeric Double where
  type RealType Double = Double
  swap = D.swap
  scal = D.scal
  copy = D.copy
  axpy = D.axpy
  dotu = D.dotu
  dotc = D.dotc
  nrm2 = D.nrm2
  asum = D.asum
  iamax = D.iamax
  gemv = D.gemv
  gbmv = D.gbmv
  hemv = D.hemv
  hbmv = D.hbmv
  hpmv = D.hpmv
  trmv = D.trmv
  tbmv = D.tbmv
  tpmv = D.tpmv
  trsv = D.trsv
  tbsv = D.tbsv
  tpsv = D.tpsv
  geru = D.geru
  gerc = D.gerc
  her = D.her
  hpr = D.hpr
  her2 = D.her2
  hpr2 = D.hpr2
  gemm = D.gemm
  symm = D.symm
  hemm = D.hemm
  syrk = D.syrk
  herk = D.herk
  syr2k = D.syr2k
  her2k = D.her2k
  trmm = D.trmm
  trsm = D.trsm

instance Numeric (Complex Float) where
  type RealType (Complex Float) = Float
  swap = C.swap
  scal = C.scal
  copy = C.copy
  axpy = C.axpy
  dotu = C.dotu
  dotc = C.dotc
  nrm2 = C.nrm2
  asum = C.asum
  iamax = C.iamax
  gemv = C.gemv
  gbmv = C.gbmv
  hemv = C.hemv
  hbmv = C.hbmv
  hpmv = C.hpmv
  trmv = C.trmv
  tbmv = C.tbmv
  tpmv = C.tpmv
  trsv = C.trsv
  tbsv = C.tbsv
  tpsv = C.tpsv
  geru = C.geru
  gerc = C.gerc
  her = C.her
  hpr = C.hpr
  her2 = C.her2
  hpr2 = C.hpr2
  gemm = C.gemm
  symm = C.symm
  hemm = C.hemm
  syrk = C.syrk
  herk = C.herk
  syr2k = C.syr2k
  her2k = C.her2k
  trmm = C.trmm
  trsm = C.trsm

instance Numeric (Complex Double) where
  type RealType (Complex Double) = Double
  swap = Z.swap
  scal = Z.scal
  copy = Z.copy
  axpy = Z.axpy
  dotu = Z.dotu
  dotc = Z.dotc
  nrm2 = Z.nrm2
  asum = Z.asum
  iamax = Z.iamax
  gemv = Z.gemv
  gbmv = Z.gbmv
  hemv = Z.hemv
  hbmv = Z.hbmv
  hpmv = Z.hpmv
  trmv = Z.trmv
  tbmv = Z.tbmv
  tpmv = Z.tpmv
  trsv = Z.trsv
  tbsv = Z.tbsv
  tpsv = Z.tpsv
  geru = Z.geru
  gerc = Z.gerc
  her = Z.her
  hpr = Z.hpr
  her2 = Z.her2
  hpr2 = Z.hpr2
  gemm = Z.gemm
  symm = Z.symm
  hemm = Z.hemm
  syrk = Z.syrk
  herk = Z.herk
  syr2k = Z.syr2k
  her2k = Z.her2k
  trmm = Z.trmm
  trsm = Z.trsm
instance RealNumeric Float where
  rotg = S.rotg
  rotmg = S.rotmg
  rot = S.rot
  rotm = S.rotm

instance RealNumeric Double where
  rotg = D.rotg
  rotmg = D.rotmg
  rot = D.rot
  rotm = D.rotm


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE FlexibleContexts #-}

module CPVO.IO.Reader.Ecalj.DOS (
  readPDOS
  )
  where

import CPVO.Numeric
import CPVO.IO
--
import Text.Printf as TP
import Numeric.LinearAlgebra
import qualified System.Process as SP
import System.IO (openTempFile,hClose)
-- ===============================================

getPDOS' :: Matrix Double -> String -> [Int] -> [String] -> IO (Matrix Double)
getPDOS' res _ _ []  = return res
getPDOS' res tmpf intAOs (nf:nfiles)  = do
  _ <- SP.system $ "mkdir -p temp; more +2 " ++ nf ++ " > " ++ tmpf
  aPDOS' <- fmap (\x -> sumRow $ (¿) x intAOs) $ loadMatrix tmpf
  getPDOS' (fromBlocks [[res,asColumn aPDOS']]) tmpf intAOs nfiles

-------------------------------------------------------------
-- Input Processing: read PDOS data
--
readPDOS :: Double -> String -> String -> [(Int, ([Char], (String, [Int])))]
         -> IO [(Matrix Double, (Int, (String, (Int, String))))]
readPDOS invStat tailer dir ctrlAtAOs = do
  putStrLn "========readPDOS"
  putStrLn $ show ctrlAtAOs
  sequence
    $ (\x ->  [f a | f <- (readPDOS' invStat dir tailer), a <- x]) ctrlAtAOs

readPDOS' :: Double -> String -> String -> [(Int, (String, (String, [Int])))
         -> IO (Matrix Double, (Int, (String, (Int, String))))]
readPDOS' invStat foldernya tailer = fmap (readOnePDOS foldernya tailer) $ flipBy invStat [1,2] -- spin 1 up n spin 2 down

--readPDOS :: String -> String -> Int -> ((String, String, [Int]), [(Int, String)]) -> IO (Int,String, Matrix Double)
--readPDOS ::(spin, (noAt, (symAt, (labelAt, PDOS :: Matrix Double))))
readOnePDOS :: String
            -> String -> Int -> (Int, (String, (String, [Int])))
            -> IO (Matrix Double, (Int, (String, (Int, String))))
readOnePDOS theFolder tailing spin (noAt,(symAt,(labelAt,intAOs))) = do
  let namaFao = theFolder ++ "/dos.isp" ++ show spin ++ ".site" ++ (TP.printf "%03d" noAt) ++ "." ++ tailing
  (tmpfile,h) <- openTempFile "temp" "aEDOS.suffix"
  hClose h
  _ <- SP.system $ "mkdir -p temp; sed '{1d}' " ++ namaFao ++ " > " ++ tmpfile
  aoE <- fmap (\x -> (¿) x [0]) $ loadMatrix $ tmpfile -- 0th column, Energy column
  let zeroE = asColumn $ konst 0 (rows aoE)                                      -- zero valued column instead of real column
  aPDOS <- fmap (dropColumns 1) $ getPDOS' zeroE tmpfile intAOs [namaFao]                                -- create sum of per atomic AOs (PDOS/atom)
  return $ (fromBlocks [[aoE, aPDOS]] , (spin, (hashSpaceText labelAt, (noAt, symAt))))
------------------------------------------------------------------

-- getPDOS :: String -> String -> Int -> ((String, String, [Int]), [(Int, String)]) -> IO (Int,String, Matrix Double)
-- getPDOS theFolder tailing spin (a@(namaAtom,jdAtom,intAOs),lsAtoms) = do
--   let namaFaos = map (\(x,_) -> theFolder ++ "/dos.isp" ++ show spin ++ ".site" ++ (TP.printf "%03d" x) ++ "." ++ tailing) lsAtoms
--   (tmpfile,h) <- openTempFile "temp" "aEDOS.suffix"
--   hClose h
--   _ <- inshell2text $ "mkdir -p temp; more +2 " ++ (head namaFaos) ++ " > " ++ tmpfile -- this is needed only to generate aoE, the real processing is in getPDOS'
--   aoE <- fmap (\x -> (¿) x [0]) $ loadMatrix tmpfile                             -- 0th column, Energy column
--   let zeroE = asColumn $ konst 0 (rows aoE)                                      -- zero valued column instead of real column
--   aPDOS <- fmap (dropColumns 1) $ getPDOS' zeroE tmpfile intAOs namaFaos                                -- create sum of per atomic AOs (PDOS/atom)
--   return $ (spin, hashSpaceText jdAtom, fromBlocks [[aoE, aPDOS]])
-- ------------------------------------------------------------------
--


module Duck.Analysis where

import Duck.Types
import Duck.Plot
import Duck.Utils
import Duck.Statistics
import Duck.Hypothesis

import qualified Statistics.Resampling.Bootstrap as B

import Criterion
import Criterion.Main.Options (defaultConfig)
import Criterion.Internal (runAndAnalyseOne)
import Criterion.Monad (withConfig)
import Control.DeepSeq (NFData)
import qualified Criterion.Types as CT

-- |The worker function. Takes a set of parameters and
-- a function to evaluate and produces a full report of
-- results. It is required that the function to be evaluated
-- is of type (a -> b), where 'a' is sizable and willing to
-- have test cases generated, and 'b' needs to have a normal
-- form.
runSingleTest :: (Cased a, Sized a, NFData b) => Parameters -> (a -> b) -> IO FullReport
runSingleTest pr src = do
  putStrIf ((verbosity pr) >= Moderate) "Starting benchmarks..."
  testInstances <- genInstances $ genSizeList (range pr) (iterations pr)
  let sizes = [fromIntegral $ dimSize vl | vl <- testInstances]
  (expTimes, expStds, otlr) <- runSource pr (src) testInstances sizes
  putStrIf ((verbosity pr) >= Moderate) "Crunching results..."
  return (FullReport {experiment = expTimes,
                      expStd = expStds,
                      sizes = sizes,
                      outlierEffect = otlr / (fromIntegral $ length sizes)
                     })

-- |Takes an hypothesis complexity function and a full
-- report and fits the experimental data to the analytical
-- data to obtain a confidence value and a proportionality
-- constant (in seconds).
testHypothesis :: Hypothesis -> FullReport -> Report
testHypothesis hp fr = generateReport ana fr
  where ana = [hp (fromIntegral vl) | vl <- (sizes fr)]

-- |Performs a grouped hypothesis test, takes a full report
-- and a set of named hypothesis, as well as a grouping function
-- (some examples defined in Duck.Statistics) and produces a list
-- of reports.
testGroup :: FullReport -> [(String, Hypothesis)] ->
             ([(Double, (String, Report))] -> [(Double, (String, Report))])
             -> GroupReport
testGroup fr xs flt = map snd fltrd
  where ls = map (\(name, f) -> (name, testHypothesis f fr)) xs
        ind = zip (map (confidence . snd) ls) ls
        fltrd = flt ind

-- |Takes experimental data and an hypothesis and plots both.
plotHypothesis :: FullReport -> Hypothesis -> Report -> String -> IO ()
plotHypothesis fr hp r ttype = plotReportHypothesis sz exp ana ttype
  where sz = (sizes fr)
        exp = (experiment fr)
        ana = [(propConstant r) * hp (fromIntegral vl) | vl <- (sizes fr)]

-- |Runs a source function in a set of inputs with a given size
-- and produces a tuple of: ([Mean], [Standard deviation], Outlier effect),
-- wrapped in the IO monad.
-- A quiet verbosity produces no output, a moderate one produces a summary
-- and a full one details every step.
runSource :: (NFData b) => Parameters -> (a -> b) -> [a] -> [Int] -> IO ([Double], [Double], Double)
runSource _ _ [] [] = return ([], [], 0)
runSource pr src (inst:is) (sz:ss) = do
  let res = runAndAnalyseOne 1 "" (nf src inst)
  CT.Analysed rep <- withConfig (defaultConfig { CT.verbosity = CT.Quiet,
                                                 CT.timeLimit = (timePerTest pr) }) res
  let sampPoint = CT.anMean $ CT.reportAnalysis rep
      sampVar = CT.anStdDev $ CT.reportAnalysis rep
      sampOutlier = CT.anOutlierVar $ CT.reportAnalysis rep

  putStrIf ((verbosity pr) == Full) $ show sampPoint
  putStrIf ((verbosity pr) == Full) $ show sz
  putStrIf ((verbosity pr) == Full) $ show sampOutlier
  putStrIf ((verbosity pr) == Full) $ show sampVar
  putStrIf ((verbosity pr) == Full) ""
  putStrIf ((verbosity pr) == Moderate && (1 + length ss) `mod` 5 == 0) $
    (show $ 1 + length ss) ++ " iterations left (about " ++
    (show $ (round $ timePerTest pr) * 4 * (1 + length ss) `div` 3) ++ " seconds left)"

  (avgs, stds, otlr) <- runSource pr src is ss
  return ((B.estPoint sampPoint):avgs,
          (B.estPoint sampVar):stds,
          otlr + CT.ovFraction sampOutlier)

-- |Generates a report from a full report and a list
-- of analytical results.
generateReport :: [Double] -> FullReport -> Report
generateReport ana fr = Report {confidence = conf,
                                propConstant = const}
  where (const, conf) = regress ana (experiment fr)


{- |
Module          : $Header$
Description     : This is the abstract file for the Scheme compiler.
Copyright       : (c) Michael Buchel
License         : BSD3

Maintainer      : abuchel2@uwo.ca
Stability       : experimental
Portability     : portable

This is the abstract module, where all the abstract concepts are kept.
| -}
module Abstract where

import Data.Array
import Data.Complex
import Data.Ratio

-- | Data structure for holding Lisp values.
data LispVal = Atom String
	     | List [LispVal]
	     | DottedList [LispVal] LispVal
	     | Number Integer
	     | String String
	     | Bool Bool
	     | Character Char
	     | Float Double
	     | Ratio Rational
	     | Complex (Complex Double)
	     | Vector (Array Int LispVal)

-- | Instance of show for LispVal.
instance Show LispVal where
	show = showVal

-- | Seperates the list into words.
unwordsList :: [LispVal] -- ^ List to unword.
	-> String
unwordsList = unwords . map showVal

-- | Lisp value to string.
showVal :: LispVal -- ^ Expression we got.
	-> String
showVal (Atom name) = name
showVal (List x) = "(" ++ unwordsList x ++ ")"
showVal (DottedList x y) = "(" ++ unwordsList x ++ " . " ++ showVal y ++ ")"
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (Number x) = show x
showVal (Character x) = show x
showVal (Float x) = show x
showVal (Ratio x) = show x
showVal (Complex x) = show x
showVal (Vector x) = show x


{-# language LambdaCase #-}
{-# language FlexibleInstances #-}
{-# language OverloadedStrings #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language TypeFamilies #-}
{-# language DerivingVia #-}
{-# language DeriveTraversable #-}
{-# language UndecidableInstances #-}
{-# language FlexibleContexts #-}

module Geometry.Decorations
  ( WithOptions (..)
  , Options, Option(..)
  , mkOptions, getOptions
  , Decorated(..), fromDecorated
  , Decorator(..)
  , (#:), (#::)
  , visible, invisible
  , stroke, white, fill
  , thickness, thin
  , dashed, dotted
  , arcs
  , label, loffs, lpos, lparam
  )
where

import Data.Monoid
import Data.Complex
import Data.Maybe
import Data.String( IsString(..) )
import Control.Monad
import Data.Functor.Identity

import Geometry.Base
import Geometry.Point
import Geometry.Line
import Geometry.Circle
import Geometry.Angle
import Geometry.Polygon
import Geometry.Plot

-- | Possible SVG options for a figure.
data Option = Invisible Bool
            | Stroke String
            | Fill String
            | Thickness String
            | Dashing String
            | MultiStroke Int
            | LabelText String
            | LabelCorner (Int, Int)
            | LabelPosition Cmp
            | LabelOffset Cmp
            | LabelAngle Direction
            | SegmentMark Int
            deriving (Show)

-- | Monoidal options list wrapper. Concatenates dually to a usual list.
newtype Options = Options (Dual [Option])
  deriving (Semigroup, Monoid, Show)

-- | Puts a list of options to a wrapper.g
mkOptions = Options . Dual
-- | Extracts an option list from the `Options` wrapper.
getOptions (Options (Dual os)) = os

-- | The class of objects which could have decorations.
class WithOptions a where
  -- | Get the decoration data
  options :: a -> Options
  options = defaultOptions

  -- | Set the decoration data
  setOptions :: Options -> a -> a
  setOptions _ = id

  -- | Default labeling settings
  defaultOptions :: a -> Options
  defaultOptions _ = mempty

instance
  {-# OVERLAPPABLE #-}
  (Functor t, Foldable t, WithOptions a) => WithOptions (t a) where
  options = foldMap options
  setOptions o a = setOptions o <$> a

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

-- | The transparent decoration wrapper for geometric objects.
-- Inherits all properties of embedded object.
newtype Decorated a = Decorated (Options, a)
  deriving (Functor, Foldable, Traversable)

-- | The selector for the embedded object.
fromDecorated (Decorated (_, x)) = x

instance Applicative Decorated where
  pure p = Decorated (mempty, p)
  (<*>) = ap

instance Monad Decorated where
  Decorated (d, x) >>= f =
    let Decorated (d', y) = f x
    in Decorated (d <> d', y)

instance {-# OVERLAPPING #-} WithOptions (Decorated a) where
  options (Decorated (o, _)) = o
  setOptions o' f = Decorated (o', id) <*> f

instance Show a => Show (Decorated a) where
  show f = l <> show (fromDecorated f)
    where l = maybe mempty (<> ":") lab
          lab = find optLabelText f
          find p d = extractOption p $ defaultOptions d <> options d
          extractOption p = getFirst . foldMap (First . p) . getOptions
          optLabelText = \case {LabelText x -> Just x; _ -> Nothing }

instance Eq a => Eq (Decorated a) where
  d1 == d2 = fromDecorated d1 == fromDecorated d2

instance Metric a => Metric (Decorated a) where
  dist a b = dist (fromDecorated a) (fromDecorated b)
  dist2 a b = dist2 (fromDecorated a) (fromDecorated b)

instance Affine a => Affine (Decorated a) where
  cmp = cmp . fromDecorated
  asCmp = pure . asCmp

instance {-# OVERLAPPING #-}  Trans a => Trans (Decorated a) where
  transform t = fmap (transform t)

instance Manifold m => Manifold (Decorated m) where
  type Domain (Decorated m) = Domain m
  param = param . fromDecorated
  project = project . fromDecorated
  paramMaybe = paramMaybe . fromDecorated
  projectMaybe = projectMaybe . fromDecorated
  isContaining = isContaining . fromDecorated
  unit = unit . fromDecorated

instance Curve c => Curve (Decorated c) where
  tangent = tangent . fromDecorated
  normal = normal . fromDecorated

instance ClosedCurve c => ClosedCurve (Decorated c) where
  isEnclosing = isEnclosing . fromDecorated
  location = location . fromDecorated

instance {-# OVERLAPPING #-} Figure a => Figure (Decorated a) where
  isTrivial = isTrivial . fromDecorated
  refPoint = refPoint . fromDecorated
  box = box . fromDecorated

instance APoint p => APoint (Decorated p) where
  toPoint = toPoint . fromDecorated
  asPoint = pure . asPoint

instance Linear l => Linear (Decorated l) where
  refPoints = refPoints . fromDecorated

instance Circular a => Circular (Decorated a) where
  toCircle = toCircle . fromDecorated
  asCircle = pure . asCircle

instance PiecewiseLinear a => PiecewiseLinear (Decorated a) where
  vertices = vertices . fromDecorated
  asPolyline = asPolyline . fromDecorated

instance Polygonal p => Polygonal (Decorated p) where

instance Angular a => Angular (Decorated a) where
  asAngle = pure . asAngle
  toAngle = toAngle . fromDecorated
  setValue v = fmap (setValue v)

instance APlot p => APlot (Decorated p) where
  rmap = fmap . rmap

------------------------------------------------------------
-- | A wrapped decoration function with monoidal properties,
-- corresponding to decoration options.
newtype Decorator a = Decorator (a -> Decorated a)

mkDecorator opt val = Decorator $
  \d -> setOptions (mkOptions [ opt val ]) (pure d)

instance Semigroup (Decorator a) where
  Decorator a <> Decorator b = Decorator (a >=> b)

instance Monoid (Decorator a) where
  mempty = Decorator $ \a -> Decorated (mempty, a)

instance WithOptions a => IsString (Decorator a) where
  fromString = label

infixl 5 #:
{- | The infix operator for decorator application.

>>> aPoint # at (4, 5) #: label "A"
A:<Point (4.0, 5.0)>

>>> segment (4,5) (6,9) #: "s" <> dotted <> white
s:<Segment (4.0,5.0) (6.0,9.0)>
-}
(#:) :: WithOptions a => a -> Decorator a -> Decorated a
a #: (Decorator d) = d a

(#::) :: Decorated a -> Decorator (Decorated a) -> Decorated a
a #:: (Decorator d) = join (d a)

-- | The stroke color decorator.
stroke :: WithOptions a => String -> Decorator a
stroke = mkDecorator Stroke

-- | The decorator for white lines.
white :: WithOptions a => Decorator a
white = stroke "white"

-- | The fill color decorator.
fill :: WithOptions a => String -> Decorator a
fill = mkDecorator Fill

-- | The stroke-thickness decorator.
thickness :: WithOptions a => String -> Decorator a
thickness = mkDecorator Thickness

-- | The decorator for thin lines.
thin :: WithOptions a => Decorator a
thin = thickness "1"

-- | The decorator for dashed lines.
dashed :: WithOptions a => Decorator a
dashed = mkDecorator Dashing "5,5"

-- | The decorator for dotted lines.
dotted :: WithOptions a => Decorator a
dotted = mkDecorator Dashing "2,3"

-- | The decorator for dotted lines.
arcs :: Int -> Decorator Angle
arcs = mkDecorator MultiStroke

-- | The decorator which makes invisible object visible.
visible :: WithOptions a => Decorator a
visible = mkDecorator Invisible False

-- | The decorator which makes visible object invisible.
invisible :: WithOptions a => Decorator a
invisible = mkDecorator Invisible True

-- | The decorator for labeling objects. Could be used as overloaded string.
--
-- >>> aPoint # at (4, 5) #: "A"
-- A:<Point (4, 5)>
--
label :: WithOptions a => String -> Decorator a
label = mkDecorator LabelText

-- | The decorator for label offset.
loffs :: (Affine p,  WithOptions a) => p -> Decorator a
loffs = mkDecorator LabelOffset . conjugate . cmp

-- | The decorator for label position.
lpos :: (Affine p, WithOptions a) => p -> Decorator a
lpos = mkDecorator LabelPosition . cmp

-- | The decorator for setting label on a curve at a given parameter value.
lparam :: (WithOptions m, Manifold m) => Double -> Decorator m
lparam x = Decorator $ \f -> f #: lpos (f @-> x)

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


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Main where
import qualified Data.Foldable as Foldable

-- vector
import Data.Vector (Vector)
import qualified Data.Vector as Vector

-- Matrix
import Data.Matrix (Matrix)
import qualified Data.Matrix as Matrix

-- HMatrix
import qualified Numeric.LinearAlgebra.Data as HMatrix
import qualified Numeric.LinearAlgebra.HMatrix as HMatrix

-- bytestring
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as ByteString

-- cassava
import Data.Csv
  ( DefaultOrdered(headerOrder)
  , FromField(parseField)
  , FromNamedRecord(parseNamedRecord)
  , Header
  , ToField(toField)
  , ToNamedRecord(toNamedRecord)
  , (.:)
  , (.=)
  )
import qualified Data.Csv as Cassava

-- text
import Data.Text (Text)
import qualified Data.Text.Encoding as Text

-- Exception
import Control.Exception

-- base
import qualified Control.Monad as Monad
import qualified System.Exit as Exit
import qualified Debug.Trace as Trace

data ComponentData =
  ComponentData {
    componentType :: ComponentType,
    nodeK :: Int,
    nodeM :: Int,
    magnitude :: Double,
    param1 :: Double,
    param2 :: Double,
    plot :: Int
     }
  deriving (Eq, Show)

data SimulationData =
  SimulationData {
    nodes :: Int,
    voltageSources :: Int,
    stepSize :: Double,
    tmax :: Double
     }
  deriving (Eq, Show)

data ComponentType = Resistor | Capacitor | Inductor | EAC | EDC | Other Text deriving (Eq, Show)
type SimulationResults = (Vector Double, Matrix Double)

instance FromNamedRecord SimulationData where
  parseNamedRecord m =
    SimulationData
      <$> m .: "Number of Nodes"
      <*> m .: "Number of Voltages Sources"
      <*> m .: "Step Size"
      <*> m .: "Maximum time for simulation"

instance FromNamedRecord ComponentData where
  parseNamedRecord m =
    ComponentData
      <$> m .: "Element Type"
      <*> m .: "Node K"
      <*> m .: "Node M"
      <*> m .: "Value"
      <*> m .: "Source param 1"
      <*> m .: "Source param 2"
      <*> m .: "Plot"

instance FromField ComponentType where
  parseField "R" =
    pure Resistor

  parseField "L" =
    pure Inductor

  parseField "C" =
    pure Capacitor

  parseField "EDC" =
    pure EDC

  parseField "EAC" =
    pure EAC

  parseField otherType =
    Other <$> parseField otherType

decodeItems :: ByteString -> Either String (Vector ComponentData)
decodeItems =
  fmap snd . Cassava.decodeByName

decodeItemsFromFile :: FilePath -> IO (Either String (Vector ComponentData))
decodeItemsFromFile filePath =
  catchShowIO (ByteString.readFile filePath)
    >>= return . either Left decodeItems

decodeSimulation :: ByteString -> Either String (Vector SimulationData)
decodeSimulation =
  fmap snd . Cassava.decodeByName

decodeSimulationFromFile :: FilePath -> IO (Either String (Vector SimulationData))
decodeSimulationFromFile filePath =
  catchShowIO (ByteString.readFile filePath)
    >>= return . either Left decodeSimulation

getSingleSimulationLine :: Vector SimulationData -> SimulationData
getSingleSimulationLine =
    Vector.head

nhComponents :: [ComponentData] -> [ComponentData]
nhComponents =
  filter (\r -> (componentType r == Capacitor) || (componentType r == Inductor))

filterEnergyStorageComponent :: Vector ComponentData -> Vector ComponentData
filterEnergyStorageComponent =
  Vector.filter (\r -> (componentType r == Capacitor) || (componentType r == Inductor))

nh :: Vector ComponentData -> Int
nh components =
  length $ filterEnergyStorageComponent components

-- filter ((== Zaal) . reviewLocation) reviews

filterSources :: Vector ComponentData -> Vector ComponentData
filterSources =
  Vector.filter (\r -> (componentType r == EDC) || (componentType r == EAC))

condutance :: ComponentData -> Double -> Double
condutance component dt =
  case componentType component of
    Resistor -> 1.0 / (magnitude component)
    Capacitor -> (magnitude component) * 0.000001 * 2 / dt
    Inductor -> dt / (2 * 0.001 * (magnitude component))
    _ -> 0.0

gkm :: Vector ComponentData -> Double -> Vector Double
gkm components dt =
  Vector.map (\c -> condutance c dt) components
  -- Matrix.colVector (Vector.map (\c -> condutance c dt) components)
  -- Matrix.fromList (length components) 1 (Vector.toList (Vector.map (\c -> condutance c dt) components))

buildCompactGMatrix :: Double -> [ComponentData] -> Matrix Double -> Matrix Double
buildCompactGMatrix dt [] buffer = buffer
buildCompactGMatrix dt (component:cs) buffer =
  case (nodeK component, nodeM component) of (0, m) -> buildCompactGMatrix dt cs (Matrix.setElem (Matrix.getElem m m buffer + condutance component dt) (m, m) buffer)
                                             (k, 0) -> buildCompactGMatrix dt cs (Matrix.setElem (Matrix.getElem k k buffer + condutance component dt) (k, k) buffer)
                                             (k, m) -> buildCompactGMatrix dt cs (Matrix.setElem (Matrix.getElem k k buffer + condutance component dt) (k, k) (Matrix.setElem (Matrix.getElem m m buffer + condutance component dt) (m, m) (Matrix.setElem (Matrix.getElem k m buffer - condutance component dt) (k, m) (Matrix.setElem (Matrix.getElem m k buffer - condutance component dt) (m, k) buffer))))
                                             (_, _) -> buildCompactGMatrix dt cs buffer

buildGMatrixFromVector :: SimulationData -> Vector ComponentData -> Matrix Double
buildGMatrixFromVector simulation components =
  buildCompactGMatrix (stepSize simulation) (Vector.toList components) (Matrix.zero (nodes simulation) (nodes simulation))

buildIhVector :: [ComponentData] -> Double -> Int -> [Double] -> [Double] -> Matrix Double -> Vector Double
buildIhVector [] _ _ _ ihnew _ = Vector.fromList ihnew
buildIhVector (component:cs) dt n (hold:ihold) ihnew vMatrix =
  case (componentType component, nodeK component, nodeM component) of (Inductor, 0, m) -> buildIhVector cs dt n ihold (ihnew ++ [(2*(condutance component dt)*(Matrix.getElem m n vMatrix) + hold)]) vMatrix
                                                                      (Inductor, k, 0) -> buildIhVector cs dt n ihold (ihnew ++ [(-2*(condutance component dt)*(Matrix.getElem k n vMatrix) + hold)]) vMatrix
                                                                      (Inductor, k, m) -> buildIhVector cs dt n ihold (ihnew ++ [(-2*(condutance component dt)*((Matrix.getElem k n vMatrix) - (Matrix.getElem m n vMatrix)) + hold)]) vMatrix
                                                                      (Capacitor, 0, m) -> buildIhVector cs dt n ihold (ihnew ++ [(-2*(condutance component dt)*(Matrix.getElem m n vMatrix) - hold)]) vMatrix
                                                                      (Capacitor, k, 0) -> buildIhVector cs dt n ihold (ihnew ++ [(2*(condutance component dt)*(Matrix.getElem k n vMatrix) - hold)]) vMatrix
                                                                      (Capacitor, k, m) -> buildIhVector cs dt n ihold (ihnew ++ [(2*(condutance component dt)*((Matrix.getElem k n vMatrix) - (Matrix.getElem m n vMatrix)) - hold)]) vMatrix
                                                                      (_, _, _) -> buildIhVector cs dt n ihold ihnew vMatrix

buildVBVector :: [ComponentData] -> Double -> [Double] -> Vector Double
buildVBVector [] _ buffer = Vector.fromList buffer
buildVBVector (c:components) time buffer =
  case (componentType c) of EDC -> buildVBVector components time ((magnitude c) : buffer)
                            EAC -> buildVBVector components time (((magnitude c * cos (2 * pi * param2 c * time + (param1 c * (pi/180))))) : buffer)
                            _   -> buildVBVector components time buffer

buildIVector :: [ComponentData] -> [Double] -> Vector Double -> Vector Double
buildIVector [] _ iVector = iVector
buildIVector (component:cs) (ihEl:ih) iVector =
  case (componentType component, nodeK component, nodeM component) of (Inductor, k, 0) -> buildIVector cs ih (iVector Vector.// [((k - 1), ((iVector Vector.! (k-1)) + ihEl))])
                                                                      (Inductor, 0, m) -> buildIVector cs ih (iVector Vector.// [((m - 1), ((iVector Vector.! (m-1)) - ihEl))])
                                                                      (Inductor, k, m) -> buildIVector cs ih (iVector Vector.// [((m - 1), ((iVector Vector.! (m-1)) - ihEl)), ((k-1), ((iVector Vector.! (k-1)) + ihEl))])
                                                                      (Capacitor, k, 0) -> buildIVector cs ih (iVector Vector.// [((k - 1), ((iVector Vector.! (k-1)) + ihEl))])
                                                                      (Capacitor, 0, m) -> buildIVector cs ih (iVector Vector.// [((m - 1), ((iVector Vector.! (m-1)) - ihEl))])
                                                                      (Capacitor, k, m) -> buildIVector cs ih (iVector Vector.// [((m - 1), ((iVector Vector.! (m-1)) - ihEl)), ((k-1), ((iVector Vector.! (k-1)) + ihEl))])
                                                                      (_, _, _) -> buildIVector cs ih iVector

thtaControl :: Int -> Double -> Vector Double -> Vector Double -> SimulationData -> (Int, Vector Double, Double)
thtaControl thtactl time ihnew ih simulation
  | thtactl <= 0 = (thtactl, ihnew, (stepSize simulation + time))
  | thtactl < 3 = (thtactl + 1, (Vector.map (\i -> i/2) $ Vector.zipWith (+) ih ihnew), (time + (stepSize simulation/2)))
  | otherwise = (0, ihnew, (stepSize simulation + time))

fromHMatrixTransformer :: HMatrix.Matrix Double -> Matrix Double
fromHMatrixTransformer matrix =
  Matrix.fromLists $ HMatrix.toLists matrix

toHMatrixTransformer :: Matrix Double -> HMatrix.Matrix Double
toHMatrixTransformer matrix =
  HMatrix.fromLists $ Matrix.toLists matrix

fromHMatrixVectorTransformer :: HMatrix.Vector Double -> Vector Double
fromHMatrixVectorTransformer vec =
  Vector.fromList $ HMatrix.toList vec

toHMatrixVectorTransformer :: Vector Double -> HMatrix.Vector Double
toHMatrixVectorTransformer vec =
  HMatrix.fromList $ Vector.toList vec

solver :: HMatrix.Vector Double -> HMatrix.Matrix Double -> HMatrix.Matrix Double -> HMatrix.Matrix Double -> HMatrix.Matrix Double -> HMatrix.Vector Double -> SimulationData -> (Vector Double, Vector Double)
solver iVector gaa gab gba gbb vb simulation =
  let ia = HMatrix.subVector 0 ((nodes simulation) - (voltageSources simulation)) iVector
      rhsa = ia - (gab HMatrix.#> vb)
      va = gaa HMatrix.<\> rhsa
      ib = (gba HMatrix.#> va) + (gbb HMatrix.#> vb)
      iVec = HMatrix.vjoin [ia, ib]
      vVec = HMatrix.vjoin [va, vb]
  in
    ((fromHMatrixVectorTransformer iVec), (fromHMatrixVectorTransformer vVec))

thtaSimulationStep :: [ComponentData] -> Matrix Double -> SimulationData -> Int -> Int -> Double  -> Vector Double -> Matrix Double -> Vector Double -> Vector Double -> SimulationResults
thtaSimulationStep _ _ _ _ 1 _ _ vMatrix _ iVector = (iVector, vMatrix)
thtaSimulationStep components condutances simulation thtactl n time ih vMatrix vbVector iVector =
  let (gaa, gab, gba, gbb) = Matrix.splitBlocks (nodes simulation - voltageSources simulation) (nodes simulation - voltageSources simulation) condutances
      ihBuffer = buildIhVector (nhComponents components) (stepSize simulation) n (Vector.toList ih) [] vMatrix
      (thta, ihThta, timeThta) = thtaControl thtactl time ihBuffer ih simulation
      vbVec = buildVBVector components timeThta []
      iVec = buildIVector (nhComponents components) (Vector.toList ihThta) (Vector.replicate (nodes simulation) 0)
      -- (iVecCalc, vVec) = Trace.trace ("Solver = \n" ++ show (solver (toHMatrixVectorTransformer iVec) (toHMatrixTransformer gaa) (toHMatrixTransformer gab) (toHMatrixTransformer gba) (toHMatrixTransformer gbb) (toHMatrixVectorTransformer vbVec) simulation)) solver (toHMatrixVectorTransformer iVec) (toHMatrixTransformer gaa) (toHMatrixTransformer gab) (toHMatrixTransformer gba) (toHMatrixTransformer gbb) (toHMatrixVectorTransformer vbVec) simulation
      (iVecCalc, vVec) = solver (toHMatrixVectorTransformer iVec) (toHMatrixTransformer gaa) (toHMatrixTransformer gab) (toHMatrixTransformer gba) (toHMatrixTransformer gbb) (toHMatrixVectorTransformer vbVec) simulation
      vMatr = Matrix.mapCol (\r _ -> vVec Vector.! (r - 1)) (n-1) vMatrix
  in
      thtaSimulationStep components condutances simulation thta (n-1) timeThta ihThta vMatr vbVec iVecCalc

thtaSimulation :: Vector ComponentData -> SimulationData -> SimulationResults
thtaSimulation components simulation =
  thtaSimulationStep (Vector.toList components) (buildGMatrixFromVector simulation components) simulation 1 (npoints simulation) 0.0 (Vector.replicate (nh components) 0) (Matrix.zero (nodes simulation) (npoints simulation)) (Vector.replicate (voltageSources simulation) 0) (Vector.replicate (nodes simulation) 0)

npoints :: SimulationData -> Int
npoints sim =
  round ((tmax sim)/(stepSize sim)) + 1

catchShowIO :: IO a -> IO (Either String a)
catchShowIO action =
  fmap Right action
    `catch` handleIOException
  where
    handleIOException :: IOException -> IO (Either String a)
    handleIOException =
      return . Left . show

main :: IO ()
main = do

  eitherSimulation <-
      fmap getSingleSimulationLine
        <$> decodeSimulationFromFile "data/simulation.csv"

  case eitherSimulation of
    Left reason ->
      Exit.die reason

    Right simulation -> do
      components_list <- decodeItemsFromFile "data/components.csv"
      case components_list of
        Left reason -> Exit.die reason
        Right components -> do
          let gmt = buildGMatrixFromVector simulation components
          putStr "GMatrix: \n"
          print (gmt)
          let results = thtaSimulation components simulation
          putStr "Simulation: \n"
          print (results)


-- |
-- Module      : BenchShow.Report
-- Copyright   : (c) 2018 Composewell Technologies
--
-- License     : BSD3
-- Maintainer  : harendra.kumar@gmail.com
-- Stability   : experimental
-- Portability : GHC
--

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}

module BenchShow.Report
    (
      report
    ) where

import Control.Applicative (ZipList(..))
import Control.Monad (forM_)
import Data.Maybe (fromMaybe)
import Statistics.Types (Estimate(..))
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
import Text.Printf (printf)

import BenchShow.Common
import BenchShow.Analysis

multiplesToPercentDiff :: Double -> Double
multiplesToPercentDiff x = (if x > 0 then x - 1 else x + 1) * 100

colorCode :: Word -> Double -> Doc -> Doc
colorCode thresh x =
    if x > fromIntegral thresh
    then dullred
    else if x < (-1) * fromIntegral thresh
         then dullgreen
         else id

-- XXX in comparative reports render lower than baseline in green and higher
-- than baseline in red
genGroupReport :: RawReport -> Config -> IO ()
genGroupReport RawReport{..} cfg@Config{..} = do
    let diffStr =
            if length reportColumns > 1
            then diffString presentation diffStrategy
            else Nothing
    case mkTitle of
        Just _ -> putStrLn $ maybe "" (\f -> f reportIdentifier) mkTitle
        Nothing -> putStrLn $ makeTitle reportIdentifier diffStr cfg

    let benchcol  = "Benchmark" : reportRowIds
        groupcols =
            let firstCol : tailCols = reportColumns
                colorCol ReportColumn{..} =
                    let f x = case presentation of
                                Groups Diff ->
                                    if x > 0 then dullred else dullgreen
                                Groups PercentDiff -> colorCode threshold x
                                Groups Multiples ->
                                    let y = multiplesToPercentDiff x
                                    in colorCode threshold y
                                _ -> id
                    in map f colValues
                renderTailCols estimators col analyzed =
                    let regular = renderGroupCol $ showCol col Nothing analyzed
                        colored = zipWith ($) (id : id : colorCol col)
                                    $ renderGroupCol
                                    $ showCol col estimators analyzed
                    in case presentation of
                        Groups Diff        -> colored
                        Groups PercentDiff -> colored
                        Groups Multiples   -> colored
                        _ -> regular
            in renderGroupCol (showFirstCol firstCol)
             : case reportEstimators of
                Just ests -> getZipList $
                            renderTailCols
                        <$> ZipList (map Just $ tail ests)
                        <*> ZipList tailCols
                        <*> ZipList (tail reportAnalyzed)
                Nothing ->  getZipList $
                            renderTailCols
                        <$> pure Nothing
                        <*> ZipList tailCols
                        <*> ZipList (tail reportAnalyzed)
        rows = foldl (zipWith (<+>)) (renderCol benchcol) groupcols
    putDoc $ vcat rows
    putStrLn "\n"

    where

    renderCol [] = error "Bug: header row missing"
    renderCol col@(h : rows) =
        let maxlen = maximum (map length col)
        in map (fill maxlen . text) (h : replicate maxlen '-' : rows)

    renderGroupCol [] = error
        "Bug: There has to be at least one column in raw report"
    renderGroupCol col@(h : rows) =
        let maxlen = maximum (map length col)
        in map (\x -> indent (maxlen - length x) $ text x)
               (h : replicate maxlen '-' : rows)

    showEstimator est =
        case est of
            Mean       -> "(mean)"
            Median     -> "(medi)"
            Regression -> "(regr)"

    showEstVal estvals est =
        case est of
            Mean ->
                let sd = analyzedStdDev estvals
                    val = analyzedMean estvals
                in
                   if val /= 0
                   then printf "(%.2f)" $ sd / abs val
                   else ""
            Median ->
                let x = ovFraction $ analyzedOutlierVar estvals
                in printf "(%.2f)" x
            Regression ->
                case analyzedRegRSq estvals of
                    Just rsq -> printf "(%.2f)" (estPoint rsq)
                    Nothing -> ""

    showFirstCol ReportColumn{..} =
        let showVal = printf "%.2f"
            withEstimator val estvals =
                showVal val ++
                    if verbose
                    then showEstVal estvals estimator
                    else ""
            withEstVal =
                zipWith withEstimator colValues (head reportAnalyzed)
        in colName : withEstVal

    showCol ReportColumn{..} estimators analyzed = colName :
        let showVal val =
                let showDiff =
                        if val > 0
                        then printf "+%.2f" val
                        else printf "%.2f" val
                in case presentation of
                        Groups Diff        -> showDiff
                        Groups PercentDiff -> showDiff
                        Groups Multiples ->
                            if val > 0
                            then printf "%.2f" val
                            else printf "1/%.2f" (negate val)
                        _ -> printf "%.2f" val

            showEstAnnot est =
                case presentation of
                    Groups Diff        -> showEstimator est
                    Groups PercentDiff -> showEstimator est
                    Groups Multiples   -> showEstimator est
                    _ -> ""

        in case estimators of
            Just ests ->
                let withAnnot val estvals est =
                           showVal val
                        ++ if verbose
                           then showEstVal estvals est
                                ++ showEstAnnot est
                           else ""
                in getZipList $
                        withAnnot
                    <$> ZipList colValues
                    <*> ZipList analyzed
                    <*> ZipList ests

            Nothing ->
                let withEstVal val estvals est =
                           showVal val
                        ++ if verbose then showEstVal estvals est else ""
                in getZipList $
                        withEstVal
                    <$> ZipList colValues
                    <*> ZipList analyzed
                    <*> pure estimator

-- | Presents the benchmark results in a CSV input file as text reports
-- according to the provided configuration.  The first parameter is the input
-- file name. The second parameter, when specified using 'Just', is the name
-- prefix for the output SVG image file(s). One or more output files may be
-- generated with the given prefix depending on the 'Presentation' setting.
-- When the second parameter is 'Nothing' the reports are printed on the
-- console. The last parameter is the configuration to customize the report,
-- you can start with 'defaultConfig' as the base and override any of the
-- fields that you may want to change.
--
-- For example:
--
-- @
-- report "bench-results.csv" Nothing 'defaultConfig'
-- @
--
-- @since 0.2.0
report :: FilePath -> Maybe FilePath -> Config -> IO ()
report inputFile outputFile cfg@Config{..} = do
    let dir = fromMaybe "." outputDir
    (csvlines, fields) <- prepareToReport inputFile cfg
    (runs, matrices) <- prepareGroupMatrices cfg inputFile csvlines fields
    case presentation of
        Groups style ->
            forM_ fields $
                reportComparingGroups style dir outputFile TextReport runs
                               cfg genGroupReport matrices
        Fields -> do
            forM_ matrices $
                reportPerGroup dir outputFile TextReport cfg genGroupReport
        Solo ->
            let funcs = map
                    (\mx -> reportComparingGroups Absolute dir
                        (fmap (++ "-" ++ groupName mx) outputFile)
                        TextReport runs cfg genGroupReport [mx])
                    matrices
             in sequence_ $ funcs <*> fields


{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where

import qualified Sound.Pulse.Simple as Pulse
import Control.Exception (bracket, finally)
import qualified Math.FFT as FFT
import Data.Array.IArray (amap, listArray)
import qualified Data.Array.IArray as IArray
import Data.Complex (Complex(..))
import Pipes
import qualified Pipes.Prelude as Pipes
import Graphics.Rendering.OpenGL (GLfloat)
import Graphics.DynamicGraph.FillLine
import Graphics.DynamicGraph.Line
import Graphics.DynamicGraph.Window
import Control.Monad (unless, guard, forever, when)
import Control.Error.Util (exceptT)
import Foreign.C.Types (CInt (..))
import Data.Foldable (for_)
import Data.Maybe (isJust)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.TH as Aeson.TH
import qualified Data.Yaml as Yaml
import qualified Data.Yaml.Pretty as Yaml.Pretty
import System.Environment (getArgs)
import Data.IORef
import qualified Data.ByteString.Char8 as BSC8

-- key presses
-- --------------------------------------------------------------------

foreign import ccall "fakekey_init"    fakeKeyInit    :: IO ()
foreign import ccall "fakekey_press"   fakeKeyPress   :: CInt -> IO ()
foreign import ccall "fakekey_release" fakeKeyRelease :: CInt -> IO ()

keyCodeToX11KeySym :: String -> Maybe CInt
keyCodeToX11KeySym code = case code of
  "KeyA" -> Just 0x0061
  "KeyB" -> Just 0x0062
  "KeyC" -> Just 0x0063
  "KeyD" -> Just 0x0064
  "KeyE" -> Just 0x0065
  "KeyF" -> Just 0x0066
  "KeyG" -> Just 0x0067
  "KeyH" -> Just 0x0068
  "KeyI" -> Just 0x0069
  "KeyJ" -> Just 0x006a
  "KeyK" -> Just 0x006b
  "KeyL" -> Just 0x006c
  "KeyM" -> Just 0x006d
  "KeyN" -> Just 0x006e
  "KeyO" -> Just 0x006f
  "KeyP" -> Just 0x0070
  "KeyQ" -> Just 0x0071
  "KeyR" -> Just 0x0072
  "KeyS" -> Just 0x0073
  "KeyT" -> Just 0x0074
  "KeyU" -> Just 0x0075
  "KeyV" -> Just 0x0076
  "KeyW" -> Just 0x0077
  "KeyX" -> Just 0x0078
  "KeyY" -> Just 0x0079
  "KeyZ" -> Just 0x007a
  "ArrowLeft" -> Just 0xff51
  "ArrowUp" -> Just 0xff52
  "ArrowRight" -> Just 0xff53
  "ArrowDown" -> Just 0xff54
  "Space" -> Just 0x0020
  _ -> Nothing

-- fft
-- --------------------------------------------------------------------

sampleRate :: Int
sampleRate = 16000

numSamples :: Int
numSamples = 512

fftFreqs :: [Float]
fftFreqs = 0 : (do
  let binWidth :: Float = fromIntegral sampleRate / fromIntegral numSamples
  ix <- fromIntegral <$> [1..numSamples]
  let freq = binWidth * ix
  -- filter frequencies above 2000, they're not very useful for what
  -- we're doing
  guard (freq < 2000)
  return freq)

fft :: [Float] -> [Float]
fft signal = IArray.elems $ amap
  (\(real :+ imag) -> sqrt (real ** 2 + imag ** 2))
  (FFT.dftRC (listArray (0, numSamples-1) signal))

-- reading audio
-- --------------------------------------------------------------------

data Graph = Audio | Frequency
  deriving (Show, Eq)
instance Aeson.FromJSON Graph where
  parseJSON = Aeson.withText "Graph" $ \case
    "Audio" -> return Audio
    "Frequency" -> return Frequency
    txt -> fail ("Invalid graph " ++ show txt)

data Params = Params
  { paramsAmplitudeCoefficient :: GLfloat
  , paramsAmplitudeLowTreshold :: GLfloat
  , paramsAmplitudeHighTreshold :: GLfloat
  -- ^ what the minimum scaled peak frequency should be to trigger high / low
  , paramsFrequncyTreshold :: GLfloat
  } deriving (Eq, Show)
Aeson.TH.deriveJSON
  Aeson.defaultOptions{ Aeson.fieldLabelModifier = drop (length ("params" :: String))}
  ''Params

data Options = Options
  { optionsPrintBestFreq :: Bool -- ^ wether to print what the chosen frequency
  , optionsControls :: Maybe (String, String) -- ^ what to press when low and high
  , optionsGraph :: Graph
  } deriving (Eq, Show)
Aeson.TH.deriveFromJSON
  Aeson.defaultOptions{ Aeson.fieldLabelModifier = drop (length ("options" :: String))}
  ''Options

data Frame = Frame
  { frameAudio :: [GLfloat]
  , frameFrequencies :: [GLfloat]
  -- ^ the frequencies amplitudes are scaled by paramsAmplitudeCoefficient
  }

-- returns the unscaled frame
readFrame :: Pulse.Simple -> IO Frame
readFrame spl = do
  frameAudio <- Pulse.simpleRead spl numSamples
  let frameFrequencies = take (length fftFreqs) (fft frameAudio)
  return Frame{..}

audioFreqs :: Pulse.Simple -> Params -> Producer Frame IO void
audioFreqs spl Params{..} = forever $ do
  frame <- lift (readFrame spl)
  yield frame{ frameFrequencies = map (* paramsAmplitudeCoefficient) (frameFrequencies frame) }

data LowHigh = Low | High
  deriving (Eq, Show)

computeLowHigh :: Options -> Params -> [GLfloat] -> IO (Maybe LowHigh)
computeLowHigh Options{..} Params{..} freqs = do
  let weightedAvg = sum (zipWith (*) fftFreqs freqs) / sum freqs
  let mbLowHigh = do
        let lowHigh = if weightedAvg < paramsFrequncyTreshold then Low else High
        guard $ case lowHigh of
          Low -> maximum freqs > paramsAmplitudeLowTreshold
          High -> maximum freqs > paramsAmplitudeHighTreshold
        return lowHigh
  when (optionsPrintBestFreq && isJust mbLowHigh) $ do
    putStrLn ("best freq: " ++ show weightedAvg)
  return mbLowHigh

control :: Options -> Params -> Pipe Frame Frame IO ()
control options@Options{..} params@Params{..} = go Nothing
  where
    go mbLowHigh = do
      frame@(Frame _ freqs) <- await
      newMbLowHigh <- lift (computeLowHigh options params freqs)
      lift $ case (mbLowHigh, newMbLowHigh) of
        (Nothing, Nothing) -> return ()
        (Nothing, Just newLowHigh) -> do
          putStrLn ("Going from idle to " ++ show newLowHigh)
          keyPress newLowHigh
        (Just lowHigh, Nothing) -> do
          putStrLn ("Going from " ++ show lowHigh ++ " to idle")
          keyRelease lowHigh
        (Just lowHigh, Just newLowHigh) | lowHigh == newLowHigh -> return ()
        (Just lowHigh, Just newLowHigh) -> do
          putStrLn ("Going from " ++ show lowHigh ++ " to " ++ show lowHigh)
          keyRelease lowHigh
          keyPress newLowHigh
      yield frame
      go newMbLowHigh

    keyPress lowHigh = for_ optionsControls $ \(lowKey, highKey) -> case lowHigh of
      Low -> do
        Just keyCode <- return (keyCodeToX11KeySym lowKey)
        fakeKeyPress keyCode
      High -> do
        Just keyCode <- return (keyCodeToX11KeySym highKey)
        fakeKeyPress keyCode

    keyRelease lowHigh = for_ optionsControls $ \(lowKey, highKey) -> case lowHigh of
      Low -> do
        Just keyCode <- return (keyCodeToX11KeySym lowKey)
        fakeKeyRelease keyCode
      High -> do
        Just keyCode <- return (keyCodeToX11KeySym highKey)
        fakeKeyRelease keyCode

calibrate :: Pulse.Simple -> IORef GLfloat -> Producer Frame IO void
calibrate spl maxFreqRef = forever $ do
  maxFreq <- lift (readIORef maxFreqRef)
  frame <- lift (readFrame spl)
  lift (writeIORef maxFreqRef (max maxFreq (maximum (frameFrequencies frame))))
  yield frame

main :: IO ()
main = do
  bracket
    (Pulse.simpleNew
      Nothing "pitch-control" Pulse.Record Nothing "Pitch controls for your keyboard"
      (Pulse.SampleSpec (Pulse.F32 Pulse.LittleEndian) sampleRate 1) Nothing Nothing)
    Pulse.simpleFree
    (\spl -> exceptT error return $ do
      res <- lift setupGLFW
      unless res (error "Unable to initilize GLFW")
      args <- lift getArgs
      case args of
        ["calibrate"] -> do
          maxFreqRef <- lift (newIORef 0)
          render <- window 1024 480 (fmap pipeify (renderFilledLine (length fftFreqs) jet_mod))
          let tranformFreqs = forever $ do
                frame <- await
                maxFreq <- lift (readIORef maxFreqRef)
                yield (map (/ maxFreq) (frameFrequencies frame))
          lift $ finally (runEffect (calibrate spl maxFreqRef >-> tranformFreqs >-> render)) $ do
            maxFreq <- readIORef maxFreqRef
            BSC8.putStrLn $ Yaml.Pretty.encodePretty Yaml.Pretty.defConfig Params
              { paramsAmplitudeCoefficient = 1 / maxFreq
              , paramsAmplitudeLowTreshold = 0.1
              , paramsAmplitudeHighTreshold = 0.2
              , paramsFrequncyTreshold = 700
              }
        ["run", paramsFile, optionsFile] -> do
          params <- lift (either (error . Yaml.prettyPrintParseException) id <$> Yaml.decodeFileEither paramsFile)
          options <- lift (either (error . Yaml.prettyPrintParseException) id <$> Yaml.decodeFileEither optionsFile)
          lift fakeKeyInit
          render <- window 1024 480 $ fmap pipeify $ case optionsGraph options of
            Frequency -> renderFilledLine (length fftFreqs) jet_mod
            Audio -> renderLine numSamples 1024
          let data_ = Pipes.map $ case optionsGraph options of
                Frequency -> frameFrequencies
                Audio -> map ((+ 0.5) . (/ 2)) . frameAudio
          lift (runEffect (audioFreqs spl params >-> control options params >-> data_ >-> render)))