text:
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

--
-- Copyright (c) 2009-2011, ERICSSON AB
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
--     * Redistributions of source code must retain the above copyright notice,
--       this list of conditions and the following disclaimer.
--     * Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in the
--       documentation and/or other materials provided with the distribution.
--     * Neither the name of the ERICSSON AB nor the names of its contributors
--       may be used to endorse or promote products derived from this software
--       without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--

module Feldspar.Core.Types
       ( module Feldspar.Core.Types
       , IntN(..), WordN(..)
       , tuple, Tuple(), RTuple(..), sel, Skip(..), First(..), (:*), TNil -- From NestedTuples
       ) where

import Data.Array.IO (IOArray(..))
import Data.Bits
import Data.Complex
import Data.Int
import Data.IORef
import Data.List
import Data.Typeable (Typeable)
import Data.Orphans
import Data.Word
import Data.Hash
import Test.QuickCheck
import System.Random (Random(..))
import qualified Control.Monad.Par as MonadPar

import Data.Patch
import Data.Proxy

import Feldspar.Lattice
import Feldspar.Range
import Feldspar.Core.NestedTuples

--------------------------------------------------------------------------------
-- * Heterogenous lists
--------------------------------------------------------------------------------

-- | Heterogeneous list
data a :> b = a :> b
  deriving (Eq, Ord, Show)

infixr 5 :>

instance (Lattice a, Lattice b) => Lattice (a :> b)
  where
    bot = bot :> bot
    top = top :> top
    (a1:>a2) \/ (b1:>b2) = (a1 \/ b1) :> (a2 \/ b2)
    (a1:>a2) /\ (b1:>b2) = (a1 /\ b1) :> (a2 /\ b2)

-- | Type representation of 8 bits
data N8

-- | Type representation of 16 bits
data N16

-- | Type representation of 32 bits
data N32

-- | Type representation of 64 bits
data N64

-- | Type representation of the native number of bits on the target
data NNative

-- | Witness for 'N8', 'N16', 'N32', 'N64' or 'NNative'
data BitWidth n
  where
    N8      :: BitWidth N8
    N16     :: BitWidth N16
    N32     :: BitWidth N32
    N64     :: BitWidth N64
    NNative :: BitWidth NNative

bitWidth :: BitWidth n -> String
bitWidth N8      = "8"
bitWidth N16     = "16"
bitWidth N32     = "32"
bitWidth N64     = "64"
bitWidth NNative = "N"

-- | Type representation of \"unsigned\"
data U

-- | Type representation of \"signed\"
data S

-- | Witness for 'U' or 'S'
data Signedness s
  where
    U :: Signedness U
    S :: Signedness S

signedness :: Signedness s -> String
signedness U = "Word"
signedness S = "Int"

-- | A generalization of unsigned and signed integers. The first parameter
-- represents the signedness and the second parameter the number of bits.
type family GenericInt s n where
  GenericInt U N8      = Word8
  GenericInt S N8      = Int8
  GenericInt U N16     = Word16
  GenericInt S N16     = Int16
  GenericInt U N32     = Word32
  GenericInt S N32     = Int32
  GenericInt U N64     = Word64
  GenericInt S N64     = Int64
  GenericInt U NNative = WordN
  GenericInt S NNative = IntN

fromWordN :: BitWidth n -> WordN -> GenericInt U n
fromWordN N8      = fromInteger . toInteger
fromWordN N16     = fromInteger . toInteger
fromWordN N32     = fromInteger . toInteger
fromWordN N64     = fromInteger . toInteger
fromWordN NNative = id
  -- TODO Check that the number fits

fromIntN :: BitWidth n -> IntN -> GenericInt S n
fromIntN N8      = fromInteger . toInteger
fromIntN N16     = fromInteger . toInteger
fromIntN N32     = fromInteger . toInteger
fromIntN N64     = fromInteger . toInteger
fromIntN NNative = id
  -- TODO Check that the number fits

genericLen :: BitWidth n -> [a] -> GenericInt U n
genericLen N8      = genericLength
genericLen N16     = genericLength
genericLen N32     = genericLength
genericLen N64     = genericLength
genericLen NNative = genericLength

type Length = WordN
type Index  = WordN

--------------------------------------------------------------------------------
-- * Arrays
--------------------------------------------------------------------------------

-- | Array whose length is represented by an @n@-bit word
data TargetArr n a = TargetArr (GenericInt U n) [a]

--------------------------------------------------------------------------------
-- * Monadic Types
--------------------------------------------------------------------------------

-- | This class is used to allow constructs to be abstract in the monad
class MonadType m
  where
    voidTypeRep :: TypeRep (m ())
  -- TODO Since the `Mut` monad is already abstract, this class is probably only
  --      needed if we want to be able to use monadic constructs with different
  --      monad types.

--------------------------------------------------------------------------------
-- * Mutable data
--------------------------------------------------------------------------------

-- TODO Make newtypes?

-- | Monad for manipulation of mutable data
type Mut = IO

-- | Mutable references
instance Show (IORef a)
  where
    show _ = "IORef"

-- | Mutable arrays
type MArr a = IOArray Integer a

instance Show (MArr a)
  where
    show _ = "MArr"

instance MonadType Mut
  where
    voidTypeRep = MutType UnitType

--------------------------------------------------------------------------------
-- * Par Monad
--------------------------------------------------------------------------------

-- | Monad for parallel constructs
type Par = MonadPar.Par

deriving instance Typeable Par

-- | Immutable references
type IV = MonadPar.IVar

instance Show (IV a)
  where
    show _ = "IVar"

instance MonadType Par
  where
    voidTypeRep = ParType UnitType

--------------------------------------------------------------------------------
-- * Elements Language
--------------------------------------------------------------------------------

newtype Elements a = Elements { unE :: [(Index, a)] }

deriving instance Typeable Elements

instance Show a => Show (Elements a)
  where
    show (Elements a) = "Elements " ++ show a

instance Eq a => Eq (Elements a)
  where
    _ == _ = False

--------------------------------------------------------------------------------
-- * Future values
--------------------------------------------------------------------------------

newtype FVal a = FVal {unFVal :: a}

deriving instance Typeable IV
deriving instance Typeable FVal

instance Show (FVal a)
  where
    show _ = "future"

instance Eq a => Eq (FVal a)
  where
    (FVal a) == (FVal b) = a == b

--------------------------------------------------------------------------------
-- * Hashing
--------------------------------------------------------------------------------

instance Hashable a => Hashable (Complex a) where
  hash (re :+ im) = hash re `combine` hash im

--------------------------------------------------------------------------------
-- * Type representation
--------------------------------------------------------------------------------

-- | Representation of supported types
data TypeRep a
  where
    UnitType      :: TypeRep ()
    BoolType      :: TypeRep Bool
    IntType       :: ( BoundedInt (GenericInt s n)
                     , Size (GenericInt s n) ~ Range (GenericInt s n)
                     ) =>
                       Signedness s -> BitWidth n -> TypeRep (GenericInt s n)
    FloatType     :: TypeRep Float
    DoubleType    :: TypeRep Double
    ComplexType   :: RealFloat a => TypeRep a -> TypeRep (Complex a)
    ArrayType     :: TypeRep a -> TypeRep [a]
    TargetArrType :: BitWidth n -> TypeRep a -> TypeRep (TargetArr n a)
    Tup2Type      :: TypeRep a -> TypeRep b -> TypeRep (a,b)
    Tup3Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep (a,b,c)
    Tup4Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep (a,b,c,d)
    Tup5Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep (a,b,c,d,e)
    Tup6Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep (a,b,c,d,e,f)
    Tup7Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep g -> TypeRep (a,b,c,d,e,f,g)
    Tup8Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep g -> TypeRep h -> TypeRep (a,b,c,d,e,f,g,h)
    Tup9Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep g -> TypeRep h -> TypeRep i -> TypeRep (a,b,c,d,e,f,g,h,i)
    Tup10Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep g -> TypeRep h -> TypeRep i -> TypeRep j -> TypeRep (a,b,c,d,e,f,g,h,i,j)
    Tup11Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep g -> TypeRep h -> TypeRep i -> TypeRep j -> TypeRep k -> TypeRep (a,b,c,d,e,f,g,h,i,j,k)
    Tup12Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep g -> TypeRep h -> TypeRep i -> TypeRep j -> TypeRep k -> TypeRep l -> TypeRep (a,b,c,d,e,f,g,h,i,j,k,l)
    Tup13Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep g -> TypeRep h -> TypeRep i -> TypeRep j -> TypeRep k -> TypeRep l -> TypeRep m -> TypeRep (a,b,c,d,e,f,g,h,i,j,k,l,m)
    Tup14Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep g -> TypeRep h -> TypeRep i -> TypeRep j -> TypeRep k -> TypeRep l -> TypeRep m -> TypeRep n -> TypeRep (a,b,c,d,e,f,g,h,i,j,k,l,m,n)
    Tup15Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep g -> TypeRep h -> TypeRep i -> TypeRep j -> TypeRep k -> TypeRep l -> TypeRep m -> TypeRep n -> TypeRep o -> TypeRep (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)
    FunType       :: TypeRep a -> TypeRep b -> TypeRep (a -> b)
    MutType       :: TypeRep a -> TypeRep (Mut a)
    RefType       :: TypeRep a -> TypeRep (IORef a)
    MArrType      :: TypeRep a -> TypeRep (MArr a)
    ParType       :: TypeRep a -> TypeRep (Par a)
    ElementsType  :: TypeRep a -> TypeRep (Elements a)
    ConsType      :: TypeRep a -> TypeRep (RTuple b) -> TypeRep (RTuple (a :* b))
    NilType       :: TypeRep (RTuple TNil)
    TupleType     :: TypeRep (RTuple a) -> TypeRep (Tuple a)
    IVarType      :: TypeRep a -> TypeRep (IV a)
    FValType      :: TypeRep a -> TypeRep (FVal a)
      -- TODO `MArrType` Should have a target-specialized version. Or perhaps
      --      use a single type with a flag to distinguish between immutable and
      --      mutable arrays.

