text:
-------------------------------------------------------------------------------
-- |
-- Module    :  Environments.Bandits
-- Copyright :  (c) Sentenai 2017
-- License   :  BSD3
-- Maintainer:  sam@sentenai.com
-- Stability :  experimental
-- Portability: non-portable
--
-- Implementation of an n-armed bandit environment.
--
-- FIXME: currently this is only for a 10-armed bandit. This needs to be tied
-- to a config.
-------------------------------------------------------------------------------
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
module Environments.Bandits
  ( Environment(..)
  , runEnvironment
  , Event.Event(..)
  , Config
  , Action
  , mkBandits
  , defaultBandits
  , mkAction
  ) where

import Control.MonadEnv
import Control.MonadMWCRandom
import qualified Data.Vector as V
import Data.Vector ((!), Vector)
import Data.Hashable
import qualified Data.Event as Event
import Control.Exception.Safe (assert, MonadThrow)
import qualified Statistics.Distribution as Dist
import Statistics.Distribution.Normal
import Data.DList
import Control.Monad.Reader.Class
import Control.Monad.RWS.Class
import Control.Monad.IO.Class
import Control.Monad.Writer.Class
import Control.Monad.State.Class
import Control.Monad.Trans.RWS (RWST, evalRWST)
import GHC.Generics

-- | FIXME: only 10 arms for the time being. This is where a "discrete space"
-- would be nice
data Config = Config
  { nBandits :: Int
  , offset   :: Int
  , stdDev   :: Float
  , bandits  :: Vector NormalDistribution
  , gen      :: GenIO
  }

instance Show Config where
  show c = "Config" ++
    "{nBandits="++ show (nBandits c)++
    "{offset="++ show (offset c)++
    "{bandit_stdDevs="++ show (stdDev c)++
    "{bandit_means="++ show (fmap Dist.mean . V.toList $ bandits c)++
    "}"

type Event = Event.Event Reward () Action

-- | The slot machine index whose arm will be pulled
newtype Action = Action { unAction :: Int }
  deriving (Eq, Ord, Show, Enum, Generic)

instance Bounded Action where
  minBound = Action 0
  maxBound = Action 9

instance Hashable Action where

-- | Convert an Int to an Action  in the bandit environment. Throw if the Int
-- falls out of bounds.
mkAction :: Int -> Environment Action
mkAction i = Environment $ do
  n <- nBandits <$> ask
  assert (i > n || i < 0) (pure $ Action i)

-- | Monad for an n-armed bandit environment
newtype Environment a = Environment
  { getEnvironment :: RWST Config (DList Event) () IO a }
  deriving
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadThrow
    , MonadReader Config
    , MonadWriter (DList Event)
    , MonadState ()
    , MonadRWS Config (DList Event) ()
    )

-- | run an n-armed bandit environment
runEnvironment :: Config -> Environment () -> IO (DList Event)
runEnvironment c (Environment m) = snd <$> evalRWST m c ()

-- | Give the default config of a 10-armed bandit
defaultBandits :: GenIO -> Config
defaultBandits = mkBandits 10 2 0.1

-- | helper function to build a bandits config with normally-distributed
-- reward functions
mkBandits :: Int -> Int -> Float -> GenIO -> Config
mkBandits n offset' std = Config n offset' std $
  V.fromList $ fmap (`rewardDist` std) [offset' .. offset' + n - 1]
  where
    rewardDist :: Int -> Float -> NormalDistribution
    rewardDist m s = normalDistr (fromIntegral m) (realToFrac s)

instance MonadMWCRandom Environment where
  getGen = Environment $ fmap gen ask

instance MonadEnv Environment () Action Reward where
  -- this isn't an episodic environment... we'll have to split this out later
  reset :: Environment (Initial ())
  reset = return $ Initial ()

  step :: Action -> Environment (Obs Reward ())
  step (Action a) = do
    rwd <- genContVar =<< (! a) . bandits <$> ask
    tell . pure $ Event.Event 0 rwd () (Action a)
    return $ Next rwd ()

max_stars_repo_name: juliendehos/reinforce

max_issues_repo_name: sentenai/reinforce

max_forks_repo_name: sentenai/reinforce


text:
module Parser.Parser (
    parseScheme
)
where

import Parser.MetaNode
import Control.Monad.State.Lazy
import Data.Data
import Common.Number
import Data.Complex
import Lexer.Token

parseScheme :: [Token] -> [MetaNode]
parseScheme st = case runState (parseExpression "Scheme Program") st of
    (mn, []) -> [mn]
    (mn, up) -> mn:parseScheme up
    --(_, t:_) -> error $ "Unexpected token " ++ show t ++ " not allowed in top level of program"

push :: Token -> State [Token] ()
push t = do
    ts <- get
    put (t:ts)

pull :: String -> State [Token] Token
pull context = do
    ts <- get
    case ts of
        (t:ts) -> do
            put ts
            return t
        _ -> error $ "Unexpected end of token stream in " ++ context

pullEq :: String -> Token -> State [Token] ()
pullEq context c = do
    t <- pull context
    if  t ==  c then
        return ()
    else
        error $ (show c) ++ " in " ++ context ++ " expected, but not found"

peek :: String -> State [Token] Token
peek context = do
    ts <- get
    case ts of
        (t:ts) -> return t
        _ -> error $ "Unexpected end of token stream in " ++ context

parseExpression :: String -> State [Token] MetaNode
parseExpression context = do
    t <- peek context
    case t of
        POpen -> parseSyntax
        ShortQuote -> do
            pullEq "Datum" ShortQuote
            parseQuotedDatum
        ShortQuasiQuote -> do
            pullEq "Quasiquoted Datum" ShortQuasiQuote
            parseQuasiQuotedDatum
        CommentDatum -> do
            pullEq "Commented Datum" CommentDatum
            parseExpression "Commented Datum"
            parseExpression context
        _ -> parseAtom

parseSyntax :: State [Token] MetaNode
parseSyntax = do
    pullEq "Syntactic construct" POpen
    t <- peek "Syntactic construct"
    case t of
        Lambda -> parseLambda
        Define -> parseDefine
        Quote -> parseQuote
        QuasiQuote -> parseQuasiQuote
        If -> parseIf
        Set -> parseSet
        PClose -> do
            pullEq "PClose" PClose
            return EmptyAtom
        DefineSyntax -> parseDefineSyntax
        LetSyntax -> parseLetSyntax
        LetrecSyntax -> parseLetrecSyntax
        _ -> parseApplication

parseAtom :: State [Token] MetaNode
parseAtom = do
    t <- pull "Atom"
    case t of
        Bool b -> return $ BoolAtom b
        String s -> return $ StringAtom s
        Char c -> return $ CharAtom c
        Number n -> return $ NumberAtom n
        Identifier i -> return $ IdentifierAtom i 0
        Quote -> return $ IdentifierAtom "quote" 0
        Unquote -> return $ IdentifierAtom "unquote" 0
        QuasiQuote -> return $ IdentifierAtom "quasiquote" 0
        Set  -> return $ IdentifierAtom "set!" 0
        Define  -> return $ IdentifierAtom "define" 0
        _ -> error $ "Unexpected token " ++ show t ++ " not allowed in current context"

parseQuote :: State [Token] MetaNode
parseQuote = do
    pullEq "Quote" Quote
    d <- parseQuotedDatum
    pullEq "Quote" PClose
    return d

parseQuasiQuote :: State [Token] MetaNode
parseQuasiQuote = do
    pullEq "Quasiquote" QuasiQuote
    d <- parseQuasiQuotedDatum
    pullEq "Quasiquote" PClose
    return d

parseLambda :: State [Token] MetaNode
parseLambda = do
    pullEq "Lambda" Lambda
    (c, l) <- parseFormalParameters
    e <- parseExpressionList "Body"
    return (LambdaNode c l e)

parseIf :: State [Token] MetaNode
parseIf = do
    pullEq "If" If
    p <- parseExpression "If Condition"
    a <- parseExpression "If Then Branch"
    next <- peek "If"
    if next /= PClose then do
        b <- parseExpression "If Else Branch"
        pullEq "If" PClose
        return (IfNode p a b)
    else do
        pullEq "If" PClose
        return (IfNode p a UnspecifiedAtom)

parseSet :: State [Token] MetaNode
parseSet = do
    pullEq "Set" Set
    t <- pull "Set"
    case t of
        (Identifier str) -> do
            e <- parseExpression "Set Body"
            pullEq "Set" PClose
            return (SetNode (IdentifierAtom str 0) e)
        _ -> error "Expected Identifier as first argument of set"

parseDefine :: State [Token] MetaNode
parseDefine = do
    pullEq "Define" Define
    t <- pull "Define"
    case t of
        (Identifier str) -> do
            p <- peek "Define"
            if p /= PClose then do
                e <- parseExpression "Define Body"
                pullEq "Define" PClose
                return (DefineNode (IdentifierAtom str 0) e)
            else do
                pullEq "Define" PClose
                return (DefineNode (IdentifierAtom str 0) UnspecifiedAtom)
        POpen -> parseDefineFunction
        _ -> error "Expected Identifier oder Parantheses as first argument of define"

parseDefineFunction :: State [Token] MetaNode
parseDefineFunction =  do
            (ps, p) <- parseFormalParameterList
            es <- parseExpressionList "Define Body"
            case ps of
                (i:ps) -> return (DefineNode i (LambdaNode ps p es))
                _ -> error "Expected parameter list in function definition"

parseDefineSyntax :: State [Token] MetaNode
parseDefineSyntax = do
    pullEq "Define-Syntax" DefineSyntax
    t <- pull "Define-Syntax"
    case t of
        (Identifier str) -> do
            e <- parseExpression "Define-Syntax Rules"
            pullEq "Define-Syntax" PClose
            return (DefineSyntaxNode (IdentifierAtom str 0) e)
        _ -> error "Expected Identifier as first argument of define-syntax"

parseLetSyntax :: State [Token] MetaNode
parseLetSyntax = do
    pullEq "Let-Syntax" LetSyntax
    e <- parseExpression "Let-Syntax Rules"
    body <- parseExpressionList "Let-Syntax Body"
    return (LetSyntaxNode e body)

parseLetrecSyntax :: State [Token] MetaNode
parseLetrecSyntax = do
    pullEq "Letrec-Syntax" LetrecSyntax
    e <- parseExpression "Letrec-Syntax Rules"
    body <- parseExpressionList "Letrec-Syntax Body"
    return (LetrecSyntaxNode e body)

parseApplication :: State [Token] MetaNode
parseApplication = do
    f <- parseExpression "Lambda Application"
    arg <- parseExpressionList "Argument"
    return (ApplicationNode f arg)

parseQuotedDatum :: State [Token] MetaNode
parseQuotedDatum = do
    t <- peek "Datum"
    case t of
        POpen -> do
            pullEq "Compound Datum" POpen
            parseQuotedCompoundDatum
        CommentDatum -> do
            pullEq "Commented Quoted Datum" CommentDatum
            parseQuotedDatum
            parseQuotedDatum
        ShortQuote -> parseQuotedShortForm
        ShortUnquote -> parseQuotedShortForm
        ShortQuasiQuote -> parseQuotedShortForm
        Identifier str -> do
            pull "Symbol"
            return $ SymbolAtom str
        _ -> parseAtom

parseQuotedCompoundDatum :: State [Token] MetaNode
parseQuotedCompoundDatum = do
    t <- peek "Compound Datum"
    case t of
        PClose -> do
            pullEq "Compound Datum" PClose
            return EmptyAtom
        Dot -> do
            pullEq "Compound Datum" Dot
            end <- parseQuotedDatum
            pullEq "Compound Datum" PClose
            return end
        _ -> do
            e <- parseQuotedDatum
            es <- parseQuotedCompoundDatum
            return (PairNode e es)

