text:
-- |
-- Module      : BattleHack.Lenses
-- Description :
-- Copyright   : (c) Jonatan H Sundqvist, 2015
-- License     : MIT
-- Maintainer  : Jonatan H Sundqvist
-- Stability   : experimental
-- Portability : POSIX

-- Created September 12 2015

--------------------------------------------------------------------------------------------------------------------------------------------
-- GHC pragmas
--------------------------------------------------------------------------------------------------------------------------------------------
{-# LANGUAGE Rank2Types #-}

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
module BattleHack.Lenses where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
-- import Control.Monad
import Control.Lens
import Data.Functor ((<$>))
import Data.Complex
import qualified Data.Set as S

import BattleHack.Types

--------------------------------------------------------------------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------------------------------------------------------------------
-- Operators -------------------------------------------------------------------------------------------------------------------------------
-- |
-- TODO: Infix declaration
(-->) :: b -> Getting a b a -> a
(-->) = (^.)

infix 8 --> -- Slightly lower precedence than the '.' operator

-- AppState --------------------------------------------------------------------------------------------------------------------------------
-- |
piano :: Lens AppState AppState PianoSettings PianoSettings
piano f s = (\new -> s { _piano=new }) <$> f (_piano s)

bindings :: Lens AppState AppState KeyMap KeyMap
bindings f s = (\new -> s { _bindings=new }) <$> f (_bindings s)

inputstate :: Lens AppState AppState InputState InputState
inputstate f s = (\new -> s { _inputstate=new }) <$> f (_inputstate s)

animation :: Lens AppState AppState AnimationData AnimationData
animation f s = (\new -> s { _animation=new }) <$> f (_animation s)

-- source :: Lens AppState AppState Source Source
-- source f s = (\new -> s { _source=new }) <$> f (_source s)

-- claviature :: Lens AppState AppState Claviature Claviature
-- claviature f s = (\new -> s { _claviature=new }) <$> f (_claviature s)

-- AnimationData ---------------------------------------------------------------------------------------------------------------------------
frame :: Lens AnimationData AnimationData Int Int
frame f s = (\new -> s { _frame=new }) <$> f (_frame s)

fps :: Lens AnimationData AnimationData Int Int
fps f s = (\new -> s { _fps=new }) <$> f (_fps s)

-- InputState ------------------------------------------------------------------------------------------------------------------------------
-- |
mouse :: Lens InputState InputState Vector Vector
mouse f s = (\new -> s { _mouse=new }) <$> f (_mouse s)

keyboard :: Lens InputState InputState (S.Set String) (S.Set String)
keyboard f s = (\new -> s { _keyboard=new }) <$> f (_keyboard s)

-- PianoSettings ---------------------------------------------------------------------------------------------------------------------------
-- |
origin :: Lens PianoSettings PianoSettings Vector Vector
origin f s = (\new -> s { _origin=new }) <$> f (_origin s)

-- |
keysize :: Lens PianoSettings PianoSettings Vector Vector
keysize f s = (\new -> s { _keysize=new }) <$> f (_keysize s)

-- |
indent :: Lens PianoSettings PianoSettings Number Number
indent f s = (\new -> s { _indent=new }) <$> f (_indent s)

-- |
mid :: Lens PianoSettings PianoSettings Number Number
mid f s = (\new -> s { _mid=new }) <$> f (_mid s)

-- |
active :: Lens PianoSettings PianoSettings (Maybe Int) (Maybe Int)
active f s = (\new -> s { _active=new }) <$> f (_active s)

-- |
keys :: Lens PianoSettings PianoSettings [Bool] [Bool]
keys f s = (\new -> s { _keys=new }) <$> f (_keys s)

-- Vectors ---------------------------------------------------------------------------------------------------------------------------------
-- | Focuses on the real part (X-component) of a vector.
-- TODO: Real part as vector (eg. x:+y -> x:+0), ditto for imag
real :: Lens (Complex a) (Complex a) a a
real f (x:+y) = (:+y) <$> f x

-- | Focuses on the imaginary part (Y-component) of a vector.
imag :: Lens (Complex a) (Complex a) a a
imag f (x:+y) = (x:+) <$> f y

-- | Like real, except the new type is also a vector.
-- TODO: Better name (?)
real' :: Num n => Lens (Complex n) (Complex n) (Complex n) (Complex n)
real' f (x:+_) = id <$> f (x:+0)

-- | Like imag, except the new type is also a vector.
-- TODO: Better name (?)
imag' :: Num n => Lens (Complex n) (Complex n) (Complex n) (Complex n)
imag' f (_:+y) = id <$> f (0:+y)


text:
module MNIST.Prelude
  ( module X
  , UVector
  , GVector
  , identity
  ) where

import Prelude                       as X hiding (id)
import Control.Applicative           as X
import Control.Arrow                 as X
import Control.Exception.Safe        as X
import Control.Monad                 as X
-- import Control.Monad.Random          as X
import Control.Monad.IO.Class        as X (liftIO)
import Control.Monad.Trans           as X (lift)
import Control.Monad.Trans.Except    as X hiding (liftCallCC, liftListen, liftPass)
import Control.Monad.Trans.Maybe     as X (MaybeT(..))
import Control.Monad.Trans.Reader    as X hiding (liftCallCC, liftCatch)
import Control.Monad.Trans.State     as X
import Control.DeepSeq               as X
import Criterion.Main                as X
import Criterion.Types               as X
import Data.Bitraversable            as X
import Data.Foldable                 as X
import Data.IDX                      as X
import Data.Int                      as X (Int32, Int64)
import Data.List                     as X (genericLength)
import Data.List.Split               as X
import Data.Maybe                    as X
import Data.Monoid                   as X
import Text.Printf                   as X
import Data.Time.Clock               as X
import Data.Time.Format              as X
import Data.Time.LocalTime           as X
import Data.Traversable              as X
import Data.Tuple                    as X
import Data.Type.Combinator          as X
import Data.Type.Index               as X
import Data.Type.Product             as X hiding (toList)
import Data.Vector                   as X (Vector)
import GHC.Generics                  as X (Generic)
import GHC.TypeLits                  as X
import GHC.IO                        as X (evaluate)
import Numeric.Backprop              as X (Op, op2')
import System.Directory              as X
import TensorFlow.Core               as X (Tensor, Shape, Build, TensorData, Session)
import Numeric.LinearAlgebra.Static  as X (R, L)

-- ========================================================================= --
-- Prelude customizations

import Data.Vector.Unboxed as UV (Vector)
import Data.Vector.Generic as G (Vector)
import qualified Prelude   as P

type UVector = UV.Vector
type GVector = G.Vector

identity :: a -> a
identity = P.id

ext: hs

max_stars_repo_name: stites/haskell-mnist-benchmarks

max_issues_repo_name: stites/haskell-mnist-benchmarks

max_forks_repo_name: stites/haskell-mnist-benchmarks


text:
module School.Utils.Debug
( compareDoubleMatrixTrace
, db
, printConduit
, printConduitP
, printVar
, showIO
, sl
, trace
) where

import Conduit (ConduitM, mapC, peekC)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Debug.Trace (trace, traceIO)
import Numeric.LinearAlgebra (Matrix, R, toLists)
import School.Types.FloatEq (compareDouble)

sl :: (Show a) => a -> String
sl a = show a ++ " "

showIO :: (MonadIO m) => String -> m ()
showIO = liftIO . traceIO

printConduitP :: (Monad m, Show a)
              => String
              -> ConduitM a a m ()
printConduitP str = do
  next <- peekC
  mapC (db id (str ++ ": " ++ show next))

printConduit :: (MonadIO m, Show a)
             => String
             -> ConduitM a a m ()
printConduit str = do
  next <- peekC
  liftIO $ putStrLn (str ++ ": " ++ show next)
  mapC id

printVar :: (Show a) => String -> a -> a
printVar str x = trace (str ++ ": " ++ show x) x

db :: a -> String -> a
db = flip trace

compareDoubleMatrixTrace :: Double
                         -> Matrix R
                         -> Matrix R
                         -> Bool
compareDoubleMatrixTrace prec m1 m2 =
  and $ zipWith (traceCompare prec) l1 l2
  where traceMsg c msg v = if c
           then trace msg v
           else v
        traceCompare p d1 d2 =
          let equal = compareDouble p d1 d2
          in traceMsg (not equal) ("UNEQ " ++ show d1 ++ " " ++ show d2) equal
        l1 = concat . toLists $ m1
        l2 = concat . toLists $ m2

max_stars_repo_name: jfulseca/School

max_issues_repo_name: jfulseca/School

max_forks_repo_name: jfulseca/School


text:
-- example 3.21

import Statistics.Distribution
import Statistics.Distribution.Binomial
import Statistics.Distribution.Poisson

bi = binomial n p
  where
    n = 20   -- trials
    p =  0.1 -- probability

pd = poisson l
  where
    l = n*p
    n = 20
    p =  0.1

main = do
  putStrLn $ "with binomial, P(X<=3):              " ++ show (cumulative bi 3.0)
  putStrLn $ "with poisson approximation, P(X<=3): " ++ show (cumulative pd 3.0)

max_stars_repo_name: raydsameshima/Stat

max_issues_repo_name: raydsameshima/Stat

max_forks_repo_name: raydsameshima/Stat


text:
module Math.Ray where

import Numeric.LinearAlgebra

import Codec.Picture

type Vec3 = Vector Double
vec3 :: Double -> Double -> Double -> Vec3
vec3 x y z= vector $! [x,y,z]

data Ray = Ray
    {-# UNPACK #-} !Vec3
    {-# UNPACK #-} !Vec3
    deriving Show

parametric :: Ray -> (Double -> Vec3)
parametric (Ray p v) k = p + scale k v
{-# INLINE parametric #-}

max_stars_repo_name: danrocag/raytracer

max_issues_repo_name: danrocag/raytracer

max_forks_repo_name: danrocag/raytracer


text:
-- tests/Data/Network/FullyConnected.hs
module Data.Network.FullyConnectedSpec (spec) where

import Test.Hspec

import Data.Network
import Data.Network.Activation
import Data.Network.FullyConnected as FC
import System.Random
import Numeric.LinearAlgebra

spec :: Spec
spec = do
  describe "A fully connected layer composed of a weight matrix, a bias vector and an activation function" $ do
    describe "instance Layer (FullyConnected (Matrix R) R) where" $ do
      describe "makeRandomLayer" $ do
        it "creates a randomly initialized layer" $ do
          g <- getStdGen
          let l = makeRandomLayer g id 10 20 (logistic :: ActivationFunction (Matrix Double)) :: FullyConnected (Matrix Double) Double
          (size (weights l)) `shouldBe` (10,20)
          (size (biases l)) `shouldBe` 20
          let (g',g'') = split g
          let rs = randoms g'
          let i = (10><20) rs
          (activate (activation l) i) `shouldBe` (activate logistic i)
      describe "compute" $ do
        it "Computes the linear combination of the layer's inputs" $ do
          g <- getStdGen
          let (g1,g2) = split g
          let l@(FC w b af) = makeRandomLayer g1 id 10 20 (logistic) :: FullyConnected (Matrix Double) Double
          let rs = randoms g2
          let i = (100><10) rs
          let o = compute l i
          size o `shouldBe` (100,20)
          o `shouldBe` ((fromRows $ replicate 100 b) + (i <> w))

    describe "instance Network i (Layers (FullyConnected i Double)) where" $ do
      describe "makeRandomNetwork" $ do
        it "Creates a randomly initialized network given the specification of the layers" $ do
          g <- getStdGen
          let (g1,g2) = split g
          let n = makeRandomNetwork g1 id 10 [(30, logistic)] (20, logistic) :: FeedForwardFC (Matrix R)
          pending

max_stars_repo_name: DrPyser/NeuralNetwork

max_issues_repo_name: DrPyser/NeuralNetwork

max_forks_repo_name: DrPyser/NeuralNetwork


text:
module NeuralNet.CostSpec (costSpec) where

import Test.Hspec
import Numeric.LinearAlgebra
import NeuralNet.Cost

costSpec :: SpecWith ()
costSpec =
  describe "NeuralNet.Cost" $
    describe "computeCost" $ do
      it "calculates correctly for example" $
        let
          al = fromLists [[0.8, 0.9, 0.4]]
          y = fromLists [[1, 1, 1]]
        in computeCost al y `shouldBe` 0.41493159961539694

max_stars_repo_name: danielholmes/neural-net

max_issues_repo_name: danielholmes/neural-net

max_forks_repo_name: danielholmes/neural-net


text:
-- O(n log n) multiply polynomials by Cooley-Tukey FFT （Mutable Vector)
-- 448 ms in atc001-c
-- cf. http://wwwa.pikara.ne.jp/okojisan/stockham/cooley-tukey.html
module FFT where

import qualified Data.Vector.Unboxed           as VU
import qualified Data.Vector.Unboxed.Mutable   as VUM
import           Data.Complex
import           Data.Function
import           Control.Monad
import           Control.Monad.Primitive
import           Control.Monad.ST

-- This function computes polynomial coefficient of (f * g)(x)
-- f & g are polynomial coefficient array of f(x) & g(x)
multiply :: VU.Vector Int -> VU.Vector Int -> VU.Vector Int
multiply f g = runST $ do
  let len = VU.length f + VU.length g - 1
  let sz  = fix (\rec k -> if k >= len then k else rec (k * 2)) 1
  tf <- VU.thaw (VU.map fromIntegral f :: VU.Vector (Complex Double))
  nf <- VUM.grow tf (sz - VU.length f)
  tg <- VU.thaw (VU.map fromIntegral g :: VU.Vector (Complex Double))
  ng <- VUM.grow tg (sz - VU.length g)
  fft sz nf
  fft sz ng
  forM_ [0 .. sz - 1] $ \i -> do
    y <- VUM.read ng i
    VUM.modify nf (* y) i
  ifft sz nf
  ret <- VU.freeze nf
  return $ VU.map (round . realPart) $ VU.take len ret
{-# INLINE multiply #-}

fft
  :: PrimMonad m
  => Int -- length
  -> VUM.MVector (PrimState m) (Complex Double) -- target data of FFT
  -> m ()
fft n = cooleyTukey n 1 0 0
{-# INLINE fft #-}

ifft
  :: PrimMonad m
  => Int -- length
  -> VUM.MVector (PrimState m) (Complex Double) -- target data of FFT
  -> m ()
ifft n x = do
  forM_ [0 .. n - 1] $ VUM.modify x conjugate
  cooleyTukey n 1 0 0 x
  forM_ [0 .. n - 1] $ VUM.modify x ((/ fromIntegral n) . conjugate)
{-# INLINE ifft #-}

cooleyTukey
  :: PrimMonad m
  => Int -- length
  -> Int -- stride
  -> Int -- start position of block
  -> Int -- temp var for bit reverse position in start position of block
  -> VUM.MVector (PrimState m) (Complex Double) -- target data of FFT
  -> m ()
cooleyTukey n s q d x
  | n > 1 = do
    let m  = n `div` 2
    let θ0 = 2 * pi / fromIntegral n
    forM_ [0 .. m - 1] $ \p -> do
      let wp = cos (fromIntegral p * θ0) :+ (-sin (fromIntegral p * θ0))
      a <- VUM.read x (q + p + 0)
      b <- VUM.read x (q + p + m)
      VUM.write x (q + p + 0) (a + b)
      VUM.write x (q + p + m) ((a - b) * wp)
    cooleyTukey m (2 * s) (q + 0) (d + 0) x
    cooleyTukey m (2 * s) (q + m) (d + s) x
  | q > d = VUM.swap x q d
  | otherwise = return ()
{-# INLINE cooleyTukey #-}

max_stars_repo_name: matonix/atcoder

max_issues_repo_name: matonix/atcoder

max_forks_repo_name: matonix/atcoder


text:
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE InstanceSigs #-}

module BraKet where

import Data.Complex
import qualified Numeric.LinearAlgebra as L

import LinAlg

-- Ket is a ket vector
-- is the coefficient type
-- in which the Ket is written
newtype Ket c = Ket (L.Vector c)
      deriving (Show, Eq)

-- Function used to act on a Ket with an operator
act :: MatOp -> Ket (Complex Double) -> Ket (Complex Double)
act op ket = Ket $ repr op L.#> getCoeffs ket

getCoeffs :: Ket c -> L.Vector c
getCoeffs (Ket cs) = cs

mapKet :: (L.Vector a -> L.Vector a) -> Ket a -> Ket a
mapKet f (Ket cs) = Ket $ f cs

instance Vector (Ket (Complex Double)) where
    -- Negation: just negate all coefficients
    vneg = mapKet negate
    -- Addition: add coefficients element-wise
    (Ket exp1) <+> (Ket exp2) = Ket $ exp1 + exp2
    -- Scalar multiplication: multiply all coefficients
    (<**>) a = mapKet (L.cmap (*a))

instance Hilbert (Ket (Complex Double)) where
    -- Inner product: Like l2 inner product; multiply coefficients
    -- and sum
    (Ket coeffs1) <.> (Ket coeffs2) = coeffs1 L.<.> coeffs2

outerProduct :: Ket (Complex Double) -> Ket (Complex Double)
                                     -> MatOp
outerProduct (Ket cs1) (Ket cs2) = Operator $ cs1 `L.outer` cs2

max_stars_repo_name: Jvanrhijn/optiqs

max_issues_repo_name: Jvanrhijn/optiqs

max_forks_repo_name: Jvanrhijn/optiqs


text:
module Main where

import Data.Complex
import Data.Complex as C
import Data.Matrix
import Data.Matrix as M

adjoint :: Num a => Matrix (Complex a) -> Matrix (Complex a)
adjoint = fmap conjugate . transpose

dot :: RealFloat a => Matrix (Complex a) -> Matrix (Complex a) -> Complex a
dot x y = M.trace $ M.multStd (adjoint x) y

norm :: RealFloat a => Matrix (Complex a) -> a
norm x = sqrt $ C.realPart $ dot x x

isHermitian :: (Eq a, Num a) => Matrix (Complex a) -> Bool
isHermitian m = adjoint m == m

isIdentity :: (Eq a, Num a) => Matrix a -> Bool
isIdentity m = M.identity (M.ncols m) == m

isUnitary :: RealFloat a => Matrix (Complex a) -> Bool
isUnitary m = isIdentity (m * adjoint m)

mult :: (Functor f, Num b) => f b -> b -> f b
mult m i = fmap (* i) m

tensor :: Num a => Matrix a -> Matrix a -> Matrix a
tensor m1 m2 = M.flatten $ fmap (mult m2) m1

main :: IO ()
main = do
  -- putStrLn "Hello! What's your name?"
  -- name <- getLine
  let c = 0 :+ 1
  let c2 = 1 :+ 1
  let m = M.fromLists [[0, 1 :+ (2)], [1 :+ 2, 3]]
  let m2 = M.fromLists [[1], [0]]
  let z = 3 * m
  putStrLn $ show m
  putStrLn $ show $ tensor m m2

max_stars_repo_name: daxfohl/qs

max_issues_repo_name: daxfohl/qs

max_forks_repo_name: daxfohl/qs


text:
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE FlexibleContexts      #-}

module GrenadeExtras.GradNorm (
  GradNorm(..)
) where

import Grenade (FullyConnected'(FullyConnected'), FullyConnected(FullyConnected), Tanh,
                Logit, Gradient, Relu, Gradients(GNil, (:/>)))
import Numeric.LinearAlgebra.Static ((<.>), toColumns)
import GHC.TypeLits (KnownNat)

class GradNorm x where
  normSquared :: x -> Double

instance (KnownNat i, KnownNat o) => GradNorm (FullyConnected' i o) where
  normSquared (FullyConnected' r l) = r <.> r + (sum . fmap (\c->c<.>c) . toColumns $ l)

instance (KnownNat i, KnownNat o) => GradNorm (FullyConnected i o) where
  normSquared (FullyConnected w _) = normSquared w

instance GradNorm () where
  normSquared _ = 0

instance (GradNorm a, GradNorm b) => GradNorm (a, b) where
  normSquared (a, b) = normSquared a + normSquared b

instance GradNorm Logit where
  normSquared _ = 0

instance GradNorm Tanh where
  normSquared _ = 0

instance GradNorm Relu where
  normSquared _ = 0

instance GradNorm (Gradients '[]) where
  normSquared GNil = 0

instance (GradNorm l, GradNorm (Gradient l), GradNorm (Gradients ls)) => GradNorm (Gradients (l ': ls)) where
  normSquared (grad :/> grest) = normSquared grad + normSquared grest

max_stars_repo_name: helq/haskell-binary-classification

max_issues_repo_name: helq/haskell-binary-classification

max_forks_repo_name: helq/haskell-binary-classification


text:
{-# LANGUAGE DataKinds, FlexibleContexts #-}

module Lib.Practice.P9 (
    f9
) where

import qualified Numeric.LinearAlgebra as LA
import Numeric.LinearAlgebra.Static
import Lib.Utility
import Control.Monad
import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class
import GHC.TypeLits

f9 = downMaybeTIO f9'
f9' :: MaybeT IO ()
f9' = do
    mnist@(tr@(trX, trT), te@(teX, teT)) <- getMnistData
    net <- liftIO (initTestNet 0.01 :: IO (MnistTwoLayerNet 50 100 784 10))
    showAccuracy te net
    net' <- train10000 mnist net
    --net' <- train100 net train'
    --showAccuracy net'
    return ()

showNetParam (MnistTwoLayerNet af1 relu af2 _) = b1
    where (Layer param2 _ _) = af2
          (Layer param1 _ _) = af1
          ((w2, b2), _, _) = param2
          ((w1, b1), _, _) = param1
train10000 mnist net = foldM (\ net' _ -> train600 mnist net') net [1..16]
train600 (tr, te) net = do
    net' <- foldM (\ net' _ -> train tr net') net [1 .. 600]
    showAccuracy te net'
    liftIO $ print $ showNetParam net'
    return net'

showAccuracy te net = do
    (batchX, batchT) <- miniBatch te
    MaybeT $ fmap Just $ print $ accuracy net batchX batchT
train tr net = do
    (batchX, batchT) <- miniBatch tr
    return $ training' net batchX batchT

training' (MnistTwoLayerNet af1 relu af2 updater) x t = MnistTwoLayerNet af1' relu af2' updater'
    where ff layer x = case layer of (Layer _ ff _) -> ff x
          bf layer state = case layer of (Layer _ _ bf) -> bf state
          (y1, af1s) = ff af1 x
          (y2, relus) = ff relu y1
          (y3, af2s) = ff af2 y2
          swl = softmaxWithLossLayer t
          (y4, swls) = ff swl y3
          resultMaybe = do
              let (dx1, _) = bf swl swls 1
              let (dx2, (p2, _, dwdbMaybe2)) = bf af2 af2s dx1
              dp2 <- dwdbMaybe2
              let (dx3, _) = bf relu relus dx2
              let (_, (p1, _, dwdbMaybe1)) = bf af1 af1s dx3
              dp1 <- dwdbMaybe1
              let ((af1s', af2s'), u') = update updater (p1, p2) (dp1, dp2)
              return (affineLayer af1s', affineLayer af2s', u')
          (af1', af2', updater') = case resultMaybe of
              Nothing -> error "Something wrong"
              Just x -> x

testAffine = y
    where (Layer s f bf) = affineLayer (w, b) :: Layer 2 2 3 (AffineState 2 2 3)
          (y, s') = f x
          (dx, (_, _, Just (dw, db))) = bf s' (matrix [1..6] :: L 2 3)
          x = matrix [0,0,1,1] :: L 2 2
          w = matrix [0,0,0,10,10,10] :: L 2 3
          b = vec3 1 2 3
testRelu = dy
    where (Layer s f bf) = reluLayer
          (y, state) = f (matrix [1.0,-0.5,-2.0,3.0] :: L 2 2)
          (dy, _) = bf state (matrix [2.0,5.5,-2.0,3.0] :: L 2 2)
testSoftmax = softmax (matrix [1010, 1000, 990] :: L 1 3)
testCrossEntropyError = crossEntropyError t y
    where t = matrix [0,0,1,0,0,0,0,0,0,0] :: L 1 10
          y = matrix [0.1,0.05,0.6,0.0,0.05,0.1,0.0,0.1,0.0,0.0] :: L 1 10


text:
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ConstraintKinds #-}

module Matrix where

import Prelude
import qualified Prelude
import qualified Data.Matrix
import qualified Data.Eigen.Matrix
import Foreign.C.Types
import qualified Numeric.LinearAlgebra.HMatrix
import qualified Numeric.LinearAlgebra.Data
import Control.Parallel.Strategies
import qualified Data.Array as Array
import Data.Array(Array, (!), range, Ix)
import GHC.Generics
import Control.Arrow
import Control.Monad.Writer
import Control.Monad.Identity

import qualified Data.Set as Set
import Data.Set(Set)
import qualified Data.Map as Map
import Data.Map(Map)

data Matrix a b v = Matrix (Array (a, b) v) deriving (Show, Eq, Ord, Functor, Generic)
instance (NFData a, NFData b, NFData v) => NFData (Matrix a b v)
type Vector a v = Matrix a () v

type Ix' a = (Ix a, Bounded a, Enum a)

instance (Ix' a, Ix' b) => Enum (a, b) where
  fromEnum (x, (y :: b)) = fromEnum x * Array.rangeSize (fullRange :: (b, b)) + fromEnum y
  toEnum i =
    let (d, m) = i `divMod` (Array.rangeSize (fullRange :: (b, b))) in
      (toEnum d, (toEnum m :: b))

instance (Linear v, Ix' a, Ix' b) => Linear (Matrix a b v) where
  zero = Matrix (f_array (\(_a, _b) -> zero))
  add = matrixZipWith add
  minus = fmap minus

fullRange :: Bounded a => (a, a)
fullRange = (minBound, maxBound)

vector_of_function f = Matrix (f_array (\(x, ()) -> f x))

{-# INLINE matrix_mult #-}
matrix_mult :: (Ix' a, Ix' b, Ix' c, Num v) => Matrix a b v -> Matrix b c v -> Matrix a c v
matrix_mult (Matrix x) (Matrix y) = Matrix (Array.array fullRange [ ((a, c), sum [ x ! (a, b) * y ! (b, c) | b <- range fullRange]) | a <- range fullRange, c <- range fullRange])

{-# INLINE matrixZipWith #-}
matrixZipWith f (Matrix a) (Matrix b) =
  Matrix (f_array (\k -> f (a ! k) (b ! k)))

{-# INLINE f_array #-}
f_array :: Ix' k => (k -> v) -> Array k v
f_array f = Array.array fullRange [(k, f k) | k <- range fullRange]

type Solution b v = Map b (Map b v)

type Solution_with_trace a b v =
  -- decomposes as much products as it can, providing for each product:
  -- 1. how much of non-decomposable products are necessary
  -- 2. how much of input recipes ([a]) you need to craft
  Map b (Map b v, Map a v)

class Linear a where
  zero :: a
  add :: a -> a -> a
  minus :: a -> a

instance (Linear a, Linear b) => Linear (a, b) where
  zero = (zero, zero)
  add (a1, b1) (a2, b2) = (add a1 a2, add b1 b2)
  minus (a, b) = (minus a, minus b)

instance Linear Double where
  zero = 0
  add = (+)
  minus x = -x

instance Linear Rational where
  zero = 0
  add = (+)
  minus x = -x

instance VectorSpace Rational where
  type Scalar Rational = Rational
  scale = (*)

instance (Eq v, Ord k, VectorSpace v) => VectorSpace (Map k v) where
  type Scalar (Map k v) = Scalar v
  scale s = fmap (scale s)

instance (VectorSpace a, VectorSpace b, Scalar a ~ Scalar b) => VectorSpace (a, b) where
  type Scalar (a, b) = Scalar a
  scale s = (scale s *** scale s)

instance (Ord k, Linear v, Eq v) => Linear (Map k v) where
  zero = Map.empty
  add a b = Map.filter (/= zero) (Map.unionWith add a b)
  minus = fmap minus

find_kernel ::
  forall v1 b s.
  ( Linear v1
  , Eq b
  , Eq v1
  , Ord b)
  =>
  (v1 -> v1 -> s)
  -> (s -> v1 -> v1)
  -> [Map b v1] -> Solution b s
find_kernel divide mult_v1 rows = go rows where

  lookupLhs :: (Map b v1) -> b -> v1
  lookupLhs lhs b = case Map.lookup b lhs of
    Nothing -> zero
    Just x -> x

  addRow a1 a2 = (Map.unionWith add a1 a2)

  scaleRow (s :: s) a1 = fmap (mult_v1 s) a1

  minusRow m = fmap minus m

  remove_b :: (b, (Map b v1)) -> (Map b v1) -> (Map b v1)
  remove_b (b, row0) row1 =
    (\m -> if m Map.! b == zero then Map.delete b m else error "should be zero") $ addRow row1 (minusRow $ scaleRow (lookupLhs row1 b `divide` lookupLhs row0 b) row0)

  go :: [(Map b v1)] -> Solution b s
  go [] = Map.empty
  go (row0 : rest) = case [(b, v) | (b, v) <- Map.toList row0, v /= zero] of
    [] -> -- all coefficients are 0, equation is useless
      go rest
    (chosen_b, chosen_v) : _ ->
      case go (map (remove_b (chosen_b, row0)) rest) of
        solutionDecompose ->
          case map (\(b, v) ->
                           if b == chosen_b
                           then Map.empty
                           else
                             case (Map.lookup b solutionDecompose) of
                               Nothing ->
                                 Map.singleton b v
                               Just vs ->
                                 fmap (`mult_v1` v) vs
                        ) (Map.toList row0) of
            lhs ->
              let sum_of_lhs = Map.unionsWith add lhs in
              (Map.insert chosen_b (fmap ((`divide` chosen_v) . minus) sum_of_lhs) solutionDecompose)

class Linear a => VectorSpace a where
  type Scalar a :: *
  scale :: Scalar a -> a -> a

find_kernel_with_trace ::
  forall v a b s.
  ( VectorSpace v
  , Scalar v ~ v
  , Ord a
  , Fractional v
  , Eq b
  , Eq v
  , Num v
  , Ord b)
  =>
  (v -> v -> v)
  -> (v -> v -> v)
  -> Map a (Map b v) -> Solution_with_trace a b v
find_kernel_with_trace divide mult_v1 rows = go (map (\(a, row) -> (row, Map.singleton a 1)) $ Map.toList rows) where

  lookupLhs :: (Map b v, Map a v) -> b -> v
  lookupLhs (lhs, _) b = case Map.lookup b lhs of
    Nothing -> zero
    Just x -> x

  addRow = add

  scaleRow = scale

  minusRow = minus

  remove_b :: (b, (Map b v, Map a v)) -> (Map b v, Map a v) -> (Map b v, Map a v)
  remove_b (b, row0) row1 =
    (\(m, r) -> if Map.member b m then error "should be absent" else (m, r)) $ addRow row1 (minusRow $ scaleRow (lookupLhs row1 b `divide` lookupLhs row0 b) row0)

  go :: [(Map b v, Map a v)] -> Solution_with_trace a b v
  go [] = Map.empty
  go (row0 : rest) = case [(b, v) | (b, v) <- Map.toList (fst row0), v /= zero] of
    [] -> -- all coefficients are 0, equation is useless
      go rest
    (chosen_b, chosen_v) : _ -> runIdentity $ do
      row0 <- return $ scaleRow (recip chosen_v) row0
      chosen_v <- return $ ()
      rest <- return $ map (remove_b (chosen_b, row0)) rest
      (lhs, rhs) <- return $ row0
      row0 <- return $ ()
      return $
        case go rest of
          solutionDecompose ->
            case map (\(b, v) ->
                             if b == chosen_b
                             then zero
                             else
                               case Map.lookup b solutionDecompose of
                                 Nothing -> do
                                   (Map.singleton b v, zero) -- don't need any recipes to make the raw material
                                 Just results ->
                                   scale v results
                          ) (Map.toList lhs) of
              lhs ->
                let sum_of_lhs = foldr add zero lhs in
                (Map.insert chosen_b (add (minus sum_of_lhs) (zero, rhs)) solutionDecompose)

max_stars_repo_name: Rotsor/factorio-module-selector

max_issues_repo_name: Rotsor/factorio-module-selector

max_forks_repo_name: Rotsor/factorio-module-selector


text:
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}

module Turtle where

import Control.Monad.State
-- import Control.Monad.Trans.Class
import Numeric.LinearAlgebra.HMatrix hiding (scale, (!))
import qualified Graphics.Rendering.OpenGL as GL
import Foreign.Storable
import GLCode
import Sketch
-- import Points
import Lines
import Triangles
import Data.Array
import Debug.Trace

clamp :: Float -> Float -> Float -> Float
clamp a b x | x < a = a
            | x > b = b
            | otherwise = x

lerp :: Float -> Float -> Float -> Float
lerp a b x = (1-x)*a+x*b

linstep :: Float -> Float -> Float -> Float
linstep a b x = clamp 0.0 1.0 ((x-a)/(b-a))

smoothstep :: Float -> Float -> Float -> Float
smoothstep a b x =
    let t = clamp 0.0 1.0 ((x-a)/(b-a))
    in t*t*(3.0-2.0*t)

v2f :: Real a => a -> a -> GL.Vertex2 Float
v2f x y = GL.Vertex2 (realToFrac x) (realToFrac y)

v3f :: Real a => a -> a -> a -> GL.Vertex3 Float
v3f x y z = GL.Vertex3 (realToFrac x) (realToFrac y) (realToFrac z)

v4f :: Real a => a -> a -> a -> a -> GL.Vertex4 Float
v4f x y z w = GL.Vertex4 (realToFrac x) (realToFrac y) (realToFrac z) (realToFrac w)

translation :: (Fractional a, Storable a) => a -> a -> a -> Matrix a
translation x y z = (4 >< 4) [ 1.0, 0.0, 0.0, 0.0,
                               0.0, 1.0, 0.0, 0.0,
                               0.0, 0.0, 1.0, 0.0,
                               x  , y  , z  , 1.0 ]

scaling :: (Fractional a, Storable a) => a -> a -> a -> Matrix a
scaling x y z = (4 >< 4) [ x  , 0.0, 0.0, 0.0,
                           0.0, y  , 0.0, 0.0,
                           0.0, 0.0, z  , 0.0,
                           0.0, 0.0, 0.0, 1.0 ]

rotation :: (Fractional a, Storable a, Floating a) => a -> Matrix a
rotation theta = let c = cos theta
                     s = sin theta
                 in (4 >< 4) [ c, s, 0.0, 0.0,
                               -s, c, 0.0, 0.0,
                               0.0, 0.0, 1.0, 0.0,
                               0.0, 0.0, 0.0, 1.0]

rectangle :: (Float, Float, Float) -> Float -> Float -> SketchMonad ()
rectangle (r, g, b) w h = do
    drawTriangle "turtle"
        "vPosition" (rectangleVertices w h)
        "color" [v4f r g b 1.0, v4f r g b 1.0, v4f r g b 1.0,
                 v4f r g b 1.0, v4f r g b 1.0, v4f r g b 1.0]

drawPath :: (Float, Float, Float) -> [(Float, Float)] -> SketchMonad ()
drawPath (r, g, b) vs = do
    drawLine "turtle"
        "vPosition" (map (uncurry v2f) vs)
        "color" (replicate (length vs) (v4f r g b 1.0))

plotPath :: (Float, Float, Float) -> Int -> (Float -> (Float, Float)) -> Float -> Float -> SketchMonad ()
plotPath rgb n f t0 t1 = do
    let scale = (t1-t0)/fromIntegral n
    drawPath rgb [f t | i <- [0..n],
                        let t = t0+scale*fromIntegral i]

constRectangle :: (Float, Float, Float) -> Float -> Float -> SketchMonad ()
constRectangle (r, g, b) w h = do
    drawTriangle "turtle"
        "vPosition" (rectangleVertices w h)
        "color" [v4f r g b 1.0, v4f r g b 1.0, v4f r g b 1.0,
                 v4f r g b 1.0, v4f r g b 1.0, v4f r g b 1.0]

rectangleVertices :: Float -> Float -> [GL.Vertex2 Float]
rectangleVertices w h =
        [v2f (-0.5*w) (-0.5*h), v2f (0.5*w) (-0.5*h), v2f (0.5*w) (0.5*h),
         v2f (-0.5*w) (-0.5*h), v2f (0.5*w) (0.5*h), v2f (-0.5*w) (0.5*h)]

rotate :: (Floating t, Numeric t, MonadState (Matrix t) m) => t -> m ()
rotate angle = modify (rotation angle `mul`)

scale :: (Fractional t, Numeric t, MonadState (Matrix t) m) => t -> t -> t -> m ()
scale s t u = modify (scaling s t u `mul`)

translate :: (Fractional t, Numeric t, MonadState (Matrix t) m) => t -> t -> t -> m ()
translate u v w = modify (translation u v w `mul`)

save :: StateT (Matrix Float) (StateT World IO) () -> StateT (Matrix Float) (StateT World IO) ()
save c = do
    m <- get
    a <- c
    put m
    setTransform
    return a

setTransform :: StateT (Matrix Float) (StateT World IO) ()
setTransform = do
    transform <- get
    lift $ setUniform "turtle"
               "transform" transform

setTransformPoint :: StateT (Matrix Float) (StateT World IO) ()
setTransformPoint = do
    transform <- get
    lift $ setUniform "turtle_point"
               "transform" transform

arrow :: (Float, Float, Float) -> Float -> Float -> Float -> Float -> SketchMonad ()
arrow (r, g, b) thickness headLength headWidth length = do
--     let thickness = 0.01
    constRectangle (r, g, b) length thickness
    drawTriangle "turtle"
        "vPosition" [v2f (0.5*length) (-0.5*headWidth), v2f (0.5*length+headLength) 0, v2f (0.5*length) (0.5*headWidth)]
        "color" [v4f r g b 1.0, v4f r g b 1.0,
                 v4f r g b 1.0]

grid :: Int -> Int -> Float -> Float ->
        (Int -> Int -> StateT (Matrix Float) (StateT World IO) ()) ->
        StateT (Matrix Float) (StateT World IO) ()
grid m n dx dy f =
    forM_ [0..(m-1)] $ \i ->
        forM_ [0..(n-1)] $ \j -> save $ do
            let x = dx*fromIntegral i
            let y = dy*fromIntegral j
            translate x y 0
            setTransform
            f i j

drawVectorField drawArrow m n dx dy vx vy = drawVectorField' drawArrow m n dx dy $ interpVelocityField vx vy

drawVectorField' drawArrow m n dx dy f =
    grid m n dx dy $ \i j -> do
        let (vx, vy) = f (fromIntegral i) (fromIntegral j)
        let theta = atan2 vy vx
        let r = sqrt (vx*vx+vy*vy)
        save $ do
            modify ((rotation theta) `mul`)
            transform <- get
            lift $ setUniform "turtle"
                              "transform" transform
            lift $ drawArrow r

type ColorMap = Float -> GL.Vertex4 Float

drawDensityField :: ColorMap -> Int -> Int -> Float -> Float -> Array (Int, Int) Float -> StateT (Matrix Float) (StateT World IO) ()
drawDensityField cmap m n dx dy a =
    grid m n dx dy $ \i j -> do
        let ip = (i+1) `mod` m
        let jp = (j+1) `mod` m
        lift $ drawTriangle "turtle"
                            "vPosition" [v2f 0.0 0.0, v2f dx 0.0, v2f dx dy,
                                         v2f 0.0 0.0, v2f dx dy, v2f 0.0 dy]
                            "color"     [cmap (a!(i, j)), cmap (a!(ip, j)), cmap (a!(ip, jp)),
                                         cmap (a!(i, j)), cmap (a!(ip, jp)), cmap (a!(i, jp))]

coolwarm :: Float -> Float -> Float -> GL.Vertex4 Float
coolwarm a b x =
    let mid = 0.5*(a+b)
    in if x > mid
        then let t = smoothstep mid b x in v4f 1.0 (1.0-t) (1.0-t) 1.0
        else let t = smoothstep mid a x in v4f (1.0-t) (1.0-t) 1.0 1.0

-- Interpolate velocity onto uniform grid from staggered grid
-- Let's say velocity field defined by
-- vx!(x, y) = v (x-0.5) y
-- vy!(x, y) = v x (y-0.5)
--
-- So, for example, (v x y)_x = vx!(x,y)+vx!(x+1,y)
interpVelocity :: Array (Int, Int) Float -> Array (Int, Int) Float -> Array (Int, Int) (Float, Float)
interpVelocity vx vy =
    let (_, (nx, ny)) = bounds vx
    in array ((0, 0), (nx, ny)) [((i, j), (0.5*(vx!(ip, j)+vx!(i, j)), 0.5*(vy!(i, jp)+vy!(i, j)))) |
                                 i <- [0..nx],
                                 j <- [0..ny],
                                 let ip = (i+1) `mod` (nx+1),
                                 let jp = (j+1) `mod` (ny+1)]

interpVelocityField :: Array (Int, Int) Float -> Array (Int, Int) Float -> Float -> Float -> (Float, Float)
interpVelocityField vx vy x y =
    (interpScalarField vx (x+0.5) y, interpScalarField vy x (y+0.5))
--     let (_, (nx, ny)) = bounds vx
--         x = x0+0.5
--         y = y0+0.5
--         ix = floor x `mod` nx
--         iy = floor y `mod` ny
--         ixp = (ix+1) `mod` nx
--         iyp = (iy+1) `mod` ny
--         fx = x-fromIntegral ix
--         fy = y-fromIntegral iy
--         vx00 = lerp (vx!(ix, iy)) (vy!(ixp, iy))
--     in (lerp (vx!(ix, iy)) (vx!(ixp, iy)) fx,
--         lerp (vy!(ix, iy)) (vy!(ix, iyp)) fy)

interpScalarField :: Array (Int, Int) Float -> Float -> Float -> Float
interpScalarField p x y =
    let (_, (nx, ny)) = bounds p
        ix = floor x `mod` nx
        iy = floor y `mod` ny
        ixp = (ix+1) `mod` nx
        iyp = (iy+1) `mod` ny
        fx = x-fromIntegral ix
        fy = y-fromIntegral iy
        p00 = p!(ix, iy)
        p01 = p!(ix, iyp)
        p10 = p!(ixp, iy)
        p11 = p!(ixp, iyp)
        p0 = lerp p00 p01 fy
        p1 = lerp p10 p11 fy
    in lerp p0 p1 fx

divergence :: Array (Int, Int) Float -> Array (Int, Int) Float -> Array (Int, Int) (Float, Float)
divergence vx vy =
    let (_, (nx, ny)) = bounds vx
    in array ((0, 0), (nx, ny)) [((i, j), (vx!(ip, j)-vx!(i, j), vy!(i, jp)-vy!(i, j))) |
                                 i <- [0..nx],
                                 j <- [0..ny],
                                 let ip = (i+1) `mod` (nx+1),
                                 let jp = (j+1) `mod` (ny+1)]

grad :: Array (Int, Int) Float -> (Array (Int, Int) Float, Array (Int, Int) Float)
grad p =
    let (_, (nx, ny)) = bounds p
        vx = array ((0, 0), (nx, ny)) [((i, j), p!(ip, j)-p!(i, j)) |
                                      i <- [0..nx],
                                      j <- [0..ny],
                                      let ip = (i+1) `mod` (nx+1)]
        vy = array ((0, 0), (nx, ny)) [((ix, iy), p!(ix, iyp)-p!(ix, iy)) |
                                      ix <- [0..nx],
                                      iy <- [0..ny],
                                      let iyp = (iy+1) `mod` (ny+1)]
    in (vx, vy)

integrate :: (Float -> Float -> (Float, Float)) -> Float -> Float -> Int -> Float -> [(Float, Float)]
integrate v x y 0 dt = []
integrate v x y n dt = (x, y) :
    let (vx, vy) = v x y
    in integrate v (x+dt*vx) (y+dt*vy) (n-1) dt

duringAndAfter :: Monad m => Float -> Float -> Float -> (Float -> m ()) -> m ()
duringAndAfter t t0 t1 m =
    if t < t0
        then return ()
        else if t > t1
            then m 1
            else m ((t-t0)/(t1-t0))

beforeAndDuring :: Monad m => Float -> Float -> Float -> (Float -> m ()) -> m ()
beforeAndDuring t t0 t1 m =
    if t > t1
        then return ()
        else if t < t0
            then m 1
            else m ((t-t1)/(t0-t1))

max_stars_repo_name: dpiponi/SketchBox

max_issues_repo_name: dpiponi/SketchBox

max_forks_repo_name: dpiponi/SketchBox


text:
{-# LANGUAGE FlexibleInstances #-}

module Main where

import Control.Monad
import Graphics.Rendering.Chart
import Data.Colour
import Data.Colour.Names
import Data.Default.Class
import Graphics.Rendering.Chart.Backend.Cairo
import Control.Lens
import Data.Complex

setLinesBlue :: PlotLines a b -> PlotLines a b
setLinesBlue = plot_lines_style  . line_color .~ opaque blue

chart :: Renderable ()
chart = toRenderable layout
  where
    sumf = plot_lines_values .~ [[ (x,(s x)) | x <- [1.3,(1.31)..10]]]
              $ plot_lines_style  . line_color .~ opaque black
              $ plot_lines_title .~ "S(a)"
              $ def

    tln = plot_lines_values .~ [[ (x,(taylor1 2.0 x)) | x <- [1.3,(1.4)..3.5]]]
              $ plot_lines_style  . line_color .~ opaque red
              $ plot_lines_title .~ "First taylor"
              $ def

    tln2 = plot_lines_values .~ [[ (x,(taylor2 2.0 x)) | x <- [1.3,(1.4)..4.0]]]
              $ plot_lines_style  . line_color .~ opaque orange
              $ plot_lines_title .~ "Second taylor"
              $ def

    tln3 = plot_lines_values .~ [[ (x,(taylor3 2.0 x)) | x <- [1.3,(1.4)..3.2]]]
              $ plot_lines_style  . line_color .~ opaque blue
              $ plot_lines_title .~ "Third taylor"
              $ def

    layout = layout_title .~ "Amplitude Modulation"
           $ layout_plots .~ [toPlot sumf, toPlot tln, toPlot tln2, toPlot tln3]
           $ def

renderChart :: IO (PickFn ())
renderChart = renderableToFile def "example1_big.png" chart

approxS :: Int -> Double -> Double
approxS i a = sum $ map (f.fromIntegral) [1..i]
  where f n = n**(-a)

class Abs a where
  absoluteValue :: a -> Double

instance Abs Double where
  absoluteValue = abs

instance Abs (Complex Double) where
  absoluteValue = magnitude

untilConverged :: (Abs a, Floating a, Num a) => Double -> [a] -> a
untilConverged epsilon (x1:xs) = go x1 xs
  where go last (y:ys) =
         if absoluteValue (last - y) < epsilon
           then y
           else go y ys

sumSeries :: (Abs a, Floating a, Num a) => (Int -> a) -> a
sumSeries seriesGen = untilConverged 0.000001 $ tail $ scanl1 (+) $ map seriesGen [1..]

s :: Double -> Double
s a = sumSeries $ \n-> (fromIntegral n)**(-a)

sDerivative :: (Abs a, Floating a, Num a) => Int -> a -> a
sDerivative d a = sign * (sumSeries $ \nInt ->
    let n = fromIntegral nInt in
    (fromIntegral nInt)**(-a) * (realToFrac $ log n)^d)
  where sign = if even d then 1 else (-1)

fact :: Int -> Int
fact 0 = 1
fact n = n * fact (n - 1)

taylorCoeffients :: (Fractional a, Num a) => (Int -> a -> a) -> a -> [a]
taylorCoeffients f a0 = map g [0..]
  where g n = (f n a0) / fromIntegral (fact n)

taylor1 :: Double -> Double -> Double
taylor1 a0 a = s a0 + (a - a0) * sDerivative 1 a0

taylor2 :: Double -> Double -> Double
taylor2 a0 a = s a0 + (a - a0) * sDerivative 1 a0 + 0.5 * (a - a0)^2 * sDerivative 2 a0

taylor3 :: Double -> Double -> Double
taylor3 a0 a = s a0 + (a - a0) * sDerivative 1 a0 + 0.5 * (a - a0)^2 * sDerivative 2 a0 + (1.0/6.0) * (a - a0)^3 * sDerivative 3 a0

main :: IO ()
main = void $ renderChart

max_stars_repo_name: gcharnock/zeta-function

max_issues_repo_name: gcharnock/zeta-function

max_forks_repo_name: gcharnock/zeta-function


text:
-- (C) Copyright Chris Banks 2011-2012

-- This file is part of The Continuous Pi-calculus Workbench (BondCalculusWB).

--     BondCalculusWB is free software: you can redistribute it and/or modify
--     it under the terms of the GNU General Public License as published by
--     the Free Software Foundation, either version 3 of the License, or
--     (at your option) any later version.

--     BondCalculusWB is distributed in the hope that it will be useful,
--     but WITHOUT ANY WARRANTY; without even the implied warranty of
--     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--     GNU General Public License for more details.

--     You should have received a copy of the GNU General Public License
--     along with BondCalculusWB.  If not, see <http://www.gnu.org/licenses/>.

module BioCalcLib.Plot
    (plot, plotD, plotToFile, layout, plots, plotPhaseToFile, plotPhase,
     plotPhaseD, plotphase, layout2phase, colours
    ) where

import Graphics.Rendering.Chart
import Graphics.Rendering.Chart.Gtk
import Graphics.Rendering.Chart.Backend.Cairo
import Data.Colour.Names
import Data.Colour.SRGB
import Data.Colour
-- import Data.Accessor
import Data.Default.Class
import Control.Lens
import qualified Control.Exception as X
import qualified Numeric.LinearAlgebra as LA
import Control.Monad
import Graphics.UI.Gtk.Misc.DrawingArea
import qualified Data.List as L

import BioCalcLib.Lib

-- Plots the time series in a GTK window
plot :: [Double] -> [(String,[Double])] -> IO ()
plot ts dims = renderableToWindow (toRenderable (layout ts dims)) 639 480

plotD  :: DrawingArea -> [Double] -> [(String,[Double])] -> IO ()
plotD da ts dims = do
  _ <- updateCanvas (toRenderable (layout ts dims)) da
  return ()

-- Plots the time series to a file
plotToFile :: [Double] -> [(String,[Double])] -> String -> IO ()
plotToFile ts dims file = void $ renderableToFile (FileOptions (842, 595) PDF) file (toRenderable (layout ts dims))

-- gets a plot layout with plots for each dimension
layout :: [Double] -> [(String, [Double])] -> Layout Double Double
layout ts dims = layout_plots .~ plots ts (colours (length dims)) dims
  $ def
                 -- layout1_legend ^= Nothing $ {-remove to add legend-}

-- gets the plots for each dimension
-- plots :: [Double] -> [AlphaColour Double] -> [(String,[Double])] ->
--          [Either (Plot Double Double) b]
plots :: [Double] -> [AlphaColour Double] -> [(String,[Double])] ->
         [Plot Double Double]
plots _ _ [] = []
plots ts (colour:cs) ((lbl,pts):dims)
    = toPlot
      ( plot_lines_style .~ solidLine 1 colour
      $ plot_lines_values .~ [zip ts pts]
      $ plot_lines_title .~ lbl
      $ def
      ) : plots ts cs dims
plots _ [] _ = X.throw $ CpiException
               "BondCalculus.Plot.plots: Run out of colours!"

---------------
-- Phase plots:
---------------

plotPhaseToFile :: [(String, [Double])] -> String -> IO ()
plotPhaseToFile dims file = void $ renderableToFile
                                   (FileOptions (842, 595) PDF) file
                                   (toRenderable (layout2phase dims))

-- getRender :: LA.Vector Double -> LA.Matrix Double -> [Species] -> [Species] -> Int -> Int -> (Maybe (Render ()))
-- getRender  ts soln ss ss' ww wh = (Just $ runBackend (defaultEnv bitmapAlignmentFns)
--            ( void $ render (getLayout ts soln ss ss') (fromIntegral ww, fromIntegral wh) )
--          )

plotPhase :: PlotValue y0 => [(String, [y0])] -> IO ()
plotPhase dims = renderableToWindow (toRenderable (layout2phase dims)) 640 480

plotPhaseD  :: DrawingArea -> [(String,[Double])] -> IO ()
plotPhaseD da dims = void $ updateCanvas (toRenderable (layout2phase dims)) da

plotphase :: [(x, y)] -> Plot x y
plotphase pts
    = toPlot
      $ plot_lines_values .~ [pts]
      $ plot_lines_style .~ solidLine 1 (opaque blue)
      $ def

layout2phase :: PlotValue y0 => [(String, [y0])] -> Layout y0 y0
layout2phase dims
    = layout_plots .~ [plotphase $ zip (snd (head dims)) (snd (dims!!1))]
--      $ layout1_bottom_axis ^: laxis_generate ^= autoScaledLogAxis defaultLogAxis
      $ layout_x_axis . laxis_title .~ "["++fst (head dims)++"]"
--      $ layout1_left_axis ^: laxis_generate ^= autoScaledLogAxis defaultLogAxis
      $ layout_y_axis . laxis_title .~ "["++fst (dims!!1)++"]"
      $ def

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

-- gives n visually distinct colours
-- algorithm taken from the MATLAB 'varycolor' function
-- by Daniel Helmick: http://j.mp/xowLV2
colours :: Int -> [AlphaColour Double]
colours n
    | n<=0 = []
    | n==1 = [clr 0 1 0]
    | n==2 = [clr 0 1 0,clr 0 1 1]
    | n==3 = [clr 0 1 0,clr 0 1 1,clr 0 0 1]
    | n==4 = [clr 0 1 0,clr 0 1 1,clr 0 0 1,clr 1 0 1]
    | n==5 = [clr 0 1 0,clr 0 1 1,clr 0 0 1,clr 1 0 1,clr 1 0 0]
    | n==6 = [clr 0 1 0,clr 0 1 1,clr 0 0 1,clr 1 0 1,clr 1 0 0,clr 0 0 0]
    | otherwise = sec (1::Integer) ++ sec 2 ++ sec 3 ++ sec 4 ++ sec 5
    where
      s = fromIntegral(n `div` 5)
      e = fromIntegral(n `mod` 5)
      f x y
          | x<=y = 1.0
          | otherwise = 0.0
      g x = [1..(s + f x e)]
      sec x
          | x==1 = [clr 0 1 ((m-1)/(s + f x e - 1)) | m<-g x]
          | x==2 = [clr 0 ((s + f x e - m)/(s + f x e)) 1 | m<-[1..(s + f x e)]]
          | x==3 = [clr (m/(s + f x e)) 0 1 | m<-[1..(s + f x e)]]
          | x==4 = [clr 1 0 ((s + f x e - m)/(s + f x e)) | m<-[1..(s + f x e)]]
          | x==5 = [clr ((s + f x e - m)/(s + f x e)) 0 0 | m<-[1..(s + f x e)]]
          | otherwise = undefined

clr :: Double -> Double -> Double -> AlphaColour Double
clr r g b = opaque $ sRGB r g b

{-- test data
testT = [0.0,0.1..2500.0]::[Double]
testD1 = [0,0.1..2500]::[Double]
testD2 = [x*x|x<-[0,0.1..2500]]::[Double]

testPlot1 = plot_lines_style ^= solidLine 1 (opaque $ sRGB 0.5 0.5 1)
            $ plot_lines_values ^= [zip testT testD1]
            $ plot_lines_title ^= "test1"
            $ defaultPlotLines

testPlot2 = plot_lines_style ^= solidLine 1 (opaque red)
            $ plot_lines_values ^= [zip testT testD2]
            $ plot_lines_title ^= "test2"
            $ defaultPlotLines

testLayout = layout1_title ^= "Test graph!"
             $ layout1_plots ^= [Left (toPlot testPlot1),
                                 Left (toPlot testPlot2)]
             $ defaultLayout1

testPlot = renderableToWindow (toRenderable testLayout) 640 480
-}

max_stars_repo_name: twright/bondwb

max_issues_repo_name: twright/bondwb

max_forks_repo_name: twright/bondwb


text:
{-|
Type aliases for activation functions and their derivative.
-}
module ML.NN.ActivationFunction (ActivationFunction, ActivationFunctionDerivative) where

import Numeric.LinearAlgebra (R)

-- | An activation function for a neuron.
type ActivationFunction = R -> R

-- | The derivative of a neuron activation function.
type ActivationFunctionDerivative = R -> R

max_stars_repo_name: m-renaud/ML

max_issues_repo_name: m-renaud/ML

max_forks_repo_name: m-renaud/ML


text:
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 708

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}

{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-simplifiable-class-constraints #-}

{- |
Module      :  Internal.Static
Copyright   :  (c) Alberto Ruiz 2006-14
License     :  BSD3
Stability   :  provisional

-}

module Internal.Static where

import GHC.TypeLits
import qualified Numeric.LinearAlgebra as LA
import Numeric.LinearAlgebra hiding (konst,size,R,C)
import Internal.Vector as D hiding (R,C)
import Internal.ST
import Control.DeepSeq
import Data.Proxy(Proxy)
import Foreign.Storable(Storable)
import Text.Printf

import Data.Binary
import GHC.Generics (Generic)
import Data.Proxy (Proxy(..))

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

type ℝ = Float
type ℂ = Complex Float

newtype Dim (n :: Nat) t = Dim t
  deriving (Show, Generic)

instance (KnownNat n, Binary a) => Binary (Dim n a) where
  get = do
    k <- get
    let n = natVal (Proxy :: Proxy n)
    if n == k
      then Dim <$> get
      else fail ("Expected dimension " ++ (show n) ++ ", but found dimension " ++ (show k))

  put (Dim x) = do
    put (natVal (Proxy :: Proxy n))
    put x

lift1F
  :: (c t -> c t)
  -> Dim n (c t) -> Dim n (c t)
lift1F f (Dim v) = Dim (f v)

lift2F
  :: (c t -> c t -> c t)
  -> Dim n (c t) -> Dim n (c t) -> Dim n (c t)
lift2F f (Dim u) (Dim v) = Dim (f u v)

instance NFData t => NFData (Dim n t) where
    rnf (Dim (force -> !_)) = ()

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

newtype R n = R (Dim n (Vector ℝ))
  deriving (Num,Fractional,Floating,Generic,Binary)

newtype C n = C (Dim n (Vector ℂ))
  deriving (Num,Fractional,Floating,Generic)

newtype L m n = L (Dim m (Dim n (Matrix ℝ)))
  deriving (Generic, Binary)

newtype M m n = M (Dim m (Dim n (Matrix ℂ)))
  deriving (Generic)

mkR :: Vector ℝ -> R n
mkR = R . Dim

mkC :: Vector ℂ -> C n
mkC = C . Dim

mkL :: Matrix ℝ -> L m n
mkL x = L (Dim (Dim x))

mkM :: Matrix ℂ -> M m n
mkM x = M (Dim (Dim x))

instance NFData (R n) where
    rnf (R (force -> !_)) = ()

instance NFData (C n) where
    rnf (C (force -> !_)) = ()

instance NFData (L n m) where
    rnf (L (force -> !_)) = ()

instance NFData (M n m) where
    rnf (M (force -> !_)) = ()

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

type V n t = Dim n (Vector t)

ud :: Dim n (Vector t) -> Vector t
ud (Dim v) = v

mkV :: forall (n :: Nat) t . t -> Dim n t
mkV = Dim

vconcat :: forall n m t . (KnownNat n, KnownNat m, Numeric t)
    => V n t -> V m t -> V (n+m) t
(ud -> u) `vconcat` (ud -> v) = mkV (vjoin [u', v'])
  where
    du = fromIntegral . natVal $ (undefined :: Proxy n)
    dv = fromIntegral . natVal $ (undefined :: Proxy m)
    u' | du /= 1 && LA.size u == 1 = LA.konst (u D.@> 0) du
       | otherwise = u
    v' | dv /= 1 && LA.size v == 1 = LA.konst (v D.@> 0) dv
       | otherwise = v

gvec2 :: Storable t => t -> t -> V 2 t
gvec2 a b = mkV $ runSTVector $ do
    v <- newUndefinedVector 2
    writeVector v 0 a
    writeVector v 1 b
    return v

gvec3 :: Storable t => t -> t -> t -> V 3 t
gvec3 a b c = mkV $ runSTVector $ do
    v <- newUndefinedVector 3
    writeVector v 0 a
    writeVector v 1 b
    writeVector v 2 c
    return v

gvec4 :: Storable t => t -> t -> t -> t -> V 4 t
gvec4 a b c d = mkV $ runSTVector $ do
    v <- newUndefinedVector 4
    writeVector v 0 a
    writeVector v 1 b
    writeVector v 2 c
    writeVector v 3 d
    return v

gvect :: forall n t . (Show t, KnownNat n, Numeric t) => String -> [t] -> V n t
gvect st xs'
    | ok = mkV v
    | not (null rest) && null (tail rest) = abort (show xs')
    | not (null rest) = abort (init (show (xs++take 1 rest))++", ... ]")
    | otherwise = abort (show xs)
  where
    (xs,rest) = splitAt d xs'
    ok = LA.size v == d && null rest
    v = LA.fromList xs
    d = fromIntegral . natVal $ (undefined :: Proxy n)
    abort info = error $ st++" "++show d++" can't be created from elements "++info

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

type GM m n t = Dim m (Dim n (Matrix t))

gmat :: forall m n t . (Show t, KnownNat m, KnownNat n, Numeric t) => String -> [t] -> GM m n t
gmat st xs'
    | ok = Dim (Dim x)
    | not (null rest) && null (tail rest) = abort (show xs')
    | not (null rest) = abort (init (show (xs++take 1 rest))++", ... ]")
    | otherwise = abort (show xs)
  where
    (xs,rest) = splitAt (m'*n') xs'
    v = LA.fromList xs
    x = reshape n' v
    ok = null rest && ((n' == 0 && dim v == 0) || n'> 0 && (rem (LA.size v) n' == 0) && LA.size x == (m',n'))
    m' = fromIntegral . natVal $ (undefined :: Proxy m) :: Int
    n' = fromIntegral . natVal $ (undefined :: Proxy n) :: Int
    abort info = error $ st ++" "++show m' ++ " " ++ show n'++" can't be created from elements " ++ info

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

class Num t => Sized t s d | s -> t, s -> d
  where
    konst     ::  t   -> s
    unwrap    ::  s   -> d t
    fromList  :: [t]  -> s
    extract   ::  s   -> d t
    create    ::  d t -> Maybe s
    size      ::  s   -> IndexOf d

singleV v = LA.size v == 1
singleM m = rows m == 1 && cols m == 1

instance KnownNat n => Sized ℂ (C n) Vector
  where
    size _ = fromIntegral . natVal $ (undefined :: Proxy n)
    konst x = mkC (LA.scalar x)
    unwrap (C (Dim v)) = v
    fromList xs = C (gvect "C" xs)
    extract s@(unwrap -> v)
      | singleV v = LA.konst (v!0) (size s)
      | otherwise = v
    create v
        | LA.size v == size r = Just r
        | otherwise = Nothing
      where
        r = mkC v :: C n

instance KnownNat n => Sized ℝ (R n) Vector
  where
    size _ = fromIntegral . natVal $ (undefined :: Proxy n)
    konst x = mkR (LA.scalar x)
    unwrap (R (Dim v)) = v
    fromList xs = R (gvect "R" xs)
    extract s@(unwrap -> v)
      | singleV v = LA.konst (v!0) (size s)
      | otherwise = v
    create v
        | LA.size v == size r = Just r
        | otherwise = Nothing
      where
        r = mkR v :: R n

instance (KnownNat m, KnownNat n) => Sized ℝ (L m n) Matrix
  where
    size _ = ((fromIntegral . natVal) (undefined :: Proxy m)
             ,(fromIntegral . natVal) (undefined :: Proxy n))
    konst x = mkL (LA.scalar x)
    fromList xs = L (gmat "L" xs)
    unwrap (L (Dim (Dim m))) = m
    extract (isDiag -> Just (z,y,(m',n'))) = diagRect z y m' n'
    extract s@(unwrap -> a)
        | singleM a = LA.konst (a `atIndex` (0,0)) (size s)
        | otherwise = a
    create x
        | LA.size x == size r = Just r
        | otherwise = Nothing
      where
        r = mkL x :: L m n

instance (KnownNat m, KnownNat n) => Sized ℂ (M m n) Matrix
  where
    size _ = ((fromIntegral . natVal) (undefined :: Proxy m)
             ,(fromIntegral . natVal) (undefined :: Proxy n))
    konst x = mkM (LA.scalar x)
    fromList xs = M (gmat "M" xs)
    unwrap (M (Dim (Dim m))) = m
    extract (isDiagC -> Just (z,y,(m',n'))) = diagRect z y m' n'
    extract s@(unwrap -> a)
        | singleM a = LA.konst (a `atIndex` (0,0)) (size s)
        | otherwise = a
    create x
        | LA.size x == size r = Just r
        | otherwise = Nothing
      where
        r = mkM x :: M m n

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

instance (KnownNat n, KnownNat m) => Transposable (L m n) (L n m)
  where
    tr a@(isDiag -> Just _) = mkL (extract a)
    tr (extract -> a) = mkL (tr a)
    tr' = tr

instance (KnownNat n, KnownNat m) => Transposable (M m n) (M n m)
  where
    tr a@(isDiagC -> Just _) = mkM (extract a)
    tr (extract -> a) = mkM (tr a)
    tr' a@(isDiagC -> Just _) = mkM (extract a)
    tr' (extract -> a) = mkM (tr' a)

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

isDiag :: forall m n . (KnownNat m, KnownNat n) => L m n -> Maybe (ℝ, Vector ℝ, (Int,Int))
isDiag (L x) = isDiagg x

isDiagC :: forall m n . (KnownNat m, KnownNat n) => M m n -> Maybe (ℂ, Vector ℂ, (Int,Int))
isDiagC (M x) = isDiagg x

isDiagg :: forall m n t . (Numeric t, KnownNat m, KnownNat n) => GM m n t -> Maybe (t, Vector t, (Int,Int))
isDiagg (Dim (Dim x))
    | singleM x = Nothing
    | rows x == 1 && m' > 1 || cols x == 1 && n' > 1 = Just (z,yz,(m',n'))
    | otherwise = Nothing
  where
    m' = fromIntegral . natVal $ (undefined :: Proxy m) :: Int
    n' = fromIntegral . natVal $ (undefined :: Proxy n) :: Int
    v = flatten x
    z = v `atIndex` 0
    y = subVector 1 (LA.size v-1) v
    ny = LA.size y
    zeros = LA.konst 0 (max 0 (min m' n' - ny))
    yz = vjoin [y,zeros]

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

instance KnownNat n => Show (R n)
  where
    show s@(R (Dim v))
      | singleV v = "(" ++ show (v!0) ++ " :: R " ++ show d ++ ")"
      | otherwise = "(vector " ++ show v ++ " :: R " ++ show d ++")"
      where
        d = size s

instance KnownNat n => Show (C n)
  where
    show s@(C (Dim v))
      | singleV v = "(" ++ show (v!0) ++ " :: C " ++ show d ++ ")"
      | otherwise = "(vector " ++ show v ++ " :: C " ++ show d ++")"
      where
        d = size s

instance (KnownNat m, KnownNat n) => Show (L m n)
  where
    show (isDiag -> Just (z,y,(m',n'))) = printf "(diag %s %s :: L %d %d)" (show z) (show y) m' n'
    show s@(L (Dim (Dim x)))
       | singleM x = printf "(%s :: L %d %d)" (show (x `atIndex` (0,0))) m' n'
       | otherwise = "(matrix" ++ dropWhile (/='\n') (show x) ++ " :: L " ++ show m' ++ " " ++ show n' ++ ")"
      where
        (m',n') = size s

instance (KnownNat m, KnownNat n) => Show (M m n)
  where
    show (isDiagC -> Just (z,y,(m',n'))) = printf "(diag %s %s :: M %d %d)" (show z) (show y) m' n'
    show s@(M (Dim (Dim x)))
       | singleM x = printf "(%s :: M %d %d)" (show (x `atIndex` (0,0))) m' n'
       | otherwise = "(matrix" ++ dropWhile (/='\n') (show x) ++ " :: M " ++ show m' ++ " " ++ show n' ++ ")"
      where
        (m',n') = size s

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

instance (Num (Vector t), Numeric t )=> Num (Dim n (Vector t))
  where
    (+) = lift2F (+)
    (*) = lift2F (*)
    (-) = lift2F (-)
    abs = lift1F abs
    signum = lift1F signum
    negate = lift1F negate
    fromInteger x = Dim (fromInteger x)

instance (Num (Vector t), Num (Matrix t), Fractional t, Numeric t) => Fractional (Dim n (Vector t))
  where
    fromRational x = Dim (fromRational x)
    (/) = lift2F (/)

instance (Fractional t, Floating (Vector t), Numeric t) => Floating (Dim n (Vector t)) where
    sin   = lift1F sin
    cos   = lift1F cos
    tan   = lift1F tan
    asin  = lift1F asin
    acos  = lift1F acos
    atan  = lift1F atan
    sinh  = lift1F sinh
    cosh  = lift1F cosh
    tanh  = lift1F tanh
    asinh = lift1F asinh
    acosh = lift1F acosh
    atanh = lift1F atanh
    exp   = lift1F exp
    log   = lift1F log
    sqrt  = lift1F sqrt
    (**)  = lift2F (**)
    pi    = Dim pi

instance (Num (Matrix t), Numeric t) => Num (Dim m (Dim n (Matrix t)))
  where
    (+) = (lift2F . lift2F) (+)
    (*) = (lift2F . lift2F) (*)
    (-) = (lift2F . lift2F) (-)
    abs = (lift1F . lift1F) abs
    signum = (lift1F . lift1F) signum
    negate = (lift1F . lift1F) negate
    fromInteger x = Dim (Dim (fromInteger x))

instance (Num (Vector t), Num (Matrix t), Fractional t, Numeric t) => Fractional (Dim m (Dim n (Matrix t)))
  where
    fromRational x = Dim (Dim (fromRational x))
    (/) = (lift2F.lift2F) (/)

instance (Num (Vector t), Floating (Matrix t), Fractional t, Numeric t) => Floating (Dim m (Dim n (Matrix t))) where
    sin   = (lift1F . lift1F) sin
    cos   = (lift1F . lift1F) cos
    tan   = (lift1F . lift1F) tan
    asin  = (lift1F . lift1F) asin
    acos  = (lift1F . lift1F) acos
    atan  = (lift1F . lift1F) atan
    sinh  = (lift1F . lift1F) sinh
    cosh  = (lift1F . lift1F) cosh
    tanh  = (lift1F . lift1F) tanh
    asinh = (lift1F . lift1F) asinh
    acosh = (lift1F . lift1F) acosh
    atanh = (lift1F . lift1F) atanh
    exp   = (lift1F . lift1F) exp
    log   = (lift1F . lift1F) log
    sqrt  = (lift1F . lift1F) sqrt
    (**)  = (lift2F . lift2F) (**)
    pi    = Dim (Dim pi)

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

adaptDiag f a@(isDiag -> Just _) b | isFull b = f (mkL (extract a)) b
adaptDiag f a b@(isDiag -> Just _) | isFull a = f a (mkL (extract b))
adaptDiag f a b = f a b

isFull m = isDiag m == Nothing && not (singleM (unwrap m))

lift1L f (L v) = L (f v)
lift2L f (L a) (L b) = L (f a b)
lift2LD f = adaptDiag (lift2L f)

instance (KnownNat n, KnownNat m) =>  Num (L n m)
  where
    (+) = lift2LD (+)
    (*) = lift2LD (*)
    (-) = lift2LD (-)
    abs = lift1L abs
    signum = lift1L signum
    negate = lift1L negate
    fromInteger = L . Dim . Dim . fromInteger

instance (KnownNat n, KnownNat m) => Fractional (L n m)
  where
    fromRational = L . Dim . Dim . fromRational
    (/) = lift2LD (/)

instance (KnownNat n, KnownNat m) => Floating (L n m) where
    sin   = lift1L sin
    cos   = lift1L cos
    tan   = lift1L tan
    asin  = lift1L asin
    acos  = lift1L acos
    atan  = lift1L atan
    sinh  = lift1L sinh
    cosh  = lift1L cosh
    tanh  = lift1L tanh
    asinh = lift1L asinh
    acosh = lift1L acosh
    atanh = lift1L atanh
    exp   = lift1L exp
    log   = lift1L log
    sqrt  = lift1L sqrt
    (**)  = lift2LD (**)
    pi    = konst pi

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

adaptDiagC f a@(isDiagC -> Just _) b | isFullC b = f (mkM (extract a)) b
adaptDiagC f a b@(isDiagC -> Just _) | isFullC a = f a (mkM (extract b))
adaptDiagC f a b = f a b

isFullC m = isDiagC m == Nothing && not (singleM (unwrap m))

lift1M f (M v) = M (f v)
lift2M f (M a) (M b) = M (f a b)
lift2MD f = adaptDiagC (lift2M f)

instance (KnownNat n, KnownNat m) =>  Num (M n m)
  where
    (+) = lift2MD (+)
    (*) = lift2MD (*)
    (-) = lift2MD (-)
    abs = lift1M abs
    signum = lift1M signum
    negate = lift1M negate
    fromInteger = M . Dim . Dim . fromInteger

instance (KnownNat n, KnownNat m) => Fractional (M n m)
  where
    fromRational = M . Dim . Dim . fromRational
    (/) = lift2MD (/)

instance (KnownNat n, KnownNat m) => Floating (M n m) where
    sin   = lift1M sin
    cos   = lift1M cos
    tan   = lift1M tan
    asin  = lift1M asin
    acos  = lift1M acos
    atan  = lift1M atan
    sinh  = lift1M sinh
    cosh  = lift1M cosh
    tanh  = lift1M tanh
    asinh = lift1M asinh
    acosh = lift1M acosh
    atanh = lift1M atanh
    exp   = lift1M exp
    log   = lift1M log
    sqrt  = lift1M sqrt
    (**)  = lift2MD (**)
    pi    = M pi

instance Additive (R n) where
    add = (+)

instance Additive (C n) where
    add = (+)

instance (KnownNat m, KnownNat n) => Additive (L m n) where
    add = (+)

instance (KnownNat m, KnownNat n) => Additive (M m n) where
    add = (+)

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

class Disp t
  where
    disp :: Int -> t -> IO ()

instance (KnownNat m, KnownNat n) => Disp (L m n)
  where
    disp n x = do
        let a = extract x
        let su = LA.dispf n a
        printf "L %d %d" (rows a) (cols a) >> putStr (dropWhile (/='\n') $ su)

instance (KnownNat m, KnownNat n) => Disp (M m n)
  where
    disp n x = do
        let a = extract x
        let su = LA.dispcf n a
        printf "M %d %d" (rows a) (cols a) >> putStr (dropWhile (/='\n') $ su)

instance KnownNat n => Disp (R n)
  where
    disp n v = do
        let su = LA.dispf n (asRow $ extract v)
        putStr "R " >> putStr (tail . dropWhile (/='x') $ su)

instance KnownNat n => Disp (C n)
  where
    disp n v = do
        let su = LA.dispcf n (asRow $ extract v)
        putStr "C " >> putStr (tail . dropWhile (/='x') $ su)

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

overMatL' :: (KnownNat m, KnownNat n)
          => (LA.Matrix ℝ -> LA.Matrix ℝ) -> L m n -> L m n
overMatL' f = mkL . f . unwrap
{-# INLINE overMatL' #-}

overMatM' :: (KnownNat m, KnownNat n)
          => (LA.Matrix ℂ -> LA.Matrix ℂ) -> M m n -> M m n
overMatM' f = mkM . f . unwrap
{-# INLINE overMatM' #-}

#else

module Numeric.LinearAlgebra.Static.Internal where

#endif

max_stars_repo_name: schnecki/hmatrix-float

max_issues_repo_name: schnecki/hmatrix-float

max_forks_repo_name: schnecki/hmatrix-float


text:
import Prelude hiding ((<>))
import Numeric.LinearAlgebra hiding (size, step)
import qualified System.Clock as Clock
import Data.Csv (FromNamedRecord, ToNamedRecord, DefaultOrdered)
import Data.Csv.Incremental
import GHC.Generics (Generic)
import qualified Data.ByteString.Lazy as LBS
import Numeric.Sundials.CVode.ODE
import Control.Exception
import System.IO.Unsafe

type Time = Double

getTime :: IO Time
getTime = do
  t <- Clock.getTime Clock.Monotonic
  let ns = realToFrac $ Clock.toNanoSecs t
  return $ ns / 10 ^ (9 :: Int)

timed :: IO a -> IO Time
timed t = do
  start <- getTime
  !_    <- t
  end   <- getTime
  return (end-start)

data Measurement t = Measurement
  { nts :: !Int -- the number of time steps in the output
  , step :: !Double -- the size of a single time step
  , time :: !t -- the total solving time (if known)
  }
  deriving Generic

instance FromNamedRecord (Measurement Time)
instance ToNamedRecord (Measurement Time)
instance DefaultOrdered (Measurement Time)

measure :: Measurement () -> IO (Measurement Time)
measure m@Measurement{..} = do
  let
    rhs _t y =
      let
        mu = 1000
        y1 = y ! 0
        y2 = y ! 1
      in
        fromList [y2, mu * (1 - y1*y1) * y2 - y1]
    y0 = fromList [2,0]
    !times = fromList . take (nts+1) $ iterate (+ step) 0
  time <- (timed . evaluate)
    (odeSolveV BDF Nothing 1e-2 1e-2 rhs y0 times :: Matrix Double)
  return m{time}

main :: IO ()
main = do
  measurements <- sequence $ do
    nts <- [2]
    step <- [1e5, 2e5 .. 2e9]
    let m0 = Measurement { time = (), .. }
    return . unsafeInterleaveIO $ measure m0
  LBS.writeFile "timings.csv" . encodeDefaultOrderedByName . mconcat $ encodeNamedRecord <$> measurements

max_stars_repo_name: tweag/hmatrix-sundials

max_issues_repo_name: idontgetoutmuch/hmatrix-sundials

max_forks_repo_name: novadiscovery/hmatrix-sundials


text:
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Packed.Internal.Signatures
-- Copyright   :  (c) Alberto Ruiz 2009
-- License     :  GPL-style
--
-- Maintainer  :  Alberto Ruiz <aruiz@um.es>
-- Stability   :  provisional
-- Portability :  portable (uses FFI)
--
-- Signatures of the C functions.
--
-----------------------------------------------------------------------------

module Data.Packed.Internal.Signatures where

import Foreign.Ptr(Ptr)
import Data.Complex(Complex)
import Foreign.C.Types(CInt)

type PF = Ptr Float                             --
type PD = Ptr Double                            --
type PQ = Ptr (Complex Float)                   --
type PC = Ptr (Complex Double)                  --
type TF = CInt -> PF -> IO CInt                 --
type TFF = CInt -> PF -> TF                     --
type TFV = CInt -> PF -> TV                     --
type TVF = CInt -> PD -> TF                     --
type TFFF = CInt -> PF -> TFF                   --
type TV = CInt -> PD -> IO CInt                 --
type TVV = CInt -> PD -> TV                     --
type TVVV = CInt -> PD -> TVV                   --
type TFM = CInt -> CInt -> PF -> IO CInt        --
type TFMFM =  CInt -> CInt -> PF -> TFM         --
type TFMFMFM =  CInt -> CInt -> PF -> TFMFM     --
type TM = CInt -> CInt -> PD -> IO CInt         --
type TMM =  CInt -> CInt -> PD -> TM            --
type TVMM = CInt -> PD -> TMM                   --
type TMVMM = CInt -> CInt -> PD -> TVMM         --
type TMMM =  CInt -> CInt -> PD -> TMM          --
type TVM = CInt -> PD -> TM                     --
type TVVM = CInt -> PD -> TVM                   --
type TMV = CInt -> CInt -> PD -> TV             --
type TMMV = CInt -> CInt -> PD -> TMV           --
type TMVM = CInt -> CInt -> PD -> TVM           --
type TMMVM = CInt -> CInt -> PD -> TMVM         --
type TCM = CInt -> CInt -> PC -> IO CInt        --
type TCVCM = CInt -> PC -> TCM                  --
type TCMCVCM = CInt -> CInt -> PC -> TCVCM      --
type TMCMCVCM = CInt -> CInt -> PD -> TCMCVCM   --
type TCMCMCVCM = CInt -> CInt -> PC -> TCMCVCM  --
type TCMCM = CInt -> CInt -> PC -> TCM          --
type TVCM = CInt -> PD -> TCM                   --
type TCMVCM = CInt -> CInt -> PC -> TVCM        --
type TCMCMVCM = CInt -> CInt -> PC -> TCMVCM    --
type TCMCMCM = CInt -> CInt -> PC -> TCMCM      --
type TCV = CInt -> PC -> IO CInt                --
type TCVCV = CInt -> PC -> TCV                  --
type TCVCVCV = CInt -> PC -> TCVCV              --
type TCVV = CInt -> PC -> TV                    --
type TQV = CInt -> PQ -> IO CInt                --
type TQVQV = CInt -> PQ -> TQV                  --
type TQVQVQV = CInt -> PQ -> TQVQV              --
type TQVF = CInt -> PQ -> TF                    --
type TQM = CInt -> CInt -> PQ -> IO CInt        --
type TQMQM = CInt -> CInt -> PQ -> TQM          --
type TQMQMQM = CInt -> CInt -> PQ -> TQMQM      --
type TCMCV = CInt -> CInt -> PC -> TCV          --
type TVCV = CInt -> PD -> TCV                   --
type TCVM = CInt -> PC -> TM                    --
type TMCVM = CInt -> CInt -> PD -> TCVM         --
type TMMCVM = CInt -> CInt -> PD -> TMCVM       --

max_stars_repo_name: curiousleo/liquidhaskell

max_issues_repo_name: curiousleo/liquidhaskell

max_forks_repo_name: curiousleo/liquidhaskell


text:
{-# LANGUAGE CPP,OverloadedStrings,PatternGuards #-}
{-# OPTIONS_GHC -F -pgmF htfpp #-}
-- |
-- Module      : Language.Haskell.BuildWrapper.UsagesTests
-- Copyright   : (c) JP Moresmau 2013
-- License     : BSD3
--
-- Maintainer  : jpmoresmau@gmail.com
-- Stability   : beta
-- Portability : portable
--
-- Test usage generation
module Language.Haskell.BuildWrapper.UsagesTests where

import Language.Haskell.BuildWrapper.Base hiding (readFile,writeFile)

import Language.Haskell.BuildWrapper.CMDTests
import Test.Framework hiding (Success)
import Test.HUnit (Assertion)

import System.Directory
import System.FilePath

--import System.Time

import qualified Data.ByteString.Lazy as BS
-- import qualified Data.ByteString.Lazy.Char8 as BSC (putStrLn)
import qualified Data.ByteString as BSS
import Data.Aeson
import Data.Maybe

import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.HashMap.Lazy as HM
import qualified Data.Vector as V
import qualified Data.Aeson.Types (parse)

test_GenerateBWUsage :: Assertion
test_GenerateBWUsage = do
        let api=cabalAPI
        root<-createTestProject
        ((fps,dels),_)<-synchronize api root False
        assertBool (not $ null fps)
        assertBool (null dels)
        assertEqual (testProjectName <.> ".cabal") (head fps)
        let rel="src" </> "A.hs"
        assertBoolVerbose "no A" (rel `elem` fps)
        let bwI1=getUsageFile (root </> ".dist-buildwrapper" </>  rel)
        ef1<-doesFileExist bwI1
        assertBoolVerbose (bwI1 ++ "  file exists before build") (not ef1)
        (BuildResult bool1 fps1,nsErrors1)<-build api root False Source
        assertBool bool1
        assertBool (null nsErrors1)
        assertBool (rel `elem` fps1)
        assertBoolVerbose (bwI1 ++ "  file exists after build") (not ef1)
        (comps,_)<-getCabalComponents api root
        --c1<-getClockTime
        gar<-mapM (generateUsage api root False) comps
        let fs=concat $ mapMaybe fst gar
        assertBool (rel `elem` fs)
        --c2<-getClockTime
        -- putStrLn ("generateUsage: " ++ timeDiffToString (diffClockTimes c2 c1))
        ef2<-doesFileExist bwI1
        assertBoolVerbose (bwI1 ++ " file doesn't exist after generateAST") ef2
        gar2<-mapM (generateUsage api root  False) comps
        let fs2=concat $ mapMaybe fst gar2
        assertBool (rel `notElem` fs2)
        gar3<-mapM (generateUsage api root  True) comps
        let fs3=concat $ mapMaybe fst gar3
        assertBool (rel `elem` fs3)

test_GenerateReferencesSimple :: Assertion
test_GenerateReferencesSimple = do
        let api=cabalAPI
        root<-createTestProject
        let relMain="src"</>"Main.hs"
        writeFile (root</> relMain) $ unlines [
                  "module Main where",
                  "import A",
                  "main=print $ reset $ Cons2 1"
                  ]
        let rel="src" </> "A.hs"
        writeFile (root</> rel) $ unlines [
                  "module A where",
                  "data MyData=Cons1",
                  "      { mdS::MyString}",
                  "      | Cons2 Int",
                  "     deriving Show",
                  "",
                  "type MyString=String",
                  "",
                  "reset :: MyData -> MyData",
                  "reset (Cons1 _)=Cons1 \"\"",
                  "reset (Cons2 _)=Cons2 0",
                  "",
                  "resetAll=map reset",
                  "",
                  "getString :: MyData -> Maybe MyString",
                  "getString (Cons1 s)=Just s",
                  "getString _= Nothing"
                  ]
        _<-synchronize api root True
        (BuildResult bool1 _,nsErrors1)<-build api root False Source
        assertBoolVerbose ("returned false on bool1:" ++ show nsErrors1)  bool1
        assertBool (null nsErrors1)
        (lib:exe:_,_)<-getCabalComponents api root
        --mapM_ (generateUsage api root False) comps
        generateUsage api root False lib
        let uf=getUsageFile $ root </> ".dist-buildwrapper" </> relMain
        euf1<-doesFileExist uf
        assertBool (not euf1)
        generateUsage api root False exe
        euf2<-doesFileExist uf
        assertBool euf2
        --sI<-fmap formatJSON (readFile  $ getInfoFile(root </> ".dist-buildwrapper" </>  rel))
        --putStrLn sI
        v<-readStoredUsage (root </> ".dist-buildwrapper" </>  rel)
        -- sU<-fmap formatJSON (readFile  $ getUsageFile(root </> ".dist-buildwrapper" </>  rel))
        -- putStrLn sU

        assertPackageModule "BWTest-0.1" "A" [1,8,1,9] v

        assertVarUsage "BWTest-0.1" "A" "Cons1" [("MyData",True,[2,13,2,18]),("reset",False,[10,8,10,13]),("reset",False,[10,17,10,22]),("getString",False,[16,12,16,17])] v
        assertVarUsage "BWTest-0.1" "A" "Cons2" [("MyData",True,[4,9,4,14]),("reset",False,[11,8,11,13]),("reset",False,[11,17,11,22])] v
        assertVarUsage "BWTest-0.1" "A" "mdS" [("MyData",True,[3,9,3,12])] v
        assertVarUsage "BWTest-0.1" "A" "reset" [("reset",True,[9,1,9,6]),("reset",True,[10,1,10,25]),("reset",True,[11,1,11,24]),("resetAll",False,[13,14,13,19])] v
        assertVarUsage "BWTest-0.1" "A" "resetAll" [("resetAll",True,[13,1,13,19])] v
        assertVarUsage "BWTest-0.1" "A" "getString" [("getString",True,[15,1,15,10]),("getString",True,[16,1,16,27]),("getString",True,[17,1,17,21])] v
        assertVarUsage "base" "Data.Maybe" "Nothing" [("getString",False,[17,14,17,21])] v
        assertVarUsage "base" "Data.Maybe" "Just" [("getString",False,[16,21,16,25])] v
        assertVarUsage "base" "GHC.Base" "map" [("resetAll",False,[13,10,13,13])] v
        assertVarUsage "base" "GHC.Num" "fromInteger" [("reset",False,[11,23,11,24])] v

        assertTypeUsage "BWTest-0.1" "A" "MyData" [("MyData",True,[2,6,2,12]),("reset",False,[9,10,9,16]),("reset",False,[9,20,9,26]),("getString",False,[15,14,15,20])] v
        assertTypeUsage "BWTest-0.1" "A" "MyString" [("MyData",False,[3,14,3,22]),("MyString",True,[7,6,7,14]),("getString",False,[15,30,15,38])] v
        assertTypeUsage "base" "Data.Maybe" "Maybe" [("getString",False,[15,24,15,29])] v
        assertTypeUsage "base" "GHC.Base" "String" [("MyString",False,[7,15,7,21])] v
        assertTypeUsage "base" "GHC.Show" "Show" [("MyData",False,[5,15,5,19])] v
        assertTypeUsage "ghc-prim" "GHC.Types" "Int" [("MyData",False,[4,15,4,18])] v

        vMain<-readStoredUsage (root </> ".dist-buildwrapper" </>  relMain)
        --sUMain<-fmap formatJSON (readFile  $ getUsageFile(root </> ".dist-buildwrapper" </>  relMain))
        --putStrLn sUMain
        assertPackageModule "BWTest-0.1" "Main" [1,8,1,12] vMain

        assertVarUsage "BWTest-0.1" "A" "" [("import",False,[2,8,2,9])] vMain
        assertVarUsage "BWTest-0.1" "A" "Cons2" [("main",False,[3,22,3,27])] vMain
        assertVarUsage "BWTest-0.1" "A" "reset" [("main",False,[3,14,3,19])] vMain
        assertVarUsage "BWTest-0.1" "Main" "main" [("main",True,[3,1,3,29])] vMain
        assertVarUsage "base" "System.IO" "print" [("main",False,[3,6,3,11])] vMain
        assertVarUsage "base" "GHC.Base" "$" [("main",False,[3,12,3,13]),("main",False,[3,20,3,21])] vMain
        return ()

test_GenerateReferencesImports :: Assertion
test_GenerateReferencesImports = do
        let api=cabalAPI
        root<-createTestProject
        let relMain="src"</>"Main.hs"
        writeFile (root</> relMain) $ unlines [
                  "module Main where",
                  "import Data.Ord",
                  "import Data.Maybe (Maybe(..))",
                  "import Data.Complex (Complex((:+)))",
                  "",
                  "main=undefined"
                  ]
        _<-synchronize api root True
        (BuildResult bool1 _,nsErrors1)<-build api root False Source
        assertBoolVerbose ("returned false on bool1:" ++ show nsErrors1)  bool1
        assertBool (null nsErrors1)
        (comps,_)<-getCabalComponents api root
        mapM_ (generateUsage api root False) comps
        vMain<-readStoredUsage (root </> ".dist-buildwrapper" </>  relMain)
        -- sUMain<-fmap formatJSON (readFile  $ getUsageFile(root </> ".dist-buildwrapper" </>  relMain))
        -- putStrLn sUMain
        assertVarUsage "base" "Data.Ord" "" [("import",False,[2,8,2,16])] vMain
        assertVarUsage "base" "Data.Maybe" "" [("import",False,[3,8,3,18])] vMain
        assertVarUsage "base" "Data.Complex" "" [("import",False,[4,8,4,20])] vMain
        assertTypeUsage "base" "Data.Maybe" "Maybe" [("import",False,[3,20,3,29])] vMain
        assertTypeUsage "base" "Data.Complex" "Complex" [("import",False,[4,22,4,35])] vMain
        assertVarUsage "base" "Data.Complex" ":+" [("import",False,[4,22,4,35])] vMain

test_GenerateReferencesExports :: Assertion
test_GenerateReferencesExports =  do
        let api=cabalAPI
        root<-createTestProject
        let rel="src" </> "A.hs"
        writeFile (root</> rel) $ unlines [
                  "module A (",
                  "    MyData,",
                  "    MyData2(..),",
                  "    MyData3(Cons31),",
                  "    reset,",
                  "    MyString,",
                  "    module Data.Ord) where",
                  "import Data.Ord",
                  "data MyData=Cons1",
                  "      { mdS::MyString}",
                  "      | Cons2 Int",
                  "     deriving Show",
                  "",
                  "type MyString=String",
                  "",
                  "reset :: MyData -> MyData",
                  "reset (Cons1 _)=Cons1 \"\"",
                  "reset (Cons2 _)=Cons2 0",
                  "",
                  "data MyData2=Cons21",
                  "      { mdS2::MyString}",
                  "      | Cons22 Int",
                  "     deriving Show",
                  "data MyData3=Cons31",
                  "      { mdS3::MyString}",
                  "      | Cons32 Int",
                  "     deriving Show"
                  ]
        _<-synchronize api root True
        (BuildResult bool1 _,nsErrors1)<-build api root False Source
        assertBoolVerbose ("returned false on bool1:" ++ show nsErrors1)  bool1
        assertBool (null nsErrors1)
        (comps,_)<-getCabalComponents api root
        mapM_ (generateUsage api root False) comps
        v<-readStoredUsage (root </> ".dist-buildwrapper" </>  rel)
        --sU<-fmap formatJSON (readFile  $ getUsageFile(root </> ".dist-buildwrapper" </>  rel))
        --putStrLn sU

        assertVarUsage "BWTest-0.1" "A" "Cons1" [("MyData",True,[9,13,9,18]),("reset",False,[17,8,17,13]),("reset",False,[17,17,17,22])] v
        assertVarUsage "BWTest-0.1" "A" "Cons2" [("MyData",True,[11,9,11,14]),("reset",False,[18,8,18,13]),("reset",False,[18,17,18,22])] v
        assertVarUsage "BWTest-0.1" "A" "Cons21" [("MyData2",True,[20,14,20,20])] v
        assertVarUsage "BWTest-0.1" "A" "Cons22" [("MyData2",True,[22,9,22,15])] v
        assertVarUsage "BWTest-0.1" "A" "Cons31" [("export",False,[4,5,4,20]),("MyData3",True,[24,14,24,20])] v
        assertVarUsage "BWTest-0.1" "A" "Cons32" [("MyData3",True,[26,9,26,15])] v
        assertVarUsage "BWTest-0.1" "A" "mdS" [("MyData",True,[10,9,10,12])] v
        assertVarUsage "BWTest-0.1" "A" "mdS2" [("MyData2",True,[21,9,21,13])] v
        assertVarUsage "BWTest-0.1" "A" "mdS3" [("MyData3",True,[25,9,25,13])] v
        assertVarUsage "BWTest-0.1" "A" "reset" [("export",False,[5,5,5,10]),("reset",True,[16,1,16,6]),("reset",True,[17,1,17,25]),("reset",True,[18,1,18,24])] v
        assertVarUsage "base" "GHC.Num" "fromInteger" [("reset",False,[18,23,18,24])] v

        assertVarUsage "base" "Data.Ord" "" [("export",False,[7,5,7,20]),("import",False,[8,8,8,16])] v

        assertTypeUsage "BWTest-0.1" "A" "MyData" [("export",False,[2,5,2,11]),("MyData",True,[9,6,9,12]),("reset",False,[16,10,16,16]),("reset",False,[16,20,16,26])] v
        assertTypeUsage "BWTest-0.1" "A" "MyString" [("export",False,[6,5,6,13]),("MyData",False,[10,14,10,22]),("MyString",True,[14,6,14,14]),("MyData2",False,[21,15,21,23]),("MyData3",False,[25,15,25,23])] v
        assertTypeUsage "base" "GHC.Base" "String" [("MyString",False,[14,15,14,21])] v
        assertTypeUsage "base" "GHC.Show" "Show" [("MyData",False,[12,15,12,19]),("MyData2",False,[23,15,23,19]),("MyData3",False,[27,15,27,19])] v
        assertTypeUsage "BWTest-0.1" "A" "MyData2" [("export",False,[3,5,3,16]),("MyData2",True,[20,6,20,13])] v
        assertTypeUsage "BWTest-0.1" "A" "MyData3" [("export",False,[4,5,4,20]),("MyData3",True,[24,6,24,13])] v
        assertTypeUsage "ghc-prim" "GHC.Types" "Int" [("MyData",False,[11,15,11,18]),("MyData2",False,[22,16,22,19]),("MyData3",False,[26,16,26,19])] v

test_GenerateReferencesExportAlias :: Assertion
test_GenerateReferencesExportAlias =  do
        let api=cabalAPI
        root<-createTestProject
        let relMain="src"</>"Main.hs"
        writeFile (root</> relMain) $ unlines [
                  "module Main (module X,main) where",
                  "import Data.Ord as X",
                  "",
                  "main=undefined"
                  ]
        _<-synchronize api root True
        (BuildResult bool1 _,nsErrors1)<-build api root False Source
        assertBoolVerbose ("returned false on bool1:" ++ show nsErrors1)  bool1
        assertBool (null nsErrors1)
        (comps,_)<-getCabalComponents api root
        mapM_ (generateUsage api root False) comps
        vMain<-readStoredUsage (root </> ".dist-buildwrapper" </>  relMain)
        -- sUMain<-fmap formatJSON (readFile  $ getUsageFile(root </> ".dist-buildwrapper" </>  relMain))
        -- putStrLn sUMain
        assertVarUsage "base" "Data.Ord" "" [("export",False,[1,14,1,22]),("import",False,[2,8,2,16])] vMain

test_GenerateReferencesPattern :: Assertion
test_GenerateReferencesPattern =  do
        let api=cabalAPI
        root<-createTestProject
        let relMain="src"</>"Main.hs"
        writeFile (root</> relMain) $ unlines [
                  "module Main where",
                  "",
                  "main=undefined",
                  "f :: Maybe String -> String",
                  "f mf=case mf of",
                  "  Just x->x",
                  "  _->\"\""
                  ]
        _<-synchronize api root True
        (BuildResult bool1 _,nsErrors1)<-build api root False Source
        assertBoolVerbose ("returned false on bool1:" ++ show nsErrors1)  bool1
        assertBool (null nsErrors1)
        (comps,_)<-getCabalComponents api root
        mapM_ (generateUsage api root False) comps
        vMain<-readStoredUsage (root </> ".dist-buildwrapper" </>  relMain)
        -- sUMain<-fmap formatJSON (readFile  $ getUsageFile(root </> ".dist-buildwrapper" </>  relMain))
        -- putStrLn sUMain
        assertVarUsage "base" "Data.Maybe" "Just" [("f",False,[6,3,6,7])] vMain

test_IncorrectModuleFileName :: Assertion
test_IncorrectModuleFileName = do
        let api=cabalAPI
        root<-createTestProject
        let relMain="src"</>"Main.hs"
        let relMain2="src"</>"Main-exe.hs"
        renameFile (root </> relMain) (root </> relMain2)
        let cf=testCabalFile root
        writeFile cf $ unlines ["name: "++testProjectName,
                "version:0.1",
                "cabal-version:  >= 1.8",
                "build-type:     Simple",
                "",
                "library",
                "  hs-source-dirs:  src",
                "  exposed-modules: A",
                "  other-modules:  B.C",
                "  build-depends:  base",
                "",
                "executable BWTest",
                "  hs-source-dirs:  src",
                "  main-is:         Main-exe.hs",
                "  other-modules:  B.D",
                "  build-depends:  base",
                "",
                "test-suite BWTest-test",
                "  type:            exitcode-stdio-1.0",
                "  hs-source-dirs:  test",
                "  main-is:         Main.hs",
                "  other-modules:  TestA",
                "  build-depends:  base",
                ""
                ]
        synchronize api root False
        configure api root Target
        (comps,_)<-getCabalComponents api root
        gar<-mapM (generateUsage api root False) comps
        let fs=concat $ mapMaybe fst gar
        assertBool (relMain2 `elem` fs)

getUsageFile :: FilePath -- ^ the source file
        -> FilePath
getUsageFile fp= let
        (dir,file)=splitFileName fp
        in combine dir ('.' : addExtension file ".bwusage")

readStoredUsage :: FilePath  -- ^ the source file
        -> IO Value
readStoredUsage =readJSONFile . getUsageFile

readJSONFile :: FilePath -> IO Value
readJSONFile f= do
       ex<-doesFileExist f
       mv<-if ex
                then do
                       bs<-BSS.readFile f
                       return $ decode' $ BS.fromChunks [bs]
                else return Nothing
       return $ fromMaybe (object []) mv

getInfoFile :: FilePath -- ^ the source file
        -> FilePath
getInfoFile fp= let
        (dir,file)=splitFileName fp
        in combine dir ('.' : addExtension file ".bwinfo")

-- | read the top JSON value containing all the information
readStoredInfo :: FilePath  -- ^ the source file
        -> IO Value
readStoredInfo =readJSONFile . getInfoFile

extractNameValue :: Value -> T.Text
extractNameValue (Object m) |Just (String s)<-HM.lookup "Name" m=s
extractNameValue _ = error "no name in value"

assertVarUsage :: T.Text -> T.Text -> T.Text -> [(T.Text,Bool,[Int])] -> Value -> IO()
assertVarUsage = assertUsage "vars"

assertTypeUsage :: T.Text -> T.Text -> T.Text -> [(T.Text,Bool,[Int])] -> Value -> IO()
assertTypeUsage = assertUsage "types"

assertUsage :: T.Text -> T.Text -> T.Text -> T.Text -> [(T.Text,Bool,[Int])] -> Value -> IO()
assertUsage tp pkg modu name lins (Array v) |
        V.length v==5,
        (Object m) <-v V.! 3,
        Just (Object m2)<-HM.lookup pkg m,
        Just (Object m3)<-HM.lookup modu m2,
        Just (Object m4)<-HM.lookup tp m3,
        Just (Array arr)<-HM.lookup name m4=   do
                let expected=S.fromList $ map (\(section,def,[sl,sc,el,ec])->(section,def,InFileSpan (InFileLoc sl sc) (InFileLoc el ec))) lins
                let actual=S.fromList $ map (\v2->
                        let (Success r)=Data.Aeson.Types.parse (\(Object o) ->do
                                --Success (Object o)<-fromJSON v
                                (String section)<-o .: "s"
                                (Bool def)<-o .: "d"
                                arr2<-o .: "l"
                                let (Success ifl)=fromJSON arr2
                                return (section,def,ifl::InFileSpan)) v2
                        in r) $ V.toList arr
                assertEqualVerbose (T.unpack modu ++ "." ++ T.unpack name ++ ": " ++ show lins) expected actual
        --V.elem (Number (I line)) arr=return ()
assertUsage _ _ modu name line _=assertFailure (T.unpack modu ++ "." ++ T.unpack name ++ ": " ++ show line)

assertPackageModule :: T.Text -> T.Text -> [Int] -> Value -> IO()
assertPackageModule pkg modu [sl,sc,el,ec] (Array v) |
         V.length v==5,
        (String s0) <-v V.! 0,
        (String s1) <-v V.! 1,
        arr<- v V.! 2= do
                assertEqualVerbose (T.unpack pkg) pkg s0
                assertEqualVerbose (T.unpack modu) modu s1
                let (Success ifs)=fromJSON arr
                assertEqualVerbose (show ifs) (InFileSpan (InFileLoc sl sc) (InFileLoc el ec)) ifs
assertPackageModule pkg modu _ _=  assertFailure (T.unpack pkg ++ "." ++ T.unpack modu)

max_stars_repo_name: JPMoresmau/BuildWrapper

max_issues_repo_name: JPMoresmau/BuildWrapper

max_forks_repo_name: JPMoresmau/BuildWrapper


text:
module Neural where

import qualified Numeric.LinearAlgebra               as HM  -- non-backprop hmatrix
import qualified Numeric.LinearAlgebra.Data          as HMD
import qualified Numeric.LinearAlgebra.Static        as HMS -- hmatrix with type-checked operations :D

linear weights bias x = (HMS.mul x weights) + bias
relu weights = map (\x -> max 0 x) (HM.toLists weights)

max_stars_repo_name: staturecrane/haskell-ml

max_issues_repo_name: staturecrane/haskell-ml

max_forks_repo_name: staturecrane/haskell-ml


text:
{-# LANGUAGE MultiParamTypeClasses #-}

module Stats where

import           Control.Applicative
import           Control.Monad.State
import           Data.Random
import           Data.Random.Distribution.Exponential
import           Data.Random.Source.PureMT
import qualified Data.Vector                          as V
import           Data.Word
import qualified Statistics.Sample.Histogram          as S

seed :: Word64
seed = 123

sampleStream :: (Num t, Distribution d t) => d t -> [t]
sampleStream distribution = evalState (iterateM $ sample distribution) (pureMT seed)

iterateM :: (Applicative m) => m a -> m [a]
iterateM f = liftA2 (:) f (iterateM f)

sampleVector :: (Num t, Distribution d t) => d t -> Int -> V.Vector t
sampleVector distribution size = V.fromList . take size $ sampleStream distribution

sampleExp :: Int -> V.Vector Double
sampleExp = sampleVector (Exp 1)

sampleExp' :: Int -> V.Vector Double
sampleExp' = fmap (negate . log) . sampleVector StdUniform

expHistograms :: (V.Vector Double, V.Vector Double)
expHistograms = S.histogram 30 (sampleExp 1000)

expHistograms' :: (V.Vector Double, V.Vector Double)
expHistograms' = S.histogram 30 (sampleExp' 1000)

mean :: Floating a => V.Vector a -> a
mean xs = V.sum xs / fromIntegral (V.length xs)

var :: Floating a => V.Vector a -> a
var xs = mean (fmap (** 2) xs) - mean xs ** 2

isCloseWithTolerance :: (Ord a, Floating a) => a -> a -> a -> a -> Bool
isCloseWithTolerance aTol rTol x y = abs (x - y) <= aTol + rTol * abs y

isClose :: (Ord a, Floating a) => a -> a -> Bool
isClose = isCloseWithTolerance 1e-8 1e5

max_stars_repo_name: anthony-khong/montecarlo

max_issues_repo_name: anthony-khong/montecarlo

max_forks_repo_name: anthony-khong/montecarlo