instance Show (TypeRep a)
  where
    show UnitType            = "()"
    show BoolType            = "Bool"
    show (IntType s n)       = signedness s ++ bitWidth n
    show FloatType           = "Float"
    show DoubleType          = "Double"
    show (ComplexType t)     = "(Complex " ++ show t ++ ")"
    show (ArrayType t)       = "[" ++ show t ++ "]"
    show (TargetArrType _ t) = "[" ++ show t ++ "]"
    show (Tup2Type ta tb)                = showTup [show ta, show tb]
    show (Tup3Type ta tb tc)             = showTup [show ta, show tb, show tc]
    show (Tup4Type ta tb tc td)          = showTup [show ta, show tb, show tc, show td]
    show (Tup5Type ta tb tc td te)       = showTup [show ta, show tb, show tc, show td, show te]
    show (Tup6Type ta tb tc td te tf)    = showTup [show ta, show tb, show tc, show td, show te, show tf]
    show (Tup7Type ta tb tc td te tf tg) = showTup [show ta, show tb, show tc, show td, show te, show tf, show tg]
    show (Tup8Type ta tb tc td te tf tg th) = showTup [show ta, show tb, show tc, show td, show te, show tf, show tg, show th]
    show (Tup9Type ta tb tc td te tf tg th ti) = showTup [show ta, show tb, show tc, show td, show te, show tf, show tg, show th, show ti]
    show (Tup10Type ta tb tc td te tf tg th ti tj) = showTup [show ta, show tb, show tc, show td, show te, show tf, show tg, show th, show ti, show tj]
    show (Tup11Type ta tb tc td te tf tg th ti tj tk) = showTup [show ta, show tb, show tc, show td, show te, show tf, show tg, show th, show ti, show tj, show tk]
    show (Tup12Type ta tb tc td te tf tg th ti tj tk tl) = showTup [show ta, show tb, show tc, show td, show te, show tf, show tg, show th, show ti, show tj, show tk, show tl]
    show (Tup13Type ta tb tc td te tf tg th ti tj tk tl tm) = showTup [show ta, show tb, show tc, show td, show te, show tf, show tg, show th, show ti, show tj, show tk, show tl, show tm]
    show (Tup14Type ta tb tc td te tf tg th ti tj tk tl tm tn) = showTup [show ta, show tb, show tc, show td, show te, show tf, show tg, show th, show ti, show tj, show tk, show tl, show tm, show tn]
    show (Tup15Type ta tb tc td te tf tg th ti tj tk tl tm tn to) = showTup [show ta, show tb, show tc, show td, show te, show tf, show tg, show th, show ti, show tj, show tk, show tl, show tm, show tn, show to]
    show (FunType ta tb)                 = show ta ++ " -> " ++ show tb
    show (MutType ta)                    = unwords ["Mut", show ta]
    show (RefType ta)                    = unwords ["Ref", show ta]
    show (MArrType ta)                   = unwords ["MArr", show ta]
    show (ParType ta)                    = unwords ["Par", show ta]
    show (ElementsType ta)               = unwords ["Elements", show ta]
    show (ConsType ta tb)                = unwords [show ta, ":*", show tb]
    show NilType                         = "TNil"
    show (TupleType t)                   = "<" ++ show t ++ ">"
    show (IVarType ta)                   = unwords ["IVar", show ta]
    show (FValType ta)                   = unwords ["FVal", show ta]

-- | Type equality witness
data TypeEq a b
  where
    TypeEq :: TypeEq a a

defaultSize :: TypeRep a -> Size a
defaultSize UnitType = universal
defaultSize BoolType = universal
defaultSize (IntType _ _) = universal
defaultSize FloatType = universal
defaultSize DoubleType = universal
defaultSize (ComplexType _) = universal
defaultSize (ArrayType t) = universal :> defaultSize t
--defaultSize (TargetArrType n t) = universal :> defaultSize t -- TODO
defaultSize (Tup2Type ta tb) =  ( defaultSize ta
                                , defaultSize tb
                                )
defaultSize (Tup3Type ta tb tc) = ( defaultSize ta
                                  , defaultSize tb
                                  , defaultSize tc
                                  )
defaultSize (Tup4Type ta tb tc td) = ( defaultSize ta
                                     , defaultSize tb
                                     , defaultSize tc
                                     , defaultSize td
                                     )
defaultSize (Tup5Type ta tb tc td te) = ( defaultSize ta
                                        , defaultSize tb
                                        , defaultSize tc
                                        , defaultSize td
                                        , defaultSize te
                                        )
defaultSize (Tup6Type ta tb tc td te tf) = ( defaultSize ta
                                           , defaultSize tb
                                           , defaultSize tc
                                           , defaultSize td
                                           , defaultSize te
                                           , defaultSize tf
                                           )
defaultSize (Tup7Type ta tb tc td te tf tg) = ( defaultSize ta
                                              , defaultSize tb
                                              , defaultSize tc
                                              , defaultSize td
                                              , defaultSize te
                                              , defaultSize tf
                                              , defaultSize tg
                                              )
defaultSize (Tup8Type ta tb tc td te tf tg th) =
                                              ( defaultSize ta
                                              , defaultSize tb
                                              , defaultSize tc
                                              , defaultSize td
                                              , defaultSize te
                                              , defaultSize tf
                                              , defaultSize tg
                                              , defaultSize th
                                              )
defaultSize (Tup9Type ta tb tc td te tf tg th ti) =
                                              ( defaultSize ta
                                              , defaultSize tb
                                              , defaultSize tc
                                              , defaultSize td
                                              , defaultSize te
                                              , defaultSize tf
                                              , defaultSize tg
                                              , defaultSize th
                                              , defaultSize ti
                                              )
defaultSize (Tup10Type ta tb tc td te tf tg th ti tj) =
                                              ( defaultSize ta
                                              , defaultSize tb
                                              , defaultSize tc
                                              , defaultSize td
                                              , defaultSize te
                                              , defaultSize tf
                                              , defaultSize tg
                                              , defaultSize th
                                              , defaultSize ti
                                              , defaultSize tj
                                              )
defaultSize (Tup11Type ta tb tc td te tf tg th ti tj tk) =
                                              ( defaultSize ta
                                              , defaultSize tb
                                              , defaultSize tc
                                              , defaultSize td
                                              , defaultSize te
                                              , defaultSize tf
                                              , defaultSize tg
                                              , defaultSize th
                                              , defaultSize ti
                                              , defaultSize tj
                                              , defaultSize tk
                                              )
defaultSize (Tup12Type ta tb tc td te tf tg th ti tj tk tl) =
                                              ( defaultSize ta
                                              , defaultSize tb
                                              , defaultSize tc
                                              , defaultSize td
                                              , defaultSize te
                                              , defaultSize tf
                                              , defaultSize tg
                                              , defaultSize th
                                              , defaultSize ti
                                              , defaultSize tj
                                              , defaultSize tk
                                              , defaultSize tl
                                              )
defaultSize (Tup13Type ta tb tc td te tf tg th ti tj tk tl tm) =
                                              ( defaultSize ta
                                              , defaultSize tb
                                              , defaultSize tc
                                              , defaultSize td
                                              , defaultSize te
                                              , defaultSize tf
                                              , defaultSize tg
                                              , defaultSize th
                                              , defaultSize ti
                                              , defaultSize tj
                                              , defaultSize tk
                                              , defaultSize tl
                                              , defaultSize tm
                                              )
defaultSize (Tup14Type ta tb tc td te tf tg th ti tj tk tl tm tn) =
                                              ( defaultSize ta
                                              , defaultSize tb
                                              , defaultSize tc
                                              , defaultSize td
                                              , defaultSize te
                                              , defaultSize tf
                                              , defaultSize tg
                                              , defaultSize th
                                              , defaultSize ti
                                              , defaultSize tj
                                              , defaultSize tk
                                              , defaultSize tl
                                              , defaultSize tm
                                              , defaultSize tn
                                              )
defaultSize (Tup15Type ta tb tc td te tf tg th ti tj tk tl tm tn to) =
                                              ( defaultSize ta
                                              , defaultSize tb
                                              , defaultSize tc
                                              , defaultSize td
                                              , defaultSize te
                                              , defaultSize tf
                                              , defaultSize tg
                                              , defaultSize th
                                              , defaultSize ti
                                              , defaultSize tj
                                              , defaultSize tk
                                              , defaultSize tl
                                              , defaultSize tm
                                              , defaultSize tn
                                              , defaultSize to
                                              )
defaultSize (FunType ta tb) = (defaultSize ta, defaultSize tb)
defaultSize (MutType ta) = defaultSize ta
defaultSize (RefType ta) = defaultSize ta
defaultSize (MArrType ta) = universal :> defaultSize ta
defaultSize (ParType ta) = defaultSize ta
defaultSize (ElementsType ta) = universal :> defaultSize ta
defaultSize (ConsType ta tb) = (defaultSize ta, defaultSize tb)
defaultSize NilType = universal
defaultSize (TupleType t) = defaultSize t
defaultSize (IVarType ta) = defaultSize ta
defaultSize (FValType ta) = defaultSize ta

-- | Type equality on 'Signedness'
signEq :: Signedness s1 -> Signedness s2 -> Maybe (TypeEq s1 s2)
signEq U U = Just TypeEq
signEq S S = Just TypeEq
signEq _ _ = Nothing

-- | Type equality on 'BitWidth'
widthEq :: BitWidth n1 -> BitWidth n2 -> Maybe (TypeEq n1 n2)
widthEq N8      N8      = Just TypeEq
widthEq N16     N16     = Just TypeEq
widthEq N32     N32     = Just TypeEq
widthEq N64     N64     = Just TypeEq
widthEq NNative NNative = Just TypeEq
widthEq _ _ = Nothing

-- | Type equality on 'TypeRep'
typeEq :: TypeRep a -> TypeRep b -> Maybe (TypeEq a b)
typeEq UnitType UnitType = Just TypeEq
typeEq BoolType BoolType = Just TypeEq
typeEq (IntType s1 n1) (IntType s2 n2) = do
    TypeEq <- signEq s1 s2
    TypeEq <- widthEq n1 n2
    return TypeEq
