text:
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}

#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE Trustworthy #-}
#endif

#if __GLASGOW_HASKELL__ >= 705
{-# LANGUAGE PolyKinds #-}
#endif

#include "HsBaseConfig.h"

module Generics.Deriving.Enum (

  -- * Generic enum class
    GEnum(..)

  -- * Default definitions for GEnum
  , genumDefault, toEnumDefault, fromEnumDefault

  -- * Internal enum class
  , Enum'(..)

  -- * Generic Ix class
  , GIx(..)

  -- * Default definitions for GIx
  , rangeDefault, indexDefault, inRangeDefault

  ) where

import           Control.Applicative (Const, ZipList)

import           Data.Int
import           Data.Monoid (All, Any, Dual, Product, Sum)
import qualified Data.Monoid as Monoid (First, Last)
import Data.Word

import           Foreign.C.Types
import           Foreign.Ptr

import           Generics.Deriving.Base
import           Generics.Deriving.Eq

import           System.Exit (ExitCode)
import           System.Posix.Types

#if MIN_VERSION_base(4,4,0)
import           Data.Complex (Complex)
#endif

#if MIN_VERSION_base(4,7,0)
import           Data.Coerce (coerce)
import           Data.Proxy (Proxy)
#else
import           Unsafe.Coerce (unsafeCoerce)
#endif

#if MIN_VERSION_base(4,8,0)
import           Data.Functor.Identity (Identity)
import           Data.Monoid (Alt)
import           Numeric.Natural (Natural)
#endif

#if MIN_VERSION_base(4,9,0)
import           Data.List.NonEmpty (NonEmpty)
import qualified Data.Semigroup as Semigroup (First, Last)
import           Data.Semigroup (Arg, Max, Min, WrappedMonoid)
#endif

-----------------------------------------------------------------------------
-- Utility functions for Enum'
-----------------------------------------------------------------------------

infixr 5 |||

-- | Interleave elements from two lists. Similar to (++), but swap left and
-- right arguments on every recursive application.
--
-- From Mark Jones' talk at AFP2008
(|||) :: [a] -> [a] -> [a]
[]     ||| ys = ys
(x:xs) ||| ys = x : ys ||| xs

-- | Diagonalization of nested lists. Ensure that some elements from every
-- sublist will be included. Handles infinite sublists.
--
-- From Mark Jones' talk at AFP2008
diag :: [[a]] -> [a]
diag = concat . foldr skew [] . map (map (\x -> [x]))

skew :: [[a]] -> [[a]] -> [[a]]
skew []     ys = ys
skew (x:xs) ys = x : combine (++) xs ys

combine :: (a -> a -> a) -> [a] -> [a] -> [a]
combine _ xs     []     = xs
combine _ []     ys     = ys
combine f (x:xs) (y:ys) = f x y : combine f xs ys

findIndex :: (a -> Bool) -> [a] -> Maybe Int
findIndex p xs = let l = [ i | (y,i) <- zip xs [(0::Int)..], p y]
                 in if (null l)
                    then Nothing
                    else Just (head l)

--------------------------------------------------------------------------------
-- Generic enum
--------------------------------------------------------------------------------

class Enum' f where
  enum' :: [f a]

instance Enum' U1 where
  enum' = [U1]

instance (GEnum c) => Enum' (K1 i c) where
  enum' = map K1 genum

instance (Enum' f) => Enum' (M1 i c f) where
  enum' = map M1 enum'

instance (Enum' f, Enum' g) => Enum' (f :+: g) where
  enum' = map L1 enum' ||| map R1 enum'

instance (Enum' f, Enum' g) => Enum' (f :*: g) where
  enum' = diag [ [ x :*: y | y <- enum' ] | x <- enum' ]

genumDefault :: (Generic a, Enum' (Rep a)) => [a]
genumDefault = map to enum'

toEnumDefault :: (Generic a, Enum' (Rep a)) => Int -> a
toEnumDefault i = let l = enum'
                  in if (length l > i)
                      then to (l !! i)
                       else error "toEnum: invalid index"

fromEnumDefault :: (GEq a, Generic a, Enum' (Rep a))
                => a -> Int
fromEnumDefault x = case findIndex (geq x) (map to enum') of
      Nothing -> error "fromEnum: no corresponding index"
      Just i  -> i

class GEnum a where
  genum :: [a]

#if __GLASGOW_HASKELL__ >= 701
  default genum :: (Generic a, Enum' (Rep a)) => [a]
  genum = genumDefault
#endif

genumNumUnbounded :: Num a => [a]
genumNumUnbounded = pos 0 ||| neg 0 where
  pos n = n     : pos (n + 1)
  neg n = (n-1) : neg (n - 1)

genumNumSigned :: (Bounded a, Enum a, Num a) => [a]
genumNumSigned = [0 .. maxBound] ||| [-1, -2 .. minBound]

genumNumUnsigned :: (Enum a, Num a) => [a]
genumNumUnsigned = [0 ..]

#if !(MIN_VERSION_base(4,7,0))
coerce :: a -> b
coerce = unsafeCoerce
#endif

-- Base types instances
instance GEnum () where
  genum = genumDefault

instance (GEnum a, GEnum b) => GEnum (a, b) where
  genum = genumDefault

instance (GEnum a, GEnum b, GEnum c) => GEnum (a, b, c) where
  genum = genumDefault

instance (GEnum a, GEnum b, GEnum c, GEnum d) => GEnum (a, b, c, d) where
  genum = genumDefault

instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e) => GEnum (a, b, c, d, e) where
  genum = genumDefault

instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f)
    => GEnum (a, b, c, d, e, f) where
  genum = genumDefault

instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f, GEnum g)
    => GEnum (a, b, c, d, e, f, g) where
  genum = genumDefault

instance GEnum a => GEnum [a] where
  genum = genumDefault

instance (GEnum (f p), GEnum (g p)) => GEnum ((f :+: g) p) where
  genum = genumDefault

instance (GEnum (f p), GEnum (g p)) => GEnum ((f :*: g) p) where
  genum = genumDefault

instance GEnum (f (g p)) => GEnum ((f :.: g) p) where
  genum = genumDefault

instance GEnum All where
  genum = genumDefault

#if MIN_VERSION_base(4,8,0)
instance GEnum (f a) => GEnum (Alt f a) where
  genum = genumDefault
#endif

instance GEnum Any where
  genum = genumDefault

#if MIN_VERSION_base(4,9,0)
instance (GEnum a, GEnum b) => GEnum (Arg a b) where
  genum = genumDefault
#endif

#if !(MIN_VERSION_base(4,9,0))
instance GEnum Arity where
  genum = genumDefault
#endif

instance GEnum Associativity where
  genum = genumDefault

instance GEnum Bool where
  genum = genumDefault

#if defined(HTYPE_CC_T)
instance GEnum CCc where
  genum = coerce (genum :: [HTYPE_CC_T])
#endif

instance GEnum CChar where
  genum = coerce (genum :: [HTYPE_CHAR])

instance GEnum CClock where
  genum = coerce (genum :: [HTYPE_CLOCK_T])

#if defined(HTYPE_DEV_T)
instance GEnum CDev where
  genum = coerce (genum :: [HTYPE_DEV_T])
#endif

instance GEnum CDouble where
  genum = coerce (genum :: [HTYPE_DOUBLE])

instance GEnum CFloat where
  genum = coerce (genum :: [HTYPE_FLOAT])

#if defined(HTYPE_GID_T)
instance GEnum CGid where
  genum = coerce (genum :: [HTYPE_GID_T])
#endif

#if defined(HTYPE_INO_T)
instance GEnum CIno where
  genum = coerce (genum :: [HTYPE_INO_T])
#endif

instance GEnum CInt where
  genum = coerce (genum :: [HTYPE_INT])

instance GEnum CIntMax where
  genum = coerce (genum :: [HTYPE_INTMAX_T])

instance GEnum CIntPtr where
  genum = coerce (genum :: [HTYPE_INTPTR_T])

instance GEnum CLLong where
  genum = coerce (genum :: [HTYPE_LONG_LONG])

instance GEnum CLong where
  genum = coerce (genum :: [HTYPE_LONG])

#if defined(HTYPE_MODE_T)
instance GEnum CMode where
  genum = coerce (genum :: [HTYPE_MODE_T])
#endif

#if defined(HTYPE_NLINK_T)
instance GEnum CNlink where
  genum = coerce (genum :: [HTYPE_NLINK_T])
#endif

#if defined(HTYPE_OFF_T)
instance GEnum COff where
  genum = coerce (genum :: [HTYPE_OFF_T])
#endif

#if MIN_VERSION_base(4,4,0)
instance GEnum a => GEnum (Complex a) where
  genum = genumDefault
#endif

instance GEnum a => GEnum (Const a b) where
  genum = genumDefault

#if defined(HTYPE_PID_T)
instance GEnum CPid where
  genum = coerce (genum :: [HTYPE_PID_T])
#endif

instance GEnum CPtrdiff where
  genum = coerce (genum :: [HTYPE_PTRDIFF_T])

#if defined(HTYPE_RLIM_T)
instance GEnum CRLim where
  genum = coerce (genum :: [HTYPE_RLIM_T])
#endif

instance GEnum CSChar where
  genum = coerce (genum :: [HTYPE_SIGNED_CHAR])

#if defined(HTYPE_SPEED_T)
instance GEnum CSpeed where
  genum = coerce (genum :: [HTYPE_SPEED_T])
#endif

#if MIN_VERSION_base(4,4,0)
instance GEnum CSUSeconds where
  genum = coerce (genum :: [HTYPE_SUSECONDS_T])
#endif

instance GEnum CShort where
  genum = coerce (genum :: [HTYPE_SHORT])

instance GEnum CSigAtomic where
  genum = coerce (genum :: [HTYPE_SIG_ATOMIC_T])

instance GEnum CSize where
  genum = coerce (genum :: [HTYPE_SIZE_T])

#if defined(HTYPE_SSIZE_T)
instance GEnum CSsize where
  genum = coerce (genum :: [HTYPE_SSIZE_T])
#endif

#if defined(HTYPE_TCFLAG_T)
instance GEnum CTcflag where
  genum = coerce (genum :: [HTYPE_TCFLAG_T])
#endif

instance GEnum CTime where
  genum = coerce (genum :: [HTYPE_TIME_T])

instance GEnum CUChar where
  genum = coerce (genum :: [HTYPE_UNSIGNED_CHAR])

#if defined(HTYPE_UID_T)
instance GEnum CUid where
  genum = coerce (genum :: [HTYPE_UID_T])
#endif

instance GEnum CUInt where
  genum = coerce (genum :: [HTYPE_UNSIGNED_INT])

instance GEnum CUIntMax where
  genum = coerce (genum :: [HTYPE_UINTMAX_T])

instance GEnum CUIntPtr where
  genum = coerce (genum :: [HTYPE_UINTPTR_T])

instance GEnum CULLong where
  genum = coerce (genum :: [HTYPE_UNSIGNED_LONG_LONG])

instance GEnum CULong where
  genum = coerce (genum :: [HTYPE_UNSIGNED_LONG])

#if MIN_VERSION_base(4,4,0)
instance GEnum CUSeconds where
  genum = coerce (genum :: [HTYPE_USECONDS_T])
#endif

instance GEnum CUShort where
  genum = coerce (genum :: [HTYPE_UNSIGNED_SHORT])

instance GEnum CWchar where
  genum = coerce (genum :: [HTYPE_WCHAR_T])

instance GEnum Double where
  genum = genumNumUnbounded

instance GEnum a => GEnum (Dual a) where
  genum = genumDefault

instance (GEnum a, GEnum b) => GEnum (Either a b) where
  genum = genumDefault

instance GEnum ExitCode where
  genum = genumDefault

instance GEnum Fd where
  genum = coerce (genum :: [CInt])

instance GEnum a => GEnum (Monoid.First a) where
  genum = genumDefault

#if MIN_VERSION_base(4,9,0)
instance GEnum a => GEnum (Semigroup.First a) where
  genum = genumDefault
#endif

instance GEnum Fixity where
  genum = genumDefault

instance GEnum Float where
  genum = genumNumUnbounded

#if MIN_VERSION_base(4,8,0)
instance GEnum a => GEnum (Identity a) where
  genum = genumDefault
#endif

instance GEnum Int where
  genum = genumNumSigned

instance GEnum Int8 where
  genum = genumNumSigned

instance GEnum Int16 where
  genum = genumNumSigned

instance GEnum Int32 where
  genum = genumNumSigned

instance GEnum Int64 where
  genum = genumNumSigned

instance GEnum Integer where
  genum = genumNumUnbounded

instance GEnum IntPtr where
  genum = genumNumSigned

instance GEnum c => GEnum (K1 i c p) where
  genum = genumDefault

instance GEnum a => GEnum (Monoid.Last a) where
  genum = genumDefault

#if MIN_VERSION_base(4,9,0)
instance GEnum a => GEnum (Semigroup.Last a) where
  genum = genumDefault
#endif

instance GEnum (f p) => GEnum (M1 i c f p) where
  genum = genumDefault

#if MIN_VERSION_base(4,9,0)
instance GEnum a => GEnum (Max a) where
  genum = genumDefault
#endif

instance GEnum a => GEnum (Maybe a) where
  genum = genumDefault

#if MIN_VERSION_base(4,9,0)
instance GEnum a => GEnum (Min a) where
  genum = genumDefault
#endif

#if MIN_VERSION_base(4,8,0)
instance GEnum Natural where
  genum = genumNumUnsigned
#endif

#if MIN_VERSION_base(4,9,0)
instance GEnum a => GEnum (NonEmpty a) where
  genum = genumDefault
#endif

instance GEnum Ordering where
  genum = genumDefault

instance GEnum p => GEnum (Par1 p) where
  genum = genumDefault

instance GEnum a => GEnum (Product a) where
  genum = genumDefault

#if MIN_VERSION_base(4,7,0)
instance GEnum
# if MIN_VERSION_base(4,9,0)
               (Proxy s)
# else
               (Proxy (s :: *))
# endif
               where
  genum = genumDefault
#endif

instance GEnum (f p) => GEnum (Rec1 f p) where
  genum = genumDefault

instance GEnum a => GEnum (Sum a) where
  genum = genumDefault

instance GEnum (U1 p) where
  genum = genumDefault

instance GEnum Word where
  genum = genumNumUnsigned

instance GEnum Word8 where
  genum = genumNumUnsigned

instance GEnum Word16 where
  genum = genumNumUnsigned

instance GEnum Word32 where
  genum = genumNumUnsigned

instance GEnum Word64 where
  genum = genumNumUnsigned

instance GEnum WordPtr where
  genum = genumNumUnsigned

#if MIN_VERSION_base(4,9,0)
instance GEnum m => GEnum (WrappedMonoid m) where
  genum = genumDefault
#endif

instance GEnum a => GEnum (ZipList a) where
  genum = genumDefault

#if MIN_VERSION_base(4,10,0)
instance GEnum CBool where
  genum = coerce (genum :: [HTYPE_BOOL])

# if defined(HTYPE_BLKSIZE_T)
instance GEnum CBlkSize where
  genum = coerce (genum :: [HTYPE_BLKSIZE_T])
# endif

# if defined(HTYPE_BLKCNT_T)
instance GEnum CBlkCnt where
  genum = coerce (genum :: [HTYPE_BLKCNT_T])
# endif

# if defined(HTYPE_CLOCKID_T)
instance GEnum CClockId where
  genum = coerce (genum :: [HTYPE_CLOCKID_T])
# endif

# if defined(HTYPE_FSBLKCNT_T)
instance GEnum CFsBlkCnt where
  genum = coerce (genum :: [HTYPE_FSBLKCNT_T])
# endif

# if defined(HTYPE_FSFILCNT_T)
instance GEnum CFsFilCnt where
  genum = coerce (genum :: [HTYPE_FSFILCNT_T])
# endif

# if defined(HTYPE_ID_T)
instance GEnum CId where
  genum = coerce (genum :: [HTYPE_ID_T])
# endif

# if defined(HTYPE_KEY_T)
instance GEnum CKey where
  genum = coerce (genum :: [HTYPE_KEY_T])
# endif
#endif

--------------------------------------------------------------------------------
-- Generic Ix
--------------------------------------------------------------------------------

-- Minimal complete instance: 'range', 'index' and 'inRange'.
class (Ord a) => GIx a where
    -- | The list of values in the subrange defined by a bounding pair.
    range               :: (a,a) -> [a]
    -- | The position of a subscript in the subrange.
    index               :: (a,a) -> a -> Int
    -- | Returns 'True' the given subscript lies in the range defined
    -- the bounding pair.
    inRange             :: (a,a) -> a -> Bool
#if __GLASGOW_HASKELL__ >= 701
    default range :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> [a]
    range = rangeDefault

    default index :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Int
    index = indexDefault

    default inRange :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Bool
    inRange = inRangeDefault
#endif

rangeDefault :: (GEq a, Generic a, Enum' (Rep a))
             => (a,a) -> [a]
rangeDefault = t (map to enum') where
  t l (x,y) =
    case (findIndex (geq x) l, findIndex (geq y) l) of
      (Nothing, _)     -> error "rangeDefault: no corresponding index"
      (_, Nothing)     -> error "rangeDefault: no corresponding index"
      (Just i, Just j) -> take (j-i) (drop i l)

indexDefault :: (GEq a, Generic a, Enum' (Rep a))
             => (a,a) -> a -> Int
indexDefault = t (map to enum') where
  t l (x,y) z =
    case (findIndex (geq x) l, findIndex (geq y) l) of
      (Nothing, _)     -> error "indexDefault: no corresponding index"
      (_, Nothing)     -> error "indexDefault: no corresponding index"
      (Just i, Just j) -> case findIndex (geq z) (take (j-i) (drop i l)) of
                            Nothing -> error "indexDefault: index out of range"
                            Just k  -> k

inRangeDefault :: (GEq a, Generic a, Enum' (Rep a))
               => (a,a) -> a -> Bool
inRangeDefault = t (map to enum') where
  t l (x,y) z =
    case (findIndex (geq x) l, findIndex (geq y) l) of
      (Nothing, _)     -> error "indexDefault: no corresponding index"
      (_, Nothing)     -> error "indexDefault: no corresponding index"
      (Just i, Just j) -> maybe False (const True)
                            (findIndex (geq z) (take (j-i) (drop i l)))

rangeEnum :: Enum a => (a, a) -> [a]
rangeEnum (m,n) = [m..n]

indexIntegral :: Integral a => (a, a) -> a -> Int
indexIntegral (m,_n) i = fromIntegral (i - m)

inRangeOrd :: Ord a => (a, a) -> a -> Bool
inRangeOrd (m,n) i =  m <= i && i <= n

-- Base types instances
instance GIx () where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (a, b) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c)
    => GIx (a, b, c) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c,
          GEq d, GEnum d, GIx d)
    => GIx (a, b, c, d) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c,
          GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e)
    => GIx (a, b, c, d, e) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c,
          GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f)
    => GIx (a, b, c, d, e, f) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c,
          GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f,
          GEq g, GEnum g, GIx g)
    => GIx (a, b, c, d, e, f, g) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance (GEq a, GEnum a, GIx a) => GIx [a] where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance GIx All where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

#if MIN_VERSION_base(4,8,0)
instance (GEq (f a), GEnum (f a), GIx (f a)) => GIx (Alt f a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

instance GIx Any where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

#if MIN_VERSION_base(4,9,0)
instance (GEq a, GEnum a, GIx a, GEnum b) => GIx (Arg a b) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

#if !(MIN_VERSION_base(4,9,0))
instance GIx Arity where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

instance GIx Associativity where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance GIx Bool where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance GIx CChar where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

#if defined(HTYPE_GID_T)
instance GIx CGid where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

#if defined(HTYPE_INO_T)
instance GIx CIno where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

instance GIx CInt where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CIntMax where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CIntPtr where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CLLong where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CLong where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

#if defined(HTYPE_MODE_T)
instance GIx CMode where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

#if defined(HTYPE_NLINK_T)
instance GIx CNlink where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

#if defined(HTYPE_OFF_T)
instance GIx COff where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

#if defined(HTYPE_PID_T)
instance GIx CPid where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

instance GIx CPtrdiff where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

#if defined(HTYPE_RLIM_T)
instance GIx CRLim where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

instance GIx CSChar where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CShort where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CSigAtomic where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CSize where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

#if defined(HTYPE_SSIZE_T)
instance GIx CSsize where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

#if defined(HTYPE_TCFLAG_T)
instance GIx CTcflag where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

instance GIx CUChar where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

#if defined(HTYPE_UID_T)
instance GIx CUid where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

instance GIx CUInt where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CUIntMax where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CUIntPtr where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CULLong where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CULong where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CUShort where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CWchar where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance (GEq a, GEnum a, GIx a) => GIx (Dual a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (Either a b) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance GIx ExitCode where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance GIx Fd where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance (GEq a, GEnum a, GIx a) => GIx (Monoid.First a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

#if MIN_VERSION_base(4,9,0)
instance (GEq a, GEnum a, GIx a) => GIx (Semigroup.First a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

instance GIx Fixity where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

#if MIN_VERSION_base(4,8,0)
instance (GEq a, GEnum a, GIx a) => GIx (Identity a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

instance GIx Int where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx Int8 where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx Int16 where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx Int32 where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx Int64 where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx Integer where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx IntPtr where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance (GEq a, GEnum a, GIx a) => GIx (Monoid.Last a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

#if MIN_VERSION_base(4,9,0)
instance (GEq a, GEnum a, GIx a) => GIx (Semigroup.Last a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

#if MIN_VERSION_base(4,9,0)
instance (GEq a, GEnum a, GIx a) => GIx (Max a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

instance (GEq a, GEnum a, GIx a) => GIx (Maybe a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

#if MIN_VERSION_base(4,9,0)
instance (GEq a, GEnum a, GIx a) => GIx (Min a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

#if MIN_VERSION_base(4,8,0)
instance GIx Natural where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

#if MIN_VERSION_base(4,9,0)
instance (GEq a, GEnum a, GIx a) => GIx (NonEmpty a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

instance GIx Ordering where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance (GEq a, GEnum a, GIx a) => GIx (Product a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

#if MIN_VERSION_base(4,7,0)
instance GIx
# if MIN_VERSION_base(4,9,0)
             (Proxy s)
# else
             (Proxy (s :: *))
# endif
             where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

instance (GEq a, GEnum a, GIx a) => GIx (Sum a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance GIx Word where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx Word8 where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx Word16 where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx Word32 where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx Word64 where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx WordPtr where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

#if MIN_VERSION_base(4,9,0)
instance (GEq m, GEnum m, GIx m) => GIx (WrappedMonoid m) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

#if MIN_VERSION_base(4,10,0)
instance GIx CBool where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

# if defined(HTYPE_BLKSIZE_T)
instance GIx CBlkSize where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
# endif

# if defined(HTYPE_BLKCNT_T)
instance GIx CBlkCnt where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
# endif

# if defined(HTYPE_CLOCKID_T)
instance GIx CClockId where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
# endif

# if defined(HTYPE_FSBLKCNT_T)
instance GIx CFsBlkCnt where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
# endif

# if defined(HTYPE_FSFILCNT_T)
instance GIx CFsFilCnt where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
# endif

# if defined(HTYPE_ID_T)
instance GIx CId where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
# endif

# if defined(HTYPE_KEY_T)
instance GIx CKey where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
# endif
#endif

max_stars_repo_name: treeowl/generic-deriving

max_issues_repo_name: treeowl/generic-deriving

max_forks_repo_name: treeowl/generic-deriving


text:
{-# LANGUAGE TemplateHaskell, RecordWildCards #-}
module TestGamer where

import           Data.ByteString.Builder        ( toLazyByteString )
import qualified Data.ByteString.Lazy          as B
import           Data.List                      ( foldl1'
                                                , stripPrefix
                                                )
import qualified Data.Map.Strict               as Map
import           Data.Maybe                     ( fromMaybe )
import           Data.Ord                       ( Down(Down) )
import qualified Data.Set                      as S
import qualified Data.Vector                   as V
import           GHC.Float                      ( float2Int
                                                , int2Float
                                                )
import           GHC.IO.Handle                  ( hDuplicate
                                                , hDuplicateTo
                                                )
import           Graphics.EasyPlot              ( Graph2D(Function2D)
                                                , Option(Title)
                                                , Option2D(Range, Step)
                                                , Plot(plot)
                                                , TerminalType(PNG)
                                                )
import           Internal.Evolution
import           Internal.Gamer
import           Statistics.Sample              ( correlation )
import           System.IO                      ( IOMode(WriteMode)
                                                , hClose
                                                , openFile
                                                , stdout
                                                )
import           Test.QuickCheck                ( Gen
                                                , Property
                                                , arbitrary
                                                , counterexample
                                                , cover
                                                , generate
                                                , quickCheckAll
                                                , vectorOf
                                                , verboseCheck
                                                , withMaxSuccess
                                                )
import           Text.Regex.TDFA                ( (=~) )
import           Util

matchup :: [Agent a] -> [[Agent a]]
--matchup = matchWithBest 2 10 (Down . agentFitness) . S.fromDistinctAscList
matchup = matchups 2 . S.fromDistinctAscList

prop_encodedLen :: GamerParams -> Gen Bool
prop_encodedLen params@GamerParams {..} = do
    tree <- genStateTransitionTree params
    let encoded = encodeTransitions params tree
        bsLen   = fromIntegral . B.length . toLazyByteString
    return $ 0 == bsLen encoded `rem` bcdLen gamerStates

prop_encodeUniformLen :: GamerParams -> Gen Bool
prop_encodeUniformLen params = do
    let encodedLen = B.length . encodeGenome params <$> genGenome params
    cs <- vectorOf 20 encodedLen
    return $ all (head cs ==) cs

prop_treeUniform :: GamerParams -> Gen Bool
prop_treeUniform params@GamerParams {..} = do
    let uniform (NextState _ ) = True
        uniform (Reactions xs) = length xs == gamerActions && all uniform xs
    tree <- genStateTransitionTree params
    return $ uniform tree

prop_evolveFitness :: GamerParams -> EvolutionParams -> Gen Property
prop_evolveFitness gParams eParams@EvolutionParams {..} = do
    let game   = playGame dilemma 100
        avgFit = combineWith
            (/)
            [ sum . map agentFitness . getFitness game . matchup
            , realToFrac . length
            ]
    pop  <- genPlayers gParams { gamerActions = 2 } evolvePopSize
    pop' <- evolve eParams game matchup pop
    let dFit = avgFit pop' - avgFit pop
    return
        . counterexample ("dFit = " ++ show dFit)
        . cover 90 (dFit > 0) "increased fitness"
        $ True -- we only care about the statistics

-- | Redirects @stdout@ to a file temporarily to capture output of an IO action,
-- then returns the file's contents.
outputToFile
    :: String -- ^ The name of the file to redirect output to.
    -> IO () -- ^ The IO action to execute, which should output to @stdout@.
    -> IO String
outputToFile filename action = do
    stdout' <- hDuplicate stdout
    file    <- openFile filename WriteMode
    hDuplicateTo file stdout
    action
    hClose file
    hDuplicateTo stdout' stdout
    readFile filename

-- | Parses parameter names and values from 'Test.QuickCheck.verboseCheck' output.
--
-- Returns a Map from each parameter's name to a Vector of its values,
-- collected from all tests in order of execution.
parseQuickCheck
    :: Read a
    => String -- ^ The output of 'Test.QuickCheck.verboseCheck'.
    -> Map.Map String (V.Vector a)
parseQuickCheck text = Map.fromListWith
    (V.++)
    [ (parseKey match, parseVal match) | match <- matches ]
  where
    regex   = "([a-zA-Z]+) = ([-0-9.]+)"
    matches = text =~ regex :: [[String]]
    stripGet s = fromMaybe s (stripPrefix "get" s)
    parseKey match = stripGet $ match !! 1
    parseVal match = V.singleton . read $ match !! 2

analyzeEvolveFitness :: IO Bool
analyzeEvolveFitness = do
    let filename = "prop_evolveFitness.log"

    text <-
        outputToFile filename
        . verboseCheck
        . withMaxSuccess 300
        $ prop_evolveFitness

    let allData = parseQuickCheck text
        pairFit = Map.map $ V.zip (allData Map.! "dFit")
        rs      = Map.map correlation $ pairFit allData

    mapM_
        putStrLn
        ("correlations:" : [ k ++ " = " ++ show v | (k, v) <- Map.assocs rs ])
    return True

graphEvolveFitness :: IO Bool
graphEvolveFitness = do
    runs <- generate $ vectorOf
        10
        (arbitrary >>= \x -> arbitrary >>= \y -> genCollectEvolve x y)
    let avgRun = mergeRuns $ map (map avgFit) runs
    plot (PNG "plot.png") $ Function2D
        [Title "Average Fitness"]
        [Range 0 (int2Float $ length avgRun - 1), Step 1]
        ((avgRun !!) . float2Int)
  where
    avgFit :: [Agent a] -> Float
    avgFit = combineWith (/) [sum . map agentFitness, realToFrac . length]
    mergeRuns :: [[Float]] -> [Float]
    mergeRuns = foldl1' (zipWith (\x y -> (x + y) / 2))
    game      = playGame dilemma 5
    genCollectEvolve
        :: GamerParams -> EvolutionParams -> Gen [[Agent [PlayerState]]]
    genCollectEvolve gParams eParams@EvolutionParams {..} = do
        pop <- genPlayers gParams { gamerActions = 2 } evolvePopSize
        collectEvolve eParams game matchup pop

return []
runTests :: IO Bool
runTests = $quickCheckAll

ext: hs

max_stars_repo_name: desophos/gamer-evolution

max_issues_repo_name: desophos/gamer-evolution

max_forks_repo_name: desophos/gamer-evolution


text:
{-# LANGUAGE Haskell98 #-}
{-# LINE 1 "Data/Default/Class.hs" #-}

{-

Copyright (c) 2013 Lukas Mai

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 author nor the names of his contributors
  may be used to endorse or promote products derived from this software
  without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY LUKAS MAI 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 REGENTS 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.

-}

{-# LANGUAGE CPP #-}

{-# LANGUAGE DefaultSignatures, TypeOperators, FlexibleContexts #-}

module Data.Default.Class (
-- | This module defines a class for types with a default value.
-- It also defines 'Default' instances for the types 'Int', 'Int8',
-- 'Int16', 'Int32', 'Int64', 'Word', 'Word8', 'Word16', 'Word32', 'Word64',
-- 'Integer', 'Float', 'Double', 'Ratio', 'Complex', 'CShort', 'CUShort',
-- 'CInt', 'CUInt', 'CLong', 'CULong', 'CLLong', 'CULLong', 'CPtrdiff',
-- 'CSize', 'CSigAtomic', 'CIntPtr', 'CUIntPtr', 'CIntMax', 'CUIntMax',
-- 'CClock', 'CTime', 'CUSeconds', 'CSUSeconds', 'CFloat', 'CDouble', '(->)',
-- 'IO', 'Maybe', '()', '[]', 'Ordering', 'Any', 'All', 'Last', 'First', 'Sum',
-- 'Product', 'Endo', 'Dual', and tuples.
    Default(..)
) where

import Data.Int
import Data.Word
import Data.Monoid
import Data.Ratio
import Data.Complex
import Foreign.C.Types

import GHC.Generics

class GDefault f where
    gdef :: f a

instance GDefault U1 where
    gdef = U1

instance (Default a) => GDefault (K1 i a) where
    gdef = K1 def

instance (GDefault a, GDefault b) => GDefault (a :*: b) where
    gdef = gdef :*: gdef

instance (GDefault a) => GDefault (M1 i c a) where
    gdef = M1 gdef

-- | A class for types with a default value.
class Default a where
    -- | The default value for this type.
    def :: a

    default def :: (Generic a, GDefault (Rep a)) => a
    def = to gdef

instance Default Int where def = 0
instance Default Int8 where def = 0
instance Default Int16 where def = 0
instance Default Int32 where def = 0
instance Default Int64 where def = 0
instance Default Word where def = 0
instance Default Word8 where def = 0
instance Default Word16 where def = 0
instance Default Word32 where def = 0
instance Default Word64 where def = 0
instance Default Integer where def = 0
instance Default Float where def = 0
instance Default Double where def = 0
instance (Integral a) => Default (Ratio a) where def = 0
instance (Default a, RealFloat a) => Default (Complex a) where def = def :+ def

instance Default CShort     where def = 0
instance Default CUShort    where def = 0
instance Default CInt       where def = 0
instance Default CUInt      where def = 0
instance Default CLong      where def = 0
instance Default CULong     where def = 0
instance Default CLLong     where def = 0
instance Default CULLong    where def = 0
instance Default CPtrdiff   where def = 0
instance Default CSize      where def = 0
instance Default CSigAtomic where def = 0
instance Default CIntPtr    where def = 0
instance Default CUIntPtr   where def = 0
instance Default CIntMax    where def = 0
instance Default CUIntMax   where def = 0
instance Default CClock     where def = 0
instance Default CTime      where def = 0
instance Default CUSeconds  where def = 0
instance Default CSUSeconds where def = 0
instance Default CFloat     where def = 0
instance Default CDouble    where def = 0

instance (Default r) => Default (e -> r) where def = const def
instance (Default a) => Default (IO a) where def = return def

instance Default (Maybe a) where def = Nothing

instance Default () where def = mempty
instance Default [a] where def = mempty
instance Default Ordering where def = mempty
instance Default Any where def = mempty
instance Default All where def = mempty
instance Default (Last a) where def = mempty
instance Default (First a) where def = mempty
instance (Num a) => Default (Sum a) where def = mempty
instance (Num a) => Default (Product a) where def = mempty
instance Default (Endo a) where def = mempty

instance (Default a) => Default (Dual a) where def = Dual def
instance (Default a, Default b) => Default (a, b) where def = (def, def)
instance (Default a, Default b, Default c) => Default (a, b, c) where def = (def, def, def)
instance (Default a, Default b, Default c, Default d) => Default (a, b, c, d) where def = (def, def, def, def)
instance (Default a, Default b, Default c, Default d, Default e) => Default (a, b, c, d, e) where def = (def, def, def, def, def)
instance (Default a, Default b, Default c, Default d, Default e, Default f) => Default (a, b, c, d, e, f) where def = (def, def, def, def, def, def)
instance (Default a, Default b, Default c, Default d, Default e, Default f, Default g) => Default (a, b, c, d, e, f, g) where def = (def, def, def, def, def, def, def)

max_stars_repo_name: BinderDavid/fragnix

max_issues_repo_name: BinderDavid/fragnix

max_forks_repo_name: BinderDavid/fragnix


text:
{-# LANGUAGE RecordWildCards #-}
module SchemeParser.Printer where

import Data.Complex (Complex(..))
import Data.Ratio (numerator, denominator)

import SchemeParser.Types
import SchemeParser.Error

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

-- lispval

showVal :: LispVal -> String
showVal (LString s) = "\"" ++ s ++ "\""
showVal (LChar c) = "#\\" ++ [c]
showVal (LAtom a) = a
showVal LNil = "nil"
showVal (LNumber n) = show n
showVal (LFloat f) = show f
showVal (LRatio r) = show (numerator r) ++ "/" ++ show (denominator r)
showVal (LComplex (r :+ i)) = show r ++ "+" ++ show i ++ "i"
showVal (LBool True) = "#true"
showVal (LBool False) = "#false"
showVal (LList xs) = "(" ++ unwordsList xs ++ ")"
showVal (LDottedList hd tl) = "(" ++ unwordsList hd ++ " . " ++ showVal tl ++ ")"
showVal (LVector xs) = "#(" ++ unwordsList xs ++ ")"
showVal (LPrimFunc _) = "<primitive>"
showVal LFunc{..} = "(lambda (" ++ unwords (map show params) ++ vargs ++ ") ...)"
  where vargs = case vararg of Nothing -> ""
                               Just args -> " . " ++ args

instance Show LispVal where
  show = showVal

-- errors

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

instance Show LispError where
  show = showError

max_stars_repo_name: alexpeits/haskell-lab-old

max_issues_repo_name: alexpeits/haskell-lab-old

max_forks_repo_name: alexpeits/haskell-lab-old


text:
{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# HLINT ignore "Use camelCase"      #-}
{-|
Module      : Grenade.Layers.Internal.Add
Description : Fast functions for performing convolutions and helper functions
License     : BSD2
Stability   : experimental
-}
module Grenade.Layers.Internal.Convolution (
  -- * im2col functions
    im2col
  , col2im
  , col2vid
  , vid2col

  -- * convolution functions
  , forwardConv2d
  , forwardBiasConv2d
  , backwardConv2d
  , backwardBiasConv2d
  ) where

import qualified Data.Vector.Storable        as U (unsafeFromForeignPtr0,
                                                   unsafeToForeignPtr0)

import           Foreign                     (mallocForeignPtrArray,
                                              withForeignPtr)
import           Foreign.Ptr                 (Ptr)
import           Grenade.Types
import           Numeric.LinearAlgebra       (Matrix, Vector, cols, flatten,
                                              rows)
import qualified Numeric.LinearAlgebra       as LA
import qualified Numeric.LinearAlgebra.Devel as U
import           System.IO.Unsafe            (unsafePerformIO)

import Grenade.Layers.Internal.Hmatrix

-- | Rearrange the matrix columns into blocks, calculates the number of channels automatically.
col2vid :: Int            -- ^ kernel rows
        -> Int            -- ^ kernel columns
        -> Int            -- ^ stride rows
        -> Int            -- ^ stride columns
        -> Int            -- ^ input height
        -> Int            -- ^ input width
        -> Matrix RealNum -- ^ input matrix
        -> Matrix RealNum -- ^ output matrix
col2vid kernelRows kernelColumns strideRows strideColumns height width dataCol =
  let channels = cols dataCol `div` (kernelRows * kernelColumns)
      outRows  = (height - kernelRows) `div` strideRows + 1
      outCols  = (width - kernelColumns) `div` strideColumns + 1
  in  col2im_c channels height width kernelRows kernelColumns strideRows strideColumns 0 0 outRows outCols dataCol

-- | Rearrange the matrix columns into blocks, assumes there is only one channel
col2im :: Int            -- ^ kernel rows
       -> Int            -- ^ kernel columns
       -> Int            -- ^ stride rows
       -> Int            -- ^ stride columns
       -> Int            -- ^ input height
       -> Int            -- ^ input width
       -> Matrix RealNum -- ^ input matrix
       -> Matrix RealNum -- ^ output matrix
col2im kernelRows kernelColumns strideRows strideColumns height width dataCol =
  let channels = 1
      outRows  = (height - kernelRows) `div` strideRows + 1
      outCols  = (width - kernelColumns) `div` strideColumns + 1
  in  col2im_c channels height width kernelRows kernelColumns strideRows strideColumns 0 0 outRows outCols dataCol

col2im_c :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix RealNum -> Matrix RealNum
col2im_c channels height width kernelRows kernelColumns strideRows strideColumns padl padt outRows outCols dataCol =
  let vec = flatten dataCol
  in unsafePerformIO $ do
    outPtr <- mallocForeignPtrArray (height * width * channels)
    let (inPtr, _) = U.unsafeToForeignPtr0 vec

    withForeignPtr inPtr $ \inPtr' ->
      withForeignPtr outPtr $ \outPtr' ->
        col2im_cpu inPtr' channels height width kernelRows kernelColumns strideRows strideColumns padt padl outRows outCols outPtr'

    let matVec = U.unsafeFromForeignPtr0 outPtr (height * width * channels)
    return $ U.matrixFromVector U.RowMajor (height * channels) width matVec
{-# INLINE col2im_c #-}

foreign import ccall unsafe
    col2im_cpu
      :: Ptr RealNum -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr RealNum -> IO ()

-- | Rearrange the matrix blocks into columns, calculates the number of channels automatically.
vid2col :: Int            -- ^ kernel rows
        -> Int            -- ^ kernel columns
        -> Int            -- ^ stride rows
        -> Int            -- ^ stride columns
        -> Int            -- ^ input height
        -> Int            -- ^ input width
        -> Matrix RealNum -- ^ input matrix
        -> Matrix RealNum -- ^ output matrix
vid2col kernelRows kernelColumns strideRows strideColumns height width dataVid =
  let channels = rows dataVid `div` height
      rowOut          = (height - kernelRows) `div` strideRows + 1
      colOut          = (width - kernelColumns) `div` strideColumns + 1
  in  im2col_c channels height width kernelRows kernelColumns strideRows strideColumns 0 0 dataVid rowOut colOut

-- | Rearrange the matrix blocks into columns, assumes there is only one channel
im2col :: Int            -- ^ kernel rows
       -> Int            -- ^ kernel columns
       -> Int            -- ^ stride rows
       -> Int            -- ^ stride columns
       -> Matrix RealNum -- ^ input matrix
       -> Matrix RealNum -- ^ output matrix
im2col kernelRows kernelColumns strideRows strideColumns dataIm =
  let channels = 1
      height = rows dataIm
      width  = cols dataIm
      rowOut          = (height - kernelRows) `div` strideRows + 1
      colOut          = (width - kernelColumns) `div` strideColumns + 1
  in  im2col_c channels height width kernelRows kernelColumns strideRows strideColumns 0 0 dataIm rowOut colOut

im2col_c :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix RealNum -> Int -> Int -> Matrix RealNum
im2col_c channels height width kernelRows kernelColumns strideRows strideColumns padl padt dataIm outRows outCols =
  let vec             = flatten dataIm
      kernelSize      = kernelRows * kernelColumns
      numberOfPatches = outRows * outCols
  in unsafePerformIO $ do
    outPtr <- mallocForeignPtrArray (numberOfPatches * kernelSize * channels)
    let (inPtr, _) = U.unsafeToForeignPtr0 vec

    withForeignPtr inPtr $ \inPtr' ->
      withForeignPtr outPtr $ \outPtr' ->
        im2col_cpu inPtr' channels height width kernelRows kernelColumns strideRows strideColumns padt padl outRows outCols outPtr'

    let matVec = U.unsafeFromForeignPtr0 outPtr (numberOfPatches * kernelSize * channels)
    return $ U.matrixFromVector U.RowMajor (kernelSize * channels) numberOfPatches matVec
{-# INLINE im2col_c #-}

foreign import ccall unsafe
    im2col_cpu
      :: Ptr RealNum -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr RealNum -> IO ()

foreign import ccall unsafe
    in_place_add_per_channel_cpu
      :: Ptr RealNum -> Int -> Int -> Int -> Ptr RealNum -> IO ()

-- | Efficient implementation of convolutions using the im2col trick as popularised by Caffe
forwardConv2d :: Matrix RealNum -- ^ input
              -> Int            -- ^ input channels
              -> Int            -- ^ input rows
              -> Int            -- ^ input columns
              -> Matrix RealNum -- ^ kernel
              -> Int            -- ^ kernel filters
              -> Int            -- ^ kernel rows
              -> Int            -- ^ kernel columns
              -> Int            -- ^ stride height
              -> Int            -- ^ stride width
              -> Int            -- ^ output rows
              -> Int            -- ^ output columns
              -> Int            -- ^ pad left
              -> Int            -- ^ pad top
              -> Matrix RealNum -- ^ output of convolution
forwardConv2d input channels rows cols kernel filters kernelRows kernelCols strideRows strideCols outRows outCols padLeft padTop
  = let dataCol  = im2col_c channels rows cols kernelRows kernelCols strideRows strideCols padLeft padTop input outRows outCols
        gemmM    = LA.tr kernel LA.<> dataCol
        dataVid  = reshapeMatrix (filters * outRows) outCols gemmM
    in  dataVid

-- | Efficient implementation of convolutions using the im2col trick as popularised by Caffe
--   also adds some bias to the functions, note that it does it in place to prevent unnecessary allocation.
forwardBiasConv2d :: Matrix RealNum -- ^ input
                  -> Int            -- ^ input channels
                  -> Int            -- ^ input rows
                  -> Int            -- ^ input columns
                  -> Vector RealNum -- ^ bias
                  -> Matrix RealNum -- ^ kernel
                  -> Int            -- ^ kernel filters
                  -> Int            -- ^ kernel rows
                  -> Int            -- ^ kernel columns
                  -> Int            -- ^ stride height
                  -> Int            -- ^ stride width
                  -> Int            -- ^ output rows
                  -> Int            -- ^ output columns
                  -> Int            -- ^ pad left
                  -> Int            -- ^ pad top
                  -> Matrix RealNum -- ^ output of convolution
forwardBiasConv2d input channels rows cols bias kernel filters kernelRows kernelCols strideRows strideCols outRows outCols padLeft padTop =
  let outSize         = outRows * outCols * filters
  in  unsafePerformIO $ do
    let dataCol  = im2col_c channels rows cols kernelRows kernelCols strideRows strideCols padLeft padTop input outRows outCols
        gemmM    = LA.tr kernel LA.<> dataCol
        dataVid  = flatten gemmM
        (xPtr, _) = U.unsafeToForeignPtr0 dataVid
        (bPtr, _) = U.unsafeToForeignPtr0 bias

    withForeignPtr xPtr $ \xPtr' ->
      withForeignPtr bPtr $ \bPtr' ->
        in_place_add_per_channel_cpu xPtr' filters outRows outCols bPtr'

    let matVec = U.unsafeFromForeignPtr0 xPtr outSize
    return $ U.matrixFromVector U.RowMajor (outRows * filters) outCols matVec

-- | Efficient implementation of the backward pass for convolutions using the im2col trick as popularised by Caffe
backwardConv2d :: Matrix RealNum -- ^ input
               -> Int            -- ^ input channels
               -> Int            -- ^ input rows
               -> Int            -- ^ input columns
               -> Matrix RealNum -- ^ kernel
               -> Int            -- ^ kernel filters
               -> Int            -- ^ kernel rows
               -> Int            -- ^ kernel columns
               -> Int            -- ^ stride height
               -> Int            -- ^ stride width
               -> Int            -- ^ pad left
               -> Int            -- ^ pad top
               -> Int            -- ^ pad right
               -> Int            -- ^ pad bottom
               -> Matrix RealNum -- ^ derivative wrt out of layer
               -> Int            -- ^ output rows
               -> Int            -- ^ output columns
               -> (Matrix RealNum, Matrix RealNum)    -- ^ (derivated wrt input, derivative wrt kernel)
backwardConv2d input channels rows cols kernel filters kernelRows kernelCols strideRows strideCols padl padt padr padb dout outRows outCols =
  let dout'  = LA.reshape (outRows * outCols) $ LA.flatten dout
      dX_col = kernel LA.<> dout'
      rowCol = (div (rows + padt + padb - kernelRows) strideRows) + 1
      colCol = (div (cols + padl + padr - kernelCols) strideCols) + 1
      dX     = col2im_c channels rows cols kernelRows kernelCols strideRows strideCols padl padt rowCol colCol dX_col

      x_col  = im2col_c channels rows cols kernelRows kernelCols strideRows strideCols padl padt input outRows outCols
      dw_col = dout' LA.<> (LA.tr x_col)
      dw     = LA.tr $ reshapeMatrix filters (kernelRows * kernelCols * channels) dw_col
  in (dX, dw)

-- | Efficient implementation of the backward pass for convolutions using the im2col trick as popularised by Caffe
backwardBiasConv2d :: Matrix RealNum    -- ^ input
                   -> Int -- ^ input channels
                   -> Int -- ^ input rows
                   -> Int -- ^ input columns
                   -> Matrix RealNum -- ^ kernel
                   -> Int -- ^ kernel filters
                   -> Int -- ^ kernel rows
                   -> Int -- ^ kernel columns
                   -> Int -- ^ stride height
                   -> Int -- ^ stride width
                   -> Int -- ^ pad left
                   -> Int -- ^ pad top
                   -> Int -- ^ pad right
                   -> Int -- ^ pad bottom
                   -> Matrix RealNum -- ^ derivative wrt out of layer
                   -> Int -- ^ output rows
                   -> Int -- ^ output columns
                   -> (Matrix RealNum, Matrix RealNum, Vector RealNum)  -- ^ (derivated wrt input, derivative wrt kernel, derivative wrt bias)
backwardBiasConv2d input channels rows cols kernel filters kernelRows kernelCols strideRows strideCols padl padt padr padb dout outRows outCols =
  let (dX, dw) = backwardConv2d input channels rows cols kernel filters kernelRows kernelCols strideRows strideCols padl padt padr padb dout outRows outCols
      dB       = sum_over_channels_c dout filters outRows outCols
  in (dX, dw, dB)

sum_over_channels_c :: Matrix RealNum -> Int -> Int -> Int -> Vector RealNum
sum_over_channels_c mat channels rows cols = unsafePerformIO $ do
  let (xPtr, _) = U.unsafeToForeignPtr0 . flatten $ mat
  outPtr <- mallocForeignPtrArray channels

  withForeignPtr xPtr $ \xPtr' ->
    withForeignPtr outPtr $ \outPtr' ->
      sum_over_channels_cpu xPtr' channels rows cols outPtr'

  return $ U.unsafeFromForeignPtr0 outPtr channels

foreign import ccall unsafe
    sum_over_channels_cpu
      :: Ptr RealNum -> Int -> Int -> Int -> Ptr RealNum -> IO ()

max_stars_repo_name: th-char/grenade

max_issues_repo_name: th-char/grenade

max_forks_repo_name: th-char/grenade


text:
-- Draw fractal by escape time method

module Escape where

import Graphics.GD
import Data.Complex

import Draw

type C = Complex Double

-- maxTime            ->
-- maxRadius          ->
-- iteration function ->
-- initial value      ->
-- time to escape
escape :: Int -> Double -> (C -> C) -> C -> Int
escape maxTime maxRadius f x = length $ takeWhile (\z -> magnitude z < maxRadius) $ take (maxTime + 1) $ iterate f x

-- exit by difference
escape' :: Int -> Double -> (C -> C) -> C -> Int
escape' maxTime minDiff f x = length $ takeWhile (\(a, b) -> abs (a - b) > minDiff) st where
    a  = map magnitude $ take (maxTime + 2) $ iterate f x
    st = zip a (tail a)

-- f z = z^2 + c, z0 = 0
mandelbrot :: IO ()
mandelbrot = drawFractal "mandelbrot.png" imageSize coorRange colorMagic where
    imageSize = (1000, 1000)
    coorRange = (-2.0, 1.0, -1.5, 1.5)
    colorMagic (x, y)
        | t > maxTime   = rgb 0 0 0
        | otherwise     = color
        where maxTime   = 256
              maxRadius = 2.0
              f         = \z -> z^2 + (x :+ y)
              t         = (escape maxTime maxRadius f 0) - 1
              color     = rgb t t t

-- quadratic polynomials is only a small subset of Julia set
-- f z = z^2 + c, z0 unset
julia :: C -> IO ()
julia c = drawFractal "julia.png" imageSize coorRange (colorMagic c) where
    imageSize = (1000, 1000)
    coorRange = (-2.0, 2.0, -2.0, 2.0)
    colorMagic c (x, y)
        | t > maxTime   = rgb 0 0 0
        | otherwise     = color
        where maxTime   = 256
              maxRadius = 2.0
              f         = \z -> z^2 + c
              t         = (escape maxTime maxRadius f (x :+ y)) - 1
              color     = rgb t t t

-- f z = (|Re(z)| + i|Im(z)|)^2 + c, z0 = 0
-- using (-) to generate, for better view
burningShip :: IO ()
burningShip = drawFractal "burningShip.png" imageSize coorRange colorMagic where
    imageSize = (2000, 1500)
    coorRange = (-1.67, -1.65, -0.002, 0.013)
    colorMagic (x, y)
        | t > maxTime   = rgb 0 0 0
        | otherwise     = color
        where maxTime   = 256
              maxRadius = 2.0
              f         = \z -> ((abs $ realPart z) :+ (negate . abs $ imagPart z))^2 + (x :+ y)
              t         = (escape maxTime maxRadius f 0) - 1
              color     = rgb t t t

-- only a subset of Nova
-- f z = z^p - 1
-- z => z - Rf/f' + c, (c = 0)
nova :: Int -> Double -> IO ()
nova p r = drawFractal "nova.png" imageSize coorRange (colorMagic p r) where
    imageSize = (1000, 1000)
    coorRange = (-2.0, 2.0, -2.0, 2.0)
    colorMagic p r (x, y)
        | t > maxTime = rgb 0 0 0
        | otherwise   = color
        where maxTime   = 256
              minDiff   = 0.0001
              cr        = r :+ 0
              f         = \z -> z - cr * (z^p - 1) / (fromIntegral p * z^(p-1))
              t         = (escape' maxTime minDiff f (x :+ y)) - 1
              color     = rgb t t t


text:
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ExplicitForAll #-}
--{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
--{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
--{-# LANGUAGE RebindableSyntax #-}
--{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE OverloadedLists #-}
--{-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS_GHC -XBangPatterns #-}

module Test.Random ( testRandom ) where

import Prelude.Extended
-- import Control.Monad.Eff (Eff)
-- import Control.Monad.Eff.Console ( CONSOLE, log )
-- import Control.Monad.Eff.Random ( RANDOM )
-- import Data.List.Lazy ( replicateM )
import Data.Vector.Unboxed as A
  ( zipWith, fromList )
-- import Data.Traversable ( for )
-- import Data.Tuple ( Tuple (..) )
import Statistics.Sample ( meanVariance )
import System.Random ( RandomGen, newStdGen )
import Data.Time.Clock
-- import Text.Printf
-- import Control.Parallel
-- import Control.Parallel.Strategies

import Data.Cov ( chol, fromArray, toArray, (*.), Vec5 )
import FV.Fit ( fit )
import FV.Types ( VHMeas(..), HMeas(..), MMeas(..)
  , invMass, fromQMeas, fitMomenta )

{-- import qualified Graphics.Gnuplot.Frame.OptionSet as Opts --}
{-- import Graphics.Histogram --}

-- | Randomizable TypeClass to provide randomize method
-- | for MC smearing of a measurement
class Randomizable a where
  randomize :: RandomGen g => a -> g -> (a, g)
-- | randomize a single helix parameters measurement, based on the cov matrix
-- | return randomized helix
instance Randomizable HMeas where
  randomize (HMeas h hh w0) g = (HMeas h' hh w0, g') where
    (rs, g') = normals 5 g
    r5 :: Vec5
    r5 = fromArray rs
    h' = fromArray $ A.zipWith (+) (toArray h) (toArray (chol hh *. r5))

-- | randomize a vertex measurement by randomizing each helix parameter measurement
-- | leaving the initial vertex untouched
instance Randomizable VHMeas where
  randomize (VHMeas { vertex= v, helices= hl}) g =
    (VHMeas { vertex= v, helices= hl' }, g') where
      doit :: RandomGen g => HMeas -> (List HMeas, g) -> (List HMeas, g)
      doit h (hs, g) = (hs', g') where
        (h', g') = randomize h g
        hs' = h' : hs
      (hl', g') = foldr doit ([], g) hl

-- calc fitted invariant mass of VHMeas
fitm :: VHMeas -> Number
fitm vm = m where
  MMeas {m= m} = invMass <<< map fromQMeas <<< fitMomenta $ fit vm

testRandom ::Int
             -> VHMeas
             -> IO Text
testRandom cnt vm = do
  g <- newStdGen
  t0 <- getCurrentTime
  let
      mf = invMass <<< map fromQMeas <<< fitMomenta <<< fit $ vm
      !mr = MMeas {m=m, dm=sqrt dm2}
      (m, dm2) = meanVariance $ A.fromList ms
      ls :: [Int]
      ls = [0 .. (cnt-1)]
      (ms, _) = foldl doit ([], g) ls where
        doit :: RandomGen g => (List Number, g) -> Int -> (List Number, g)
        doit (ms, g) _ = (ms', g') where
          (vm', g') = randomize vm g
          m = fitm vm'
          ms' = m : ms
  t1 <- getCurrentTime

  -- ms = map func 1..cnt
  -- func vm g = (m, g') where
  --   (vm', g') = randomize vm g
  --   m' = fitm vm'

  pure $ "Fit Mass  " <> tshow mf
       <> "\nMean Mass " <> tshow mr
       <> "\ntime: "
            <> to2fix (realToFrac (diffUTCTime t1 t0) :: Number)
            <> " seconds"
  {-- let hist = histogram binSturges (V.toList hf) --}
  {-- _ <- plot "invMass.png" hist --}

max_stars_repo_name: LATBauerdick/fv-hs

max_issues_repo_name: LATBauerdick/fv-hs

max_forks_repo_name: LATBauerdick/fv-hs


text:
-------------------------------------------------------------------------------
-- |
-- Module    :  Supervised.LinearRegression
-- Copyright :  (c) Sam Stites 2017
-- License   :  MIT
-- Maintainer:  sam@stites.io
-- Stability :  experimental
-- Portability: non-portable
--
-- Fits a linear model with coefficients w = (w_1, ..., w_p) to minimize the
-- residual sum of squares between the observed responses in the dataset, and
-- the responses predicted by the linear approximation. Mathematically it solves
-- a problem of the form:
--
--     \underset{w}{min\,} {|| X w - y||_2}^2
--
-- === Ordinary Least Squares Complexity
--
-- This method computes the least squares solution using a singular value
-- decomposition of X. If X is a matrix of size (n, p) this method has a cost of
-- O(n p^2), assuming that n \geq p.
-------------------------------------------------------------------------------
{-# LANGUAGE TypeFamilies #-}
module Supervised.LinearRegression where

import Prelude
import qualified Data.Monoid as M
import Numeric.LinearAlgebra
import qualified Numeric.LinearAlgebra.Data as LD
import Debug.Trace

type Labels  = Vector Double
type Weights = Vector Double
type Inputs  = Matrix Double
type Model   = (Weights, Inputs -> Labels)

data LinearRegression = LinearRegression
  { nIters       :: Integer  -- ^ The number of iterations the algorithm will train weights for.
  , learningRate :: Double   -- ^ Step length for updating weights
  }

-- "scikit-learn style" naming
mkModel :: LinearRegression
mkModel = LinearRegression 100 0.001

fit :: LinearRegression -> Inputs -> Labels -> Model
fit cfg i l = weightedFit cfg w i l
  where
    nfs :: Int
    nfs = cols i

    w :: Weights
    w =  (vector $ replicate nfs 1) / (konst (fromIntegral nfs) nfs)

weightedFit :: LinearRegression -> Weights -> Inputs -> Labels -> Model
weightedFit cfg _ _xs y = (w, \i -> snocBias i #> w)
  where
    xs :: Matrix Double
    xs = snocBias _xs

    u, s, v :: Matrix Double
    (u, s, v) = svdM $ tr xs <> xs

    xSqInv :: Matrix Double
    xSqInv = (v <> pinv s) <> tr u

    w :: Vector Double
    w = (xSqInv <> tr xs) #> y

svdM :: Matrix Double -> (Matrix Double, Matrix Double, Matrix Double)
svdM = (\(a,b,c) -> (a, diag b, c)) . svd

consBias :: Matrix Double -> Matrix Double
consBias m = LD.fromColumns $ ones (snd $ size m) : LD.toColumns m

snocBias :: Matrix Double -> Matrix Double
snocBias m = m ||| konst 1 (fst (size m), 1)

ones :: Int -> Vector Double
ones = konst 1

predict :: Model -> Inputs -> Labels
predict (_, fn) i = fn i

-- | Returns the coefficient of determination R^2 of the prediction.
scoreR2Regressor :: (truth ~ Labels) => Model -> truth -> Inputs -> Double
scoreR2Regressor (_, fn) truth i = rSquare truth (fn i)

-- | Compute R^2, the coefficient of determination that
-- indicates goodness-of-fit of a regression.
rSquare :: (truth ~ Labels) => truth -> Labels -> Double
rSquare truth pred = 1 - numerator / denominator
  where
    weight :: Vector Double
    weight = 1

    numerator :: Double
    numerator = sumElements $ weight * ((truth - pred) ** 2)

    denominator :: Double
    denominator = sumElements $ weight * ((truth - averageTruth) ** 2)

    averageTruth :: Vector Double
    averageTruth = konst ((sumElements truth) / (fromIntegral n)) n
      where
        n :: Int
        n = size truth

sumColumns :: Matrix Double -> Vector Double
sumColumns = vector . fmap sumElements . toColumns

coefficients :: Model -> Weights
coefficients = fst

max_stars_repo_name: stites/hasklearn

max_issues_repo_name: stites/hasklearn

max_forks_repo_name: stites/hasklearn


text:
{-# LANGUAGE Trustworthy #-}
-- |
-- Module    : Statistics.Distribution.Hypergeometric.GenVar
-- Copyright : (c) 2015 Sam Rijs
--             (c) 2005 Robert Kern
--             (c) 1998 Ivan Frohne
-- License   : MIT
--
-- Maintainer  : srijs@airpost.net
-- Stability   : experimental
--

module Statistics.Distribution.Hypergeometric.GenVar (genVar) where

import Control.Monad.Primitive (PrimMonad, PrimState)

import Statistics.Distribution (ContGen(..), DiscreteGen(..))
import Statistics.Distribution.Hypergeometric (HypergeometricDistribution, hdM, hdL, hdK)

import Numeric.SpecFunctions (logGamma)

import System.Random.MWC (Gen, uniform)

d1 = 1.7155277699214135 -- 2*sqrt(2/e)
d2 = 0.8989161620588988 -- 3 - 2*sqrt(3/e)

instance ContGen HypergeometricDistribution
  where genContVar d g = return . fromIntegral =<< genVar (hdM d, hdL d, hdK d) g

instance DiscreteGen HypergeometricDistribution
  where genDiscreteVar d g = genVar (hdM d, hdL d, hdK d) g

-- | Random variates from the hypergeometric distribution /(m, l, k)/.
-- Returns the number of white balls drawn when /k/ balls
-- are drawn at random from an urn containing /m/ white
-- and /l-m/ black balls.
genVar :: (PrimMonad m, Integral a) => (a, a, a) -> Gen (PrimState m) -> m a
genVar (good, popsize, sample) gen = return . fix2 . fix1 =<< loop
  where fix1 z = if good > bad then m - z else z
        fix2 z = if m < sample then good - z else z
        mingoodbad = min good bad
        bad = popsize - good
        maxgoodbad = max good bad
        m = min sample (popsize - sample)
        gamma z = sum $ map (logGamma . fromIntegral)
          [ z + 1,     mingoodbad - z + 1
          , m - z + 1, maxgoodbad - m + z + 1 ]
        d4 = fromIntegral mingoodbad / fromIntegral popsize
        d5 = 1 - d4
        d6 = fromIntegral m * d4 + 0.5
        d7 = sqrt $ fromIntegral (popsize - m) * fromIntegral sample * d4 * d5 / fromIntegral (popsize - 1) + 0.5
        d8 = d1 * d7 + d2
        d9 = floor $ fromIntegral (m + 1) * fromIntegral (mingoodbad + 1) / fromIntegral (popsize + 2)
        d10 = gamma d9
        d11 = fromIntegral $ min (min m mingoodbad + 1) (floor (d6 + 16 * d7))
        -- 16 for 16-decimal-digit precision in d1 and d2
        loop = do
          x <- uniform gen
          y <- uniform gen
          case () of
            _  | w < 0 || w >= d11    -> loop -- fast rejection
               | x * (4 - x) - 3 <= t -> return z -- fast acceptance
               | x * (x - t) >= 1     -> loop -- fast rejection
               | 2 * (log x) <= t     -> return z -- acceptance
               | otherwise            -> loop -- rejection
               where w = d6 + d8 * (y - 0.5) / x
                     z = floor w
                     t = d10 - gamma z

max_stars_repo_name: srijs/statistics-hypergeometric-gen

max_issues_repo_name: srijs/statistics-hypergeometric-gen

max_forks_repo_name: srijs/statistics-hypergeometric-gen


text:
import Graphics.Gloss
import Graphics.Gloss.Raster.Field
import Graphics.Gloss.Data.ViewPort
import Data.Complex
import Data.Colour.RGBSpace
import Data.Colour.RGBSpace.HSV
import qualified Graphics.Gloss.Data.Point.Arithmetic as PA

mandelbrot :: Complex Float -> Complex Float -> Int -> (Complex Float, Int)
mandelbrot z _ 0 = (z, 0)
mandelbrot z c n
  | magnitude z > 2 = (z, n)
  | otherwise = mandelbrot (z * z + c) c (n - 1)

rgbcolor :: Float -> Float -> Float -> Color
rgbcolor r g b = makeColor r g b 1.0

smoothcolor :: Complex Float -> Int -> Int -> Color
smoothcolor _ 0 _ = black
smoothcolor z n max = (uncurryRGB rgbcolor) $ hsv deg 1 1
  where deg = 360 * ((fromIntegral n) - 1.0 + (log (log (magnitude z))) / (log 2)) / (fromIntegral max)

colorof :: Int -> Point -> Color
colorof max (x,y) = let (z, n) = mandelbrot 0 (x :+ y) max
                in smoothcolor z n max

getpicture :: ViewPort -> Float -> (Picture,Point) -> (Picture,Point)
getpicture vp _ pd@(pic,pt) = let npt = invertViewPort vp (1,1)
                                  adjpt = (PA.- (1/300 PA.* t)).(300/scl PA.*)
                                  adjpic = (translate (-tx) (-ty)).(scale (300 /scl) (300/scl))
                                  t@(tx,ty) = viewPortTranslate vp
                                  scl = 300 * (viewPortScale vp)
                                  max = (round $ 4 * (log scl))
                              in case (pt /= npt) of
                                True -> (adjpic $ makePicture 600 600 5 5 ((colorof max).adjpt), npt)
                                False -> pd

main :: IO ()
main = simulate
  (InWindow "Mandelbrot" (600,600) (20,20))
  black
  1
  (Circle 0, (0,0))
  (\(p,_ ) -> p)
  getpicture

max_stars_repo_name: swarmalator/mandelbrot-zoom

max_issues_repo_name: swarmalator/mandelbrot-zoom

max_forks_repo_name: swarmalator/mandelbrot-zoom


text:
-- |
-- Module    : Main
-- Copyright : (c) 2011 Jason Knight
-- License   : BSD3
--
-- Maintainer  : jason@jasonknight.us
-- Stability   : experimental
-- Portability : portable
--
-- See the help information by executing the generated executable with no
-- parameters.
--

module Main where

import GRN.Parse
import GRN.StateTransition
import GRN.Render
import GRN.Types
import GRN.Density
import GRN.Sparse
import GRN.EM
import GRN.Uncertainty
import GRN.DataFlow
import GRN.Utils

import qualified Data.Map as M
import Data.List
import Data.Ord
import Control.Monad
import Text.Printf
import System.Environment
import System.Cmd
import System.Console.ParseArgs
import System.FilePath
import System.Directory

import Data.Graph.Analysis

import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.Vector.Generic as G
import Statistics.Sample.KernelDensity
import Statistics.Sample
import Graphics.Gnuplot.Simple

argList :: [Arg String]
argList =
 [ Arg "output" (Just 'o') (Just "output")
    (argDataDefaulted "FILE" ArgtypeString "out.svg") "Output file."
 , Arg "extra" (Just 'e') (Just "extra")
    (argDataDefaulted "PW_ARGS" ArgtypeString "")
    "Extra Pathway arguments; space delimited."
 , Arg "extra2" (Just 'f') (Just "extra2")
    (argDataDefaulted "PW_ARGS" ArgtypeString "")
    "Extra Pathway arguments; space delimited For SM runs."
 , Arg "reduce" (Just 'r') (Just "reduce") Nothing
    "Reduce output graph to attractor cycles."
 , Arg "generate" (Just 'g') (Just "generate") Nothing
    "Generate an image"
 , Arg "open" (Just 'x') (Just "open") Nothing
    "Open generated image automatically"
 , Arg "avg" Nothing (Just "avg")
    (argDataDefaulted "INT" ArgtypeInt 8)
    "Averaging sums to perform"
 , Arg "n1" Nothing (Just "n1")
    (argDataDefaulted "INT" ArgtypeInt 15)
    "First elimination (reduction) pass amount"
 , Arg "n2" Nothing (Just "n2")
    (argDataDefaulted "INT" ArgtypeInt 150)
    "Second pass (only simulation) amount. "
 , Arg "n3" Nothing (Just "n3")
    (argDataDefaulted "INT" ArgtypeInt 140)
    "Runs for Density estimation ignored if m!=d"
 , Arg "n4" Nothing (Just "n4")
    (argDataDefaulted "INT" ArgtypeInt 0)
    ("If mode=d, then this is the seed, otherwise 0:deterministic equal valued "++
    "outgoing edge probabilities. Also number of samples in \
    \sampling dataflow mode.")
 , Arg "mode" (Just 'm') (Just "mode")
    (argDataRequired "MODE" ArgtypeString)
    ("s:state transition graph, ss:state transition matrix, p:pathway diagram, \
    \sm:modified stg, d:density estimation, em:expectation maximization, \
    \m:Mohammad output, df: DataFlow, c: Control")
 , Arg "submode" Nothing (Just "submode")
    (argDataDefaulted "SUBMODE" ArgtypeString "m")
    "m: Matrix multiplication, g: graph, \
    \When control: e: exact, s: sampling."
 , Arg "prog" (Nothing) (Just "prog")
    (argDataDefaulted "PROG" ArgtypeString "dot")
    "Graphviz Draw Program to generate output"
 , Arg "knock" (Just 'k') (Just "knock")
    (argDataDefaulted "KNOCK" ArgtypeString "stoch")
    "Knockouts in Dataflow mode: det(erministic), stoch(astic)"
 , Arg "gamma" Nothing (Just "gamma")
    (argDataDefaulted "DOUBLE" ArgtypeDouble 0.1)
    "Amount to modify edges in dataflow mode."
 , Arg "perturb" (Just 'p') (Just "perturb")
    (argDataDefaulted "DOUBLE" ArgtypeDouble 0.0)
    "In Mohammad output, set the perturbation probability."
 , Arg "input" Nothing Nothing
    (argDataRequired "FILE" ArgtypeString) "Input File."
 ]

main = do
    args <- parseArgsIO ArgsComplete argList
    let inFile = getRequiredArg args "input"
        n1 = getRequiredArg args "n1" :: Int
        n2 = getRequiredArg args "n2" :: Int
        mode = getRequiredArg args "mode"
        gen = gotArg args "generate"
        modes = ["s","p","sm","d","ss","em","m","df","c"]
    if (length (modes\\[mode]) == length mode)
        then error $ usageError args ("Choose a valid mode.")
        else return ()
    con <- readFile inFile
    let start = parsePW $ (unlines.words $ getRequiredArg args "extra2") ++ con
        p = parsePW $ (unlines.words $ getRequiredArg args "extra") ++ con

    when (mode == "s") $ do
        let initg = kmapToStateGraph.buildKmaps $ p
            finalGraph = simulate args initg
        if (n1+n2 < 50) then print "WARNING: Number of simulation iterations \
        \less than 50. Please consider increasing n1 or n2. Also consider \
        \using the far superior 'ss' method for simulation." else return ()
        mapM_ (printf "%7s") (M.keys p)
        putStrLn ""
        printSSA $ genSSA finalGraph
        when gen $ drawStateGraph finalGraph args
        return ()

    when (mode == "ss") $ do
        let initm = (kmapToDOK.buildKmaps $ p)  0
            finalSSD = simulateDOKUnif args initm
            (DOK (n,_) m) = initm
        mapM_ (printf "%7s") (M.keys p)
        putStrLn ""
        --print $ maximum $ map (snd) $ M.keys m
        --print $ G.length $ colIndices $ dokToCSC initm
        --print $ G.length $ rowIndices $ dokToCSC initm
        --print $ G.length $ cscValues $ dokToCSC initm
        printSSA $ ssdToSSA finalSSD
        --Cant draw a graph when we have a matrix... well we could, but we'd
        --have to convert:
        --when gen $ drawStateGraph finalGraph args
        return ()

    when (mode == "df") $ do
        let initm = parseToDataFlow args p
            finalSSD = simulateDOKUnif args initm
            graph = convertProbsVG finalSSD $ dataFlowToGraph initm
            (DOK (n,_) m) = initm
        mapM_ (printf "%7s") (M.keys p)
        putStrLn ""
        printSSA $ ssdToSSA finalSSD
        when gen $ drawDataFlow graph args
        return ()

    when (mode == "c") $ do
        let pcon = parseControl con
        simControl args p pcon
        return ()

    when (mode == "d") $ do
        simRuns args p
        return ()

    when (mode == "m") $ do
        uncertaintyPrint args p
        return ()

    when (mode == "sm") $ do
        let initm = (kmapToDOK.buildKmaps $ start)  0
            secm = (kmapToDOK.buildKmaps $ p) 0
            interSSD = simulateDOKUnif args initm
            (DOK (n,_) m) = initm
            finalSSD = simulateDOK args secm interSSD
        mapM_ (printf "%7s") (M.keys p)
        putStrLn ""
        printSSA $ ssdToSSA finalSSD
        return ()

    when (mode == "p") $ do
        let finalGraph = mkSimple $ buildGeneGraph p
        when gen $ drawGeneGraph finalGraph args
        return ()

defArgs :: Args String
defArgs = parseArgs ArgsComplete argList "./grnsim" ["-m","df","pws/doesntmatter.pw"]

max_stars_repo_name: binarybana/grn-pathways

max_issues_repo_name: binarybana/grn-pathways

max_forks_repo_name: binarybana/grn-pathways


text:
-----------------------------------------------------------------------------
-- |
-- Module      :  Internal.IO
-- Copyright   :  (c) Alberto Ruiz 2010
-- License     :  BSD3
--
-- Maintainer  :  Alberto Ruiz
-- Stability   :  provisional
--
-- Display, formatting and IO functions for numeric 'Vector' and 'Matrix'
--
-----------------------------------------------------------------------------

module Internal.IO (
    dispf, disps, dispcf, vecdisp, latexFormat, format,
    loadMatrix, loadMatrix', saveMatrix
) where

import           Data.Complex
import           Data.List           (intersperse, transpose)
import           Internal.Devel
import           Internal.Matrix
import           Internal.Vector
import           Internal.Vectorized
import           Text.Printf         (PrintfArg, PrintfType, printf)

-- | Formatting tool
table :: String -> [[String]] -> String
table sep as = unlines . map unwords' $ transpose mtp
  where
    mt = transpose as
    longs = map (maximum . map length) mt
    mtp = zipWith (\a b -> map (pad a) b) longs mt
    pad n str = replicate (n - length str) ' ' ++ str
    unwords' = concat . intersperse sep

{- | Creates a string from a matrix given a separator and a function to show each entry. Using
this function the user can easily define any desired display function:

@import Text.Printf(printf)@

@disp = putStr . format \"  \" (printf \"%.2f\")@

-}
format :: (Element t) => String -> (t -> String) -> Matrix t -> String
format sep f m = table sep . map (map f) . toLists $ m

{- | Show a matrix with \"autoscaling\" and a given number of decimal places.

>>> putStr . disps 2 $ 120 * (3><4) [1..]
3x4  E3
 0.12  0.24  0.36  0.48
 0.60  0.72  0.84  0.96
 1.08  1.20  1.32  1.44

-}
disps :: Int -> Matrix Float -> String
disps d x = sdims x ++ "  " ++ formatScaled d x

{- | Show a matrix with a given number of decimal places.

>>> dispf 2 (1/3 + ident 3)
"3x3\n1.33  0.33  0.33\n0.33  1.33  0.33\n0.33  0.33  1.33\n"

>>> putStr . dispf 2 $ (3><4)[1,1.5..]
3x4
1.00  1.50  2.00  2.50
3.00  3.50  4.00  4.50
5.00  5.50  6.00  6.50

>>> putStr . unlines . tail . lines . dispf 2 . asRow $ linspace 10 (0,1)
0.00  0.11  0.22  0.33  0.44  0.56  0.67  0.78  0.89  1.00

-}
dispf :: Int -> Matrix Float -> String
dispf d x = sdims x ++ "\n" ++ formatFixed (if isInt x then 0 else d) x

sdims :: Matrix t -> [Char]
sdims x = show (rows x) ++ "x" ++ show (cols x)

formatFixed :: (Show a, Text.Printf.PrintfArg t, Element t)
            => a -> Matrix t -> String
formatFixed d x = format "  " (printf ("%."++show d++"f")) $ x

isInt :: Matrix Float -> Bool
isInt = all lookslikeInt . toList . flatten

formatScaled :: (Text.Printf.PrintfArg b, RealFrac b, Floating b, Num t, Element b, Show t)
             => t -> Matrix b -> [Char]
formatScaled dec t = "E"++show o++"\n" ++ ss
    where ss = format " " (printf fmt. g) t
          g x | o >= 0    = x/10^(o::Int)
              | otherwise = x*10^(-o)
          o | rows t == 0 || cols t == 0 = 0
            | otherwise = floor $ maximum $ map (logBase 10 . abs) $ toList $ flatten t
          fmt = '%':show (dec+3) ++ '.':show dec ++"f"

{- | Show a vector using a function for showing matrices.

>>> putStr . vecdisp (dispf 2) $ linspace 10 (0,1)
10 |> 0.00  0.11  0.22  0.33  0.44  0.56  0.67  0.78  0.89  1.00

-}
vecdisp :: (Element t) => (Matrix t -> String) -> Vector t -> String
vecdisp f v
    = ((show (dim v) ++ " |> ") ++) . (++"\n")
    . unwords . lines .  tail . dropWhile (not . (`elem` " \n"))
    . f . trans . reshape 1
    $ v

{- | Tool to display matrices with latex syntax.

>>>  latexFormat "bmatrix" (dispf 2 $ ident 2)
"\\begin{bmatrix}\n1  &  0\n\\\\\n0  &  1\n\\end{bmatrix}"

-}
latexFormat :: String -- ^ type of braces: \"matrix\", \"bmatrix\", \"pmatrix\", etc.
            -> String -- ^ Formatted matrix, with elements separated by spaces and newlines
            -> String
latexFormat del tab = "\\begin{"++del++"}\n" ++ f tab ++ "\\end{"++del++"}"
    where f = unlines . intersperse "\\\\" . map unwords . map (intersperse " & " . words) . tail . lines

-- | Pretty print a complex number with at most n decimal digits.
showComplex :: Int -> Complex Float -> String
showComplex d (a:+b)
    | isZero a && isZero b = "0"
    | isZero b = sa
    | isZero a && isOne b = s2++"i"
    | isZero a = sb++"i"
    | isOne b = sa++s3++"i"
    | otherwise = sa++s1++sb++"i"
  where
    sa = shcr d a
    sb = shcr d b
    s1 = if b<0 then "" else "+"
    s2 = if b<0 then "-" else ""
    s3 = if b<0 then "-" else "+"

shcr :: (Show a, Show t1, Text.Printf.PrintfType t, Text.Printf.PrintfArg t1, RealFrac t1)
     => a -> t1 -> t
shcr d a | lookslikeInt a = printf "%.0f" a
         | otherwise      = printf ("%."++show d++"f") a

lookslikeInt :: (Show a, RealFrac a) => a -> Bool
lookslikeInt x = show (round x :: Int) ++".0" == shx || "-0.0" == shx
   where shx = show x

isZero :: Show a => a -> Bool
isZero x = show x `elem` ["0.0","-0.0"]
isOne :: Show a => a -> Bool
isOne  x = show x `elem` ["1.0","-1.0"]

-- | Pretty print a complex matrix with at most n decimal digits.
dispcf :: Int -> Matrix (Complex Float) -> String
dispcf d m = sdims m ++ "\n" ++ format "  " (showComplex d) m

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

apparentCols :: FilePath -> IO Int
apparentCols s = f . dropWhile null . map words . lines <$> readFile s
  where
    f []    = 0
    f (x:_) = length x

-- | load a matrix from an ASCII file formatted as a 2D table.
loadMatrix :: FilePath -> IO (Matrix Float)
loadMatrix f = do
    v <- vectorScan f
    c <- apparentCols f
    if (dim v `mod` c /= 0)
      then
        error $ printf "loadMatrix: %d elements and %d columns in file %s"
                       (dim v) c f
      else
        return (reshape c v)

loadMatrix' :: FilePath -> IO (Maybe (Matrix Float))
loadMatrix' name = mbCatch (loadMatrix name)

max_stars_repo_name: schnecki/hmatrix-float

max_issues_repo_name: schnecki/hmatrix-float

max_forks_repo_name: schnecki/hmatrix-float


text:
{-|
Module: MachineLearning.Regularization
Description: Regularization
Copyright: (c) Alexander Ignatyev, 2017
License: BSD-3
Stability: experimental
Portability: POSIX

Regularization.
-}

module MachineLearning.Regularization
(
  Regularization(..)
  , costReg
  , gradientReg
)

where

import MachineLearning.Types (R, Vector)
import qualified Data.Vector.Storable as V
import qualified Numeric.LinearAlgebra as LA

-- | Regularization
data Regularization = RegNone -- ^ No regularization
                    | L2 R    -- ^ L2 Regularization

-- | Calculates regularization for Model.cost function.
-- It takes regularization parameter and theta.
costReg :: Regularization -> Vector -> R
costReg RegNone _ = 0
costReg (L2 lambda) theta = (thetaReg LA.<.> thetaReg) * lambda * 0.5
  where thetaReg = V.tail theta

-- | Calculates regularization for Model.gradient function.
-- It takes regularization parameter and theta.
gradientReg :: Regularization -> Vector -> Vector
gradientReg RegNone _ = 0
gradientReg (L2 lambda) theta = (LA.scalar lambda) * thetaReg
  where thetaReg = theta V.// [(0, 0)]

max_stars_repo_name: aligusnet/mltool

max_issues_repo_name: aligusnet/mltool

max_forks_repo_name: aligusnet/mltool


text:
module NeuralNet.Cost (computeCost) where

import Numeric.LinearAlgebra

computeCost :: Matrix Double -> Matrix Double -> Double
computeCost al y
  | rows al /= 1       = error "al should be a row vector"
  | rows y /= 1        = error "y should be a row vector"
  | cols y /= cols al = error "y and al should be same length"
  -- TODO: Must be a better impl than this sum
  | otherwise           = (-1 / fromIntegral m) * sum (concat (toLists (term1 + term2)))
    where
      m = cols y
      unitRowVector = row (replicate m 1)
      term1 = y * cmap log al
      term2 = (unitRowVector - y) * (cmap log (unitRowVector - al))

max_stars_repo_name: danielholmes/neural-net

max_issues_repo_name: danielholmes/neural-net

max_forks_repo_name: danielholmes/neural-net