parseQuotedShortForm :: State [Token] MetaNode
parseQuotedShortForm = do
    t <- pull "Quoted Shortform"
    d <- parseQuotedDatum
    return $ PairNode (IdentifierAtom (show t) 0) (PairNode d EmptyAtom)

parseQuasiQuotedDatum :: State [Token] MetaNode
parseQuasiQuotedDatum = do
    t <- peek "Quasiquoted Datum"
    case t of
        POpen -> do
            pullEq "Quasiquoted Datum" POpen
            t <- peek "Quasiquoted Datum"
            case t of
                Unquote -> parseUnquotedExpression
                _ -> parseQuasiQuotedCompoundDatum
        ShortUnquote -> do
            pullEq "Unquoted Expression" ShortUnquote
            parseExpression "Unquoted Expression"
        CommentDatum -> do
            pullEq "Commented Quasiquoted Datum" CommentDatum
            parseQuasiQuotedDatum
            parseQuasiQuotedDatum
        ShortQuote -> parseQuasiQuotedShortForm
        ShortQuasiQuote -> parseQuasiQuotedShortForm
        Identifier str -> do
            pull "Symbol"
            return $ SymbolAtom str
        _ -> parseAtom

parseQuasiQuotedCompoundDatum :: State [Token] MetaNode
parseQuasiQuotedCompoundDatum = do
    t <- peek "Quasiquoted Compound Datum"
    case t of
        PClose -> do
            pullEq "Quasiquoted Compound Datum" PClose
            return EmptyAtom
        Dot -> do
            pullEq "Quasiquoted Compound Datum" Dot
            end <- parseQuasiQuotedDatum
            pullEq "Quasiquoted Compound Datum" PClose
            return end
        _ -> do
            e <- parseQuasiQuotedDatum
            es <- parseQuasiQuotedCompoundDatum
            return (PairNode e es)

parseQuasiQuotedShortForm :: State [Token] MetaNode
parseQuasiQuotedShortForm = do
    t <- pull "Quasiquoted Shortform"
    d <- parseQuasiQuotedDatum
    return $ PairNode (IdentifierAtom (show t) 0) (PairNode d EmptyAtom)

parseUnquotedExpression :: State [Token] MetaNode
parseUnquotedExpression = do
    pullEq "Unquoted Expression" Unquote
    e <- parseExpression "Unquoted Expression"
    pullEq "Unquoted Expression" PClose
    return e

parseExpressionList :: String -> State [Token] [MetaNode]
parseExpressionList  context = do
    t <- peek (context ++ " List")
    case t of
        PClose -> do
            pullEq context PClose
            return []
        _ -> do
            e <- parseExpression context
            es <- parseExpressionList (context ++ " List")
            return (e:es)

parseFormalParameters :: State [Token] ([MetaNode], MetaNode)
parseFormalParameters = do
    t <- pull "Formal Paramters"
    case t of
        POpen -> parseFormalParameterList
        Identifier s -> return ([],IdentifierAtom s 0)
        _ -> error "Expected parameter list or single parameter in lambda definition"

parseFormalParameterList :: State [Token] ([MetaNode], MetaNode)
parseFormalParameterList = do
    t <- pull "Formal Paramterlist"
    case t of
        PClose -> do
            return ([], IdentifierAtom "" 0)
        Dot -> do
            t <- pull "Formal Paramterlist"
            case t of
                Identifier str -> do
                    pullEq "Formal Paramterlist" PClose
                    return ([], IdentifierAtom str 0)
                _ -> error $ "Expected formal parameters in formal parameterlist not token " ++ show t
        Identifier str -> do
            (is, i) <- parseFormalParameterList
            return ((IdentifierAtom str 0):is, i)
        _ -> error $ "Expected formal parameters in formal parameterlist not token " ++ show t

ext: hs

max_stars_repo_name: scheme-metamorph/metamorph

max_issues_repo_name: scheme-metamorph/metamorph

max_forks_repo_name: scheme-metamorph/metamorph