typeEq FloatType FloatType = Just TypeEq
typeEq DoubleType DoubleType = Just TypeEq
typeEq (ComplexType t1) (ComplexType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (ArrayType t1) (ArrayType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (TargetArrType n1 t1) (TargetArrType n2 t2) = do
    TypeEq <- widthEq n1 n2
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (Tup2Type a1 b1) (Tup2Type a2 b2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    return TypeEq
typeEq (Tup3Type a1 b1 c1) (Tup3Type a2 b2 c2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    return TypeEq
typeEq (Tup4Type a1 b1 c1 d1) (Tup4Type a2 b2 c2 d2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    return TypeEq
typeEq (Tup5Type a1 b1 c1 d1 e1) (Tup5Type a2 b2 c2 d2 e2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    return TypeEq
typeEq (Tup6Type a1 b1 c1 d1 e1 f1) (Tup6Type a2 b2 c2 d2 e2 f2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    return TypeEq
typeEq (Tup7Type a1 b1 c1 d1 e1 f1 g1) (Tup7Type a2 b2 c2 d2 e2 f2 g2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    TypeEq <- typeEq g1 g2
    return TypeEq
typeEq (Tup8Type a1 b1 c1 d1 e1 f1 g1 h1) (Tup8Type a2 b2 c2 d2 e2 f2 g2 h2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    TypeEq <- typeEq g1 g2
    TypeEq <- typeEq h1 h2
    return TypeEq
typeEq (Tup9Type a1 b1 c1 d1 e1 f1 g1 h1 i1) (Tup9Type a2 b2 c2 d2 e2 f2 g2 h2 i2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    TypeEq <- typeEq g1 g2
    TypeEq <- typeEq h1 h2
    TypeEq <- typeEq i1 i2
    return TypeEq
typeEq (Tup10Type a1 b1 c1 d1 e1 f1 g1 h1 i1 j1) (Tup10Type a2 b2 c2 d2 e2 f2 g2 h2 i2 j2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    TypeEq <- typeEq g1 g2
    TypeEq <- typeEq h1 h2
    TypeEq <- typeEq i1 i2
    TypeEq <- typeEq j1 j2
    return TypeEq
typeEq (Tup11Type a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 k1) (Tup11Type a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    TypeEq <- typeEq g1 g2
    TypeEq <- typeEq h1 h2
    TypeEq <- typeEq i1 i2
    TypeEq <- typeEq j1 j2
    TypeEq <- typeEq k1 k2
    return TypeEq
typeEq (Tup12Type a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 k1 l1) (Tup12Type a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    TypeEq <- typeEq g1 g2
    TypeEq <- typeEq h1 h2
    TypeEq <- typeEq i1 i2
    TypeEq <- typeEq j1 j2
    TypeEq <- typeEq k1 k2
    TypeEq <- typeEq l1 l2
    return TypeEq
typeEq (Tup13Type a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 k1 l1 m1) (Tup13Type a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2 m2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    TypeEq <- typeEq g1 g2
    TypeEq <- typeEq h1 h2
    TypeEq <- typeEq i1 i2
    TypeEq <- typeEq j1 j2
    TypeEq <- typeEq k1 k2
    TypeEq <- typeEq l1 l2
    TypeEq <- typeEq m1 m2
    return TypeEq
typeEq (Tup14Type a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 k1 l1 m1 n1) (Tup14Type a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2 m2 n2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    TypeEq <- typeEq g1 g2
    TypeEq <- typeEq h1 h2
    TypeEq <- typeEq i1 i2
    TypeEq <- typeEq j1 j2
    TypeEq <- typeEq k1 k2
    TypeEq <- typeEq l1 l2
    TypeEq <- typeEq m1 m2
    TypeEq <- typeEq n1 n2
    return TypeEq
typeEq (Tup15Type a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 k1 l1 m1 n1 o1) (Tup15Type a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2 m2 n2 o2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    TypeEq <- typeEq g1 g2
    TypeEq <- typeEq h1 h2
    TypeEq <- typeEq i1 i2
    TypeEq <- typeEq j1 j2
    TypeEq <- typeEq k1 k2
    TypeEq <- typeEq l1 l2
    TypeEq <- typeEq m1 m2
    TypeEq <- typeEq n1 n2
    TypeEq <- typeEq o1 o2
    return TypeEq
typeEq (FunType a1 b1) (FunType a2 b2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    return TypeEq
typeEq (MutType t1) (MutType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (RefType t1) (RefType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (MArrType a1) (MArrType a2) = do
    TypeEq <- typeEq a1 a2
    return TypeEq
typeEq (ParType t1) (ParType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (ElementsType t1) (ElementsType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (ConsType a1 b1) (ConsType a2 b2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    return TypeEq
typeEq NilType NilType = do
    return TypeEq
typeEq (TupleType t1) (TupleType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (IVarType t1) (IVarType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (FValType t1) (FValType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq _ _ = Nothing

showTup :: [String] -> String
showTup as =  "(" ++ intercalate "," as ++ ")"

type family TargetType n a where
  TargetType n ()              = ()
  TargetType n Bool            = Bool
  TargetType n Word8           = Word8
  TargetType n Int8            = Int8
  TargetType n Word16          = Word16
  TargetType n Int16           = Int16
  TargetType n Word32          = Word32
  TargetType n Int32           = Int32
  TargetType n Word64          = Word64
  TargetType n Int64           = Int64
  TargetType n WordN           = GenericInt U n
  TargetType n IntN            = GenericInt S n
  TargetType n Float           = Float
  TargetType n Double          = Double
  TargetType n (Complex a)     = Complex (TargetType n a)
  TargetType n [a]             = TargetArr n (TargetType n a)
  TargetType n (a,b)           = (TargetType n a, TargetType n b)
  TargetType n (a,b,c)         = (TargetType n a, TargetType n b, TargetType n c)
  TargetType n (a,b,c,d)       = (TargetType n a, TargetType n b, TargetType n c, TargetType n d)
  TargetType n (a,b,c,d,e)     = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e)
  TargetType n (a,b,c,d,e,f)   = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f)
  TargetType n (a,b,c,d,e,f,g) = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f, TargetType n g)
  TargetType n (a,b,c,d,e,f,g,h) = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f, TargetType n g, TargetType n h)
  TargetType n (a,b,c,d,e,f,g,h,i) = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f, TargetType n g, TargetType n h, TargetType n i)
  TargetType n (a,b,c,d,e,f,g,h,i,j) = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f, TargetType n g, TargetType n h, TargetType n i, TargetType n j)
  TargetType n (a,b,c,d,e,f,g,h,i,j,k) = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f, TargetType n g, TargetType n h, TargetType n i, TargetType n j, TargetType n k)
  TargetType n (a,b,c,d,e,f,g,h,i,j,k,l) = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f, TargetType n g, TargetType n h, TargetType n i, TargetType n j, TargetType n k, TargetType n l)
  TargetType n (a,b,c,d,e,f,g,h,i,j,k,l,m) = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f, TargetType n g, TargetType n h, TargetType n i, TargetType n j, TargetType n k, TargetType n l, TargetType n m)
  TargetType n (a,b,c,d,e,f,g,h,i,j,k,l,m,n') = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f, TargetType n g, TargetType n h, TargetType n i, TargetType n j, TargetType n k, TargetType n l, TargetType n m, TargetType n n')
  TargetType n (a,b,c,d,e,f,g,h,i,j,k,l,m,n',o) = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f, TargetType n g, TargetType n h, TargetType n i, TargetType n j, TargetType n k, TargetType n l, TargetType n m, TargetType n n', TargetType n o)
  TargetType n (IORef a)       = IORef (TargetType n a)
  TargetType n (MArr a)        = MArr (TargetType n a)
  TargetType n (Elements a)    = Elements (TargetType n a)
  TargetType n (RTuple (a:*b)) = RTuple (TargetType n a :* TargetType n b)
  TargetType n (RTuple TNil)   = Tuple TNil
  TargetType n (Tuple a)       = Tuple (TargetType n a)
  TargetType n (IV a)          = IV (TargetType n a)
  TargetType n (FVal a)        = FVal (TargetType n a)

-- | The set of supported types
class (Eq a, Show a, Typeable a, Show (Size a), Lattice (Size a), TypeF a) => Type a
  where
    -- | Gives the type representation a value.
    typeRep  :: TypeRep a
    sizeOf   :: a -> Size a
    toTarget :: BitWidth n -> a -> TargetType n a

instance Type ()      where typeRep = UnitType;          sizeOf _ = AnySize;      toTarget _ = id
instance Type Bool    where typeRep = BoolType;          sizeOf _ = AnySize;      toTarget _ = id
instance Type Word8   where typeRep = IntType U N8;      sizeOf = singletonRange; toTarget _ = id
instance Type Int8    where typeRep = IntType S N8;      sizeOf = singletonRange; toTarget _ = id
instance Type Word16  where typeRep = IntType U N16;     sizeOf = singletonRange; toTarget _ = id
instance Type Int16   where typeRep = IntType S N16;     sizeOf = singletonRange; toTarget _ = id
instance Type Word32  where typeRep = IntType U N32;     sizeOf = singletonRange; toTarget _ = id
instance Type Int32   where typeRep = IntType S N32;     sizeOf = singletonRange; toTarget _ = id
instance Type Word64  where typeRep = IntType U N64;     sizeOf = singletonRange; toTarget _ = id
instance Type Int64   where typeRep = IntType S N64;     sizeOf = singletonRange; toTarget _ = id
instance Type WordN   where typeRep = IntType U NNative; sizeOf = singletonRange; toTarget = fromWordN
instance Type IntN    where typeRep = IntType S NNative; sizeOf = singletonRange; toTarget = fromIntN
instance Type Float   where typeRep = FloatType;         sizeOf _ = AnySize;      toTarget _ = id
instance Type Double  where typeRep = DoubleType;        sizeOf _ = AnySize;      toTarget _ = id

instance (Type a, RealFloat a) => Type (Complex a)
  where
    typeRep             = ComplexType typeRep
    sizeOf _            = AnySize
    toTarget _ (_ :+ _) = error "TODO" -- toTarget n r :+ toTarget n i

instance Type a => Type [a]
  where
    typeRep       = ArrayType typeRep
    sizeOf as     = singletonRange (genericLength as) :> unions (map sizeOf as)
    toTarget n as = TargetArr (genericLen n as) $ map (toTarget n) as

instance (Type a, Type b) => Type (a,b)
  where
    typeRep = Tup2Type typeRep typeRep

    sizeOf (a,b) =
        ( sizeOf a
        , sizeOf b
        )

    toTarget n (a,b) =
        ( toTarget n a
        , toTarget n b
        )

instance (Type a, Type b, Type c) => Type (a,b,c)
  where
    typeRep = Tup3Type typeRep typeRep typeRep

    sizeOf (a,b,c) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        )

    toTarget n (a,b,c) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        )

instance (Type a, Type b, Type c, Type d) => Type (a,b,c,d)
  where
    typeRep = Tup4Type typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        )

    toTarget n (a,b,c,d) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        )

instance (Type a, Type b, Type c, Type d, Type e) => Type (a,b,c,d,e)
  where
    typeRep = Tup5Type typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        )

    toTarget n (a,b,c,d,e) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f) => Type (a,b,c,d,e,f)
  where
    typeRep = Tup6Type typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        )

    toTarget n (a,b,c,d,e,f) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f, Type g) => Type (a,b,c,d,e,f,g)
  where
    typeRep = Tup7Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f,g) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        , sizeOf g
        )

    toTarget n (a,b,c,d,e,f,g) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        , toTarget n g
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f, Type g, Type h) => Type (a,b,c,d,e,f,g,h)
  where
    typeRep = Tup8Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f,g,h) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        , sizeOf g
        , sizeOf h
        )

    toTarget n (a,b,c,d,e,f,g,h) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        , toTarget n g
        , toTarget n h
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f, Type g, Type h, Type i) => Type (a,b,c,d,e,f,g,h,i)
  where
    typeRep = Tup9Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f,g,h,i) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        , sizeOf g
        , sizeOf h
        , sizeOf i
        )

    toTarget n (a,b,c,d,e,f,g,h,i) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        , toTarget n g
        , toTarget n h
        , toTarget n i
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f, Type g, Type h, Type i, Type j) => Type (a,b,c,d,e,f,g,h,i,j)
  where
    typeRep = Tup10Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f,g,h,i,j) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        , sizeOf g
        , sizeOf h
        , sizeOf i
        , sizeOf j
        )

    toTarget n (a,b,c,d,e,f,g,h,i,j) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        , toTarget n g
        , toTarget n h
        , toTarget n i
        , toTarget n j
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f, Type g, Type h, Type i, Type j, Type k) => Type (a,b,c,d,e,f,g,h,i,j,k)
  where
    typeRep = Tup11Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f,g,h,i,j,k) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        , sizeOf g
        , sizeOf h
        , sizeOf i
        , sizeOf j
        , sizeOf k
        )

    toTarget n (a,b,c,d,e,f,g,h,i,j,k) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        , toTarget n g
        , toTarget n h
        , toTarget n i
        , toTarget n j
        , toTarget n k
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f, Type g, Type h, Type i, Type j, Type k, Type l) => Type (a,b,c,d,e,f,g,h,i,j,k,l)
  where
    typeRep = Tup12Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f,g,h,i,j,k,l) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        , sizeOf g
        , sizeOf h
        , sizeOf i
        , sizeOf j
        , sizeOf k
        , sizeOf l
        )

    toTarget n (a,b,c,d,e,f,g,h,i,j,k,l) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        , toTarget n g
        , toTarget n h
        , toTarget n i
        , toTarget n j
        , toTarget n k
        , toTarget n l
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f, Type g, Type h, Type i, Type j, Type k, Type l, Type m) => Type (a,b,c,d,e,f,g,h,i,j,k,l,m)
  where
    typeRep = Tup13Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f,g,h,i,j,k,l,m) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        , sizeOf g
        , sizeOf h
        , sizeOf i
        , sizeOf j
        , sizeOf k
        , sizeOf l
        , sizeOf m
        )

    toTarget n (a,b,c,d,e,f,g,h,i,j,k,l,m) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        , toTarget n g
        , toTarget n h
        , toTarget n i
        , toTarget n j
        , toTarget n k
        , toTarget n l
        , toTarget n m
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f, Type g, Type h, Type i, Type j, Type k, Type l, Type m,Type n') => Type (a,b,c,d,e,f,g,h,i,j,k,l,m,n')
  where
    typeRep = Tup14Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f,g,h,i,j,k,l,m,n') =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        , sizeOf g
        , sizeOf h
        , sizeOf i
        , sizeOf j
        , sizeOf k
        , sizeOf l
        , sizeOf m
        , sizeOf n'
        )

    toTarget n (a,b,c,d,e,f,g,h,i,j,k,l,m,n') =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        , toTarget n g
        , toTarget n h
        , toTarget n i
        , toTarget n j
        , toTarget n k
        , toTarget n l
        , toTarget n m
        , toTarget n n'
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f, Type g, Type h, Type i, Type j, Type k, Type l, Type m, Type n', Type o) => Type (a,b,c,d,e,f,g,h,i,j,k,l,m,n',o)
  where
    typeRep = Tup15Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f,g,h,i,j,k,l,m,n',o) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        , sizeOf g
        , sizeOf h
        , sizeOf i
        , sizeOf j
        , sizeOf k
        , sizeOf l
        , sizeOf m
        , sizeOf n'
        , sizeOf o
        )

    toTarget n (a,b,c,d,e,f,g,h,i,j,k,l,m,n',o) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        , toTarget n g
        , toTarget n h
        , toTarget n i
        , toTarget n j
        , toTarget n k
        , toTarget n l
        , toTarget n m
        , toTarget n n'
        , toTarget n o
        )

