text:
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE QuasiQuotes           #-}
module Enecuum.Samples.Assets.Nodes.Client
  ( clientNode
  , ClientNode(..)
  , NodeConfig (..)
  , SendTo(..)
  , Protocol(..)
  ) where

import qualified Data.Aeson                               as J
import           Data.Aeson.Extra                         (noLensPrefix)
import           Data.Complex
import qualified Data.Map                                 as Map
import           Data.Set                                 (union, (\\))
import qualified Data.Set                                 as Set
import           Data.Text                                hiding (filter, map)
import           Enecuum.Config
import qualified Enecuum.Domain                           as D
import           Enecuum.Framework.Domain.Error
import qualified Enecuum.Framework.Lens                   as Lens
import qualified Enecuum.Language                         as L
import           Enecuum.Prelude                          hiding (unpack)
import           Enecuum.Samples.Assets.Blockchain.Keys
import qualified Enecuum.Samples.Assets.Blockchain.Wallet as A
import qualified Enecuum.Samples.Assets.Nodes.Address     as A
import qualified Enecuum.Samples.Assets.Nodes.Messages    as M
import qualified Enecuum.Samples.Blockchain.Domain        as D
import qualified Enecuum.Samples.Blockchain.Language      as L
import           System.Console.Haskeline
import           Text.Regex.Posix                         ((=~))

data ClientNode = ClientNode
    deriving (Show, Generic)

data instance NodeConfig ClientNode = ClientNodeConfig
    { _dummyOption :: Int
    }
    deriving (Show, Generic)

instance Node ClientNode where
    data NodeScenario ClientNode = CLI
        deriving (Show, Generic)
    getNodeScript CLI = clientNode'
    getNodeTag _ = ClientNode

instance ToJSON   ClientNode                where toJSON    = J.genericToJSON    nodeConfigJsonOptions
instance FromJSON ClientNode                where parseJSON = J.genericParseJSON nodeConfigJsonOptions
instance ToJSON   (NodeConfig ClientNode)   where toJSON    = J.genericToJSON    nodeConfigJsonOptions
instance FromJSON (NodeConfig ClientNode)   where parseJSON = J.genericParseJSON nodeConfigJsonOptions
instance ToJSON   (NodeScenario ClientNode) where toJSON    = J.genericToJSON    nodeConfigJsonOptions
instance FromJSON (NodeScenario ClientNode) where parseJSON = J.genericParseJSON nodeConfigJsonOptions

type TimeGap = Int

data CreateTransaction              = CreateTransaction CLITransaction D.Address deriving (Show, Eq, Ord, Read)
newtype GetLastKBlock               = GetLastKBlock D.Address deriving Read
data GetWalletBalance               = GetWalletBalance Int D.Address deriving Read
newtype GetLengthOfChain            = GetLengthOfChain D.Address deriving Read
newtype StartForeverChainGeneration = StartForeverChainGeneration D.Address deriving Read
data Ping                           = Ping Protocol D.Address deriving Read
newtype StopRequest                 = StopRequest D.Address deriving Read
data GetBlock                       = GetBlock D.StringHash D.Address deriving Read
data Protocol                       = UDP | TCP | RPC deriving (Show, Eq, Ord, Read)
data SendTo                         = SendTo Address D.PortNumber deriving Read
data Address                        = Address D.Host D.PortNumber deriving Read

data GenerateBlocksPacket           = GenerateBlocksPacket
    { blocks  :: D.BlockNumber
    , timeGap :: TimeGap
    , address :: D.Address
    }
    deriving (Show, Read)

data DumpToDB = DumpToDB
    { address :: D.Address
    }
    deriving (Show, Read)

data RestoreFromDB = RestoreFromDB
    { address :: D.Address
    }
    deriving (Show, Read)

data CLITransaction = CLITransaction
  { _owner    :: String
  , _receiver :: String
  , _amount   :: D.Amount
  , _currency :: D.Currency
  } deriving (Show, Eq, Ord, Read)

sendSuccessRequest :: forall a. (ToJSON a, Typeable a) => D.Address -> a -> L.NodeL Text
sendSuccessRequest address request = do
    res :: Either Text D.SuccessMsg <- L.makeRpcRequest address request
    pure . eitherToText $ res

startForeverChainGenerationHandler :: StartForeverChainGeneration -> L.NodeL Text
startForeverChainGenerationHandler (StartForeverChainGeneration address) = sendSuccessRequest address M.ForeverChainGeneration

generateBlocksPacketHandler :: GenerateBlocksPacket -> L.NodeL Text
generateBlocksPacketHandler (GenerateBlocksPacket i timeGap address) = sendSuccessRequest address $ M.NBlockPacketGeneration i timeGap

getLastKBlockHandler :: GetLastKBlock -> L.NodeL Text
getLastKBlockHandler (GetLastKBlock address) = do
    res :: Either Text D.KBlock <- L.makeRpcRequest address M.GetLastKBlock
    pure . eitherToText $ res

idToKey :: (L.FileSystem m, Monad m) => Int -> m (D.PublicKey, String)
idToKey n = do
    let walletsMap = Map.fromList $ fmap (\w -> (A._id (w :: A.CLIWallet), w))  A.hardcodedWalletsWithNames
    case Map.lookup n walletsMap of
        Nothing -> error $ "There is no wallet with id: " +| n |+ ""
        Just j  -> pure (A._publicKey (j :: A.CLIWallet), A._name (j :: A.CLIWallet))

getWalletBalance :: GetWalletBalance -> L.NodeL Text
getWalletBalance (GetWalletBalance walletId address) = do
    (pubKey, name) <- idToKey walletId
    res :: Either Text M.WalletBalanceMsg <- L.makeRpcRequest address (M.GetWalletBalance pubKey)
    let fun :: M.WalletBalanceMsg -> Text
        fun (M.WalletBalanceMsg _ balance) = "" +|| name ||+ " : " +|| balance ||+ ""
    pure $ eitherToText2 $ fmap fun res

transform :: (L.ERandom m, L.Logger m, L.FileSystem m, Monad m) => CLITransaction -> m D.Transaction
transform tx = do
    let walletsMap = Map.fromList $ fmap (\w -> (A._name (w :: A.CLIWallet), w))  A.hardcodedWalletsWithNames
    let ownerName  = _owner tx
    let receiverName = _receiver tx
    let mbOwner = Map.lookup ownerName walletsMap
    let mbReceiver = Map.lookup receiverName walletsMap

    let (ownerPub, ownerPriv) = case mbOwner of
                    Nothing -> error $ "There is no record for owner: " +|| ownerName ||+ "."
                    Just  j -> (pub, priv)
                                where pub = A._publicKey (j :: A.CLIWallet)
                                      priv = fromJust $ A._privateKey (j :: A.CLIWallet)
        receiverPub = case mbReceiver of
                        Nothing -> read receiverName :: D.PublicKey
                        Just j  -> A._publicKey (j :: A.CLIWallet)
    uuid <- L.nextUUID
    D.signTransaction ownerPub ownerPriv receiverPub (_amount tx) (_currency tx) uuid

createTransaction :: CreateTransaction -> L.NodeL Text
createTransaction (CreateTransaction tx address) = do
    transaction <- transform tx
    res :: Either Text D.SuccessMsg <- L.makeRpcRequest address (M.CreateTransaction transaction)
    pure . eitherToText $ res

dumpToDB :: DumpToDB -> L.NodeL Text
dumpToDB (DumpToDB address) = do
    res :: Either Text D.SuccessMsg <- L.makeRpcRequest address M.DumpToDB
    pure . eitherToText $ res

restoreFromDB :: RestoreFromDB -> L.NodeL Text
restoreFromDB (RestoreFromDB address) = do
    res :: Either Text D.SuccessMsg <- L.makeRpcRequest address M.RestoreFromDB
    pure . eitherToText $ res

getLengthOfChain :: GetLengthOfChain -> L.NodeL Text
getLengthOfChain (GetLengthOfChain address) = do
    mKBlock <- L.makeRpcRequest address M.GetLastKBlock
    pure $ case mKBlock of
        Right kBlock       -> "Length of chain is " <> show (D._number kBlock)
        Left  requestError -> requestError

ping :: Ping -> L.NodeL Text
ping (Ping TCP address) = do
    ok <- L.withConnection D.Tcp address $ \conn -> L.send conn D.Ping
    pure $ case ok of
        Just (Right _) -> "Tcp port is available."
        Just (Left  _) -> "Tcp disconnection."
        _              -> "Tcp port is not available."

ping (Ping RPC address) = do
    res :: Either Text D.Pong <- L.makeRpcRequest address D.Ping
    pure $ case res of Right _ -> "Rpc port is available."; Left _ -> "Rpc port is not available."

ping (Ping UDP _) = pure "This functionality is not supported."

stopRequest :: StopRequest -> L.NodeL Text
stopRequest (StopRequest address) = sendSuccessRequest address D.Stop

getBlock :: GetBlock -> L.NodeL Text
getBlock (GetBlock hash address) = do
    mblock <- L.makeRpcRequest address (M.GetGraphNode hash)
    pure $ case mblock of
        Right (D.KBlockContent block) -> "Key block is "  <> show block
        Right (D.MBlockContent block) -> "Microblock is " <> show block
        Left  requestError            -> "Error: "        <> requestError

createNodeId :: M.CreateNodeId -> L.NodeL Text
createNodeId (M.CreateNodeId password) = do
    createKeyPair NodeId $ User (Manual password)
    pure "Success"

createWallet :: M.CreateWallet -> L.NodeL Text
createWallet (M.CreateWallet password) = do
    createWallet' "default" $ User (Manual password)
    pure "Success"

createWalletWithAlias :: M.CreateWalletWithAlias -> L.NodeL Text
createWalletWithAlias (M.CreateWalletWithAlias alias (M.CreateWallet password)) = do
    createWallet' alias $ User (Manual password)
    pure "Success"

showMyWallets :: M.ShowMyWallets -> L.NodeL Text
showMyWallets _ = showWallets

-- TODO change it to console help
help :: Help -> L.NodeL Text
help Help = pure "TODO change it to console help"
{- Commands for client:
CreateNodeId  'Password'
CreateWallet  'Password'
ShowMyWallets
CreateWalletWithAlias "alias" (CreateWallet "Password")
-}

-- For CLI completion
completeWith :: [L.CLICommand] -> String -> [Completion]
completeWith possibles left = case filter (=~ left) possibles of
  []  -> []
  [x] -> [Completion x x False]
  xs  -> map (\str -> Completion left str False) xs

-- local activity
data Help = Help deriving (Show, Read)
data CmdLocal = CreateNodeId | CreateWallet | CreateWalletWithAlias | ShowMyWallets deriving (Show, Enum, Bounded)
cliCommandsLocal = fmap show localCmds
    where localCmds = [minBound..maxBound] :: [CmdLocal]

cliCommands = "Help" : cliCommandsLocal

clientNode :: L.NodeDefinitionL ()
clientNode = clientNode' (ClientNodeConfig 42)

clientNode' :: NodeConfig ClientNode -> L.NodeDefinitionL ()
clientNode' _ = do
    L.logInfo "Client started"
    L.setNodeTag "Client"
    stateVar <- L.newVarIO D.NodeActing

    L.stdF (completeWith cliCommands) $ do
        -- network
        L.stdHandler ping
        L.stdHandler stopRequest
        L.stdHandler $ L.stopNodeHandler' stateVar

        -- local activity
        L.stdHandler createNodeId
        L.stdHandler createWallet
        L.stdHandler createWalletWithAlias
        L.stdHandler showMyWallets
        L.stdHandler help

        -- interaction with graph node
        L.stdHandler createTransaction
        L.stdHandler getWalletBalance
        L.stdHandler dumpToDB
        L.stdHandler restoreFromDB
        -- interaction with graph node sync scenario
        L.stdHandler getLastKBlockHandler
        L.stdHandler getLengthOfChain
        L.stdHandler getBlock

        -- interaction with pow node
        L.stdHandler startForeverChainGenerationHandler

        --  GenerateBlocksPacket {blocks = 2, timeGap = 0, address = Address {_host = "127.0.0.1", _port = 6020}}
        L.stdHandler generateBlocksPacketHandler

    L.awaitNodeFinished' stateVar

max_stars_repo_name: rosenk/Node

max_issues_repo_name: rosenk/Node

max_forks_repo_name: rosenk/Node


text:
module Mnist where

  import Numeric.LinearAlgebra
  import System.Environment

  import Neural
  import Test
  import Mnist.Load

  main :: IO ()
  main = do
    mnist <- loadExamples
    learningRate <- (getArgs >>= (\args -> (return.read) $ head args))
    epoch <- (getArgs >>= (\args -> (return.read) $ args!!1))
    let dataSet = splitDataSet mnist
    runSuite epoch learningRate networkSetting dataSet

  -- one hidden layer with 300 nodes
  networkSetting = [10, 300]

ext: hs

max_stars_repo_name: ycjungSubhuman/hskmlp

max_issues_repo_name: ycjungSubhuman/hskmlp

max_forks_repo_name: ycjungSubhuman/hskmlp


text:
module NeuralNet.MatrixSpec (matrixSpec) where

import Test.Hspec
import Numeric.LinearAlgebra
import NeuralNet.Matrix

matrixSpec :: SpecWith ()
matrixSpec =
  describe "NeuralNet.Matrix" $ do
    describe "sumRows" $
      it "should work correctly" $
        let
          source = fromLists [[0, 1], [2, 3], [4, 5]]
          expected = fromLists [[1], [5], [9]]
        in
          sumRows source `shouldBe` expected