text:
{-# LANGUAGE BangPatterns         #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE MagicHash            #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UnboxedTuples        #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- Module      :  Internal.Vector
-- Copyright   :  (c) Alberto Ruiz 2007-15
-- License     :  BSD3
-- Maintainer  :  Alberto Ruiz
-- Stability   :  provisional
--

module Internal.Vector(
    I,Z,R,C,
    fi,ti,
    Vector, fromList, unsafeToForeignPtr, unsafeFromForeignPtr, unsafeWith,
    createVector, avec, inlinePerformIO,
    toList, dim, (@>), at', (|>),
    vjoin, subVector, takesV, idxs,
    buildVector,
    asReal, asComplex,
    toByteString,fromByteString,
    zipVector, unzipVector, zipVectorWith, unzipVectorWith,
    foldVector, foldVectorG, foldVectorWithIndex, foldLoop,
    mapVector, mapVectorM, mapVectorM_,
    mapVectorWithIndex, mapVectorWithIndexM, mapVectorWithIndexM_
) where

import           Data.Complex
import           Data.Int                      (Int64)
import           Data.Vector.Storable          (Vector, fromList, unsafeFromForeignPtr,
                                                unsafeToForeignPtr, unsafeWith)
import qualified Data.Vector.Storable          as Vector
import           Foreign.C.Types               (CInt)
import           Foreign.ForeignPtr
import           Foreign.Marshal.Array
import           Foreign.Ptr
import           Foreign.Storable
import           GHC.Base                      (IO (IO), realWorld#, when)
import           GHC.ForeignPtr                (mallocPlainForeignPtrBytes)
import           System.IO.Unsafe              (unsafePerformIO)

import           Control.Monad                 (replicateM)
import           Data.Binary
import           Data.Binary.Put
import qualified Data.ByteString.Internal      as BS
import           Data.Vector.Storable.Internal (updPtr)

type I = CInt
type Z = Int64
type R = Float
type C = Complex Float

-- | specialized fromIntegral
fi :: Int -> CInt
fi = fromIntegral

-- | specialized fromIntegral
ti :: CInt -> Int
ti = fromIntegral

-- | Number of elements
dim :: (Storable t) => Vector t -> Int
dim = Vector.length
{-# INLINE dim #-}

-- C-Haskell vector adapter
{-# INLINE avec #-}
avec :: Storable a => Vector a -> (f -> IO r) -> ((CInt -> Ptr a -> f) -> IO r)
avec v f g = unsafeWith v $ \ptr -> f (g (fromIntegral (Vector.length v)) ptr)

-- allocates memory for a new vector
createVector :: Storable a => Int -> IO (Vector a)
createVector n = do
    when (n < 0) $ error ("trying to createVector of negative dim: "++show n)
    fp <- doMalloc undefined
    return $ unsafeFromForeignPtr fp 0 n
  where
    --
    -- Use the much cheaper Haskell heap allocated storage
    -- for foreign pointer space we control
    --
    doMalloc :: Storable b => b -> IO (ForeignPtr b)
    doMalloc dummy = do
        mallocPlainForeignPtrBytes (n * sizeOf dummy)

{- | creates a Vector from a list:

@> fromList [2,3,5,7]
4 |> [2.0,3.0,5.0,7.0]@

-}

safeRead :: Storable a => Vector a -> (Ptr a -> IO c) -> c
safeRead v = inlinePerformIO . unsafeWith v
{-# INLINE safeRead #-}

inlinePerformIO :: IO a -> a
inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
{-# INLINE inlinePerformIO #-}

{- extracts the Vector elements to a list

>>> toList (linspace 5 (1,10))
[1.0,3.25,5.5,7.75,10.0]

-}
toList :: Storable a => Vector a -> [a]
toList v = safeRead v $ peekArray (dim v)

{- | Create a vector from a list of elements and explicit dimension. The input
     list is truncated if it is too long, so it may safely
     be used, for instance, with infinite lists.

>>> 5 |> [1..]
[1.0,2.0,3.0,4.0,5.0]
it :: (Enum a, Num a, Foreign.Storable.Storable a) => Vector a

-}
(|>) :: (Storable a) => Int -> [a] -> Vector a
infixl 9 |>
n |> l
    | length l' == n = fromList l'
    | otherwise      = error "list too short for |>"
  where
    l' = take n l

-- | Create a vector of indexes, useful for matrix extraction using '(??)'
idxs :: [Int] -> Vector I
idxs js = fromList (map fromIntegral js) :: Vector I

{- | takes a number of consecutive elements from a Vector

>>> subVector 2 3 (fromList [1..10])
[3.0,4.0,5.0]
it :: (Enum t, Num t, Foreign.Storable.Storable t) => Vector t

-}
subVector :: Storable t => Int       -- ^ index of the starting element
                        -> Int       -- ^ number of elements to extract
                        -> Vector t  -- ^ source
                        -> Vector t  -- ^ result
subVector = Vector.slice
{-# INLINE subVector #-}

{- | Reads a vector position:

>>> fromList [0..9] @> 7
7.0

-}
(@>) :: Storable t => Vector t -> Int -> t
infixl 9 @>
v @> n
    | n >= 0 && n < dim v = at' v n
    | otherwise = error "vector index out of range"
{-# INLINE (@>) #-}

-- | access to Vector elements without range checking
at' :: Storable a => Vector a -> Int -> a
at' v n = safeRead v $ flip peekElemOff n
{-# INLINE at' #-}

{- | concatenate a list of vectors

>>> vjoin [fromList [1..5::Float], konst 1 3]
[1.0,2.0,3.0,4.0,5.0,1.0,1.0,1.0]
it :: Vector Float

-}
vjoin :: Storable t => [Vector t] -> Vector t
vjoin [] = fromList []
vjoin [v] = v
vjoin as = unsafePerformIO $ do
    let tot = sum (map dim as)
    r <- createVector tot
    unsafeWith r $ \ptr ->
        joiner as tot ptr
    return r
  where joiner [] _ _ = return ()
        joiner (v:cs) _ p = do
            let n = dim v
            unsafeWith v $ \pb -> copyArray p pb n
            joiner cs 0 (advancePtr p n)

{- | Extract consecutive subvectors of the given sizes.

>>> takesV [3,4] (linspace 10 (1,10::Float))
[[1.0,2.0,3.0],[4.0,5.0,6.0,7.0]]
it :: [Vector Float]

-}
takesV :: Storable t => [Int] -> Vector t -> [Vector t]
takesV ms w | sum ms > dim w = error $ "takesV " ++ show ms ++ " on dim = " ++ (show $ dim w)
            | otherwise = go ms w
    where go [] _ = []
          go (n:ns) v = subVector 0 n v
                      : go ns (subVector n (dim v - n) v)

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

-- | transforms a complex vector into a real vector with alternating real and imaginary parts
asReal :: (RealFloat a, Storable a) => Vector (Complex a) -> Vector a
asReal v = unsafeFromForeignPtr (castForeignPtr fp) (2*i) (2*n)
    where (fp,i,n) = unsafeToForeignPtr v

-- | transforms a real vector into a complex vector with alternating real and imaginary parts
asComplex :: (RealFloat a, Storable a) => Vector a -> Vector (Complex a)
asComplex v = unsafeFromForeignPtr (castForeignPtr fp) (i `div` 2) (n `div` 2)
    where (fp,i,n) = unsafeToForeignPtr v

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

-- | map on Vectors
mapVector :: (Storable a, Storable b) => (a-> b) -> Vector a -> Vector b
mapVector f v = unsafePerformIO $ do
    w <- createVector (dim v)
    unsafeWith v $ \p ->
        unsafeWith w $ \q -> do
            let go (-1) = return ()
                go !k = do x <- peekElemOff p k
                           pokeElemOff      q k (f x)
                           go (k-1)
            go (dim v -1)
    return w
{-# INLINE mapVector #-}

-- | zipWith for Vectors
zipVectorWith :: (Storable a, Storable b, Storable c) => (a-> b -> c) -> Vector a -> Vector b -> Vector c
zipVectorWith f u v = unsafePerformIO $ do
    let n = min (dim u) (dim v)
    w <- createVector n
    unsafeWith u $ \pu ->
        unsafeWith v $ \pv ->
            unsafeWith w $ \pw -> do
                let go (-1) = return ()
                    go !k = do x <- peekElemOff pu k
                               y <- peekElemOff pv k
                               pokeElemOff      pw k (f x y)
                               go (k-1)
                go (n -1)
    return w
{-# INLINE zipVectorWith #-}

-- | unzipWith for Vectors
unzipVectorWith :: (Storable (a,b), Storable c, Storable d)
                   => ((a,b) -> (c,d)) -> Vector (a,b) -> (Vector c,Vector d)
unzipVectorWith f u = unsafePerformIO $ do
      let n = dim u
      v <- createVector n
      w <- createVector n
      unsafeWith u $ \pu ->
          unsafeWith v $ \pv ->
              unsafeWith w $ \pw -> do
                  let go (-1) = return ()
                      go !k   = do z <- peekElemOff pu k
                                   let (x,y) = f z
                                   pokeElemOff      pv k x
                                   pokeElemOff      pw k y
                                   go (k-1)
                  go (n-1)
      return (v,w)
{-# INLINE unzipVectorWith #-}

foldVector :: Storable a => (a -> b -> b) -> b -> Vector a -> b
foldVector f x v = unsafePerformIO $
    unsafeWith v $ \p -> do
        let go (-1) s = return s
            go !k !s = do y <- peekElemOff p k
                          go (k-1::Int) (f y s)
        go (dim v -1) x
{-# INLINE foldVector #-}

-- the zero-indexed index is passed to the folding function
foldVectorWithIndex :: Storable a => (Int -> a -> b -> b) -> b -> Vector a -> b
foldVectorWithIndex f x v = unsafePerformIO $
    unsafeWith v $ \p -> do
        let go (-1) s = return s
            go !k !s = do y <- peekElemOff p k
                          go (k-1::Int) (f k y s)
        go (dim v -1) x
{-# INLINE foldVectorWithIndex #-}

foldLoop :: (Int -> t -> t) -> t -> Int -> t
foldLoop f s0 d = go (d - 1) s0
     where
       go 0 s   = f (0::Int) s
       go !j !s = go (j - 1) (f j s)

foldVectorG :: Storable t1 => (Int -> (Int -> t1) -> t -> t) -> t -> Vector t1 -> t
foldVectorG f s0 v = foldLoop g s0 (dim v)
    where g !k !s = f k (safeRead v . flip peekElemOff) s
          {-# INLINE g #-} -- Thanks to Ryan Ingram (http://permalink.gmane.org/gmane.comp.lang.haskell.cafe/46479)
{-# INLINE foldVectorG #-}

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

-- | monadic map over Vectors
--    the monad @m@ must be strict
mapVectorM :: (Storable a, Storable b, Monad m) => (a -> m b) -> Vector a -> m (Vector b)
mapVectorM f v = do
    w <- return $! unsafePerformIO $! createVector (dim v)
    mapVectorM' w 0 (dim v -1)
    return w
    where mapVectorM' w' !k !t
              | k == t               = do
                                       x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k
                                       y <- f x
                                       return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y
              | otherwise            = do
                                       x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k
                                       y <- f x
                                       _ <- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y
                                       mapVectorM' w' (k+1) t
{-# INLINE mapVectorM #-}

-- | monadic map over Vectors
mapVectorM_ :: (Storable a, Monad m) => (a -> m ()) -> Vector a -> m ()
mapVectorM_ f v = do
    mapVectorM' 0 (dim v -1)
    where mapVectorM' !k !t
              | k == t            = do
                                    x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k
                                    f x
              | otherwise         = do
                                    x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k
                                    _ <- f x
                                    mapVectorM' (k+1) t
{-# INLINE mapVectorM_ #-}

-- | monadic map over Vectors with the zero-indexed index passed to the mapping function
--    the monad @m@ must be strict
mapVectorWithIndexM :: (Storable a, Storable b, Monad m) => (Int -> a -> m b) -> Vector a -> m (Vector b)
mapVectorWithIndexM f v = do
    w <- return $! unsafePerformIO $! createVector (dim v)
    mapVectorM' w 0 (dim v -1)
    return w
    where mapVectorM' w' !k !t
              | k == t               = do
                                       x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k
                                       y <- f k x
                                       return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y
              | otherwise            = do
                                       x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k
                                       y <- f k x
                                       _ <- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y
                                       mapVectorM' w' (k+1) t
{-# INLINE mapVectorWithIndexM #-}

-- | monadic map over Vectors with the zero-indexed index passed to the mapping function
mapVectorWithIndexM_ :: (Storable a, Monad m) => (Int -> a -> m ()) -> Vector a -> m ()
mapVectorWithIndexM_ f v = do
    mapVectorM' 0 (dim v -1)
    where mapVectorM' !k !t
              | k == t            = do
                                    x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k
                                    f k x
              | otherwise         = do
                                    x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k
                                    _ <- f k x
                                    mapVectorM' (k+1) t
{-# INLINE mapVectorWithIndexM_ #-}

mapVectorWithIndex :: (Storable a, Storable b) => (Int -> a -> b) -> Vector a -> Vector b
--mapVectorWithIndex g = head . mapVectorWithIndexM (\a b -> [g a b])
mapVectorWithIndex f v = unsafePerformIO $ do
    w <- createVector (dim v)
    unsafeWith v $ \p ->
        unsafeWith w $ \q -> do
            let go (-1) = return ()
                go !k = do x <- peekElemOff p k
                           pokeElemOff      q k (f k x)
                           go (k-1)
            go (dim v -1)
    return w
{-# INLINE mapVectorWithIndex #-}

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

-- a 64K cache, with a Float taking 13 bytes in Bytestring,
-- implies a chunk size of 5041
chunk :: Int
chunk = 5000

chunks :: Int -> [Int]
chunks d = let c = d `div` chunk
               m = d `mod` chunk
           in if m /= 0 then reverse (m:(replicate c chunk)) else (replicate c chunk)

putVector :: (Storable t, Binary t) => Vector t -> Data.Binary.Put.PutM ()
putVector v = mapM_ put $! toList v

getVector :: (Storable a, Binary a) => Int -> Get (Vector a)
getVector d = do
              xs <- replicateM d get
              return $! fromList xs

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

toByteString :: Storable t => Vector t -> BS.ByteString
toByteString v = BS.PS (castForeignPtr fp) (sz*o) (sz * dim v)
  where
    (fp,o,_n) = unsafeToForeignPtr v
    sz = sizeOf (v@>0)

fromByteString :: Storable t => BS.ByteString -> Vector t
fromByteString (BS.PS fp o n) = r
  where
    r = unsafeFromForeignPtr (castForeignPtr (updPtr (`plusPtr` o) fp)) 0 n'
    n' = n `div` sz
    sz = sizeOf (r@>0)

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

instance (Binary a, Storable a) => Binary (Vector a) where

    put v = do
            let d = dim v
            put d
            mapM_ putVector $! takesV (chunks d) v

    -- put = put . v2bs

    get = do
          d <- get
          vs <- mapM getVector $ chunks d
          return $! vjoin vs

    -- get = fmap bs2v get

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

{- | creates a Vector of the specified length using the supplied function to
     to map the index to the value at that index.

@> buildVector 4 fromIntegral
4 |> [0.0,1.0,2.0,3.0]@

-}
buildVector :: Storable a => Int -> (Int -> a) -> Vector a
buildVector len f =
    fromList $ map f [0 .. (len - 1)]

-- | zip for Vectors
zipVector :: (Storable a, Storable b, Storable (a,b)) => Vector a -> Vector b -> Vector (a,b)
zipVector = zipVectorWith (,)

-- | unzip for Vectors
unzipVector :: (Storable a, Storable b, Storable (a,b)) => Vector (a,b) -> (Vector a,Vector b)
unzipVector = unzipVectorWith id

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

max_stars_repo_name: schnecki/hmatrix-float

max_issues_repo_name: schnecki/hmatrix-float

max_forks_repo_name: schnecki/hmatrix-float


text:
import ActivationFunction
import Numeric.LinearAlgebra

main = do
    let x = (1><2) [1.0, 0.5] :: Matrix R
        y = forward x
    print y

forward x =
    let w1 = (2><3) [0.1, 0.3, 0.5, 0.2, 0.4, 0.6] :: Matrix R
        w2 = (3><2) [0.1, 0.4, 0.2, 0.5, 0.3, 0.6] :: Matrix R
        w3 = (2><2) [0.1, 0.3, 0.2, 0.4] :: Matrix R
        b1 = (1><3) [0.1, 0.2, 0.3] :: Matrix R
        b2 = (1><2) [0.1, 0.2] :: Matrix R
        b3 = (1><2) [0.1, 0,2] :: Matrix R
        a1 = (x <> w1) + b1
        z1 = sigmoid a1
        a2 = (z1 <> w2) + b2
        z2 = sigmoid a2
        a3 = (z2 <> w3) + b3
    in id a3


text:
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}

module DispatchLoop (dispatchLoop) where

import qualified Sound.ALSA.Sequencer.Connect as Connect
import qualified Sound.ALSA.Sequencer.Address as Addr
import qualified Sound.ALSA.Sequencer.Client as Client
import qualified Sound.ALSA.Sequencer.Port as Port
import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Sound.ALSA.Sequencer as SndSeq

import qualified Data.Foldable as DF
import qualified Data.List as DL
import qualified Data.Set as DS
import qualified Data.Map as DM
import qualified Data.IntSet as IS
import qualified Data.Sequence as SQ
import GHC.Word
import Data.Maybe
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Control.Monad

import Statistics

import Control.Exception
import Control.Concurrent
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Lazy

import ChordData
import ChordUtils
import EventUtils
import LoopConfig
import ChordMatrix
import ShowStatus

import WithCli

data Options = Options {
  channel :: Maybe Int,
  config :: Maybe String,
  cmdelay :: Maybe Int,
  codelay :: Maybe Int,
  histlen :: Maybe Int
} deriving (Show, Generic, HasArguments)

getus :: IO Integer

getus = (*1000000) `fmap` getPOSIXTime >>= return . round

loadcr :: Maybe String -> IO (ChordRouting, Maybe UTCTime)

loadcr Nothing = return (chordMatrix, Nothing)
loadcr (Just f) = tryLoad f `catch` \(e :: SomeException) -> do
  putStrLn $ show e
  cfgt <- getCfgTime f
  return (chordMatrix, cfgt)

fromMaybeMax n d mbn = max n (fromMaybe d mbn)

dispatchLoop :: SndSeq.T SndSeq.DuplexMode ->
                Connect.T ->
                Options -> IO ()

dispatchLoop h ci opt@Options {channel = chan, config = s} = do
  dtt <- getus
  (cr, mbcfgt) <- loadcr s
  evalStateT loop LoopStatus {
    h = h,
    ci = ci,
    chan = Event.Channel $ fromIntegral $ fromMaybe 0 chan,
    cr = cr,
    is = IS.empty,
    pvl = 0,
    os = DS.empty,
    dt = dtt,
    diff = 0,
    tsamples = IS.empty,
    age = 0,
    status = ChordOff,
    ping = Nothing,
    ckcfg = Nothing,
    cfgtime = mbcfgt,
    cfgpath = s,
    cmdly = fromMaybeMax 1 10 (cmdelay opt),
    codly = fromMaybeMax 1 10 (codelay opt),
    portmap = DM.empty,
    statmsg = "",
    statchg = False,
    chstlen = fromMaybeMax 1 3 (histlen opt),
    chist = SQ.empty,
    stats = Stats 0 0 0 0
}

loop :: StateT LoopStatus IO ()

loop = do
  showstat
  ports <- gets cr >>= (return . listPorts)
  pm <- gets portmap
  let newports = ports DL.\\ DM.keys pm
  hh <- gets h
  newconns <- lift $ mapM (makePort hh) newports
  modify (\s -> s {portmap = DM.union pm (DM.fromList $ zip newports newconns)})
  cn <- gets chan
  pn <- gets ping
  e <- gets h >>= lift . Event.input
  case eventChannel e of
    Nothing | pingEvent (Event.body e) -> handleChords
    Nothing | ckcfgEvent (Event.body e) -> checkConfig
    Just ec | ec == cn -> do
      if isNothing pn then (do
        let pn' = e {Event.body = Event.CustomEv Event.User0 Event.customZero}
        let ck' = e {Event.body = Event.CustomEv Event.User1 Event.customZero}
        modify (\s -> s {ping = Just pn', ckcfg = Just ck'})
        sendPingDelay' ckcfg 1000000)
      else return ()
      loop' e
    _ -> loop

loop' e = do
  case Event.body e of
    Event.CtrlEv ce ctrl | allNotesOff ce ctrl -> cancelChord
    Event.NoteEv ne note -> processNote ne note
    _ -> do
      loop

checkConfig = do
  cfgp <- gets cfgpath
  cfgt <- gets cfgtime
  case (cfgp, cfgt) of
    (Just fp, Just ft) -> do
      mbnwt <- lift $ getCfgTime fp
      case mbnwt of
        Just nwt -> do
          if nwt > ft
            then do
              crr <- gets cr
              (ncr, mbxx) <- lift (tryLoad fp `catch`
                                    (\(_::SomeException) -> return (crr, Nothing)))
              let sucf = case mbxx of
                           Just _ -> "success"
                           Nothing -> "failure"
              updstat ("reload config " ++ sucf)
              modify (\s -> s {cr = ncr, cfgtime = Just nwt})
            else return ()
          sendPingDelay' ckcfg 1000000
          loop
        _ -> loop
    _ -> loop

handleChords = do
  iss <- gets is
  ddff <- gets diff
  let dxff = fromIntegral ddff
  stt <- gets status
  hh <- gets h
  pvll <- gets pvl
  modify (\s -> s {pvl = IS.size iss})
  case stt of
    ChordOn d -> do
      case (IS.size iss `compare` pvll) of
        GT -> do
          updstat "chord growing while playing ignore"
          sendPingDelay d
          loop
        LT -> do
          updstat "chord dropping"
          modify (\s -> s {status = ChordOff, is = IS.empty})
          cancelChord
          loop
        EQ -> do
          modify (\s -> s {status = ChordOn d})
          sendPingDelay d
          loop
    Pinged -> case IS.size iss of
      _ | IS.size iss < pvll -> do
        modify (\s -> s {status = ChordOff, is = IS.empty})
        loop
      0 -> do
        modify (\s -> s {status = ChordOff})
        cancelChord
        loop
      1 -> do
        modify (\s -> s {status = ChordOff})
        loop
      _ | IS.size iss >= 2 -> do
        updstat "chord mature"
        ndxff <- compStats dxff
        let delay = ndxff * 10
        modify (\s -> s {status = Aging delay})
        sendPingDelay delay
        loop
    Aging d -> do
      case (IS.size iss `compare` pvll) of
        GT -> do
          sendPingDelay d
          loop
        LT -> do
          modify (\s -> s {status = ChordOff, is = IS.empty})
          cancelChord
          loop
        EQ -> do
          modify (\s -> s {status = ChordOn d})
          sendPingDelay d
          crr <- gets cr
          hist <- gets chist >>= return . DF.toList
          let chints = toIntervals iss
              mboc = routeChord hist crr (intervals chints)
          case mboc of
            Nothing -> do
              modify (\s -> s {status = ChordOff, is = IS.empty })
              loop
            _ -> do
              addHistory chints
              playChords mboc
              loop
    _ -> loop
  loop

playChords Nothing = loop

playChords (Just oc) = do
  pm <- gets portmap
  let mbcn = DM.lookup (outport oc) pm
  case mbcn of
    Nothing -> return ()
    Just cc -> do
      iss <- gets is
      let pc = buildChord iss oc
      oss <- gets os
      modify (\s -> s {statchg = True, os = DS.insert (outport oc, cc, outchan oc, pc) oss})
      hh <- gets h
      lift $ playChord hh cc (outchan oc) pc True
  playChords $ also oc

processNote ne note = do
  cn <- gets chan
  hh <- gets h
  let pitch = Event.unPitch $ Event.noteNote note
      velo = Event.unVelocity $ Event.noteVelocity note
  let note' = Event.simpleNote cn
                               (Event.Pitch pitch)
                               (Event.noteVelocity note)
  iss <- gets is
  let is' = compactChord $ case (ne, velo) of
              (Event.NoteOn, 0) -> IS.delete (fromIntegral pitch) iss
              (Event.NoteOn, _) -> IS.insert (fromIntegral pitch) iss
              (Event.NoteOff, _) -> IS.delete (fromIntegral pitch) iss
              _ -> iss
  cdtt <- lift getus
  pdtt <- gets dt
  modify (\s -> s {is = is', dt = cdtt})
  case IS.size is' of
    0 -> return ()
    1 -> modify (\s -> s {diff = 0})
    _ -> modify (\s -> s {diff = cdtt - pdtt})
  stt <- gets status
  case stt of
    _ | stt `elem` [ChordOff] -> do
      sendPingDelay 0
      modify (\s -> s {status = Pinged })
      return ()
    _ -> return ()
  loop

cancelChord = do
  hh <- gets h
  oss <- gets os
  forM_ oss $ \(_, cc, ochan, is) -> lift $ playChord hh cc ochan is False
  modify (\s -> s {statchg = True, is = IS.empty, os = DS.empty, status = ChordOff })
  loop

sendPingDelay d = sendPingDelay' ping d

sendPingDelay' ppp d = do
  hh <- gets h
  p <- gets ppp
  lift $ forkOS $ do
    threadDelay d
    sendPing hh p
  return ()

sendPing hh ping = do
  case ping of
    Just p -> do
      Event.outputDirect hh p
      return ()
    _ -> return ()
  Event.drainOutput hh
  return ()

compStats d = do
  samples <- gets tsamples
  let samples' = IS.insert d samples
  let st = map fromIntegral $ IS.toList samples'
  let tmean = mean st
  let tstd = stddev st
  let outlrs = filter (> (tmean + 3 * tstd)) st
  let keep = if length st > 10
               then filter (<= (tmean + 3 * tstd)) st
               else st
  let newmean = mean keep
  let newsamp = IS.fromList $ map round keep
  let newsamp' = if IS.size newsamp > 50 then IS.delete (IS.findMax newsamp) newsamp else newsamp
  modify (\s -> s {tsamples = newsamp', stats = Stats {
                                                  meann = tmean,
                                                  stddevv = tstd,
                                                  minn = fromIntegral $ IS.findMin samples',
                                                  maxx = fromIntegral $ IS.findMax samples'
                                                      }})
  return $ round newmean

max_stars_repo_name: dmgolubovsky/chordemux

max_issues_repo_name: dmgolubovsky/chordemux

max_forks_repo_name: dmgolubovsky/chordemux


text:
{-# LANGUAGE NoMonomorphismRestriction #-}
module Cargo(Cargo, Market,
  randomCargo, randomMarket,
  showCargo, showMarket,
  fromMarket, fromCargo,
  withdraw,
  tradeScreen, takeScreen)
where

import System.Random
import Text.Printf
import Data.List
import Control.Monad
import Control.Monad.State as State

import qualified Data.Edison.Assoc.StandardMap as M
import Graphics.Rendering.OpenGL as OpenGL
import Graphics.UI.SDL as SDL
import Graphics.Rendering.FTGL as FTGL

import Statistics
import TextScreen
import Space
import SDLUtils

type Cargo = M.FM String Int
type Market = M.FM String (Int, Int)

cargonames = sort ["Grain", "Fruit", "Gem stones", "Firearms"]

randomCargo :: IO String
randomCargo = chooseIO cargonames

showCargo :: Cargo -> String
showCargo c | M.null c  = "No cargo\n"
            | otherwise = concatMap (\(k, v) -> printf "%-20s-%4d\n" k v) (M.toOrdSeq c)

showMarket :: Market -> String
showMarket m = title ++ infos
  where title = printf "%-16s%8s%8s\n" "Good" "Quantity" "Price"
        infos = concatMap (\(n, (q, p)) -> printf "%-20s%10d%10d\n" n q p) (M.toOrdSeq m)

numCargoItems = length cargonames

randomMarket :: IO Market
randomMarket = do
  let names = cargonames
  prices <- replicateM numCargoItems $ randomRIO (5, 15)
  quantities <- replicateM numCargoItems $ randomRIO (0, 30)
  return $ M.fromSeq $ zip names (zip quantities prices)

fitCargo :: Cargo -> [(String, Int)]
fitCargo c = map (\s -> (s, M.lookupWithDefault 0 s c)) cargonames

cargoToMarket :: Cargo -> Market
cargoToMarket cargo =
  foldl' (\acc x -> M.insert x (M.lookupWithDefault 0 x cargo, 0) acc) M.empty cargonames

fromMarket :: Int -> String -> Market -> Market
fromMarket q = toMarket (-q)

fromCargo :: Int -> String -> Cargo -> Cargo
fromCargo q = toCargo (-q)

toMarket :: Int -> String -> Market -> Market
toMarket q = M.adjust (\(q', p) -> (q' + q, p))

toCargo :: Int -> String -> Cargo -> Cargo
toCargo q n = M.insertWith (+) n q

showMarketAndCargo :: Bool -> Market -> Cargo -> String
showMarketAndCargo t m c = title ++ infos
  where title = if t
                  then printf "%-14s%9s%6s%6s\n" "Good" "Quantity" "Price" "Cargo"
                  else printf "%-17s%-12s%-9s\n" "Good" "Captured" "Cargo"
        infos = if t
                  then concatMap (\((n, (q, p)), (_, q')) -> printf "%-14s%9d%6d%6d\n" n q p q') (zip (M.toOrdSeq m) (fitCargo c))
                  else concatMap (\((n, (q, _)), (_, q')) -> printf "%-17s%-12d%-9d\n" n q q') (zip (M.toOrdSeq m) (fitCargo c))

type TradeState = (Market, Cargo, Int, Int)
type TakeState = (Cargo, Cargo, Int, Int)

buy :: Int -> String -> StateT TradeState IO ()
buy q n = do
  (market, cargo, cash, holdspace) <- State.get
  let mval = M.lookupM n market
  case mval of
    Nothing      -> return ()
    Just (q', p) -> do
      let totalq = minimum [max 0 q', q, holdspace]
      let totalp = totalq * p
      if totalp > cash || totalq == 0
        then return ()
        else do
          State.put (fromMarket totalq n market,
               toCargo totalq n cargo,
               subtract totalp cash,
               holdspace - totalq)

sell :: Int -> String -> StateT TradeState IO ()
sell q n = do
  (_, cargo, _, _) <- State.get
  let mval = M.lookupM n cargo
  case mval of
    Nothing -> return ()
    Just q' -> buy (negate (min q' q)) n

tradeScreen :: String -> Font -> Font -> StateT TradeState IO ()
tradeScreen = screenGeneric True

withdraw :: Int -> String -> StateT TradeState IO ()
withdraw q n = withStateT (\(m, c, _, hold) -> (m, c, maxBound, hold)) (buy q n)

screenGeneric :: Bool -> String -> Font -> Font -> StateT TradeState IO ()
screenGeneric trade str f1 f2 = do
  (market, _, _, _) <- State.get
  let exitb = ((100, 100), (100, 30))
      buybuttons  = map (\i -> ((550, 440 - 50 * fromIntegral i), (100, 30))) [1..numCargoItems]
      sellbuttons = map (\i -> ((680, 440 - 50 * fromIntegral i), (100, 30))) [1..numCargoItems]
      buyactions  = map (\(n, (_, _)) -> buy  1 n >> return Nothing) (M.toOrdSeq market)
      sellactions = map (\(n, (_, _)) -> sell 1 n >> return Nothing) (M.toOrdSeq market)
      allbuttons  = exitb : (buybuttons ++ sellbuttons)
      allactions  = return (Just ()) : (buyactions ++ sellactions)
      bttoaction  = zip allbuttons allactions
  let handleInput = do
        events <- liftIO $ pollAllSDLEvents
        let mbutton = mouseClickInAny height [ButtonLeft] allbuttons events
        case mbutton of
          Nothing -> return Nothing
          Just n  -> case lookup n bttoaction of
                       Just act -> act
                       Nothing  -> return Nothing
  loopTextScreen (do (market', cargo, cash, holdspace) <- State.get
                     liftIO $ makeTextScreen (10, 500)
                               [(f1, Color4 1.0 1.0 1.0 1.0, str),
                                (f2, Color4 1.0 1.0 0.0 1.0, showMarketAndCargo trade market' cargo),
                                (f1, Color4 1.0 1.0 1.0 1.0, if trade then "Cash: " ++ show cash else ""),
                                (f1, Color4 1.0 1.0 1.0 1.0, "Hold space: " ++ show holdspace)]
                               (drawButton (Just ("Exit", f1)) exitb >>
                                mapM_ (drawButton (Just (if trade then "Buy" else "Take", f1))) buybuttons >>
                                mapM_ (drawButton (Just (if trade then "Sell" else "Leave", f1))) sellbuttons))
                 handleInput

takeScreen :: String -> Font -> Font -> StateT TakeState IO ()
takeScreen str f1 f2 = do
  (stuff, cargo, cash, hold) <- State.get
  (_, cargo', _, hold') <- liftIO $ execStateT (screenGeneric False str f1 f2) (cargoToMarket stuff, cargo, cash, hold)
  State.put (stuff, cargo', cash, hold')


text:
module Main where

import Numeric.GSL.Integration
import Complex
import System.IO
import Data.Fixed
import Data.Array
import Data.Maybe
import Control.Monad
import Data.Packed.Matrix
import Data.Packed.Vector
import Numeric.LinearAlgebra.Algorithms
import qualified Data.IntMap as M

data Ctree a b = End (a,b)
               | Branche (a,b) [Ctree a b]
    deriving (Show)

-- Given N boxes, return all possible combinations of P particles in these boxes.

c n p = g 1 0
    where g i a | i == n     = [ End (n, p - a) ]
                | a == p - 1 = [ End (i, 1) ] ++ g (i + 1) a
                | otherwise  = [ if r == p - a
                                 then End (i,r)
                                 else Branche (i,r) $ g (i+1) (a + r) |
                                                         i <- [i..n-1],
                                                         r <- [1..p-a] ]
                                                            ++ [ End (n, p-a) ]

-- Convert combinations of Ctree do list format

cl [] = []
cl ((End p):l) = [p]:cl l
cl ((Branche p b):l) = (map (p:) $ cl b) ++ cl l

-- Create newstates aplying A+(i)A+(j)A(k)A(l) operator on state 'a'

newState i j k l n a = do cp i =<< cp j =<< dp k =<< dp l a
    where
        cp i a = if a!i < n
                 then Just $ a//[(i,a!i + 1)]
                 else Nothing

        dp i a = if a!i > 0
                 then Just $ a//[(i,a!i - 1)]
                 else Nothing

-- List all states that can have operator A+(i)A+(j)A(k)A(l) applied

possibleStates i j k l nb np = filter (isJust . newState i j k l np) . aStates nb

-- Autovalue of operator A+(i)A+(j)A(k)A(l)

value i j k l n a = sqrt $ ((a!i + 1)*(a!j + 1)*a!k*a!l) / ((prod $ elems a')*(prod $ elems a))
    where a' = fromJust $ newState i j k l n a
          prod x = prod' x 1
          prod' [] a = a
          prod' (x:xs) a | x == 0 = prod' xs a
                         | otherwise = prod' xs a*x

sumValues i j k l n = sum . map (value i j k l n)

-- Convert state from List to Array type

aStates nb = map (listArray (1,nb) (repeat 0) //)

-- Total quasi-momentum of base state 'a'

qt a = qt' a 0 (min + 1)
    where qt' a t i | i == max  = mod (t + (max - 1)*a!max) max
                    | otherwise = qt' a (t + (i-1)*a!i) (i + 1)
          (min,max) = bounds a

-- Group states by quasi-momentum

groupQt states = M.fromListWith (++) $ map (\x -> (qt x, [x])) states

-- Print grouped states

printGroups states = do mapM_ printG states
    where printG (n,s) = do putStrLn $ (show n) ++ ":"
                            mapM_ (putStrLn.show.elems) s
                            putStrLn ""

na = array (0, 4) [ (0, 1.81772),
                    (1, 1.75048),
                    (2, 0.998368),
                    (3, 0.111417),
                    (4, 1.19828) ]

a = array (0,4) [ (0, 1.94699),
                  (1, 1.98301),
                  (2, 2.29932),
                  (3, 2.49687),
                  (4, 2.22725) ]

n = 5 :: Int
nd = 5 :: Double

bloch phi w a b = exp(0 :+ a*phi)*exp(0 :+ (-wa*phy))*(cos(b*phy)*sin(b*pi/nd)*cos(wa*pi/nd) :+ sin(b*phy)*cos(b*pi/nd)*sin(wa*pi/nd))
    where phy = -pi/nd + mod' (phi + pi/nd) (2*pi/nd)
          wa = a - w

cbloch phi w a b = conjugate $ bloch phi w a b

toInt phi w i j k l = 1/((na!i)*(na!j)*(na!k)*(na!l))*
                            cbloch phi w (fi i) (a!i) * cbloch phi w (fi j) (a!j) *
                            bloch phi w (fi k) (a!k) * bloch phi w (fi l) (a!l)
      where fi = fromIntegral

-- Calculate matrix for each quasi-momentum

matFrom :: Int -> Int -> Array Int (Array Int Int) -> Double -> Array (Int,Int) Double
matFrom nb np gs c = matrix
    where matrix = array ((1,1),(size,size)) [((i,j), f i j) | i <- [1..size], j <- [1..size]]
          f i j | i > j =  matrix!(j,i)
                | otherwise = energy i j + c*(sum $ map (\x -> sq x (gs!j)*(im!x)) [ (oi,oj,ok,ol) | oi <- [1..nb],
                                                                                oj <- [1..nb],
                                                                                ok <- [1..nb], ol <- [1..nb],
                                                                                newState oi oj ok ol np (gs!j) == Just (gs!i) ])
          sq (i,j,k,l) s = sqrt $ (fi $ (s!i) + 1)*(fi $ (s!j) + 1)*(fi $ s!k)*(fi $ s!l)
          energy i j | i == j = e (gs!j) 1 0
                     | otherwise = 0
          e s i t | i == nb = t*(fi $ s!i)
                  | otherwise = e s (i+1) (t + (a!(i-1))*(fi $ s!i))
          size = snd $ bounds gs
          im = intMatrix nb
          fi = fromIntegral

intMatrix n = array ((1,1,1,1),(n,n,n,n)) [ ((i,j,k,l), integrate (i,j,k,l) n) | i <- [1..n], j <- [1..n], k <- [1..n], l <- [1..n] ]

integrate (i,j,k,l) n | mod (i+j-k-l) n == 0 = fst $ integrateQAGS 1E-6 1000 (\x -> realPart $ toInt x 0.4 (i-1) (j-1) (k-1) (l-1)) 0 (2*pi)
                      | otherwise = 0

-- Create Matrix

genMatrix nb np k cst = matFrom nb np (listArray (1,length $ qmGroup M.! k) $ qmGroup M.! k) cst
    where qmGroup = groupQt $ aStates nb $ cl $ c nb np
          qmKeys = M.keys qmGroup

-- Print eigenvalues and eigenstates to all states, group by quasi-momentum

printStates nb np cst file = do
    let qmGroup = groupQt $ aStates nb $ cl $ c nb np
        qmKeys = M.keys qmGroup

        calEig n x = eig $ (n><n) $ elems x
        printEig (s,v) = do forM_ (zip (toList s) (toLists v)) $ \(e,v) -> do
                                 hPutStrLn file $ "Eigenvalue: " ++ (show e) ++ "\n"
                                 mapM_ (\n -> hPutStrLn file $ (show n) ++ " ") v
                                 hPutStrLn file "\n"

    forM_ qmKeys $ \k -> do
        let kSize = length $ qmGroup M.! k
        hPutStrLn file $ "quasi-momentum: " ++ (show k) ++ "\n"
        printEig $ calEig (kSize) $ matFrom nb np (listArray (1, kSize) $ qmGroup M.! k) cst

main = do
    file <- openFile "output" WriteMode
    printStates 5 10 1 file
    hClose file

max_stars_repo_name: aivuk/quantum-haskell

max_issues_repo_name: aivuk/quantum-haskell

max_forks_repo_name: aivuk/quantum-haskell


text:
module Main where

import Criterion.Main

import Control.Monad
import Data.IORef
import Data.Random
import Data.Random.Distribution.Uniform
import Data.Vector (Vector, fromList)
import System.Random.MWC (GenIO, uniformVector, createSystemRandom, create)
import qualified System.Random.MWC as MWC
import Statistics.Sample (mean)

import Data.Random.Source.PureMT (newPureMT)
import Data.Random.Source.DevRandom

k = 10000

randomListFu :: RVar (Vector Double)
randomListFu = fromList <$> replicateM k stdUniform

randomListMWC :: GenIO -> IO (Vector Double)
randomListMWC gen = fromList <$> replicateM k (MWC.uniform gen)

main :: IO ()
main = do
  mwc <- createSystemRandom
  puremt <- newPureMT >>= newIORef

  defaultMain
    [ bgroup "MWC vs randomu-fu abstraction"
      [ bench "random-fu"
        $ nfIO (mean <$> sampleFrom mwc randomListFu)
      , bench "mw'"
        $ nfIO (mean <$> randomListMWC mwc)
      ]
    , bgroup "Different sources"
      [ bench "pureMT"
        $ nfIO (mean <$> sampleFrom puremt randomListFu)
      , bench "std"
        $ nfIO (mean <$> sample randomListFu)
      , bench "urandom"
        $ nfIO (mean <$> sampleFrom DevURandom randomListFu)
      ]
    ]


text:
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
module Q.Options.ImpliedVol.InterpolatingSmile where

import Q.Types
import Q.SortedVector (SortedVector)
import Numeric.LinearAlgebra (Vector)
import Q.Options.ImpliedVol.TimeSlice
import Q.Options.ImpliedVol.StrikeInterpolation
import Q.Interpolation
data InterpolatingSmile = StrikeSmile
  {
    smileForward :: Forward
  , smileTenor   :: YearFrac
  , smileStrikes :: SortedVector Strike
  , smileVols    :: Vector Vol
  , smileInterpolation :: StrikeInterpolation
  , smileExtrapolation :: StrikeExtrapolation
  , smileMinStrike :: Strike
  , smileMaxStrike :: Strike
  }

instance TimeSlice InterpolatingSmile Strike where
  totalVar smile@StrikeSmile{..} k = TotalVar $ scale smileTenor (sigma * sigma) where
    (Vol sigma) = impliedVol smile k

impliedVol StrikeSmile{..} = interpolateV smileInterpolation smileStrikes smileVols

max_stars_repo_name: ghais/lowq

max_issues_repo_name: ghais/lowq

max_forks_repo_name: ghais/lowq


text:
-- Copyright (c) 2019-2021 China University of Water Resources and Electric Power,
-- All rights reserved.
{-# LANGUAGE OverloadedStrings #-}

module Main (
    main      -- IO()
    ) where

import Control.Monad
import qualified System.IO.Streams as S
import System.IO
import Database.MySQL.Base
import Corpus
import SentParse
import Database
import Statistics

{- This program create syntactic and semantic parsing results for Chinese sentences. Please run MySQL Workbench or other similiar tools, connecting MySQL database 'ccg4c', and querying table 'corpus' for revising parts of speech as well as CCG syntactic types, and the MySQL server is running on a certain compute in Hua-shui campus. The program includes commands for parsing sentences and storing results in database 'ccg4c', as following.
    ?   Display this message.
    1   Get the raw part-of-speech marked sentence (namely column raw_sent) given by value of column 'serial_num'.
    2   Copy column 'raw_sent' to column 'raw_sent2' to be revised for a given row. After executing this command, part-of-speech of every word in this sentence should be revised, then set column 'pos_check' as 1. If the value of column 'pos_check' of this row is 0, this child command will be banned.
    3   Get the part-of-speech marks revised sentence (namely column raw_sent2) given by value of column 'serial_num'.
    4   Create categorial column 'cate_sent' from part-of-speech column 'raw_sent2' for a given row. Before executing this child command, parts of speech of all words in this sentence should be revised, and set column 'pos_check' as 1. If the value of column 'pos_check' of this row is 0, this child command will be banned.
    5   Copy categorial column 'cate_sent' to column 'cate_sent2' to be revised for a given row. After executing this command, CCG-syntactic types of every words in this sentence should be revised, then set column 'cate_check' as 1.
    6   Get the CCG-marked sentence (namely column cate_sent) given by value of column 'serial_num'.
    7   Get the CCG mark-revised sentence (namely column cate_sent2) given by value of column 'serial_num'.
    8   Parse the sentence given by value of column 'serial_num'.
    9   Display parsing result of the sentence given by value of column 'serial_num'.
    A   Statistically analyze the database table 'corpus' and 'stru_gene'.
    0   Quit from this program.
 -}
main :: IO ()
main = do
    hSetBuffering stdout NoBuffering               -- Set buffering mode for stdout as no buffering.
    hSetBuffering stdin LineBuffering              -- Set buffering mode for stdin as line buffering.
    hSetEncoding stdout utf8                       -- Set encoding for stdout as UTF8
    hFlush stdout                                  -- Flush buffered data to assure changing the encoding.

    putStrLn " Chinese CCG parser (build 0.2.5.0)"
    putStrLn " Copyright (c) 2019-2021 China University of Water Resources and Electric Power, All rights reserved."

    (username, ok) <- login 1
    if ok
      then interpreter username
      else return ()

-- The n'th User authentication, returns user name and its authentication result.
login :: Int -> IO (String, Bool)
login 4 = do
    putStrLn " Login failed! input attempts have reached maximal times."
    return ("", False)
login n = do
    putStr " Login: "
    username <- getLine
    putStr " Password: "
    password <- getLine

    conn <- getConn
    stmt <- prepareStmt conn "select * from user where name = ? && password = ?"
    (defs, is) <- queryStmt conn stmt [toMySQLText username, toMySQLText password]   --([ColumnDef], InputStream [MySQLValue])
    row <- S.read is
    let row' = case row of
                 Just x -> x
                 Nothing -> []
    skipToEof is
    if row' == []
      then do
        putStrLn " User or password is error."
        login (n + 1)
      else do
        putStrLn $ " Welcome " ++ fromMySQLText (row'!!1) ++ " :)"    -- The second element is true name of this user.
        return (username, True)

-- Check whether current user is intellectual property creator (IPC) of the row indicated by serial_num.
checkIpc :: Int -> String -> IO Bool
checkIpc sn username = do
    conn <- getConn
    stmt <- prepareStmt conn "select ipc from corpus where serial_num = ? "
    (defs, is) <- queryStmt conn stmt [toMySQLInt32 sn]
    row <- S.read is
    let row' = case row of
                 Just x -> x
                 Nothing -> []
    skipToEof is
    if row' == []
      then do
        putStrLn "checkIpc: No this row."
        return False
      else do
        if (fromMySQLText (row'!!0) == username)
          then return True
          else return False

-- Command interpreter for given user.
interpreter :: String -> IO ()
interpreter username = do
    putStrLn " ? -> Display command list."
    putStrLn " 1 -> Get raw part-of-speech marked sentence indicated by serial_num."
    putStrLn " 2 -> Copy raw sentence indicated by serial_num to column raw_sent2"
    putStrLn " 3 -> Get the revised part-of-speech marked sentence indicated by serial_num."
    putStrLn " 4 -> Create CCG-marked sentence from its revised part-of-speech marks."
    putStrLn " 5 -> Get CCG-marked sentence indicated by serial_num."
    putStrLn " 6 -> Copy CCG-marked sentence indicated by serial_num to column cate_sent2."
    putStrLn " 7 -> Get revised CCG-marked sentence indicated by serial_num."
    putStrLn " 8 -> Parse the sentence indicated by serial_num."
    putStrLn " 9 -> Display parsing Trees of the sentence indicated by serial_num."
    putStrLn " A -> Statistically analyze the database table corpus and stru_gene"
    putStrLn " 0 -> doQuit"
    putStr "Please input command: "
    line <- getLine
    if notElem line ["?","1","2","3","4","5","6","7","8","9","A","0"]
      then do
             putStrLn "Invalid input."
             interpreter username
      else case line of
             "?" -> interpreter username
             "1" -> doGetRawSentForASent username
             "2" -> doCopyRawSentForASent username
             "3" -> doGetRawSent2ForASent username
             "4" -> doPosToCateForASent username
             "5" -> doGetCateSentForASent username
             "6" -> doCopyCateForASent username
             "7" -> doGetCateSent2ForASent username
             "8" -> doParseSent username
             "9" -> doDisplayTreesForASent username
             "A" -> doStatisticalAnalysis username
             "0" -> doQuit

-- 1. Get raw part-of-speech marked sentence indicated by serial_num.
doGetRawSentForASent :: String -> IO ()
doGetRawSentForASent username = do
    putStr "Please input value of 'serial_num': "
    line <- getLine
    let sn = read line :: Int
    getRawSentForASent sn >>= putStrLn
    interpreter username

{- 2. Copy raw sentence indicated by serial_num to column 'raw_sent2', here 'username' MUST
   be the intellectual property creator (ipc) of the row indicated by serial_num.
 -}
doCopyRawSentForASent :: String -> IO ()
doCopyRawSentForASent username = do
    putStr "Please input value of 'serial_num': "
    line <- getLine
    let sn = read line :: Int

    ok <- checkIpc sn username
    if ok
      then do                          -- Pass authentication!
        conn <- getConn
        stmt <- prepareStmt conn "select pos_check from corpus where serial_num = ?"
        (defs, is) <- queryStmt conn stmt [toMySQLInt32 sn]            --([ColumnDef], InputStream [MySQLValue])
        pos_check <- S.read is
        let pos_check' = case pos_check of
                           Just x -> fromMySQLInt8 (head x)
                           Nothing -> error "doCopyRawSentForASent: No pos_check was read."
        skipToEof is                                                   -- Go to the end of the stream.
        if pos_check' == 1
          then do
             putStrLn "Creating column 'raw_sent2' failed because column 'pos_check' is 1."
             interpreter username
          else if pos_check' == 0
                 then do
                   copyRawSentForASent sn
                   interpreter username
                 else do
                   putStrLn "pos_check value is abnormal."
                   interpreter username
      else do
        putStrLn "Copying failed! you are not the intellectual property creator of this sentence."
        interpreter username

-- 3. Get the revised part-of-speech marked sentence indicated by serial_num.
doGetRawSent2ForASent :: String -> IO ()
doGetRawSent2ForASent username = do
    putStr "Please input value of 'serial_num': "
    line <- getLine
    let sn = read line :: Int
    getRawSent2ForASent sn >>= putStrLn
    interpreter username

{- 4. Create CCG-marked sentence from its revised part-of-speech marks, here 'username' MUST
   be the intellectual property creator (ipc) of the row indicated by serial_num.
 -}
doPosToCateForASent :: String -> IO ()
doPosToCateForASent username = do
    putStr "Please input value of 'serial_num': "
    line <- getLine
    let sn = read line :: Int

    ok <- checkIpc sn username
    if ok
      then do                          -- Pass authentication!
        conn <- getConn
        stmt <- prepareStmt conn "select pos_check from corpus where serial_num = ?"
        (defs, is) <- queryStmt conn stmt [toMySQLInt32 sn]            --([ColumnDef], InputStream [MySQLValue])
        pos_check <- S.read is
        let pos_check' = case pos_check of
                           Just x -> fromMySQLInt8 (head x)
                           Nothing -> error "doPosToCateForASent: No pos_check was read."
        skipToEof is                                                   -- Go to the end of the stream.
        if pos_check' == 0
          then do
             putStrLn "Creating column 'cate_sent' failed because column 'pos_check' is 0."
             interpreter username
          else if pos_check' == 1
                 then do
                   posToCateForASent sn
                   interpreter username
                 else do
                   putStrLn "pos_check value is abnormal."
                   interpreter username
      else do
        putStrLn "Creating CCG marks failed! you are not the intellectual property creator of this sentence."
        interpreter username

-- 5. Get CCG-marked sentence indicated by serial_num.
doGetCateSentForASent :: String -> IO ()
doGetCateSentForASent username = do
    putStr "Please input value of 'serial_num': "
    line <- getLine
    let sn = read line :: Int
    getCateSentForASent sn >>= putStrLn
    interpreter username

{- 6. Copy CCG-marked sentence indicated by serial_num to column cate_sent2, here 'username' MUST
   be the intellectual property creator (ipc) of the row indicated by serial_num.
 -}
doCopyCateForASent :: String -> IO ()
doCopyCateForASent username = do
    putStr "Please input value of 'serial_num': "
    line <- getLine
    let sn = read line :: Int

    ok <- checkIpc sn username
    if ok
      then do                          -- Pass authentication!
        conn <- getConn
        stmt <- prepareStmt conn "select cate_check from corpus where serial_num = ?"
        (defs, is) <- queryStmt conn stmt [toMySQLInt32 sn]            --([ColumnDef], InputStream [MySQLValue])
        cate_check <- S.read is
        let cate_check' = case cate_check of
                            Just x -> fromMySQLInt8 (head x)
                            Nothing -> error "doCopyCateForASent: No cate_check was read."
        skipToEof is                                                   -- Go to the end of the stream.
        if cate_check' == 1
          then do
             putStrLn "Creating column 'cate_sent2' failed because column 'cate_check' is 1."
             interpreter username
          else if cate_check' == 0
             then do
               copyCateForASent sn
               interpreter username
             else do
               putStrLn "cate_check value is abnormal."
               interpreter username
      else do
        putStrLn "Copying failed! you are not the intellectual property creator of this sentence."
        interpreter username

-- 7. Get revised CCG-marked sentence indicated by serial_num.".
doGetCateSent2ForASent :: String -> IO ()
doGetCateSent2ForASent username = do
    putStr "Please input value of 'serial_num': "
    line <- getLine
    let sn = read line :: Int
    getCateSent2ForASent sn >>= putStrLn
    interpreter username

{- 8. Parse the sentence indicated by serial_num, here 'username' MUST
   be the intellectual property creator (ipc) of the row indicated by serial_num.
 -}
doParseSent :: String -> IO ()
doParseSent username = do
    putStr "Please input value of 'serial_num': "
    line <- getLine
    let sn = read line :: Int

    ok <- checkIpc sn username
    if ok
      then do                          -- Pass authentication!
        conn <- getConn
        stmt <- prepareStmt conn "select cate_check, tree_check from corpus where serial_num = ?"
        (defs, is) <- queryStmt conn stmt [toMySQLInt32 sn]            --([ColumnDef], InputStream [MySQLValue])
        cate_tree_check <- S.read is
        let cate_tree_check' = case cate_tree_check of
                                 Just x -> x
                                 Nothing -> error "doParseSent: No cate_tree_check was read."
        skipToEof is                                                   -- Go to the end of the stream.
        let cate_check = fromMySQLInt8 (cate_tree_check'!!0)
        let tree_check = fromMySQLInt8 (cate_tree_check'!!1)
        if (cate_check == 0 || tree_check == 1)
          then do
             putStrLn $ "Parsing failed because cate_check = " ++ (show cate_check) ++ ", tree_check = " ++ (show tree_check)
             interpreter username
          else if (cate_check == 1 && tree_check == 0)
                 then do
                   getSentFromDB sn >>= getSent >>= parseSent sn
                   interpreter username
                 else do
                   putStrLn "Value of cate_check or tree_check is abnormal."
                   interpreter username
      else do
        putStrLn "Parsing failed! you are not the intellectual property creator of this sentence."
        interpreter username

-- 9. Display parsing Trees of the sentence indicated by serial_num.
doDisplayTreesForASent :: String -> IO ()
doDisplayTreesForASent username = do
    putStr "Please input value of 'serial_num': "
    line <- getLine
    let sn = read line :: Int
    readTree_String sn >>= sentToClauses >>= dispTree
    interpreter username

-- A. Do statistical analysis about Table corpus and stru_gene, and display results.
doStatisticalAnalysis :: String -> IO ()
doStatisticalAnalysis username = do
    putStrLn " ? -> Display command list."
    putStrLn " 1 -> Count in table 'corpus'."
    putStrLn " 2 -> Count in table 'stru_gene'."
    putStrLn " 0 -> Go back to the upper layer."
    putStr "Please input command: "
    line <- getLine
    if notElem line ["?","1","2","0"]
       then do
         putStrLn "Invalid input."
         doStatisticalAnalysis username
    else case line of
         "?" -> doStatisticalAnalysis username
         "1" -> doCountInCorpus username
         "2" -> doCountInStruGene username
         "0" -> interpreter username

-- A1. Do count in corpus and display results. 't' means from field 'tree', and 's' means from 'script'.
doCountInCorpus :: String -> IO ()
doCountInCorpus username = do
    putStrLn " ? -> Display command list."
    putStrLn " t1 -> Get total number of sentences."
    putStrLn " t2 -> Get clausal number in every sentence."
    putStrLn " t3 -> Get averge clausal number per sentence."
    putStrLn " t4 -> Get length of every clause in every sentence."
    putStrLn " t5 -> Get phrase number of every clause in every sentence."
    putStrLn " t6 -> Get clausal number of different clausal lengths."
    putStrLn " t7 -> Get clausal number of different parsing-tree depths."
    putStrLn " t8 -> Get frequency total and normalized frequencies of different CCG tags."
    putStrLn " t9 -> Get frequency total and normalized frequencies of different phrasal structures."
    putStrLn " tA -> Get frequency total and normalized frequencies of different type-tag-stru(s)."
    putStrLn " s1 -> Get transitive times of every clause in all sentences."
    putStrLn " s2 -> Get frequencies of different ransitive times in all clause parsing."
    putStrLn " s3 -> Get conversion-ruled list in parsing every clause."
    putStrLn " s4 -> Get number of abandoned phrases in parsing every clause."
    putStrLn " s5 -> Get number of abandoned not-recognizable phrases in parsing every clause."
    putStrLn " 0 -> Go back to the upper layer."

    putStr "Please input command: "
    line <- getLine
    if notElem line ["?","t1","t2","t3","t4","t5","t6","t7","t8","t9","tA","s1","s2","s3","s4","s5","0"]
       then do
         putStrLn "Invalid input."
         doCountInCorpus username
       else case line of
         "?" -> doCountInCorpus username
         "t1" -> doCountInTree username 1
         "t2" -> doCountInTree username 2
         "t3" -> doCountInTree username 3
         "t4" -> doCountInTree username 4
         "t5" -> doCountInTree username 5
         "t6" -> doCountInTree username 6
         "t7" -> doCountInTree username 7
         "t8" -> doCountInTree username 8
         "t9" -> doCountInTree username 9
         "tA" -> doCountInTree username 10
         "s1" -> doCountInScript username 1
         "s2" -> doCountInScript username 2
         "s3" -> doCountInScript username 3
         "s4" -> doCountInScript username 4
         "s5" -> doCountInScript username 5
         "0" -> interpreter username

-- A1_1. Display statistical results from field 'tree' in table 'corpus'.
doCountInTree :: String -> Int -> IO ()
doCountInTree username funcIndex = do
    putStr "Please input the value of 'serial_num' of start sentence: "
    line <- getLine
    let bottomSn = read line :: Int
    putStr "Please input the value of 'serial_num' of end sentence: "
    line <- getLine
    let topSn = (read line :: Int) + 1
    countInTree bottomSn topSn funcIndex
    doCountInCorpus username

-- A1_2. Display statistical results from field 'script' in table 'corpus'.
doCountInScript :: String -> Int -> IO ()
doCountInScript username funcIndex = do
    putStr "Please input the value of 'serial_num' of start sentence: "
    line <- getLine
    let bottomSn = read line :: Int
    putStr "Please input the value of 'serial_num' of end sentence: "
    line <- getLine
    let topSn = (read line :: Int) + 1
    countInScript bottomSn topSn funcIndex
    doCountInCorpus username

-- A2. Display statistical results from table 'struGene'.
doCountInStruGene :: String  -> IO ()
doCountInStruGene username = do
    putStrLn " ? -> Display command list."
    putStrLn " 1 -> Get total number of structural genes."
    putStrLn " 2 -> Get frequencies of different overlapping types."
    putStrLn " 3 -> Get frequencies of most common phrasal overlapping (LROs) by given common proportion."
    putStrLn " 4 -> Get frequencies of most common phrasal overlapping (LROPs) by given common proportion."
    putStrLn " 5 -> Get clausal number of different clausal lengths."
    putStrLn " 6 -> Get clausal number of different parsing-tree depths."
    putStrLn " 7 -> Get frequency total and normalized frequencies of different CCG tags."
    putStrLn " 8 -> Get frequency total and normalized frequencies of different phrasal structures."
    putStrLn " 9 -> Get frequency total and normalized frequencies of different type-tag-stru(s)."
    putStrLn " 0 -> Go back to the upper layer."

    putStr "Please input command: "
    line <- getLine
    if notElem line ["?","1","2","3","4","5","6","7","8","9","0"]
      then do
        putStrLn "Invalid input."
        doCountInStruGene username
      else case line of
        "?" -> doCountInStruGene username
        "1" -> doCountInStruGene' username 1
        "2" -> doCountInStruGene' username 2
        "3" -> doCountInStruGene' username 3
        "4" -> doCountInStruGene' username 4
        "5" -> doCountInTree username 5
        "6" -> doCountInTree username 6
        "7" -> doCountInTree username 7
        "8" -> doCountInTree username 8
        "9" -> doCountInTree username 9
        "0" -> interpreter username

-- A2_1. Display statistical results from table 'stru_gene'.
doCountInStruGene' :: String -> Int -> IO ()
doCountInStruGene' username funcIndex = do
    countInStruGene funcIndex
    doCountInStruGene username

-- 0. Quit from this program.
doQuit :: IO ()
doQuit = putStrLn "Bye!"

max_stars_repo_name: wangqingjiang-ncwu/my-ccg

max_issues_repo_name: wangqingjiang-ncwu/my-ccg

max_forks_repo_name: wangqingjiang-ncwu/my-ccg


text:
import Data.Complex
import Data.Map (Map)
import qualified Data.Map as Map

type Direction = Complex Float
type Turn = Complex Float

type Location = (Int, Int)
type Cart = (Direction, [Turn])
type State = Map Location Cart

parse' :: [(Int, Char)] -> (String, [(Int, Cart)])
parse' ((i,l):xs) =
  let (s, cs) = parse' xs
  in case l of
    '^' -> ('|':s, (i, (((-1):+   0 ), turns)):cs)
    'v' -> ('|':s, (i, ((  1 :+   0 ), turns)):cs)
    '<' -> ('-':s, (i, ((  0 :+ (-1)), turns)):cs)
    '>' -> ('-':s, (i, ((  0 :+   1 ), turns)):cs)
    _ -> (l:s, cs)
  where turns = cycle [(0 :+ 1), (1 :+ 0), (0 :+ (-1))]
parse' [] = ("", [])

parse :: String -> ([String], State)
parse input =
  let (ls, cs) = unzip . map p . zip [0..] . map (parse' . zip [0..]) . lines $ input
  in (ls, Map.fromList $ concat cs)
  where p (y, (l, cs)) = (l, map (\(x, c) -> ((y, x), c)) cs)

turn :: Cart -> Char -> Cart
turn (d, (t:xs)) '+' = (d * t, xs)
turn ((y :+ x), turns) '/'  = (((-x) :+ (-y)), turns)
turn ((y :+ x), turns) '\\' = ((  x  :+   y ), turns)
turn (c, turns) '|' = (c, turns)
turn (c, turns) '-' = (c, turns)

tick' :: [String] -> State -> [(Location, Cart)] -> (State, Maybe Location)
tick' tracks state (((y, x), cart@((vy :+ vx), turns)):xs) =
  if Map.notMember (y, x) state
  then tick' tracks state xs
  else let (y', x') = (y + round vy, x + round vx)
  in if Map.member (y', x') state
  then
    let state' = Map.delete (y', x') $ Map.delete (y, x) state
    in (fst $ tick' tracks state' xs, Just (y', x'))
  else
    let cart' = turn cart $ tracks !! y' !! x'
        state' = Map.insert (y', x') cart' $ Map.delete (y, x) state
    in tick' tracks state' xs
tick' _ state [] = (state, Nothing)

tick :: [String] -> State -> (State, Maybe Location)
tick tracks state = tick' tracks state $ Map.toList state

firstCollision :: [String] -> State -> Location
firstCollision tracks state = case tick tracks state of
  (state', Nothing) -> firstCollision tracks state'
  (_, Just location) -> location

lastCart :: [String] -> State -> Location
lastCart tracks state =
  let (state', _) = tick tracks state
  in if Map.size state == 1
  then head $ Map.keys state
  else lastCart tracks state'

part1 :: String -> (Int, Int)
part1 input =
  let (tracks, state) = parse input
      (y, x) = firstCollision tracks state
  in (x, y)

part2 :: String -> (Int, Int)
part2 input =
  let (tracks, state) = parse input
      (y, x) = lastCart tracks state
  in (x, y)


text:
{-| Provides 'hash' function for many data types
-}
module Hash(Hash, combineHash, emptyHash, hashToInt, hashToMax, Hashable(..)) where
--
-- Hash a value.  Hashing produces an Int of
-- unspecified range.
--
import Data.Array
import Data.Complex
import Data.Ratio

newtype Hash = H Int deriving (Eq)

----instance Show Hash where
--    showsType _ = showString "Hash"

combineHash :: Hash -> Hash -> Hash
combineHash (H x) (H y) = H (x+y)

emptyHash :: Hash
emptyHash = H 0

class Hashable a where
    hash :: a -> Hash

instance Hashable Char where
    hash x = H $ fromEnum x

instance Hashable Int where
    hash x = H $ x

instance Hashable Integer where
    hash x = H $ fromInteger x

instance Hashable Float where
    hash x = H $ truncate x

instance Hashable Double where
    hash x = H $ truncate x

instance Hashable (IO a) where
    hash x = H 0

instance Hashable () where
    hash x = H 0

instance Hashable (a -> b) where
    hash x = H 0

instance (Hashable a) => Hashable (Maybe a) where
    hash Nothing = H 0
    hash (Just x) = hash x

instance (Hashable a, Hashable b) => Hashable (Either a b) where
    hash (Left x) = hash x
    hash (Right y) = hash y

-- Denna bör inte vara bortkommenterad men jag kunde inte
-- göra en instans med String nedan
--instance Hashable a => Hashable [a] where
--    hash l = H $ f l 0
--      where f :: (Hashable a) => [a] -> Int -> Int
--            f [] r = r
--            f (c:cs) r = f cs (3*r + (case hash ( c ) of H h -> h) )

instance (Hashable a,Enum a) => Hashable [a] where
    hash l = H $ f l 0
        where f :: Enum b => [b] -> Int -> Int
              f [] r = r
              f (c:cs) r = f cs (3*r + fromEnum c)

instance (Hashable a, Hashable b) => Hashable (a,b) where
    hash (a,b) = H $ (case hash ( a ) of H h -> h)  + 3 * (case hash ( b ) of H h -> h)

instance (Hashable a, Hashable b, Hashable c) => Hashable (a,b,c) where
    hash (a,b,c) = H $ (case hash ( a ) of H h -> h)  + 3 * (case hash ( b ) of H h -> h)  + 5 * (case hash ( c ) of H h -> h)

instance (Hashable a, Hashable b, Hashable c, Hashable d) => Hashable (a,b,c,d) where
    hash (a,b,c,d) = H $ (case hash ( a ) of H h -> h)  + 3 * (case hash ( b ) of H h -> h)  + 5 * (case hash ( c ) of H h -> h)  + 7 * (case hash ( d ) of H h -> h)

instance (Hashable a, Hashable b, Hashable c, Hashable d, Hashable e) => Hashable (a,b,c,d,e) where
    hash (a,b,c,d,e) = H $ (case hash ( a ) of H h -> h)  + 3 * (case hash ( b ) of H h -> h)  + 5 * (case hash ( c ) of H h -> h)  + 7 * (case hash ( d ) of H h -> h)  + 9 * (case hash ( e ) of H h -> h)

instance Hashable Bool where
    hash False = H 0
    hash True = H 1

instance (Integral a, Hashable a) => Hashable (Ratio a) where
    hash x = H $ (case hash ( denominator x ) of H h -> h)  + (case hash ( numerator x ) of H h -> h)

instance (RealFloat a, Hashable a) => Hashable (Complex a) where
    hash (x :+ y) = H $ (case hash ( x ) of H h -> h)  + (case hash ( y ) of H h -> h)

instance (Ix a) => Hashable (Array a b) where
    hash x = H $ 0 -- !!!

hashToInt :: Int -> Hash -> Int
hashToInt maxhash x =
    case x of
    H h ->
        if h < 0 then
            if -h < 0 then 0
            else (-h) `rem` maxhash
        else h `rem` maxhash

hashToMax maxhash x =
    case hash x of
    H h ->
        if h < 0 then
            if -h < 0 then 0
            else (-h) `rem` maxhash
        else h `rem` maxhash

max_stars_repo_name: asr/agda-kanso

max_issues_repo_name: masondesu/agda

max_forks_repo_name: masondesu/agda


text:
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TemplateHaskell #-}

import Frames
import Frames.CSV (rowGen, RowGen(..), readTableOpt)
import Pipes (Producer)
import qualified Data.Foldable as F
import qualified Numeric.LinearAlgebra.HMatrix as H

import Numeric.BMML.RVMC

tableTypes'
    rowGen
    { rowTypeName = "Iris"
    , columnNames = [ "sepal length"
                    , "sepal width"
                    , "petal length"
                    , "petal width"
                    , "iris name"]
    }
    "data/iris.csv"

irisStream :: Producer Iris IO ()
irisStream = readTableOpt irisParser "data/iris.csv"

loadIris :: IO (Frame Iris)
loadIris = inCoreAoS irisStream

restructureIris :: ( CanDelete IrisName rs
                   , rs' ~ RDelete IrisName rs
                   , AllAre Double (UnColumn rs')
                   , AsVinyl rs') => Record rs -> Record (IrisName ': rs')
restructureIris r = frameCons (rget' irisName' r) (rdel [pr|IrisName|] r)

splitXY :: (AllAre Double (UnColumn rs), AsVinyl rs)
        => Record (s :-> Text ': rs) -> (Text, [Double])
splitXY (recUncons -> (h, t)) = (h, recToList t)

loadDataSet :: IO ([Text], [[Double]])
loadDataSet =
    loadIris >>=
    \ds ->
         return $ unzip $ F.foldMap ((: []) . splitXY . restructureIris) ds

splitTrainTest :: [[Double]]
               -> [Text]
               -> (([[Double]], [Double]), ([[Double]], [Double]))
splitTrainTest x y =
    splitTT
        (takeN
             (foldr
                  (\(xi,yi) ((x1,y1),(x0,y0)) ->
                        if yi == "Iris-setosa"
                            then ((x1 ++ [xi], y1 ++ [1]), (x0, y0))
                            else ((x1, y1), (x0 ++ [xi], y0 ++ [0])))
                  (([], []), ([], []))
                  (zip x y)))
  where
    takeN ((x1,y1),(x0,y0)) = ((take n x1, take n y1), (take n x0, take n y0))
      where
        n = min (length y1) (length y0)
    splitTT ((x1,y1),(x0,y0)) = ((x1Train ++ x0Train, y1Train ++ y0Train), (x1Test ++ x0Test, y1Test ++ y0Test))
      where
        n = length y1
        m = floor (0.7 * fromIntegral n)
        (x1Train,x1Test) = splitAt m x1
        (y1Train,y1Test) = splitAt m y1
        (x0Train,x0Test) = splitAt m x0
        (y0Train,y0Test) = splitAt m y0

main :: IO ()
main = do
    (y,x) <- loadDataSet
    let ((xTrain,yTrain),(xTest,yTest)) = splitTrainTest x y
        c = fit (H.fromLists xTrain) (H.fromList yTrain)
    mapM_
        (\(x,y) ->
              print
                  ("Real: " ++
                   show y ++
                   "probability of class 1: " ++
                   show (predict c (H.fromList x))))
        (zip xTest yTest)

max_stars_repo_name: DbIHbKA/BMML

max_issues_repo_name: DbIHbKA/BMML

max_forks_repo_name: DbIHbKA/BMML


text:
module UnitTests
  ( unitTests
  ) where

import Test.Tasty
import Test.Tasty.HUnit
import Numeric.LinearAlgebra

unitTests =
  testGroup
    "Unit tests"
    [checkTransposition, checkSubtraction]

matrix1 = (2><2) [1,2,3,4] :: Matrix Double
matrix2 = (2><2) [1,1,1,1] :: Matrix Double
trMatrix1 = (2><2) [1,3,2,4] :: Matrix Double
subMatrix1 = (2><2) [0,1,2,3] :: Matrix Double
checkTranspositionMsg = "                        |1 2|    |1 3|" ++ "\n    " ++
                        "Transposition of Matrix |3 4| is |2 4|"

checkSubtractionMsg = "|1 2|   |1 1|    |0 1|" ++ "\n    " ++
                      "|3 4| - |1 1| is |2 3|"

checkTransposition =
  testCase checkTranspositionMsg $ assertEqual [] trMatrix1 (tr matrix1)

checkSubtraction =
  testCase checkSubtractionMsg $ assertEqual [] subMatrix1 (matrix1 - matrix2)

max_stars_repo_name: Malenczuk/HuskNet

max_issues_repo_name: Malenczuk/HuskNet

max_forks_repo_name: Malenczuk/HuskNet


text:
{-|
Module: MachineLearning.NeuralNetwork
Description: Neural Network
Copyright: (c) Alexander Ignatyev, 2016
License: BSD-3
Stability: experimental
Portability: POSIX

Simple Neural Networks.
-}

module MachineLearning.NeuralNetwork
(
    Model(..)
  , NeuralNetworkModel(..)
  , MLC.calcAccuracy
  , T.Topology
  , T.initializeTheta
  , T.initializeThetaIO
  , T.initializeThetaM
  , Regularization(..)
)

where

import qualified Numeric.LinearAlgebra as LA
import MachineLearning.Types (R, Vector, Matrix)
import MachineLearning.Utils (reduceByRowsV)
import qualified MachineLearning.Classification.Internal as MLC
import MachineLearning.Model (Model(..))
import qualified MachineLearning.NeuralNetwork.Topology as T
import MachineLearning.Regularization (Regularization(..))

-- | Neural Network Model.
-- Takes neural network topology as a constructor argument.
newtype NeuralNetworkModel = NeuralNetwork T.Topology

instance Model NeuralNetworkModel where
  hypothesis (NeuralNetwork topology) x theta = predictions
    where thetaList = T.unflatten topology theta
          scores = calcScores topology x thetaList
          predictions = reduceByRowsV (fromIntegral . LA.maxIndex) scores

  cost (NeuralNetwork topology) lambda x y theta =
    let (ys, thetaList) = processParams topology y theta
        scores = calcScores topology x thetaList
    in T.loss topology lambda scores thetaList ys

  gradient (NeuralNetwork topology) lambda x y theta =
    let (ys, thetaList) = processParams topology y theta
        (scores, cacheList) = T.propagateForward topology x thetaList
        grad = T.flatten $ T.propagateBackward topology lambda scores cacheList ys
    in grad

-- | Score function. Takes a topology, X and theta list.
calcScores :: T.Topology -> Matrix -> [(Matrix, Matrix)] -> Matrix
calcScores topology x thetaList = fst $ T.propagateForward topology x thetaList

processParams :: T.Topology -> Vector -> Vector -> (Matrix, [(Matrix, Matrix)])
processParams topology y theta =
  let nOutputs = T.numberOutputs topology
      ys = LA.fromColumns $ MLC.processOutputOneVsAll nOutputs y
      thetaList = T.unflatten topology theta
  in (ys, thetaList)

max_stars_repo_name: aligusnet/mltool

max_issues_repo_name: aligusnet/mltool

max_forks_repo_name: aligusnet/mltool


text:
{-# LANGUAGE FlexibleContexts #-}

-- |
-- Module    : Statistics.Sample.Internal
-- Copyright : (c) 2013 Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- Internal functions for computing over samples.
module Statistics.Sample.Internal
    (
      robustSumVar
    , sum
    ) where

import Numeric.Sum (kbn, sumVector)
import Prelude hiding (sum)
import Statistics.Function (square)
import qualified Data.Vector.Generic as G

robustSumVar :: (G.Vector v Double) => Double -> v Double -> Double
robustSumVar m = sum . G.map (square . subtract m)
{-# INLINE robustSumVar #-}

sum :: (G.Vector v Double) => v Double -> Double
sum = sumVector kbn
{-# INLINE sum #-}

max_stars_repo_name: StefanHubner/statistics

max_issues_repo_name: StefanHubner/statistics

max_forks_repo_name: StefanHubner/statistics