instance (Type a, Show (IORef a)) => Type (IORef a)
  where
    typeRep = RefType typeRep

    sizeOf _ = universal

    toTarget = error "toTarget: IORef"  -- TODO Requires IO

instance Type a => Type (MArr a)
  where
    typeRep = MArrType typeRep

    sizeOf _ = universal

    toTarget = error "toTarget: MArr"  -- TODO Requires IO

instance Type a => Type (Elements a)
  where
    typeRep = ElementsType typeRep

    sizeOf _ = universal

    toTarget = error "toTarget: Elements"  -- TODO Requires IO

instance (Type a, Type (RTuple a), Eq (Tuple a), Size (Tuple a) ~ Size (RTuple a))
  => Type (Tuple a)
  where
    typeRep = TupleType typeRep

    sizeOf (Tuple xs) = sizeOf xs

    toTarget = error "toTarget: Tuple"

instance Type a => Type (IV a)
  where
    typeRep = IVarType typeRep

    sizeOf _ = universal

    toTarget = error "toTarget: IVar" -- TODO Requires IO

instance Type a => Type (FVal a)
  where
    typeRep = FValType typeRep

    sizeOf _ = universal

    toTarget = error "toTarget: FVal" -- TODO

-- | Extend the class Type to higher order types
class (Typeable a, Show (Size a), Lattice (Size a)) => TypeF a where
  typeRepF :: TypeRep a
  sizeOfF :: a -> Size a

instance {-# OVERLAPPING #-} (TypeF a, TypeF b) => TypeF (a -> b) where
  typeRepF = FunType typeRepF typeRepF
  sizeOfF f = universal

instance {-# OVERLAPPING #-} (Type a, Typeable b, TypeF (RTuple b)) => TypeF (RTuple (a :* b))
  where
    typeRepF = ConsType typeRep typeRepF
    sizeOfF (x :* xs) = (sizeOf x, sizeOfF xs)

instance {-# OVERLAPPING #-} TypeF (RTuple TNil)
  where
    typeRepF = NilType
    sizeOfF _ = universal

instance {-# OVERLAPPABLE #-} (Typeable a, Type a) => TypeF a where
  typeRepF = typeRep
  sizeOfF = sizeOf

--------------------------------------------------------------------------------
-- * Sized types
--------------------------------------------------------------------------------

data AnySize = AnySize
    deriving (Eq, Show, Ord)

anySizeFun :: AnySize -> AnySize
anySizeFun AnySize = AnySize

anySizeFun2 :: AnySize -> AnySize -> AnySize
anySizeFun2 AnySize AnySize = AnySize

instance Num AnySize
  where
    fromInteger _ = AnySize
    abs           = anySizeFun
    signum        = anySizeFun
    (+)           = anySizeFun2
    (-)           = anySizeFun2
    (*)           = anySizeFun2

instance Lattice AnySize
  where
    bot  = AnySize
    top  = AnySize
    (\/) = anySizeFun2
    (/\) = anySizeFun2

type family Size a where
  Size ()              = AnySize
  Size Bool            = AnySize
  Size Word8           = Range Word8
  Size Int8            = Range Int8
  Size Word16          = Range Word16
  Size Int16           = Range Int16
  Size Word32          = Range Word32
  Size Int32           = Range Int32
  Size Word64          = Range Word64
  Size Int64           = Range Int64
  Size WordN           = Range WordN
  Size IntN            = Range IntN
  Size Float           = AnySize
  Size Double          = AnySize
  Size (Complex a)     = AnySize
  Size [a]             = Range Length :> Size a
  Size (TargetArr n a) = Range (GenericInt U n) :> Size a
  Size (a,b)           = (Size a, Size b)
  Size (a,b,c)         = (Size a, Size b, Size c)
  Size (a,b,c,d)       = (Size a, Size b, Size c, Size d)
  Size (a,b,c,d,e)     = (Size a, Size b, Size c, Size d, Size e)
  Size (a,b,c,d,e,f)   = (Size a, Size b, Size c, Size d, Size e, Size f)
  Size (a,b,c,d,e,f,g) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g)
  Size (a,b,c,d,e,f,g,h) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g, Size h)
  Size (a,b,c,d,e,f,g,h,i) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g, Size h, Size i)
  Size (a,b,c,d,e,f,g,h,i,j) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g, Size h, Size i, Size j)
  Size (a,b,c,d,e,f,g,h,i,j,k) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g, Size h, Size i, Size j, Size k)
  Size (a,b,c,d,e,f,g,h,i,j,k,l) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g, Size h, Size i, Size j, Size k, Size l)
  Size (a,b,c,d,e,f,g,h,i,j,k,l,m) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g, Size h, Size i, Size j, Size k, Size l, Size m)
  Size (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g, Size h, Size i, Size j, Size k, Size l, Size m, Size n)
  Size (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g, Size h, Size i, Size j, Size k, Size l, Size m, Size n, Size o)
  Size (a -> b)        = (Size a, Size b)
  Size (Mut a)         = Size a
  Size (IORef a)       = Size a
  Size (MArr a)        = Range Length :> Size a
  Size (Par a)         = Size a
  Size (Elements a)    = Range Length :> Size a
  Size (RTuple (a :* b)) = (Size a, Size (RTuple b))
  Size (RTuple TNil)   = Size ()
  Size (Tuple a)       = Size (RTuple a)
  Size (IV a)          = Size a
  Size (FVal a)        = Size a

tIntN :: Patch IntN IntN
tIntN = id

tWordN :: Patch WordN WordN
tWordN = id

tIndex :: Patch Index Index
tIndex  = id

tLength :: Patch Length Length
tLength = id

tArr :: Patch a a -> Patch [a] [a]
tArr _ = id

max_stars_repo_name: pjonsson/feldspar-language

max_issues_repo_name: pjonsson/feldspar-language

max_forks_repo_name: pjonsson/feldspar-language