max_stars_repo_name: danielholmes/neural-net

max_issues_repo_name: danielholmes/neural-net

max_forks_repo_name: danielholmes/neural-net


text:
{-|
Module      : FileParsing
Description : Definition of Parsers for csv-files
Copyright   : (c) Julian Kopka Larsen, 2015
Stability   : experimental

Various Functions that provide parsing of CSV files.
-}
module FileParsing (
    parseToArray,
    parseToMatrix,
    parseToDouble,
    normalizeColumns,
    p2NormArray,
    p2NormList,
    matrix2Array
) where

import Text.Parsec
import Data.Array
import Data.Packed.Vector
import Numeric.LinearAlgebra
import Numeric.Statistics

-- Csv parser
csvFile = endBy line eol
line = sepBy cell (char ',')
cell = many (noneOf ",\n")
eol = char '\n'

-- | Parse a File to a list of lists of elements.
parseToStrings :: String -> [[String]]
parseToStrings input = case parse csvFile "(unknown)" input of
                        Left e -> []
                        Right c -> c

-- | Read a csv string to List of Lists of 'Double'
parseToDouble :: String -> [[Double]]
parseToDouble input = map (map read) . tail $ parseToStrings input

-- | Read a csv string into a 'Matrix' of 'Double'
parseToMatrix :: String -> Matrix Double
parseToMatrix = fromLists . parseToDouble

-- | Convert a 'Matrix Double' into an 'Array' of 'Vector Double'
matrix2Array :: Matrix Double -> Array Int (Vector Double)
matrix2Array m = listArray (1,n) r
                 where   r = toRows m
                         n = length r

-- | Parse a csv 'String' into an 'Array' of 'Vector Double'
parseToArray :: String -> Array Int (Vector Double)
parseToArray = matrix2Array . parseToMatrix

-- | Normalize (alt. Studetize) the Collumns in a 'Matrix'
normalizeColumns :: Matrix Double -> Matrix Double
normalizeColumns m = fromColumns $ map studentize (toColumns m)

-- | Parse a csv 'String' into a Normalized 'Array' of 'Vector Double'
p2NormArray :: String -> Array Int (Vector Double)
p2NormArray = matrix2Array . normalizeColumns . parseToMatrix

-- | Parse a csv 'String' into a Normalized 'List' of 'Vector Double'
p2NormList :: String -> [Vector Double]
p2NormList = toRows . normalizeColumns . parseToMatrix

max_stars_repo_name: juliankopkalarsen/FpStats

max_issues_repo_name: juliankopkalarsen/FpStats

max_forks_repo_name: juliankopkalarsen/FpStats


text:
module Julia where

import Data.Complex
import System.Random
import Data.List

-- JULIA MATH-----
-- A generalized Julia Function
superJulia :: (RealFloat a, Fractional a) =>  [Complex a] -- parameters
  -> Complex a -- starting point.
  -> Complex a
superJulia [c] z = c
superJulia (c:cs) z = c * z^(length cs) + superJulia cs z

-- Some functions that look cool.

{--
snowflake :: (RealFloat a, Fractional a) => a -> Complex a -> Complex a -> Complex a
    -> Complex a -> Complex a
    --}
snowflake p a b c z = (abs (a * (z ^ p))) * b + c

flake :: (RealFloat a, Fractional a) => Complex a -> Complex a
flake z = z^6 + (0.883 * (cis(pi/4)))

flake2 :: (RealFloat a, Fractional a) => Complex a -> Complex a
flake2 z = (0.91:+0.8) * z^3 + (mkPolar 0.8 1)

newton :: (Floating a, Fractional a) => a -> a -> a
newton n z = (1 + (n - 1) * z**n) / (n * (z**(n-1)))

glynn :: (RealFloat a, Fractional a) => Complex a -> Complex a
glynn z = z**1.5 - 0.2

julia7 :: (RealFloat a, Fractional a) => Complex a -> Complex a
julia7 z = z^3 + 0.400

dragon :: (RealFloat a, Fractional a) =>  Complex a -> Complex a
dragon z = z^2 + ((-0.835) :+ 0.2321)

sshaped :: (RealFloat a, Fractional a) =>  Complex a -> Complex a
sshaped z = z^2 + (0.32:+0.043)

pierced :: (RealFloat a, Fractional a) =>  Complex a -> Complex a
pierced z = z^2 + ((-0.74543):+0.11301)

liquidSpirals :: (RealFloat a, Fractional a) =>  Complex a -> Complex a
liquidSpirals z = z^2 + ((-0.1):+0.651)

julia1 :: (RealFloat a, Fractional a) => Complex a -> Complex a
julia1 z = z^2 + ((-0.156844471694257101941):+(-0.649707745759247905171))

julia2 :: (RealFloat a, Fractional a) => Complex a -> Complex a
julia2 z = z^2 + ((-0.4):+0.6)

julia3 :: (RealFloat a, Fractional a) => Complex a -> Complex a
julia3 z = 1 - (z^2) + (z^5) / (2 + 4 * z) + (0.4:+0.6)

julia4 :: (RealFloat a, Fractional a) => Complex a -> Complex a
julia4 z = z^2 + ((-0.742):+0.1)

impossible :: (RealFloat a, Fractional a) => Complex a -> Complex a
impossible z = (sinh(z^2)**0.5) + (0.065:+0.122)

impossible2 :: (RealFloat a, Fractional a) => Complex a -> Complex a
impossible2 z = ((z^2+z)/log(z))+(0.268:+0.060)

superPattern :: (RealFloat a, Fractional a) =>  Complex a -> Complex a
superPattern z = (exp (z^3)) - 0.59

max_stars_repo_name: Vetii/Fractal

max_issues_repo_name: Vetii/Fractal

max_forks_repo_name: Vetii/Fractal


text:
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-|
Module      : Grenade.Layers.Logit
Description : Exponential linear unit layer
Copyright   : (c) Huw Campbell, 2016-2017
License     : BSD2
Stability   : experimental
-}
module Grenade.Layers.Elu
  ( Elu(..)
  , SpecElu (..)
  , specElu1D
  , specElu2D
  , specElu3D
  , elu
  ) where

import           Control.DeepSeq                (NFData)
import           Data.Constraint                (Dict (..))
import           Data.Reflection                (reifyNat)
import           Data.Serialize
import           Data.Singletons
import           GHC.Generics                   (Generic)
import           GHC.TypeLits
import qualified Numeric.LinearAlgebra.Static   as LAS
import           Unsafe.Coerce                  (unsafeCoerce)

import           Grenade.Core
import           Grenade.Dynamic
import           Grenade.Dynamic.Internal.Build

-- | An exponential linear unit.
--   A layer which can act between any shape of the same dimension, acting as a
--   diode on every neuron individually.
data Elu = Elu
  deriving (Generic, NFData, Show)

instance UpdateLayer Elu where
  type Gradient Elu = ()
  runUpdate _ _ _ = Elu

instance RandomLayer Elu where
  createRandomWith _ _ = return Elu

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

