{-# LANGUAGE CPP                #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE StandaloneDeriving #-}

-- | Flat instances for the base library
module Flat.Instances.Base () where

import           Control.Monad         (liftM2)
import           Data.Bool
import           Data.Char
import           Data.Complex          (Complex (..))
import           Data.Fixed
-- #if MIN_VERSION_base(4,9,0)
import qualified Data.List.NonEmpty    as B
-- #endif

#if ! MIN_VERSION_base(4,8,0)
import           Control.Applicative
import           Data.Monoid           (mempty)
#endif

#if MIN_VERSION_base(4,9,0)
import qualified Data.Semigroup        as Semigroup
#endif

import qualified Data.Monoid           as Monoid
import           Data.Ratio
import           Flat.Instances.Util
import           Prelude               hiding (mempty)

#if !MIN_VERSION_base(4,11,0)
import           Data.Monoid           ((<>))
#endif

#if MIN_VERSION_base(4,8,0)
import           Data.Functor.Identity (Identity (..))
#endif

#if !MIN_VERSION_base(4,9,0)
deriving instance Generic (Complex a)
#endif

{- ORMOLU_DISABLE -}
-- $setup
-- >>> :set -XNegativeLiterals
-- >>> import Flat.Instances.Test
-- >>> import Data.Fixed
-- >>> import Data.Int
-- >>> import Data.Complex(Complex(..))
-- >>> import Numeric.Natural
-- >>> import Data.Word
-- >>> import Data.Ratio
-- >>> import Flat.Run
-- >>> import Data.Monoid
-- >>> import qualified Data.List.NonEmpty as B
-- >>> let test = tstBits
-- >>> let y = 33
{- ORMOLU_ENABLE -}

-- >>> y

#if MIN_VERSION_base(4,8,0)
-- | @since 0.4.4
instance Flat a => Flat (Identity a) where
    encode (Identity a) = encode a
    size (Identity a) = size a
    decode = Identity <$> decode
#endif

-- | @since 0.4.4
instance Flat a => Flat (Monoid.Dual a) where
    encode (Monoid.Dual a) = encode a
    size (Monoid.Dual a) = size a
    decode = Monoid.Dual <$> decode

-- | @since 0.4.4
instance Flat Monoid.All where
    encode (Monoid.All a) = encode a
    size (Monoid.All a) = size a
    decode = Monoid.All <$> decode

-- | @since 0.4.4
instance Flat Monoid.Any where
    encode (Monoid.Any a) = encode a
    size (Monoid.Any a) = size a
    decode = Monoid.Any <$> decode

-- | @since 0.4.4
instance Flat a => Flat (Monoid.Sum a) where
    encode (Monoid.Sum a) = encode a
    size (Monoid.Sum a) = size a
    decode = Monoid.Sum <$> decode

-- | @since 0.4.4
instance Flat a => Flat (Monoid.Product a) where
    encode (Monoid.Product a) = encode a
    size (Monoid.Product a) = size a
    decode = Monoid.Product <$> decode

#if MIN_VERSION_base(4,9,0)
{- |

>>> let w = Just (11::Word8); a = Alt w <> Alt (Just 24) in tst a == tst w
True

>>> let w = Just (11::Word8); a = Alt Nothing <> Alt w in tst a == tst w
True

@since 0.4.4
-}
instance Flat (f a) => Flat (Monoid.Alt f a) where
    encode (Monoid.Alt a) = encode a
    size (Monoid.Alt a) = size a
    decode = Monoid.Alt <$> decode

-- | @since 0.4.4
instance Flat a => Flat (Semigroup.Min a) where
    encode (Semigroup.Min a) = encode a
    size (Semigroup.Min a) = size a
    decode = Semigroup.Min <$> decode

-- | @since 0.4.4
instance Flat a => Flat (Semigroup.Max a) where
    encode (Semigroup.Max a) = encode a
    size (Semigroup.Max a) = size a
    decode = Semigroup.Max <$> decode

-- | @since 0.4.4
instance Flat a => Flat (Semigroup.First a) where
    encode (Semigroup.First a) = encode a
    size (Semigroup.First a) = size a
    decode = Semigroup.First <$> decode

-- | @since 0.4.4
instance Flat a => Flat (Semigroup.Last a) where
    encode (Semigroup.Last a) = encode a
    size (Semigroup.Last a) = size a
    decode = Semigroup.Last <$> decode
#endif

{- |
`()`, as all data types with a single constructor, has a zero-length encoding.

>>> test ()
(True,0,"")
-}
instance Flat () where
    encode _ = mempty

    size _ = id

    decode = pure ()

{- |
One bit is plenty for a Bool.

>>> test False
(True,1,"0")

>>> test True
(True,1,"1")
-}
instance Flat Bool where
    encode = eBool

    size = sBool

    decode = dBool

{- |
Char's are mapped to Word32 and then encoded.

For ascii characters, the encoding is standard ascii.

>>> test 'a'
(True,8,"01100001")

For unicode characters, the encoding is non standard.

>>> test 'È'
(True,16,"11001000 00000001")

>>> test '不'
(True,24,"10001101 10011100 00000001")

#ifndef ETA
>>> test "\x1F600"
(True,26,"11000000 01110110 00000011 10")
#endif
-}
instance Flat Char where
    size = sChar

    encode = eChar

    decode = dChar

{- |
>>> test (Nothing::Maybe Bool)
(True,1,"0")

>>> test (Just False::Maybe Bool)
(True,2,"10")
-}
instance Flat a => Flat (Maybe a)

{- |
>>> test (Left False::Either Bool ())
(True,2,"00")

>>> test (Right ()::Either Bool ())
(True,1,"1")
-}
instance (Flat a, Flat b) => Flat (Either a b)

{- |
>>> test (MkFixed 123 :: Fixed E0)
(True,16,"11110110 00000001")

>>> test (MkFixed 123 :: Fixed E0) == test (MkFixed 123 :: Fixed E2)
True
-}
instance Flat (Fixed a) where
    encode (MkFixed n) = encode n

    size (MkFixed n) = size n

    decode = MkFixed <$> decode

{- |
Word8 always take 8 bits.

>>> test (0::Word8)
(True,8,"00000000")

>>> test (255::Word8)
(True,8,"11111111")
-}
instance Flat Word8 where
    encode = eWord8

    decode = dWord8

    size = sWord8

{- |
Natural, Word, Word16, Word32 and Word64 are encoded as a non empty list of 7 bits chunks (least significant chunk first and most significant bit first in every chunk).

Words are always encoded in a whole number of bytes, as every chunk is 8 bits long (1 bit for the List constructor, plus 7 bits for the value).

The actual definition is:

@
Word64 ≡   Word64 Word

Word32 ≡   Word32 Word

Word16 ≡   Word16 Word

Word ≡   Word (LeastSignificantFirst (NonEmptyList (MostSignificantFirst Word7)))

LeastSignificantFirst a ≡   LeastSignificantFirst a

NonEmptyList a ≡   Elem a
                 | Cons a (NonEmptyList a)

MostSignificantFirst a ≡   MostSignificantFirst a

Word7 ≡   V0
        | V1
        | V2
        ...
        | V127
@

Values between as 0 and 127 fit in a single byte.

127 (0b1111111) is represented as Elem V127 and encoded as: Elem=0 127=1111111

>>> test (127::Word)
(True,8,"01111111")

254 (0b11111110) is represented as Cons V126 (Elem V1) (254=128+126) and encoded as: Cons=1 V126=1111110 (Elem=0 V1=0000001):

>>> test (254::Word)
(True,16,"11111110 00000001")

Another example, 32768 (Ob1000000000000000 = 0000010 0000000 0000000):

>>> test (32768::Word32)
(True,24,"10000000 10000000 00000010")

As this is a variable length encoding, values are encoded in the same way, whatever their type:

>>> all (test (3::Word) ==) [test (3::Word16),test (3::Word32),test (3::Word64)]
True
-}
instance Flat Word where
    size = sWord

    encode = eWord

    decode = dWord

{- |
Naturals are encoded just as the fixed size Words.

>>> test (0::Natural)
(True,8,"00000000")

>>> test (2^120::Natural)
(True,144,"10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 00000010")
-}
instance Flat Natural where
    size = sNatural

    encode = eNatural

    decode = dNatural

instance Flat Word16 where
    encode = eWord16

    decode = dWord16

    size = sWord16

instance Flat Word32 where
    encode = eWord32

    decode = dWord32

    size = sWord32

instance Flat Word64 where
    encode = eWord64

    decode = dWord64

    size = sWord64

{- |
Integer, Int, Int16, Int32 and Int64 are defined as the <https://developers.google.com/protocol-buffers/docs/encoding#signed-integers ZigZag> encoded version of the equivalent unsigned Word:

@
Int   ≡  Int   (ZigZag Word)

Int64 ≡  Int64 (ZigZag Word64)

Int32 ≡  Int32 (ZigZag Word32)

Int16 ≡  Int16 (ZigZag Word16)

Int8  ≡  Int8  (ZigZag Word8)

ZigZag a ≡ ZigZag a
@

ZigZag encoding alternates between positive and negative numbers, so that numbers whose absolute value is small can be encoded efficiently:

>>> test (0::Int)
(True,8,"00000000")

>>> test (-1::Int)
(True,8,"00000001")

>>> test (1::Int)
(True,8,"00000010")

>>> test (-2::Int)
(True,8,"00000011")

>>> test (2::Int)
(True,8,"00000100")
-}
instance Flat Int where
    size = sInt

    encode = eInt

    decode = dInt

{- |
Integers are encoded just as the fixed size Ints.

>>> test (0::Integer)
(True,8,"00000000")

>>> test (-1::Integer)
(True,8,"00000001")

>>> test (1::Integer)
(True,8,"00000010")

>>> test (-(2^4)::Integer)
(True,8,"00011111")

>>> test (2^4::Integer)
(True,8,"00100000")

>>> test (-(2^120)::Integer)
(True,144,"11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000011")

>>> test (2^120::Integer)
(True,144,"10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 00000100")
-}
instance Flat Integer where
    size = sInteger

    encode = eInteger

    decode = dInteger

{- |
>>> test (0::Int8)
(True,8,"00000000")

>>> test (127::Int8)
(True,8,"11111110")

>>> test (-128::Int8)
(True,8,"11111111")
-}
instance Flat Int8 where
    encode = eInt8

    decode = dInt8

    size = sInt8

{- |
>>> test (0::Int16)
(True,8,"00000000")

>>> test (1::Int16)
(True,8,"00000010")

>>> test (-1::Int16)
(True,8,"00000001")

>>> test (minBound::Int16)
(True,24,"11111111 11111111 00000011")

equivalent to 0b1111111111111111

>>> test (maxBound::Int16)
(True,24,"11111110 11111111 00000011")

equivalent to 0b1111111111111110
-}
instance Flat Int16 where
    size = sInt16

    encode = eInt16

    decode = dInt16

{- |
>>> test (0::Int32)
(True,8,"00000000")

>>> test (minBound::Int32)
(True,40,"11111111 11111111 11111111 11111111 00001111")

>>> test (maxBound::Int32)
(True,40,"11111110 11111111 11111111 11111111 00001111")
-}
instance Flat Int32 where
    size = sInt32

    encode = eInt32

    decode = dInt32

{- |
>>> test (0::Int64)
(True,8,"00000000")

>>> test (minBound::Int64)
(True,80,"11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000001")

>>> test (maxBound::Int64)
(True,80,"11111110 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000001")
-}
instance Flat Int64 where
    size = sInt64

    encode = eInt64

    decode = dInt64

{- |
Floats are encoded as standard IEEE binary32 values:

@
IEEE_754_binary32 ≡ IEEE_754_binary32 {sign :: Sign,
                                        exponent :: MostSignificantFirst Bits8,
                                        fraction :: MostSignificantFirst Bits23}
@

>>> test (0::Float)
(True,32,"00000000 00000000 00000000 00000000")

>>> test (1.4012984643E-45::Float)
(True,32,"00000000 00000000 00000000 00000001")

>>> test (1.1754942107E-38::Float)
(True,32,"00000000 01111111 11111111 11111111")
-}
instance Flat Float where
    size = sFloat

    encode = eFloat

    decode = dFloat

{- |
Doubles are encoded as standard IEEE binary64 values:

@
IEEE_754_binary64 ≡ IEEE_754_binary64 {sign :: Sign,
                                        exponent :: MostSignificantFirst Bits11,
                                        fraction :: MostSignificantFirst Bits52}
@
-}
instance Flat Double where
    size = sDouble

    encode = eDouble

    decode = dDouble

{- |
>>> test (4 :+ 2 :: Complex Word8)
(True,16,"00000100 00000010")
-}
instance Flat a => Flat (Complex a)

{- |
Ratios are encoded as tuples of (numerator,denominator)

>>> test (3%4::Ratio Word8)
(True,16,"00000011 00000100")
-}
instance (Integral a, Flat a) => Flat (Ratio a) where
    size a = size (numerator a, denominator a)

    encode a = encode (numerator a, denominator a)

    -- decode = uncurry (%) <$> decode
    decode = liftM2 (%) decode decode

{- |
>>> test ([]::[Bool])
(True,1,"0")

>>> test [False,False]
(True,5,"10100")

This instance and other similar ones are declared as @OVERLAPPABLE@, because for better encoding/decoding
performance it can be useful to declare instances of concrete types, such as @[Char]@ (not provided out of the box).
-}
instance {-# OVERLAPPABLE #-} Flat a => Flat [a]

{-
>>> import Weigh
>>> flat [1..10::Int]
-}

-- Generic list instance (stack overflows with ETA, see https://github.com/typelead/eta/issues/901)
-- where
--size [] n = n+1
--size (h:t) n = trampoline size t (trampoline size h (n+1))
-- size = sizeListWith size -- foldl' (\n e -> ) n
-- encode = error "BAD"
-- encode = trampoline . encodeListWith encode
-- decode = decodeListWith decode
-- sizeListWith siz l n = foldl' (\n e -> 1 + n + siz e 0) n l
-- #ifdef ETA_VERSION
-- import Data.Function(trampoline)
-- import GHC.IO(trampolineIO)
-- #else
-- trampoline = id
-- trampolineIO = id
-- #endif

-- #if MIN_VERSION_base(4,9,0)

{- |
>>> test (B.fromList [True])
(True,2,"10")

>>> test (B.fromList [False,False])
(True,4,"0100")
-}
instance {-# OVERLAPPABLE #-} Flat a => Flat (B.NonEmpty a)

-- #endif

{- |
Tuples are supported up to 7 elements.

>>> test (False,())
(True,1,"0")

>>> test ((),())
(True,0,"")

"7 elements tuples ought to be enough for anybody" (Bill Gates - apocryphal)

>>> test (False,True,True,True,False,True,True)
(True,7,"0111011")

tst (1::Int,"2","3","4","5","6","7","8")
...error
-}

-- Not sure if these should be OVERLAPPABLE
instance {-# OVERLAPPABLE #-} (Flat a, Flat b) => Flat (a, b)

instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c) => Flat (a, b, c)

instance
    {-# OVERLAPPABLE #-}
    (Flat a, Flat b, Flat c, Flat d) =>
    Flat (a, b, c, d)

instance
    {-# OVERLAPPABLE #-}
    (Flat a, Flat b, Flat c, Flat d, Flat e) =>
    Flat (a, b, c, d, e)

instance
    {-# OVERLAPPABLE #-}
    (Flat a, Flat b, Flat c, Flat d, Flat e, Flat f) =>
    Flat (a, b, c, d, e, f)

instance
    {-# OVERLAPPABLE #-}
    ( Flat a
    , Flat b
    , Flat c
    , Flat d
    , Flat e
    , Flat f
    , Flat g
    ) =>
    Flat (a, b, c, d, e, f, g)


{-# LANGUAGE AllowAmbiguousTypes, FlexibleContexts, MagicHash #-}

-- | Utility functions for type-safe PPCA
-- This module contains mostly redefined functions for DimMatrix wrapper
-- around the REPA matrix
module GPLVM.TypeSafe.Util
  ( cholM
  , deleteColumnsM
  , deleteRowsM
  , detSM
  , diagM
  , eigSHM
  , emptyM
  , extendX
  , extendY
  , foldAllSM
  , getColumn
  , getFirstColumns
  , getRow
  , invSM
  , makeLessThenNat
  , mapDiagonalM
  , mapMM
  , meanColumnM
  , meanColumnWithNanM
  , meanCovSM
  , mulM
  , pinvSM
  , solveM
  , substractMeanM
  , sumAllSM
  , sumListMatricesM
  , toListM
  , trace2SM
  , transposeM
  , withMat
  , withVec
  , vecToMat
  , (+^^)
  , (^++^)
  , (-^^)
  , (*^^)
  , (^!^)
  , Decisions
  ) where

import Universum hiding (All, Any, Nat, One, Vector,
                         map, toList, transpose,
                         (%~), (++))

import GPLVM.Types
import GPLVM.TypeSafe.Types
import GPLVM.Util

import Data.Array.Repa
import Numeric.LinearAlgebra.Repa hiding (Matrix, Vector, diag)

import Data.Singletons.Decide (Decision(..))
import Data.Type.Natural hiding (Z)

-- | Creates new Matrix with dimensions in its type and passes it to continuation.
-- Also creates SinI instances for dimensions
withMat
  :: Matrix D Double
  -> (forall (x :: Nat) (y :: Nat). (SingI y, SingI x) => DimMatrix D x y Double -> k)
  -> k
withMat m f =
    let (Z  :.  y  :.  x) = extent m
    in
    case toSing (intToNat y) of
      SomeSing (sy :: Sing m) -> withSingI sy $
        case toSing (intToNat x) of
          SomeSing (sx :: Sing n) -> withSingI sx $ f (DimMatrix @D @m @n m)

-- | Vector cousin of withMat
withVec
  :: Vector D a
  -> (forall (n :: Nat). SingI n => DimVector D n a -> k)
  -> k
withVec vec f =
  case toSing (intToNat n) of
    SomeSing (sy :: Sing m) -> withSingI sy $ f (DimVector @D @m vec)
  where
    (Z :. n) = extent vec

vecToMat
  :: forall (n :: Nat) a.
  SingI n
  => DimVector D n a
  -> DimMatrix D n One a
vecToMat (DimVector vec) =
  DimMatrix $
  fromFunction (Z :. dim :. 1) (\(Z :. a :. b) -> index vec (Z :. a))
  where
    dim = natToInt $ demote @n :: Int

-- | Creates type-level number which is less then given Nat type
makeLessThenNat :: forall (max :: Nat). (SingI max) => Int -> LessThen max
makeLessThenNat i =
  case toSing (intToNat i) of
    (SomeSing (tt:: Sing (uu :: Nat))) ->
          case (tt %< (Sing :: Sing max)) of
            (Proved LS) -> withSingI tt $ Less (Proxy @uu)
            (Disproved _) -> error "the first number is not less then given type-level number"

-- | Creates empty column with desired number of rows
emptyM
  :: forall y x. (SingI y, SingI x) => (x ~ Zero)
  => DimMatrix D y x Double
emptyM =
  let x = fromIntegral $ toNatural (sing :: Sing x)
      y = fromIntegral $ toNatural (sing :: Sing y)
  in DimMatrix (delay  $ fromListUnboxed (Z  :.  y  :.  x) []) :: DimMatrix D y x Double

-- | Returns the column with given index

getColumn
  :: forall n x y. (((n <= x) ~ 'True), SingI n)
  => DimMatrix D y x Double
  -> DimMatrix D y One Double
getColumn (DimMatrix m) =
  let i = (fromIntegral $ toNatural (Sing :: Sing n)) :: Int
  in DimMatrix $ extend (Any   :.  (1 :: Int)) $ slice m (Any :.  i)

-- | Replicates the given column
extendX :: forall n y. (SingI n)
        => DimMatrix D y One Double
        -> DimMatrix D y n Double
extendX (DimMatrix m) =
  let n = natToInt $ fromSing (Sing :: Sing n) :: Int
  in DimMatrix $ (extend (Any :. n) $ slice m (Any   :.  (0 :: Int)))

-- | Replicates the given row
extendY :: forall n x. (SingI n)
        => DimMatrix D One x Double
        -> DimMatrix D n x Double
extendY (DimMatrix m) =
  let n = natToInt $ fromSing (Sing :: Sing n) :: Int
  in DimMatrix $ (extend (Any :. n :. All) $ slice m (Any   :.  (0 :: Int) :. All))

-- | Returns the row with given index
getRow
  :: forall n x y. (((n <= y) ~ 'True), SingI n)
  => DimMatrix D y x Double
  -> DimMatrix D One x Double
getRow (DimMatrix m) =
  let j = (fromIntegral $ toNatural (Sing :: Sing n)) :: Int
  in DimMatrix $ extend (Any   :.  (1 :: Int)  :.  All ) $ slice m (Any   :.  (j :: Int)  :.  All )

-- | Column of the mean values along every dimension
meanColumnM
  :: forall y x. DimMatrix D y x Double
  -> DimMatrix D x One Double
meanColumnM (DimMatrix m) = DimMatrix $ extend (Any   :.  (1 :: Int)) $ meanColumn m

-- | Similar to "meanColumnM" but it does not take into account NaN values
meanColumnWithNanM
  :: forall y x. DimMatrix D y x Double
  -> DimMatrix D y One Double
meanColumnWithNanM (DimMatrix m) = DimMatrix $ extend (Any   :.  (1 :: Int)) $ meanColumnWithNan m

-- todo: make sure that length of deleting indexes is equal to toDel
-- of change the list to list with length in its type
deleteRowsM
  :: forall toDel y1 x1. DimMatrix D y1 x1 Double
  -> [Int]
  -> DimMatrix D (y1 - toDel) x1 Double
deleteRowsM (DimMatrix m) indexes = DimMatrix $
  deleteRows indexes m

deleteColumnsM
  :: forall toDel y1 x1. DimMatrix D y1 x1 Double
  -> [Int]
  -> DimMatrix D y1 (x1 - toDel) Double
deleteColumnsM (DimMatrix m) indexes = DimMatrix $
  deleteColumns indexes m

getFirstColumns
  :: forall toSave y1 x1. (SingI toSave, (toSave <= x1) ~ 'True)
  => DimMatrix D y1 x1 Double
  -> DimMatrix D y1 toSave Double
getFirstColumns (DimMatrix m@(ADelayed (Z :. y :. x) f)) =
  let desiredColumns = natToInt $ fromSing (Sing :: Sing toSave)
  in DimMatrix $ ADelayed (Z :. y :. desiredColumns) f

sumListMatricesM
  :: [DimMatrix D y x Double]
  -> DimMatrix D y x Double
sumListMatricesM [] = error "Empty matrices list"
sumListMatricesM mss = foldl1 (\ms m -> ms +^^ m) mss

-- == Numeric functions from REPA of Numeric.LinearAlgebra for DimMatrix ==

mulM
  :: forall y1 x1 y2 x2.
  (x1 ~ y2)
  => DimMatrix D y1 x1 Double
  -> DimMatrix D y2 x2 Double
  -> DimMatrix D y1 x2 Double
mulM (DimMatrix m1) (DimMatrix m2) = DimMatrix $ delay  $ m1 `mulS` m2

transposeM
  :: DimMatrix D y x Double
  -> DimMatrix D x y Double
transposeM (DimMatrix m) = DimMatrix $ transpose m

mapMM :: (Double -> Double)
  -> DimMatrix D y x Double
  -> DimMatrix D y x Double
mapMM f (DimMatrix m) =  DimMatrix $ map f m

mapDiagonalM :: (Double -> Double)
  -> DimMatrix D y x Double
  -> DimMatrix D y x Double
mapDiagonalM f (DimMatrix m) = DimMatrix $ mapDiagonal f m

invSM
  :: (y ~ x)
  => DimMatrix D y x Double
  -> DimMatrix D y x Double
invSM (DimMatrix m) = DimMatrix $ delay  $ invS m

pinvSM
  :: DimMatrix D y x Double
  -> DimMatrix D x y Double
pinvSM (DimMatrix m) = DimMatrix $ delay $ pinvS m

substractMeanM
  :: DimMatrix D y x Double
  -> DimMatrix D y x Double
substractMeanM (DimMatrix m) = DimMatrix $ substractMean m

(+^^) :: forall y1 x1 y2 x2.
  ( x1 ~ x2
  , y1 ~ y2
  )
  => DimMatrix D y1 x1 Double
  -> DimMatrix D y2 x2 Double
  -> DimMatrix D y2 x2 Double
(+^^) (DimMatrix m1) (DimMatrix m2) = DimMatrix $ m1 +^ m2

(^++^) :: forall y1 x1 y2 x2.
  ( y1 ~ y2
  )
  => DimMatrix D y1 x1 Double
  -> DimMatrix D y2 x2 Double
  -> DimMatrix D y2 (x1 :+: x2) Double
(^++^) (DimMatrix m1) (DimMatrix m2) = DimMatrix $ m1 ++ m2

(-^^) :: forall y1 x1 y2 x2.
  ( x1 ~ x2
  , y1 ~ y2
  )
  => DimMatrix D y1 x1 Double
  -> DimMatrix D y2 x2 Double
  -> DimMatrix D y2 x2 Double
(-^^) (DimMatrix m1) (DimMatrix m2) = DimMatrix $ m1 -^ m2

(*^^) :: forall y1 x1 y2 x2.
  ( x1 ~ x2
  , y1 ~ y2
  )
  => DimMatrix D y1 x1 Double
  -> DimMatrix D y2 x2 Double
  -> DimMatrix D y2 x2 Double
(*^^) (DimMatrix m1) (DimMatrix m2) = DimMatrix $ m1 *^ m2

(^!^) :: forall y x. DimMatrix D y x Double
      -> (LessThen y, LessThen x)
      -> Double
(^!^) (DimMatrix m) ((Less (Proxy :: Proxy y1)), (Less (Proxy :: Proxy x1))) =
  let y1 = natToInt $ fromSing (Sing :: Sing y1)
      x1 = natToInt $ fromSing (Sing :: Sing x1)
  in m ! (Z :. y1 :. x1)

cholM
  :: DimMatrix D y x Double
  -> DimMatrix D y x Double
cholM (DimMatrix m) = DimMatrix $ delay  $ chol $ trustSym $ computeS m

meanCovSM
  :: DimMatrix D y x Double
  -> (DimMatrix D One x Double, DimMatrix D x x Double)
meanCovSM (DimMatrix m) =
  let (meanVec, covMatrix) = meanCovS m
  in ((DimMatrix $ extend (Any  :. (1 :: Int) :. All) meanVec), DimMatrix $ delay $ unSym covMatrix)

solveM
  :: forall x1 y1 x2 y2.
  ( y1 ~ y2
  , x1 ~ y2
  )
  => DimMatrix D y1 x1 Double
  -> DimMatrix D y2 x2 Double
  -> DimMatrix D y1 x2 Double
solveM (DimMatrix m1) (DimMatrix m2) = DimMatrix $ delay $ m1 `solveS` m2

sumAllSM
  :: DimMatrix D y x Double
  -> Double
sumAllSM (DimMatrix m) = sumAllS m

foldAllSM
  :: (Double -> Double -> Double)
  -> Double
  -> DimMatrix D y x Double
  -> Double
foldAllSM f initValue (DimMatrix m) = foldAllS f initValue m

detSM
  :: DimMatrix D y x Double
  -> Double
detSM (DimMatrix m) = detS m

eigSHM
  :: (x ~ y, y1 ~ x) => DimMatrix D y x Double
  -> (DimMatrix D y1 One Double, DimMatrix D y x Double)
eigSHM (DimMatrix m) =
  let hermM = trustSymS m
      (eigenVals, eigenVecs) = eigSH hermM
  in ((DimMatrix $ extend (Any   :.  (1 :: Int)) eigenVals), DimMatrix $ delay eigenVecs)

diagM
  :: forall x y. (y ~ x)
  => DimMatrix D y x Double
  -> DimMatrix D y One Double
diagM (DimMatrix m) = DimMatrix $ diag m

trace2SM
  :: DimMatrix D y x Double
  -> Double
trace2SM (DimMatrix m) = trace2S $ computeS m

toListM
  :: DimMatrix D x1 y1 Double
  -> [Double]
toListM (DimMatrix m) = toList m

-- | this type family is introduced as a syntax-sugar for multiple decisions
type family Decisions k :: Type

type instance Decisions (a, b, c) = (Decision a, Decision b, Decision c)


module Prelude
  ( module P
  ) where

import Data.Tuple as P (fst,snd)
import Data.String as P (String)
import GHC.Show as P (Show(..))
import Data.Int as P (Int)
import Data.Bool as P (Bool(..),not)
import Data.Monoid as P (Monoid(..))
import Data.Semigroup as P (Semigroup(..))
import Data.Complex as P (Complex(..))
import Data.Functor as P (Functor(..))
import Data.Semiring as P (Semiring(..), Ring(..), (+), (*), (-))
import Control.Monad as P (Monad(..), (=<<))
import Control.Applicative as P (Applicative(..))
import Data.Eq as P (Eq(..))
import Data.Ord as P (Ord(..))
import GHC.Base as P (Double)
import Data.Function as P (($),(.),(&),id,flip)
import Data.Map as P (Map)
import GHC.Float as P (Floating(..))
import GHC.Real as P (fromIntegral, (/))


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Lisp (Number(..), SourceRange(..), Lisp(..), parseLisp,
                  parseLispFile, parseLispExpr, showLispPos, CharParser,
                  lispParser) where
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Data.Text(Text)
import Control.Applicative hiding (some, many)
import Data.Ratio
import Data.Char
import Control.Monad
import Data.Complex
import Data.Void
import Text.Megaparsec
import Text.Megaparsec.Char

data Number =
  Integer Integer |
  SingleFloat Float |
  DoubleFloat Double |
  NumRatio (Ratio Integer) |
  ComplexDouble (Complex Double)

replaceChar :: Char -> Char -> String -> String
replaceChar _ _ [] = []
replaceChar from to (c:cs)
  | c == from = to:replaceChar from to cs
  | otherwise = c:replaceChar from to cs

specialChars :: String
specialChars = "()#\"\\,'`| ;"

instance Show Number where
  show (Integer i) = show i
  show (SingleFloat f) = replaceChar 'e' 's' $ show f
  show (DoubleFloat f)
    | 'd' `elem` str = str
    | otherwise = str ++ "d0"
    where str = replaceChar 'e' 'd' $ show f
  show (NumRatio r) = show (numerator r) ++ "/" ++ show (denominator r)
  show (ComplexDouble (a :+ b)) = "#(" ++ show a ++ " " ++ show b ++ ")"

-- | A position range in the Lisp source file or string.
data SourceRange = SourceRange
  { sourceFrom :: SourcePos
  , sourceTo :: SourcePos
  }

instance Show SourceRange where
  show (SourceRange from to) =
    "<" ++ showPos from ++ "," ++ showPos to ++ ">"
    where showPos (SourcePos _ l c) =
            show (unPos l) ++ ":" ++ show (unPos c)

data Lisp =
  LispString Text SourceRange |
  LispNumber Number SourceRange |
  LispSymbol Text SourceRange |
  LispVector [Lisp] SourceRange |
  LispList [Lisp] SourceRange |
  LispDotList [Lisp] Lisp SourceRange

instance Show Lisp where
  show (LispString t _) = show t
  show (LispNumber n _) = show n
  show (LispSymbol s _)
    | Text.null s = "||"
    | Text.any (`elem` specialChars) s = '|': Text.unpack s ++ "|"
    | otherwise = Text.unpack s

  show (LispVector l _) =
    "#(" ++ unwords (map show l) ++ ")"
  show (LispList l _) = "(" ++ unwords (map show l) ++ ")"
  show (LispDotList l e _) =
    "(" ++ unwords (map show l) ++ " . " ++ show e ++ ")"

-- | show the lisp with position info
showLispPos :: Lisp -> String
showLispPos (LispString t p) = show t ++ show p
showLispPos (LispNumber n p) = show n ++ show p
showLispPos (LispSymbol s p)
  | Text.null s = "||" ++ show p
  | Text.any (`elem` specialChars) s = '|': Text.unpack s ++ "|" ++ show p
  | otherwise = Text.unpack s ++ show p
showLispPos (LispVector l p) =
  "#(" ++ unwords (map showLispPos l) ++ ")" ++ show p
showLispPos (LispList l p) = "(" ++ unwords (map showLispPos l) ++ ")" ++ show p
showLispPos (LispDotList l e p) =
  "(" ++ unwords (map showLispPos l) ++ " . " ++ showLispPos e ++ ")" ++ show p

instance Read Lisp where
  readsPrec _ input =
    case runParser' (whiteSpace >> withSourceRange lispExprP) $
         State input 0 (PosState input 0 (initialPos "read") (mkPos 0) []) [] of
      (_, Left _) -> []
      (rest, Right r) -> [(r, stateInput rest)]

dummyRange :: SourceRange
dummyRange = SourceRange (initialPos "dummy") (initialPos "dummy")

-- | A megaparsec parser that has characters as tokens.
type CharParser t a = (Stream t, Token t ~ Char)
                    => Parsec Void t a

-- | A megaparsec parser for lisp expressions
lispParser :: CharParser t Lisp
lispParser = withSourceRange lispExprP

-- | Parse a lisp file
parseLispFile :: String -> IO (Either (ParseErrorBundle Text Void) [Lisp])
parseLispFile file =
  runParser (many lispParser <* whiteSpace <* eof) file
  <$> Text.readFile file

-- | @parse source text@: parse the text into a list of lisp
-- expressions.  Source is used for the error messages, and in the
-- `SourceRanges`.
parseLisp :: String -> Text -> Either (ParseErrorBundle Text Void) [Lisp]
parseLisp = runParser (sepEndBy lispParser whiteSpace <* eof)

-- | parse a single expression
parseLispExpr :: String -> Text -> Either (ParseErrorBundle Text Void) Lisp
parseLispExpr = runParser lispParser

signP :: CharParser t String
signP = option "" $ ("" <$ char '+') <|> ("-" <$ char '-')

withSourceRange :: CharParser t (SourceRange -> a) -> CharParser t a
withSourceRange p = do
  startRange <- getSourcePos
  mkParser <- p
  endRange <- getSourcePos
  pure $ mkParser $ SourceRange startRange endRange

-- numbers not starting with #
numP :: CharParser t (SourceRange -> Lisp)
numP = label "number" $ do
  sign <- signP
  -- 'try' the dot, because it could be a single dot, and then we need
  -- to backtrack
  let decimalP :: CharParser t String
      decimalP = some digitChar

      -- number starting with number
      numNumP :: CharParser t (SourceRange -> Lisp)
      numNumP = do
        decimal <- decimalP
        choice [ ratioP decimal
               , try (floatP decimal)
               , do _ <- optional (char '.')
                    pure $ LispNumber $ Integer $ read (sign++decimal)
               ]

      ratioP :: String -> CharParser t (SourceRange -> Lisp)
      ratioP d = do
        _ <- char '/'
        denom <- decimalP
        pure $ LispNumber $ NumRatio $ read (sign++d) % read denom

      floatP :: String -> CharParser t (SourceRange -> Lisp)
      floatP d =
        exptP sign d "0"
        <|> do _ <- char '.'
               exptP sign d "0" <|> do
                 fract <- decimalP
                 exptP sign d fract <|>
                   do pure $ LispNumber $ DoubleFloat $
                        read (sign++d ++ "." ++ fract)
      dotNumP = do
        _ <- char '.'
        fract <- decimalP
        exptP sign "0" fract <|>
          pure (LispNumber $ DoubleFloat $ read $ sign++"0." ++ fract)

  (numNumP <|> try dotNumP) <* notFollowedBy identifierBlocksP

exptP :: String -> String -> String -> CharParser t (SourceRange -> Lisp)
exptP sign num fract = do
  -- e would be context dependend, but I am defaulting it to Double here
  e <- oneOf ("esd" :: String)
  eSign <- option '+' $ char '+' <|> char '-'
  expt <- some digitChar
  let toFloat :: (Read a, Num a) => a
      toFloat = read $ sign ++ num ++ "." ++ fract ++ "e" ++ eSign:expt
  pure $ LispNumber $ case e of
    's' -> SingleFloat toFloat
    _   -> DoubleFloat toFloat

quoteAnyChar :: CharParser t Char
quoteAnyChar = char '\\' >> anySingle

stringP :: CharParser t (SourceRange -> Lisp)
stringP =
  label "string" $ do
  str <- between (char '"') (char '"') $
         Text.pack <$> many (quoteAnyChar <|> noneOf ("\\\"" :: String))
  pure $ LispString str

identifierP :: CharParser t (SourceRange -> Lisp)
identifierP =
  label "identifier" $ do
  str <- fmap Text.pack $ (++) <$> (firstBlock <|> quotedBlockP) <*> moreBlocksP
  if str == "."
    then fail ("dot" :: String)
    else pure $ LispSymbol str

  where firstBlock :: CharParser t String
        firstBlock = (:) <$> (notSpecial <|> quoteAnyChar) <*> many blockCharP

        moreBlocksP :: CharParser t String
        moreBlocksP = concat <$> many (some blockCharP <|> quotedBlockP)

quotedBlockP :: CharParser t String
quotedBlockP = between (char '|') (char '|') $
               many (noneOf ("|\\" :: String) <|> quoteAnyChar)

notSpecial :: CharParser t Char
notSpecial = toUpper <$> noneOf specialChars

blockCharP :: CharParser t Char
blockCharP = notSpecial <|> char '#' <|> char '`' <|> quoteAnyChar

identifierBlocksP :: CharParser t String
identifierBlocksP = concat <$> some (some blockCharP <|> quotedBlockP)

lispExprP :: CharParser t (SourceRange -> Lisp)
lispExprP = choice [ stringP
                   , listP
                   , try numP
                   , try identifierP
                   , quoteP
                   , readersP
                   ]

listP :: CharParser t (SourceRange -> Lisp)
listP =
  label "list" $
  between (char '(') (char ')') $ do
  elems <- lispParser `sepEndBy` whiteSpace
  dotElem <- optional $
    char '.' *> whiteSpace *>
    lispParser <* whiteSpace
  pure $ case dotElem of
    Nothing -> LispList elems
    Just (LispList l _) ->  LispList $ elems ++ l
    Just (LispDotList l el _) -> LispDotList (elems ++ l) el
    Just el -> LispDotList elems el

commentP :: CharParser t ()
commentP =
  label "comment" $
  char ';' >>
  many (noneOf ("\r\n" :: String)) >>
  (void eol <|> eof)

whiteSpace :: CharParser t ()
whiteSpace = () <$ many (space1 <|> commentP)

quoteSymbol :: String -> Text -> CharParser t (SourceRange -> Lisp)
quoteSymbol symbol quoteExpansion  = do
  foldMap (void <$> char) symbol
  pure $ \(SourceRange from _) ->
    LispSymbol quoteExpansion $ SourceRange from $
    from {sourceColumn = mkPos $ length symbol + unPos (sourceColumn from)}

quoteP :: CharParser t (SourceRange -> Lisp)
quoteP = do
  quote <- (quoteSymbol "'" "quote" <|>
            try (quoteSymbol ",@" "unquote-splicing") <|>
            quoteSymbol "," "unquote" <|>
            quoteSymbol "`" "quasiquote")
           <* whiteSpace
  expr <- lispParser
  pure $ \range -> LispList [quote range, expr] range

readersP :: CharParser t (SourceRange -> Lisp)
readersP = do
  _ <- char '#'
  (vectorReaderP <|> complexReaderP) <|>
    (octalReaderP <|> hexReaderP <|> binaryReaderP)
    <* notFollowedBy identifierBlocksP

vectorReaderP :: CharParser t (SourceRange -> Lisp)
vectorReaderP =
  between (char '(') (char ')') $
  LispVector <$> (lispParser `sepEndBy` whiteSpace)

octalReaderP :: CharParser t (SourceRange -> Lisp)
octalReaderP = do
  _ <- char 'o' <|> char 'O'
  sign <- signP
  digits <- some octDigitChar
  pure $ LispNumber $ Integer $ read $ sign ++ "0o" ++ digits

binaryReaderP :: CharParser t (SourceRange -> Lisp)
binaryReaderP = do
  _ <- char 'b' <|> char 'B'
  sign <- signP
  digits <- some binDigitChar
  let digitSum = foldl (\tot dig -> tot*2 + if dig == '1' then 1 else 0)
                 0 digits
      signedSum | sign == "-" = negate digitSum
                | otherwise = digitSum
  pure $ LispNumber $ Integer signedSum

hexReaderP :: CharParser t (SourceRange -> Lisp)
hexReaderP = do
  _ <- char 'x' <|> char 'X'
  sign <- signP
  digits <- some hexDigitChar
  pure $ LispNumber $ Integer $ read $ sign ++ "0x" ++ digits

convertToDouble :: Number -> Double
convertToDouble l = case l of
  Integer i -> realToFrac i
  SingleFloat f -> realToFrac f
  DoubleFloat f -> realToFrac f
  NumRatio r -> realToFrac r
  ComplexDouble _ -> error "convertToDouble"

complexReaderP :: CharParser t (SourceRange -> Lisp)
complexReaderP = do
  _ <- char 'c' <|> char 'C'
  between (char '(') (char ')') $ do
    _ <- many whiteSpace
    LispNumber rl _ <- ($ dummyRange) <$> numP
    _ <- some whiteSpace
    LispNumber imag _ <- ($ dummyRange) <$> numP
    _ <- many whiteSpace
    pure $ LispNumber $ ComplexDouble $
      convertToDouble rl :+ convertToDouble imag


{-# LANGUAGE CPP #-}
-- |
-- Module: Optics.At.Core
-- Description: Optics for 'Map' and 'Set'-like containers.
--
-- This module provides optics for 'Map' and 'Set'-like containers, including an
-- 'AffineTraversal' to traverse a key in a map or an element of a sequence:
--
-- >>> preview (ix 1) ['a','b','c']
-- Just 'b'
--
-- a 'Lens' to get, set or delete a key in a map:
--
-- >>> set (at 0) (Just 'b') (Map.fromList [(0, 'a')])
-- fromList [(0,'b')]
--
-- and a 'Lens' to insert or remove an element of a set:
--
-- >>> IntSet.fromList [1,2,3,4] & contains 3 .~ False
-- fromList [1,2,4]
--
-- The @Optics.At@ module from @optics-extra@ provides additional instances of
-- the classes defined here.
--
module Optics.At.Core
  (
    -- * Type families
    Index
  , IxValue

    -- * Ixed
  , Ixed(..)
  , ixAt

    -- * At
  , At(..)
  , at'
  , sans

  -- * Contains
  , Contains(..)
  ) where

import Data.Array.IArray as Array
import Data.Array.Unboxed
import Data.Complex
import Data.Functor.Identity
import Data.IntMap as IntMap
import Data.IntSet as IntSet
import Data.List.NonEmpty as NonEmpty
import Data.Map as Map
import Data.Sequence as Seq
import Data.Set as Set
import Data.Tree

import Data.Maybe.Optics
import Optics.AffineTraversal
import Optics.Iso
import Optics.Lens
import Optics.Optic
import Optics.Setter

-- | Type family that takes a key-value container type and returns the type of
-- keys (indices) into the container, for example @'Index' ('Map' k a) ~ k@.
-- This is shared by 'Ixed', 'At' and 'Contains'.
type family Index (s :: *) :: *
type instance Index (e -> a) = e
type instance Index IntSet = Int
type instance Index (Set a) = a
type instance Index [a] = Int
type instance Index (NonEmpty a) = Int
type instance Index (Seq a) = Int
type instance Index (a,b) = Int
type instance Index (a,b,c) = Int
type instance Index (a,b,c,d) = Int
type instance Index (a,b,c,d,e) = Int
type instance Index (a,b,c,d,e,f) = Int
type instance Index (a,b,c,d,e,f,g) = Int
type instance Index (a,b,c,d,e,f,g,h) = Int
type instance Index (a,b,c,d,e,f,g,h,i) = Int
type instance Index (IntMap a) = Int
type instance Index (Map k a) = k
type instance Index (Array.Array i e) = i
type instance Index (UArray i e) = i
type instance Index (Complex a) = Int
type instance Index (Identity a) = ()
type instance Index (Maybe a) = ()
type instance Index (Tree a) = [Int]

-- | This class provides a simple 'Lens' that lets you view (and modify)
-- information about whether or not a container contains a given 'Index'.
-- Instances are provided for 'Set'-like containers only.
class Contains m where
  -- |
  -- >>> IntSet.fromList [1,2,3,4] ^. contains 3
  -- True
  --
  -- >>> IntSet.fromList [1,2,3,4] ^. contains 5
  -- False
  --
  -- >>> IntSet.fromList [1,2,3,4] & contains 3 .~ False
  -- fromList [1,2,4]
  contains :: Index m -> Lens' m Bool

instance Contains IntSet where
  contains k = lensVL $ \f s -> f (IntSet.member k s) <&> \b ->
    if b then IntSet.insert k s else IntSet.delete k s
  {-# INLINE contains #-}

instance Ord a => Contains (Set a) where
  contains k = lensVL $ \f s -> f (Set.member k s) <&> \b ->
    if b then Set.insert k s else Set.delete k s
  {-# INLINE contains #-}

-- | Type family that takes a key-value container type and returns the type of
-- values stored in the container, for example @'IxValue' ('Map' k a) ~ a@. This
-- is shared by both 'Ixed' and 'At'.
type family IxValue (m :: *) :: *

-- | Provides a simple 'AffineTraversal' lets you traverse the value at a given
-- key in a 'Map' or element at an ordinal position in a list or 'Seq'.
class Ixed m where
  -- | /NB:/ Setting the value of this 'AffineTraversal' will only set the value
  -- in 'at' if it is already present.
  --
  -- If you want to be able to insert /missing/ values, you want 'at'.
  --
  -- >>> [1,2,3,4] & ix 2 %~ (*10)
  -- [1,2,30,4]
  --
  -- >>> "abcd" & ix 2 .~ 'e'
  -- "abed"
  --
  -- >>> "abcd" ^? ix 2
  -- Just 'c'
  --
  -- >>> [] ^? ix 2
  -- Nothing
  ix :: Index m -> AffineTraversal' m (IxValue m)
  default ix :: At m => Index m -> AffineTraversal' m (IxValue m)
  ix = ixAt
  {-# INLINE ix #-}

-- | A definition of 'ix' for types with an 'At' instance. This is the default
-- if you don't specify a definition for 'ix'.
ixAt :: At m => Index m -> AffineTraversal' m (IxValue m)
ixAt = \i -> at i % _Just
{-# INLINE ixAt #-}

type instance IxValue (e -> a) = a
instance Eq e => Ixed (e -> a) where
  ix e = atraversalVL $ \_ p f -> p (f e) <&> \a e' -> if e == e' then a else f e'
  {-# INLINE ix #-}

type instance IxValue (Maybe a) = a
instance Ixed (Maybe a) where
  ix () = castOptic @An_AffineTraversal _Just
  {-# INLINE ix #-}

type instance IxValue [a] = a
instance Ixed [a] where
  ix k = atraversalVL (ixListVL k)
  {-# INLINE ix #-}

type instance IxValue (NonEmpty a) = a
instance Ixed (NonEmpty a) where
  ix k = atraversalVL $ \point f xs0 ->
    if k < 0
    then point xs0
    else let go (a:|as) 0 = f a <&> (:|as)
             go (a:|as) i = (a:|) <$> ixListVL (i - 1) point f as
         in go xs0 k
  {-# INLINE ix #-}

type instance IxValue (Identity a) = a
instance Ixed (Identity a) where
  ix () = atraversalVL $ \_ f (Identity a) -> Identity <$> f a
  {-# INLINE ix #-}

type instance IxValue (Tree a) = a
instance Ixed (Tree a) where
  ix xs0 = atraversalVL $ \point f ->
    let go [] (Node a as) = f a <&> \a' -> Node a' as
        go (i:is) t@(Node a as)
          | i < 0     = point t
          | otherwise = Node a <$> ixListVL i point (go is) as
    in go xs0
  {-# INLINE ix #-}

type instance IxValue (Seq a) = a
instance Ixed (Seq a) where
  ix i = atraversalVL $ \point f m ->
    if 0 <= i && i < Seq.length m
    then f (Seq.index m i) <&> \a -> Seq.update i a m
    else point m
  {-# INLINE ix #-}

type instance IxValue (IntMap a) = a
-- Default implementation uses IntMap.alterF
instance Ixed (IntMap a)

type instance IxValue (Map k a) = a
-- Default implementation uses Map.alterF
instance Ord k => Ixed (Map k a)

type instance IxValue (Set k) = ()
instance Ord k => Ixed (Set k) where
  ix k = atraversalVL $ \point f m ->
    if Set.member k m
    then f () <&> \() -> Set.insert k m
    else point m
  {-# INLINE ix #-}

type instance IxValue IntSet = ()
instance Ixed IntSet where
  ix k = atraversalVL $ \point f m ->
    if IntSet.member k m
    then f () <&> \() -> IntSet.insert k m
    else point m
  {-# INLINE ix #-}

type instance IxValue (Array.Array i e) = e
-- |
-- @
-- arr 'Array.!' i ≡ arr 'Optics.Operators.^.' 'ix' i
-- arr '//' [(i,e)] ≡ 'ix' i 'Optics.Operators..~' e '$' arr
-- @
instance Ix i => Ixed (Array.Array i e) where
  ix i = atraversalVL $ \point f arr ->
    if inRange (bounds arr) i
    then f (arr Array.! i) <&> \e -> arr Array.// [(i,e)]
    else point arr
  {-# INLINE ix #-}

type instance IxValue (UArray i e) = e
-- |
-- @
-- arr 'Array.!' i ≡ arr 'Optics.Operators.^.' 'ix' i
-- arr '//' [(i,e)] ≡ 'ix' i 'Optics.Operators..~' e '$' arr
-- @
instance (IArray UArray e, Ix i) => Ixed (UArray i e) where
  ix i = atraversalVL $ \point f arr ->
    if inRange (bounds arr) i
    then f (arr Array.! i) <&> \e -> arr Array.// [(i,e)]
    else point arr
  {-# INLINE ix #-}

-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a) a@
type instance IxValue (a0, a2) = a0
instance (a0 ~ a1) => Ixed (a0, a1) where
  ix i = atraversalVL $ \point f ~s@(a0, a1) ->
    case i of
      0 -> (,a1) <$> f a0
      1 -> (a0,) <$> f a1
      _ -> point s

-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a) a@
type instance IxValue (a0, a1, a2) = a0
instance (a0 ~ a1, a0 ~ a2) => Ixed (a0, a1, a2) where
  ix i = atraversalVL $ \point f ~s@(a0, a1, a2) ->
    case i of
      0 -> (,a1,a2) <$> f a0
      1 -> (a0,,a2) <$> f a1
      2 -> (a0,a1,) <$> f a2
      _ -> point s

-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a, a) a@
type instance IxValue (a0, a1, a2, a3) = a0
instance (a0 ~ a1, a0 ~ a2, a0 ~ a3) => Ixed (a0, a1, a2, a3) where
  ix i = atraversalVL $ \point f ~s@(a0, a1, a2, a3) ->
    case i of
      0 -> (,a1,a2,a3) <$> f a0
      1 -> (a0,,a2,a3) <$> f a1
      2 -> (a0,a1,,a3) <$> f a2
      3 -> (a0,a1,a2,) <$> f a3
      _ -> point s

-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a, a, a) a@
type instance IxValue (a0, a1, a2, a3, a4) = a0
instance (a0 ~ a1, a0 ~ a2, a0 ~ a3, a0 ~ a4) => Ixed (a0, a1, a2, a3, a4) where
  ix i = atraversalVL $ \point f ~s@(a0, a1, a2, a3, a4) ->
    case i of
      0 -> (,a1,a2,a3,a4) <$> f a0
      1 -> (a0,,a2,a3,a4) <$> f a1
      2 -> (a0,a1,,a3,a4) <$> f a2
      3 -> (a0,a1,a2,,a4) <$> f a3
      4 -> (a0,a1,a2,a3,) <$> f a4
      _ -> point s

-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a, a, a, a) a@
type instance IxValue (a0, a1, a2, a3, a4, a5) = a0
instance
  (a0 ~ a1, a0 ~ a2, a0 ~ a3, a0 ~ a4, a0 ~ a5
  ) => Ixed (a0, a1, a2, a3, a4, a5) where
  ix i = atraversalVL $ \point f ~s@(a0, a1, a2, a3, a4, a5) ->
    case i of
      0 -> (,a1,a2,a3,a4,a5) <$> f a0
      1 -> (a0,,a2,a3,a4,a5) <$> f a1
      2 -> (a0,a1,,a3,a4,a5) <$> f a2
      3 -> (a0,a1,a2,,a4,a5) <$> f a3
      4 -> (a0,a1,a2,a3,,a5) <$> f a4
      5 -> (a0,a1,a2,a3,a4,) <$> f a5
      _ -> point s

-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a, a, a, a, a) a@
type instance IxValue (a0, a1, a2, a3, a4, a5, a6) = a0
instance
  (a0 ~ a1, a0 ~ a2, a0 ~ a3, a0 ~ a4, a0 ~ a5, a0 ~ a6
  ) => Ixed (a0, a1, a2, a3, a4, a5, a6) where
  ix i = atraversalVL $ \point f ~s@(a0, a1, a2, a3, a4, a5, a6) ->
    case i of
      0 -> (,a1,a2,a3,a4,a5,a6) <$> f a0
      1 -> (a0,,a2,a3,a4,a5,a6) <$> f a1
      2 -> (a0,a1,,a3,a4,a5,a6) <$> f a2
      3 -> (a0,a1,a2,,a4,a5,a6) <$> f a3
      4 -> (a0,a1,a2,a3,,a5,a6) <$> f a4
      5 -> (a0,a1,a2,a3,a4,,a6) <$> f a5
      6 -> (a0,a1,a2,a3,a4,a5,) <$> f a6
      _ -> point s

-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a, a, a, a, a, a) a@
type instance IxValue (a0, a1, a2, a3, a4, a5, a6, a7) = a0
instance
  (a0 ~ a1, a0 ~ a2, a0 ~ a3, a0 ~ a4, a0 ~ a5, a0 ~ a6, a0 ~ a7
  ) => Ixed (a0, a1, a2, a3, a4, a5, a6, a7) where
  ix i = atraversalVL $ \point f ~s@(a0, a1, a2, a3, a4, a5, a6, a7) ->
    case i of
      0 -> (,a1,a2,a3,a4,a5,a6,a7) <$> f a0
      1 -> (a0,,a2,a3,a4,a5,a6,a7) <$> f a1
      2 -> (a0,a1,,a3,a4,a5,a6,a7) <$> f a2
      3 -> (a0,a1,a2,,a4,a5,a6,a7) <$> f a3
      4 -> (a0,a1,a2,a3,,a5,a6,a7) <$> f a4
      5 -> (a0,a1,a2,a3,a4,,a6,a7) <$> f a5
      6 -> (a0,a1,a2,a3,a4,a5,,a7) <$> f a6
      7 -> (a0,a1,a2,a3,a4,a5,a6,) <$> f a7
      _ -> point s

-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a, a, a, a, a, a, a) a@
type instance IxValue (a0, a1, a2, a3, a4, a5, a6, a7, a8) = a0
instance
  (a0 ~ a1, a0 ~ a2, a0 ~ a3, a0 ~ a4, a0 ~ a5, a0 ~ a6, a0 ~ a7, a0 ~ a8
  ) => Ixed (a0, a1, a2, a3, a4, a5, a6, a7, a8) where
  ix i = atraversalVL $ \point f ~s@(a0, a1, a2, a3, a4, a5, a6, a7, a8) ->
    case i of
      0 -> (,a1,a2,a3,a4,a5,a6,a7,a8) <$> f a0
      1 -> (a0,,a2,a3,a4,a5,a6,a7,a8) <$> f a1
      2 -> (a0,a1,,a3,a4,a5,a6,a7,a8) <$> f a2
      3 -> (a0,a1,a2,,a4,a5,a6,a7,a8) <$> f a3
      4 -> (a0,a1,a2,a3,,a5,a6,a7,a8) <$> f a4
      5 -> (a0,a1,a2,a3,a4,,a6,a7,a8) <$> f a5
      6 -> (a0,a1,a2,a3,a4,a5,,a7,a8) <$> f a6
      7 -> (a0,a1,a2,a3,a4,a5,a6,,a8) <$> f a7
      8 -> (a0,a1,a2,a3,a4,a5,a6,a7,) <$> f a8
      _ -> point s

-- | 'At' provides a 'Lens' that can be used to read, write or delete the value
-- associated with a key in a 'Map'-like container on an ad hoc basis.
--
-- An instance of 'At' should satisfy:
--
-- @
-- 'ix' k ≡ 'at' k '%' '_Just'
-- @
class Ixed m => At m where
  -- |
  -- >>> Map.fromList [(1,"world")] ^. at 1
  -- Just "world"
  --
  -- >>> at 1 ?~ "hello" $ Map.empty
  -- fromList [(1,"hello")]
  --
  -- /Note:/ Usage of this function might introduce space leaks if you're not
  -- careful to make sure that values put inside the 'Just' constructor are
  -- evaluated. To force the values and avoid such leaks, use 'at'' instead.
  --
  -- /Note:/ 'Map'-like containers form a reasonable instance, but not
  -- 'Array'-like ones, where you cannot satisfy the 'Lens' laws.
  at :: Index m -> Lens' m (Maybe (IxValue m))

-- | Version of 'at' strict in the value inside the `Just` constructor.
--
-- Example:
--
-- >>> (at () .~ Just (error "oops") $ Nothing) `seq` ()
-- ()
--
-- >>> (at' () .~ Just (error "oops") $ Nothing) `seq` ()
-- *** Exception: oops
-- ...
--
-- >>> view (at ()) (Just $ error "oops") `seq` ()
-- ()
--
-- >>> view (at' ()) (Just $ error "oops") `seq` ()
-- *** Exception: oops
-- ...
--
-- It also works as expected for other data structures:
--
-- >>> (at 1 .~ Just (error "oops") $ Map.empty) `seq` ()
-- ()
--
-- >>> (at' 1 .~ Just (error "oops") $ Map.empty) `seq` ()
-- *** Exception: oops
-- ...
at' :: At m => Index m -> Lens' m (Maybe (IxValue m))
at' k = at k % iso f f
  where
    f = \case
      Just !x -> Just x
      Nothing -> Nothing
{-# INLINE at' #-}

-- | Delete the value associated with a key in a 'Map'-like container
--
-- @
-- 'sans' k = 'at' k 'Optics.Operators..~' Nothing
-- @
sans :: At m => Index m -> m -> m
sans k = set (at k) Nothing
{-# INLINE sans #-}

instance At (Maybe a) where
  at () = lensVL id
  {-# INLINE at #-}

instance At (IntMap a) where
#if MIN_VERSION_containers(0,5,8)
  at k = lensVL $ \f -> IntMap.alterF f k
#else
  at k = lensVL $ \f m ->
    let mv = IntMap.lookup k m
    in f mv <&> \r -> case r of
      Nothing -> maybe m (const (IntMap.delete k m)) mv
      Just v' -> IntMap.insert k v' m
#endif
  {-# INLINE at #-}

instance Ord k => At (Map k a) where
#if MIN_VERSION_containers(0,5,8)
  at k = lensVL $ \f -> Map.alterF f k
#else
  at k = lensVL $ \f m ->
    let mv = Map.lookup k m
    in f mv <&> \r -> case r of
      Nothing -> maybe m (const (Map.delete k m)) mv
      Just v' -> Map.insert k v' m
#endif
  {-# INLINE at #-}

instance At IntSet where
  at k = lensVL $ \f m ->
    let mv = if IntSet.member k m
             then Just ()
             else Nothing
    in f mv <&> \r -> case r of
      Nothing -> maybe m (const (IntSet.delete k m)) mv
      Just () -> IntSet.insert k m
  {-# INLINE at #-}

instance Ord k => At (Set k) where
  at k = lensVL $ \f m ->
    let mv = if Set.member k m
             then Just ()
             else Nothing
    in f mv <&> \r -> case r of
      Nothing -> maybe m (const (Set.delete k m)) mv
      Just () -> Set.insert k m
  {-# INLINE at #-}

----------------------------------------
-- Internal

ixListVL :: Int -> AffineTraversalVL' [a] a
ixListVL k point f xs0 =
  if k < 0
  then point xs0
  else let go [] _ = point []
           go (a:as) 0 = f a <&> (:as)
           go (a:as) i = (a:) <$> (go as $! i - 1)
       in go xs0 k
{-# INLINE ixListVL #-}

-- $setup
-- >>> import Optics.Core


{-# LANGUAGE TypeApplications #-}
module ArrayFire.UtilSpec where

import qualified ArrayFire        as A

import           Data.Complex
import           Data.Int
import           Data.Proxy
import           Data.Word
import           Foreign.C.Types
import           System.Directory
import           Test.Hspec

spec :: Spec
spec =
  describe "Util spec" $ do
    it "Should get size of" $ do
      A.getSizeOf (Proxy @ Int) `shouldBe` 8
      A.getSizeOf (Proxy @ Int64) `shouldBe` 8
      A.getSizeOf (Proxy @ Int32) `shouldBe` 4
      A.getSizeOf (Proxy @ Int16) `shouldBe` 2
      A.getSizeOf (Proxy @ Word) `shouldBe` 8
      A.getSizeOf (Proxy @ Word64) `shouldBe` 8
      A.getSizeOf (Proxy @ Word32) `shouldBe` 4
      A.getSizeOf (Proxy @ Word16) `shouldBe` 2
      A.getSizeOf (Proxy @ Word8) `shouldBe` 1
      A.getSizeOf (Proxy @ CBool) `shouldBe` 1
      A.getSizeOf (Proxy @ Double) `shouldBe` 8
      A.getSizeOf (Proxy @ Float) `shouldBe` 4
      A.getSizeOf (Proxy @ (Complex Float)) `shouldBe` 8
      A.getSizeOf (Proxy @ (Complex Double)) `shouldBe` 16
    it "Should get version" $ do
      x <- A.getVersion
      x `shouldBe` (3,6,4)
    it "Should get revision" $ do
      x <- A.getRevision
      x `shouldSatisfy` (not . null)
    it "Should save / read array" $ do
      let arr = A.constant @Int [1,1,1,1] 10
      idx <- A.saveArray "key" arr "file.array" False
      doesFileExist "file.array" `shouldReturn` True
      (`shouldBe` idx) =<< A.readArrayKeyCheck "file.array" "key"
      (`shouldBe` arr) =<< A.readArrayIndex "file.array" idx
      (`shouldBe` arr) =<< A.readArrayKey "file.array" "key"
      removeFile "file.array"


module Lambda.Types where

-- Global Imports
import Data.Ratio
import Data.Complex
import Control.Monad.Except
import Text.ParserCombinators.Parsec.Error
import Data.IORef
import System.IO
import qualified Data.Map.Strict as Map

data LispVal
  = Atom String
  | List [LispVal]
  | DottedList [LispVal] LispVal
  | Vector [LispVal]
  | Number Integer
  | Float Double
  | Ratio Rational
  | Complex (Complex Double)
  | String String
  | Bool Bool
  | Character Char
  | IOFunc ([LispVal] -> IOThrowsError LispVal)
  | Port Handle
  | PrimitiveFunc ([LispVal] -> ThrowsError LispVal)
  | Func { params  :: [String]
         , vararg  :: (Maybe String)
         , body    :: [LispVal]
         , closure :: Env
         }

instance Show LispVal where show = showVal
-- This feels like a hack...not sure why it is working or if it truly is
instance Eq LispVal where (==) = (==)

showVal :: LispVal -> String
showVal (String contents)      = "\"" ++ contents ++ "\""
showVal (Atom name)            = name
showVal (Number contents)      = show contents
showVal (Bool True)            = "#t"
showVal (Bool False)           = "#f"
showVal (List contents)        = "(" ++ unwordsList contents ++ ")"
showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"
showVal (Vector contents)      = "(" ++ unwordsList contents ++ ")"
showVal (IOFunc _)             = "<IO primitive>"
showVal (Port _)               = "<IO port>"
showVal (PrimitiveFunc _)      = "<primitive>"
showVal (Func {params = args ,
vararg = varargs             ,
body = body                  ,
               closure = env}) = "(lambda (" ++ unwords (map show args) ++
                 (case varargs of
                    Nothing -> ""
                    Just arg -> " . " ++ arg) ++ ") ...)"

unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal

-- LispError Data Type and associated functions
data LispError = NumArgs Integer [LispVal]
               | TypeMismatch String LispVal
               | Parser ParseError
               | BadSpecialForm String LispVal
               | NotFunction String String
               | UnboundVar String String
               | Default String

showError :: LispError -> String
showError (UnboundVar msg var)          = msg ++ ": " ++ var
showError (BadSpecialForm msg form)     = msg ++ ": " ++ show form
showError (NotFunction msg func)        = msg ++ ": " ++ show func
showError (NumArgs expected found)      = "Expected " ++ show expected ++ " args; found values " ++ unwordsList found
showError (TypeMismatch expected found) = "Invalid type.  Expected " ++ expected ++ ", found " ++ show found
showError (Parser parseErr)             = "Parse error at " ++ show parseErr
showError (Default err)                 = "Unknown error: " ++ show err

instance Show LispError where show = showError

type ThrowsError = Either LispError

-- Helper Functions for Parsing
trapError action = catchError action (return . show)

extractValue :: ThrowsError a -> a
extractValue (Right val) = val

-- Environment Errors
type IOThrowsError = ExceptT LispError IO

liftThrows :: ThrowsError a -> IOThrowsError a
-- Note that this type signature is not general...
-- try (MonadError m a) => Either e a -> m a
liftThrows (Left err)  = throwError err
liftThrows (Right val) = return val

runIOThrows :: IOThrowsError String -> IO String
runIOThrows action = runExceptT (trapError action) >>= return . extractValue

-- Environment Definition
type Env = IORef (Map.Map String (IORef LispVal))

nullEnv :: IO Env
nullEnv = newIORef Map.empty

isBound :: Env -> String -> IO Bool
isBound e s = readIORef e >>= return . Map.member s

getVar :: Env -> String -> IOThrowsError LispVal
getVar e s = do
  env <- liftIO $ readIORef e
  case Map.lookup s env of
    Just v  -> liftIO $ readIORef v
    Nothing -> throwError $ UnboundVar "Trying to get an unbound variable..." s

setVar :: Env -> String -> LispVal -> IOThrowsError LispVal
setVar e s l = do
  env <- liftIO $ readIORef e
  case Map.lookup s env of
    Just v  -> liftIO $ writeIORef v l
    Nothing -> throwError $ UnboundVar "Trying to update an unbound variable.." s
  return l

defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal
defineVar e s l = do
  defined <- liftIO $ isBound e s
  if defined then setVar e s l
  else liftIO $ do
    newVar <- newIORef l
    modifyIORef' e $ Map.insert s newVar
    return l

bindVars :: Env -> [(String, LispVal)] -> IO Env
bindVars e ls = do
  updates <- mapM mkRef ls >>= return . Map.fromList
  modifyIORef' e (Map.union updates)
  return e
    where
      mkRef :: (String, LispVal) -> IO (String, IORef LispVal)
      mkRef (s, l) = newIORef l >>= return . (,) s

showEnv :: Env -> IO String
showEnv e = do
  env <- readIORef e
  vars <- return $ Map.toList env
  (sequence $ map printOne vars) >>= return . unlines
    where
      printOne :: (String, IORef LispVal) -> IO String
      printOne (s, l) = do
        lispval <- readIORef l
        return $ s ++ " : " ++ show lispval


module Fractal.Gui.FractalWindow(
  mainW
)where

import Graphics.UI.Gtk
import Graphics.UI.Gtk.Builder
import System.Glib.Signals (on)
import Control.Monad.IO.Class
import Graphics.UI.Gtk.Buttons.Button
import Graphics.UI.Gtk.Entry.Entry
import qualified Fractal.Gui.UI_ID as GUI_ID
import Graphics.UI.Gtk.Display.Image
import Graphics.UI.Gtk.MenuComboToolbar.ComboBox
import Control.Monad
import Data.Complex
import Data.Maybe
import Graphics.UI.Gtk.Display.Spinner
import Control.Concurrent

data MandelUI = MandelUI{
                  _window          :: Window,
                  _calcButton      :: Button,
                  _limitEntry      :: Entry,
                  _iterEntry       :: Entry,
                  _stepEntry       :: Entry,
                  _x_startEntry    :: Entry,
                  _y_startEntry    :: Entry,
                  _x_endEntry      :: Entry,
                  _y_endEntry      :: Entry,
                  _evalStratEntry  :: ComboBox,
                  _spinner         :: Spinner
                  --_image           :: Image
                }

type MandelInput = (Double, Int, Double, Complex Double, Complex Double, String)

createUI :: Builder -> IO MandelUI
createUI builder = do
  let builderAcces = builderGetObject builder
  win     <- builderAcces castToWindow GUI_ID.id_WINDOW
  clcB    <- builderGetObject builder castToButton GUI_ID.id_CALC_BUTTON
  lim     <- builderGetObject builder castToEntry GUI_ID.id_LIMIT
  step    <- builderGetObject builder castToEntry GUI_ID.id_STEP_SIZE
  x_s     <- builderGetObject builder castToEntry GUI_ID.id_X_START
  y_s     <- builderGetObject builder castToEntry GUI_ID.id_Y_START
  iter    <- builderGetObject builder castToEntry GUI_ID.id_MAX_ITER
  x_e     <- builderGetObject builder castToEntry GUI_ID.id_X_END
  y_e     <- builderGetObject builder castToEntry GUI_ID.id_Y_END
  calcT   <- builderGetObject builder castToComboBox GUI_ID.id_EVAL_STRAT
  spinn   <- builderGetObject builder castToSpinner GUI_ID.id_SPINNER
  --img     <- builderGetObject builder castToImage GUI_ID.id_IMAGE
  return (MandelUI { _window=win, _calcButton=clcB, _limitEntry=lim
                   , _stepEntry=step, _x_startEntry=x_s, _iterEntry=iter, _y_startEntry=y_s
                   , _x_endEntry=x_e, _y_endEntry=y_e, _spinner=spinn, _evalStratEntry=calcT{-, _image=img-}})

buttonClick :: ((Double, Int, Double, Complex Double, Complex Double, String) -> IO ()) -> MandelUI -> IO ()
buttonClick f ui = do
  let entrys =  getEntrys ui
  stringInput <- readEntrys entrys
  evalStrat   <- readEvaluationMode (_evalStratEntry ui)
  let mandelInput = readMandelInput evalStrat stringInput
  putStrLn $ show mandelInput
  spinnerStart (_spinner ui)
  forkFinally (f mandelInput) (\_ -> spinnerStop (_spinner ui))
  return ()

getEntrys :: MandelUI -> [Entry]
getEntrys ui = [_limitEntry ui, _iterEntry ui, _stepEntry ui, _x_startEntry ui, _y_startEntry ui
               , _x_endEntry ui, _y_endEntry ui]

readMandelInput :: String -> [String] -> MandelInput
readMandelInput _ [] = error "No Parameters found!"
readMandelInput eval blah@[lim, iter, step, xS, yS, xE, yE] =
  let lim'  = (read lim) :: Double
      step' = (read step) :: Double
      iter' = (read iter) :: Int
      xS'   = (read xS) :: Double
      yS'   = (read yS) :: Double
      xE'   = (read xE) :: Double
      yE'   = (read yE) :: Double
  in (lim', iter', step', xS' :+ yS', xE':+ yE', eval)

readEvaluationMode :: ComboBox -> IO String
readEvaluationMode box = do
  active <- comboBoxGetActive box
  putStrLn $ show active
  let a = case active of
            1 -> "Parallel"
            0 -> "Single"
            2 -> "RepaSingle"
            _ -> "RepaParallel"
  return a

readEntrys :: [Entry] -> IO [String]
readEntrys entrys = do
  input <- mapM entryGetText entrys
  return input

mainW :: ((Double, Int, Double, Complex Double, Complex Double, String) -> IO ()) -> IO ()
mainW computation = do
    initGUI
    builder    <- builderNew
    builderAddFromFile builder GUI_ID.path_INTERFACE
    mandelUI <- createUI builder
    --imageSetFromFile (_image mandelUI) GUI_ID.path_IMAGE
    (on) (_window mandelUI)    deleteEvent $ liftIO mainQuit >> return False
    (on) (_calcButton mandelUI) buttonActivated $ buttonClick computation mandelUI
    widgetShowAll (_window mandelUI)
    mainGUI


module Classifiers.QLearning.Prelude
  ( module Prelude
  , module Control.Monad.Primitive
  , module Statistics.Distribution
  , module Statistics.Distribution.Normal
  , module System.Random.MWC
  , module Data.Sequence
  , module GHC.Float
  , module Control.Exception
  , module Data.List
  , module Data.Vector
  ) where

import Control.Monad.Primitive
import Control.Exception (assert)
import Data.List (intercalate)
import Data.Vector (Vector, (!), (//))
import Data.Sequence (Seq, (<|), (|>))
import Statistics.Distribution
import Statistics.Distribution.Normal
import System.Random.MWC
import GHC.Float

import Prelude


{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TemplateHaskell, OverloadedStrings #-}
module Numeric.Sundials.Types
  ( OdeRhsCType
  , OdeRhs(..)
  , UserData
  , Jacobian
  , StepControl(..)
  , ODEOpts(..)
  , SundialsDiagnostics(..)
  , emptyDiagnostics
  , SundialsSolution(..)
  , EventInfo(..)
  , CrossingDirection(..)
  , EventSpec(..)
  , SunVector(..)
  , SunIndexType
  , SunRealType
  , sunContentLengthOffset
  , sunContentDataOffset
  , sunCtx
  )
  where

import           Data.Int (Int32)
import qualified Data.Vector.Storable as VS
import qualified Data.Map.Strict as Map
import qualified Language.Haskell.TH as TH

import           Numeric.LinearAlgebra.HMatrix (Vector, Matrix)
import           Control.DeepSeq (NFData)
import           GHC.Generics (Generic)
import           Foreign.C.Types
import           Foreign.Ptr
import           Language.C.Types as CT
import           Language.C.Inline.Context
import           Numeric.Sundials.Arkode (SunVector(..), SunMatrix(..),
                                          SunIndexType, SunRealType,
                                          sunContentLengthOffset,
                                          sunContentDataOffset)

-- | The type of the C ODE RHS function.
type OdeRhsCType = CDouble -> Ptr SunVector -> Ptr SunVector -> Ptr UserData -> IO CInt

data UserData

-- | The right-hand side of the ODE system.
--
-- Can be either a Haskell function or a pointer to a C function.
data OdeRhs
  = OdeRhsHaskell (CDouble -> VS.Vector CDouble -> VS.Vector CDouble)
  | OdeRhsC (FunPtr OdeRhsCType) (Ptr UserData)

type Jacobian = Double -> Vector Double -> Matrix Double

-- | Adaptive step-size control
-- functions.
--
-- [GSL](https://www.gnu.org/software/gsl/doc/html/ode-initval.html#adaptive-step-size-control)
-- allows the user to control the step size adjustment using
-- \(D_i = \epsilon^{abs}s_i + \epsilon^{rel}(a_{y} |y_i| + a_{dy/dt} h |\dot{y}_i|)\) where
-- \(\epsilon^{abs}\) is the required absolute error, \(\epsilon^{rel}\)
-- is the required relative error, \(s_i\) is a vector of scaling
-- factors, \(a_{y}\) is a scaling factor for the solution \(y\) and
-- \(a_{dydt}\) is a scaling factor for the derivative of the solution \(dy/dt\).
--
-- [CVode](https://computation.llnl.gov/projects/sundials/cvode)
-- and [ARKode](https://computation.llnl.gov/projects/sundials/arkode)
-- allow the user to control the step size adjustment using
-- \(\eta^{rel}|y_i| + \eta^{abs}_i\). For compatibility with
-- [hmatrix-gsl](https://hackage.haskell.org/package/hmatrix-gsl),
-- tolerances for \(y\) and \(\dot{y}\) can be specified but the latter have no
-- effect.
data StepControl = X     Double Double -- ^ absolute and relative tolerance for \(y\); in GSL terms, \(a_{y} = 1\) and \(a_{dy/dt} = 0\); in ARKode terms, the \(\eta^{abs}_i\) are identical
                 | X'    Double Double -- ^ absolute and relative tolerance for \(\dot{y}\); in GSL terms, \(a_{y} = 0\) and \(a_{dy/dt} = 1\); in ARKode terms, the latter is treated as the relative tolerance for \(y\) so this is the same as specifying 'X' which may be entirely incorrect for the given problem
                 | XX'   Double Double Double Double -- ^ include both via relative tolerance
                                                     -- scaling factors \(a_y\), \(a_{{dy}/{dt}}\); in ARKode terms, the latter is ignored and \(\eta^{rel} = a_{y}\epsilon^{rel}\)
                 | ScXX' Double Double Double Double (Vector Double) -- ^ scale absolute tolerance of \(y_i\); in ARKode terms, \(a_{{dy}/{dt}}\) is ignored, \(\eta^{abs}_i = s_i \epsilon^{abs}\) and \(\eta^{rel} = a_{y}\epsilon^{rel}\)
  deriving (Eq, Ord, Show, Read)

data ODEOpts method = ODEOpts {
    maxNumSteps :: Int32
  , minStep     :: Double
  , maxFail     :: Int32
  , odeMethod   :: method
  , stepControl :: StepControl
  , initStep    :: Maybe Double
    -- ^ initial step size - by default, CVode
    -- estimates the initial step size to be the
    -- solution \(h\) of the equation
    -- \(\|\frac{h^2\ddot{y}}{2}\| = 1\), where
    -- \(\ddot{y}\) is an estimated value of the second
    -- derivative of the solution at \(t_0\)
  } deriving (Read, Show, Eq, Ord)

data SundialsDiagnostics = SundialsDiagnostics {
    odeGetNumSteps               :: Int
  , odeGetNumStepAttempts        :: Int
  , odeGetNumRhsEvals_fe         :: Int
  , odeGetNumRhsEvals_fi         :: Int
  , odeGetNumLinSolvSetups       :: Int
  , odeGetNumErrTestFails        :: Int
  , odeGetNumNonlinSolvIters     :: Int
  , odeGetNumNonlinSolvConvFails :: Int
  , dlsGetNumJacEvals            :: Int
  , dlsGetNumRhsEvals            :: Int
  } deriving Show

emptyDiagnostics :: SundialsDiagnostics
emptyDiagnostics = SundialsDiagnostics 0 0 0 0 0 0 0 0 0 0

data SundialsSolution =
  SundialsSolution
  { actualTimeGrid :: VS.Vector Double    -- ^ actual time grid returned by the solver (with duplicated event times)
  , solutionMatrix :: Matrix Double       -- ^ matrix of solutions: each column is an unknwown
  , eventInfo      :: [EventInfo]         -- ^ event infos, as many items as triggered events during the simulation
  , diagnostics    :: SundialsDiagnostics -- ^ usual Sundials diagnostics
  }

data EventInfo =
  EventInfo
  { eventTime     :: !Double            -- ^ time at which event was triggered
  , eventIndex    :: !Int               -- ^ which index was triggered
  , rootDirection :: !CrossingDirection -- ^ in which direction ((+)->(-) or (-)->(+)) the root is crossed
  }
  deriving (Generic, Show, NFData)

-- | The direction in which a function should cross the x axis
data CrossingDirection = Upwards | Downwards | AnyDirection
  deriving (Generic, Eq, Show, NFData)

data EventSpec = EventSpec
  { eventCondition :: Double -> VS.Vector Double -> Double
  , eventDirection :: CrossingDirection
  , eventUpdate :: Double -> VS.Vector Double -> VS.Vector Double
  }

sunTypesTable :: Map.Map TypeSpecifier TH.TypeQ
sunTypesTable = Map.fromList
  [
    (TypeName "sunindextype", [t| SunIndexType |] )
  , (TypeName "SunVector",    [t| SunVector |] )
  , (TypeName "SunMatrix",    [t| SunMatrix |] )
  , (TypeName "UserData",     [t| UserData |] )
  ]

-- | Allows to map between Haskell and C types
sunCtx :: Context
sunCtx = mempty {ctxTypesTable = sunTypesTable}


{-# OPTIONS_HADDOCK hide #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE EmptyDataDecls  #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE ForeignFunctionInterface  #-}
{-# LANGUAGE FunctionalDependencies  #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables  #-}

module Data.Eigen.Internal where

import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable
import Foreign.C.Types
import Foreign.C.String
import Control.Monad
#if __GLASGOW_HASKELL__ >= 710
#else
import Control.Applicative
#endif
import System.IO.Unsafe
import Data.Complex
import Data.Bits
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import qualified Data.Vector.Storable as VS
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BSI

class (Num a, Cast a b, Cast b a, Storable b, Code b) => Elem a b | a -> b where

instance Elem Float CFloat where
instance Elem Double CDouble where
instance Elem (Complex Float) (CComplex CFloat) where
instance Elem (Complex Double) (CComplex CDouble) where

class Cast a b where
    cast :: a -> b

instance Storable a => Binary (VS.Vector a) where
    put vs = put (BS.length bs) >> putByteString bs where
        (fp,fs) = VS.unsafeToForeignPtr0 vs
        es = sizeOf (VS.head vs)
        bs = BSI.fromForeignPtr (castForeignPtr fp) 0 (fs * es)

    get = get >>= getByteString >>= \bs -> let
        (fp,fo,fs) = BSI.toForeignPtr bs
        es = sizeOf (VS.head vs)
        vs = VS.unsafeFromForeignPtr0 (Data.Eigen.Internal.plusForeignPtr fp fo) (fs `div` es)
        in return vs

-- | Complex number for FFI with the same memory layout as std::complex\<T\>
data CComplex a = CComplex !a !a deriving Show

instance Storable a => Storable (CComplex a) where
    sizeOf _ = sizeOf (undefined :: a) * 2
    alignment _ = alignment (undefined :: a)
    poke p (CComplex x y) = do
        pokeElemOff (castPtr p) 0 x
        pokeElemOff (castPtr p) 1 y
    peek p = CComplex
        <$> peekElemOff (castPtr p) 0
        <*> peekElemOff (castPtr p) 1

data CTriplet a = CTriplet !CInt !CInt !a deriving Show

instance Storable a => Storable (CTriplet a) where
    sizeOf _ = sizeOf (undefined :: a) + sizeOf (undefined :: CInt) * 2
    alignment _ = alignment (undefined :: CInt)
    poke p (CTriplet row col val) = do
        pokeElemOff (castPtr p) 0 row
        pokeElemOff (castPtr p) 1 col
        pokeByteOff p (sizeOf (undefined :: CInt) * 2) val
    peek p = CTriplet
        <$> peekElemOff (castPtr p) 0
        <*> peekElemOff (castPtr p) 1
        <*> peekByteOff p (sizeOf (undefined :: CInt) * 2)

instance Cast CInt Int where; cast = fromIntegral
instance Cast Int CInt where; cast = fromIntegral
instance Cast CFloat Float where; cast (CFloat x) = x
instance Cast Float CFloat where; cast = CFloat
instance Cast CDouble Double where; cast (CDouble x) = x
instance Cast Double CDouble where; cast = CDouble
instance Cast (CComplex CFloat) (Complex Float) where; cast (CComplex x y) = cast x :+ cast y
instance Cast (Complex Float) (CComplex CFloat) where; cast (x :+ y) = CComplex (cast x) (cast y)
instance Cast (CComplex CDouble) (Complex Double) where; cast (CComplex x y) = cast x :+ cast y
instance Cast (Complex Double) (CComplex CDouble) where; cast (x :+ y) = CComplex (cast x) (cast y)

instance Cast a b => Cast (CTriplet a) (Int, Int, b) where; cast (CTriplet x y z) = (cast x, cast y, cast z)
instance Cast a b => Cast (Int, Int, a) (CTriplet b) where; cast (x,y,z) = CTriplet (cast x) (cast y) (cast z)

intSize :: Int
intSize = sizeOf (undefined :: CInt)

encodeInt :: CInt -> BS.ByteString
encodeInt x = BSI.unsafeCreate (sizeOf x) $ (`poke` x) . castPtr

decodeInt :: BS.ByteString -> CInt
decodeInt (BSI.PS fp fo fs)
    | fs == sizeOf x = x
    | otherwise = error "decodeInt: wrong buffer size"
    where x = performIO $ withForeignPtr fp $ peek . (`plusPtr` fo)

data CSparseMatrix a b
type CSparseMatrixPtr a b = Ptr (CSparseMatrix a b)

data CSolver a b
type CSolverPtr a b = Ptr (CSolver a b)

performIO :: IO a -> a
performIO = unsafeDupablePerformIO

plusForeignPtr :: ForeignPtr a -> Int -> ForeignPtr b
plusForeignPtr fp fo = castForeignPtr fp' where
    vs :: VS.Vector CChar
    vs = VS.unsafeFromForeignPtr (castForeignPtr fp) fo 0
    (fp', _) = VS.unsafeToForeignPtr0 vs

foreign import ccall "eigen-proxy.h free" c_freeString :: CString -> IO ()

call :: IO CString -> IO ()
call func = func >>= \c_str -> when (c_str /= nullPtr) $
    peekCString c_str >>= \str -> c_freeString c_str >> fail str

foreign import ccall "eigen-proxy.h free" free :: Ptr a -> IO ()

foreign import ccall "eigen-proxy.h eigen_setNbThreads" c_setNbThreads :: CInt -> IO ()
foreign import ccall "eigen-proxy.h eigen_getNbThreads" c_getNbThreads :: IO CInt

class Code a where; code :: a -> CInt
instance Code CFloat where; code _ = 0
instance Code CDouble where; code _ = 1
instance Code (CComplex CFloat) where; code _ = 2
instance Code (CComplex CDouble) where; code _ = 3

newtype MagicCode = MagicCode CInt deriving Eq

instance Binary MagicCode where
    put (MagicCode code) = putWord32be $ fromIntegral code
    get = MagicCode . fromIntegral <$> getWord32be

magicCode :: Code a => a -> MagicCode
magicCode x = MagicCode (code x `xor` 0x45696730)

#let api1 name, args = "foreign import ccall \"eigen_%s\" c_%s :: CInt -> %s\n%s :: forall b . Code b => %s\n%s = c_%s (code (undefined :: b))", #name, #name, args, #name, args, #name, #name

#api1 random,        "Ptr b -> CInt -> CInt -> IO CString"
#api1 identity,      "Ptr b -> CInt -> CInt -> IO CString"
#api1 add,           "Ptr b -> CInt -> CInt -> Ptr b -> CInt -> CInt -> Ptr b -> CInt -> CInt -> IO CString"
#api1 sub,           "Ptr b -> CInt -> CInt -> Ptr b -> CInt -> CInt -> Ptr b -> CInt -> CInt -> IO CString"
#api1 mul,           "Ptr b -> CInt -> CInt -> Ptr b -> CInt -> CInt -> Ptr b -> CInt -> CInt -> IO CString"
#api1 diagonal,      "Ptr b -> CInt -> CInt -> Ptr b -> CInt -> CInt -> IO CString"
#api1 transpose,     "Ptr b -> CInt -> CInt -> Ptr b -> CInt -> CInt -> IO CString"
#api1 inverse,       "Ptr b -> CInt -> CInt -> Ptr b -> CInt -> CInt -> IO CString"
#api1 adjoint,       "Ptr b -> CInt -> CInt -> Ptr b -> CInt -> CInt -> IO CString"
#api1 conjugate,     "Ptr b -> CInt -> CInt -> Ptr b -> CInt -> CInt -> IO CString"
#api1 normalize,     "Ptr b -> CInt -> CInt -> IO CString"
#api1 sum,           "Ptr b -> Ptr b -> CInt -> CInt -> IO CString"
#api1 prod,          "Ptr b -> Ptr b -> CInt -> CInt -> IO CString"
#api1 mean,          "Ptr b -> Ptr b -> CInt -> CInt -> IO CString"
#api1 norm,          "Ptr b -> Ptr b -> CInt -> CInt -> IO CString"
#api1 trace,         "Ptr b -> Ptr b -> CInt -> CInt -> IO CString"
#api1 squaredNorm,   "Ptr b -> Ptr b -> CInt -> CInt -> IO CString"
#api1 blueNorm,      "Ptr b -> Ptr b -> CInt -> CInt -> IO CString"
#api1 hypotNorm,     "Ptr b -> Ptr b -> CInt -> CInt -> IO CString"
#api1 determinant,   "Ptr b -> Ptr b -> CInt -> CInt -> IO CString"
#api1 rank,          "CInt -> Ptr CInt -> Ptr b -> CInt -> CInt -> IO CString"
#api1 image,         "CInt -> Ptr (Ptr b) -> Ptr CInt -> Ptr CInt -> Ptr b -> CInt -> CInt -> IO CString"
#api1 kernel,        "CInt -> Ptr (Ptr b) -> Ptr CInt -> Ptr CInt -> Ptr b -> CInt -> CInt -> IO CString"
#api1 solve,         "CInt -> Ptr b -> CInt -> CInt -> Ptr b -> CInt -> CInt -> Ptr b -> CInt -> CInt -> IO CString"
#api1 relativeError, "Ptr b -> Ptr b -> CInt -> CInt -> Ptr b -> CInt -> CInt -> Ptr b -> CInt -> CInt -> IO CString"

#let api2 name, args = "foreign import ccall \"eigen_%s\" c_%s :: CInt -> %s\n%s :: forall a b . Code b => %s\n%s = c_%s (code (undefined :: b))", #name, #name, args, #name, args, #name, #name

#api2 sparse_new,           "CInt -> CInt -> Ptr (CSparseMatrixPtr a b) -> IO CString"
#api2 sparse_clone,         "CSparseMatrixPtr a b -> Ptr (CSparseMatrixPtr a b) -> IO CString"
#api2 sparse_fromList,      "CInt -> CInt -> Ptr (CTriplet b) -> CInt -> Ptr (CSparseMatrixPtr a b) -> IO CString"
#api2 sparse_toList,        "CSparseMatrixPtr a b -> Ptr (CTriplet b) -> CInt -> IO CString"
#api2 sparse_free,          "CSparseMatrixPtr a b -> IO CString"
#api2 sparse_makeCompressed,"CSparseMatrixPtr a b -> Ptr (CSparseMatrixPtr a b) -> IO CString"
#api2 sparse_uncompress,    "CSparseMatrixPtr a b -> Ptr (CSparseMatrixPtr a b) -> IO CString"
#api2 sparse_isCompressed,  "CSparseMatrixPtr a b -> Ptr CInt -> IO CString"
#api2 sparse_transpose,     "CSparseMatrixPtr a b -> Ptr (CSparseMatrixPtr a b) -> IO CString"
#api2 sparse_adjoint,       "CSparseMatrixPtr a b -> Ptr (CSparseMatrixPtr a b) -> IO CString"
#api2 sparse_pruned,        "CSparseMatrixPtr a b -> Ptr (CSparseMatrixPtr a b) -> IO CString"
#api2 sparse_prunedRef,     "CSparseMatrixPtr a b -> Ptr b -> Ptr (CSparseMatrixPtr a b) -> IO CString"
#api2 sparse_scale,         "CSparseMatrixPtr a b -> Ptr b -> Ptr (CSparseMatrixPtr a b) -> IO CString"
#api2 sparse_nonZeros,      "CSparseMatrixPtr a b -> Ptr CInt -> IO CString"
#api2 sparse_innerSize,     "CSparseMatrixPtr a b -> Ptr CInt -> IO CString"
#api2 sparse_outerSize,     "CSparseMatrixPtr a b -> Ptr CInt -> IO CString"
#api2 sparse_coeff,         "CSparseMatrixPtr a b -> CInt -> CInt -> Ptr b -> IO CString"
#api2 sparse_coeffRef,      "CSparseMatrixPtr a b -> CInt -> CInt -> Ptr (Ptr b) -> IO CString"
#api2 sparse_cols,          "CSparseMatrixPtr a b -> Ptr CInt -> IO CString"
#api2 sparse_rows,          "CSparseMatrixPtr a b -> Ptr CInt -> IO CString"
#api2 sparse_norm,          "CSparseMatrixPtr a b -> Ptr b -> IO CString"
#api2 sparse_squaredNorm,   "CSparseMatrixPtr a b -> Ptr b -> IO CString"
#api2 sparse_blueNorm,      "CSparseMatrixPtr a b -> Ptr b -> IO CString"
#api2 sparse_add,           "CSparseMatrixPtr a b -> CSparseMatrixPtr a b -> Ptr (CSparseMatrixPtr a b) -> IO CString"
#api2 sparse_sub,           "CSparseMatrixPtr a b -> CSparseMatrixPtr a b -> Ptr (CSparseMatrixPtr a b) -> IO CString"
#api2 sparse_mul,           "CSparseMatrixPtr a b -> CSparseMatrixPtr a b -> Ptr (CSparseMatrixPtr a b) -> IO CString"
#api2 sparse_block,         "CSparseMatrixPtr a b -> CInt -> CInt -> CInt -> CInt -> Ptr (CSparseMatrixPtr a b) -> IO CString"
#api2 sparse_fromMatrix,    "Ptr b -> CInt -> CInt -> Ptr (CSparseMatrixPtr a b) -> IO CString"
#api2 sparse_toMatrix,      "CSparseMatrixPtr a b -> Ptr b -> CInt -> CInt -> IO CString"
#api2 sparse_values,        "CSparseMatrixPtr a b -> Ptr CInt -> Ptr (Ptr b) -> IO CString"
#api2 sparse_outerStarts,   "CSparseMatrixPtr a b -> Ptr CInt -> Ptr (Ptr CInt) -> IO CString"
#api2 sparse_innerIndices,  "CSparseMatrixPtr a b -> Ptr CInt -> Ptr (Ptr CInt) -> IO CString"
#api2 sparse_innerNNZs,     "CSparseMatrixPtr a b -> Ptr CInt -> Ptr (Ptr CInt) -> IO CString"
#api2 sparse_setZero,       "CSparseMatrixPtr a b -> IO CString"
#api2 sparse_setIdentity,   "CSparseMatrixPtr a b -> IO CString"
#api2 sparse_reserve,       "CSparseMatrixPtr a b -> CInt -> IO CString"
#api2 sparse_resize,        "CSparseMatrixPtr a b -> CInt -> CInt -> IO CString"

#api2 sparse_conservativeResize,    "CSparseMatrixPtr a b -> CInt -> CInt -> IO CString"
#api2 sparse_compressInplace,       "CSparseMatrixPtr a b -> IO CString"
#api2 sparse_uncompressInplace,     "CSparseMatrixPtr a b -> IO CString"

#let api3 name, args = "foreign import ccall \"eigen_%s\" c_%s :: CInt -> CInt -> %s\n%s :: forall s a b . (Code s, Code b) => s -> %s\n%s s = c_%s (code (undefined :: b)) (code s)", #name, #name, args, #name, args, #name, #name

#api3 sparse_la_newSolver,          "Ptr (CSolverPtr a b) -> IO CString"
#api3 sparse_la_freeSolver,         "CSolverPtr a b -> IO CString"
#api3 sparse_la_factorize,          "CSolverPtr a b -> CSparseMatrixPtr a b -> IO CString"
#api3 sparse_la_analyzePattern,     "CSolverPtr a b -> CSparseMatrixPtr a b -> IO CString"
#api3 sparse_la_compute,            "CSolverPtr a b -> CSparseMatrixPtr a b -> IO CString"
#api3 sparse_la_tolerance,          "CSolverPtr a b -> Ptr CDouble -> IO CString"
#api3 sparse_la_setTolerance,       "CSolverPtr a b -> CDouble -> IO CString"
#api3 sparse_la_maxIterations,      "CSolverPtr a b -> Ptr CInt -> IO CString"
#api3 sparse_la_setMaxIterations,   "CSolverPtr a b -> CInt -> IO CString"
#api3 sparse_la_info,               "CSolverPtr a b -> Ptr CInt -> IO CString"
#api3 sparse_la_error,              "CSolverPtr a b -> Ptr CDouble -> IO CString"
#api3 sparse_la_iterations,         "CSolverPtr a b -> Ptr CInt -> IO CString"
#api3 sparse_la_solve,              "CSolverPtr a b -> CSparseMatrixPtr a b -> Ptr (CSparseMatrixPtr a b) -> IO CString"
-- #api3 sparse_la_solveWithGuess,     "CSolverPtr a b -> CSparseMatrixPtr a b -> CSparseMatrixPtr a b -> Ptr (CSparseMatrixPtr a b) -> IO CString"
#api3 sparse_la_matrixQ,            "CSolverPtr a b -> Ptr (CSparseMatrixPtr a b) -> IO CString"
#api3 sparse_la_matrixR,            "CSolverPtr a b -> Ptr (CSparseMatrixPtr a b) -> IO CString"
#api3 sparse_la_setPivotThreshold,  "CSolverPtr a b -> CDouble -> IO CString"
#api3 sparse_la_rank,               "CSolverPtr a b -> Ptr CInt -> IO CString"
#api3 sparse_la_matrixL,            "CSolverPtr a b -> Ptr (CSparseMatrixPtr a b) -> IO CString"
#api3 sparse_la_matrixU,            "CSolverPtr a b -> Ptr (CSparseMatrixPtr a b) -> IO CString"
#api3 sparse_la_setSymmetric,       "CSolverPtr a b -> CInt -> IO CString"
#api3 sparse_la_determinant,        "CSolverPtr a b -> Ptr b -> IO CString"
#api3 sparse_la_logAbsDeterminant,  "CSolverPtr a b -> Ptr b -> IO CString"
#api3 sparse_la_absDeterminant,     "CSolverPtr a b -> Ptr b -> IO CString"
#api3 sparse_la_signDeterminant,    "CSolverPtr a b -> Ptr b -> IO CString"


module Render (cfileSink) where

import           Control.Monad
import           Data.ByteString.Builder
import           Data.Complex
import           IQ
import           Pipes
import qualified Pipes.Prelude as P
import           System.IO

foldChunk :: (Monad m, Monoid a) => Int -> Pipe a a m ()
foldChunk n = forever $ go n mempty
  where go 0 x = yield x
        go n x = do
          x' <- await
          go (n - 1) $ x <> x'

renderSample :: IQ -> Builder
renderSample (real :+ imag) = floatLE real <> floatLE imag

cfileSink :: MonadIO m => Handle -> Consumer IQ m ()
cfileSink h = P.map renderSample
           >-> foldChunk 100
           >-> P.mapM_ (liftIO . hPutBuilder h)
{-# INLINE cfileSink #-}