text:
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Parallel.Strategies
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Parallel strategy combinators
--
-----------------------------------------------------------------------------
module Control.Parallel.Strategies where

-- based on hslibs/concurrent/Strategies.lhs; see it for more detailed
-- code comments. Original authors:
--
--	Phil Trinder, Hans-Wolfgang Loidl, Kevin Hammond et al.
--

#ifdef __HADDOCK__
import Prelude
#endif

import Control.Parallel as Parallel
import Data.Ix
import Data.Array
import Data.Complex
import Data.Ratio

-- not a terribly portable way of getting at Ratio rep.
#ifdef __GLASGOW_HASKELL__
import GHC.Real	(Ratio(..))	-- The basic defns for Ratio
#endif

#ifdef __HUGS__
import Hugs.Prelude(Ratio(..) )
#endif

#ifdef __NHC__
import Ratio (Ratio(..) )
#endif

infixl 0 `using`,`demanding`,`sparking`              -- weakest precedence!

infixr 2 >||                -- another name for par
infixr 3 >|                 -- another name for seq
infixl 6 $||, $|            -- strategic function application (seq and par)
infixl 9 .|, .||, -|, -||   -- strategic (inverse) function composition

------------------------------------------------------------------------------
--			Strategy Type, Application and Semantics
------------------------------------------------------------------------------
type Done = ()
type Strategy a = a -> Done