text:
{-# LANGUAGE OverloadedStrings, NoImplicitPrelude, BangPatterns #-}
import ClassyPrelude hiding (head, tail)
import Prelude (head, tail)
import Test.Hspec
import Test.QuickCheck
import qualified Criterion.Main as Criterion
import Lens.Micro

import Control.Exception (evaluate)
import qualified Data.Vector.Storable as SVec
import qualified Data.Vector.Generic as Vec
import qualified Data.Binary as Bin

import NLP.Albemarle
import qualified NLP.Albemarle.Tokens as Tokens
import NLP.Albemarle.Dict (Dict, counts, ids)
import qualified NLP.Albemarle.Dict as Dict
import NLP.Albemarle.LSA (termvectors, topicweights)
import qualified NLP.Albemarle.LSA as LSA
import qualified NLP.Albemarle.Bench.Maps
import qualified NLP.Albemarle.Test.Dict
import qualified NLP.Albemarle.Test.GloVe
import qualified NLP.Albemarle.Test.LanguageModelEntropy
import qualified NLP.Albemarle.Examples.Webpage

import System.CPUTime
import Text.Printf
import Data.Text.Encoding.Error (lenientDecode)
import System.Directory (doesFileExist)

import qualified Data.Text as Text
import qualified Data.HashSet as HashSet
import qualified Data.HashMap.Strict as HashMap
import System.IO.Streams (InputStream, OutputStream)
import qualified System.IO.Streams as Streams
import Numeric.LinearAlgebra (Matrix)
import qualified Numeric.LinearAlgebra as HMatrix

main :: IO ()
main = hspec $ do
  NLP.Albemarle.Examples.Webpage.test
  NLP.Albemarle.Test.Dict.test
  NLP.Albemarle.Test.GloVe.test
  NLP.Albemarle.Test.LanguageModelEntropy.test

  let sentences = words <$> [
        "Maybe not today. Maybe not tomorrow. But soon.",
        "Pay no attention to the man behind the curtain.",
        "Life is like a box of chocolates."]:: [[Text]]

  describe "Streaming (semi-Gensim) Style Topic Analysis" $ do
    let mean :: SVec.Vector Double -> Double
        mean x = Vec.sum x / fromIntegral (Vec.length x)
        -- Root mean squared error
        rmse l r = mean (Vec.zipWith (\x y -> (x-y)**2) (flat l) (flat r)) ** 0.5
        -- Mean signal to noise ratio
        -- - we tank the PSNR because most things are really close to 0
        -- - in fact we avoid handling 0's altogether
        msnr l r = mean $ Vec.zipWith (\x y -> abs $ x-y / max 1 (min x y)) (flat l) (flat r)
        flat = HMatrix.flatten
        mult u s vt = mconcat [u, HMatrix.diag s, HMatrix.tr vt] :: HMatrix.Matrix Double

    it "performs sparse stochastic truncated SVD with SVDLIBC" $ do
      let termdoc = "termdoc.small.nonzero.txt"
      [zippedfile, originalfile] <- sequence $ doesFileExist <$> [termdoc++".gz", termdoc]
      when ( zippedfile && not originalfile ) $
        Streams.withFileAsInput "termdoc.small.nonzero.txt.gz" $ \infl ->
          Streams.withFileAsOutput "termdoc.small.nonzero.txt" $ \outfl ->
            Streams.gunzip infl >>= Streams.connectTo outfl
      matrix <- HMatrix.loadMatrix "termdoc.small.nonzero.txt"
      let (u, sigma, vt) = LSA.batchLSA 100 $ LSA.sparsify matrix
      -- typically -> RMSE: 0.06464712163523892
      -- printf "RMSE: %f\n" $ rmse (mconcat [u, HMatrix.diag sigma, HMatrix.tr vt]) matrix
      rmse (mult u sigma vt) matrix < 0.12 `shouldBe` True
      -- typically -> MSNR: 0.010548326765305554
      -- printf "MSNR: %f\n" $ msnr (mconcat [u, HMatrix.diag sigma, HMatrix.tr vt]) matrix
      msnr (mult u sigma vt) matrix < 0.02 `shouldBe` True

    it "performs topic analysis starting from text" $ do
      (final_dict, model) <- Streams.withFileAsInput "kjv.verses.txt.gz" $ \file ->
        Streams.gunzip file
        >>= Streams.lines
        >>= Streams.decodeUtf8With lenientDecode
        >>= Streams.map Tokens.wordTokenize
        >>= Streams.chunkList 373 -- Yep, I'm making this stuff up.
        >>= Streams.map (\chunk -> let
          dict = Dict.dictifyAllWords chunk
          sparsem = Dict.asSparseMatrix dict chunk
          lsa = LSA.lsa 222 sparsem -- Too many topics. Should not cause errors
          in (dict, lsa))
        >>= Streams.fold (\(!d1, !lsa1) (d2, lsa2) -> let
          d3 = Dict.filterDict 2 0.5 100 $ d1 <> d2 -- Not nearly enough words
          lsa3 = LSA.rebase d1 d3 lsa1 <> LSA.rebase d2 d3 lsa2
          in (d3, lsa3)) (mempty, mempty)

      -- It should use all 100 words allowed plus the unknown
      HashMap.size (final_dict^.counts) `shouldBe` 101
      -- It should have a full size LSA as well
      HMatrix.size (model^.termvectors) `shouldBe` (222, 101)
      -- Plus topic weights
      HMatrix.size (model^.topicweights) `shouldBe` 222

  describe "Monoid style Topic Analysis" $
    it "creates LSA Models" $ do
      let dict = Dict.dictifyAllWords sentences
      let lsavecs = LSA.lsa 2
            $ Dict.asSparseMatrix dict sentences
      -- Sadly, I can't think of much to assert in this test so let's use size
      -- There are 21 unique words plus one unknown
      HMatrix.size (lsavecs^.termvectors) `shouldBe` (2,22)
      -- It should use both topics
      HMatrix.size (lsavecs^.topicweights) `shouldBe` 2

-- Thanks to Ying He for the following example text and proper
-- tokenizations.
--weightGain :: Text
--weightGain = unwords [
--  "Independent of current body composition, IGF-I levels at 5 yr were ",
--  "significantly associated with rate of weight gain between 0-2 yr",
--  "(beta = 0.19; P < 0.0005), and children who showed postnatal",
--  "catch-up growth (i.e. those who showed gains in weight or length",
--  "between 0-2 yr by >0.67 SD score) had higher IGF-I levels than other",
--  "children (P = 0.02)."]

--weightGainTokens :: [Text]
--weightGainTokens = words $ unwords [
--  "Independent of current body composition , IGF - I levels at 5 yr were",
--  "significantly associated with rate of weight gain between 0 - 2 yr ( beta",
--  "= 0.19 ; P < 0.0005 ) , and children who showed postnatal catch - up",
--  "growth ( i.e . those who showed gains in weight or length between 0 - 2 yr",
--  "by > 0.67 SD score ) had higher IGF - I levels than other children",
--  "( P = 0.02 ) ."] -- i.e. is wrong, but we're calling this close enough.

ext: hs

max_stars_repo_name: SeanTater/albemarle

max_issues_repo_name: SeanTater/albemarle

max_forks_repo_name: SeanTater/albemarle


text:
{-# LANGUAGE FlexibleContexts, OverloadedLists, OverloadedStrings, UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Main (
	main,
	testXor, testClassify, testIris, testMnist
	) where

import Prelude.Unicode

import Control.DeepSeq
import Control.Monad
import Control.Monad.State.Strict
import Control.Monad.Morph
import qualified Data.Attoparsec.Text as A
import qualified Data.Text.IO as T
import qualified Data.Vector as V
import System.Random (mkStdGen)
import Test.Hspec
import Numeric.LinearAlgebra hiding (conv2, conv)
import Text.Format

import Numeric.Trainee.Data
import Numeric.Trainee.Neural
import Numeric.Trainee.Gradee (reshapeVec, flattenMat, concatVecs)

main ∷ IO ()
main = hspec $
	describe "training neural network" $ do
		it "should approximate xor function" testXor
		it "should classify objects" testClassify
		it "should support 3 classes" testIris

testXor ∷ IO ()
testXor = do
	n ← return $ netSeed (mkStdGen 0) $ fc sigma 2 2 ⭃ fc sigma 2 2 ⭃ fc sigma 2 1 ∷ IO (Net Double)
	(e, n') ← runLearnT n $ trainUntil 5.0 10000 4 1e-4 squared xorSamples
	e `shouldSatisfy` (≤ 1e-4)
	mapM_ (shouldPass n' 0.1) xorSamples

testClassify ∷ IO ()
testClassify = do
	n ← return $ netSeed (mkStdGen 0) $ fc sigma 4 4 ⭃ fc sigma 4 2 ⭃ fc sigma 2 1 ∷ IO (Net Double)
	let
		cases ∷ [(String, Vector Double → Vector Double)]
		cases = [
			("adult+stretch", fn $ \[_, _, act, age] → act ≡ 0.0 ∨ age ≡ 0.0),
			("adult-stretch", fn $ \[_, _, act, age] → act ≡ 0.0 ∧ age ≡ 0.0),
			("yellow-small+adult-stretch", fn $ \[color, sz, act, age] → (color ≡ 0.0 ∧ sz ≡ 0.0) ∨ (act ≡ 0.0 ∧ age ≡ 0.0)),
			("yellow-small", fn $ \[color, sz, _, _] → color ≡ 0.0 ∧ sz ≡ 0.0)]
		fn ∷ ([Double] → Bool) → Vector Double → Vector Double
		fn f = vector ∘ return ∘ fromIntegral ∘ fromEnum ∘ f ∘ toList
	forM_ cases $ \(name, fun) → do
		classes ← readBalloonSamples $ "data/classify/balloon/{name}.data" ~~ ("name" ~% name)
		(e, n') ← runLearnT n $ trainUntil 10.0 1000 10 1e-4 squared classes
		e `shouldSatisfy` (≤ 1e-4)
		mapM_ (shouldPass n' 0.1) [xs ⇢ fun xs |
			xs ← map vector (replicateM 4 [0.0, 1.0])]

instance Show (Vector a) ⇒ FormatBuild (Vector a)

testIris ∷ IO ()
testIris = do
	n ← return $ netSeed (mkStdGen 0) $ fc sigma 4 12 ⭃ fc sigma 12 3 ∷ IO (Net Double)
	classes ← readIrisData "data/classify/iris/iris.data"
	(_, n') ← runLearnT n $ hoist (`evalStateT` (rightAnswers n classes, 0)) $ learnIris classes
	let
		failedSamples = filter (not ∘ rightClass n' ∘ snd) $ zip ([1..] ∷ [Integer]) (V.toList classes)
	putStrLn "--- Done. ---"
	putStrLn "Failed samples:"
	forM_ failedSamples $ \(i, Sample inp outp) → putStrLn $ "{n}\t{input} → {output} ≢ {right}"
		~~ ("n" ~% i)
		~~ ("input" ~% inp)
		~~ ("output" ~% eval n' inp)
		~~ ("right" ~% outp)
	length failedSamples `shouldSatisfy` (≤ 2)
	where
		learnIris ∷ Samples (Vector Double) (Vector Double) → StateT (Net Double) (StateT (Int, Int) IO) ()
		learnIris classes = do
			e ← fmap last $ replicateM 100 $ trainEpoch 1.0 150 crossEntropy classes
			n' ← get
			let
				ans = rightAnswers n' classes
			lift $ modify (\(ans', long') → (ans, if ans ≡ ans' then succ long' else 0))
			liftIO $ putStrLn $ "correct answers: {rights}/{total}; error = {e}"
				~~ ("e" ~% e)
				~~ ("rights" ~% ans)
				~~ ("total" ~% length classes)
			long' ← lift $ gets snd
			when (long' ≤ 10 ∧ e > 0.1) $ learnIris classes

testMnist ∷ IO ()
testMnist = do
	n ← net $
		return (computee (reshapeVec 28)) ⭃ ndup 1 ⭃
		npar 1 (pad2 2 2) ⭃ dconv2 sigma 1 32 (5, 5) ⭃ npar 32 (maxPool2 2 2) ⭃
		npar 32 (pad2 2 2) ⭃ dconv2 sigma 32 64 (5, 5) ⭃ npar 64 (maxPool2 2 2) ⭃
		npar 64 (return $ computee flattenMat) ⭃ return (computee concatVecs) ⭃
		fc sigma (7 * 7 * 64) 1024 ⭃
		fc sigma 1024 10
		∷ IO (Net Double)
	putStrLn "reading train data"
	smps ← readMnist "data/classify/mnist/train.csv"
	putStrLn $ "loaded {0} samples" ~~ length smps
	(_, n') ← runLearnT n $ learnMnist smps
	print n'
	where
		learnMnist ∷ Samples (Vector Double) (Vector Double) → StateT (Net Double) IO ()
		learnMnist smps = do
			ixs ← shuffleList [0 .. V.length smps - 1]
			es ← forM ixs $ \i → do
				-- let
				-- 	b = V.fromList $ map (smps V.!) is
				e ← trainOnce 0.001 crossEntropy (smps V.! i)
				liftIO $ putStrLn $ "error: {}" ~~ e
				return e
			let
				e = avg es
			liftIO $ putStrLn $ "error: {}" ~~ e
			when (e > 0.1) $ learnMnist smps

rightClass ∷ Net Double → Sample (Vector Double) (Vector Double) → Bool
rightClass n_ (Sample i o) = maxIndex (eval n_ i) ≡ maxIndex o

rightAnswers ∷ Net Double → Samples (Vector Double) (Vector Double) → Int
rightAnswers n_ = V.length ∘ V.filter (rightClass n_)

xorSamples ∷ Samples (Vector Double) (Vector Double)
xorSamples = samples [
	[0, 0] ⇢ [0],
	[1, 1] ⇢ [0],
	[1, 0] ⇢ [1],
	[0, 1] ⇢ [1]]

readIrisData ∷ FilePath → IO (Samples (Vector Double) (Vector Double))
readIrisData fpath = parseCsvFile False fpath $ do
	is ← mapM (col_ >=> read_ >=> (return ∘ (* 0.1))) [0 .. 3]
	os ← col_ 4 >>= class_ ["Iris-setosa", "Iris-versicolor", "Iris-virginica"]
	sample_ is os

readBalloonSamples ∷ FilePath → IO (Samples (Vector Double) (Vector Double))
readBalloonSamples fpath = parseCsvFile False fpath $ do
	is ← sequence [
		col_ 0 >>= enum_ ["yellow", "purple"],
		col_ 1 >>= enum_ ["small", "large"],
		col_ 2 >>= enum_ ["stretch", "dip"],
		col_ 3 >>= enum_ ["adult", "child"]]
	os ← col_ 4 >>= enum_ ["f", "t"] >>= single_
	sample_ is os

readMnist ∷ FilePath → IO (Samples (Vector Double) (Vector Double))
readMnist fpath = do
	cts ← T.readFile fpath
	either error return $ A.parseOnly mnist cts
	where
		mnist ∷ A.Parser (Samples (Vector Double) (Vector Double))
		mnist = do
			_ ← A.manyTill A.anyChar A.endOfLine
			fmap samples $ A.many' $ do
				(f:fs) ← A.sepBy A.decimal (A.char ',') <* A.endOfLine
				let
					is = fromList $ map ((/ 255.0) ∘ fromIntegral) fs
					os = fromList $ replicate f 0.0 ++ [1.0] ++ replicate (10 - f - 1) 0.0
				is `deepseq` os `deepseq` return (Sample is os)

shouldPass ∷ Net Double → Double → Sample (Vector Double) (Vector Double) → IO ()
shouldPass n ε (Sample xs ys) = when (err > ε) $ expectationFailure msg where
	msg = show xs ++ " -> " ++ show res ++ " should be " ++ show ys
	res = eval n xs
	err = vecSize (res - ys)
	vecSize v = sqrt (dot v v)

max_stars_repo_name: mvoidex/trainee

max_issues_repo_name: mvoidex/trainee

max_forks_repo_name: mvoidex/trainee


text:
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE OverloadedStrings     #-}
module Taiji.Pipeline.ATACSeq.Functions.QC
    ( plotFragDistr
    , plotAlignQC
    , plotDupRate
    , plotTE
    , plotPeakCor

    , computeTE
    , fragDistr
    , alignStat
    , peakSignal
    ) where

import Language.Javascript.JMacro
import           Bio.Pipeline.Report
import Bio.Data.Bed.Utils
import Bio.Data.Bed.Types
import Bio.RealWorld.GENCODE
import Bio.Data.Bed
import Bio.Utils.Functions (slideAverage)
import qualified Data.ByteString.Char8 as B
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Unboxed.Mutable as UM
import Data.Binary
import           Bio.Pipeline.Utils
import qualified Data.Map.Strict               as M
import qualified Data.Text as T
import Bio.HTS
import Statistics.Correlation (pearsonMatByRow)
import Statistics.Matrix (fromRows, toRowLists)

import           Taiji.Pipeline.ATACSeq.Types
import Taiji.Utils.Plot.ECharts
import Taiji.Utils (readGenesValidated)
import           Taiji.Prelude
import qualified Taiji.Utils.DataFrame as DF

plotAlignQC :: [(String, Double, Double)]
            -> Maybe EChart
plotAlignQC xs
    | null xs = Nothing
    | otherwise = Just $ yAxisLabel "Percent" >+> options >+> toolbox >+> plt
  where
    plt = (bar df){_height=480,_width=w}
    w = max 480 $ fromIntegral (length xs) * 30 + 40
    options = [jmacroE| { grid: {top: 60} } |]
    df = DF.mkDataFrame ["mappable", "chrM"] names $
        [p, chrM]
    (names, p, chrM) = unzip3 $
        map (\(a,b,c) -> (T.pack a, 100*b, 100*c)) xs

-- | Return name, percent_mapped_reads and percent_chrM_reads.
alignStat :: ATACSeq S (Either (File tags1 'Bam) (File tags2 'Bam))
          -> IO (String, Double, Double)
alignStat e = do
    stats <- either bamStat bamStat $ e^.replicates._2.files
    let p = fromIntegral (_mapped_tags stats) / fromIntegral (_total_tags stats)
        chrM = case lookup "chrM" (_mapped_tags_by_chrom stats) of
            Nothing -> case lookup "M" (_mapped_tags_by_chrom stats) of
                Nothing -> 0
                Just x -> fromIntegral x / fromIntegral (_mapped_tags stats)
            Just x -> fromIntegral x / fromIntegral (_mapped_tags stats)
    return (nm, p, chrM)
  where
    nm = printf "%s_rep%d" (T.unpack $ e^.eid) (e^.replicates._1)

plotDupRate :: [ATACSeq S (Either (File tags1 'Bam) (File tags2 'Bam))]
            -> [EChart]
plotDupRate [] = []
plotDupRate input =
    [ yAxisLabel "Usable reads (Million)" >+> options >+> toolbox >+> (bar totalReads){_height=480,_width=w}
    , yAxisLabel "Percent duplicated" >+> options >+> toolbox >+> (bar dupRate){_height=480,_width=w}
    ]
  where
    w = max 480 $ fromIntegral (length input) * 20 + 40
    options = [jmacroE| { grid: {top: 60} }|]
    (dupRate, totalReads) = DF.unzip $ DF.mkDataFrame [""] names [dat]
    (names, dat) = unzip $ mapMaybe getDupRate input
    getDupRate e = case either getResult getResult (e^.replicates._2.files) of
        Nothing -> Nothing
        Just r ->  Just
            (T.pack $ printf "%s_rep%d" (T.unpack $ e^.eid) (e^.replicates._1), r)
    getResult fl = do
        total <- fmap (read . T.unpack) $ M.lookup "READ" $ fl^.info
        dup <- fmap (read . T.unpack) $ M.lookup "DUPLICATE TOTAL" $ fl^.info
        return (100 * dup / total, total / 1000000)

peakSignal :: ATACSeqConfig config
           => ( ATACSeq S (Either (File '[Gzip] 'Bed) (File '[PairedEnd, Gzip] 'Bed))
              , File '[Gzip] 'Bed )   -- ^ Reference peak list
           -> ReaderT config IO (ATACSeq S (File '[] 'Other))
peakSignal (atac, peakFl) = do
    dir <- asks _atacseq_output_dir >>= getPath . (<> (asDir "/Peaks"))
    let output = printf "%s/%s_rep%d.signal.bin" dir (T.unpack $ atac^.eid)
            (atac^.replicates._1)
    atac & replicates.traverse.files %%~ liftIO . ( \fl -> do
        regions <- runResourceT $ runConduit $ streamBedGzip (peakFl^.location) .|
            concatMapC (splitBedBySizeLeft 500) .| sinkList :: IO [BED3]
        let readInput = either (streamBedGzip . (^.location))
                (\x -> streamBedGzip (x^.location) .| concatMapC f)
        res <- runResourceT $ runConduit $ readInput fl .|
            rpkmBed regions :: IO (U.Vector Double)
        encodeFile output res
        return $ location .~ output $ emptyFile )
  where
    f :: BED -> [BED]
    f x = [ BED (x^.chrom) (x^.chromStart) (x^.chromStart + 1) (x^.name) Nothing (Just True)
          , BED (x^.chrom) (x^.chromEnd - 1) (x^.chromEnd) (x^.name) Nothing (Just False) ]

-- | Compute correlation between experiments.
plotPeakCor :: [ATACSeq S (File '[] 'Other)] -> IO (Maybe EChart)
plotPeakCor inputs
    | length inputs == 0 || length inputs > 100 = return Nothing
    | otherwise = do
        let names = flip map inputs $ \x ->
                (x^.eid) <> "_rep" <> T.pack (show $ x^.replicates._1)
        cor <- fmap (pearsonMatByRow . fromRows) $ forM inputs $ \input ->
            decodeFile $ input^.replicates._2.files.location
        let plt = heatmap $ DF.orderDataFrame id $
                DF.mkDataFrame names names $ toRowLists cor
        return $ Just $ addAttr (title "Pearson correlation") $ addAttr toolbox plt

plotTE :: [(T.Text, U.Vector Double)] -> [EChart]
plotTE [] = []
plotTE xs = [p1{_width=w,_height=480}, p2{_width=480,_height=480}]
  where
    p1 = addAttr toolbox $ addAttr (yAxisLabel "TSS Enrichment") $ stackBar $
        DF.mkDataFrame [""] names [map U.maximum vals]
    w = max 480 $ fromIntegral (length xs) * 30 + 40
    p2 = addAttr toolbox $ addAttr (yAxisLabel "TSS Enrichment") $
        line $ DF.mkDataFrame names (map (T.pack . show) [-2000..2000::Int]) $
        map U.toList vals
    (names, vals) = unzip xs

computeTE :: ATACSeqConfig config
          => ATACSeq S (Either (File '[Gzip] 'Bed) (File '[PairedEnd, Gzip] 'Bed))
          -> ReaderT config IO (T.Text, U.Vector Double)
computeTE input = do
    genes <- getAnnotation >>= liftIO . readGenesValidated
    let tss = flip map genes $ \g ->
            let chr = geneChrom g
                str = geneStrand g
                x = if str then geneLeft g else geneRight g
            in (chr, x, str)
        readInput = either (streamBedGzip . (^.location))
            (\x -> streamBedGzip (x^.location) .| concatMapC f)
    res <- liftIO $ runResourceT $ runConduit $
        readInput (input^.replicates._2.files) .| tssEnrichment tss
    return (input^.eid <> "_rep" <> T.pack (show $ input^.replicates._1), res)
  where
    f :: BED -> [BED]
    f x = [ BED (x^.chrom) (x^.chromStart) (x^.chromStart + 1) (x^.name) Nothing (Just True)
          , BED (x^.chrom) (x^.chromEnd - 1) (x^.chromEnd) (x^.name) Nothing (Just False) ]

-- | Transcription Start Site (TSS) Enrichment Score
-- The TSS enrichment calculation is a signal to noise calculation.
-- The reads around a reference set of TSSs are collected to
-- form an aggregate distribution of reads centered on the TSSs
-- and extending to 1000 bp in either direction (for a total of 2000bp).
-- This distribution is then normalized by taking the average
-- read depth in the 100 bps at each of the end flanks of
-- the distribution (for a total of 200bp of averaged data) and
-- calculating a fold change at each position over that average
-- read depth. This means that the flanks should start at 1,
-- and if there is high read signal at transcription start
-- sites (highly open regions of the genome) there should be an
-- increase in signal up to a peak in the middle. We take the signal
-- value at the center of the distribution after this normalization
-- as our TSS enrichment metric. Used to evaluate ATAC-seq.
--
-- 1. For each TSS, get per base coverage for the 1000 bp flanking region.
--    We will get a matrix of #TSS x 2000 bp dimension.
-- 2. Do a column sum of the matrix.
-- 3. Sum of the coverage of the endFlank (100bp) at both ends and divide
--    by 200 bp to get a normalization factor.
-- 4. divide the the normalization factor for -1900 to + 1900 bp to get per base normalized coverage.
-- 5. do a smoothing with a defined window (50bp by default) using zoo::rollmean.
-- 6. select the highest value within a window (highest_tss_flank, 50 bp by default)
--    around the TSS because the highest peak is not necessary at exactly the TSS
--    site (position 0)
tssEnrichment :: [(B.ByteString, Int, Bool)]   -- ^ A list of TSSs
              -> ConduitT BED o (ResourceT IO) (U.Vector Double)
tssEnrichment tss = mapC getCutSite .| intersectBedWith f regions .| sink
  where
    sink = do
        vec <- liftIO $ UM.replicate 4000 0
        mapM_C $ mapM_ $ UM.unsafeModify vec (+1)
        liftIO $ normalize <$> U.unsafeFreeze vec
    normalize vec = slideAverage 5 $ U.map (/bk) vec
      where
        bk = (U.sum (U.take 100 vec) + U.sum (U.drop 3900 vec)) / 200 + 0.1
    getCutSite x = BED3 (x^.chrom) i $ i + 1
      where
        i = case x^.strand of
            Just False -> x^.chromEnd - 76
            _ -> x^.chromStart + 75
    f x ys = flip map ys $ \y -> case y^.strand of
        Just False -> 3999 - (x^.chromStart - y^.chromStart)
        _ -> x^.chromStart - y^.chromStart
    regions = map ( \(chr, x, str) ->
        BED chr (x - 2000) (x + 2000) Nothing Nothing $ Just str ) tss

-- | Plot QC for fragment size distribution.
plotFragDistr :: [Maybe (T.Text, U.Vector Double)] -> [EChart]
plotFragDistr xs = flip map (catMaybes xs) $ \(nm, dat) ->
    let df = DF.mkDataFrame ["fraction"] labels [U.toList dat]
    in addAttr (yAxisLabel "Fraction") $
        addAttr (title (T.unpack nm)) (stackLine df){_width=400, _height=480}
  where
    labels = map (T.pack . show) [0..1000 :: Int]

-- | Compute fragment size distribution.
fragDistr :: ATACSeq S (Either (File tags1 'Bam) (File tags2 'Bam))
          -> IO (Maybe (T.Text, U.Vector Double))
fragDistr input = case input^.replicates._2.files of
    Left _ -> return Nothing
    Right fl -> do
        r <- runResourceT $ runConduit $
            streamBam (fl^.location) .| fragmentSizeDistr 1001
        return $ Just (nm, r)
  where
    nm = (input^.eid) <> "_rep" <> (T.pack $ show $ input^.replicates._1)

max_stars_repo_name: Taiji-pipeline/Taiji-ATAC-seq

max_issues_repo_name: Taiji-pipeline/Taiji-ATAC-seq

max_forks_repo_name: Taiji-pipeline/Taiji-ATAC-seq


text:
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLabels #-}

module NotificationCenter where

import Config
  (replaceColors,getConfig,Config(..))
import NotificationCenter.NotificationInCenter
  (DisplayingNotificationInCenter(..), showNotification, updateNoti)
import NotificationCenter.Notifications
  (NotifyState(..), startNotificationDaemon, hideAllNotis)
import NotificationCenter.Notifications.Data (Notification(..))
import NotificationCenter.Glade (glade, style)
import NotificationCenter.Button
  (Button(..), createButton, setButtonState)
import TransparentWindow
import Helpers

import Prelude

import Text.I18N.GetText
import System.Locale.SetLocale
import System.IO.Unsafe

import Data.Int (Int32(..))
import Data.Tuple.Sequence (sequenceT)
import Data.Maybe
import Data.IORef
import Data.List
import Data.Time
import Data.Time.LocalTime
import qualified Data.Text as Text
import qualified Data.ByteString.Char8 as BS
import qualified Data.Map as Map
import Data.Complex
import Data.Monoid ((<>))

import Control.Monad
import Control.Applicative
import Control.Concurrent (forkIO, threadDelay, ThreadId(..))
import Control.Concurrent.STM
  ( readTVarIO, modifyTVar', TVar(..), atomically, newTVarIO )

import System.Process (runCommand)
import System.Locale.Read
import System.Posix.Signals (sigUSR1)
import System.Posix.Daemonize (serviced, daemonize)
import System.Directory (getXdgDirectory, XdgDirectory(..))

import DBus ( fromVariant )

import GI.Gtk
       (buttonSetLabel, widgetSetHalign, widgetSetHexpand, buttonNew, setWidgetMargin, buttonSetRelief, widgetSetSizeRequest, widgetShowAll, widgetShow, widgetHide, onWidgetDestroy
       , windowSetDefaultSize, setWindowTitle, boxPackStart, boxNew
       , setWindowWindowPosition, WindowPosition(..), windowMove
       , frameSetShadowType, aspectFrameNew
       , widgetGetAllocatedHeight, widgetGetAllocatedWidth, onWidgetDraw
       , onWidgetLeaveNotifyEvent, onWidgetMotionNotifyEvent
       , widgetAddEvents, alignmentSetPadding, alignmentNew, rangeSetValue
       , scaleSetDigits, scaleSetValuePos, rangeGetValue
       , afterScaleButtonValueChanged, scaleNewWithRange, containerAdd
       , buttonBoxNew, mainQuit, onButtonActivate
       , toggleButtonGetActive, onToggleButtonToggled, buttonSetUseStock
       , toggleButtonNewWithLabel, onButtonClicked
       , buttonNewWithLabel, widgetQueueDraw, drawingAreaNew
       , windowNew, widgetDestroy, dialogRun, setAboutDialogComments
       , setAboutDialogAuthors, setAboutDialogVersion
       , setAboutDialogProgramName, aboutDialogNew, labelNew, get
       , afterWindowSetFocus, labelSetText
       , onWidgetFocusOutEvent, onWidgetKeyReleaseEvent, widgetGetParentWindow
       , onButtonClicked, windowGetScreen, boxNew, widgetSetValign)
import qualified GI.Gtk as Gtk (containerAdd, Window(..), Box(..), Label(..), Button(..))

import qualified GI.Gtk as GI (init, main)
import GI.GLib (sourceRemove, timeoutAdd, unixSignalAdd)
import GI.GLib.Constants
import GI.Gdk.Constants
import GI.Gdk.Flags (EventMask(..))
import GI.Gtk.Enums
       (Orientation(..), WindowType(..), ShadowType(..)
       , PositionType(..), ReliefStyle(..), Align(..))
import Data.GI.Base.BasicConversions (gflagsToWord)
import qualified GI.Gdk.Objects.Window

data State = State
  { stMainWindow :: Gtk.Window
  , stNotiBox :: Gtk.Box
  , stTimeLabel :: Gtk.Label
  , stDateLabel :: Gtk.Label
  , stDeleteAll :: Gtk.Button
  , stUserButtons :: [ Button ]
  , stNotiState :: TVar NotifyState
  , stDisplayingNotiList :: [ DisplayingNotificationInCenter ]
  , stNotisForMe :: [ Notification ]
  , stCenterShown :: Bool
  }

setTime :: TVar State -> IO Bool
setTime tState = do
  state <- readTVarIO tState
  now <- zonedTimeToLocalTime <$> getZonedTime
  zone <- System.Locale.Read.getCurrentLocale
  let format = Text.pack . flip (formatTime zone) now
  labelSetText (stTimeLabel state) $ format "%H:%M"
  labelSetText (stDateLabel state) $ format "%A, %x"
  return False

startSetTimeThread :: TVar State -> IO ()
startSetTimeThread tState = do
  runAfterDelay 1000 (startSetTimeThread' tState)
  return ()

startSetTimeThread' :: TVar State -> IO ()
startSetTimeThread' tState = do
  addSource (setTime tState)
  time <- fromIntegral <$> diffTimeToPicoseconds <$> utctDayTime <$> getCurrentTime
  let delay = (60 * 1000000) - ((ceiling (time / 1000000)) `mod` (1000000 * 60))
  runAfterDelay delay (startSetTimeThread' tState)
  return ()

createNotiCenter :: TVar State -> Config -> IO ()
createNotiCenter tState config = do
  (objs, _) <- createTransparentWindow (Text.pack glade)
    [ "main_window"
    , "label_time"
    , "label_date"
    , "box_notis"
    , "box_buttons"
    , "button_deleteAll" ]
    (Just "Notification area")

  mainWindow <- window objs "main_window"
  notiBox <- box objs "box_notis"
  buttonBox <- box objs "box_buttons"
  timeL <- label objs "label_time"
  timeD <- label objs "label_date"
  deleteButton <- button objs "button_deleteAll"

  screen <- windowGetScreen mainWindow
  setStyle screen $ BS.pack $
    replaceColors config style
--  (Just mainWindowGDK) <- widgetGetParentWindow mainWindow

  onButtonClicked deleteButton $ do
    displayList <- stDisplayingNotiList <$> readTVarIO tState
    mapM (removeNoti tState) displayList
    return ()
  buttonSetLabel deleteButton $ Text.pack $ translate "Delete all"

  let buttons = zip
        (split $ removeOuterLetters $ configLabels config)
        (split $ removeOuterLetters $ configCommands config)
      (buttonLabels, buttonCommands) = unzip buttons
      margin = fromIntegral $ configButtonMargin config
      width = fromIntegral (((configWidth config) - 20)
                            `div` (configButtonsPerRow config))
              - margin * 2
      height = fromIntegral $ configButtonHeight config
      linesNeeded = fromIntegral $ ceiling
        $ ((fromIntegral $ length buttons) / (fromIntegral $ configButtonsPerRow config))
  lines' <- sequence $ take linesNeeded $ repeat $ boxNew OrientationHorizontal 0
  buttons' <- sequence $ map
    (\(label, command) -> createButton config width height command label)
    buttons

  sequence $ map (\(box, buttons'') ->
                    sequence $ Gtk.containerAdd box <$> buttons'')
    $ zip (reverse lines') (splitEvery (configButtonsPerRow config)
                            $ (buttonButton <$> buttons'))
  sequence $ Gtk.containerAdd buttonBox <$> lines'
  sequence $ widgetShowAll <$> lines'

  atomically $ modifyTVar' tState $
    \state -> state { stMainWindow = mainWindow
                      , stNotiBox = notiBox
                      , stTimeLabel = timeL
                      , stDateLabel = timeD
                      , stDeleteAll = deleteButton
                      , stNotisForMe = []
                      , stUserButtons = buttons' }

  startSetTimeThread tState

  onWidgetLeaveNotifyEvent mainWindow $ \(_) -> do
    hideNotiCenter tState
    return True

  setNotificationCenterPosition mainWindow config

  onWidgetDestroy mainWindow mainQuit

  return ()

setNotificationCenterPosition mainWindow config = do
  (screenW, screenY, screenH) <- getScreenPos mainWindow
    (fromIntegral $ configNotiCenterMonitor config)

  windowSetDefaultSize mainWindow
    width -- w
    (screenH - barHeightTop - barHeightBottom) -- h
  windowMove mainWindow
    (screenW - width - marginRight) -- x
    (screenY + barHeightTop)  -- y
  return ()
    where
      barHeightTop = fromIntegral $ configBarHeight config
      barHeightBottom = fromIntegral $ configBottomBarHeight config
      marginRight = fromIntegral $ configRightMargin config
      width = fromIntegral $ configWidth config

parseNotisForMe tState = do
  state <- readTVarIO tState
  -- do stuff
  let buttons = stUserButtons state
      notisForMe = stNotisForMe state
      myNotiHints = notiHints <$> notisForMe
      maybeIds = Map.lookup "id" <$> myNotiHints
      ids = join <$> map (\id' -> fromVariant <$> id') maybeIds :: [ Maybe Int32 ]
      ids' = map checkId ids
        where
          checkId (Just id)
            | id < (fromIntegral $ length buttons) = Just id
            | otherwise = Nothing
          checkId Nothing = Nothing
      maybeStates = Map.lookup "state" <$> myNotiHints
      states = join <$> map (\id' -> fromVariant <$> id') maybeStates :: [ Maybe Bool ]
      comb = sequenceT <$> (zip
                            (map
                             (\id -> (!!) buttons <$> (fromIntegral <$> id))
                             ids') states) :: [ Maybe (Button, Bool) ]
  sequence $ map (\comb' -> sequence $
                    (\(button, state) ->
                           setButtonState button state) <$> comb') comb
  atomically $ modifyTVar' tState
    (\state -> state { stNotisForMe = [] })
  return False

hideNotiCenter tState = do
  state <- readTVarIO tState
  mainWindow <- stMainWindow <$> readTVarIO tState
  widgetHide mainWindow
  atomically $ modifyTVar' tState
    (\state -> state { stCenterShown = False })

showNotiCenter tState notiState config = do
  state <- readTVarIO tState
  mainWindow <- stMainWindow <$> readTVarIO tState
  setNotificationCenterPosition mainWindow config
  newShown <- if stCenterShown state then
    do
      widgetHide mainWindow
      return False
    else
    do
      hideAllNotis $ stNotiState state
      widgetShow mainWindow
      return True
  atomically $ modifyTVar' tState
    (\state -> state {stCenterShown = newShown })
  return True

updateNotisForMe :: TVar State -> IO()
updateNotisForMe tState = do
  state <- readTVarIO tState
  notiState <- readTVarIO $ stNotiState state
  atomically $ modifyTVar' (stNotiState state) (
    \state -> state { notiForMeList = [] })
  atomically $ modifyTVar' tState (
    \state -> state { stNotisForMe = notiForMeList notiState
                                     ++ stNotisForMe state})

  addSource (parseNotisForMe tState)
  return ()

updateNotis :: Config -> TVar State -> IO()
updateNotis config tState = do
  state <- readTVarIO tState
  notiState <- readTVarIO $ stNotiState state

  let newNotis = filter (
        \n -> (find (\nd -> _dNotiId nd == notiId n )
               (stDisplayingNotiList state))
              == Nothing
              && ((configIgnoreTransient config) || (not $ notiTransient n)))
                 $ notiStList notiState
  newNotis' <- mapM (
    \n -> do
      let newNoti = DisplayingNotificationInCenter
                    { _dNotiId = notiId n }
      showNotification config
        (stNotiBox state) newNoti
        (stNotiState state) $ removeNoti tState
    ) newNotis

  let delNotis = filter (\nd -> (find (\n -> _dNotiId nd == notiId n)
                                $ notiStList notiState) == Nothing)
                 $ stDisplayingNotiList state
  atomically $ modifyTVar' tState (
    \state -> state { stDisplayingNotiList =
                      newNotis' ++ stDisplayingNotiList state
                    })
  setDeleteAllState tState
  mapM (removeNoti tState) $ delNotis
  when (stCenterShown state) $
    do
      hideAllNotis $ stNotiState state
  return ()

removeNoti :: TVar State -> DisplayingNotificationInCenter -> IO ()
removeNoti tState dNoti = do
  state <- readTVarIO tState
  atomically $ modifyTVar' tState $ \state ->
    state { stDisplayingNotiList =
            filter ((/=) dNoti) $ stDisplayingNotiList state}
  setDeleteAllState tState
  atomically $ modifyTVar' (stNotiState state) $ \state ->
    state { notiStList = filter
                         (\n -> notiId n /= _dNotiId dNoti) $
                         notiStList state }
  addSource $ do
    _dNotiDestroy dNoti
    return False
  return ()

setDeleteAllState tState = do
  addSource $ do
    state <- readTVarIO tState
    if (length $ stDisplayingNotiList state) > 1 then
      widgetShow $ stDeleteAll state
      else
      widgetHide $ stDeleteAll state
    return False
  return ()

getInitialState = do
  newTVarIO $ State
    { stDisplayingNotiList = []
    , stCenterShown = False}

main' :: IO ()
main' = do
  GI.init Nothing

  homeDir <- getXdgDirectory XdgConfig ""
  config <- getConfig <$> (readConfigFile
                            (homeDir ++ "/deadd/deadd.conf"))

  initI18n

  istate <- getInitialState
  notiState <- startNotificationDaemon config
    (updateNotis config istate) (updateNotisForMe istate)

  atomically $ modifyTVar' istate $
    \istate' -> istate' { stNotiState = notiState }
  createNotiCenter istate config

  unixSignalAdd PRIORITY_HIGH (fromIntegral sigUSR1)
    (showNotiCenter istate notiState config)

  runCommand $ configStartupCommand config

  GI.main

main :: IO ()
main = do
--  daemonize main'
  main'


text:
module Algoritmo where

import Prelude as P
import Data.Complex
import Control.Monad.State
import Numeric.Statistics (percentile)
import Numeric.LinearAlgebra
import Data.Vector.Storable as VS hiding (modify, null)

import FFT
import ArrayPoking
import Bases

type L2  = Vector (Complex Double)
type Dim = Int
type Niveles = Int

secAnalitica :: Niveles -> L2 -> State [L2] ()
secAnalitica n zF =
  do let dim = VS.length zF
         uF  = conj . fft $ haarU dim
         vF  = conj . fft $ haarV dim
         x1  = downSampF (zF * vF) dim
         y1  = downSampF (zF * uF) dim

     -- [y3, x3, x2, x1]
     -- modify (x1 :)
     if n <= 1
       -- Haz nada, este es el ultimo nivel
       then modify (zF :)
       --
       else modify (x1 :) >> secAnalitica (n - 1) y1

secSintetica :: Niveles -> State [L2] L2
secSintetica n =
  do y2 : x2 : rest <- get
     let dim = VS.length y2
         dim_n = dim * 2
         x2' = upSampF x2 dim
         y2' = upSampF y2 dim
         y1  = x2' * (fft (haarV dim_n)) +
               y2' * (fft (haarU dim_n))
     put (y1 : rest)

     if null rest || n <= 1
       then return y1
       else secSintetica (n - 1)

{-
  Idea: Mantener los @k terminos mayores y lo demas setearlos a 0. Es
  molesto contar, asi que veremos un porcentaje.
  rate = 90.0, es decir 90% de calidad, debo de matar 10% de los
  candidatos.
-}
compresion :: Double -> State [L2] ()
compresion rate =
  do vec <- get
     let cut  = percentile (100 - rate) . sortIP
                . cmap magnitude $ VS.concat vec

         go c = if magnitude c < cut then 0 else c
     put $ P.map (VS.map go) vec

waveletAlgo :: Double -> Niveles -> Niveles -> L2 -> L2
waveletAlgo calidad div recon color = evalState go []
  where
    go :: State [L2] L2
    go = return (fft color)
         >>= secAnalitica div
         -- >> modify (P.map ifft)
         >> compresion calidad
         -- >> modify (P.map fft)
         >> secSintetica recon
         >>= return . ifft

max_stars_repo_name: RubenAstudillo/proyecto-lena

max_issues_repo_name: RubenAstudillo/proyecto-lena

max_forks_repo_name: RubenAstudillo/proyecto-lena


text:
{-# LANGUAGE CPP #-}

module Main (main) where

import Data.Complex (Complex ((:+)))
import Data.Complex.Polar
#ifdef __GLASGOW_HASKELL__
import GHC.Stack (HasCallStack)
#endif
import System.Exit
  ( ExitCode (ExitFailure, ExitSuccess),
    exitWith,
  )
import Test.HUnit
  ( Assertion,
    Test (TestCase, TestList),
    assertBool,
    assertEqual,
    errors,
    failures,
    runTestTT,
  )

tests :: Test
tests =
  TestList
    [ TestCase $ rAndThetaAre 1 (0.1 - pi) $ mkPolar (- 1) 0.1,
      TestCase $ rAndThetaAre 1 (pi / 2) $ mkPolar 1 (-3 * pi / 2),
      TestCase $ rAndThetaAre 1 (0.5 - pi) $ mkPolar 1 (pi + 0.5),
#if __GLASGOW_HASKELL__ >= 736
      TestCase $ rAndThetaAre 1 (0.1 - pi) $ (- 1) :< 0.1,
      TestCase $ rAndThetaAre 1 (pi / 2) $ 1 :< (- 3 * pi / 2),
      TestCase $ rAndThetaAre 1 (0.5 - pi) $ 1 :< (pi + 0.5),
#endif
      TestCase $ rAndThetaAre 1 0.3 $ cis 0.3,
      TestCase $ rAndThetaAre 1 (0.3 - pi) $ cis (pi + 0.3),
      TestCase $ rAndThetaAre 0 0 $ mkPolar 0 pi,
      TestCase $ rAndThetaAre 1 pi $ signum (mkPolar 1 pi),
      TestCase $ rAndThetaAre 0 0 $ signum (mkPolar 0 pi),
      TestCase $ rAndThetaAre 1 (-3 * pi / 4) $ negate (mkPolar 1 (pi / 4)),
      TestCase $ rAndThetaAre 1 pi $ fromRational (- 1),
      TestCase $ rAndThetaAre 1 0 $ exp $ mkPolar (10 * pi) (pi / 2),
      TestCase $ rAndThetaAre (sqrt 2) (pi / 4) $ fromComplex $ 1 :+ 1,
      TestCase $ isApproximately "realPart" 1 $ realPart $ mkPolar 1 0,
      TestCase $ isApproximately "imagPart" 1 $ imagPart $ mkPolar 1 (pi / 2),
      TestCase $ rAndThetaAre 1 (- pi / 4) $ conjugate $ mkPolar 1 (pi / 4),
      TestCase $
        rAndThetaAre (sqrt 2) (pi / 4) $
          mkPolar 1 0 + mkPolar 1 (pi / 2),
      TestCase $
        rAndThetaAre (sqrt 2) (- pi / 4) $
          mkPolar 1 0 - mkPolar 1 (pi / 2),
      TestCase $ rAndThetaAre 1 0.7 $ mkPolar 1 0.3 * mkPolar 1 0.4,
      TestCase $ rAndThetaAre (sqrt 2) 0 $ abs $ mkPolar (sqrt 2) 0.3,
      TestCase $ rAndThetaAre 1 0 1, -- Test Num fromInteger
      TestCase $ rAndThetaAre 1 0 $ mkPolar 1 0 * mkPolar 2 0.2 / mkPolar 2 0.2,
      TestCase $ rAndThetaAre pi 0 pi, -- Test Floating pi
      TestCase $ rAndThetaAre 54.5984 2.00000 $ exp z,
      TestCase $ rAndThetaAre 1.56798 0.30018 $ log z,
      TestCase $ rAndThetaAre 2.11474 0.23182 $ sqrt z,
      TestCase $ rAndThetaAre 3.70497 (- 2.4472) $ sin z,
      TestCase $ rAndThetaAre 3.68529 2.30135 $ cos z,
      TestCase $ rAndThetaAre 1.00534 1.53455 $ tan z,
      TestCase $ rAndThetaAre 27.3050 1.99974 $ sinh z,
      TestCase $ rAndThetaAre 27.2930 2.00025 $ cosh z,
      TestCase $ rAndThetaAre 1.00043 (- 0.0005) $ tanh z,
      TestCase $ rAndThetaAre 2.44362 1.10527 $ asin z,
      TestCase $ rAndThetaAre 2.23441 (- 1.3570) $ acos z,
      TestCase $ rAndThetaAre 1.37491 0.07018 $ atan z,
      TestCase $ rAndThetaAre 2.24493 0.20357 $ asinh z,
      TestCase $ rAndThetaAre 2.23441 0.21370 $ acosh z,
      TestCase $ rAndThetaAre 1.48069 1.43491 $ atanh z,
      TestCase $ assertBool "Eq instance works" $ mkPolar 1 pi == mkPolar 1 pi,
      TestCase $
        assertEqual "Show output good" "mkPolar 1.0 1.0" $
          show $ mkPolar 1 1,
      TestCase $ readShowInverse z,
      TestCase $ readShowInverse [z, z],
      TestCase $ readShowInverse $ Just z
    ]
  where
    z = mkPolar 4.47214 0.46364

approximatelyEqualFloat :: Float -> Float -> Bool
approximatelyEqualFloat x1 x2 = abs (x1 - x2) < 0.001

isApproximately ::
#ifdef __GLASGOW_HASKELL__
  HasCallStack =>
#endif
  String -> Float -> Float -> Assertion
isApproximately name x1 x2 =
  assertBool (name ++ " = " ++ show x1 ++ " is approximately " ++ show x2) $
    approximatelyEqualFloat x1 x2

rAndThetaAre ::
#ifdef __GLASGOW_HASKELL__
  HasCallStack =>
#endif
  Float -> Float -> Polar Float -> Assertion
rAndThetaAre r theta z = do
  isApproximately "magnitude" r (magnitude z)
  isApproximately "phase" theta (phase z)
  let (r', theta') = polar z
  isApproximately "magnitude from polar" r r'
  isApproximately "phase from polar" theta theta'
#if __GLASGOW_HASKELL >= 786
  let (r'' :< theta') = polar z
  isApproximately "magnitude from :<" r r''
  isApproximately "phase from :<" theta theta''
#endif

readShowInverse ::
  (Show a, Read a,
#ifdef __GLASGOW_HASKELL__
  HasCallStack,
#endif
  Eq a) =>
  a -> Assertion
readShowInverse a = assertEqual ("read . show = id on " ++ show a)
                                (read $ show a)
                                a

main :: IO ()
main = do
  counts <- runTestTT tests
  if errors counts + failures counts == 0
    then exitWith ExitSuccess
    else exitWith (ExitFailure 1)

max_stars_repo_name: kaoskorobase/polar

max_issues_repo_name: kaoskorobase/polar

max_forks_repo_name: kaoskorobase/polar