instance ( KnownNat i) => Layer Elu ('D1 i) ('D1 i) where
  type Tape Elu ('D1 i) ('D1 i) = LAS.R i

  runForwards _ (S1D y) = (y, S1D (elu y))
    where
      elu = LAS.dvmap (\a -> if a <= 0 then exp a - 1 else a)
  runBackwards _ y (S1D dEdy) = ((), S1D (elu' y * dEdy))
    where
      elu' = LAS.dvmap (\a -> if a <= 0 then exp a else 1)

instance (KnownNat i, KnownNat j) => Layer Elu ('D2 i j) ('D2 i j) where
  type Tape Elu ('D2 i j) ('D2 i j) = S ('D2 i j)

  runForwards _ (S2D y) = (S2D y, S2D (elu y))
    where
      elu = LAS.dmmap (\a -> if a <= 0 then exp a - 1 else a)
  runBackwards _ (S2D y) (S2D dEdy) = ((), S2D (elu' y * dEdy))
    where
      elu' = LAS.dmmap (\a -> if a <= 0 then exp a else 1)

instance (KnownNat i, KnownNat j, KnownNat k) => Layer Elu ('D3 i j k) ('D3 i j k) where

  type Tape Elu ('D3 i j k) ('D3 i j k) = S ('D3 i j k)

  runForwards _ (S3D y) = (S3D y, S3D (elu y))
    where
      elu = LAS.dmmap (\a -> if a <= 0 then exp a - 1 else a)
  runBackwards _ (S3D y) (S3D dEdy) = ((), S3D (elu' y * dEdy))
    where
      elu' = LAS.dmmap (\a -> if a <= 0 then exp a else 1)

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

instance FromDynamicLayer Elu where
  fromDynamicLayer inp _ _ = SpecNetLayer $ SpecElu (tripleFromSomeShape inp)

instance ToDynamicLayer SpecElu where
  toDynamicLayer _ _ (SpecElu (rows, cols, depth)) =
     reifyNat rows $ \(_ :: (KnownNat rows) => Proxy rows) ->
     reifyNat cols $ \(_ :: (KnownNat cols) => Proxy cols) ->
     reifyNat depth $ \(_ :: (KnownNat depth) => Proxy depth) ->
     case (rows, cols, depth) of
         (_, 1, 1)    -> return $ SpecLayer Elu (sing :: Sing ('D1 rows)) (sing :: Sing ('D1 rows))
         (_, _, 1) -> return $ SpecLayer Elu (sing :: Sing ('D2 rows cols)) (sing :: Sing ('D2 rows cols))
         _    -> case (unsafeCoerce (Dict :: Dict()) :: Dict (KnownNat (rows GHC.TypeLits.* depth))) of
           Dict -> return $ SpecLayer Elu (sing :: Sing ('D3 rows cols depth)) (sing :: Sing ('D3 rows cols depth))

-- | Create a specification for a elu layer.
specElu1D :: Integer -> SpecNet
specElu1D i = specElu3D (i, 1, 1)

-- | Create a specification for a elu layer.
specElu2D :: (Integer, Integer) -> SpecNet
specElu2D (i,j) = specElu3D (i,j,1)

-- | Create a specification for a elu layer.
specElu3D :: (Integer, Integer, Integer) -> SpecNet
specElu3D = SpecNetLayer . SpecElu

-- | Add a Elu layer to your build.
elu :: BuildM ()
elu = buildGetLastLayerOut >>= buildAddSpec . SpecNetLayer . SpecElu

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

instance GNum Elu where
  _ |* Elu = Elu
  _ |+ Elu = Elu

max_stars_repo_name: schnecki/grenade

max_issues_repo_name: schnecki/grenade

max_forks_repo_name: schnecki/grenade


text:
{-# LANGUAGE BangPatterns #-}
module Polestar.Core.Eval where
import Polestar.Core.Type
import Polestar.Core.TypeCheck
import Data.Complex
import GHC.Float (expm1, log1p)

termSubstD :: Int -> Term -> Int -> Term -> Term
termSubstD !depth s !i t = case t of
  TmAbs name ty body -> TmAbs name (typeShift (-1) i ty) (termSubstD (depth + 1) s (i + 1) body)
  TmRef j | j == i -> termShift depth 0 s
          | j > i -> TmRef (j - 1)
          | otherwise -> t
  TmApp u v -> TmApp (termSubstD depth s i u) (termSubstD depth s i v)
  TmLet name def body -> TmLet name (termSubstD depth s i def) (termSubstD (depth + 1) s (i + 1) body)
  TmTypedLet name ty def body -> TmTypedLet name ty (termSubstD depth s i def) (termSubstD (depth + 1) s (i + 1) body)
  TmIf cond then_ else_ -> TmIf (termSubstD depth s i cond) (termSubstD depth s i then_) (termSubstD depth s i else_)
  TmPrim _ -> t
  TmTuple components -> TmTuple $ termSubstD depth s i <$> components
  TmProj tuple j -> TmProj (termSubstD depth s i tuple) j
  TmIterate n init succ -> TmIterate (termSubstD depth s i n) (termSubstD depth s i init) (termSubstD depth s i succ)

-- replaces occurrences of TRef j (j > i) with TRef (j-1), and TRef i with the given term
termSubst = termSubstD 0

natFromValue :: Term -> Either String Integer
natFromValue (TmPrim (PVNat x)) = return x
natFromValue x = Left ("type error (expected a natural number, but got " ++ show x ++ ")")

intFromValue :: Term -> Either String Integer
intFromValue (TmPrim (PVInt x)) = return x
intFromValue x = Left ("type error (expected an integer, but got " ++ show x ++ ")")

realFromValue :: Term -> Either String Double
realFromValue (TmPrim (PVReal x)) = return x
realFromValue x = Left ("type error (expected a real number, but got " ++ show x ++ ")")

boolFromValue :: Term -> Either String Bool
boolFromValue (TmPrim (PVBool x)) = return x
boolFromValue x = Left ("type error (expected a boolean, but got " ++ show x ++ ")")

applyBuiltinUnary :: UnaryFn -> Term -> Either String Term
applyBuiltinUnary f v = case f of
  UNegateInt -> (TmPrim . PVInt) <$> intFromValue v
  UNegateReal -> (TmPrim . PVReal) <$> realFromValue v
  UNatToInt -> (TmPrim . PVInt) <$> natFromValue v
  UIntToReal -> (TmPrim . PVReal . fromInteger) <$> intFromValue v
  UIntToNat -> (TmPrim . PVNat . max 0) <$> intFromValue v

applyBuiltinBinary :: BinaryFn -> Term -> Term -> Either String Term
applyBuiltinBinary f u v = case f of
  UAddNat -> (TmPrim . PVNat) <$> ((+) <$> natFromValue u <*> natFromValue v)
  UMulNat -> (TmPrim . PVNat) <$> ((*) <$> natFromValue u <*> natFromValue v)
  UTSubNat -> (TmPrim . PVNat . max 0) <$> ((-) <$> natFromValue u <*> natFromValue v)
  UPowNatNat -> (TmPrim . PVNat) <$> ((^) <$> natFromValue u <*> natFromValue v)
  UEqualNat -> (TmPrim . PVBool) <$> ((==) <$> natFromValue u <*> natFromValue v)
  ULessThanNat -> (TmPrim . PVBool) <$> ((<) <$> natFromValue u <*> natFromValue v)
  ULessEqualNat -> (TmPrim . PVBool) <$> ((<=) <$> natFromValue u <*> natFromValue v)
  UAddInt -> (TmPrim . PVInt) <$> ((+) <$> intFromValue u <*> intFromValue v)
  USubInt -> (TmPrim . PVInt) <$> ((-) <$> intFromValue u <*> intFromValue v)
  UMulInt -> (TmPrim . PVInt) <$> ((*) <$> intFromValue u <*> intFromValue v)
  UPowIntNat -> (TmPrim . PVInt) <$> ((^) <$> intFromValue u <*> natFromValue v)
  UEqualInt -> (TmPrim . PVBool) <$> ((==) <$> intFromValue u <*> intFromValue v)
  ULessThanInt -> (TmPrim . PVBool) <$> ((<) <$> intFromValue u <*> intFromValue v)
  ULessEqualInt -> (TmPrim . PVBool) <$> ((<=) <$> intFromValue u <*> intFromValue v)
  UAddReal -> (TmPrim . PVReal) <$> ((+) <$> realFromValue u <*> realFromValue v)
  USubReal -> (TmPrim . PVReal) <$> ((-) <$> realFromValue u <*> realFromValue v)
  UMulReal -> (TmPrim . PVReal) <$> ((*) <$> realFromValue u <*> realFromValue v)
  UDivReal -> (TmPrim . PVReal) <$> ((/) <$> realFromValue u <*> realFromValue v)
  UPowRealReal -> (TmPrim . PVReal) <$> ((**) <$> realFromValue u <*> realFromValue v)
  UEqualReal -> (TmPrim . PVBool) <$> ((==) <$> realFromValue u <*> realFromValue v)
  ULessThanReal -> (TmPrim . PVBool) <$> ((<) <$> realFromValue u <*> realFromValue v)
  ULessEqualReal -> (TmPrim . PVBool) <$> ((<=) <$> realFromValue u <*> realFromValue v)

data ValueBinding = ValueBind !Term
                  | TypeBind
                  deriving (Eq,Show)

getValueFromContext :: [ValueBinding] -> Int -> Term
getValueFromContext ctx i
  | i < length ctx = case ctx !! i of
                       ValueBind x -> x
                       b -> error ("TRef: expected a variable binding, found " ++ show b)
  | otherwise = error "TRef: index out of bounds"

eval1 :: [ValueBinding] -> Term -> Either String Term
eval1 ctx t = case t of
  TmPrim _ -> return t
  TmAbs _ _ _ -> return t
  TmRef i -> return $ getValueFromContext ctx i
  TmApp u v
    | isValue u && isValue v -> case u of
        TmAbs _name _ty body -> return $ termSubst v 0 body -- no type checking here
        TmPrim (PVUnary f) -> applyBuiltinUnary f v
        TmPrim (PVBinary _) -> return t -- partial application
        TmApp (TmPrim (PVBinary f)) u' -> applyBuiltinBinary f u' v
        _ -> Left "invalid function application (expected function type)"
    | isValue u -> TmApp u <$> (eval1 ctx v)
    | otherwise -> TmApp <$> (eval1 ctx u) <*> pure v
  TmLet name def body
    | isValue def -> return $ termSubst def 0 body
    | otherwise -> TmLet name <$> eval1 ctx def <*> pure body
  TmTypedLet name ty def body
    | isValue def -> return $ termSubst def 0 body
    | otherwise -> TmTypedLet name ty <$> eval1 ctx def <*> pure body
  TmIf cond then_ else_
    | isValue cond -> case cond of
        TmPrim (PVBool True) -> return then_  -- no type checking here
        TmPrim (PVBool False) -> return else_ -- no type checking here
        _ -> Left "if-then-else: condition must be boolean"
    | otherwise -> TmIf <$> (eval1 ctx cond) <*> pure then_ <*> pure else_
  TmTuple components -> case span isValue components of
    (_,[]) -> return t
    (v,w:ws) -> eval1 ctx w >>= \w' -> return (TmTuple (v ++ (w':ws)))
  TmProj tuple j
    | isValue tuple -> case tuple of
        TmTuple components | length components > j -> return $ components !! j
                           | otherwise -> Left "tuple too short"
        _ -> Left "projection: not a tuple"
    | otherwise -> TmProj <$> eval1 ctx tuple <*> pure j
  TmIterate n init succ
    | isValue n && isValue init && isValue succ -> do
        n' <- natFromValue n
        if n' == 0
          then return $ init
          else return $ TmIterate (TmPrim (PVNat (n' - 1))) (TmApp succ init) succ
    | isValue n && isValue init -> TmIterate n init <$> eval1 ctx succ
    | isValue n -> TmIterate n <$> eval1 ctx init <*> pure succ
    | otherwise -> TmIterate <$> eval1 ctx n <*> pure init <*> pure succ

eval :: [ValueBinding] -> Term -> Either String Term
eval ctx t | isValue t = return t
           | otherwise = eval1 ctx t >>= eval ctx

max_stars_repo_name: minoki/polestar

max_issues_repo_name: minoki/polestar

max_forks_repo_name: minoki/polestar


text:
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ForeignFunctionInterface #-}

module Foreign.CUDA.Magma.TH where
import Control.Applicative
import Control.Arrow
import Control.Monad ((>=>), join, void)

import GHC.Exts (groupWith)

import Language.Haskell.TH as TH
import Language.C
import Language.C.System.GCC

import Data.List (isInfixOf, isPrefixOf, isSuffixOf)
import Data.Char (toLower, toUpper)
import Data.Maybe (mapMaybe)

import Debug.Trace
import qualified Foreign.C.Types as C
import qualified Foreign.C.String as C (castCharToCChar, castCCharToChar)
import qualified Foreign as F
import Foreign.Storable.Complex ()
import Data.Complex (Complex(..))

import Data.Either (partitionEithers)
import Data.Maybe (isJust)

import System.FilePath.Posix ((</>))

import qualified Text.Parsec as P

import Foreign.CUDA as FC
import qualified Foreign.CUDA.Runtime.Stream as FC

import Foreign.CUDA.Magma.Types

try :: [(Bool, a)] -> a
try ((p,y):conds) = if p then y else try conds
try [] = error "TH.try: No match!"

data TypeInfo = TI
  { ctype    :: Q Type
  , hsinput  :: Either Convert Create
  , hsoutput :: Maybe (Either Convert Destroy) }

data TypeDat = TD
  { ct    :: Q Type
  , hst   :: Q Type
  , c2hs  :: (Q Exp, ExpType)
  , hs2c  :: (Q Exp, ExpType) }

data ExpType = Pure | Monadic

data TypeC = VoidC | IntC | CharC | FloatC | DoubleC | EnumC String
           | ComplexC TypeC | ArbStructC String | PtrC TypeC | HPtrC TypeC | PhonyC TH.Name
           | ArrC TypeC
           deriving (Eq, Show)

prim :: Q Type -> Q Type -> Q Exp -> Q Exp -> TypeDat
prim ct hst c2hs hs2c = TD ct hst (c2hs, Pure) (hs2c, Pure)

simple :: Q Type -> TypeDat
simple t = prim t t [| id |] [| id |]

bothc :: (a -> b) -> Complex a -> Complex b
bothc f (a :+ b) = f a :+ f b

typeDat :: TypeC -> TypeDat
typeDat (PhonyC n)  = simple (varT n)
typeDat VoidC       = simple [t| () |]
typeDat (PtrC t)    = prim [t| F.Ptr $(ctype) |] [t| FC.DevicePtr $(ctype) |] [| FC.DevicePtr |]       [| FC.useDevicePtr |] where
  ctype = ct (typeDat t)
typeDat (HPtrC t)    = simple [t| F.Ptr $(ctype) |] where ctype = ct (typeDat t)
typeDat (ArrC t)    = typeDat (PtrC t)
typeDat IntC        = prim [t| C.CInt |]    [t| Int |]    [| fromIntegral |]          [| fromIntegral |]
typeDat CharC       = prim [t| C.CChar |]    [t| Char |]   [| C.castCCharToChar |]       [| C.castCharToCChar |]
typeDat FloatC      = simple [t| C.CFloat |]
typeDat DoubleC     = simple [t| C.CDouble |]
typeDat (EnumC str) = prim [t| C.CInt |] x [| toEnum . fromIntegral |] [| fromIntegral . fromEnum |] where
  x = case str of
     "magma_uplo_t" -> [t| UpLoT |]
     "magma_trans_t" -> [t| TransT |]
     "magma_vec_t" -> [t| VecT |]
     _ -> error ("typeDat.EnumC : Missing type: " ++ str)
typeDat (ArbStructC str) = error "typeDat.ArbstructC"
typeDat (ComplexC t) = prim
  [t| Complex $(ctype) |]
  [t| Complex $(hstype) |]
  [| bothc $(fromC) |]
  [| bothc $(toC) |]
  where
  TD ctype hstype (fromC, Pure) (toC, Pure) = typeDat t

convertT x y = Left (Convert x y)
createT = Right . Create
destroyT = Right . Destroy

data Convert = Convert (Q Type) (Q Exp)
newtype Create = Create (Q Exp)
newtype Destroy = Destroy (Q Exp)

pointerify :: Q Type -> Q Type
pointerify x = [t| F.Ptr $(x) |]

useT :: TypeC -> TypeInfo
useT = useT' . typeDat where
  useT' (TD ct hst c2hs (hs2c,purity)) = TI
    ct
    (convertT hst exp)
    Nothing
    where
    exp = case purity of Pure -> [| return . $(hs2c) |]; Monadic -> hs2c

inT :: TypeC -> TypeInfo
inT (PtrC t) = inT' (typeDat t) where
  inT' (TD ct hst c2hs (hs2c,purity)) = TI
    (pointerify ct)
    (convertT hst exp)
    (Just (destroyT [| F.free |]))
    where
    exp = case purity of Pure -> [| F.new . $(hs2c) |] ; Monadic -> undefined
inT (ArrC t) = inT' (typeDat t) where
  inT' (TD ct hst c2hs (hs2c,purity)) = TI
    (pointerify ct)
    (convertT [t| [ $(hst) ] |] exp)
    (Just (destroyT [| F.free |]))
    where
    exp = case purity of Pure -> [| F.newArray . map $(hs2c) |] ; Monadic -> undefined

outT :: TypeC -> TypeInfo
outT (PtrC t) = outT' (typeDat t) where
  outT' (TD ct hst (c2hs,purity) hs2c) = TI
    ct
    (createT [| F.malloc |])
    (Just (convertT hst [| \p -> do { x <- F.peek p ; F.free p; $(exp) x } |]))
    where
    exp = case purity of Pure -> [| return . $(c2hs) |] ; Monadic -> c2hs

inOutT :: TypeC -> TypeInfo
inOutT (PtrC t) = inOutT' (typeDat t) where
  inOutT' (TD ct hst (c2hs,purity1) (hs2c,purity2)) = TI
    (pointerify ct)
    (convertT hst exp1)
    (Just (convertT hst [| \p -> do { x <- F.peek p ; F.free p; $(exp2) x } |]))
    where
    exp1 = case purity1 of Pure -> [| F.new . $(hs2c) |] ; Monadic -> hs2c
    exp2 = case purity2 of Pure -> [| return . $(c2hs) |] ; Monadic -> c2hs

convert :: CTypeSpecifier a -> TypeC
convert (CVoidType _) = VoidC
convert (CCharType _) = CharC
--CCharType a
--CShortType a
convert (CIntType _) = IntC
--CLongType a
convert (CFloatType _) = FloatC
convert (CDoubleType _) = DoubleC
--CSignedType a
--CUnsigType a
--CBoolType a
--CComplexType a
convert (CTypeDef ident _) = try
  [ (s=="magma_int_t", IntC)
  , (s=="magmaFloatComplex", ComplexC FloatC)
  , (s=="magmaDoubleComplex", ComplexC DoubleC)
  , (True, EnumC s) ]
  where
  s = identToString ident
convert _ = VoidC

convert' :: [CDeclarationSpecifier a] -> TypeC
convert' (CTypeSpec x:_) = convert x
convert' (_:xs) = convert' xs
convert' [] = error "convert': invalid CDeclarationSpecifier list"

typeOf :: (TypeC -> Q Type) -> CDeclaration a -> Q Type
typeOf proj (CDecl basetype [(Just (CDeclr (Just ident) ptrs _ _ _), _, _)] _) =
  foldr f (proj $ convert' basetype) ptrs
  where
  f (CPtrDeclr _ _) b = [t| F.Ptr $(b) |]
  f _ _ = error "haven't implemented other things"

pointerification :: CDeclaration a -> (TypeC -> TypeC)
pointerification (CDecl _ [(Just (CDeclr _ ptrs _ _ _), _, _)] _) = foldr (.) id $ map f ptrs where
  f (CPtrDeclr _ _) = PtrC
  f (CArrDeclr _ _ _) = ArrC
  f _ = id --possible there are other things that should be here?

baseType :: CDeclaration a -> TypeC
baseType (CDecl basetype _ _) = convert' basetype

cType :: CDeclaration a -> TypeC
cType d = (pointerification d) (baseType d)

typeInfo :: String -> CVar -> TypeInfo
typeInfo fn (n, typec) = ($ typec) $ try
  [ (case typec of ArrC _ -> True; _ -> False
      , inT)
  , (n `elem` []
      , inT)
  , (n == "info"
      , outT)
  , (n == "ipiv"
      , const (case typec of PtrC t -> useT (HPtrC t)))
    {- End -}
  , (True
      , useT)
  ]

declName :: CDeclaration a -> Maybe String
declName (CDecl _ [(Just (CDeclr (Just ident) _ _ _ _), _, _)] _) = Just (identToString ident)
declName _ = Nothing

outMarshall :: TypeC -> (Q Exp, Q Type -> Q Type)
outMarshall VoidC = ([| return . snd |], id)
outMarshall x = let hstype = hst $ typeDat x in
  ([| return |], \typ -> [t| ( $(hstype), $(typ) ) |])

createf' :: (String, CFunction) -> Q [Dec]
createf' (foreignname, cf@(fname, rettype, args)) = do
  ins <- mapM (safeName "_in") args
  toCs <- mapM (safeName "_out") args
  (outstatements, (outtypes, outs)) <- second (unzip . filterMaybes) . unzip <$> collect (zip3 args argsTI toCs)
  let instatements = map inMarsh (zip3 argsTI ins toCs)
  ret <- newName "res"
  let runstatement = bindS (varP ret) (foldl f z toCs)
  let returnstatement = [| $(checkStatusExp) ( $(outputConv) $(varE ret), $(tupE (map varE outs)) ) |]
  expr <- doE $ concat [instatements, runstatement:outstatements, [noBindS returnstatement]]
  let usedins = map snd . filter (isused . fst) $ zip argsTI ins
  let fdec = FunD fcall [Clause (map VarP usedins) (NormalB expr) []]
  tdec <- sigD fcall $ funTypeMod checkStatusType argsTI
  return [tdec, fdec]
  where
  safeName :: String -> CVar -> Q TH.Name
  safeName end (s:str, _) = newName (toLower s : str ++ end)

  argsTI = functionTypeInfo cf
  (outputConv, _) = c2hs (typeDat rettype)
  (checkStatusExp, checkStatusType) = outMarshall rettype
  isused (TI _ (Left _) _) = True
  isused _ = False
  fcall = mkName fname
  z = varE (mkName foreignname)
  f x e = appE x (varE e)
  inMarsh (ti,e,e') = case hsinput ti of
    Left (Convert t a) -> bindS (varP e') (appE a (varE e))
    Right (Create a)   -> bindS (varP e') a
  collect ( (arg, TI _ _ (Just cleanup), e) : xs) = do
    e' <- safeName "_out" arg
    let outinfo = case cleanup of
          Left (Convert t a) -> (bindS (varP e') (appE a (varE e)), Just (t, e'))
          Right (Destroy a) ->  (noBindS (appE a (varE e)), Nothing)
    ys <- collect xs
    return (outinfo:ys)
  collect (_:xs) = collect xs
  collect [] = return []
  collecti (TI _ (Left (Convert t _)) _) =
    [t]
  collecti _ = []

magmaFile :: FilePath
magmaFile = MAGMA_INCLUDE_DIR </> "magma.h"

filterMaybes :: [Maybe a] -> [a]
filterMaybes [] = []
filterMaybes (Just x:xs) = x : filterMaybes xs
filterMaybes (Nothing:xs) = filterMaybes xs

funname :: CDeclaration a -> String
funname (CDecl _ [(Just (CDeclr (Just ident ) _ _ _ _), _, _)] _) = identToString ident
funname _ = error "Weird!"

infol :: Show a =>  CDerivedDeclarator a -> Maybe [[String]]
infol (CFunDeclr (Right (ys,_)) _ _) = Just $ map f ys where
  f (CDecl specs _ _) = map show specs
infol _ = Nothing

funArgs :: CDeclarator a -> Maybe [CDeclaration a]
funArgs (CDeclr _ [(CFunDeclr (Right (ys,_)) _ _)] _ _ _) = Just ys
funArgs _ = Nothing

funDecl :: CDeclaration a -> Maybe (CDeclarator a)
funDecl (CDecl _ [(Just declarator, _, _)] _) = Just declarator
funDecl _ = Nothing

maybeFunction :: CDeclaration a -> Maybe (CFunction)
maybeFunction d@(CDecl returnType _ _) = do
  args <- funArgs =<< funDecl d
  retName <- declName d
  argNames <- mapM declName args
  let argTypes = map cType args
  return (retName, convert' returnType, zip argNames argTypes )

maybeExternalDec :: CExternalDeclaration a -> Maybe (CDeclaration a)
maybeExternalDec (CDeclExt d) = Just d
maybeExternalDec _ = Nothing

type CVar = (String, TypeC)
type CFunction = ( String , TypeC , [CVar] )

getFunctions :: FilePath -> IO [CFunction]
getFunctions fp = do
  Right (CTranslUnit xs _) <- parseCFile (newGCC "/usr/bin/gcc") Nothing ["-DHAVE_CUBLAS", "-I" ++ CUDA_INCLUDE_DIR] fp
  return $ mapMaybe (maybeExternalDec >=> maybeFunction) xs

createf :: FilePath -> CFunction -> Q Dec
createf fp (name, ret, args) =
  forImpD cCall safe{-unsafe-} (fp ++ ' ':name) (mkName name) cFunType
  where
  cFunType = foldr f z (map (ct . typeDat . snd) args)
  z = [t| IO $(ct . typeDat $ ret) |]
  f x y = [t| $(x) -> $(y) |]

parse' :: P.Parsec String () a -> String -> Maybe a
parse' p = \str -> case P.parse p "Unknown error" str of
  Right x -> Just x
  Left e -> Nothing

-- ["Magma", [("potrf_gpu", [("spotrf_gpu", spotrf_gpu )])]
sharedDecs :: String -> [CFunction] -> [(String, [Char], [(String, [(String, CFunction)])])]
sharedDecs prefix@(p:ps) xs = [(prefix' ++ "1", "sd", floatDouble), (prefix', "sdcz", all4)] where
  prefix' = toUpper p : ps
  g x@(s,ret,args) = do
    newname <- goodName prefix s
    return (s, (newname, ret, args))
  xs' = mapMaybe g xs
  fst3 (s,_,_) = s
  (floatDouble, all4) = partitionEithers .
    mapMaybe sdFilter . groupWith (tail . fst3 . snd) $ xs'
  sdFilter xs@((_, (newname, _, _)) : _)
    | length xs == 4 = Just $ Right (newname, xs)
    | length xs == 2 = Just $ Left (newname, xs)
    | otherwise      = Nothing

mkClass :: String -> [CFunction] -> Q Dec
mkClass classname xs = classD (return []) className [PlainTV typeName] [] decs where
  className = mkName classname
  typeName = mkName "a"
  decs = map (f . phonifyF) xs
  mkPhony :: TypeC -> TypeC
  mkPhony (PtrC t) = PtrC (mkPhony t)
  mkPhony (ArrC t) = ArrC (mkPhony t)
  mkPhony x = let t' = PhonyC typeName in
    case x of DoubleC -> t'; FloatC -> t'; ComplexC _ -> t'; y -> y
  phonifyF :: CFunction -> CFunction
  phonifyF cf@(name, ret, args) = (name, mkPhony ret, map (second mkPhony) args)
  f cfunc@(name, ret, _) =
     let (_, retTytrans) = outMarshall ret
         funtype = funTypeMod retTytrans (functionTypeInfo cfunc)
     in sigD (mkName (tail name)) funtype

mkClassInstances :: String -> [Char] -> [(String, [(String,CFunction)])] -> [Q Dec]
mkClassInstances classname instances xs = map (\c -> makeInstance c $ map (f c) xs) instances where
  makeInstance c decs = instanceD (return []) classSig (decs) where
    classSig = appT (return . ConT $ mkName classname) (ct . typeDat $ typeMap c)
  f c (_, funcs) = (!! 1) <$> createf' (foreignn, (name, ret, args)) where
    [(foreignn,((_:name), ret, args))] = filter (\(_,((s:_),_,_))-> s==c) funcs

typeMap :: Char -> TypeC
typeMap 'c' = ComplexC FloatC
typeMap 'z' = ComplexC DoubleC
typeMap 'd' = DoubleC
typeMap 's' = FloatC
typeMap _ = error "typeMap: Invalid character"

makeClassDecs :: String -> FilePath -> IO (Q [Dec])
makeClassDecs str fp = do
  sds <- sharedDecs str <$> getFunctions fp
  return . sequence $ concat
   [ mkClass classname (map (snd . head . snd) funcs) : mkClassInstances classname instances funcs
     | (classname, instances, funcs) <- sds ]

makeFFIDecs :: String -> FilePath -> IO (Q [Dec])
makeFFIDecs str fp = sequence . map (createf fp) . filter (desired str) <$> getFunctions fp

makeAllFuncs :: String -> FilePath -> IO (Q [Dec])
makeAllFuncs str fp = fmap concat . sequence . mapMaybe (fmap createf' . alter) . filter (desired str) <$> getFunctions fp where
  alter (fname, rettype, args) = do
    newname <- goodName str fname
    return (fname, (newname, rettype, args))

goodName :: String -> String -> Maybe String
goodName prefix = parse' $ do
    P.string prefix
    P.char '_'
    char <- P.oneOf "sdcz"
    res <- P.choice $ map (P.try . P.string)
      ["gelqf", "gels3", {-"geqp3",-} "geqrf", "geqrs", "gesv", "getrf", "getrs", "potrf"
      , "potrs", "sposv", "syevd" ]
    P.string "_gpu"
    return (char : res)

desired :: String -> CFunction -> Bool
desired prefix = \(name, _, _) -> isJust $ goodName prefix name

doIO :: IO (Q [a]) -> Q [a]
doIO = join . runIO

inTypes :: [TypeInfo] -> [Q Type]
inTypes = mapMaybe f where
  f (TI _ (Left (Convert t _)) _) = Just t
  f _ = Nothing

outTypes :: [TypeInfo] -> [Q Type]
outTypes = mapMaybe f where
  f (TI _ _ (Just (Left (Convert t _)))) = Just t
  f _ = Nothing

functionTypeInfo :: CFunction -> [TypeInfo]
functionTypeInfo (fname, ret, args) = map (typeInfo fname) args

funTypeMod :: (Q Type -> Q Type) -> [TypeInfo] -> Q Type
funTypeMod f args = foldr arrow z ins where
  arrow x y = [t| $(x) -> $(y) |]
  z = [t| IO $( f $ foldl appT (tupleT (length outs)) outs) |]
  [ins, outs] = map ($ args) [inTypes, outTypes]

funType :: [TypeInfo] -> Q Type
funType = funTypeMod id

max_stars_repo_name: bmsherman/magma-gpu

max_issues_repo_name: bmsherman/magma-gpu

max_forks_repo_name: bmsherman/magma-gpu


text:
module Autoencoder where

import AI.HNN.FF.Network (Network)
import Numeric.LinearAlgebra.HMatrix (Vector, Matrix)
import System.Exit
import qualified AI.HNN.FF.Network as Network
import qualified Data.Vector
import qualified Numeric.LinearAlgebra.HMatrix as Vector

newtype Encoder = Encoder (Matrix Double)
  deriving (Show, Read, Eq)

newtype Decoder = Decoder (Matrix Double)
  deriving (Show, Read, Eq)

type LayerCount = Int
type EpochCount = Int
type Autoencoder = (Encoder, Decoder)

generateAutoencoderIO :: [Vector Double] -> LayerCount -> EpochCount -> IO Autoencoder
generateAutoencoderIO v l e = do
  net <- Network.createNetwork (Vector.size $ head v) [l] (Vector.size $ head v)
  let Network.Network x = Network.trainNTimes e 0.8 Network.tanh Network.tanh' net (zipWith (,) v v)
  case Data.Vector.toList x of
    [enc, dec] -> return (Encoder enc, Decoder dec)
    _ -> error "colossal failure"

encode :: Encoder -> Vector Double -> Vector Double
encode (Encoder m) v = Vector.app m $ Vector.vjoin [v, 1]

decode :: Decoder -> Vector Double -> Vector Double
decode (Decoder m) v = Vector.app m $ Vector.vjoin [v, 1]

max_stars_repo_name: intolerable/project-utilities

max_issues_repo_name: intolerable/project-utilities

max_forks_repo_name: intolerable/project-utilities


text:
{-|
Module      : PRNG
Description : Class definitions of PRNG api

Copyright   : Thodoris Papakonstantinou, 2017
License     : GPL-3
Maintainer  : mail@tpapak.com
Stability   : experimental
Portability : POSIX

Deterministic (Pure) Pseudo Random Number Generator Class definitions.
 -}

module Data.PRNG
    ( Seed
    , RNG (..)
    , randomBools
    , randomInts
    , randomPermutation
    , sample
    , normalSample
    , truncatedNormalSample
    ) where

import Data.Maybe
import Data.List
import qualified Data.Vector as V
import qualified Data.Set as S
import qualified Data.IntMap as IM
import Data.Number.Erf
import qualified Numeric.SpecFunctions as NS

type Seed = Int
class RNG r where
  getRNG :: Seed -> r
  randomDouble :: r -> (Double, r)
  randomInt :: r -> (Int, r)
  uniformSample :: r -> Int -> [Double]

-- | booleans given the length of the list the probability p and the seed
randomBools :: RNG r => r -> Int -> Double -> [Bool]
randomBools r l p        =
  let rndbls 0 _         = []
      rndbls n g         = b:(rndbls (n-1) g')
        where (d,g')     = randomDouble g
              b          = d > p
  in rndbls l r

-- | booleans given the length of the list the probability p and the seed
randomInts :: RNG r => r -> Int -> [Int]
randomInts r l         =
  let rnds 0 _         = []
      rnds n g         = i:(rnds (n-1) g')
        where (i,g')   = randomInt g
  in rnds l r

-- | Permutates list using a RNG, given that the list has fewer elements than
-- the minimum between  2^64 which is the precision of Double and the period of the prng,the position probability of every element is uniform.
randomPermutation :: RNG r => r -> [a] -> [a]
randomPermutation r ls =
  let randoms = zip (uniformSample r (length ls)) ls
   in map snd $ sortOn fst randoms

-- | Sample from list
sample :: RNG r => r -> Int -> [a] -> [a]
sample r k c
  | k < 0  || k > length c = []
  | otherwise = take k $ randomPermutation r c

-- | List of doubles from nornal distribution given
-- RNG -> μ -> σ -> length of list
normalSample :: RNG r => r -> Double -> Double -> Int -> [Double]
normalSample r μ σ n
  | σ == 0 = replicate n μ
  | otherwise =
    let uds = uniformSample r n
        invx x = σ * x + μ
     in map (invx . invnormcdf) uds

-- | Sample truncated nomral μ -> σ -> left bound -> right bound -> length of list
truncatedNormalSample :: RNG r => r -> Double -> Double -> Double -> Double -> Int -> [Double]
truncatedNormalSample r μ σ f t n
  | (μ < f) || (μ > t) = []
  | σ == 0 = replicate n μ
  | otherwise =
    let uds = uniformSample r n
        sqt = sqrt 2
        invtruncnormcdf y = μ - sqt * σ * inverf (
          - ((-1) + y) * erf((-f + μ)/(sqt * σ)) +
          y * erf((μ - t)/(sqt * σ))
          )
     in map invtruncnormcdf uds

-- | List of doubles from the binomial distribution given
-- RNG -> n -> p -> length of list
binomialSample :: RNG r => r -> Int -> Double -> Int -> [Int]
binomialSample r n p l =
  let uds = uniformSample r l
      invbinomcdf a n p = let sumpr i = foldl (\ac i -> ac + (binomialProb i n p)) 0 [1..i]
                              binomialProb i n p = n `NS.choose` i * p^^i * (1-p)^^(n-i)
                              firstBigger x a
                                | sumpr (x-1) > a = x
                                | x > n = n
                                | otherwise = firstBigger (x+1) a
                              in firstBigger 1 a
 in map (\a -> invbinomcdf a n p) uds

max_stars_repo_name: tosku/prng

max_issues_repo_name: tosku/prng

max_forks_repo_name: tosku/prng


text:
{-# LANGUAGE BangPatterns     #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Strict           #-}
{-# LANGUAGE StrictData       #-}
module FourierPinwheel.Harmonics where

import           Data.Array.IArray   as IA
import           Data.Array.Repa     as R
import           Data.Complex
import           Data.List
import           Data.List           as L
import           Data.Vector.Generic as VG
import           Data.Vector.Unboxed as VU
import           Filter.Utils
import           Math.Gamma
import           Utils.Parallel

data FPData vector = FPData
  { getFPDataHarmonics       :: [vector]
  , getFPDataHarmonicsOffset :: [vector]
  , getFPDataCoef            :: [vector]
  , getFPDataCoefHollow      :: [vector]
  }

createHarmonics ::
     ( RealFloat e
     , Unbox e
     , NFData e
     , VG.Vector vector (Complex e)
     , NFData (vector (Complex e))
     , Gamma (Complex e)
     )
  => Int
  -> Int
  -> Int
  -> Int
  -> Int
  -> e
  -> e
  -> e
  -> R.Array U DIM4 (Complex e)
  -> IO (FPData (vector (Complex e)))
createHarmonics numR2Freqs phiFreq rhoFreq thetaFreq rFreq alpha periodR2 periodEnv coefficients = do
  let harmonicVecs =
        parMap
          rdeepseq
          (\radialFreq ->
             createVector
               numR2Freqs
               (2 * phiFreq + 1)
               1
               (pinwheel periodR2 radialConst alpha radialFreq))
          [-rhoFreq .. rhoFreq]
      harmonicVecsOffset =
        parMap
          rdeepseq
          (\radialFreq ->
             createVector
               numR2Freqs
               (2 * thetaFreq + 1)
               (-1)
               (logpolarHarmonics periodR2 radialConst radialFreq)) .
        L.reverse $
        [-rFreq .. rFreq]
  phaseShiftedCoefArr <-
    computeUnboxedP .
    R.zipWith (*) coefficients . fromFunction (extent coefficients) $ \(Z :. r :. theta :. rho :. phi) ->
      phaseShift
        (phi - phiFreq - (theta - thetaFreq))
        (rho - rhoFreq - (r - rFreq))
        radialConst
        alpha
  let phaseShiftedCoefVecs =
        parMap
          rdeepseq
          (\r ->
             VU.convert . toUnboxed . computeS . R.slice phaseShiftedCoefArr $
             (Z :. r :. All :. All :. All))
          [0 .. 2 * rFreq]
  coefHollowArr <- computeUnboxedP $ sumArr *^ coefficients
  let coefHollowVecs =
        parMap
          rdeepseq
          (\r ->
             VU.convert . toUnboxed . computeS . R.slice coefHollowArr $
             (Z :. r :. All :. All :. All))
          [0 .. 2 * rFreq]
  return $
    FPData harmonicVecs harmonicVecsOffset phaseShiftedCoefVecs coefHollowVecs
  where
    radialConst = 2 * pi / log periodEnv
    !sumArr1 =
      computePinwheelArray
        numR2Freqs
        phiFreq
        rhoFreq
        thetaFreq
        rFreq
        alpha
        periodR2
        periodEnv
    sumArr =
      fromListUnboxed (extent coefficients) .
      parMap
        rdeepseq
        (\(r, theta, rho, phi) ->
           let angularFreq = phi - theta
               radialFreq = rho - r
            in sumArr1 IA.! (radialFreq, angularFreq)) $
      [ (r, theta, rho, phi)
      | r <- [-rFreq .. rFreq]
      , theta <- [-thetaFreq .. thetaFreq]
      , rho <- [-rhoFreq .. rhoFreq]
      , phi <- [-phiFreq .. phiFreq]
      ]

{-# INLINE createVector #-}
createVector ::
     (RealFloat e, Unbox e, VG.Vector vector (Complex e))
  => Int
  -> Int
  -> Int
  -> (Int -> e -> e -> Complex e)
  -> vector (Complex e)
createVector numR2Freqs numAngularFreqs sign f =
  let centerR2 = div numR2Freqs 2
      centerAngular = div numAngularFreqs 2
   in VG.convert .
      toUnboxed .
      computeS .
      makeFilter2D .
      fromFunction (Z :. numAngularFreqs :. numR2Freqs :. numR2Freqs) $ \(Z :. k :. i :. j) ->
        let x = fromIntegral (i - centerR2)
            y = fromIntegral (j - centerR2)
            rho = sqrt $ x ^ 2 + y ^ 2
            phi = atan2 y x
         in if rho == 0
              then 0
              else f (sign * (k - centerAngular)) phi rho

{-# INLINE pinwheel #-}
pinwheel :: (RealFloat e) => e -> e -> e -> Int -> Int -> e -> e -> Complex e
pinwheel periodR2 radialConst alpha radialFreq angularFreq phi rho =
  pi * cis (fromIntegral angularFreq * phi) *
  ((periodR2 / (pi * rho) :+ 0) **
   ((2 + alpha) :+ (radialConst * fromIntegral radialFreq)))

{-# INLINE logpolarHarmonics #-}
logpolarHarmonics ::
     (RealFloat e) => e -> e -> Int -> Int -> e -> e -> Complex e
logpolarHarmonics periodR2 radialConst radialFreq angularFreq phi rho =
  cis (fromIntegral angularFreq * phi) *
  ((periodR2 / (pi * rho) :+ 0) **
   (0 :+ (radialConst * fromIntegral radialFreq)))

{-# INLINE phaseShift #-}
phaseShift ::
     (RealFloat e, Gamma (Complex e)) => Int -> Int -> e -> e -> Complex e
phaseShift angularFreq radialFreq radialConst alpha =
  ((0 :+ (-1)) ^ abs angularFreq) *
  (gamma $
   ((2 + fromIntegral (abs angularFreq) + alpha) :+
    (radialConst * fromIntegral radialFreq)) /
   2) /
  (gamma $
   ((fromIntegral (abs angularFreq) - alpha) :+
    (radialConst * fromIntegral (-radialFreq))) /
   2)

{-# INLINE computeIndicesFromRadius #-}
computeIndicesFromRadius :: Double -> [(Int,Int)]
computeIndicesFromRadius radius =
  let rho = round radius
      r2 = rho ^ 2
   in L.filter
        (\(x, y) ->
           let r = fromIntegral $ x ^ 2 + y ^ 2
            in r < r2)
        [(x, y) | x <- [-rho .. rho], y <- [-rho .. rho]]

{-# INLINE computePinwheelArray #-}
computePinwheelArray ::
     ( Num e
     , RealFloat e
     , Gamma (Complex e)
     , Unbox e
     , NFData e
     )
  => Int
  -> Int
  -> Int
  -> Int
  -> Int
  -> e
  -> e
  -> e
  -> IA.Array (Int, Int) (Complex e)
computePinwheelArray numR2Freqs phiFreq rhoFreq thetaFreq rFreq alpha periodR2 periodEnv =
  let maxAngularFreq = phiFreq + thetaFreq
      maxRadialFreq = rhoFreq + rFreq
      radialConst = 2 * pi / log periodEnv
      centerR2 = div numR2Freqs 2
      idxs =
        [ (radialFreq, angularFreq)
        | radialFreq <- [-maxRadialFreq .. maxRadialFreq]
        , angularFreq <- [-maxAngularFreq .. maxAngularFreq]
        ]
      pinwheels =
        parMap
          rdeepseq
          (\(radialFreq, angularFreq) ->
             let arr =
                   fromFunction (Z :. numR2Freqs :. numR2Freqs) $ \(Z :. i :. j) ->
                     let x = fromIntegral $ i - centerR2
                         y = fromIntegral $ j - centerR2
                         rho = sqrt $ x ^ 2 + y ^ 2
                         phi = atan2 y x
                      in if rho == 0
                           then 0
                           else pinwheel
                                  periodR2
                                  radialConst
                                  alpha
                                  radialFreq
                                  angularFreq
                                  phi
                                  rho *
                                phaseShift
                                  angularFreq
                                  radialFreq
                                  radialConst
                                  alpha
              in sumAllS arr / (fromIntegral numR2Freqs^2))
          idxs
   in listArray
        ((-maxRadialFreq, -maxAngularFreq), (maxRadialFreq, maxAngularFreq))
        pinwheels

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:
{-# LANGUAGE CPP #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, GADTs, RecordWildCards #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}

-- |
-- Module      : Criterion.Types
-- Copyright   : (c) 2009-2014 Bryan O'Sullivan
--
-- License     : BSD-style
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : GHC
--
-- Types for benchmarking.
--
-- The core type is 'Benchmarkable', which admits both pure functions
-- and 'IO' actions.
--
-- For a pure function of type @a -> b@, the benchmarking harness
-- calls this function repeatedly, each time with a different 'Int64'
-- argument (the number of times to run the function in a loop), and
-- reduces the result the function returns to weak head normal form.
--
-- For an action of type @IO a@, the benchmarking harness calls the
-- action repeatedly, but does not reduce the result.

module Criterion.Types
    (
    -- * Configuration
      Config(..)
    , Verbosity(..)
    -- * Benchmark descriptions
    , Benchmarkable(..)
    , Benchmark(..)
    -- * Measurements
    , Measured(..)
    , fromInt
    , toInt
    , fromDouble
    , toDouble
    , measureAccessors
    , measureKeys
    , measure
    , rescale
    -- * Benchmark construction
    , env
    , envWithCleanup
    , perBatchEnv
    , perBatchEnvWithCleanup
    , perRunEnv
    , perRunEnvWithCleanup
    , toBenchmarkable
    , bench
    , bgroup
    , addPrefix
    , benchNames
    -- ** Evaluation control
    , nf
    , whnf
    , nfIO
    , whnfIO
    -- * Result types
    , Outliers(..)
    , OutlierEffect(..)
    , OutlierVariance(..)
    , Regression(..)
    , KDE(..)
    , Report(..)
    , SampleAnalysis(..)
    , DataRecord(..)
    ) where

import Control.DeepSeq (NFData(rnf))
import Criterion.Measurement.Types
import Data.Aeson (FromJSON(..), ToJSON(..))
import Data.Binary (Binary(..), putWord8, getWord8)
import Data.Data (Data, Typeable)
import Data.Int (Int64)
import Data.Map (Map)
import GHC.Generics (Generic)
import Prelude ()
import Prelude.Compat
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as U
import qualified Statistics.Types as St
import           Statistics.Resampling.Bootstrap ()

-- | Control the amount of information displayed.
data Verbosity = Quiet
               | Normal
               | Verbose
                 deriving (Eq, Ord, Bounded, Enum, Read, Show, Typeable, Data,
                           Generic)

-- | Top-level benchmarking configuration.
data Config = Config {
      confInterval :: St.CL Double
      -- ^ Confidence interval for bootstrap estimation (greater than
      -- 0, less than 1).
    , timeLimit    :: Double
      -- ^ Number of seconds to run a single benchmark.  (In practice,
      -- execution time will very slightly exceed this limit.)
    , resamples    :: Int
      -- ^ Number of resamples to perform when bootstrapping.
    , regressions  :: [([String], String)]
      -- ^ Regressions to perform.
    , rawDataFile  :: Maybe FilePath
      -- ^ File to write binary measurement and analysis data to.  If
      -- not specified, this will be a temporary file.
    , reportFile   :: Maybe FilePath
      -- ^ File to write report output to, with template expanded.
    , csvFile      :: Maybe FilePath
      -- ^ File to write CSV summary to.
    , jsonFile     :: Maybe FilePath
      -- ^ File to write JSON-formatted results to.
    , junitFile    :: Maybe FilePath
      -- ^ File to write JUnit-compatible XML results to.
    , verbosity    :: Verbosity
      -- ^ Verbosity level to use when running and analysing
      -- benchmarks.
    , template     :: FilePath
      -- ^ Template file to use if writing a report.
    } deriving (Eq, Read, Show, Typeable, Data, Generic)

-- | Outliers from sample data, calculated using the boxplot
-- technique.
data Outliers = Outliers {
      samplesSeen :: !Int64
    , lowSevere   :: !Int64
    -- ^ More than 3 times the interquartile range (IQR) below the
    -- first quartile.
    , lowMild     :: !Int64
    -- ^ Between 1.5 and 3 times the IQR below the first quartile.
    , highMild    :: !Int64
    -- ^ Between 1.5 and 3 times the IQR above the third quartile.
    , highSevere  :: !Int64
    -- ^ More than 3 times the IQR above the third quartile.
    } deriving (Eq, Read, Show, Typeable, Data, Generic)

instance FromJSON Outliers
instance ToJSON Outliers

instance Binary Outliers where
    put (Outliers v w x y z) = put v >> put w >> put x >> put y >> put z
    get = Outliers <$> get <*> get <*> get <*> get <*> get
instance NFData Outliers

-- | A description of the extent to which outliers in the sample data
-- affect the sample mean and standard deviation.
data OutlierEffect = Unaffected -- ^ Less than 1% effect.
                   | Slight     -- ^ Between 1% and 10%.
                   | Moderate   -- ^ Between 10% and 50%.
                   | Severe     -- ^ Above 50% (i.e. measurements
                                -- are useless).
                     deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)

instance FromJSON OutlierEffect
instance ToJSON OutlierEffect

instance Binary OutlierEffect where
    put Unaffected = putWord8 0
    put Slight     = putWord8 1
    put Moderate   = putWord8 2
    put Severe     = putWord8 3
    get = do
        i <- getWord8
        case i of
            0 -> return Unaffected
            1 -> return Slight
            2 -> return Moderate
            3 -> return Severe
            _ -> fail $ "get for OutlierEffect: unexpected " ++ show i
instance NFData OutlierEffect

instance Semigroup Outliers where
    (<>) = addOutliers

instance Monoid Outliers where
    mempty  = Outliers 0 0 0 0 0
#if !(MIN_VERSION_base(4,11,0))
    mappend = addOutliers
#endif

addOutliers :: Outliers -> Outliers -> Outliers
addOutliers (Outliers s a b c d) (Outliers t w x y z) =
    Outliers (s+t) (a+w) (b+x) (c+y) (d+z)
{-# INLINE addOutliers #-}

-- | Analysis of the extent to which outliers in a sample affect its
-- standard deviation (and to some extent, its mean).
data OutlierVariance = OutlierVariance {
      ovEffect   :: OutlierEffect
    -- ^ Qualitative description of effect.
    , ovDesc     :: String
    -- ^ Brief textual description of effect.
    , ovFraction :: Double
    -- ^ Quantitative description of effect (a fraction between 0 and 1).
    } deriving (Eq, Read, Show, Typeable, Data, Generic)

instance FromJSON OutlierVariance
instance ToJSON OutlierVariance

instance Binary OutlierVariance where
    put (OutlierVariance x y z) = put x >> put y >> put z
    get = OutlierVariance <$> get <*> get <*> get

instance NFData OutlierVariance where
    rnf OutlierVariance{..} = rnf ovEffect `seq` rnf ovDesc `seq` rnf ovFraction

-- | Results of a linear regression.
data Regression = Regression {
    regResponder  :: String
    -- ^ Name of the responding variable.
  , regCoeffs     :: Map String (St.Estimate St.ConfInt Double)
    -- ^ Map from name to value of predictor coefficients.
  , regRSquare    :: St.Estimate St.ConfInt Double
    -- ^ R² goodness-of-fit estimate.
  } deriving (Eq, Read, Show, Typeable, Generic)

instance FromJSON Regression
instance ToJSON Regression

instance Binary Regression where
    put Regression{..} =
      put regResponder >> put regCoeffs >> put regRSquare
    get = Regression <$> get <*> get <*> get

instance NFData Regression where
    rnf Regression{..} =
      rnf regResponder `seq` rnf regCoeffs `seq` rnf regRSquare

-- | Result of a bootstrap analysis of a non-parametric sample.
data SampleAnalysis = SampleAnalysis {
      anRegress    :: [Regression]
      -- ^ Estimates calculated via linear regression.
    , anMean       :: St.Estimate St.ConfInt Double
      -- ^ Estimated mean.
    , anStdDev     :: St.Estimate St.ConfInt Double
      -- ^ Estimated standard deviation.
    , anOutlierVar :: OutlierVariance
      -- ^ Description of the effects of outliers on the estimated
      -- variance.
    } deriving (Eq, Read, Show, Typeable, Generic)

instance FromJSON SampleAnalysis
instance ToJSON SampleAnalysis

instance Binary SampleAnalysis where
    put SampleAnalysis{..} = do
      put anRegress; put anMean; put anStdDev; put anOutlierVar
    get = SampleAnalysis <$> get <*> get <*> get <*> get

instance NFData SampleAnalysis where
    rnf SampleAnalysis{..} =
        rnf anRegress `seq` rnf anMean `seq`
        rnf anStdDev `seq` rnf anOutlierVar

-- | Data for a KDE chart of performance.
data KDE = KDE {
      kdeType   :: String
    , kdeValues :: U.Vector Double
    , kdePDF    :: U.Vector Double
    } deriving (Eq, Read, Show, Typeable, Data, Generic)

instance FromJSON KDE
instance ToJSON KDE

instance Binary KDE where
    put KDE{..} = put kdeType >> put kdeValues >> put kdePDF
    get = KDE <$> get <*> get <*> get

instance NFData KDE where
    rnf KDE{..} = rnf kdeType `seq` rnf kdeValues `seq` rnf kdePDF

-- | Report of a sample analysis.
data Report = Report {
      reportNumber   :: Int
      -- ^ A simple index indicating that this is the /n/th report.
    , reportName     :: String
      -- ^ The name of this report.
    , reportKeys     :: [String]
      -- ^ See 'measureKeys'.
    , reportMeasured :: V.Vector Measured
      -- ^ Raw measurements.
    , reportAnalysis :: SampleAnalysis
      -- ^ Report analysis.
    , reportOutliers :: Outliers
      -- ^ Analysis of outliers.
    , reportKDEs     :: [KDE]
      -- ^ Data for a KDE of times.
    } deriving (Eq, Read, Show, Typeable, Generic)

instance FromJSON Report
instance ToJSON Report

instance Binary Report where
    put Report{..} =
      put reportNumber >> put reportName >> put reportKeys >>
      put reportMeasured >> put reportAnalysis >> put reportOutliers >>
      put reportKDEs

    get = Report <$> get <*> get <*> get <*> get <*> get <*> get <*> get

instance NFData Report where
    rnf Report{..} =
      rnf reportNumber `seq` rnf reportName `seq` rnf reportKeys `seq`
      rnf reportMeasured `seq` rnf reportAnalysis `seq` rnf reportOutliers `seq`
      rnf reportKDEs

data DataRecord = Measurement Int String (V.Vector Measured)
                | Analysed Report
                deriving (Eq, Read, Show, Typeable, Generic)

instance Binary DataRecord where
  put (Measurement i n v) = putWord8 0 >> put i >> put n >> put v
  put (Analysed r)        = putWord8 1 >> put r

  get = do
    w <- getWord8
    case w of
      0 -> Measurement <$> get <*> get <*> get
      1 -> Analysed    <$> get
      _ -> error ("bad tag " ++ show w)

instance NFData DataRecord where
  rnf (Measurement i n v) = rnf i `seq` rnf n `seq` rnf v
  rnf (Analysed r)        = rnf r

instance FromJSON DataRecord
instance ToJSON DataRecord

max_stars_repo_name: rubenpieters/criterion

max_issues_repo_name: rubenpieters/criterion

max_forks_repo_name: rubenpieters/criterion


text:
{-# LANGUAGE BangPatterns, RecordWildCards #-}
-- |
-- Module      : Criterion
-- Copyright   : (c) 2009-2014 Bryan O'Sullivan
--
-- License     : BSD-style
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : GHC
--
-- Core benchmarking code.

module Criterion.Internal
    (
      runAndAnalyse
    , runAndAnalyseOne
    , runNotAnalyse
    , addPrefix
    ) where

import Control.DeepSeq (rnf)
import Control.Exception (evaluate)
import Control.Monad (foldM, forM_, void, when)
import Control.Monad.Reader (ask, asks)
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Either
import Data.Binary (encode)
import Data.Int (Int64)
import qualified Data.ByteString.Lazy as L
import Criterion.Analysis (analyseSample, noteOutliers)
import Criterion.IO (header, hGetReports)
import Criterion.IO.Printf (note, printError, prolix, writeCsv)
import Criterion.Measurement (runBenchmark, secs)
import Criterion.Monad (Criterion)
import Criterion.Report (report)
import Criterion.Types hiding (measure)
import Criterion.Versus (vscsv, versusReports, VersusReport(..))
import qualified Data.Map as Map
import Statistics.Resampling.Bootstrap (Estimate(..))
import System.Directory (getTemporaryDirectory, removeFile)
import System.IO (IOMode(..), SeekMode(..), hClose, hSeek, openBinaryFile,
                  openBinaryTempFile)
import Text.Printf (printf)

-- | Run a single benchmark and analyse its performance.
runAndAnalyseOne :: Int -> String -> Benchmarkable -> Criterion Report
runAndAnalyseOne i desc bm = do
  Config{..} <- ask
  (meas,timeTaken) <- liftIO $ runBenchmark bm timeLimit
  when (timeTaken > timeLimit * 1.25) .
    void $ prolix "measurement took %s\n" (secs timeTaken)
  _ <- prolix "analysing with %d resamples\n" resamples
  erp <- runEitherT $ analyseSample i desc meas
  case erp of
    Left err -> printError "*** Error: %s\n" err
    Right rpt@Report{..} -> do
      let SampleAnalysis{..} = reportAnalysis
          OutlierVariance{..} = anOutlierVar
          wibble = case ovEffect of
                     Unaffected -> "unaffected" :: String
                     Slight -> "slightly inflated"
                     Moderate -> "moderately inflated"
                     Severe -> "severely inflated"
          (builtin, others) = splitAt 1 anRegress
      let r2 n = printf "%.3f R\178" n
      forM_ builtin $ \Regression{..} ->
        case Map.lookup "iters" regCoeffs of
          Nothing -> return ()
          Just t  -> bs secs "time" t >> bs r2 "" regRSquare
      bs secs "mean" anMean
      bs secs "std dev" anStdDev
      forM_ others $ \Regression{..} -> do
        _ <- bs r2 (regResponder ++ ":") regRSquare
        forM_ (Map.toList regCoeffs) $ \(prd,val) ->
          bs (printf "%.3g") ("  " ++ prd) val
      writeCsv csvFile (desc,
                        estPoint anMean, estLowerBound anMean, estUpperBound anMean,
                        estPoint anStdDev, estLowerBound anStdDev,
                        estUpperBound anStdDev)
      when (verbosity == Verbose || (ovEffect > Slight && verbosity > Quiet)) $ do
        when (verbosity == Verbose) $ noteOutliers reportOutliers
        _ <- note "variance introduced by outliers: %d%% (%s)\n"
             (round (ovFraction * 100) :: Int) wibble
        return ()
      _ <- note "\n"
      return rpt
      where bs :: (Double -> String) -> String -> Estimate -> Criterion ()
            bs f metric Estimate{..} =
              note "%-20s %-10s (%s .. %s%s)\n" metric
                   (f estPoint) (f estLowerBound) (f estUpperBound)
                   (if estConfidenceLevel == 0.95 then ""
                    else printf ", ci %.3f" estConfidenceLevel)

-- | Run, and analyse, one or more benchmarks.
runAndAnalyse :: (String -> Bool) -- ^ A predicate that chooses
                                  -- whether to run a benchmark by its
                                  -- name.
              -> Benchmark
              -> Criterion ()
runAndAnalyse p bs' = do
  mbRawFile <- asks rawDataFile
  (rawFile, handle) <- liftIO $
    case mbRawFile of
      Nothing -> do
        tmpDir <- getTemporaryDirectory
        openBinaryTempFile tmpDir "criterion.dat"
      Just file -> do
        handle <- openBinaryFile file ReadWriteMode
        return (file, handle)
  liftIO $ L.hPut handle header

  let go (!k, !vr) (pfx, Environment mkenv mkbench) = do
        e <- liftIO $ do
               ee <- mkenv
               evaluate (rnf ee)
               return ee
        go (k, vr) (pfx, mkbench e)
      go (!k, !vr) (pfx, Benchmark desc b)
          | p desc'   = do _ <- note "benchmarking %s\n" desc'
                           rpt <- runAndAnalyseOne k desc' b
                           liftIO $ L.hPut handle (encode rpt)
                           return $! (k + 1, vr)
          | otherwise = return (k :: Int, vr)
          where desc' = addPrefix pfx desc
      go (!k, !vr) (pfx, BenchGroup desc bs) =
          foldM go (k, vr) [(addPrefix pfx desc, b) | b <- bs]
      go (!k, !vr) (pfx, BenchVersus desc envs algs)
         | p desc'   = do
             envs' <- mapM mkEnv envs
             liftIO $ evaluate $ rnf envs'
             let indices = [(a, e, aN, eN) | (aN, a) <- algs
                                           , (eN, e) <- envs']
                 vs = VersusReport {
                     vsReportDescription = desc'
                   , vsReportData = []
                   , vsReportDataPoints = map fst envs
                   , vsReportIndices = [((aN, eN), i)|
                                        (i, (_, _, aN, eN)) <- zip [k..] indices]
                   }
             (k', _) <- foldM go (k, [])
                        [(desc', bench name $ a e)
                        | (a, e, aN, eN) <- indices
                        , let name = aN ++ "/" ++ show eN]
             return (k', vs:vr)
         | otherwise = return (k :: Int, vr)
         where desc' = addPrefix pfx desc
               mkEnv (t, mkenv) = liftIO $ do
                 e <- mkenv
                 return (t, e)
  (_, vsRpts) <- go (0, []) ("", bs')

  rpts <- (either fail return =<<) . liftIO $ do
    hSeek handle AbsoluteSeek 0
    rs <- hGetReports handle
    hClose handle
    case mbRawFile of
      Just _ -> return rs
      _      -> removeFile rawFile >> return rs
  let vsRpts' = versusReports vsRpts rpts
  report rpts vsRpts'
  junit rpts
  vscsv vsRpts'

-- | Run a benchmark without analysing its performance.
runNotAnalyse :: Int64            -- ^ Number of loop iterations to run.
              -> (String -> Bool) -- ^ A predicate that chooses
                                  -- whether to run a benchmark by its
                                  -- name.
              -> Benchmark
              -> Criterion ()
runNotAnalyse iters p bs' = goQuickly "" bs'
  where goQuickly :: String -> Benchmark -> Criterion ()
        goQuickly pfx (Environment mkenv mkbench) = do
            e <- liftIO mkenv
            goQuickly pfx (mkbench e)
        goQuickly pfx (Benchmark desc b)
            | p desc'   = do _ <- note "benchmarking %s\n" desc'
                             runOne b
            | otherwise = return ()
            where desc' = addPrefix pfx desc
        goQuickly pfx (BenchGroup desc bs) =
            mapM_ (goQuickly (addPrefix pfx desc)) bs
        goQuickly pfx (BenchVersus desc envs algs) = do
            envs' <- mapM mkEnv envs
            liftIO $ evaluate $ rnf envs'
            mapM_ (goQuickly pfx') [bench name $ a e
                                   | (aN, a) <- algs, (eN, e) <- envs'
                                   , let name = aN ++ "/" ++ show eN]
            where mkEnv (t, mkenv) = liftIO $ do
                    e <- mkenv
                    return (t, e)
                  pfx' = addPrefix pfx desc

        runOne (Benchmarkable run) = liftIO (run iters)

-- | Add the given prefix to a name.  If the prefix is empty, the name
-- is returned unmodified.  Otherwise, the prefix and name are
-- separated by a @\'\/\'@ character.
addPrefix :: String             -- ^ Prefix.
          -> String             -- ^ Name.
          -> String
addPrefix ""  desc = desc
addPrefix pfx desc = pfx ++ '/' : desc

-- | Write summary JUnit file (if applicable)
junit :: [Report] -> Criterion ()
junit rs
  = do junitOpt <- asks junitFile
       case junitOpt of
         Just fn -> liftIO $ writeFile fn msg
         Nothing -> return ()
  where
    msg = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ++
          printf "<testsuite name=\"Criterion benchmarks\" tests=\"%d\">\n"
          (length rs) ++
          concatMap single rs ++
          "</testsuite>\n"
    single Report{..} = printf "  <testcase name=\"%s\" time=\"%f\" />\n"
               (attrEsc reportName) (estPoint $ anMean $ reportAnalysis)
    attrEsc = concatMap esc
      where
        esc '\'' = "'"
        esc '"'  = """
        esc '<'  = "<"
        esc '>'  = ">"
        esc '&'  = "&"
        esc c    = [c]


text:
module Type
    (
      -- * Types
      LispVal(..)
    , LispError(..)
    , LispEnv
      -- * Monads
    , ThrowsError
    ) where

import Data.Array (Array, elems)
import Data.Complex (Complex(..), imagPart, realPart)
import Data.Ratio (numerator, denominator)

import Data.IORef (IORef)
import Text.ParserCombinators.Parsec (ParseError)

-- | Values and code structures for lisp.
data LispVal
    = Symbol String
    | Integer Integer
    | Rational Rational
    | Real Float
    | Complex (Complex Integer)
    | Character Char
    | String String
    | Boolean Bool
    | List [LispVal]
    | DottedList [LispVal] LispVal
    | Vector (Array Int LispVal)
    | PrimitiveFunc String
    | Func [String] (Maybe String) [LispVal] LispEnv
    deriving (Eq)

instance Show LispVal where
    show = showVal

-- | Show the s-expression for LispVal.
showVal :: LispVal -> String
showVal (Symbol x)        = x
showVal (Integer x)       = show x
showVal (Rational x)      = show (numerator x) ++ "/" ++ show (denominator x)
showVal (Real x)          = show x
showVal (Complex x)       = show (realPart x) ++ "+" ++ show (imagPart x) ++ "i"
showVal (Character x)     = "#\\" ++ [x]
showVal (String x)        = "\"" ++ x ++ "\""
showVal (Boolean True)    = "#t"
showVal (Boolean False)   = "#f"
showVal (List xs)         = "(" ++ unwordsList xs ++ ")"
showVal (DottedList xs t) = "(" ++ unwordsList xs ++ " . " ++ showVal t ++ ")"
showVal (Vector xs)       = "#(" ++ unwordsList (elems xs) ++ ")"
showVal (PrimitiveFunc n) = "<primitive " ++ n ++ ">"
showVal (Func pns vn _ _) =
    "(lambda (" ++ varargText ++ unwords (map show pns) ++ ") ...)"
  where
    varargText = maybe "" (" . " ++) vn

-- | Errors for evaluating or parsing lisp.
data LispError
    = NumArgs String Integer [LispVal]
    | TypeMismatch String String LispVal
    | Parser ParseError
    | BadSpecialForm String LispVal
    | NotFunction String String
    | UnboundVar String String
    | Default String
    deriving (Eq)

-- | Show `LispError` as text.
showError :: LispError -> String
showError (NumArgs fName expected found) =
    fName ++ ": Expected " ++ show expected ++ " arguments, found values " ++ vs
  where
    vs = unwords $ map show found
showError (TypeMismatch fName expected found) =
    fName ++ ": Invalid type: expected " ++ expected ++ ", found " ++ show found
showError (Parser parseError) = "Parse error at " ++ show parseError
showError (BadSpecialForm message form) = message ++ ": " ++ show form
showError (NotFunction message fName)   = message ++ ": " ++ fName
showError (UnboundVar message varName)  = message ++ ": " ++ varName
showError (Default message)             = "Default: " ++ message

instance Show LispError where
    show = showError

-- | Monad for computation with potential `LispError`.
type ThrowsError = Either LispError

-- | Environment of mutable `LispVal` bindings.
type LispEnv = IORef [(String, IORef LispVal)]

-- | Join the s-expressions of a list of `LispVal` with spaces.
unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal

max_stars_repo_name: gavinkflam/backspin

max_issues_repo_name: gavinkflam/backspin

max_forks_repo_name: gavinkflam/backspin


text:
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
module Statistics.Distribution.Random.Normal (normal) where

import Control.Monad
import Data.Bits
import Data.Word
import qualified Data.Vector.Unboxed as I
import Random.CRI
import Statistics.Distribution.Random.Uniform

-- Copied from mwc-random.

data T = T {-# UNPACK #-} !Double {-# UNPACK #-} !Double

-- | Generate a normally distributed random variate.
--
-- The implementation uses Doornik's modified ziggurat algorithm.
-- Compared to the ziggurat algorithm usually used, this is slower,
-- but generates more independent variates that pass stringent tests
-- of randomness.
normal :: (Source m g Double, Source m g Word32) => g m -> m Double
normal gen = loop
  where
    loop = do
      u  <- (subtract 1 . (*2)) `liftM` uniform gen
      ri <- uniform gen
      let i  = fromIntegral ((ri :: Word32) .&. 127)
          bi = I.unsafeIndex blocks i
          bj = I.unsafeIndex blocks (i+1)
      if abs u < I.unsafeIndex ratios i
        then return $! u * bi
        else if i == 0
        then normalTail (u < 0)
        else do
          let x  = u * bi
              xx = x * x
              d  = exp (-0.5 * (bi * bi - xx))
              e  = exp (-0.5 * (bj * bj - xx))
          c <- uniform gen
          if e + c * (d - e) < 1
            then return x
            else loop
    blocks = let f = exp (-0.5 * r * r)
             in (`I.snoc` 0) . I.cons (v/f) . I.cons r .
                I.unfoldrN 126 go $! T r f
      where
        go (T b g)   = let !u = T h (exp (-0.5 * h * h))
                           h  = sqrt (-2 * log (v / b + g))
                       in Just (h, u)
        v            = 9.91256303526217e-3
    {-# NOINLINE blocks #-}
    r                = 3.442619855899
    ratios           = I.zipWith (/) (I.tail blocks) blocks
    {-# NOINLINE ratios #-}
    normalTail neg  = tailing
      where tailing  = do
              x <- ((/r) . log) `liftM` uniform gen
              y <- log          `liftM` uniform gen
              if y * (-2) < x * x
                then tailing
                else return $! if neg then x - r else r - x
{-# INLINE normal #-}

max_stars_repo_name: finlay/random-dist

max_issues_repo_name: finlay/random-dist

max_forks_repo_name: finlay/random-dist


text:
module Numeric.Sundials.Types
  ( OdeProblem(..)
  , EventHandler
  , EventHandlerResult(..)
  , Tolerances(..)
  , OdeRhsCType
  , OdeRhs(..)
  , odeRhsPure
  , UserData
  , Jacobian
  , JacobianRepr(..)
  , SparsePattern(..)
  , ODEOpts(..)
  , SundialsDiagnostics(..)
  , ErrorDiagnostics(..)
  , emptyDiagnostics
  , SundialsSolution(..)
  , CrossingDirection(..)
  , EventSpec(..)
  , TimeEventSpec(..)
  , SunVector(..)
  , SunIndexType
  , SunRealType
  , sunContentLengthOffset
  , sunContentDataOffset
  , sunCtx
  )
  where

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

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

data EventHandlerResult = EventHandlerResult
  { eventStopSolver :: !Bool
    -- ^ should we stop the solver after handling this event?
  , eventRecord :: !Bool
    -- ^ should we record the state before and after the event in the ODE
    -- solution?
  , eventNewState :: !(VS.Vector Double)
    -- ^ the new state after the event has been applied
  }

type EventHandler
  =  Double -- ^ time
  -> VS.Vector Double -- ^ values of the variables
  -> VS.Vector Int
    -- ^ Vector of triggered event indices.
    -- If the vector is empty, this is a time-based event.
  -> IO EventHandlerResult

data OdeProblem = OdeProblem
  { odeEvents :: V.Vector EventSpec
    -- ^ The events that may occur, including the condition when they occur
    -- and how to update the state of the system when they do.
  , odeMaxEvents :: !Int
    -- ^ The maximal number of events that may occur. This is needed to
    -- allocate enough space to store the events. If more events occur, an
    -- error is returned.
  , odeEventHandler :: EventHandler -- ^ The event handler.
  , odeTimeBasedEvents :: TimeEventSpec
  , odeRhs :: OdeRhs
    -- ^ The right-hand side of the system: either a Haskell function or
    -- a pointer to a compiled function.
  , odeJacobian :: Maybe (Double -> Vector Double -> Matrix Double)
    -- ^ The optional Jacobian (the arguments are the time and the state
    -- vector).
  , odeInitCond :: VS.Vector Double
    -- ^ The initial conditions of the problem.
  , odeSolTimes :: VS.Vector Double
    -- ^ The requested solution times. The actual solution times may be
    -- larger if any events occurred.
  , odeTolerances :: Tolerances
    -- ^ How much error is tolerated in each variable.
  }

data Tolerances = Tolerances
  { relTolerance :: !CDouble
  , absTolerances :: Either CDouble (VS.Vector CDouble)
    -- ^ If 'Left', then the same tolerance is used for all variables.
    --
    -- If 'Right', the vector should contain one tolerance per variable.
  } deriving (Show, Eq, Ord)

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

data UserData

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

-- | A version of 'OdeRhsHaskell' that accepts a pure function
odeRhsPure
  :: (CDouble -> VS.Vector CDouble -> VS.Vector CDouble)
  -> OdeRhs
odeRhsPure f = OdeRhsHaskell $ \t y -> return $ f t y

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

data JacobianRepr
  = SparseJacobian !SparsePattern -- ^ sparse Jacobian with the given sparse pattern
  | DenseJacobian
  deriving (Show)

data ODEOpts method = ODEOpts {
    maxNumSteps :: Int32
  , minStep     :: Double
  , fixedStep   :: Double
      -- ^ If this is greater than 0.0, then a fixed-size step is used.
      --
      -- This is only recommended for testing/debugging, not for production
      -- use.
      --
      -- Also, this only has effect for ARKode; using this with CVode will
      -- trigger an error.
  , maxFail     :: Int32
  , odeMethod   :: method
  , initStep    :: Maybe Double
    -- ^ initial step size - by default, CVode
    -- estimates the initial step size to be the
    -- solution \(h\) of the equation
    -- \(\|\frac{h^2\ddot{y}}{2}\| = 1\), where
    -- \(\ddot{y}\) is an estimated value of the second
    -- derivative of the solution at \(t_0\)
  , jacobianRepr :: JacobianRepr
    -- ^ use a sparse matrix to represent the Jacobian
    -- and a sparse linear solver for Newton iterations
  } deriving (Show)

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

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

data SundialsSolution =
  SundialsSolution
  { actualTimeGrid :: VS.Vector Double    -- ^ actual time grid returned by the solver (with duplicated event times)
  , solutionMatrix :: Matrix Double       -- ^ matrix of solutions: each column is an unknwown
  , diagnostics    :: SundialsDiagnostics -- ^ usual Sundials diagnostics
  }

data ErrorDiagnostics = ErrorDiagnostics
  { errorCode :: !Int
    -- ^ The numeric error code. Mostly useless at this point, since it is
    -- set to 1 under most error conditions. See 'solveOdeC'.
  , errorEstimates :: !(VS.Vector Double)
    -- ^ The local error estimates as returned by @CVodeGetEstLocalErrors@.
    -- Either an empty vector, or has the same dimensionality as the state
    -- space.
  , varWeights :: !(VS.Vector Double)
    -- ^ The weights with which errors are combined, equal to @1 / (atol_i + y_i * rtol)@.
    -- Either an empty vector, or has the same dimensionality as the state
    -- space.
  , partialResults :: !(Matrix Double)
    -- ^ Partial solution of the ODE system, up until the moment when
    -- solving failed. Contains the time as its first column.
  } deriving Show

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

-- | A time-based event, implemented as an action that returns the time of
-- the next time-based event.
--
-- If there's an additional condition attached to a time-based event, it
-- should be verified in the event handler.
--
-- The action is supposed to be stateful, and the state of the action
-- should be updated by the event handler so that after a given time-based
-- event is handled, the action starts returning the time of the next
-- unhandled time-based event.
--
-- If there is no next time-based event, the action should return +Inf.
newtype TimeEventSpec = TimeEventSpec (IO Double)

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

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

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

max_stars_repo_name: tweag/hmatrix-sundials

max_issues_repo_name: tweag/hmatrix-sundials

max_forks_repo_name: haskell-numerics/hmatrix-sundials


text:
{-# LANGUAGE BangPatterns, LambdaCase #-}

module Input
   ( Options(..)
   , FractalType(..)
   , AA(..)
   , Normalization(..)
   , Color(..)
   , Animation(..)
   , processArgs
   , pPrintOptions
   , defaultOptions
   )
where

import           Data.Complex
import           System.IO
import           Data.Word
import           System.Environment
import           Data.Char
import qualified Graphics.Image                as I

data FractalType =
   Mandelbrot | Julia deriving (Show)
data AA
   = AAEnabled | AADisabled deriving (Show)
data Normalization =
   Linear | Sigmoid Double Double | Periodic Double | Sine Double deriving (Show)
data Color =
   Greyscale | Hue | Gradient Bool [I.Pixel I.RGB Double] deriving (Show)
data Animation =
   NoAnimation | Power Double | Zoom Double (Maybe Int) |
   Iterations Int | Theta Double (Maybe Double) | LinearC (Complex Double) |
   Grid Double Double Double Double Int Int deriving (Show)
data Options = Options
   { fractalType     :: FractalType
   , resolution      :: (Int, Int)
   , center          :: Complex Double
   , range           :: Double
   , iterations      :: Int
   , power           :: Double
   , aa              :: AA
   , normalization   :: Normalization
   , color           :: Color
   , animation       :: Animation
   , cvalue          :: Complex Double
   , setColor        :: I.Pixel I.RGB Double
   , frameCount      :: Int
   , startingFrame   :: Int
   } deriving (Show)

defaultOptions = Options Mandelbrot
                         (500, 500)
                         (0 :+ 0)
                         2
                         500
                         2
                         AAEnabled
                         Linear
                         Hue
                         NoAnimation
                         (0 :+ 0)
                         (I.PixelRGB 0 0 0)
                         100
                         1

-- Primary function that produces a set of options from a ist of arguments
processArgs :: [String] -> Options
processArgs = getOptionsFromArgs . separateArgs . normalizeArgs

-- Makes sure all arguments are lowercase
normalizeArgs :: [String] -> [String]
normalizeArgs = map $ map toLower

-- Group into arguments and their subarguments
separateArgs :: [String] -> [[String]]
separateArgs []       = []
separateArgs (x : xs) = case lookup (take 3 x) arguments of
   Nothing -> error $ "Invalid argument \"" ++ x ++ "\""
   otherwise ->
      let (subArgs, args) = span
             (\y -> case lookup (take 3 y) arguments of
                Nothing   -> True
                otherwise -> False
             )
             xs
      in  (x : subArgs) : separateArgs args

-- Lookup and process all arguments
getOptionsFromArgs :: [[String]] -> Options
getOptionsFromArgs = foldl
   (\opt (arg : subargs) ->
      let func = lookup (take 3 arg) arguments
      in  case fmap (\f -> f (subargs, opt)) func of
             Just x    -> x
             otherwise -> error ""
   )
   defaultOptions

-- Function to convert a string like "23,4,198" to a color
colorFromString :: String -> I.Pixel I.RGB Double
colorFromString s =
   case map ((/ 255) . read) . words $ map (\case ',' -> ' '; x -> x) s
     of (r : g : b : []) -> if r <= 1 && g <= 1 && b <= 1
           then I.PixelRGB r g b
           else error "All color values must be on the interval [0,255]"
        otherwise -> error "Invalid color format for gradient"

-- Array of all command line arguments and functions to interpret their subarguments
-- It is assumed that arguments have been converted to lowercase and shortened to 3 characters
arguments :: [(String, (([String], Options) -> Options))]
arguments =
   [ ( "-fr"
     , \(x : xs, opt) -> case (take 3 x) : xs of
        ("man" : []) -> opt { fractalType = Mandelbrot }
        ("jul" : []) -> opt { fractalType = Julia }
        otherwise    -> error $ "Invalid arguments for -fractalType: \"" ++ (show $ x : xs) ++ "\""
     )
   , ( "-re"
     , \case
        (c : r : [], opt) -> opt { resolution = (read r, read c) }
        x                 -> error $ "Invalid arguments for -resolution: \"" ++ (show x) ++ "\""
     )
   , ( "-ce"
     , \(x : xs, opt) -> case (take 3 x) : xs of
        ("rec" : r : i : []) -> opt { center = read r :+ read i }
        ("pol" : m : p : []) -> opt { center = mkPolar (read m) ((/ 180) . (* pi) $ read p) }
        otherwise            -> error $ "Invalid arguments for -center: \"" ++ (show $ x : xs) ++ "\""
     )
   , ( "-ra"
     , \case
        (n : [], opt) -> opt { range = read n }
        x             -> error $ "Invalid arguments for -range: \"" ++ (show x) ++ "\""
     )
   , ( "-it"
     , \case
        (n : [], opt) -> opt { iterations = read n }
        x             -> error $ "Invalid arguments for -iterations: \"" ++ (show x) ++ "\""
     )
   , ( "-po"
     , \case
        (n : [], opt) -> opt { power = read n }
        x             -> error $ "Invalid arguments for -power: \"" ++ (show x) ++ "\""
     )
   , ( "-aa"
     , \(x : xs, opt) -> case (take 3 x) : xs of
        ("ena" : []) -> opt { aa = AAEnabled }
        ("dis" : []) -> opt { aa = AADisabled }
        otherwise    -> error $ "Invalid arguments for -aa: \"" ++ (show $ x : xs) ++ "\""
     )
   , ( "-no"
     , \(x : xs, opt) -> case (take 3 x) : xs of
        ("lin"         : []) -> opt { normalization = Linear }
        ("sig"     : c : []) -> opt { normalization = Sigmoid (read c) 2.5 }
        ("sig" : c : p : []) -> opt { normalization = Sigmoid (read c) (read p) }
        ("per"     : p : []) -> opt { normalization = Periodic (read p) }
        ("sin"     : p : []) -> opt { normalization = Sine (read p) }
        otherwise -> error $ "Invalid arguments for -normalization: \"" ++ (show $ x : xs) ++ "\""
     )
   , ( "-co"
     , \(x : xs, opt) -> case (take 3 x) : xs of
        ("gre"             : []  ) -> opt { color = Greyscale }
        ("hue"             : []  ) -> opt { color = Hue }
        ("gra" : ('l' : _) : args) -> if length args < 2
           then error "Insufficient colors for a gradient to be formed"
           else opt { color = (Gradient False $ map colorFromString args) }
        ("gra" : args) -> if length args < 2
           then error "Insufficient colors for a gradient to be formed"
           else opt { color = (Gradient True $ map colorFromString args) }
        otherwise -> error $ "Invalid arguments for -color: \"" ++ (show $ x : xs) ++ "\""
     )
   , ( "-an"
     , \(x : xs, opt) -> case (take 3 x) : xs of
        ("non"           : []) -> opt { animation = NoAnimation }
        ("pow" : fn : fr : []) -> opt { animation = Power (read fn), frameCount = (read fr) }
        ("zoo" : fn : fr : []) -> opt { animation = Zoom (read fn) Nothing, frameCount = (read fr) }
        ("zoo" : fn : fr : fi : []) ->
           opt { animation = Zoom (read fn) (Just $ read fi), frameCount = (read fr) }
        ("ite" : fn : fr : []) -> opt { animation = Iterations (read fn), frameCount = (read fr) }
        ("the" : fn : fr : []) -> opt { animation = Theta (read fn) Nothing, frameCount = (read fr) }
        ("the" : fn : fr : fm : []) ->
           opt { animation = Theta (read fn) (Just $ read fm), frameCount = (read fr) }
        ("lin" : ty : xs) -> case ((take 3 ty) : xs) of
           ("rec" : r : i : fr : []) ->
              opt { animation = LinearC (read r :+ read i), frameCount = (read fr) }
           ("pol" : m : p : fr : []) ->
              opt { animation = LinearC (mkPolar (read m) ((/ 180) . (* pi) $ read p))
                  , frameCount = (read fr) }
        ("gri" : ri : rl : ii : il : rc : ic : []) ->
            opt { animation = Grid (read ri) (read rl) (read ii) (read il) (read rc) (read ic)
                , frameCount = (read rc) * (read ic) }
        otherwise -> error $ "Invalid arguments for -animation: \"" ++ (show $ x : xs) ++ "\""
     )
   , ( "-cv"
     , \(x : xs, opt) -> case (take 3 x) : xs of
        ("rec" : r : i : []) -> opt { cvalue = read r :+ read i }
        ("pol" : m : p : []) -> opt { cvalue = mkPolar (read m) ((/ 180) . (* pi) $ read p) }
        otherwise            -> error $ "Invalid arguments for -cvalue: \"" ++ (show $ x : xs) ++ "\""
     )
   , ( "-se"
     , \case
        ([x], opt) -> opt { setColor = colorFromString x }
        x          -> error $ "Invalid arguments for -setColor: \"" ++ (show x) ++ "\""
     )
   , ( "-st"
     , \case
        ([x], opt) -> opt { startingFrame = read x }
        x          -> error $ "Invalid arguments for -startingFrame: \"" ++ (show x) ++ "\""
     )
   ]

pPrintOptions :: Options -> String
pPrintOptions options =
   "Fractal Type:    " ++ (show $ fractalType   options) ++ '\n' :
   "Resolution:      " ++ (show $ resolution    options) ++ '\n' :
   "Center:          " ++ (show $ center        options) ++ '\n' :
   "Range:           " ++ (show $ range         options) ++ '\n' :
   "Iterations:      " ++ (show $ iterations    options) ++ '\n' :
   "Power:           " ++ (show $ power         options) ++ '\n' :
   "Antialiasing:    " ++ (show $ aa            options) ++ '\n' :
   "Normalization:   " ++ (show $ normalization options) ++ '\n' :
   "Color:           " ++ (show $ color         options) ++ '\n' :
   "Animation:       " ++ (show $ animation     options) ++ '\n' :
   "C-Value:         " ++ (show $ cvalue        options) ++ '\n' :
   "Set Color:       " ++ (show $ setColor      options) ++ '\n' :
   "Frames:          " ++ (show $ frameCount    options) ++ '\n' :
   "Starting Frame:  " ++ (show $ startingFrame options)

max_stars_repo_name: MaygeKyatt/Fractals

max_issues_repo_name: MaygeKyatt/Fractals

max_forks_repo_name: MaygeKyatt/Fractals