{-
A strategy takes a value and returns a dummy `done' value to indicate that
the specifed evaluation has been performed.

The basic combinators for strategies are @par@ and @seq@ but with types that
indicate that they only combine the results of a strategy application.

NB: This version can be used with Haskell 1.4 (GHC 2.05 and beyond), *but*
    you won't get strategy checking on seq (only on par)!

The infix fcts >| and >|| are alternative names for `seq` and `par`.
With the introduction of a Prelude function `seq` separating the Prelude
function from the Strategy function becomes a pain. The notation also matches
the notation for strategic function application.
-}

{-
par and seq have the same types as before; >| and >|| are more specific
and can only be used when composing strategies.
-}

(>|), (>||) :: Done -> Done -> Done
{-# INLINE (>|) #-}
{-# INLINE (>||) #-}
(>|) = Prelude.seq
(>||) = Parallel.par

using :: a -> Strategy a -> a
using x s = s x `seq` x

{-
using takes a strategy and a value, and applies the strategy to the
value before returning the value. Used to express data-oriented parallelism

x `using` s is a projection on x, i.e. both

  a retraction: x `using` s [ x
			    -
  and idempotent: (x `using` s) `using` s = x `using` s

demanding and sparking are used to express control-oriented
parallelism. Their second argument is usually a sequence of strategy
applications combined `par` and `seq`. Sparking should only be used
with a singleton sequence as it is not necessarily excuted
-}

demanding, sparking :: a -> Done -> a
demanding = flip Parallel.seq
sparking  = flip Parallel.par

{-
sPar and sSeq have been superceded by sparking and demanding: replace
  e `using` sPar x	with  	e `sparking`  x
  e `using` sSeq x	with 	e `demanding` x

sPar is a strategy corresponding to par. i.e. x `par` e <=> e `using` sPar x
-}

sPar :: a -> Strategy b
sPar x y = x `par` ()

{-
sSeq is a strategy corresponding to seq. i.e. x `seq` e <=> e `using` sSeq x
-}
sSeq :: a -> Strategy b
sSeq x y = x `seq` ()

-----------------------------------------------------------------------------
--			Basic Strategies
-----------------------------------------------------------------------------

-- r0 performs *no* evaluation on its argument.
r0 :: Strategy a
r0 x = ()

--rwhnf reduces its argument to weak head normal form.
rwhnf :: Strategy a
rwhnf x = x `seq` ()

class NFData a where
  -- rnf reduces its argument to (head) normal form
  rnf :: Strategy a
  -- Default method. Useful for base types. A specific method is necessay for
  -- constructed types
  rnf = rwhnf

class (NFData a, Integral a) => NFDataIntegral a
class (NFData a, Ord a) => NFDataOrd a

------------------------------------------------------------------------------
--                      Strategic Function Application
------------------------------------------------------------------------------

{-
The two  infix functions @$|@   and @$||@  perform sequential and  parallel
function application, respectively. They  are parameterised with a strategy
that is applied to the argument of the  function application.  This is very
handy when  writing  pipeline parallelism  as  a sequence of  @$@, @$|@ and
@$||@'s. There is no  need of naming intermediate values  in this case. The
separation  of algorithm from strategy  is  achieved by allowing strategies
only as second arguments to @$|@ and @$||@.
-}

($|), ($||) :: (a -> b) -> Strategy a -> a -> b

f $| s  = \ x -> f x `demanding` s x
f $|| s = \ x -> f x `sparking`  s x

{-
The same thing for function composition (.| and .||) and inverse function
composition (-| and -||) for those who read their programs from left to
right.
-}

(.|), (.||) :: (b -> c) -> Strategy b -> (a -> b) -> (a -> c)
(-|), (-||) :: (a -> b) -> Strategy b -> (b -> c) -> (a -> c)

(.|) f s g = \ x -> let  gx = g x
                    in   f gx `demanding` s gx
(.||) f s g = \ x -> let  gx = g x
                     in   f gx `sparking` s gx

(-|) f s g = \ x -> let  fx = f x
                    in   g fx `demanding` s fx
(-||) f s g = \ x -> let  fx = f x
                     in   g fx `sparking` s fx

------------------------------------------------------------------------------
--			Marking a Strategy
------------------------------------------------------------------------------

{-
Marking a strategy.

Actually, @markStrat@  sticks a label @n@  into the sparkname  field of the
thread executing strategy @s@. Together with a runtime-system that supports
propagation of sparknames to the children this means that this strategy and
all its children have  the sparkname @n@ (if the  static sparkname field in
the @parGlobal@ annotation contains the value 1). Note, that the @SN@ field
of starting the marked strategy itself contains the sparkname of the parent
thread. The END event contains @n@ as sparkname.
-}

#if 0
markStrat :: Int -> Strategy a -> Strategy a
markStrat n s x = unsafePerformPrimIO (
     _casm_ ``%r = set_sparkname(CurrentTSO, %0);'' n `thenPrimIO` \ z ->
     returnPrimIO (s x))
#endif

-----------------------------------------------------------------------------
--			Strategy Instances and Functions
-----------------------------------------------------------------------------

-----------------------------------------------------------------------------
--	                Tuples
-----------------------------------------------------------------------------

{-
We currently support up to 9-tuples. If you need longer tuples you have to
add the instance explicitly to your program.
-}

instance (NFData a, NFData b) => NFData (a,b) where
  rnf (x,y) = rnf x `seq` rnf y

instance (NFData a, NFData b, NFData c) => NFData (a,b,c) where
  rnf (x,y,z) = rnf x `seq` rnf y `seq` rnf z

instance (NFData a, NFData b, NFData c, NFData d) => NFData (a,b,c,d) where
  rnf (x1,x2,x3,x4) = rnf x1 `seq`
		        rnf x2 `seq`
		        rnf x3 `seq`
		        rnf x4

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5) =>
         NFData (a1, a2, a3, a4, a5) where
  rnf (x1, x2, x3, x4, x5) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6) =>
         NFData (a1, a2, a3, a4, a5, a6) where
  rnf (x1, x2, x3, x4, x5, x6) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7) =>
         NFData (a1, a2, a3, a4, a5, a6, a7) where
  rnf (x1, x2, x3, x4, x5, x6, x7) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8) =>
         NFData (a1, a2, a3, a4, a5, a6, a7, a8) where
  rnf (x1, x2, x3, x4, x5, x6, x7, x8) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7 `seq`
                  rnf x8

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8, NFData a9) =>
         NFData (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
  rnf (x1, x2, x3, x4, x5, x6, x7, x8, x9) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7 `seq`
                  rnf x8 `seq`
                  rnf x9

seqPair :: Strategy a -> Strategy b -> Strategy (a,b)
seqPair strata stratb (x,y) = strata x `seq` stratb y

parPair :: Strategy a -> Strategy b -> Strategy (a,b)
parPair strata stratb (x,y) = strata x `par` stratb y `par` ()

{-
The reason for the  second `par` is so that the strategy terminates
quickly. This is important if the strategy is used as the 1st argument of a seq
-}

seqTriple :: Strategy a -> Strategy b -> Strategy c -> Strategy (a,b,c)
seqTriple strata stratb stratc p@(x,y,z) =
  strata x `seq`
  stratb y `seq`
  stratc z

parTriple :: Strategy a -> Strategy b -> Strategy c -> Strategy (a,b,c)
parTriple strata stratb stratc (x,y,z) =
  strata x `par`
  stratb y `par`
  stratc z `par`
  ()

{-
Weak head normal form and normal form are identical for integers, so the
default rnf is sufficient.
-}
instance NFData Int
instance NFData Integer
instance NFData Float
instance NFData Double

instance NFDataIntegral Int
instance NFDataOrd Int

--Rational and complex numbers.

instance (Integral a, NFData a) => NFData (Ratio a) where
  rnf (x:%y) = rnf x `seq`
               rnf y `seq`
               ()

instance (RealFloat a, NFData a) => NFData (Complex a) where
  rnf (x:+y) = rnf x `seq`
	         rnf y `seq`
               ()

instance NFData Char
instance NFData Bool
instance NFData ()

-----------------------------------------------------------------------------
--			Lists
----------------------------------------------------------------------------

instance NFData a => NFData [a] where
  rnf [] = ()
  rnf (x:xs) = rnf x `seq` rnf xs

----------------------------------------------------------------------------
--                        Lists: Parallel Strategies
----------------------------------------------------------------------------

-- | Applies a strategy to every element of a list in parallel
parList :: Strategy a -> Strategy [a]
parList strat []     = ()
parList strat (x:xs) = strat x `par` (parList strat xs)

-- | Applies a strategy to the first  n elements of a list  in parallel
parListN :: (Integral b) => b -> Strategy a -> Strategy [a]
parListN n strat []     = ()
parListN 0 strat xs     = ()
parListN n strat (x:xs) = strat x `par` (parListN (n-1) strat xs)

-- | Evaluates N elements of the spine of the argument list and applies
-- the given strategy to the Nth element (if there is one) in parallel with
-- the result. e.g. parListNth 2 [e1, e2, e3] evaluates e2
parListNth :: Int -> Strategy a -> Strategy [a]
parListNth n strat xs
  | null rest = ()
  | otherwise = strat (head rest) `par` ()
  where
    rest = drop n xs

-- | 'parListChunk' sequentially applies a strategy to chunks
-- (sub-sequences) of a list in parallel. Useful to increase grain size
parListChunk :: Int -> Strategy a -> Strategy [a]
parListChunk n strat [] = ()
parListChunk n strat xs = seqListN n strat xs `par`
			    parListChunk n strat (drop n xs)

-- | 'parMap' applies a function to each element of the argument list in
-- parallel.  The result of the function is evaluated using the given
-- strategy.
parMap :: Strategy b -> (a -> b) -> [a] -> [b]
parMap strat f xs 	= map f xs `using` parList strat

-- | 'parFlatMap' uses 'parMap' to apply a list-valued function to each
-- element of the argument list in parallel.  The result of the function
-- is evaluated using the given strategy.
parFlatMap :: Strategy [b] -> (a -> [b]) -> [a] -> [b]
parFlatMap strat f xs = concat (parMap strat f xs)

-- | 'parZipWith' zips together two lists with a function z in parallel
parZipWith :: Strategy c -> (a -> b -> c) -> [a] -> [b] -> [c]
parZipWith strat z as bs =
  zipWith z as bs `using` parList strat

----------------------------------------------------------------------------
--                        Lists: Sequential Strategies
----------------------------------------------------------------------------

-- | Sequentially applies a strategy to each element of a list
seqList :: Strategy a -> Strategy [a]
seqList strat []     = ()
seqList strat (x:xs) = strat x `seq` (seqList strat xs)

-- | Sequentially applies a strategy to the first  n elements of a list
seqListN :: (Integral a) => a -> Strategy b -> Strategy [b]
seqListN n strat []     = ()
seqListN 0 strat xs     = ()
seqListN n strat (x:xs) = strat x `seq` (seqListN (n-1) strat xs)

-- | 'seqListNth' applies a strategy to the Nth element of it's argument
-- (if there is one) before returning the result. e.g. seqListNth 2 [e1,
-- e2, e3] evaluates e2
seqListNth :: Int -> Strategy b -> Strategy [b]
seqListNth n strat xs
  | null rest = ()
  | otherwise = strat (head rest)
  where
    rest = drop n xs

-- | Parallel n-buffer function added for the revised version of the strategies
-- paper. 'parBuffer' supersedes the older @fringeList@. It has the same
-- semantics.
parBuffer :: Int -> Strategy a -> [a] -> [a]
parBuffer n s xs =
  return xs (start n xs)
  where
    return (x:xs) (y:ys) = (x:return xs ys) `sparking` s y
    return xs     []     = xs

    start n []     = []
    start 0 ys     = ys
    start n (y:ys) = start (n-1) ys `sparking` s y

{-
 'fringeList' implements a `rolling buffer' of length n, i.e.applies a
 strategy to the nth element of list when the head is demanded. More
 precisely:

   semantics:         fringeList n s = id :: [b] -> [b]
   dynamic behaviour: evalutates the nth element of the list when the
		      head is demanded.

 The idea is to provide a `rolling buffer' of length n.
fringeList :: (Integral a) => a -> Strategy b -> [b] -> [b]
fringeList n strat [] = []
fringeList n strat (r:rs) =
  seqListNth n strat rs `par`
  r:fringeList n strat rs
-}

------------------------------------------------------------------------------
--			Arrays
------------------------------------------------------------------------------
instance (Ix a, NFData a, NFData b) => NFData (Array a b) where
  rnf x = rnf (bounds x) `seq` seqList rnf (elems x) `seq` ()

-- | Apply a strategy to all elements of an array in parallel. This can be done
-- either in sequentially or in parallel (same as with lists, really).
seqArr :: (Ix b) => Strategy a -> Strategy (Array b a)
seqArr s arr = seqList s (elems arr)

parArr :: (Ix b) => Strategy a -> Strategy (Array b a)
parArr s arr = parList s (elems arr)

-- Associations maybe useful even without mentioning Arrays.

data  Assoc a b =  a := b  deriving ()

instance (NFData a, NFData b) => NFData (Assoc a b) where
  rnf (x := y) = rnf x `seq` rnf y `seq` ()

------------------------------------------------------------------------------
--	                Some strategies specific for Lolita
------------------------------------------------------------------------------

fstPairFstList :: (NFData a) => Strategy [(a,b)]
fstPairFstList = seqListN 1 (seqPair rwhnf r0)

-- Some HACKs for Lolita. AFAIK force is just another name for our rnf and
-- sforce is a shortcut (definition here is identical to the one in Force.lhs)

force :: (NFData a) => a -> a
sforce :: (NFData a) => a -> b -> b

force = id $| rnf
sforce x y = force x `seq` y

max_stars_repo_name: alekar/hugs

max_issues_repo_name: alekar/hugs

max_forks_repo_name: alekar/hugs


text:
{-# LANGUAGE FlexibleContexts #-}

module Lib
  ( someFunc,
  )
where

import Control.Exception (throw)
import Data.Char (digitToInt, isHexDigit, toLower, toUpper)
import Data.Complex (Complex ((:+)))
import Data.Foldable (Foldable (foldl'))
import qualified Data.Functor
import Data.Ratio (Ratio, denominator, numerator)
import Foreign.C (isValidErrno)
import GHC.Arr (Array, listArray)
import GHC.Float (rationalToDouble)
import GHC.Real ((%))
import GHC.Unicode (isHexDigit)
import Numeric (readFloat, readHex, readOct)
import System.Environment (getArgs)
import Text.Parsec (ParseError, alphaNum, anyChar, digit, optional, sepBy, sepEndBy, skipMany)
import Text.Parsec.Char (digit)
import Text.ParserCombinators.Parsec
  ( Parser,
    char,
    digit,
    endBy,
    hexDigit,
    letter,
    many,
    many1,
    noneOf,
    notFollowedBy,
    octDigit,
    oneOf,
    parse,
    sepBy,
    skipMany1,
    space,
    string,
    try,
    (<?>),
    (<|>),
  )
import Text.ParserCombinators.Parsec.Char (digit)
import Text.Show (Show)
import Control.Monad.Except (throwError, catchError)

someFunc :: IO ()
someFunc = do
  (expr : _) <- getArgs
  let evaled = fmap show  $ readExpr expr >>= eval
  putStrLn $ extractValue $ trapError evaled

trapError :: ThrowsError String -> ThrowsError String
trapError action = catchError action (return . show)

symbol :: Parser Char
symbol = oneOf "!$%|*+-/:<=>?@^_~"

readExpr :: String -> ThrowsError LispVal
readExpr input = case parse parseExpr "lisp" input of
  Left err -> throwError $ Parser err
  Right val -> return val

spaces :: Parser ()
spaces = skipMany1 space

spaces1 :: Parser ()
spaces1 = skipMany space

data LispVal
  = Atom String
  | List [LispVal]
  | DottedList [LispVal] LispVal
  | String String
  | Bool Bool
  | Character Char
  | Number Integer
  | Float Double
  | Ratio Rational
  | Complex (Complex Double)
  | Vector (Array Int LispVal)

instance Show LispVal where show = showVal

showVal :: LispVal -> String
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Atom name) = name
showVal (Number contents) = show contents
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (Character c) = "\'" ++ show c ++ "\'"
showVal (Float f) = show f
showVal (Ratio r) = show r
showVal (Complex c) = show c
showVal (List contents) = "(" ++ unwordsList contents ++ ")"
showVal (DottedList head tail) =
  "(" ++ unwordsList head ++ " . "
    ++ showVal tail
    ++ ")"
showVal (Vector array) = show array

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

parseString :: Parser LispVal
parseString = do
  char '"'
  x <- many $ escapedChar <|> noneOf "\\\""
  char '"'
  return $ String x

escapedChar :: Parser Char
escapedChar = do
  char '\\'
  oneOf "\\\"\n\r\t"

parseAtom :: Parser LispVal
parseAtom = do
  first <- letter <|> symbol
  rest <- many (letter <|> digit <|> symbol)
  let atom = first : rest
  return $ case atom of
    "#t" -> Bool True
    "#f" -> Bool False
    _ -> Atom atom

parseNumber :: Parser LispVal
parseNumber =
  parseDecimal1
    <|> parseDecimal2
    <|> parseHex
    <|> parseOct
    <|> parseBin

parseDecimal1 :: Parser LispVal
parseDecimal1 = Number . read <$> many1 digit

parseDecimal2 :: Parser LispVal
parseDecimal2 = do
  try $ string "#d"
  x <- many1 digit
  return $ (Number . read) x

parseHex :: Parser LispVal
parseHex = do
  try $ string "#x"
  x <- many1 hexDigit
  return $ Number $ hex2dig x

parseOct :: Parser LispVal
parseOct = do
  try $ string "#o"
  x <- many1 octDigit
  return $ Number $ oct2dig x

parseBin :: Parser LispVal
parseBin = do
  try $ string "#b"
  x <- many1 (oneOf "10")
  return $ Number $ bin2dig x

oct2dig :: (Eq a, Num a) => String -> a
oct2dig x = fst $ head $ readOct x

hex2dig :: (Eq a, Num a) => String -> a
hex2dig x = fst $ head $ readHex x

bin2dig :: [Char] -> Integer
bin2dig = foldl' (\acc x -> acc * 2 + (toInteger . digitToInt) x) 0

parseBool :: Parser LispVal
parseBool = do
  char '#'
  (char 't' >> return (Bool True))
    <|> (char 'f' >> return (Bool False))

parseChar :: Parser LispVal
parseChar = try parseCharacter <|> parseCharacterName

parseCharacter :: Parser LispVal
parseCharacter =
  do
    string "#\\"
    x <- anyChar
    notFollowedBy alphaNum
    return $ Character x

parseCharacterName :: Parser LispVal
parseCharacterName =
  do
    string "#\\"
    val <- caseInsensitiveString "newline" <|> caseInsensitiveString "space"
    return $
      Character $ case val of
        "space" -> ' '
        "newline" -> '\n'
        _ -> ' '

caseInsensitiveChar :: Char -> Parser Char
caseInsensitiveChar c = char (toLower c) <|> char (toUpper c)

caseInsensitiveString :: String -> Parser String
caseInsensitiveString s = mapM caseInsensitiveChar s <?> "\"" ++ s ++ "\""

parseFloat :: Parser LispVal
parseFloat = do
  x <- many1 digit
  char '.'
  y <- many1 digit
  return $ Float (fst . head $ readFloat $ x ++ "." ++ y)

parseRatio :: Parser LispVal
parseRatio = do
  x <- many1 digit
  char '/'
  y <- many1 digit
  return $ Ratio $ read x % read y

parseComplex :: Parser LispVal
parseComplex = do
  x <- try parseFloat <|> parseNumber
  char '+'
  y <- try parseFloat <|> parseNumber
  char 'i'
  return $ Complex $ toDouble x :+ toDouble y

toDouble :: LispVal -> Double
toDouble (Float f) = realToFrac f
toDouble (Number n) = fromIntegral n
toDouble (Ratio r) = rationalToDouble (numerator r) (denominator r)
toDouble _ = error "not implement"

-- parse list
parseList :: Parser LispVal
parseList = List <$> sepBy parseExpr spaces

parseDottedList :: Parser LispVal
parseDottedList = do
  head <- endBy parseExpr spaces
  tail <- char '.' >> spaces >> parseExpr
  return $ DottedList head tail

parseListAll :: Parser LispVal
parseListAll = do
  char '('
  spaces1
  x <- try parseList <|> parseDottedList
  spaces1
  char ')'
  return x

parseListAllWithoutTry :: Parser LispVal
parseListAllWithoutTry = do
  char '('
  spaces1
  head <- sepEndBy parseExpr spaces
  do
    char '.' >> spaces
    tail <- parseExpr
    spaces1 >> char ')'
    return $ DottedList head tail
    <|> (char ')' >> return (List head))

parseQuoted :: Parser LispVal
parseQuoted = do
  char '\''
  x <- parseExpr
  return $ List [Atom "quote", x]

parseBackQuoted :: Parser LispVal
parseBackQuoted = do
  char '`'
  x <- parseExpr
  return $ List [Atom "quasiquote", x]

parseUnquote :: Parser LispVal
parseUnquote = do
  try $ char ','
  x <- parseExpr
  return $ List [Atom "unquote", x]

parseUnquoteSplicing :: Parser LispVal
parseUnquoteSplicing = do
  try $ string ",@"
  x <- parseExpr
  return $ List [Atom "unquote-splicing", x]

parseVector :: Parser LispVal
parseVector = do
  string "#("
  arrayVal <- sepBy parseExpr spaces
  char ')'
  return $ Vector $ listArray (0, length arrayVal - 1) arrayVal

parseNumber1 :: Parser LispVal
parseNumber1 = do
  num <- many1 digit
  return $ (Number . read) num

parseNumber2 :: Parser LispVal
parseNumber2 = many1 digit Data.Functor.<&> (Number . read)

parseExpr :: Parser LispVal
parseExpr =
  parseAtom
    <|> parseString
    <|> try parseComplex
    <|> try parseFloat
    <|> try parseRatio
    <|> try parseNumber -- we need the 'try' because these can all
    <|> try parseBool -- start with  the '#' char
    <|> try parseChar
    <|> parseQuoted
    <|> parseBackQuoted
    <|> parseUnquoteSplicing
    <|> parseUnquote
    <|> try parseVector
    <|> parseListAllWithoutTry

eval :: LispVal -> ThrowsError LispVal
eval val@(String _) = return val
eval val@(Number _) = return  val
eval val@(Bool _) = return val
eval val@(Character _) = return val
eval val@(Float _) = return val
eval val@(Ratio _) = return val
eval val@(Complex _) = return val
eval val@(Vector _) = return val
eval val@(DottedList _ _) = return val
eval (List [Atom "quote", val]) = return  val
eval (List [Atom "quasiquote", val]) = return val
eval (List (Atom func : args)) =  mapM  eval args >>= apply func
eval badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm

apply :: String -> [LispVal] -> ThrowsError LispVal
apply func args =
  maybe
    (throwError $ NotFunction "Unrecognized primitive function args" func)
    ($ args)
    (lookup func primitives)

{-
boolean? --Boolean? returns #t if obj is either #t or #f and returns #f otherwise.
pair? --Pair? returns #t if obj is a pair, and otherwise returns #f.
null? --Returns #t if obj is the empty list, otherwise returns #f.
list? --Returns #t if obj is a list, otherwise returns #f.
symbol? --Returns #t if obj is a symbol, otherwise returns #f.
char? --Returns #t if obj is a character, otherwise returns #f.
string? --Returns #t if obj is a string, otherwise returns #f.
vector? --Returns #t if obj is a vector, otherwise returns #f.

number?
complex?
real?
rational?
integer?
-}
primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
primitives =
  [ ("+", numericBinop (+)),
    ("-", numericBinop (-)),
    ("*", numericBinop (*)),
    ("/", numericBinop div),
    ("mod", numericBinop mod),
    ("quotient", numericBinop quot),
    ("remainder", numericBinop rem),
    ("boolean?", unaryOp booleanOp),
    ("pair?", unaryOp pairOp),
    ("null?", unaryOp nullOp),
    ("list?", unaryOp listOp),
    ("symbol?", unaryOp symbolOp),
    ("char?", unaryOp charOp),
    ("string?", unaryOp stringOp),
    ("vector?", unaryOp vectorOp),
    ("integer?", unaryOp integerOp),
    ("rational?", unaryOp rationalOp),
    ("real?", unaryOp realOp),
    ("complex?", unaryOp complexOp),
    ("number?", unaryOp numberOp),
    -- symbol handler
    ("symbol->string", unaryOp symbol2stringOp),
    ("string->symbol", unaryOp string2symbolOp)
  ]

string2symbolOp :: LispVal -> LispVal
string2symbolOp (String s) = Atom s
string2symbolOp n = error $ show n ++ " is not string."

symbol2stringOp :: LispVal -> LispVal
symbol2stringOp (Atom a) = String a
symbol2stringOp n = error $ show n ++ " is not atom."

integerOp :: LispVal -> LispVal
integerOp (Number _) = Bool True
integerOp _ = Bool False

rationalOp :: LispVal -> LispVal
rationalOp (Number _) = Bool True
rationalOp (Ratio _) = Bool True
rationalOp _ = Bool False

realOp :: LispVal -> LispVal
realOp (Number _) = Bool True
realOp (Ratio _) = Bool True
realOp (Float _) = Bool True
realOp _ = Bool False

complexOp :: LispVal -> LispVal
complexOp (Number _) = Bool True
complexOp (Ratio _) = Bool True
complexOp (Float _) = Bool True
complexOp (Complex _) = Bool True
complexOp _ = Bool False

numberOp :: LispVal -> LispVal
numberOp = complexOp

vectorOp :: LispVal -> LispVal
vectorOp (Vector _) = Bool True
vectorOp _ = Bool False

stringOp :: LispVal -> LispVal
stringOp (String _) = Bool True
stringOp _ = Bool False

charOp :: LispVal -> LispVal
charOp (Character _) = Bool True
charOp _ = Bool False

symbolOp :: LispVal -> LispVal
symbolOp (Atom _) = Bool True
symbolOp _ = Bool False

listOp :: LispVal -> LispVal
listOp (List _) = Bool True
listOp _ = Bool False

nullOp :: LispVal -> LispVal
nullOp (List []) = Bool True
nullOp _ = Bool False

pairOp :: LispVal -> LispVal
pairOp (List (a : _)) = Bool True
pairOp (DottedList _ _) = Bool True
pairOp _ = Bool False

booleanOp :: LispVal -> LispVal
booleanOp (Bool _) = Bool True
booleanOp _ = Bool False

unaryOp :: (LispVal -> LispVal) -> [LispVal] -> ThrowsError LispVal
unaryOp f [v] = return $ f v
unaryOp _ _ = error "only support one argument."

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

unpackNum :: LispVal -> ThrowsError Integer
unpackNum (Number n) = return n
unpackNum notNum = throwError $ TypeMismatch "number" notNum

-- error checking and exceptions

data LispError
  = NumArgs Integer [LispVal]
  | TypeMismatch String LispVal
  | Parser ParseError
  | BadSpecialForm String LispVal
  | NotFunction String String
  | UnboundVar String String
  | Default String

showError :: LispError -> String
showError (UnboundVar 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 str) = show str

instance Show LispError where show = showError

type ThrowsError = Either LispError

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

ext: hs

max_stars_repo_name: chonhnm/wyas

max_issues_repo_name: chonhnm/wyas

max_forks_repo_name: chonhnm/wyas


text:
-- |
-- Module      : Occlusion.Vector
-- Description :
-- Copyright   : (c) Jonatan H Sundqvist, 2015
-- License     : MIT
-- Maintainer  : Jonatan H Sundqvist
-- Stability   : experimental|stable
-- Portability : POSIX (not sure)
--

-- Created Jonatan H Sundqvist 2015

-- TODO | - Most of these functions should be moved to a utility library (eg. Cartesian)
--        -

-- SPEC | -
--        -

--------------------------------------------------------------------------------------------------------------------------------------------
-- GHC Pragmas
--------------------------------------------------------------------------------------------------------------------------------------------

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
module Occlusion.Vector where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
import Data.Complex
import Data.Functor ((<$>))
import Data.List    (sort, sortBy)
import Control.Applicative
import Control.Lens
import Control.Monad

import Southpaw.Math.Constants

import Occlusion.Types
import Occlusion.Lenses

--------------------------------------------------------------------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------------------------------------------------------------------
-- |
vectorise :: (a -> a -> b) -> Complex a -> b
vectorise f (x:+y) = f x y

-- Plumbing --------------------------------------------------------------------------------------------------------------------------------

-- |
dotwise :: (a -> a -> a) -> Complex a -> Complex a -> Complex a
dotwise f (x:+y) (x':+y') = f x x':+f y y'

-- |
dotmap :: (a -> a) -> Complex a -> Complex a
dotmap f (x:+y) = f x:+f y

-- Linear functions ------------------------------------------------------------------------------------------------------------------------

-- |
-- TODO: Refactor
-- TODO: Invariants, check corner cases
-- TODO: Deal with vertical lines
-- TODO: Factor out infinite-line logic
-- TODO: Decide how to deal with identical lines
-- TODO: Factor out domain logic (eg. write restrict or domain function)
-- TODO: Visual debugging functions
intersect :: RealFloat f => Line f -> Line f -> Maybe (Complex f)
-- intersect f@(Line a b) g@(Line a' b')
intersect f' g' = mp >>= \p -> indomain f' p >> indomain g' p
  where
    indomain h' = restrict (h'^.linebegin) (h'^.linestop)
    mp = case [linear f', linear g'] of
      [Just f, Nothing] -> let x = g'^.linebegin.real in Just $ (x):+(plotpoint f x)
      [Nothing, Just g] -> let x = f'^.linebegin.real in Just $ (x):+(plotpoint g x)
      [Just f,  Just g] -> linearIntersect f g
      _                 -> Nothing

-- | Gives the linear function overlapping the given segment
linear :: RealFloat f => Line f -> Maybe (Linear f)
linear line = (,) <$> slope line <*> intercept line

-- | Applies a linear function to the given value
-- TODO: Rename (?)
plotpoint :: RealFloat f => Linear f -> f -> f
plotpoint (slope', intercept') x = slope'*x + intercept'

-- | Finds the intersection (if any) of two linear functions
linearIntersect :: RealFloat f => Linear f -> Linear f -> Maybe (Complex f)
linearIntersect (kf, mf) (kg, mg)
  | kf == kg  = Nothing
  | otherwise = let x = (mg-mf)/(kg-kg)
                    y = (mf*x + kf)
                in Just $ x:+y

-- |
slope :: RealFloat f => Line f -> Maybe f
slope (Line fr to)
  | dx == 0   = Nothing
  | otherwise = Just $ dy/dx
  where
    (dx:+dy) = to - fr

-- |
intercept :: Line f -> Maybe f
intercept (Line a b) = error ""

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

-- |
between :: Ord a => a -> a -> a -> Bool
between mini maxi a = mini <= a && a <= maxi

-- | Ensures that a given point lies within the domain and codomain
-- TODO: Let thus function work on scalars, write another function for domain and codomain (?)
-- restrict domain codomain p = _
restrict :: Ord f => Complex f -> Complex f -> Complex f -> Maybe (Complex f)
restrict a b p@(x:+y)
  | indomain && incodomain = Just p
  | otherwise              = Nothing
  where
    (lowx:+lowy)   = dotwise min a b
    (highx:+highy) = dotwise max a b
    indomain       = between lowx highx x
    incodomain     = between lowy highy y

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

-- |
pass :: Monad m => m ()
pass = return ()

-- |
unit :: Monad m => a -> m a
unit = return

-- | Like maybe, except the function comes at the end
perhaps :: b -> Maybe a -> (a -> b) -> b
perhaps d m f = maybe d f m

max_stars_repo_name: SwiftsNamesake/Occlusion

max_issues_repo_name: SwiftsNamesake/Occlusion

max_forks_repo_name: SwiftsNamesake/Occlusion


text:
{-# LANGUAGE Rank2Types          #-}
{-# LANGUAGE TypeOperators       #-}

import Numeric.FAD
import Data.Complex
import Test.QuickCheck
import Data.Function (on)
import List.Util (zipWithDefaults, indexDefault)

-- Test only once, useful for properties with no parameters (could use
-- HUnit for such tests instead.)
onceCheck = quickCheckWith stdArgs { maxSuccess = 1 }

-- | Comparison allowing for inaccuracy.  Not transitive.

nearbyAbsolute accuracy x1 x2 = abs (x1 - x2) < accuracy
nearbyRelative accuracy x1 x2 = abs (x1 - x2) < accuracy * maximum (map abs [x1,x2])
nearbyHybrid   accuracy x1 x2 = abs (x1 - x2) < accuracy * maximum (map abs [x1,x2,1])

(~=) :: (Fractional t, Ord t) => t -> t -> Bool
(~=) = nearbyHybrid 1.0e-10
infix 4 ~=

(~~=) :: (Fractional t, Ord t) => [t] -> [t] -> Bool
(~~=) = ((.).(.)) and $ zipWithDefaults (~=) notNumber notNumber
    where notNumber = 0/0
infix 4 ~~=

-- Type signatures are supplied when QuickCheck is otherwise unable to
-- infer the type of the property's arguments.  An alternative way of
-- providing the type information would be, e.g.:
--
--   prop_constant_one x y = diffUU (\y -> lift x + y) y == (1 :: Double)
--

-- Nesting with @lift@ and @diffUU@ test cases.
prop_is1, prop_is2 :: Double -> Bool
prop_is1 x = diffUU (\x ->    diffUU ((lift x)*) 2)  x == 1
prop_is2 x = diffUU (\x -> x*(diffUU ((lift x)*) 2)) x == 2 * x

prop_constant_one :: Double -> Double -> Bool
prop_constant_one x y = diffUU (\y -> lift x + y) y == 1

-- @jacobian@ test cases.
prop_jacobian = jacobian (\xs -> [sum xs,
                                  product xs,
                                  log $ product $ map (sqrt . (^2) . exp) xs])
                [1..5] == [[1,1,1,1,1],
                           [120,60,40,30,24],
                           [1,1,1,1,1]]

-- @zeroNewton@ test cases.
prop_zeroNewton_1 = zeroNewton (\x->x^2-4) 1 !! 10 ~= 2
prop_zeroNewton_2 = zeroNewton ((+1).(^2)) (1 :+ 1) !! 10 == 0 :+ 1

-- @inverseNewton@ test case.
prop_inverseNewton = inverseNewton sqrt 1 (sqrt 10) !! 10 == 10

-- @atan2@ test cases.
prop_atan2_shouldBeOne :: Double -> Bool
prop_atan2_shouldBeOne a = diff (\a->atan2 (sin a) (cos a)) a ~= 1

-- @diffMF@ test cases.
prop_diffMF_1 = diffMF (\xs -> [sum (zipWith (*) xs [1..5])])
                [1,1,1,1,1] (map (10^) [0..4])
                == [54321]

prop_diffMF_2 = diffMF id [10..14] [0..4] == [0..4]

-- @diffMU@ test cases.
prop_diffMU_1 = diffMU (\xs -> sum (zipWith (*) xs [1..5]))
                [1,1,1,1,1] (map (10^) [0..4])
                == 54321

-- @diffsUU@ test cases.
prop_diffs_1 = (diffsUU (^5) 1) == [1,5,20,60,120,120]

prop_diffs_5 n =
    on (~~=) (take n)
           (map (2^) [0..])
           (diffsUU (exp . (2*)) 0)

-- @diffs0UU@ test cases:
prop_diffs_2 =
    on (==) (take 20)
           (diffs0UU (^5) 1)
           ([1,5,20,60,120,120] ++ repeat 0)

-- @diffsUF@ test cases:
prop_diffs_3 = (diffsUF ((:[]) . (^5)) 1) == [[1],[5],[20],[60],[120],[120]]

-- @diffs0UF@ test cases:
prop_diffs_4 =
    on (==) (take 20)
           (diffs0UF ((:[]) . (^5)) 1)
           ([[1],[5],[20],[60],[120],[120]] ++ repeat [0])

-- General routines for testing Taylor series accuracy

taylor_accurate :: (Ord a, Fractional a) =>
                   (forall tag. Tower tag a -> Tower tag a)
                       -> Int -> a -> a -> Bool

taylor_accurate f n x dx = s !!~ 0 ~= f0 x &&
                           s !!~ n ~= f0 (x+dx)
    where s = taylor f x dx
          f0 = primalUU f
          (!!~) = indexDefault Nothing

taylor_accurate_p :: (forall tag. Tower tag Double -> Tower tag Double) ->
                 Int -> Double -> Double -> Double -> Double -> Property

taylor_accurate_p f n dLo dHi x d =
    dLo <= d && d <= dHi ==> taylor_accurate f n x d

taylor2_accurate  :: (Ord a, Fractional a) =>
                  (forall tag0 tag.
                          Tower tag0 (Tower tag a)
                              -> Tower tag0 (Tower tag a)
                              -> Tower tag0 (Tower tag a))
                      -> Int -> Int -> a -> a -> a -> a -> Bool

taylor2_accurate f nx ny x y dx dy =
    let
        s2 = taylor2 f x y dx dy
        f2 x y = primal $ primal $ on f (lift . lift) x y
    in
      f2 x y ~= s2 !! 0 !! 0
            &&
      f2 (x+dx) (y+dy) ~= s2 !! nx !! ny

id_c c x = if x==c then c else x

-- Test all properties.
main = do
  quickCheck prop_is1
  quickCheck prop_is2
  quickCheck prop_constant_one
  onceCheck  prop_diffMF_1
  onceCheck  prop_diffMF_2
  onceCheck  prop_diffMU_1
  onceCheck  prop_jacobian
  onceCheck  prop_zeroNewton_1
  onceCheck  prop_zeroNewton_2
  onceCheck  prop_inverseNewton
  onceCheck prop_diffs_1
  onceCheck prop_diffs_2
  onceCheck prop_diffs_3
  onceCheck prop_diffs_4
  onceCheck  $ prop_diffs_5 1024
  -- (+)
  quickCheck $ \x -> taylor_accurate_p (+(lift x))         1 (-1e9) 1e9
  quickCheck $ \x -> taylor_accurate_p ((lift x)+)         1 (-1e9) 1e9
  -- (-)
  quickCheck $ \x -> taylor_accurate_p (flip (-) (lift x)) 1 (-1e9) 1e9
  quickCheck $ \x -> taylor_accurate_p ((lift x)-)         1 (-1e9) 1e9
  -- (*)
  quickCheck $ \x -> taylor_accurate_p (*(lift x))         1 (-1e9) 1e9
  quickCheck $ \x -> taylor_accurate_p ((lift x)*)         1 (-1e9) 1e9
  -- abs
  quickCheck $ taylor_accurate_p abs 1 (-1) 1e9 1
  quickCheck $ taylor_accurate_p abs 1 (-1e9) 1 (-1)
  -- recip
  quickCheck $ taylor_accurate_p recip 12 (-50) 50 200
  quickCheck $ taylor_accurate_p recip 12 (-50) 50 (-200)
  -- negate
  quickCheck $ taylor_accurate_p negate 1 (-1e9) 1e9
  -- pi
  onceCheck  $ diffs (const pi) 17 == [pi]
  -- exp
  quickCheck $ taylor_accurate_p exp 40 (-4) 4
  -- sqrt
  quickCheck $ taylor_accurate_p sqrt 10 (-1) 1 10
  -- log
  quickCheck $ taylor_accurate_p log 10 (-1) 1 (exp 2)
  -- (**)
  quickCheck $ taylor_accurate_p (**2.5) 12 (-0.5) 1 3
  quickCheck $ taylor_accurate_p (2.5**) 12 (-0.5) 1 3
  -- sin
  onceCheck  $ taylor_accurate   sin 40 0 (2*pi)
  quickCheck $ taylor_accurate_p sin 40 (-2.5*pi) (2.5*pi)
  -- cos
  onceCheck  $ taylor_accurate   cos 40 0 (2*pi)
  quickCheck $ taylor_accurate_p cos 40 (-2.5*pi) (2.5*pi)
  -- tan
  onceCheck  $ taylor_accurate tan 15 0 (pi/8)
  -- trig identity
  quickCheck $ taylor_accurate_p (\x -> sin x * cos x - sin (2*x) / 2) 10 (-5) 5
  -- asin
  quickCheck $ taylor_accurate_p (asin . sin) 10 (-0.9) (0.9) 0.1
  -- acos
  quickCheck $ taylor_accurate_p (acos . cos) 10 (-1) 1 (pi/3)
  -- atan
  quickCheck $ taylor_accurate_p (atan . tan) 10 (-1) 1 0.1
  -- sinh
  quickCheck $ taylor_accurate_p sinh 40 (-5) 5 0.1
  -- cosh
  quickCheck $ taylor_accurate_p cosh 40 (-5) 5 0.1
  -- tanh ?
  -- asinh
  onceCheck  $ taylor_accurate asinh 15 0.1 0.3
  -- acosh
  onceCheck  $ taylor_accurate acosh 15 2 0.2
  -- atanh
  onceCheck  $ taylor_accurate atanh 15 0.1 0.2
  -- atan2
  quickCheck $ prop_atan2_shouldBeOne
  onceCheck  $ prop_atan2_shouldBeOne (pi/2)
  -- (==)
  onceCheck  $ diffs (id_c 7) 3 == [3,1]
  onceCheck  $ diffs (id_c 7) 7 == [7]
  -- succ
  onceCheck  $ diffs succ 17 == [18,1]
  -- pred
  onceCheck  $ diffs pred 17 == [16,1]
  -- The [x..] construct
  onceCheck  $ diff (\x->[x]   !! 0) 7 == 1
  onceCheck  $ diff (\x->[x..] !! 0) 7 == 1
  onceCheck  $ diff (\x->[0,x..] !! 2) 7 == 2
  -- onceCheck  $ diffsUF (\x->[1,x..4.5]) 2 !! 0 == (\x->[1,x..4.5]) 2 -- BUG?

max_stars_repo_name: bjornbm/fad

max_issues_repo_name: bjornbm/fad

max_forks_repo_name: bjornbm/fad


text:
module Other (
    parseCsvToMatrixR,
    printCsvFromMatrixR,
    iterateM
  ) where

import Numeric.LinearAlgebra
import Data.List
import Data.List.Split

parseCsvToMatrixR :: FilePath -> IO (Matrix R)
parseCsvToMatrixR fp = do
  csv <- readFile fp
  return . fromLists . fmap (fmap (read :: String -> R) . splitOn ",") $ lines csv

printCsvFromMatrixR :: FilePath -> Matrix R -> IO ()
printCsvFromMatrixR fp m = do
  let csv = unlines . fmap (intercalate ", ") $ fmap show <$> toLists m
  writeFile fp csv

-- TODO: check monad rule
iterateM :: Monad m => (a -> m a) -> a -> [m a]
iterateM f x = iterate (f =<<) (return x)

max_stars_repo_name: pupuu/deep-neuralnet

max_issues_repo_name: pupuu/deep-neuralnet

max_forks_repo_name: pupuu/deep-neuralnet


text:
{-# OPTIONS_GHC -Wall #-}

{-|

  Module      : AutoBench.Internal.Analysis
  Description : Coordinates the analysis of runtime measurements.
  Copyright   : (c) 2018 Martin Handley
  License     : BSD-style
  Maintainer  : martin.handley@nottingham.ac.uk
  Stability   : Experimental
  Portability : GHC

  This module is responsible for coordinating the statistical analysis of
  runtime measurements. Raw measurements are subject to regression analysis
  (ridge regression) and linear models are fitted sets of (input size, runtime)
  coordinates. Regression models are then ranked according to fitting statistics
  generated by e.g., cross-validation (see 'Stats'). The equations of best
  fitting models are used to approximate the time complexity of test programs.

  * 'quickAnalysis' is for analysing the results of QuickBenching;
  * 'analyse' and 'analyseWith' are for analysing the results of AutoBenching.

  Note that 'analyse' and 'analyseWith' will be moved to a user exposed module
  when 'TestReport's can be saved to/loaded from file.

-}

{-
   ----------------------------------------------------------------------------
   <TO-DO>:
   ----------------------------------------------------------------------------
   - Address the cleansing of input sizes to remove 0;
   -
-}

module AutoBench.Internal.Analysis
  (

  -- * QuickBench.
    quickAnalyseWith   -- Analyse the given @[QuickReport]@, i.e., test results using the given 'AnalOpts'.
  -- * AutoBench.
  , analyse            -- Analyse the given 'TestReport', i.e., test results using the default 'AnalOpts'.
  , analyseWith        -- Analyse the given 'TestReport', i.e., test results using the given 'AnalOpts'

  ) where

import           Control.Arrow         ((&&&))
import           Criterion.Types       (OutlierEffect(..))
import           Data.Default          (def)
import           Data.List             (genericLength, sort, sortBy)
import           Data.Maybe            (catMaybes)
import qualified Data.Vector.Storable  as V
import           Numeric.LinearAlgebra (Vector, norm_1, norm_2)
import           System.IO.Unsafe      (unsafePerformIO)
import           System.Random         (randomRIO)

import AutoBench.Internal.AbstractSyntax  (Id)
import AutoBench.Internal.Configuration   (maximumModelPredictors)
import AutoBench.Internal.UserIO          (outputAnalysisReport, outputQuickAnalysis)
import AutoBench.Internal.Regression      (generateLinearCandidate, fitRidgeRegress)
import AutoBench.Internal.UserInputChecks (validateAnalOpts, validateTestReport)
import AutoBench.Internal.Utils           (notNull, uniqPairs)

import AutoBench.Internal.Types
  ( AnalOpts(..)
  , AnalysisReport(..)
  , BenchReport(..)
  , Coord
  , Coord3
  , CVStats(..)
  , Improvement
  , InputError(..)
  , LinearCandidate(..)
  , LinearFit(..)
  , SimpleReport(..)
  , SimpleResults(..)
  , Stats(..)
  , TestReport(..)
  , QuickAnalysis(..)
  , QuickReport(..)
  , QuickResults(..)
  , numPredictors
  , simpleReportsToCoords
  )

-- * QuickBench Top-level

-- | Analyse the given @[QuickReport]@, i.e., test results using the
-- given 'AnalOpts'. Analysis results are output to the console and file
-- depending on the 'AnalOpts'. The boolean parameter is whether the
-- test programs have the same results according to QuickCheck testing.
-- Note: this function is not exposed to users.
quickAnalyseWith :: AnalOpts -> Bool -> [QuickReport] -> IO ()
quickAnalyseWith _ _ [] = print $ QuickBenchErr "No results to analyse."
quickAnalyseWith aOpts eql qrs = outputQuickAnalysis aOpts eql $
  quickAnalysis aOpts qrs

-- * AutoBench Top-level

-- | Analyse the given 'TestReport', i.e., test results using the
-- default 'AnalOpts'.
analyse :: TestReport -> IO ()
analyse  = analyseWith def

-- | Analyse the given 'TestReport', i.e., test results using the
-- given 'AnalOpts'. Analysis results are output to the console and file
-- depending on the 'AnalOpts'.
analyseWith :: AnalOpts -> TestReport -> IO ()
analyseWith aOpts tr
  | notNull (aOptsErrs ++ trErrs) = do
      putStrLn "Cannot analyse results due to one or more errors:"
      mapM_ print (aOptsErrs ++ trErrs)
  -- Just output the results of statistical analysis.
  | otherwise = outputAnalysisReport aOpts tr $ calculateAnalysisReport aOpts tr

  where
    -- Validate the 'AnalOpts'.
    aOptsErrs = validateAnalOpts aOpts
    -- Validate the 'TestReport'
    trErrs    = validateTestReport tr

-- * QuickBench Analysis

-- | Perform statistical analysis on the benchmarking results (i.e., runtime
-- measurements of test programs) in the given @[QuickReport]@ and produce a
-- 'QuickAnalysis' report to summarise the system's analysis phase.
quickAnalysis :: AnalOpts -> [QuickReport] -> QuickAnalysis
quickAnalysis aOpts qrs =
  QuickAnalysis
    {
      _qAnlys = quickResults aOpts qrs                               -- A set of quick results ('QuickResults') for each test program.
    , _qImps  = catMaybes $ fmap (uncurry $ calculateImprovements    -- A set of improvements.
        (_improv aOpts)) (uniqPairs $ zip names coords)
    }
  where
    -- Names of test programs
    names = fmap _qName qrs
    -- (Input size(s), runtime) coordinates.
    coords = fmap _qRuntimes qrs

-- | Perform statistical analysis on the benchmarking results (i.e., runtime
-- measurements of test programs) in the given @[QuickReport]@ and produce an
-- analysis report ('QuickResults') /for each test program/.
quickResults :: AnalOpts -> [QuickReport] -> [QuickResults]
quickResults aOpts = fmap quickResult
  where
    quickResult :: QuickReport -> QuickResults
    quickResult qr =
      QuickResults
        {
          _qrIdt  = _qName qr
        -- Raw measurements.
        , _qrRaws = coords
        -- Fit all models in the 'AnalOpts' to the raw measurements.
        , _qrFits = fitCoords aOpts coords
        }
      where coords = _qRuntimes qr

-- * AutoBench Analysis

-- | Perform statistical analysis on the benchmarking results (i.e., runtime
-- measurements of test programs) in the given 'TestReport' and produce an
-- 'AnalysisReport' to summarise the system's overall analysis phase.
calculateAnalysisReport :: AnalOpts -> TestReport -> AnalysisReport
calculateAnalysisReport aOpts tr =
  AnalysisReport
    {
      _anlys = anlys                                               -- A set of simple results ('SimpleResults') for each test program.
    , _imps  = catMaybes $ fmap (uncurry $ calculateImprovements   -- A set of improvements.
        -- Compare every set of measurements against every other set.
        (_improv aOpts)) (uniqPairs $ zip srNames srCoords)
    , _blAn  = blAn                                                -- Analysis of baseline measurements, if applicable.
    }
  where
    -- 'SimpleResults' for test programs and baseline measurements, if applicable.
    (anlys, blAn) =  calculateSimpleResults aOpts tr

    -- For generating improvements: compare all results from test programs
    -- against eachother using 'uniqPairs'.

    -- SimpleReports.
    srs = _reports (_br tr)
    -- Names of test programs from 'SimpleReport's.
    srNames  = fmap (_name . head) srs
    -- (Input size(s), runtime) coordinates.
    srCoords = zipWith simpleReportsToCoords srNames srs

-- | Perform statistical analysis on the benchmarking results (i.e., runtime
-- measurements of test programs) in the given 'TestReport' and produce an
-- analysis report ('SimpleResults') /for each test program/.
-- If baseline measurements have been taken then also produce a 'SimpleReport'
-- for these results.
calculateSimpleResults
  :: AnalOpts
  -> TestReport
  -> ([SimpleResults], Maybe SimpleResults) -- Maybe is for baseline measurements.
calculateSimpleResults aOpts tr = (progResults, blResults)

  where
    -- Analysis for test programs.
    progResults = zipWith calculateSimpleResult (_tProgs tr) (_reports $ _br tr)
    -- Analysis for baseline measurements.
    blResults = case _baselines $ _br tr of
      []  -> Nothing
      bls -> Just $ calculateSimpleResult "Baseline measurements" bls                               -- <TO-DO>: This shouldn't be a string.

    -- For a set of 'SimpleReport's (i.e., test cases) relating to a
    -- given test program, perform statistical analysis and generate
    -- 'SimpleResults'.
    calculateSimpleResult
      :: Id               -- Name of test program.
      -> [SimpleReport]   -- Benchmarking measurements for each test case.
      -> SimpleResults
    calculateSimpleResult idt srs =
      SimpleResults
        {
          _srIdt           = idt
        -- Raw measurements.
        , _srRaws          = coords
        -- Cumulative statistics for /all/ test cases, taken from Criterion's 'Report'.
        , _srStdDev        = stdDev
        , _srAvgOutVarEff  = avgOutVarEff
        , _srAvgPutVarFrac = avgOutVarFrac
        -- Fit all models in the 'AnalOpts' to the raw measurements.
        , _srFits          = fitCoords aOpts coords
        }
      where
        coords = simpleReportsToCoords idt srs
        (stdDev, avgOutVarFrac, avgOutVarEff) = simpleReportSummary srs

    -- Provide an summary of the simple statistics taken from
    -- Criterion's 'Report's relating to the /same/ test program:
    --
    -- * Standard deviation of all test cases;
    -- * Average effect of outliers on variance (percentage);
    -- * Average effect of outliers on variance ('OutlierEffect').
    simpleReportSummary
      :: [SimpleReport]
      -> (Double, Double, OutlierEffect)
    simpleReportSummary []  = (0, 0, Unaffected)                                                    -- <TO-DO> What is this error handling?
    simpleReportSummary srs = (stdDev srs, avgOutVarFrac, avgOutVarEff)
      where
        -- Standard deviation for all test cases: sqrt (SUM variance_i/samples_i).
        stdDev = sqrt . sum . fmap (uncurry (/) . ((** 2) .
          _stdDev &&& fromIntegral . _samples))

        -- Average effect of outliers on variance.
        avgOutVarFrac = sum (fmap _outVarFrac srs) / genericLength srs
        avgOutVarEff
          | avgOutVarFrac < 0.01 = Unaffected -- Same as Criterion.
          | avgOutVarFrac < 0.1  = Slight
          | avgOutVarFrac < 0.5  = Moderate
          | otherwise            = Severe

-- * Linear fitting

-- | Fit a 'LinearCandidate' model to a data set, generating a 'LinearFit'
-- that can be used to asses the model's goodness of fit.
candidateFit
  :: ([Coord] -> LinearCandidate -> Vector Double)  -- Fitting function.
  -> Double                                         -- Cross-validation train/validate data split.
  -> Int                                            -- Cross-validation iterations.
  -> [Coord]                                        -- Data set.
  -> LinearCandidate                                -- Model to fit.
  -> Maybe LinearFit
candidateFit ff split iters coords c
  | length cleansedCoords < maximumModelPredictors + 1 = Nothing     -- Need a minimum of (maximumModelPredictors + 1) coordinates.
  | V.null coeffs = Nothing                                          -- If coefficients are null, can't use model.
  | otherwise = Just
      LinearFit
        {
          _lft  = _lct c
        , _cfs  = coeffs
        , _ex   = _fex   c coeffs
        , _yhat = _fyhat c coeffs
        , _sts  = sts
        }
  where
    -- Model coefficients when fit to /entire/ data set.
    -- This is for e.g., R^2, Adj. R^2, BIC, AIC CP.
    coeffs = ff cleansedCoords c                                                                    -- <TO-DO>: can 'ff' fail?
    -- Statistics from cross-validation, e.g., PRESS, PMAE, PMSE.
    cvSts  = cvCandidateFit ff split iters cleansedCoords c
    -- Combine statistics from each cross-validation iteration and also compute
    -- other goodness of fit measures.
    sts    = stats c cleansedCoords coeffs cvSts

    -- Cleanse in case transformation produces infinite values.                                     -- <TO-DO> *** This needs addressing. ***
    -- /This happens when for size 0 only, LogBase _ 0 = -Infinity/.
    -- Remove the @(0, _)@ coordinate.
    -- ** Only cleanse runtimes predicted by models. **
    cleansedCoords = cleanse coords
    cleanse :: [Coord] -> [Coord]
    cleanse  = filter (\(x, _) -> x /= 0)

-- ** Linear fitting cross-validation

-- | Fit a 'LinearCandidate' to a data set using Monte Carlo cross-validation.
-- Return the fitting statistics ('CVStats') from each iteration of
-- cross-validation.
cvCandidateFit
  :: ([Coord] -> LinearCandidate -> Vector Double)  -- Fitting function (ridge regression in practice).
  -> Double                                         -- Train/evaluate data split.
  -> Int                                            -- Number of iterations.
  -> [Coord]                                        -- Full data set.
  -> LinearCandidate                                -- Model to fit.
  -> [CVStats]
cvCandidateFit ff split iters coords c =
  fmap (uncurry trainAndValidate) splits
  where
    splits = fmap (splitRand split) (replicate iters coords)

    -- Train the model on the training data and evaluate it on the validation
    -- data: calculating the cross-validation statistics ('CVStats').
    trainAndValidate :: [Coord] -> [Coord] -> CVStats
    trainAndValidate train valid = cvStats c valid (ff train c)

-- ** Linear fitting statistics

-- | Fitting statistics generated from a /single/ iteration of cross-validation.
-- See 'stats' for cumulative fitting statistics.
cvStats
  :: LinearCandidate    -- The model.
  -> [Coord]            -- The /evaluation/ set of this iteration of cross-validation.
  -> Vector Double      -- The coefficients of the model calculated using the /training/ set.
  -> CVStats            -- The model's fitting statistics for this iteration of cross-validation.
cvStats c coords coeffs =
  CVStats
   {
     _cv_mse    = mse
   , _cv_mae    = mae
   , _cv_ss_tot = ss_tot
   , _cv_ss_res = ss_res
   }
  where
    ---------------------------------------------------------------------------
    (xs, ys) = unzip coords
    _X       = V.fromList xs                              -- X. ** don't transform using fxs **
    _Y       = V.fromList ys                              -- Y.
    n        = length coords
    n'       = fromIntegral n                             -- n data points.
    ---------------------------------------------------------------------------
    yhat    = _fyhat c coeffs _X                          -- Model y-coords.
    ybar    = V.sum _Y / n'                               -- Average of data y-coords.
    ybars   = V.replicate n ybar
    ---------------------------------------------------------------------------
    mse     = ss_res / n'                                 -- Mean squared error       ss_res / n
    mae     = (norm_1 $ V.zipWith (-) _Y yhat) / n'       -- Mean absolute error:     (SUM |y_i - f(y_i)|) / n
    ss_tot  = (norm_2 $ V.zipWith (-) _Y ybars) ** 2.0    -- Total sum of squares:    SUM (y_i - avg(y))^2
    ss_res  = (norm_2 $ V.zipWith (-) _Y yhat)  ** 2.0    -- Residual sum of squares: SUM (y_i - f(y_i))^2

-- | Overall fitting statics for a model and a given data set. Some statistics
-- are cumulative fitting stats, generated by cross-validation (PMSE, PMAE,
-- PRESS, SST, Pred. R^2); others are generated by using the whole data set as
-- training data (R^2, Adj. R^2, AIC, BIC, Mallow's CP).
stats
  :: LinearCandidate  -- The model.
  -> [Coord]          -- The data set
  -> Vector Double    -- The coefficients of the model calculated using the /entire/ set.
  -> [CVStats]        -- The statistics from each iteration of cross-validation.
  -> Stats            -- The cumulative fitting statistics.
stats c coords coeffs cvSts = _sts
  where
    -- Statistics calculated below.
    _sts = Stats
            {
              _p_mse    = p_mse
            , _p_mae    = p_mae
            , _ss_tot   = cv_ss_tot
            , _p_ss_res = p_ss_res
            , _r2       = r2
            , _a_r2     = a_r2
            , _p_r2     = p_r2
            , _bic      = bic
            , _aic      = aic
            , _cp       = cp
            }
    ---------------------------------------------------------------------------
    -- Statistics for /complete/ data set:
    ---------------------------------------------------------------------------
    (xs, ys) = unzip coords
    _X       = V.fromList xs                                           -- X. ** do not transform using fxs **
    _Y       = V.fromList ys                                           -- Y.
    n        = length coords
    n'       = fromIntegral n                                          -- n data points.
    k'       = fromIntegral (numPredictors $ _lct c)                   -- k predictors.
    ---------------------------------------------------------------------------
    yhat     = _fyhat c coeffs _X                                      -- Model y-coords.
    ybar     = V.sum _Y / n'                                           -- Average of data y-coords.
    ybars    = V.replicate n ybar
    ---------------------------------------------------------------------------
    _mse     = _ss_res / n'                                            -- Mean squared error:                       ss_res / n
    _ss_tot  = (norm_2 $ V.zipWith (-) _Y ybars) ** 2.0                -- Total sum of squares:                     SUM (y_i - avg(y))^2
    _ss_res  = (norm_2 $ V.zipWith (-) _Y yhat)  ** 2.0                -- Residual sum of squares:                  SUM (y_i - f(y_i))^2
    r2       = 1.0 - (_ss_res / _ss_tot)                               -- Coefficient of Determination:             1 - ss_res/ss_tot
    a_r2     = 1.0 - ((1.0 - r2) * (n' - 1.0) / (n' - k' - 1.0))       -- Adjusted Coefficient of Determination:    1 - ((1 - r^2)(n - 1)/(n - k - 1))
    ---------------------------------------------------------------------------
    -- http://www.stat.wisc.edu/courses/st333-larget/aic.pdf (implementations from R).
    ---------------------------------------------------------------------------
    aic = (n' * log (_ss_res / n')) + (2 * k')                         -- Akaike’s Information Criterion:           n * ln(ss_res/n) + 2k
    bic = (n' * log (_ss_res / n')) + (k' * log n')                    -- Bayesian Information Criterion:           n * ln(ss_res/n) + k * ln(n)
    cp  = (_ss_res / _mse) - (n' - (2 * k'))                           -- Mallows' Cp Statistic:                    (ss_res/_mse) - (n - 2k)
    ---------------------------------------------------------------------------
    -- Cross-validated statistics:
    ---------------------------------------------------------------------------
    cv_n      = genericLength cvSts
    p_mse     = (sum $ fmap _cv_mse cvSts)    / cv_n                   -- 1/n * SUM mse_k         for each iteration k
    p_mae     = (sum $ fmap _cv_mae cvSts)    / cv_n                   -- 1/n * SUM mae_k         for each iteration k
    cv_ss_tot = (sum $ fmap _cv_ss_tot cvSts) / cv_n                   -- 1/n * SUM ss_tot_k      for each iteration k
    p_ss_res  = (sum $ fmap _cv_ss_res cvSts) / cv_n                   -- 1/n * SUM ss_res_k      for each iteration k
    p_r2     = 1.0 - (p_ss_res / cv_ss_tot)                            -- 1 - p_ss_res/cv_ss_tot

-- * Helpers

-- | Split a list into two random sublists of specified sizes.
-- Warning: uses 'unsafePerformIO' for randomness.
splitRand :: Double -> [a] -> ([a], [a])                                                            -- <TO-DO>: Does this need to be more sophisticated?
splitRand split xs = (take len shuffled, drop len shuffled)
  where
    len = ceiling (genericLength xs * split)
    shuffled = unsafePerformIO (shuffle xs)                                                         -- <TO-DO> 'unsafePerformIO'

-- | Naive-ish way to shuffle a list.
shuffle :: [a] -> IO [a]                                                                            -- <TO-DO>: Could shuffle in the top-level functions to avoid using unsafePerformIO?
shuffle x =                                                                                -- <TO-DO>: Does this need to be more sophisticated?
  if length x < 2
  then return x
  else do
   i <- randomRIO (0, length x - 1)
   r <- shuffle (take i x ++ drop (i + 1) x)
   return (x !! i : r)

-- | Compare the runtimes of two test programs, given as a list of
-- xy-coordinates, pointwise to generate improvement results. Only compare
-- results relating to test programs of the same airty. (Note: this should
-- always be the case when used in practice).
calculateImprovements
 :: ([(Double, Double)] -> Maybe (Ordering, Double))  -- '_improv' function from 'AnalOpts'.
 -> (Id, Either [Coord] [Coord3])                     -- Runtimes of test program 1.
 -> (Id, Either [Coord] [Coord3])                     -- Runtimes of test program 2.
 -> Maybe Improvement
calculateImprovements improv (idt1, Left cs1) (idt2, Left cs2) -- Unary against unary.
  -- If all coordinates didn't match, then can't generate improvements.
  | length toCompare < length cs1 = Nothing
  | otherwise = case improv toCompare of
      Nothing       -> Nothing
      Just (ord, d) -> Just (idt1, ord, idt2, d)
  where toCompare = matchCoords (sort cs1) (sort cs2)
calculateImprovements improv (idt1, Right cs1) (idt2, Right cs2) -- Binary against binary.
  -- If all coordinates didn't match, then can't generate improvements.
  | length toCompare < length cs1 = Nothing
  | otherwise = case improv toCompare of
      Nothing       -> Nothing
      Just (ord, d) -> Just (idt1, ord, idt2, d)
  where toCompare = matchCoords3 (sort cs1) (sort cs2)
calculateImprovements _ _ _ = Nothing -- Shouldn't happen.

-- | Make sure coordinates to compare when generating improvement results have
-- the same size information. (Note: this should always be the case because of
-- how they are generated, but better to check.). For 'Coord'.
matchCoords :: [Coord] -> [Coord] -> [(Double, Double)]
matchCoords [] _  = []
matchCoords _  [] = []
matchCoords ((s1, t1) : cs1) ((s1', t2) : cs2)
  | s1 == s1' = (t1, t2) : matchCoords cs1 cs2
  | otherwise = matchCoords cs1 cs2

-- | Make sure coordinates to compare when generating improvement results have
-- the same size information. (Note: this should always be the case because of
-- how they are generated, but better to check.). For 'Coord3'
matchCoords3 :: [Coord3] -> [Coord3] -> [(Double, Double)]
matchCoords3 [] _  = []
matchCoords3 _  [] = []
matchCoords3 ((s1, s2, t1) : cs1) ((s1', s2', t2) : cs2)
  | s1 == s1' && s2 == s2' = (t1, t2) : matchCoords3 cs1 cs2
  | otherwise = matchCoords3 cs1 cs2

-- | Fit the '_linearModels' in a given 'AnalOpts' to a data set to generate
-- 'LinearFit's (i.e., models with their missing parameters/coefficients
-- approximated). Currently this only works for 'Coord's, i.e., runtime
-- measurements from /unary/ test programs. Models are fitted to data
-- sets using ridge regression.
--
-- Note 'AnalOpts' is required here because it contains other settings needed
-- for fitting, i.e., cross-validation parameters: '_cvTrain', '_cvIters'.
--
-- Also sorts and filters the resulting models using '_statsSort' and
-- '_statsFilt' from 'AnalOpts', respectively.
fitCoords :: AnalOpts -> Either [Coord] [Coord3] -> [LinearFit]
fitCoords _ Right{} = []                                                                            -- <TO-DO>: Analyse 3D coords?
fitCoords aOpts (Left coords) = take (_topModels aOpts)
   $ sortBy (\lf1 lf2 -> (_statsSort aOpts) (_sts lf1) (_sts lf2))    -- SORT:   '_statsSort'
   $ filter (\lf -> (_statsFilt aOpts) (_sts lf))                     -- FILTER: '_statsFilt'
   $ catMaybes  -- The fitting process may fail in some cases, exactly when?                        -- <TO-DO>: When does fitting fail.. When not enough coords only!
   $ fmap ( ( candidateFit
               fitRidgeRegress           -- Use ridge regression to fit.
               (_cvTrain aOpts)          -- Train/evaluate data split.
               (_cvIters aOpts)          -- Number of cross-validation iterations.
               coords                    -- Data set.
            ) . generateLinearCandidate   -- 'LinearType' -> 'LinearCandidate'.
          ) (_linearModels aOpts)         -- Fit all models in 'AnalOpts'.

max_stars_repo_name: recursion-ninja/AutoBench

max_issues_repo_name: recursion-ninja/AutoBench

max_forks_repo_name: recursion-ninja/AutoBench


text:
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-- |
-- Module      : Graphics.Image.Processing.Complex.Internal
-- Copyright   : (c) Alexey Kuleshevich 2016-2018
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Image.Processing.Complex.Internal
  (
  -- * Pixel
    Complex(..)
  -- ** Rectangular form
  , (+:)
  , realPart
  , imagPart
  -- ** Polar form
  , mkPolar
  , cis
  , polar
  , magnitude
  , phase
  -- ** Conjugate
  , conjugate
  -- * Image
  -- ** Rectangular form
  , (+:!)
  , realPartI
  , imagPartI
  -- ** Polar form
  , mkPolarI
  , cisI
  , polarI
  , magnitudeI
  , phaseI
  -- ** Conjugate
  , conjugateI
  -- * Re-export
  ) where

import Control.Applicative
import Data.Complex (Complex(..))
import qualified Data.Complex as C
import Graphics.Image.Internal
import Prelude hiding (map, zipWith)

infix 6 +:!, +:

(+:) :: Applicative (Color cs) => Pixel cs e -> Pixel cs e -> Pixel cs (Complex e)
(+:) = liftA2 (:+)
{-# INLINE (+:) #-}

realPart :: Functor (Color cs) => Pixel cs (Complex e) -> Pixel cs e
realPart = fmap C.realPart
{-# INLINE realPart #-}

imagPart ::  Functor (Color cs) => Pixel cs (Complex e) -> Pixel cs e
imagPart = fmap C.imagPart
{-# INLINE imagPart #-}

mkPolar :: (Applicative (Color cs), Floating e) => Pixel cs e -> Pixel cs e -> Pixel cs (Complex e)
mkPolar = liftA2 C.mkPolar
{-# INLINE mkPolar #-}

cis :: (Functor (Color cs), Floating e) => Pixel cs e -> Pixel cs (Complex e)
cis = fmap C.cis
{-# INLINE cis #-}

polar :: (Functor (Color cs), RealFloat e) => Pixel cs (Complex e) -> (Pixel cs e, Pixel cs e)
polar z = (magnitude z, phase z)
{-# INLINE polar #-}

magnitude :: (Functor (Color cs), RealFloat e) => Pixel cs (Complex e) -> Pixel cs e
magnitude = fmap C.magnitude
{-# INLINE magnitude #-}

phase :: (Functor (Color cs), RealFloat e) => Pixel cs (Complex e) -> Pixel cs e
phase = fmap C.phase
{-# INLINE phase #-}

conjugate :: (Functor (Color cs), Num e) => Pixel cs (Complex e) -> Pixel cs (Complex e)
conjugate = fmap C.conjugate
{-# INLINE conjugate #-}

-- | Construct a complex image from two images representing real and imaginary parts.
--
-- >>> frog <- readImageRGB "images/frog.jpg"
-- >>> frog !+! 0
-- <Image RGB Complex Double: 200x320>
-- >>> frog !+! frog
-- <Image RGB Complex Double: 200x320>
--
(+:!) :: (ColorModel cs e, ColorModel cs (Complex e)) =>
         Image cs e -> Image cs e -> Image cs (Complex e)
(+:!) = zipWith (+:)
{-# INLINE (+:!) #-}

-- | Extracts the real part of a complex image.
realPartI :: (RealFloat e, ColorModel cs e, ColorModel cs (Complex e)) =>
             Image cs (Complex e) -> Image cs e
realPartI = map realPart
{-# INLINE realPartI #-}

-- | Extracts the imaginary part of a complex image.
imagPartI :: (RealFloat e, ColorModel cs e, ColorModel cs (Complex e)) =>
             Image cs (Complex e) -> Image cs e
imagPartI = map imagPart
{-# INLINE imagPartI #-}

-- | Form a complex image from polar components of magnitude and phase.
mkPolarI :: (RealFloat e, ColorModel cs e, ColorModel cs (Complex e)) =>
            Image cs e -> Image cs e -> Image cs (Complex e)
mkPolarI = zipWith mkPolar
{-# INLINE mkPolarI #-}

-- | @'cisI' t@ is a complex image with magnitude 1 and phase t (modulo @2*'pi'@).
cisI :: (RealFloat e, ColorModel cs e, ColorModel cs (Complex e)) =>
        Image cs e -> Image cs (Complex e)
cisI = map cis
{-# INLINE cisI #-}

-- | The function @'polar''@ takes a complex image and returns a (magnitude, phase)
-- pair of images in canonical form: the magnitude is nonnegative, and the phase
-- in the range @(-'pi', 'pi']@; if the magnitude is zero, then so is the phase.
polarI :: (RealFloat e, ColorModel cs e, ColorModel cs (Complex e)) =>
          Image cs (Complex e) -> (Image cs e, Image cs e)
polarI !zImg = (magnitudeI zImg, phaseI zImg)
{-# INLINE polarI #-}

-- | The nonnegative magnitude of a complex image.
magnitudeI :: (RealFloat e, ColorModel cs e, ColorModel cs (Complex e)) =>
              Image cs (Complex e) -> Image cs e
magnitudeI = map magnitude
{-# INLINE magnitudeI #-}

-- | The phase of a complex image, in the range @(-'pi', 'pi']@. If the
-- magnitude is zero, then so is the phase.
phaseI :: (RealFloat e, ColorModel cs e, ColorModel cs (Complex e)) =>
          Image cs (Complex e) -> Image cs e
phaseI = map phase
{-# INLINE phaseI #-}

-- | The conjugate of a complex image.
conjugateI :: (RealFloat e, ColorModel cs e, ColorModel cs (Complex e)) =>
              Image cs (Complex e) -> Image cs (Complex e)
conjugateI = map conjugate
{-# INLINE conjugateI #-}

max_stars_repo_name: HanStolpo/hip

max_issues_repo_name: HanStolpo/hip

max_forks_repo_name: HanStolpo/hip


text:
{-# LANGUAGE RecordWildCards #-}
module Q.Options.Black76
  (
    module Q.Options
  , Black76(..)
  , atmf
  , euOption
  , eucall
  , euput
  )
  where

import           Q.Options
import           Q.Types
import           Statistics.Distribution        (cumulative, density)
import           Statistics.Distribution.Normal (standard)

data Black76 = Black76 {
    b76F   :: Forward
  , b76DF  :: DF
  , b76T   :: YearFrac
  , b76Vol :: Vol
}

-- | At the money forward strike.
atmf :: Black76 -> Strike
atmf Black76{..} = Strike f
  where (Forward f) = b76F

-- | European option valuation with black 76
euOption :: Black76 -> OptionType -> Strike -> Valuation
euOption b76@Black76{..} cp k = Valuation premium delta vega gamma where
  (Forward f) = b76F
  n           = cumulative standard
  (Vol sigmaSqt) = scale b76T b76Vol
  d1          = (dPlus  b76F b76Vol k b76T)
  d2          = (dMinus b76F b76Vol k b76T)
  nd1         = n d1
  nd2         = n d2
  callDelta   = b76DF `discount` nd1
  putDelta    = b76DF `discount` (- (n (-d1)))
  vega        = Vega  $ b76DF `discount` (density standard d1 ) * f * sigmaSqt
  gamma       = Gamma $ b76DF `discount` (density standard d1) / (f * sigmaSqt)
  premium  = Premium $ case cp of
    Call -> b76DF `discount` (f * nd1 - nd2 * k')
    Put  -> b76DF `discount` (n (-d2) * k' - n (-d1) * f)
    where (Strike k') = k
  delta | cp == Call = Delta $ callDelta
        | cp == Put  = Delta $ putDelta

-- | see 'euOption'
euput b76 =  euOption b76 Put

-- | see 'euOption'
eucall b76 = euOption b76 Call

dPlus (Forward f) (Vol sigma) (Strike k) (YearFrac t) =
  recip (sigma * sqrt t) * (log (f/k) + (0.5 * sigma * sigma) * t)
dMinus (Forward f) (Vol sigma) (Strike k) (YearFrac t) =
  recip (sigma * sqrt t) * (log (f/k) - (0.5 * sigma * sigma) * t)

max_stars_repo_name: ghais/lowq

max_issues_repo_name: ghais/lowq

max_forks_repo_name: ghais/lowq


text:
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE FlexibleContexts #-}
module DigitRecognition where

import Numeric.LinearAlgebra as LA
import Codec.Compression.GZip (decompress)
import qualified Data.ByteString.Lazy as BS
import Data.Functor
import qualified Foreign.Storable as ForeignStorable
import GHC.Float (float2Double)
--import System.Random

render :: Integral a => a -> Char
render n = let s = " .:oO@" in s !! (fromIntegral n * length s `div` 256)

--main :: IO ()
--main = do
--  s <- decompress <$> BS.readFile "train-images-idx3-ubyte.gz"
--  l <- decompress <$> BS.readFile "train-labels-idx1-ubyte.gz"
--  n <- (`mod` 60000) <$> randomIO
--  putStr . unlines $
--    [render . BS.index s . (n * 28 ^ 2 + 16 + r * 28 +) <$> [0 .. 27] | r <- [0..27]]
-- print $ BS.index l (n + 8)

clip :: Ord c => c -> c -> c -> c
clip a b = max a . min b

computeProbabilities :: Matrix R -> Matrix R -> R -> Matrix R
computeProbabilities x theta temp = cmap (\x -> if x < 1.0e-16 then 0 else x) p / divisor
    where
        c = (rows theta >< rows x) $ concat $ repeat $ map (maximum . toList) $ toColumns $ (theta LA.<> tr x) / scalar temp
        p = cmap exp $ (theta LA.<> tr x) / scalar temp - c
        divisor = (rows theta >< rows x) $ concat $ repeat $ map (sum . toList) $ toColumns p

contributors :: (ForeignStorable.Storable R, Fractional R) => Int -> Int -> Vector Int -> Matrix R
contributors n k y = (n >< k) $ contributor k y
    where
        contributor k = concatMap (contributor' k) . toList
        contributor' k v = l ++ [1.0] ++ r
            where
                (l, r) = splitAt v $ replicate (k - 1) 0.0

computeCostFunction :: Matrix R -> Vector Int -> Matrix R -> R -> R -> R
computeCostFunction x y theta lambda temp = loss (rows x) (rows theta) y + regularisation
    where
        logProbabilities = cmap log $ cmap (clip 1e-15 (1 - 1e-15)) (computeProbabilities x theta temp)
        regularisation = lambda / 2 * sumElements (cmap (** 2) theta)
        loss n k y' = -sumElements (tr (contributors n k y') * logProbabilities) / fromIntegral n

runGradientDescentIteration :: Matrix R -> Vector Int -> Matrix R -> R -> R -> R -> Matrix R
runGradientDescentIteration x y theta alpha lambda temp = theta - scale alpha grad
    where
        n = rows x
        k = rows theta
        m = tr $ contributors n k y
        probs = cmap (clip 1e-15 (1 - 1e-15)) (computeProbabilities x theta temp)
        grad = scale lambda theta - (m - probs) LA.<> x / (scalar temp * fromIntegral n)

augmentFeatures :: (Element R, Fractional R) => Matrix R -> Matrix R
augmentFeatures x = (rows x >< 1) (repeat 1.0) ||| x

softmaxRegression :: Matrix R -> Vector Int -> R -> R -> R -> Int -> Int -> (Matrix R, [R])
softmaxRegression x y temp alpha lambda k t = iterate step ((k >< cols x') $ repeat 0.0, []) !! t
    where
        x' = augmentFeatures x
        step (theta, cs) =
            (runGradientDescentIteration x' y theta alpha lambda temp, cs ++ [computeCostFunction x' y theta lambda temp])

getClassifification :: Matrix R -> Matrix R -> R -> [Int]
getClassifification x theta temp = map maxIndex $ toColumns probs
    where
        x' = augmentFeatures x
        probs = computeProbabilities x' theta temp

computeTestError :: Matrix R -> Vector Int -> Matrix R -> R -> R
computeTestError x y theta temp = 1 - sum (compare y assignedLabels) / fromIntegral (length assignedLabels)
    where
        assignedLabels = getClassifification x theta temp
        compare y z = zipWith (\x y -> if x == y then 1 else 0) (toList y) z

buildData :: (ForeignStorable.Storable Float, Num Float) => Int -> BS.ByteString -> Matrix R
buildData length ds = cmap float2Double $ (length >< (28 ^ 2)) $ map ((/ 256) . fromIntegral) $ BS.unpack $ BS.drop 16 ds

buildLabels :: (ForeignStorable.Storable Int, Num Int) => BS.ByteString -> Vector Int
buildLabels bs = fromList $ map fromIntegral $ BS.unpack $ BS.drop 8 bs

main :: IO ()
main = do

    tr <- decompress <$> BS.readFile "train-images-idx3-ubyte.gz"
    trl <- decompress <$> BS.readFile "train-labels-idx1-ubyte.gz"
    te <- decompress <$> BS.readFile "t10k-images-idx3-ubyte.gz"
    tel <- decompress <$> BS.readFile "t10k-labels-idx1-ubyte.gz"

    let trainData = buildData 60000 tr
    let trainLabels = buildLabels trl
    let testData = buildData 10000 te
    let testLabels = buildLabels tel
    let temp = 1
    let alpha = 0.3
    let lambda = 0.0001
    let k = 10
    let iter = 150
    let (theta, cs) = softmaxRegression trainData trainLabels temp alpha lambda k iter
--    print $ trainData ? [0]
--    print $ toList trainLabels !! 0
--    print $ (computeProbabilities' (augmentFeatures trainData) theta temp) ¿ [0]
--    let theta' = runGradientDescentIteration (augmentFeatures trainData) trainLabels theta alpha lambda temp
--    print $ computeCostFunction (augmentFeatures trainData) trainLabels theta lambda temp
--    print $ theta ¿ [0]
--    print $ getClassifification testData theta temp
    print $ computeTestError testData testLabels theta temp
    -- print $ take 5 $ toList trainLabels


text:
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE OverloadedStrings     #-}
{-|
Module      : Grenade.Layers.GlobalAvgPool
Description : Global Average Pooling
Maintainer  : Theo Charalambous
License     : BSD2
Stability   : experimental

The layer follows the implementation as introduced in the paper:
Min Lin, Qiang Chen, Shuicheng Yan. Network In Network
<https://arxiv.org/abs/1312.4400>
-}

module Grenade.Layers.GlobalAvgPool
  (
  -- * Layer definition
    GlobalAvgPool (..)
  )
where

import           Control.DeepSeq                (NFData (..))
import           Data.Serialize
import           Data.Singletons
import           GHC.Generics                   (Generic)
import           GHC.TypeLits

import qualified Numeric.LinearAlgebra.Static   as H

import           Grenade.Core
import           Grenade.Utils.LinearAlgebra

import           Grenade.Onnx

data GlobalAvgPool = GlobalAvgPool
  deriving (Generic, NFData, Show)

instance UpdateLayer GlobalAvgPool where
  type Gradient GlobalAvgPool = ()
  runUpdate _ _ _ = GlobalAvgPool
  reduceGradient _ = ()

instance RandomLayer GlobalAvgPool where
  createRandomWith _ _ = return GlobalAvgPool

instance Serialize GlobalAvgPool where
  put _ = return ()
  get   = return GlobalAvgPool

-- | Performing a global average pool on a 1d vector will take the average of the elements and
--   return a vector of size 1
instance (KnownNat i) => Layer GlobalAvgPool ('D1 i) ('D1 1) where
  type Tape GlobalAvgPool ('D1 i) ('D1 1) = S ('D1 i)

  runForwards _ x =
    let n   = fromIntegral $ natVal (Proxy :: Proxy i)
        avg = nsum x / n
        vec = listToVector [avg]
    in  (x, S1D vec)

  runBackwards = undefined

-- | Performing a global average pool on a 2d matrix will take the average of the elements
--   and return a matrix of size 1x1
instance (KnownNat i, KnownNat j) => Layer GlobalAvgPool ('D2 i j) ('D2 1 1) where
  type Tape GlobalAvgPool ('D2 i j) ('D2 1 1) = S ('D2 i j)

  runForwards _ x =
    let n   = fromIntegral $ natVal (Proxy :: Proxy i)
        m   = fromIntegral $ natVal (Proxy :: Proxy j)
        avg = nsum x / (n * m)
        mat = H.fromList [avg]
    in  (x, S2D mat)

  runBackwards = undefined

-- | Performing a global average pool on a 3d matrix with k channels will take the average of the elements
--   channel-wise and return a 3d matrix with k channels each of size 1x1
instance (KnownNat i, KnownNat j, KnownNat k) => Layer GlobalAvgPool ('D3 i j k) ('D3 1 1 k) where

  type Tape GlobalAvgPool ('D3 i j k) ('D3 1 1 k) = S ('D3 i j k)

  runForwards _ x =
    let n   = fromIntegral $ natVal (Proxy :: Proxy i)
        m   = fromIntegral $ natVal (Proxy :: Proxy j)
        cs  = splitChannels x
        ys  = map (\c -> nsum c / (n * m)) cs
        mat = H.fromList ys
    in  (x, S3D mat)

  runBackwards = undefined

instance OnnxOperator GlobalAvgPool where
  onnxOpTypeNames _ = ["GlobalAveragePool"]

instance OnnxLoadableActivation GlobalAvgPool where
  activationLayer = GlobalAvgPool

max_stars_repo_name: th-char/grenade

max_issues_repo_name: th-char/grenade

max_forks_repo_name: th-char/grenade


text:
-----------------------------------------------------------------------------
-- |
-- Module      :  DSP.Matrix.Matrix
-- Copyright   :  (c) Matthew Donadio 2003
-- License     :  GPL
--
-- Maintainer  :  m.p.donadio@ieee.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Basic matrix routines
--
-----------------------------------------------------------------------------

module Matrix.Matrix where

import Data.Array
import Data.Complex

-- | Matrix-matrix multiplication: A x B = C

mm_mult :: (Ix a, Integral a, Num b) => Array (a,a) b -- ^ A
	-> Array (a,a) b -- ^ B
	-> Array (a,a) b -- ^ C

mm_mult a b = if ac /= br
	      then error "mm_mult: inside dimensions inconsistent"
	      else array bnds [ ((i,j), mult i j) | (i,j) <- range bnds ]
    where mult i j = sum [ a!(i,k) * b!(k,j) | k <- [1..ac] ]
	  ((_,_),(ar,ac)) = bounds a
	  ((_,_),(br,bc)) = bounds b
	  bnds = ((1,1),(ar,bc))

-- | Matrix-vector multiplication: A x b = c

mv_mult :: (Ix a, Integral a, Num b) => Array (a,a) b -- ^ A
	-> Array a b -- ^ b
	-> Array a b -- ^ c

mv_mult a b = if ac /= br
	      then error "mv_mult: dimensions inconsistent"
	      else array bnds [ (i, mult i) | i <- range bnds ]
    where mult i = sum [ a!(i,k) * b!(k) | k <- [1..ac] ]
	  ((_,_),(ar,ac)) = bounds a
	  (_,br) = bounds b
	  bnds = (1,ar)

-- | Transpose of a matrix

m_trans :: (Ix a, Integral a, Num b) => Array (a,a) b -- ^ A
	-> Array (a,a) b -- ^ A^T

m_trans a = array bnds [ ((i,j), a!(j,i)) | (i,j) <- range bnds ]
    where (_,(m,n)) = bounds a
	  bnds = ((1,1),(n,m))

-- | Hermitian transpose (conjugate transpose) of a matrix

m_hermit :: (Ix a, Integral a, RealFloat b) => Array (a,a) (Complex b) -- ^ A
	 -> Array (a,a) (Complex b) -- ^ A^H

m_hermit a = array bnds [ ((i,j), conjugate (a!(j,i))) | (i,j) <- range bnds ]
    where (_,(m,n)) = bounds a
	  bnds = ((1,1),(n,m))

max_stars_repo_name: Fapfood/MES-LshapedDomain

max_issues_repo_name: Fapfood/MES-LshapedDomain

max_forks_repo_name: Fapfood/MES-LshapedDomain


text:
{-# OPTIONS_GHC -fwarn-unused-imports #-}

module Main(main) where

import Control.Monad
import Control.Monad.Par
import Control.Monad.Par.Internal (runParAsync)
import Control.Monad.Par.Stream as S
import Control.Monad.Par.OpenList
import Control.DeepSeq
import Control.Exception

-- import Data.Array.Unboxed as U
import Data.Array.CArray as C
import Data.Complex
import Data.Int
import Data.Word
import Data.List (intersperse)
import Data.List.Split (chunk)

import System.CPUTime
import System.CPUTime.Rdtsc
import GHC.Conc as Conc
import GHC.IO (unsafePerformIO, unsafeDupablePerformIO, unsafeInterleaveIO)
import Debug.Trace

--------------------------------------------------------------------------------
-- Main script

main = do

  -- Generate 20 million elements:
  let s = countupWin 1024 (20 * 1000 * 1000) :: Par (WStream Int)
  measureRate $ runParAsync s

  putStrLn$ "Done with 5 million elements."


text:
module Statistics.Information.Utils.Random where

import Data.Matrix
import Statistics.Information.Utils.List
import System.Random

splitN :: RandomGen g => Int -> g -> [g]
splitN 0 _ = []
splitN 1 g = [g]
splitN n g = let (g', g'') = split g in
  g' : splitN (n-1) g''

rands :: (RandomGen g, Random a) => g -> Int -> (a, a) -> [a]
rands g n (a, b) = take n $ randomRs (a, b) g

noisy :: RandomGen g => g -> Matrix Double -> Matrix Double
noisy g xs =
  let noise = [repeatN d (intens * r) | r <- rands g n (0.0, fromIntegral n)] in
    elementwise (+) xs (fromLists noise)
  where
    intens = 1e-10
    n = nrows xs
    d = ncols xs

max_stars_repo_name: eligottlieb/Shannon

max_issues_repo_name: eligottlieb/Shannon

max_forks_repo_name: eligottlieb/Shannon


text:
module World
where

import Galaxy
import ZipperGalaxy
import ZipperGalaxyUtils
import Civilization
import Statistics
import Utils
import System.Random
import Control.Monad.State
import Data.Maybe (mapMaybe)
import Data.List (foldl')
import qualified Data.Edison.Assoc.StandardMap as E
import Terrain
import Good

data World = World { galaxy  :: Galaxy Terrain
                   , time    :: GalaxyTime
                   , empires :: E.FM CivKey Empire
                   , player  :: Player
                   }

data GalaxyTime = GalaxyTime { year   :: Int
                             , day    :: Int
                             , hour   :: Int
                             , minute :: Int
                             }

data Relation a = Relation { relationship :: Int
                           , contracts :: [Contract a] }

data Contract a = Embargo a

data Player = Player {playername :: String }

testRandomWorld :: Galaxy Terrain -> Int -> Int -> Maybe World
testRandomWorld g v numciv =
  let r = mkStdGen v
  in evalState (createWorld g numciv) r

nullGalaxyTime = GalaxyTime 0 0 0 0

nullPlayer = Player ""

habitablePlanetsZ :: Galaxy Terrain -> [GalaxyZipper Terrain]
habitablePlanetsZ g = filter sustainsLifeZ (ZipperGalaxyUtils.allBodies g)

civnames :: [String]
civnames = ["humans",
            "aliens",
            "ant insect animals",
            "slimy aliens",
            "cosmic hive snakes"
           ]

colonyStartPopulation :: ResourceUnit
colonyStartPopulation = 100

createWorld :: Galaxy Terrain -> Int -> Rnd (Maybe World)
createWorld g numciv = do
  let ps = habitablePlanetsZ g
  if null ps
    then return Nothing
    else do
      ps' <- shuffle ps
      let cs = take numciv ps'
      if length cs < numciv
        then return Nothing
        else do
          let cols = map ((:[]) . stdColony "colony" colonyStartPopulation) (map zipperToNames cs)
          let empires = zipWith Empire civnames (map namedsToMap cols)
          let collocs = pairToLists civnames (repeat "colony")
          return $ Just $ World
               (foldl' (\g' (cl, pn) -> setColonyOnPlanet cl pn g')
                       g
                       (zip collocs (map planetname (mapMaybe satelliteInZipper cs))))
               nullGalaxyTime
               (namedsToMap empires)
               nullPlayer

max_stars_repo_name: anttisalonen/starrover

max_issues_repo_name: anttisalonen/starrover

max_forks_repo_name: anttisalonen/starrover