text:
{-# LANGUAGE ViewPatterns #-}
-- |
-- Module    : Statistics.Test.WilcoxonT
-- Copyright : (c) 2010 Neil Brown
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- The Wilcoxon matched-pairs signed-rank test is non-parametric test
-- which could be used to test whether two related samples have
-- different means.
module Statistics.Test.WilcoxonT (
    -- * Wilcoxon signed-rank matched-pair test
    -- ** Test
    wilcoxonMatchedPairTest
    -- ** Building blocks
  , wilcoxonMatchedPairSignedRank
  , wilcoxonMatchedPairSignificant
  , wilcoxonMatchedPairSignificance
  , wilcoxonMatchedPairCriticalValue
  , module Statistics.Test.Types
    -- * References
    -- $references
  ) where

--
--
--
-- Note that: wilcoxonMatchedPairSignedRank == (\(x, y) -> (y, x)) . flip wilcoxonMatchedPairSignedRank
-- The samples are zipped together: if one is longer than the other, both are truncated
-- The value returned is the pair (T+, T-).  T+ is the sum of positive ranks (the
-- These values mean little by themselves, and should be combined with the 'wilcoxonSignificant'
-- function in this module to get a meaningful result.
-- ranks of the differences where the first parameter is higher) whereas T- is
-- the sum of negative ranks (the ranks of the differences where the second parameter is higher).
-- to the length of the shorter sample.

import Data.Function (on)
import Data.List (findIndex)
import Data.Ord (comparing)
import qualified Data.Vector.Unboxed as U
import Prelude hiding (sum)
import Statistics.Function (sortBy)
import Statistics.Sample.Internal (sum)
import Statistics.Test.Internal (rank, splitByTags)
import Statistics.Test.Types
import Statistics.Types -- (CL,pValue,getPValue)
import Statistics.Distribution
import Statistics.Distribution.Normal

-- | Calculate (n,T⁺,T⁻) values for both samples. Where /n/ is reduced
--   sample where equal pairs are removed.
wilcoxonMatchedPairSignedRank :: (Ord a, Num a, U.Unbox a) => U.Vector (a,a) -> (Int, Double, Double)
wilcoxonMatchedPairSignedRank ab
  = (nRed, sum ranks1, negate (sum ranks2))
  where
    -- Positive and negative ranks
    (ranks1, ranks2) = splitByTags
                     $ U.zip tags (rank ((==) `on` abs) diffs)
    -- Sorted list of differences
    diffsSorted = sortBy (comparing abs)    -- Sort the differences by absolute difference
                $ U.filter  (/= 0)          -- Remove equal elements
                $ U.map (uncurry (-)) ab    -- Work out differences
    nRed = U.length diffsSorted
    -- Sign tags and differences
    (tags,diffs) = U.unzip
                 $ U.map (\x -> (x>0 , x))   -- Attach tags to distribution elements
                 $ diffsSorted

-- | The coefficients for x^0, x^1, x^2, etc, in the expression
-- \prod_{r=1}^s (1 + x^r).  See the Mitic paper for details.
--
-- We can define:
-- f(1) = 1 + x
-- f(r) = (1 + x^r)*f(r-1)
--      = f(r-1) + x^r * f(r-1)
-- The effect of multiplying the equation by x^r is to shift
-- all the coefficients by r down the list.
--
-- This list will be processed lazily from the head.
coefficients :: Int -> [Integer]
coefficients 1 = [1, 1] -- 1 + x
coefficients r = let coeffs = coefficients (r-1)
                     (firstR, rest) = splitAt r coeffs
  in firstR ++ add rest coeffs
  where
    add (x:xs) (y:ys) = x + y : add xs ys
    add xs [] = xs
    add [] ys = ys

-- This list will be processed lazily from the head.
summedCoefficients :: Int -> [Double]
summedCoefficients n
  | n < 1     = error "Statistics.Test.WilcoxonT.summedCoefficients: nonpositive sample size"
  | n > 1023  = error "Statistics.Test.WilcoxonT.summedCoefficients: sample is too large (see bug #18)"
  | otherwise = map fromIntegral $ scanl1 (+) $ coefficients n

-- | Tests whether a given result from a Wilcoxon signed-rank matched-pairs test
-- is significant at the given level.
--
-- This function can perform a one-tailed or two-tailed test.  If the first
-- parameter to this function is 'TwoTailed', the test is performed two-tailed to
-- check if the two samples differ significantly.  If the first parameter is
-- 'OneTailed', the check is performed one-tailed to decide whether the first sample
-- (i.e. the first sample you passed to 'wilcoxonMatchedPairSignedRank') is
-- greater than the second sample (i.e. the second sample you passed to
-- 'wilcoxonMatchedPairSignedRank').  If you wish to perform a one-tailed test
-- in the opposite direction, you can either pass the parameters in a different
-- order to 'wilcoxonMatchedPairSignedRank', or simply swap the values in the resulting
-- pair before passing them to this function.
wilcoxonMatchedPairSignificant
  :: PositionTest          -- ^ How to compare two samples
  -> PValue Double         -- ^ The p-value at which to test (e.g. @mkPValue 0.05@)
  -> (Int, Double, Double) -- ^ The (n,T⁺, T⁻) values from 'wilcoxonMatchedPairSignedRank'.
  -> Maybe TestResult      -- ^ Return 'Nothing' if the sample was too
                           --   small to make a decision.
wilcoxonMatchedPairSignificant test pVal (sampleSize, tPlus, tMinus) =
  case test of
    -- According to my nearest book (Understanding Research Methods and Statistics
    -- by Gary W. Heiman, p590), to check that the first sample is bigger you must
    -- use the absolute value of T- for a one-tailed check:
    AGreater      -> do crit <- wilcoxonMatchedPairCriticalValue sampleSize pVal
                        return $ significant $ abs tMinus <= fromIntegral crit
    BGreater      -> do crit <- wilcoxonMatchedPairCriticalValue sampleSize pVal
                        return $ significant $ abs tPlus <= fromIntegral crit
    -- Otherwise you must use the value of T+ and T- with the smallest absolute value:
    --
    -- Note that in absence of ties sum of |T+| and |T-| is constant
    -- so by selecting minimal we are performing two-tailed test and
    -- look and both tails of distribution of T.
    SamplesDiffer -> do crit <- wilcoxonMatchedPairCriticalValue sampleSize (mkPValue $ p/2)
                        return $ significant $ t <= fromIntegral crit
  where
    t = min (abs tPlus) (abs tMinus)
    p = pValue pVal

-- | Obtains the critical value of T to compare against, given a sample size
-- and a p-value (significance level).  Your T value must be less than or
-- equal to the return of this function in order for the test to work out
-- significant.  If there is a Nothing return, the sample size is too small to
-- make a decision.
--
-- 'wilcoxonSignificant' tests the return value of 'wilcoxonMatchedPairSignedRank'
-- for you, so you should use 'wilcoxonSignificant' for determining test results.
--  However, this function is useful, for example, for generating lookup tables
-- for Wilcoxon signed rank critical values.
--
-- The return values of this function are generated using the method
-- detailed in the Mitic's paper. According to that paper, the results
-- may differ from other published lookup tables, but (Mitic claims)
-- the values obtained by this function will be the correct ones.
wilcoxonMatchedPairCriticalValue ::
     Int                -- ^ The sample size
  -> PValue Double      -- ^ The p-value (e.g. @mkPValue 0.05@) for which you want the critical value.
  -> Maybe Int          -- ^ The critical value (of T), or Nothing if
                        --   the sample is too small to make a decision.
wilcoxonMatchedPairCriticalValue n pVal
  | n < 100   =
      case subtract 1 <$> findIndex (> m) (summedCoefficients n) of
        Just k | k < 0     -> Nothing
               | otherwise -> Just k
        Nothing  -> error "Statistics.Test.WilcoxonT.wilcoxonMatchedPairCriticalValue: impossible happened"
  | otherwise =
     case quantile (normalApprox n) p of
       z | z < 0     -> Nothing
         | otherwise -> Just (round z)
  where
    p = pValue pVal
    m = (2 ** fromIntegral n) * p

-- | Works out the significance level (p-value) of a T value, given a sample
-- size and a T value from the Wilcoxon signed-rank matched-pairs test.
--
-- See the notes on 'wilcoxonCriticalValue' for how this is calculated.
wilcoxonMatchedPairSignificance
  :: Int           -- ^ The sample size
  -> Double        -- ^ The value of T for which you want the significance.
  -> PValue Double -- ^ The significance (p-value).
wilcoxonMatchedPairSignificance n t
  = mkPValue p
  where
    p | n < 100   = (summedCoefficients n !! floor t) / 2 ** fromIntegral n
      | otherwise = cumulative (normalApprox n) t

-- | Normal approximation for Wilcoxon T statistics
normalApprox :: Int -> NormalDistribution
normalApprox ni
  = normalDistr m s
  where
    m = n * (n + 1) / 4
    s = sqrt $ (n * (n + 1) * (2*n + 1)) / 24
    n = fromIntegral ni

-- | The Wilcoxon matched-pairs signed-rank test. The samples are
-- zipped together: if one is longer than the other, both are
-- truncated to the length of the shorter sample.
--
-- For one-tailed test it tests whether first sample is significantly
-- greater than the second. For two-tailed it checks whether they
-- significantly differ
--
-- Check 'wilcoxonMatchedPairSignedRank' and
-- 'wilcoxonMatchedPairSignificant' for additional information.
wilcoxonMatchedPairTest
  :: (Ord a, Num a, U.Unbox a)
  => PositionTest     -- ^ Perform one-tailed test.
  -> U.Vector (a,a)   -- ^ Sample of pairs
  -> Test ()          -- ^ Return 'Nothing' if the sample was too
                      --   small to make a decision.
wilcoxonMatchedPairTest test pairs =
  Test { testSignificance = pVal
       , testStatistics   = t
       , testDistribution = ()
       }
  where
    (n,tPlus,tMinus) = wilcoxonMatchedPairSignedRank pairs
    (t,pVal) = case test of
                 AGreater      -> (abs tMinus, wilcoxonMatchedPairSignificance n (abs tMinus))
                 BGreater      -> (abs tPlus,  wilcoxonMatchedPairSignificance n (abs tPlus ))
                 -- Since we take minimum of T+,T- we can't get more
                 -- that p=0.5 and can multiply it by 2 without risk
                 -- of error.
                 SamplesDiffer -> let t' = min (abs tMinus) (abs tPlus)
                                      p  = wilcoxonMatchedPairSignificance n t'
                                  in (t', mkPValue $ min 1 $ 2 * pValue p)

-- $references
--
-- * \"Critical Values for the Wilcoxon Signed Rank Statistic\", Peter
--   Mitic, The Mathematica Journal, volume 6, issue 3, 1996
--   (<http://www.mathematica-journal.com/issue/v6i3/article/mitic/contents/63mitic.pdf>)

max_stars_repo_name: vaerksted/statistics

max_issues_repo_name: vaerksted/statistics

max_forks_repo_name: vaerksted/statistics


text:
{- |

This module defines the monad of sampling functions. See

Park, Pfenning and Thrun (2005) A probabilistic language based upon sampling
functions, Principles of Programming Languages 2005

Sampling functions allow the composition of both discrete and continuous
probability distributions.

The implementation and interface are similar to those in the random-fu,
monte-carlo and monad-mersenne-random packages.

Example -- a biased coin:

@
data Throw = Head | Tail

throw bias = do
  b <- bernoulli bias
  return $ if b then Head else Tail

tenThrowsCrooked = replicateM 10 $ throw 0.3

countHeads = do
   throws <- tenThrowsCrooked
   return $ length [ () | Head <- throws]

main = do
 print =<< sampleIO tenThrowsCrooked
 print =<< eval ((\<4) \`fmap\` countHeads)
@

-}

{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}

module Math.Probably.Sampler where

import Control.Monad
import Data.List
import Data.Maybe
import Data.Ord
import qualified Math.Probably.PDF as PDF
import Math.Probably.Types
import Numeric.LinearAlgebra hiding (find)
import System.Environment
import System.Random.Mersenne.Pure64

-- | given a seed, return an infinite list of draws from sampling function
runProb :: Seed -> Prob a -> [a]
runProb pmt s@(Sampler sf)
   = let (x, pmt') = sf pmt
     in x : runProb pmt' s
runProb _ (Samples xs) = xs

-- | given a seed, return an infinite list of draws from sampling function
runProbOne :: Seed -> Prob a -> (a,Seed)
runProbOne pmt (Sampler sf)
   = sf pmt
runProbOne pmt (Samples xs) = primOneOf xs pmt

-- | Get a seed
getSeedIO :: IO Seed
getSeedIO = do
   args <- getArgs
   case mapMaybe (stripPrefix "--seed=") args of
      [] ->  newPureMT
      sdStr:_ -> return $ pureMT $ read sdStr

-- | Return an infinite list of draws from sampling function in the IO monad
runProbIO :: Prob a -> IO [a]
runProbIO s =
   fmap (`runProb` s) $ getSeedIO

-- | Return a singe draw from sampling function
sampleIO :: Prob a -> IO a
sampleIO s = head `fmap` runProbIO s

-- | Return a list of n draws from sampling function
sampleNIO :: Int -> Prob a -> IO [a]
sampleNIO n s = take n `fmap` runProbIO s

-- | Estimate the probability that a hypothesis is true (in the IO monad)
eval :: Prob Bool -> Prob Double
eval s = do
  bs <- replicateM 1000 s
  return $ realToFrac (length (filter id bs)) / 1000

{-mu :: Vector Double
sigma :: Matrix Double

mystery = -1
mu = fromList [0,0,0]
sigma =  (3><3) [ 1,    1,       0,
                  1,    1,     mystery,
                  0,  mystery,   1]

samIt = sampleNIO 2 $ multiNormal mu sigma
 -}
-- | The joint distribution of two independent distributions
joint :: Prob a -> Prob b -> Prob (a,b)
joint sf1 sf2 = liftM2 (,) sf1 sf2

-- | The joint distribution of two distributions where one depends on the other
jointConditional :: Prob a -> (a-> Prob b) -> Prob (a,b)
jointConditional sf1 condsf
    = do x <- sf1
         y <- condsf x
         return (x,y)

--replicateM :: Monad m => Int -> m a -> m [a]
--replicateM n ma = forM [1..n] $ const ma

-- * Uniform distributions

-- | The unit interval U(0,1)
unit :: Prob Double
unit = Sampler randomDouble

-- | for x and y, the uniform distribution between x and y
uniform :: (Fractional a) => a -> a -> Prob a
uniform a b = (\x->(realToFrac x)*(b-a)+a) `fmap` unit

-- | useful for data display
jitter :: Double -> [Int] -> Prob [Double]
jitter j = mapM $ \i-> let x = realToFrac i in uniform (x-j) (x+j)

-- * Normally distributed sampling function

--http://en.wikipedia.org/wiki/Box-Muller_transform
-- | The univariate gaussian (normal) distribution defined by mean and standard deviation

unormal ::  Prob Double
unormal = do
   u1 <- unit
   u2 <- unit
   return (sqrt ((0.0-2.0) * log u1) * cos(2.0 * pi * u2))

normal :: Double -> Double -> Prob Double
normal mean variance = do
   u <- unormal
   return (u * (sqrt variance) + mean)

normalMany :: [(Double,Double)] -> Prob [Double]
normalMany means_vars = do gus <- normalManyUnit (length means_vars)
                           return $ map f $ zip gus means_vars
    where f (gu, (mean, var)) = gu*(sqrt var)+mean

normalManyUnit :: Int -> Prob [Double]
normalManyUnit 0 = return []
normalManyUnit n | odd n = liftM2 (:) unormal (normalManyUnit (n-1))
                 | otherwise = do us <- forM [1..n] $ const $ unit
                                  return $ gaussTwoAtATime $ map realToFrac us
  where
    gaussTwoAtATime :: Floating a =>  [a] -> [a]
    gaussTwoAtATime (u1:u2:rest) = sqrt(-2*log(u1))*cos(2*pi*u2) : sqrt(-2*log(u1))*sin(2*pi*u2) : gaussTwoAtATime rest
    gaussTwoAtATime _ = []

-- | Multivariate normal distribution
multiNormal :: Vector Double -> Matrix Double -> Prob (Vector Double)
multiNormal mu sigma =
  let c =   cholSH sigma
      a = trans c
      k = dim mu
  in do z <- fromList `fmap` normalManyUnit k
--        return $ mu + (head $ toColumns $ a*asRow z)
        let c = asColumn z
        let r = asRow z
        return $ (mu + (head $ toColumns $ a `multiply` asColumn z))

multiNormalByChol :: Vector Double -> Matrix Double -> Prob (Vector Double)
multiNormalByChol mu cholSigma =
  let a = trans $ cholSigma
      k = dim mu
  in do z <- fromList `fmap` normalManyUnit k
--        return $ mu + (head $ toColumns $ a*asRow z)
        let c = asColumn z
        let r = asRow z
        return $ (mu + (head $ toColumns $ a `multiply` asColumn z))

multiNormalIndep  :: Vector Double -> Vector Double -> Prob (Vector Double)
multiNormalIndep vars mus = do
   let k = dim mus
   gs <- normalManyUnit k
   return $ fromList $ zipWith3 (\var mu g -> g*sqrt(var) + mu) (toList vars) (toList mus) gs

--http://en.wikipedia.org/wiki/Log-normal_distribution#Generating_log-normally-distributed_random_variates

-- | log-normal distribution <http://en.wikipedia.org/wiki/Log-normal_distribution>
logNormal :: Double -> Double -> Prob Double
logNormal m var =
    fmap exp $  normal m var

-- * Other distribution

-- | Bernoulli distribution. Returns a Boolean that is 'True' with probability 'p'
bernoulli :: Double -> Prob Bool
bernoulli p = (<p) `fmap` unit

discrete :: [(Double,a)] -> Prob a
discrete weightedSamples =
   let sumWeights = sum $ map fst weightedSamples
       cummWeightedSamples = scanl (\(csum,_) (w,x) -> (csum+w,x)) (0,undefined) $ sortBy (comparing fst) weightedSamples
   in do u <- unit
         case find ((>=u*sumWeights) . fst) cummWeightedSamples of
           Just (_,x) -> return x
           Nothing -> error $ "discrete error u*sumweigts="++show (u*sumWeights)++"wsams="++show (map fst cummWeightedSamples)

-- primOneOf :: [a] -> Seed -> (a, Seed)
-- primOneOf xs seed
--    = let (u, nextSeed) = randomDouble seed
--          idx = floor $ (realToFrac u)*(realToFrac $ length xs )
--      in (xs !! idx, nextSeed)

shuffle :: [a] -> Prob [a]
shuffle xs = do
  uxs <- forM xs $ \x -> do
    u <- unit
    return (u,x)
  return $ map snd $ sortBy (comparing fst) uxs

oneOf :: [a] -> Prob a
oneOf xs = do idx <- floor `fmap` uniform (0::Double) (realToFrac $ length xs )
              return $ xs !! idx

nOf :: Int -> [a] -> Prob [a]
nOf n xs = sequence $ replicate n $ oneOf xs

--sampling without replacement. Terrible performance
nDistinctOf :: Int ->  [a] -> Prob [a]
nDistinctOf wantN xs = do
  let haveN = length xs
      select ys | length ys == wantN = return ys
                | otherwise = do
                    y <- floor `fmap` uniform (0::Double) (realToFrac $ length xs )
                    if y `elem` ys
                       then select ys
                       else select (y:ys)
  ixs <- select []
  return $ map (xs!!) ixs

withoutReplacementFrom :: Eq a => Int -> Prob a -> Prob [a]
withoutReplacementFrom wantN p = select [] where
  select ys | length ys == wantN = return ys
            | otherwise = do
                y <- p
                if y `elem` ys
                  then select ys
                  else select (y:ys)

-- | Bayesian inference from likelihood and prior using rejection sampling.
bayesRejection :: (PDF.PDF a) -> Double -> Prob a -> Prob a
bayesRejection p c q = bayes
    where bayes = do x <- q
                     u <- unit
                     if u < p x / c
                        then return x
                        else bayes

--poisson ::  ::  Double -> [Double] -> IO Double
-- | Exponential distribution
expDist rate =  (\u-> negate $ (log(1-u))/rate) `fmap` unit

poissonAux :: Double -> Int -> Double -> Prob Int
poissonAux bigl k p = if p>bigl
                         then do
                           u<- unit
                           poissonAux bigl (k+1) (p*u)
                         else return (k-1)

poisson :: Double -> (Prob Int)
poisson lam =  poissonAux (exp (-lam)) 0 1

-- | binomial distribution
binomial :: Int -> Double -> Prob Int
binomial n p = do
  bools <- forM [1..n] $ const $ fmap (<p) unit
  return $ length $ [t | t@True <- bools]

-- from random-fu
-- | Gamma distribution
gamma :: Double -> Double -> Prob Double
gamma a b
     | a < 1
    = do
        u <- unit
        x <- gamma (1 + a) b
        return (x * u ** recip a)
    | otherwise
    = go
        where
            d = a - (1 / 3)
            c = recip (3 * sqrt d) -- (1 / 3) / sqrt d

            go = do
                x <- unormal

                let cx = c * x
                    v = (1 + cx) ^ 3

                    x_2 = x * x
                    x_4 = x_2 * x_2

                if cx <= (-1)
                    then go
                    else do
                        u <- unit

                        if         u < 1 - 0.0331 * x_4
                            || log u < 0.5 * x_2  + d * (1 - v + log v)
                            then return (b * d * v)
                            else go

-- | inverse gamma distribution
invGamma :: Double -> Double -> Prob Double
invGamma a b = recip `fmap` gamma a b

-- | beta distribution
beta :: Int -> Int -> Prob Double
beta a b =
    let gam n = do us <- forM [1..n] $ const unit
                   return $ log $ product us
    in do gama1 <- gamma (realToFrac a) 1

          gamb <- gamma (realToFrac b) 1
          return $ gama1/(gama1+gamb)

ext: hs

max_stars_repo_name: glutamate/probably-baysig

max_issues_repo_name: silky/probably-baysig

max_forks_repo_name: silky/probably-baysig


text:
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE OverloadedLabels      #-}

module Grenade.Dynamic.Layers.FullyConnected
  ( SpecFullyConnected (..)
  , specFullyConnected
  , fullyConnected
  ) where

import           Data.Proxy
import           Data.Reflection                     (reifyNat)
import           Data.Singletons
import           Data.Singletons.Prelude.Num         ((%*))
import           Data.Singletons.TypeLits            hiding (natVal)
import           GHC.TypeLits

import           Numeric.LinearAlgebra.Static        hiding (build, toRows, (&),
                                                      (|||), size)

import           Grenade.Core
import           Grenade.Utils.ListStore
import           Grenade.Dynamic.Internal.Build
import           Grenade.Dynamic.Specification
import           Grenade.Layers.FullyConnected

-------------------- DynamicNetwork instance --------------------

instance (KnownNat i, KnownNat o) => FromDynamicLayer (FullyConnected i o) where
  fromDynamicLayer _ _ _ = SpecNetLayer $ SpecFullyConnected (natVal (Proxy :: Proxy i)) (natVal (Proxy :: Proxy o))

instance ToDynamicLayer SpecFullyConnected where
  toDynamicLayer wInit gen (SpecFullyConnected nrI nrO) =
    reifyNat nrI $ \(pxInp :: (KnownNat i) => Proxy i) ->
      reifyNat nrO $ \(pxOut :: (KnownNat o') => Proxy o') ->
        case singByProxy pxInp %* singByProxy pxOut of
          SNat -> do
            (layer :: FullyConnected i o') <- randomFullyConnected wInit gen
            return $ SpecLayer layer (sing :: Sing ('D1 i)) (sing :: Sing ('D1 o'))

-- | Make a specification of a fully connected layer (see Grenade.Dynamic.Build for a user-interface to specifications).
specFullyConnected :: Integer -> Integer -> SpecNet
specFullyConnected nrI nrO = SpecNetLayer $ SpecFullyConnected nrI nrO

-- | A Fully-connected layer with input dimensions as given in last output layer and output dimensions specified. 1D only!
fullyConnected :: Integer -> BuildM ()
fullyConnected rows = do
  (inRows, _, _) <- buildRequireLastLayerOut Is1D
  buildAddSpec (SpecNetLayer $ SpecFullyConnected inRows rows)
  buildSetLastLayer (rows, 1, 1)

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

instance (KnownNat i, KnownNat o) => GNum (FullyConnected i o) where
  s |* FullyConnected w store = FullyConnected (s |* w) (s |* store)
  FullyConnected w1 store1 |+ FullyConnected w2 store2 = FullyConnected (w1 |+ w2) (store1 |+ store2)
  gFromRational r = FullyConnected (gFromRational r) mkListStore

instance (KnownNat i, KnownNat o) => GNum (FullyConnected' i o) where
  s |* FullyConnected' b w = FullyConnected' (dvmap (fromRational s *) b) (dmmap (fromRational s *) w)
  FullyConnected' b1 w1 |+ FullyConnected' b2 w2 = FullyConnected' (b1 + b2) (w1 + w2)
  gFromRational r = FullyConnected' (fromRational r) (fromRational r)

max_stars_repo_name: th-char/grenade

max_issues_repo_name: th-char/grenade

max_forks_repo_name: th-char/grenade


text:
{-# LANGUAGE CPP, NoImplicitPrelude #-}
module Data.Complex.Compat (
  module Base
#if MIN_VERSION_base(4,4,0) && !(MIN_VERSION_base(4,8,0))
, realPart
, imagPart
, mkPolar
, cis
, conjugate
#endif
) where

#if !(MIN_VERSION_base(4,4,0)) || MIN_VERSION_base(4,8,0)
import Data.Complex as Base
#else
import Data.Complex as Base hiding (
    realPart
  , imagPart
  , mkPolar
  , cis
  , conjugate
  )
import Prelude
#endif

#if MIN_VERSION_base(4,4,0) && !(MIN_VERSION_base(4,8,0))
-- | Extracts the real part of a complex number.
realPart :: Complex a -> a
realPart (x :+ _) =  x

-- | Extracts the imaginary part of a complex number.
imagPart :: Complex a -> a
imagPart (_ :+ y) =  y

-- | The conjugate of a complex number.
{-# SPECIALISE conjugate :: Complex Double -> Complex Double #-}
conjugate        :: Num a => Complex a -> Complex a
conjugate (x:+y) =  x :+ (-y)

-- | Form a complex number from polar components of magnitude and phase.
{-# SPECIALISE mkPolar :: Double -> Double -> Complex Double #-}
mkPolar          :: Floating a => a -> a -> Complex a
mkPolar r theta  =  r * cos theta :+ r * sin theta

-- | @'cis' t@ is a complex value with magnitude @1@
-- and phase @t@ (modulo @2*'pi'@).
{-# SPECIALISE cis :: Double -> Complex Double #-}
cis              :: Floating a => a -> Complex a
cis theta        =  cos theta :+ sin theta
#endif

max_stars_repo_name: kozross/base-compat

max_issues_repo_name: kozross/base-compat

max_forks_repo_name: kozross/base-compat


text:
module STCR2Z2T0S0Image where

import           Data.Array.Repa         as R
import           Data.Binary             (decodeFile)
import           Data.Complex
import           Data.List               as L
import           DFT.Plan
import           FokkerPlanck.MonteCarlo
import           FokkerPlanck.Pinwheel
import           Image.IO
import           STC
import           System.Directory
import           System.Environment
import           System.FilePath
import           Text.Printf
import           Types

main = do
  args@(numPointStr:numOrientationStr:numScaleStr:thetaSigmaStr:scaleSigmaStr:maxScaleStr:taoStr:numTrailStr:maxTrailStr:theta0FreqsStr:thetaFreqsStr:scale0FreqsStr:scaleFreqsStr:histFilePath:numIterationStr:writeSourceFlagStr:imagePath:cutoffRStr:reversalFactorStr:numThreadStr:_) <-
    getArgs
  print args
  let numPoint = read numPointStr :: Int
      numOrientation = read numOrientationStr :: Int
      numScale = read numScaleStr :: Int
      thetaSigma = read thetaSigmaStr :: Double
      scaleSigma = read scaleSigmaStr :: Double
      maxScale = read maxScaleStr :: Double
      tao = read taoStr :: Double
      numTrail = read numTrailStr :: Int
      maxTrail = read maxTrailStr :: Int
      theta0Freq = read theta0FreqsStr :: Double
      theta0Freqs = [-theta0Freq .. theta0Freq]
      thetaFreq = read thetaFreqsStr :: Double
      thetaFreqs = [-thetaFreq .. thetaFreq]
      scale0Freq = read scale0FreqsStr :: Double
      scaleFreq = read scaleFreqsStr :: Double
      scale0Freqs = [-scale0Freq .. scale0Freq]
      scaleFreqs = [-scaleFreq .. scaleFreq]
      numIteration = read numIterationStr :: Int
      writeSourceFlag = read writeSourceFlagStr :: Bool
      cutoffR = read cutoffRStr :: Int
      reversalFactor = read reversalFactorStr :: Double
      numThread = read numThreadStr :: Int
      folderPath = "output/test/STCR2Z2T0S0Image"
  imgRepa@(ImageRepa _ img') <- readImageRepa imagePath False
  let (Z :. _ :. cols :. rows) = extent img'
      img =
        computeUnboxedS . R.traverse img' id $ \f idx@(Z :. k :. i :. j) ->
          if (sqrt . fromIntegral $ (i - div cols 2) ^ 2 + (j - div rows 2) ^ 2) >
             48
            then 0
            else f idx
  createDirectoryIfMissing True folderPath
  plotImageRepa (folderPath </> "input.png") . ImageRepa 8 $ img
  flag <- doesFileExist histFilePath
  radialArr <-
    if flag
      then R.map magnitude . getNormalizedHistogramArr <$>
           decodeFile histFilePath
      else do
        putStrLn "Couldn't find a Green's function data. Start simulation..."
        solveMonteCarloR2Z2T0S0Radial
          numThread
          numTrail
          maxTrail
          cols
          rows
          thetaSigma
          scaleSigma
          maxScale
          tao
          theta0Freqs
          thetaFreqs
          scale0Freqs
          scaleFreqs
          histFilePath
          (emptyHistogram
             [ (round . sqrt . fromIntegral $ 2 * (div (max rows cols) 2) ^ 2)
             , L.length scale0Freqs
             , L.length theta0Freqs
             , L.length scaleFreqs
             , L.length thetaFreqs
             ]
             0)
  arrR2Z2T0S0 <-
    computeUnboxedP $
    computeR2Z2T0S0ArrayRadial
      (cutoff cutoffR radialArr)
      cols
      rows
      1
      maxScale
      thetaFreqs
      scaleFreqs
      theta0Freqs
      scale0Freqs
  plan <- makeR2Z2T0S0Plan emptyPlan arrR2Z2T0S0
  powerMethodR2Z2T0S0Reversal
    plan
    folderPath
    cols
    rows
    numOrientation
    thetaFreqs
    theta0Freqs
    numScale
    scaleFreqs
    scale0Freqs
    arrR2Z2T0S0
    numIteration
    writeSourceFlag
    (printf
       "_%d_%d_%.2f_%.2f"
       (round maxScale :: Int)
       (round tao :: Int)
       thetaSigma
       scaleSigma)
    0.5
    reversalFactor
    (R.traverse
       img
       (const
          (Z :. (L.length theta0Freqs) :. (L.length scale0Freqs) :. cols :. rows)) $ \f (Z :. _ :. _ :. i :. j) ->
       if f (Z :. (0 :: Int) :. i :. j) > 0
         then 1
         else 0)
    (R.traverse
       img
       (const
          (Z :. (L.length thetaFreqs) :. (L.length scaleFreqs) :.
           (L.length theta0Freqs) :.
           (L.length scale0Freqs) :.
           cols :.
           rows)) $ \f (Z :. k :. l :. _ :. _ :. i :. j) ->
       if k == div (L.length thetaFreqs) 2 && l == div (L.length scaleFreqs) 2
         then 1 / (fromIntegral $ (L.length theta0Freqs * L.length scale0Freqs)) :+
              0
         else 0)

max_stars_repo_name: XinhuaZhang/Stochastic-Completion-Field

max_issues_repo_name: XinhuaZhang/Stochastic-Completion-Field

max_forks_repo_name: XinhuaZhang/Stochastic-Completion-Field


text:
module Math.IRT.Model.OnePLM
  ( OnePLM (..)
  ) where

import Statistics.Distribution

import Math.IRT.Internal.Distribution
import Math.IRT.Internal.LogLikelihood
import Math.IRT.Model.FourPLM ( FourPLM(..) )
import Math.IRT.Model.Generic

data OnePLM = OnePLM { difficulty :: !Double
                     } deriving (Show)

instance Distribution OnePLM where
    cumulative = cumulative . toFourPLM

instance ContDistr OnePLM where
    density    = density . toFourPLM
    quantile _ = error "This shouldn't be needed"

instance DensityDeriv OnePLM where
    densityDeriv = densityDeriv . toFourPLM

instance GenericModel OnePLM where
    fromRasch           = OnePLM
    fromOnePLM          = OnePLM
    fromTwoPLM      _ b = OnePLM b
    fromThreePLM  _ b _ = OnePLM b
    fromFourPLM _ b _ _ = OnePLM b

instance LogLikelihood OnePLM where
    logLikelihood b = logLikelihood b . toFourPLM

toFourPLM :: OnePLM -> FourPLM
toFourPLM (OnePLM sb) = FourPLM 1.7 sb 0.0 1.0

max_stars_repo_name: argiopetech/irt

max_issues_repo_name: argiopetech/irt

max_forks_repo_name: argiopetech/irt


text:
module School.Types.Encoding
( Put
, putDouble
, putInt
, putWord
, doubleToBin
, intToBin
, wordToBin
, matrixDoubleToBin
, matrixIntToBin
, runPut
) where

import Data.ByteString (ByteString)
import Data.Serialize.IEEE754 (putFloat64be)
import Data.Serialize.Put (Put, putInt32be, putWord8, runPut)
import Data.Word (Word8)
import Numeric.LinearAlgebra (Element, I, Matrix, R, toLists)
import School.Types.DataType (DataType(..))

putDouble :: R -> Put
putDouble = putFloat64be

doubleToBin :: R -> ByteString
doubleToBin = runPut . putDouble

putInt :: I -> Put
putInt = putInt32be . fromIntegral

intToBin :: I -> ByteString
intToBin = runPut . putInt

putWord :: Word8 -> Put
putWord = putWord8

wordToBin :: Word8 -> ByteString
wordToBin = runPut . putWord

writer :: (Element b)
       => (a -> Put)
       -> ([b] -> [a])
       -> (Matrix b -> ByteString)
writer put trans matrix = runPut $
  mapM_ put ( trans
            . concat
            . toLists
            $ matrix
            )

matrixDoubleToBin :: DataType
                  -> Matrix R
                  -> ByteString
matrixDoubleToBin DBL64B = writer putDouble id
matrixDoubleToBin INT32B = undefined
matrixDoubleToBin INT08B = undefined

matrixIntToBin :: DataType
               -> Matrix I
               -> ByteString
matrixIntToBin DBL64B =
  writer putDouble (map fromIntegral)
matrixIntToBin INT32B =
  writer putInt id
matrixIntToBin INT08B = undefined

max_stars_repo_name: jfulseca/School

max_issues_repo_name: jfulseca/School

max_forks_repo_name: jfulseca/School


text:
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif

module Complex (
        Complex((:+)), realPart, imagPart, conjugate,
        mkPolar, cis, polar, magnitude, phase
    ) where

import Data.Complex

max_stars_repo_name: emorins/nahc

max_issues_repo_name: emorins/nahc

max_forks_repo_name: emorins/nahc


text:
{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE ConstraintKinds         #-}
{-# LANGUAGE DefaultSignatures       #-}
{-# LANGUAGE FlexibleContexts        #-}
{-# LANGUAGE FlexibleInstances       #-}
{-# LANGUAGE FunctionalDependencies  #-}
{-# LANGUAGE KindSignatures          #-}
{-# LANGUAGE MultiParamTypeClasses   #-}
{-# LANGUAGE TypeFamilies            #-}
{-# LANGUAGE ViewPatterns            #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Coordinates.Isomorphic
-- Copyright   :  (C) 2015 Christopher Chalmers
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Christopher Chalmers
-- Stability   :  experimental
-- Portability :  non-portable
--
-- This module defines a class for coordinates that are (loosely)
-- isomorphic to the standard spaces ('V2' and 'V3'). This allows plots
-- to accept more data types for plot data.
--
----------------------------------------------------------------------------
module Diagrams.Coordinates.Isomorphic
  ( -- * Type constraints
    HasIndexedBasis, Euclidean

    -- * Vector like
  , VectorLike (..)
  , V2Like, V3Like

    -- * Point like
  , PointLike (..)
  , P2Like, P3Like
  )
  where

import           Control.Lens
import           Data.Complex
import           Data.Typeable

import           Diagrams.Prelude

type HasIndexedBasis v = (HasBasis v, TraversableWithIndex (E v) v)

-- | Umbrella class giving everything needed for working in the space. This is
--   basically 'V2' or 'V3' from "linear".
type Euclidean (v :: * -> *) = (HasLinearMap v, HasIndexedBasis v, Metric v)

-- vector like ---------------------------------------------------------

-- | Provides an 'Iso'' between @a@ and @v n@. This is normally used to
--   convert between the data type you're already using, @a@, and diagram's
--   native form, @v n@.
class (Euclidean v, Typeable v) => VectorLike v n a | a -> v n where
  -- | Isomorphism from @Point v n@ to something 'PointLike' @a@.
  --
  -- >>> V2 3 5 ^. vectorLike :: (Int, Int)
  -- (3,5)
  vectorLike :: Iso' (v n) a

  -- | Isomorphism from something 'PointLike' @a@ to @Point v n@.
  --
  -- >>> ((3, 5) :: (Int, Int)) ^. unvectorLike
  -- V2 3 5
  unvectorLike :: Iso' a (v n)
  unvectorLike = from vectorLike
  {-# INLINE unvectorLike #-}

instance VectorLike V2 n (V2 n) where
  vectorLike = id
  {-# INLINE vectorLike #-}

type V2Like = VectorLike V2

instance n ~ m => VectorLike V2 n (n, m) where
  vectorLike = iso unr2 r2
  {-# INLINE vectorLike #-}

instance VectorLike V2 n (Complex n) where
  vectorLike = iso (\(V2 x y) -> x :+ y)
                   (\(i :+ j) -> V2 i j)
  {-# INLINE vectorLike #-}

type V3Like = VectorLike V3

instance VectorLike V3 n (V3 n) where
  vectorLike = id
  {-# INLINE vectorLike #-}

instance (n ~ m, m ~ o) => VectorLike V3 n (n, m, o) where
  vectorLike = iso unr3 r3
  {-# INLINE vectorLike #-}

-- point like ----------------------------------------------------------

-- | Provides an 'Iso'' between @a@ and @'Point' v n@. This is normally used to
--   convert between the data type you're already using, @a@, and diagram's
--   native form, @'Point' v n@.
class (Euclidean v, Typeable v) => PointLike v n a | a -> v n where
  -- | Isomorphism from @'Point' v n@ to something 'PointLike' @a@.
  --
  -- >>> mkP2 3 5 ^. pointLike :: (Int, Int)
  -- (3,5)
  pointLike :: Iso' (Point v n) a

  -- | Isomorphism from something 'PointLike' @a@ to @Point v n@.
  --
  -- >>> ((3, 5) :: (Int, Int)) ^. unpointLike
  -- P (V2 3 5)
  unpointLike :: Iso' a (Point v n)
  unpointLike = from pointLike
  {-# INLINE unpointLike #-}

-- | Things that are isomorphic to points in R2.
type P2Like = PointLike V2

instance (Euclidean v, Typeable v) => PointLike v n (Point v n) where
  pointLike = id

instance PointLike V2 n (V2 n) where
  pointLike = _Point
  {-# INLINE pointLike #-}

instance n ~ m => PointLike V2 n (n, m) where
  pointLike = iso unp2 p2
  {-# INLINE pointLike #-}

instance PointLike V2 n (Complex n) where
  pointLike = iso (\(unp2 -> (x,y)) -> x :+ y)
                  (\(i :+ j)        -> p2 (i,j))
  {-# INLINE pointLike #-}

type P3Like = PointLike V3

instance (n ~ m, m ~ o) => PointLike V3 n (n, m, o) where
  pointLike = iso unp3 p3
  {-# INLINE pointLike #-}

max_stars_repo_name: adamConnerSax/plots

max_issues_repo_name: adamConnerSax/plots

max_forks_repo_name: adamConnerSax/plots


text:
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FunctionalDependencies #-}

#ifdef DEFAULT_SIGNATURES
{-# LANGUAGE DefaultSignatures #-}
#endif

#ifndef MIN_VERSION_base
#define MIN_VERSION_base(x,y,z) 1
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Lens.Each
-- Copyright   :  (C) 2012 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-----------------------------------------------------------------------------
module Control.Lens.Each
  ( Each(..)
  ) where

import Control.Applicative
import Control.Lens.Classes
import Control.Lens.Iso
import Control.Lens.Indexed as Lens
import Control.Lens.IndexedTraversal
import Control.Lens.Traversal
import Data.ByteString as StrictB
import Data.ByteString.Lazy as LazyB
import Data.Complex
import Data.Functor.Identity
import Data.Int
import Data.Sequence as Seq
import Data.Text as StrictT
import Data.Text.Lazy as LazyT
import Data.Traversable
import Data.Tree as Tree
import Data.Word
import Data.Map as Map
import Data.IntMap as IntMap
import Data.HashMap.Lazy as HashMap
import Data.Vector as Vector
import Data.Vector.Primitive as Prim
import Data.Vector.Storable as Storable
import Data.Vector.Unboxed as Unboxed
import Data.Array.Unboxed as Unboxed
import Data.Array.IArray as IArray

-- $setup
-- >>> import Control.Lens
-- >>> import Data.Text.Strict.Lens as Text
-- >>> import Data.Char as Char

-- | Extract 'each' element of a (potentially monomorphic) container.
--
-- Notably, when applied to a tuple, this generalizes 'Control.Lens.Traversal.both' to arbitrary homogeneous tuples.
--
-- >>> (1,2,3) & each *~ 10
-- (10,20,30)
--
-- It can also be used on monomorphic containers like 'StrictT.Text' or 'StrictB.ByteString'
--
-- >>> over each Char.toUpper ("hello"^.Text.packed)
-- "HELLO"
--
-- 'each' is an indexed traversal, so it can be used to access keys in many containers:
--
-- >>> itoListOf each $ Map.fromList [("hello",2),("world",4)]
-- [("hello",2),("world",4)]
--
-- >>> ("hello","world") & each.each %~ Char.toUpper
-- ("HELLO","WORLD")
class Functor f => Each i f s t a b | s -> i a, t -> i b, s b -> t, t a -> s where
  each :: Indexable i p => IndexedLensLike p f s t a b
#ifdef DEFAULT_SIGNATURES
  default each :: (Indexable Int p, Applicative f, Traversable g, s ~ g a, t ~ g b) => IndexedLensLike p f s t a b
  each = traversed
  {-# INLINE each #-}
#endif

-- | @'each' :: 'IndexedTraversal' 'Int' (a,a) (b,b) a b@
instance (Applicative f, a~a', b~b') => Each Int f (a,a') (b,b') a b where
  each f ~(a,b) = (,) <$> f' (0 :: Int) a <*> f' 1 b
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a) (b,b,b) a b@
instance (Applicative f, a~a2, a~a3, b~b2, b~b3) => Each Int f (a,a2,a3) (b,b2,b3) a b where
  each f ~(a,b,c) = (,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a,a) (b,b,b,b) a b@
instance (Applicative f, a~a2, a~a3, a~a4, b~b2, b~b3, b~b4) => Each Int f (a,a2,a3,a4) (b,b2,b3,b4) a b where
  each f ~(a,b,c,d) = (,,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c <*> f' 3 d
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a,a,a) (b,b,b,b,b) a b@
instance (Applicative f, a~a2, a~a3, a~a4, a~a5, b~b2, b~b3, b~b4, b~b5) => Each Int f (a,a2,a3,a4,a5) (b,b2,b3,b4,b5) a b where
  each f ~(a,b,c,d,e) = (,,,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c <*> f' 3 d <*> f' 4 e
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a,a,a,a) (b,b,b,b,b,b) a b@
instance (Applicative f, a~a2, a~a3, a~a4, a~a5, a~a6, b~b2, b~b3, b~b4, b~b5, b~b6) => Each Int f (a,a2,a3,a4,a5,a6) (b,b2,b3,b4,b5,b6) a b where
  each f ~(a,b,c,d,e,g) = (,,,,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c <*> f' 3 d <*> f' 4 e <*> f' 5 g
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a,a,a,a,a) (b,b,b,b,b,b,b) a b@
instance (Applicative f, a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, b~b2, b~b3, b~b4, b~b5, b~b6, b~b7) => Each Int f (a,a2,a3,a4,a5,a6,a7) (b,b2,b3,b4,b5,b6,b7) a b where
  each f ~(a,b,c,d,e,g,h) = (,,,,,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c <*> f' 3 d <*> f' 4 e <*> f' 5 g <*> f' 6 h
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a,a,a,a,a,a) (b,b,b,b,b,b,b,b) a b@
instance (Applicative f, a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, a~a8, b~b2, b~b3, b~b4, b~b5, b~b6, b~b7, b~b8) => Each Int f (a,a2,a3,a4,a5,a6,a7,a8) (b,b2,b3,b4,b5,b6,b7,b8) a b where
  each f ~(a,b,c,d,e,g,h,i) = (,,,,,,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c <*> f' 3 d <*> f' 4 e <*> f' 5 g <*> f' 6 h <*> f' 7 i
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a,a,a,a,a,a,a) (b,b,b,b,b,b,b,b,b) a b@
instance (Applicative f, a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, a~a8, a~a9, b~b2, b~b3, b~b4, b~b5, b~b6, b~b7, b~b8, b~b9) => Each Int f (a,a2,a3,a4,a5,a6,a7,a8,a9) (b,b2,b3,b4,b5,b6,b7,b8,b9) a b where
  each f ~(a,b,c,d,e,g,h,i,j) = (,,,,,,,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c <*> f' 3 d <*> f' 4 e <*> f' 5 g <*> f' 6 h <*> f' 7 i <*> f' 8 j
    where f' = Lens.indexed f
  {-# INLINE each #-}

#if MIN_VERSION_base(4,4,0)
-- | @'each' :: ('RealFloat' a, 'RealFloat' b) => 'IndexedTraversal' 'Int' ('Complex' a) ('Complex' b) a b@
instance (Applicative f, RealFloat a, RealFloat b) => Each Int f (Complex a) (Complex b) a b where
  each f (a :+ b) = (:+) <$> f' (0 :: Int) a <*> f' 1 b
    where f' = Lens.indexed f
  {-# INLINE each #-}
#else
-- | @'each' :: 'IndexedTraversal' 'Int' ('Complex' a) ('Complex' b) a b@
instance Applicative f => Each Int f (Complex a) (Complex b) a b where
  each f (a :+ b) = (:+) <$> f' (0 :: Int) a <*> f' (1 :: Int) b
    where f' = Lens.indexed f
  {-# INLINE each #-}
#endif

-- | @'each' :: 'IndexedTraversal' c ('Map' c a) ('Map' c b) a b@
instance Applicative f => Each c f (Map c a) (Map c b) a b where
  each f m = sequenceA $ Map.mapWithKey f' m
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' ('Map' c a) ('Map' c b) a b@
instance Applicative f => Each Int f (IntMap a) (IntMap b) a b where
  each f m = sequenceA $ IntMap.mapWithKey f' m
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' c ('HashMap' c a) ('HashMap' c b) a b@
instance Applicative f => Each c f (HashMap c a) (HashMap c b) a b where
  each = HashMap.traverseWithKey . Lens.indexed
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' [a] [b] a b@
instance Applicative f => Each Int f [a] [b] a b where
  each = traversed
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' ('Identity' a) ('Identity' b) a b@
instance Applicative f => Each Int f (Identity a) (Identity b) a b where
  each = traversed
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' ('Maybe' a) ('Maybe' b) a b@
instance Applicative f => Each Int f (Maybe a) (Maybe b) a b where
  each = traversed
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' ('Seq' a) ('Seq' b) a b@
instance Applicative f => Each Int f (Seq a) (Seq b) a b where
  each = traversed
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' ('Tree' a) ('Tree' b) a b@
instance Applicative f => Each Int f (Tree a) (Tree b) a b where
  each = traversed
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' ('Vector.Vector' a) ('Vector.Vector' b) a b@
instance Applicative f => Each Int f (Vector.Vector a) (Vector.Vector b) a b where
  each = traversed
  {-# INLINE each #-}

-- | @'each' :: ('Prim' a, 'Prim' b) => 'IndexedTraversal' 'Int' ('Prim.Vector' a) ('Prim.Vector' b) a b@
instance (Applicative f, Prim a, Prim b) => Each Int f (Prim.Vector a) (Prim.Vector b) a b where
  each f v = Prim.fromListN (Prim.length v) <$> withIndex traversed f' (Prim.toList v)
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: ('Storable' a, 'Storable' b) => 'IndexedTraversal' 'Int' ('Storable.Vector' a) ('Storable.Vector' b) a b@
instance (Applicative f, Storable a, Storable b) => Each Int f (Storable.Vector a) (Storable.Vector b) a b where
  each f v = Storable.fromListN (Storable.length v) <$> withIndex traversed f' (Storable.toList v)
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: ('Unbox' a, 'Unbox' b) => 'IndexedTraversal' 'Int' ('Unboxed.Vector' a) ('Unboxed.Vector' b) a b@
instance (Applicative f, Unbox a, Unbox b) => Each Int f (Unboxed.Vector a) (Unboxed.Vector b) a b where
  each f v = Unboxed.fromListN (Unboxed.length v) <$> withIndex traversed f' (Unboxed.toList v)
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' 'StrictT.Text' 'StrictT.Text' 'Char' 'Char'@
instance Applicative f =>  Each Int f StrictT.Text StrictT.Text Char Char where
  each = iso StrictT.unpack StrictT.pack . traversed
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int64' 'LazyT.Text' 'LazyT.Text' 'Char' 'Char'@
instance Applicative f => Each Int64 f LazyT.Text LazyT.Text Char Char where
  each = iso LazyT.unpack LazyT.pack . traversed64
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' 'StrictB.ByteString' 'StrictB.ByteString' 'Char' 'Char'@
instance Applicative f => Each Int f StrictB.ByteString StrictB.ByteString Word8 Word8 where
  each = iso StrictB.unpack StrictB.pack . traversed
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int64' 'LazyB.ByteString' 'LazyB.ByteString' 'Char' 'Char'@
instance Applicative f => Each Int64 f LazyB.ByteString LazyB.ByteString Word8 Word8 where
  each = iso LazyB.unpack LazyB.pack . traversed64
  {-# INLINE each #-}

-- | @'each' :: 'Ix' i => 'IndexedTraversal' i ('Array' i a) ('Array' i b) a b@
instance (Applicative f, Ix i) => Each i f (Array i a) (Array i b) a b where
  each f arr = array (bounds arr) <$> traverse (\(i,a) -> (,) i <$> Lens.indexed f i a) (IArray.assocs arr)
  {-# INLINE each #-}

-- | @'each' :: ('Ix' i, 'IArray' 'UArray' a, 'IArray' 'UArray' b) => 'IndexedTraversal' i ('Array' i a) ('Array' i b) a b@
instance (Applicative f, Ix i, IArray UArray a, IArray UArray b) => Each i f (UArray i a) (UArray i b) a b where
  each f arr = array (bounds arr) <$> traverse (\(i,a) -> (,) i <$> Lens.indexed f i a) (IArray.assocs arr)
  {-# INLINE each #-}

-- | @'each' :: 'Control.Lens.IndexedSetter.IndexedSetter' i (i -> a) (i -> b) a b@
instance Settable f => Each i f (i -> a) (i -> b) a b where
  each f g = pure (\i -> untaintedDot (Lens.indexed f i) (g i))
  {-# INLINE each #-}

max_stars_repo_name: np/lens

max_issues_repo_name: np/lens

max_forks_repo_name: np/lens


text:
{-# LANGUAGE TemplateHaskell #-}
module Turtle3 (main) where
import Prelude hiding (dropWhile)
import Control.Applicative
import Control.Arrow
import System.IO (hFlush, stdout)
import Data.Complex
import Ros.Logging
import Ros.Node
import Ros.Topic (repeatM, force, dropWhile, metamorphM, yieldM)
import Ros.Topic.Util (everyNew, interruptible, forkTopic, topicOn, subsample)
import Ros.Util.PID (pidTimedIO)
import AngleNum
import Ros.Turtlesim.Pose
import Ros.Geometry_msgs.Twist
import qualified Ros.Geometry_msgs.Vector3 as V
import Data.Default.Generics (def)
import Lens.Family ((.~), (^.), (&))

-- A type synonym for a 2D point.
type Point = Complex Float

-- A Topic of user-supplied waypoint trajectories.
getTraj :: Topic IO [Point]
getTraj = repeatM (do putStr "Enter waypoints: " >> hFlush stdout
                      $(logInfo "Waiting for new traj")
                      map (uncurry (:+)) . read <$> getLine)

-- Create Twist message with linear and angular velocity in arguments.
mkTwist :: Real a => a -> a -> Twist
mkTwist l a = def & linear  . V.x .~ realToFrac l
                  & angular . V.z .~ realToFrac a

-- Produce a new goal 'Point' every time a 'Pose' topic reaches the
-- vicinity of the previous goal.
destinations :: (Functor m, Monad m) =>
                Topic m Point -> Topic m Pose -> Topic m Point
destinations goals poses = metamorphM (start (p2v <$> poses)) goals
  where start t g = yieldM g (go g t)
        go g t g' = let keepGoing x = magnitude (g - x) > 0.5
                    in force (dropWhile keepGoing t) >>= yieldM g' . go g'
        p2v (Pose x y _ _ _) = x :+ y

-- Compute linear and angular error to goal.
toGoal :: (Pose,Point) -> (Float, Float)
toGoal (pos,goal) = (magnitude v, thetaErr)
  where v = goal - (pos ^. x :+ pos ^. y)
        thetaErr = toDegrees $ angle (phase v) - angle (pos ^. theta)

-- Run a PID loop on angular velocity to converge to a bearing for the
-- goal.
steering :: Topic IO (Float,Float) -> Topic IO Twist
steering = topicOn snd (mkTwist . fst) (($ 0) <$> pidTimedIO 0.01 0.5 0)

-- Compute position and bearing error to goal, clamp linear and
-- angular velocities, and generate a steering command.
navigate :: Topic IO (Pose,Point) -> Topic IO Twist
navigate = steering . fmap ((clamp *** id) . toGoal)
  where clamp x = signum x * min 2 (abs x)

main = runNode "HaskellBTurtle" $
       do enableLogging (Just Warn)
          poses <- subscribe "/turtle1/pose"
          let goals = destinations (interruptible getTraj) poses
              commands = subsample 15 $ navigate $ everyNew poses goals
          advertise "/turtle1/cmd_vel" commands

max_stars_repo_name: hpacheco/roshask

max_issues_repo_name: hpacheco/roshask

max_forks_repo_name: hpacheco/roshask


text:
{-# language FlexibleInstances #-}
{-|
Module      : MachineLearning.Model.Fitness
Description : TIR expression data structures
Copyright   : (c) Fabricio Olivetti de Franca, 2022
License     : GPL-3
Maintainer  : fabricio.olivetti@gmail.com
Stability   : experimental
Portability : POSIX

This module exports the functions that calculates the coefficients,
evaluate the fitness, penalty and constraints of a TIR expression.
-}
module MachineLearning.Model.Fitness
  ( evalTrain
  , evalTest
  , selectValidTerms
  ) where

import Data.Bifunctor
import Data.Maybe            (fromJust)
import Data.Vector.Storable  (Vector)
import Data.Vector           ((!))
import Numeric.LinearAlgebra ((<\>))
import Numeric.ModalInterval      (Kaucher, inf, sup, width, singleton)
import qualified Numeric.ModalInterval as Interval
import Control.Monad.Reader
import qualified Data.Vector.Storable  as VS
import qualified Data.Vector           as V
import qualified Numeric.LinearAlgebra as LA
import Data.Maybe (fromMaybe)
import MachineLearning.Model.Measure       (Measure)
import MachineLearning.Model.Regression    (nonlinearFit, evalPenalty, fitTask, predictTask, applyMeasures)
import MachineLearning.TIR       (TIR(..),  Individual(..), Dataset, Constraint, assembleTree, replaceConsts)
import MachineLearning.Utils.Config       (Task(..), Penalty)
import Data.SRTree                (SRTree(..), Function, OptIntPow(..), evalTree, evalTreeMap, evalFun, inverseFunc, countNodes)

import Data.SRTree.Print

-- | removes invalid terms from the TIR expression. Invalid terms
-- are those that evaluate to `NaN` or `Infinite` within the
-- domains of each variable. The domains are either provided by
-- the configuration file or estimated using the training data.
selectValidTerms :: TIR -> V.Vector (Kaucher Double) -> TIR
selectValidTerms tir@(TIR _ p q) domains = tir{ _p=p', _q=q' }
  where
    p' = selectValid p
    q' = selectValid q

    selectValid = filter (\(_, g, ps) -> isValidInterval $ evalFun g (evalPi ps))
    evalPi      = foldr (\(ix, k) acc -> acc * (domains ! ix ^. k)) 1
{-# INLINE selectValidTerms #-}

isValidInterval = not. isInvalidInterval
{-# INLINE isValidInterval #-}

isInvalidInterval :: Kaucher Double -> Bool
isInvalidInterval ys =  Interval.isEmpty ys
                     || Interval.isInvalid ys
                     || isInfinite ys1 || isInfinite ys2
                     || ys2 < ys1
                     || abs ys1 >= 1e50 || abs ys2 >= 1e50
                     || isNaN ys1 || isNaN ys2
                     || width ys < 1e-8
  where
    ys1 = fromMaybe (-1/0) $ inf ys
    ys2 = fromMaybe (1/0) $ sup ys
{-# INLINE isInvalidInterval #-}

-- | evaluates an individual first fitting the expression
-- with either OLS or a nonlinear optimization (not yet implemented)
-- and calculating the fitness vector, constraints, penalty.
evalTrain :: Task                          -- ^ Regression or Classification task
          -> Bool                          -- ^ if we are fitting the final best individual, in this case do not split the training data for validation
          -> [Measure]                     -- ^ list of performance measures to calculate
          -> Constraint                    -- ^ constraint function
          -> Penalty                       -- ^ penalty
          -> V.Vector (Kaucher Double)     -- ^ variable domains represented as a Kaucher Interval
          -> Dataset Double                -- ^ training data
          -> Vector Double                 -- ^ training target
          -> Dataset Double                -- ^ validation data
          -> Vector Double                 -- ^ validation target
          -> Individual
          -> Individual
evalTrain task isRefit measures cnstrFun penalty domains xss_train ys_train xss_val ys_val sol
--  | LA.cols zss == 0                   = error "found"
--  | (not.null) (LA.find (\x -> isNaN x || isInfinite x) zss)  = error $ (show $ _chromo sol) <> show domains
  | not isRefit && (not.null._fit) sol = sol
--  | LA.cols zssP == 0                  = sol { _fit = [1/0] }
  | otherwise                          = sol{ _chromo  = fitted
                                            , _fit     = fitness
                                            , _weights = ws
                                            , _constr  = cnst
                                            , _len     = len
                                            , _penalty = pnlty
                                            }
  where
    -- Fit the rational IT
    tir          = selectValidTerms (_chromo sol) domains
    ws           = fitTask task tir xss_train ys_train

    -- Validate (it should be applied to every different weights set)
    fitted         = replaceConsts tir . V.tail . VS.convert . head
                   $ ws
    fitness        = map nan2inf . fromJust . evalTest task measures xss_val ys_val
                   $ sol{ _chromo=fitted, _weights=ws }
    -- Length and constraint
    tree           = assembleTree (V.head $ VS.convert $ head ws) fitted
    len            = countNodes tree
    cnst           = cnstrFun tree
    pnlty          = evalPenalty penalty len cnst

-- | Evaluates an expression into the test set. This is different from `fitnessReg` since
-- it doesn't apply OLS.
evalTest :: Task -> [Measure] -> Dataset Double -> Vector Double -> Individual -> Maybe [Double]
evalTest task measures xss ys sol
  | null weights = Nothing
  | otherwise    = Just
                 $ applyMeasures measures ys
                 $ predictTask task
                 $ map (evalTIR xss' bias . replaceConsts tir . V.tail . VS.convert) weights
  where
    tir          = _chromo sol
    weights      = _weights sol
    bias         = V.head $ VS.convert $ head weights -- only works for regression
    -- nSamples     = VS.length $ V.head xss
    xss'         = V.tail xss
    -- treeEval t   = fromJust $ runReader (evalTreeMap (VS.replicate nSamples) t) (xss' V.!?)

evalTIR :: Dataset Double -> Double -> TIR -> LA.Vector Double
evalTIR xss bias (TIR g p q) = evalFun g ((LA.scalar bias + p') / (1 + q'))
  where
    p'     = foldr (\(w, h, ks) acc -> LA.scalar w * evalFun h (evalPi ks) + acc) 0 p
    q'     = foldr (\(w, h, ks) acc -> LA.scalar w * evalFun h (evalPi ks) + acc) 0 q
    evalPi = foldr (\(ix,k) acc -> acc * (xss ! ix)^^k) 1
{-# INLINE evalTIR #-}

--instance OptIntPow (LA.Vector Double) where
--  (^.) = (^^)

nan2inf :: RealFloat a => a -> a
nan2inf x | isNaN x = 1/0
          |otherwise = x
{-# INLINE nan2inf #-}

max_stars_repo_name: folivetti/tir

max_issues_repo_name: folivetti/tir

max_forks_repo_name: folivetti/tir


text:
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE ScopedTypeVariables #-}

module TensorSpec (spec) where

import Control.Arrow ((&&&))
import Control.Exception.Safe
import Numeric.Half
import Data.Complex
import Data.Int
import Data.Word
import Test.Hspec
import Test.QuickCheck
import Torch.DType
import Torch.Functional
import Torch.Tensor
import Torch.TensorFactories
import Torch.TensorOptions
import Test.QuickCheck.Arbitrary

instance Arbitrary Half where
  arbitrary = arbitrarySizedFractional
  shrink    = shrinkDecimal

spec :: Spec
spec = do
  describe "TensorLike" $ do
    it "TensorLike Bool" $
      property $
        \x -> asValue (asTensor x) `shouldBe` (x :: Bool)
    it "TensorLike Word8" $
      property $
        \x -> asValue (asTensor x) `shouldBe` (x :: Word8)
    it "TensorLike Int8" $
      property $
        \x -> asValue (asTensor x) `shouldBe` (x :: Int8)
    it "TensorLike Int16" $
      property $
        \x -> asValue (asTensor x) `shouldBe` (x :: Int16)
    it "TensorLike Int32" $
      property $
        \x -> asValue (asTensor x) `shouldBe` (x :: Int32)
    it "TensorLike Int" $
      property $
        \x -> asValue (asTensor x) `shouldBe` (x :: Int)
    it "TensorLike Int64" $
      property $
        \x -> asValue (asTensor x) `shouldBe` (x :: Int64)
    it "TensorLike Half" $
      property $
        \x -> asValue (asTensor x) `shouldBe` (x :: Half)
    it "TensorLike Float" $
      property $
        \x -> asValue (asTensor x) `shouldBe` (x :: Float)
    it "TensorLike Double" $
      property $
        \x -> asValue (asTensor x) `shouldBe` (x :: Double)
    it "TensorLike ComplexHalf" $
      property $
        \x -> asValue (asTensor x) `shouldBe` (x :: Complex Half)
    it "TensorLike Complex Float" $
      property $
        \x -> asValue (asTensor x) `shouldBe` (x :: Complex Float)
    it "TensorLike Complex Double" $
      property $
        \x -> asValue (asTensor x) `shouldBe` (x :: Complex Double)

    it "Compare internal expression of c++ with Storable expression of haskell" $ do
      show (asTensor [True, False, True, False])
        `shouldBe` "Tensor Bool [4] [ 1,  0,  1,  0]"
      show (asTensor ([1, 0, 1, 0] :: [Word8]))
        `shouldBe` "Tensor UInt8 [4] [ 1,  0,  1,  0]"
      show (asTensor ([1, 0, 1, 0] :: [Int8]))
        `shouldBe` "Tensor Int8 [4] [ 1,  0,  1,  0]"
      show (asTensor ([1, 0, 1, 0] :: [Int16]))
        `shouldBe` "Tensor Int16 [4] [ 1,  0,  1,  0]"
      show (asTensor ([1, 0, 1, 0] :: [Int32]))
        `shouldBe` "Tensor Int32 [4] [ 1,  0,  1,  0]"
      show (asTensor ([1, 0, 1, 0] :: [Int]))
        `shouldBe` "Tensor Int64 [4] [ 1,  0,  1,  0]"
      show (asTensor ([1, 0, 1, 0] :: [Int64]))
        `shouldBe` "Tensor Int64 [4] [ 1,  0,  1,  0]"
      show (asTensor ([1, 0, 1, 0] :: [Float]))
        `shouldBe` "Tensor Float [4] [ 1.0000   ,  0.0000,  1.0000   ,  0.0000]"
      show (asTensor ([1, 0, 1, 0] :: [Double]))
        `shouldBe` "Tensor Double [4] [ 1.0000   ,  0.0000,  1.0000   ,  0.0000]"
      show (asTensor ([[]] :: [[Int]]))
        `shouldBe` "Tensor Int64 [1,0] [[]]"
      show (asTensor ([[1]] :: [[Int]]))
        `shouldBe` "Tensor Int64 [1,1] [[ 1]]"

    it "TensorLike [Bool]" $
      property $
        \(NonEmpty (x :: [Bool])) -> do
          asValue (asTensor x) `shouldBe` x
          toDouble (select 0 0 (asTensor x)) `shouldBe` (if (head x) then 1 else 0)
          shape (asTensor x) `shouldBe` [length x]
          let xx = replicate 5 x
          asValue (asTensor xx) `shouldBe` xx
          let xxx = replicate 3 xx
          asValue (asTensor xxx) `shouldBe` xxx
    it "TensorLike [Word8]" $
      property $
        \(NonEmpty (x :: [Word8])) -> do
          asValue (asTensor x) `shouldBe` x
          toDouble (select 0 0 (asTensor x)) `shouldBe` fromIntegral (head x)
          shape (asTensor x) `shouldBe` [length x]
          let xx = replicate 5 x
          asValue (asTensor xx) `shouldBe` xx
          let xxx = replicate 3 xx
          asValue (asTensor xxx) `shouldBe` xxx
    it "TensorLike [Int8]" $
      property $
        \(NonEmpty (x :: [Int8])) -> do
          asValue (asTensor x) `shouldBe` x
          toDouble (select 0 0 (asTensor x)) `shouldBe` fromIntegral (head x)
          shape (asTensor x) `shouldBe` [length x]
          let xx = replicate 5 x
          asValue (asTensor xx) `shouldBe` xx
          let xxx = replicate 3 xx
          asValue (asTensor xxx) `shouldBe` xxx
    it "TensorLike [Int16]" $
      property $
        \(NonEmpty (x :: [Int16])) -> do
          asValue (asTensor x) `shouldBe` x
          toDouble (select 0 0 (asTensor x)) `shouldBe` fromIntegral (head x)
          shape (asTensor x) `shouldBe` [length x]
          let xx = replicate 5 x
          asValue (asTensor xx) `shouldBe` xx
          let xxx = replicate 3 xx
          asValue (asTensor xxx) `shouldBe` xxx
    it "TensorLike [Int32]" $
      property $
        \(NonEmpty (x :: [Int32])) -> do
          asValue (asTensor x) `shouldBe` x
          toDouble (select 0 0 (asTensor x)) `shouldBe` fromIntegral (head x)
          shape (asTensor x) `shouldBe` [length x]
          let xx = replicate 5 x
          asValue (asTensor xx) `shouldBe` xx
          let xxx = replicate 3 xx
          asValue (asTensor xxx) `shouldBe` xxx
    it "TensorLike [Int]" $
      property $
        \(NonEmpty (x :: [Int])) -> do
          asValue (asTensor x) `shouldBe` x
          toDouble (select 0 0 (asTensor x)) `shouldBe` fromIntegral (head x)
          shape (asTensor x) `shouldBe` [length x]
          let xx = replicate 5 x
          asValue (asTensor xx) `shouldBe` xx
          let xxx = replicate 3 xx
          asValue (asTensor xxx) `shouldBe` xxx
    it "TensorLike [Int64]" $
      property $
        \(NonEmpty (x :: [Int64])) -> do
          asValue (asTensor x) `shouldBe` x
          toDouble (select 0 0 (asTensor x)) `shouldBe` fromIntegral (head x)
          shape (asTensor x) `shouldBe` [length x]
          let xx = replicate 5 x
          asValue (asTensor xx) `shouldBe` xx
          let xxx = replicate 3 xx
          asValue (asTensor xxx) `shouldBe` xxx
    it "TensorLike [Half]" $
      property $
        \(NonEmpty (x :: [Half])) -> do
          asValue (asTensor x) `shouldBe` x
          toDouble (select 0 0 (asTensor x)) `shouldBe` realToFrac (head x)
          shape (asTensor x) `shouldBe` [length x]
          let xx = replicate 5 x
          asValue (asTensor xx) `shouldBe` xx
          let xxx = replicate 3 xx
          asValue (asTensor xxx) `shouldBe` xxx
    it "TensorLike [Float]" $
      property $
        \(NonEmpty (x :: [Float])) -> do
          asValue (asTensor x) `shouldBe` x
          toDouble (select 0 0 (asTensor x)) `shouldBe` realToFrac (head x)
          shape (asTensor x) `shouldBe` [length x]
          let xx = replicate 5 x
          asValue (asTensor xx) `shouldBe` xx
          let xxx = replicate 3 xx
          asValue (asTensor xxx) `shouldBe` xxx
    it "TensorLike [Double]" $
      property $
        \(NonEmpty (x :: [Double])) -> do
          asValue (asTensor x) `shouldBe` x
          toDouble (select 0 0 (asTensor x)) `shouldBe` realToFrac (head x)
          shape (asTensor x) `shouldBe` [length x]
          let xx = replicate 5 x
          asValue (asTensor xx) `shouldBe` xx
          let xxx = replicate 3 xx
          asValue (asTensor xxx) `shouldBe` xxx
    it "TensorLike [Complex Half]" $
      property $
        \(NonEmpty (x :: [Complex Half])) -> do
          asValue (asTensor x) `shouldBe` x
          asValue (select 0 0 (asTensor x)) `shouldBe` (head x)
          shape (asTensor x) `shouldBe` [length x]
          let xx = replicate 5 x
          asValue (asTensor xx) `shouldBe` xx
          let xxx = replicate 3 xx
          asValue (asTensor xxx) `shouldBe` xxx
    it "TensorLike [Complex Float]" $
      property $
        \(NonEmpty (x :: [Complex Float])) -> do
          asValue (asTensor x) `shouldBe` x
          asValue (select 0 0 (asTensor x)) `shouldBe` (head x)
          shape (asTensor x) `shouldBe` [length x]
          let xx = replicate 5 x
          asValue (asTensor xx) `shouldBe` xx
          let xxx = replicate 3 xx
          asValue (asTensor xxx) `shouldBe` xxx
    it "TensorLike [Complex Double]" $
      property $
        \(NonEmpty (x :: [Complex Double])) -> do
          asValue (asTensor x) `shouldBe` x
          asValue (select 0 0 (asTensor x)) `shouldBe` (head x)
          shape (asTensor x) `shouldBe` [length x]
          let xx = replicate 5 x
          asValue (asTensor xx) `shouldBe` xx
          let xxx = replicate 3 xx
          asValue (asTensor xxx) `shouldBe` xxx

    it "invalid cast of TensorLike a" $ do
      let x = asTensor (10 :: Int)
      (dtype x) `shouldBe` Int64
      (print (asValue x :: Double)) `shouldThrow` anyException
    it "invalid cast of TensorLike [a]" $ do
      let x = asTensor ([0 .. 10] :: [Int])
      (print (asValue x :: [Double])) `shouldThrow` anyException

    it "lists having different length" $ do
      (print (asTensor ([[1], [1, 2]] :: [[Double]]))) `shouldThrow` anyException
    it "cast of Tensor" $ do
      let x = asTensor ([0 .. 10] :: [Int])
      (dtype (toType Float x)) `shouldBe` Float

  describe "indexing" $ do
    it "pick up a value" $ do
      let x = asTensor ([[[0, 1, 2], [3, 4, 5]], [[6, 7, 8], [9, 10, 11]]] :: [[[Int]]])
          r = x ! (1, 0, 2)
      (dtype &&& shape &&& asValue) r `shouldBe` (Int64, ([], 8 :: Int))
    it "pick up a bottom tensor" $ do
      let x = asTensor ([[[0, 1, 2], [3, 4, 5]], [[6, 7, 8], [9, 10, 11]]] :: [[[Int]]])
          r = x ! (1, 0)
      (dtype &&& shape &&& asValue) r `shouldBe` (Int64, ([3], [6 :: Int, 7, 8]))
    it "make a slice of bottom values" $ do
      let x = asTensor ([[[0, 1, 2], [3, 4, 5]], [[6, 7, 8], [9, 10, 11]]] :: [[[Int]]])
          r = x ! ((), (), 1)
      (dtype &&& shape &&& asValue) r `shouldBe` (Int64, ([2, 2], [[1 :: Int, 4], [7, 10]]))
    it "ellipsis" $ do
      let x = asTensor ([[[0, 1, 2], [3, 4, 5]], [[6, 7, 8], [9, 10, 11]]] :: [[[Int]]])
          r = x ! (Ellipsis, 1)
      (dtype &&& shape &&& asValue) r `shouldBe` (Int64, ([2, 2], [[1 :: Int, 4], [7, 10]]))
    it "make a slice via muliple slices" $ do
      let x = asTensor ([[[0, 1, 2], [3, 4, 5]], [[6, 7, 8], [9, 10, 11]]] :: [[[Int]]])
          r = x ! ((), (Slice (1, None)))
      (dtype &&& shape &&& asValue) r `shouldBe` (Int64, ([2, 1, 3], [[[3 :: Int, 4, 5]], [[9, 10, 11]]]))
    it "make a slice via muliple slices" $ do
      let x = asTensor ([[[0, 1, 2], [3, 4, 5]], [[6, 7, 8], [9, 10, 11]]] :: [[[Int]]])
          r = x ! ((), (Slice (1, None)), (Slice (0, 1)))
      (dtype &&& shape &&& asValue) r `shouldBe` (Int64, ([2, 1, 1], [[[3 :: Int]], [[9]]]))
  describe "masked fill" $ do
    it "Fill a value" $ do
      let x = asTensor ([[[0, 1, 2], [3, 4, 5]], [[6, 7, 8], [9, 10, 11]]] :: [[[Int]]])
          r = maskedFill x (1, 0, 2) (9 :: Int)
      (dtype &&& shape &&& asValue) r `shouldBe` (Int64, ([2, 2, 3], [[[0, 1, 2], [3, 4, 5]], [[6, 7, 9], [9, 10, 11]]] :: [[[Int]]]))
    it "Fill a bottom tensor" $ do
      let x = asTensor ([[[0, 1, 2], [3, 4, 5]], [[6, 7, 8], [9, 10, 11]]] :: [[[Int]]])
          r = maskedFill x (1, 0) [8 :: Int, 8, 8]
      (dtype &&& shape &&& asValue) r `shouldBe` (Int64, ([2, 2, 3], [[[0, 1, 2], [3, 4, 5]], [[8, 8, 8], [9, 10, 11]]] :: [[[Int]]]))
    it "masked fill by boolean" $ do
      let m = asTensor ([[[True, True, False], [False, False, False]], [[True, False, False], [False, False, False]]] :: [[[Bool]]])
          x = asTensor ([[[0, 1, 2], [3, 4, 5]], [[6, 7, 8], [9, 10, 11]]] :: [[[Int]]])
          r = maskedFill x m [8 :: Int, 8, 8]
      (dtype &&& shape &&& asValue) r `shouldBe` (Int64, ([2, 2, 3], [[[8, 8, 2], [3, 4, 5]], [[8, 7, 8], [9, 10, 11]]] :: [[[Int]]]))

max_stars_repo_name: acald-creator/hasktorch

max_issues_repo_name: acald-creator/hasktorch

max_forks_repo_name: acald-creator/hasktorch