text:
-- Copyright 2016 TensorFlow authors.
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

-- | This module contains definitions for some built-in TensorFlow operations.
--
-- Note that certain, "stateful" ops like 'variable' and 'assign' return a
-- 'Build' action (e.g., @Build (Tensor Ref a)@ instead of a pure value; the
-- returned 'Tensor's are always rendered in the current 'Build' context.  This
-- approach helps us avoid problems with inlining or common subexpression
-- elimination, by writing
--
-- > do
-- >     v <- variable []
-- >     w <- assign v 3
-- >     render $ w * w
--
-- instead of
--
-- > let
-- >    v = variable []
-- >    w = assign v 3
-- > in w * w
--
-- since the latter could be reasonably transformed by the compiler into (or
-- vice versa)
--
-- > let
-- >    v = variable []
-- >    w = assign v 3
-- >    w' = assign v 3
-- > in w * w'
--
-- Ops should return a 'Build' action if their original 'OpDef' marks them as
-- stateful, or if they take any Refs as input.  (This mirrors the rules that
-- TensorFlow uses to avoid common subexpression elimination.)
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module TensorFlow.Ops
    ( CoreOps.add
    , CoreOps.add'
    , CoreOps.abs
    , CoreOps.abs'
    , CoreOps.addN
    , CoreOps.addN'
    , CoreOps.argMax
    , CoreOps.argMax'
    , CoreOps.assign
    , CoreOps.assign'
    , CoreOps.broadcastGradientArgs
    , CoreOps.broadcastGradientArgs'
    , CoreOps.cast
    , CoreOps.cast'
    , CoreOps.concat
    , CoreOps.concat'
    , constant
    , constant'
    , CoreOps.equal
    , CoreOps.equal'
    , expandDims
    , expandDims'
    , initializedVariable
    , initializedVariable'
    , zeroInitializedVariable
    , zeroInitializedVariable'
    , CoreOps.fill
    , CoreOps.fill'
    , CoreOps.identity
    , CoreOps.identity'
    , CoreOps.matMul
    , CoreOps.matMul'
    , matTranspose
    , matTranspose'
    , CoreOps.mean
    , CoreOps.mean'
    , CoreOps.mul
    , CoreOps.mul'
    , CoreOps.neg
    , CoreOps.neg'
    , CoreOps.oneHot
    , CoreOps.oneHot'
    , CoreOps.pack
    , CoreOps.pack'
    , placeholder
    , placeholder'
    , CoreOps.range
    , CoreOps.range'
    , reducedShape
    , reduceMean
    , reduceMean'
    , CoreOps.relu
    , CoreOps.relu'
    , CoreOps.reluGrad
    , CoreOps.reluGrad'
    , CoreOps.reshape
    , CoreOps.reshape'
    , restore
    , restoreFromName
    , save
    , scalar
    , scalar'
    , shape
    , shape'
    , CoreOps.sign
    , CoreOps.sign'
    , CoreOps.size
    , CoreOps.size'
    , CoreOps.softmax
    , CoreOps.softmax'
    , CoreOps.softmaxCrossEntropyWithLogits
    , CoreOps.softmaxCrossEntropyWithLogits'
    , CoreOps.sparseToDense
    , CoreOps.sparseToDense'
    , CoreOps.sub
    , CoreOps.sub'
    , CoreOps.sum
    , CoreOps.sum'
    , reduceSum
    , reduceSum'
    , CoreOps.transpose
    , CoreOps.transpose'
    , truncatedNormal
    , truncatedNormal'
    , CoreOps.variable
    , CoreOps.variable'
    , vector
    , vector'
    , zeros
    , CoreOps.zerosLike
    , CoreOps.zerosLike'
    , scalarize
    ) where

import Data.ByteString (ByteString)
import Data.Complex (Complex)
import Data.Int (Int32, Int64)
import Data.Word (Word16)
import Prelude hiding (abs, sum, concat)
import Data.ProtoLens (def)
import Data.Text.Encoding (encodeUtf8)
import Lens.Family2 ((.~), (&))
import Text.Printf (printf)
import Proto.Tensorflow.Core.Framework.Tensor
    ( TensorProto
    , dtype
    , tensorShape
    )
import qualified Proto.Tensorflow.Core.Framework.TensorShape
  as TensorShape
import TensorFlow.Build
import TensorFlow.BuildOp
import TensorFlow.ControlFlow (group)
import TensorFlow.Tensor
import TensorFlow.Types

import qualified TensorFlow.GenOps.Core as CoreOps

import qualified Prelude (abs)

-- TODO: Look into hs-boot refactoring to allow mutually recursive imports.
-- | Must be defined as an orphan because of the dependency order between Ops
-- and Tensor.
--
-- The indirect constraint "v ~ Value" helps disambiguate types, for example in
-- "neg 1 :: Tensor Value Float", it helps find the type of the subexpression
-- "1".
instance ( TensorType a
         , Num a
         , v ~ Build
         , OneOf '[ Double, Float, Int32, Int64
                  , Complex Float, Complex Double] a) => Num (Tensor v a) where
    (+) = CoreOps.add
    (*) = CoreOps.mul
    (-) = CoreOps.sub
    abs = CoreOps.abs
    fromInteger = scalar . fromInteger
    signum = CoreOps.sign
    negate = CoreOps.neg

matTranspose :: TensorType a => Tensor e a -> Tensor Build a
matTranspose = matTranspose' id

matTranspose' :: TensorType a => OpParams -> Tensor v a -> Tensor Build a
matTranspose' params = flip (CoreOps.transpose' params) (vector [1, 0 :: Int32])

placeholder :: (MonadBuild m, TensorType a) => Shape -> m (Tensor Value a)
placeholder = placeholder' id

placeholder' :: forall m a . (MonadBuild m, TensorType a)
             => OpParams -> Shape -> m (Tensor Value a)
placeholder' params pShape
    -- Note: we don't use CoreOps.placeholder' since that op isn't stateful,
    -- and thus would be CSE'd.
    = build $ buildOp [] $ opDef "Placeholder"
                & opAttr "dtype" .~ tensorType (undefined :: a)
                & opAttr "shape" .~ pShape
                & params

-- | Creates a variable initialized to the given value.
-- Initialization happens next time session runs.
initializedVariable :: (MonadBuild m, TensorType a)
                    => Tensor v a -> m (Tensor Ref a)
initializedVariable = initializedVariable' id

initializedVariable' :: (MonadBuild m, TensorType a)
                    => OpParams -> Tensor v a -> m (Tensor Ref a)
initializedVariable' params initializer = do
    v <- CoreOps.variable' params []  -- The shape is not known initially.
    i <- CoreOps.assign' (opAttr "validate_shape" .~ False) v
                            initializer
    addInitializer =<< group i
    return v

-- | Creates a zero-initialized variable with the given shape.
zeroInitializedVariable
  :: (MonadBuild m, TensorType a, Num a) =>
     TensorFlow.Types.Shape -> m (Tensor TensorFlow.Tensor.Ref a)
zeroInitializedVariable = zeroInitializedVariable' id

zeroInitializedVariable'
  :: (MonadBuild m, TensorType a, Num a) =>
     OpParams -> TensorFlow.Types.Shape -> m (Tensor TensorFlow.Tensor.Ref a)
zeroInitializedVariable' params = initializedVariable' params . zeros

-- TODO: Support heterogeneous list of tensors.
save :: forall a m v . (Rendered (Tensor v), MonadBuild m, TensorType a)
        => ByteString    -- ^ File path.
        -> [Tensor v a]  -- ^ Tensors to save.
        -> m ControlNode
save path xs = build $ do
    let toByteStringTensor = scalar . encodeUtf8 . encodeOutput . renderedOutput
    let names = fmap toByteStringTensor xs
    let types = replicate (length xs) (tensorType (undefined :: a))
    names' <- buildInputs $ CoreOps.pack names
    xs' <- buildInputs xs
    path' <- buildInputs $ scalar path
    buildOp [] $ opDef "Save"
                    & opAttr "T" .~ types
                    & opInputs .~ (path' ++ names' ++ xs')

-- | Restore a tensor's value from a checkpoint file.
--
-- This version allows restoring from a checkpoint file that uses a different
-- tensor name than the variable.
restoreFromName :: forall a m . (MonadBuild m, TensorType a)
                => ByteString    -- ^ File path.
                -> ByteString    -- ^ Tensor name override.
                -> Tensor Ref a  -- ^ Tensor to restore.
                -> m ControlNode
restoreFromName path name x = build $ do
    path' <- buildInputs $ scalar path
    name' <- buildInputs $ scalar name
    restoreOp <- buildOp [] $ opDef "Restore"
                               & opAttr "dt" .~ tensorType (undefined :: a)
                               & opInputs .~ (path' ++ name')
    group =<< CoreOps.assign x (restoreOp :: Tensor Value a)

-- | Restore a tensor's value from a checkpoint file.
restore :: forall a m . (MonadBuild m, TensorType a)
        => ByteString    -- ^ File path.
        -> Tensor Ref a  -- ^ Tensor to restore.
        -> m ControlNode
restore path x = restoreFromName path name x
  where
    name = encodeUtf8 $ encodeOutput $ renderedOutput x

-- | Create a constant tensor.
--
-- The values should be in row major order, e.g.,
--
--   element 0:   index (0, ..., 0)
--   element 1:   index (0, ..., 1)
--   ...
constant :: TensorType a => Shape -> [a] -> Tensor Build a
constant = constant' id

constant' :: forall a . TensorType a => OpParams -> Shape -> [a] -> Tensor Build a
constant' params (Shape cShape) values
    | invalidLength = error invalidLengthMsg
    | otherwise = CoreOps.const' (params . (opAttr "value" .~ typedNode))
  where
    invalidLength = product cShape /= fromIntegral (length values)
    invalidLengthMsg = printf "invalid tensor length: expected %d got %d"
                              (product cShape)
                              (length values)
    typedNode :: TensorProto
    typedNode = def
                & dtype .~ tensorType (undefined :: a)
                & tensorShape.TensorShape.dim .~
                      [def & TensorShape.size .~ x | x <- cShape]
                & tensorVal .~ values

-- | Reshape a N-D tensor down to a scalar.
--
-- See `TensorFlow.GenOps.Core.reshape`.
scalarize :: TensorType a => Tensor v a -> Tensor Build a
scalarize t = CoreOps.reshape t (vector scalarShape)
    where
        scalarShape = [] :: [Int32]

-- | Sum a tensor down to a scalar
-- Seee `TensorFlow.GenOps.Core.sum`
reduceSum :: (OneOf '[ Double, Float, Int32, Int64
                     , Complex Float, Complex Double] a) =>
             Tensor v a -> Tensor Build a
reduceSum x = CoreOps.sum x allAxes
  where allAxes = CoreOps.range 0 (CoreOps.rank x :: Tensor Build Int32) 1

reduceSum' :: (OneOf '[ Double, Float, Int32, Int64
                      , Complex Float, Complex Double] a) =>
              OpParams -> Tensor v a -> Tensor Build a
reduceSum' params x = CoreOps.sum' params x allAxes
  where allAxes = CoreOps.range 0 (CoreOps.rank x :: Tensor Build Int32) 1

-- | Computes the mean of elements across dimensions of a tensor.
-- See `TensorFlow.GenOps.Core.mean`
reduceMean
  :: ( TensorType a
     , OneOf '[ Double, Float, Complex Float, Complex Double] a
     )
  => Tensor v a -> Tensor Build a
reduceMean = reduceMean' id

reduceMean'
  :: ( TensorType a
     , OneOf '[ Double, Float, Complex Float, Complex Double] a
     )
  => OpParams -> Tensor v a -> Tensor Build a
reduceMean' params x = CoreOps.mean' params x allAxes
  where allAxes = CoreOps.range 0 (CoreOps.rank x :: Tensor Build Int32) 1

-- | Create a constant vector.
vector :: TensorType a => [a] -> Tensor Build a
vector = vector' id

vector' :: TensorType a => OpParams -> [a] -> Tensor Build a
vector' params xs = constant' params [fromIntegral $ length xs] xs

-- | Create a constant scalar.
scalar :: TensorType a => a -> Tensor Build a
scalar = scalar' id

scalar' :: TensorType a => OpParams -> a -> Tensor Build a
scalar' params x = constant' params [] [x]

-- | Random tensor from the unit normal distribution with bounded values.
--
-- This is a type-restricted version of 'TensorFlow.GenOps.Core.truncatedNormal'.
truncatedNormal :: (MonadBuild m, OneOf '[Word16, Double, Float] a)
                => Tensor v Int64  -- ^ Shape.
                -> m (Tensor Value a)
truncatedNormal = CoreOps.truncatedNormal

truncatedNormal' :: (MonadBuild m, OneOf '[Word16, Double, Float] a)
                => OpParams -> Tensor v Int64  -- ^ Shape.
                -> m (Tensor Value a)
truncatedNormal' = CoreOps.truncatedNormal'

zeros :: forall a . (Num a, TensorType a) => Shape -> Tensor Build a
zeros (Shape s) = CoreOps.fill (vector s) (scalar 0)

shape :: TensorType t => Tensor v t -> Tensor Build Int32
shape = CoreOps.shape

shape' :: TensorType t => OpParams -> Tensor v t -> Tensor Build Int32
shape' = CoreOps.shape'

expandDims :: TensorType t => Tensor v1 t -> Tensor v2 Int32 -> Tensor Build t
expandDims = CoreOps.expandDims

expandDims' :: TensorType t => OpParams -> Tensor v1 t -> Tensor v2 Int32 -> Tensor Build t
expandDims' = CoreOps.expandDims'

-- | Helper function for reduction ops (translation of math_ops.reduced_shape).
reducedShape :: (OneOf '[ Int32, Int64 ] t1, OneOf '[ Int32, Int64 ] t2) =>
                Tensor v1 t1 -> Tensor v2 t2 -> Tensor Build Int32
reducedShape inputShape axes =
    let inputShape32 = toInt32 inputShape         -- [2, 3, 5, 7]
        axes32 = toInt32 axes                     -- [1, 2]
        toInt32 x = CoreOps.cast x :: Tensor Build Int32
        inputRank = CoreOps.size inputShape32     -- 4
        axesMod = (axes32 + inputRank) `CoreOps.mod` inputRank
        axesShape = shape axesMod                 -- [2]
    in CoreOps.dynamicStitch                      -- [2, 1, 1, 7]
         [CoreOps.range 0 inputRank 1,            -- [0, 1, 2, 3]
           axesMod]                               -- [1, 2]
         [inputShape32,                           -- [2, 3, 5, 7]
           CoreOps.fill axesShape 1]              -- [1, 1]


text:
module FEECa.Utility.Quadrature where

import Math.Combinatorics.Exact.Factorial
import Numeric.LinearAlgebra.HMatrix
-- import Numeric.LinearAlgebra.Data
import FEECa.Utility.Utility (pairM)

-- | Type synomnym to represent a quadrature as a list pairs
-- | of nodes and corresponding weights, the first element being the node
-- | and the second the weight.
type Quadrature = [(Double, Double)]

-- | Type synomym for the coefficients a_i, b_i, c_i of the recurrence relation of
-- | a given est of orthogonal polynomials.
type Coeff a = (Int -> a)

-- | Compute the Gauss-Jacobi quadrature of degree n and parameters alpha = a
-- | and beta = b.
gaussJacobiQuadrature :: Int -> Int -> Int -> Quadrature
gaussJacobiQuadrature = golubWelsch

-- | Compute the Gauss-Jacobi quadrature of degree n and parameters alpha = a
-- | and beta = b shifted and scaled to the interval [0,1].
gaussJacobiQuadrature' :: Int -> Int -> Int -> Quadrature
gaussJacobiQuadrature' alpha beta n = transform (gaussJacobiQuadrature alpha beta n)
    where transform = map (pairM scale1 id)
          scale1 x = 0.5 + x/2
          -- scale2 y = y

-- | Compute the Gauss-Legendre quadrature of degree n.
gaussLegendreQuadrature :: Int -> Quadrature
gaussLegendreQuadrature = golubWelsch 0 0

-- | Golub-Welsch algorithm as described in "Calculation of Gauss Quadrature
-- | Rules" (Golub, Welsch).
golubWelsch :: Int -> Int -> Int -> Quadrature
golubWelsch alpha beta n = extract $ eigSH' (buildMatrix n a b c)
    where a = a_jac alpha beta
          b = b_jac alpha beta
          c = c_jac alpha beta
          extract (v, m) = zip (toList v)
                               (square (toList (head (toRows m))))
          square  = map (** 2)
          -- TODO: why is scale defined but not used?
          -- normalize l = map ((2 / sum l) *) l
          -- alpha' = fromIntegral alpha
          -- scale = map ((2.0**(1.0+ alpha') / (1 + alpha')) *)

gamma :: Int -> Int -> Double
gamma a b = fromInteger (2^(a + b + 1) * factorial a * factorial b) /
            fromInteger (factorial (a + b + 1))

-- Build the tridiagonal matrix used in the Golub-Welsch algorithm.
buildMatrix :: Int -> Coeff Double -> Coeff Double -> Coeff Double -> Matrix Double
buildMatrix n a b c = (n >< n) $ concat [ p1 i ++ [p2 i] ++ p3 i | i <- [1..n] ]
    where p1 i = replicate (i - 2) 0 ++ f1 i
          p2 i = - (b i / a i)
          p3 i = f2 i ++ replicate (n - i - 1) 0
          f1 i = [ beta (i-1) | i > 1 ]
          f2 i = [ beta  i    | i < n ]
          beta i = sqrt (c (i + 1) / (a i * a (i+1)))

-- | Evaluate an orthogonal Polynomial using the coefficient functions describing
-- | its recurrence relation.
orthogonalPolynomial :: Int -> Int -> Int -> Double -> Double
orthogonalPolynomial n alpha beta x
    | n == 0     = 1.0
    | n > 0      = orthogonalPolynomial' n 1 alpha beta x 1.0 0.0
    | otherwise  = error $ "orthogonalPolynomial: n = " ++ show n ++ " < 0"

-- Iterative implementation of the recursion relations for orthogonal polynomials.
-- See article by Golub and Welsch.
orthogonalPolynomial' ::
  Int -> Int -> Int -> Int ->
  Double -> Double -> Double -> Double
orthogonalPolynomial' n i alpha beta x pi1 pi2
    | n == i     = p_i
    | otherwise  = orthogonalPolynomial' n (i+1) alpha beta x p_i pi1
    where  p_i  = (a i * x + b i) * pi1 - c i * pi2
           a    = a_jac alpha beta
           b    = b_jac alpha beta
           c    = c_jac alpha beta

-- a_i coefficient for Jacobi polynomials as defined in the paper by
-- Golub and Welsch.
a_jac :: Int -> Int -> Coeff Double
a_jac alpha beta i
    | (2*i + alpha + beta) <= 2 = 1
    | otherwise = i2ab * (i2ab - 1) * (i2ab -2) / den_jac alpha beta i
  where i2ab = fromIntegral (2 * i + alpha + beta)

-- b_i coefficient for Jacobi polynomials as defined in the paper by
-- Golub and Welsch.
b_jac :: Int -> Int -> Coeff Double
b_jac alpha beta i
    | (2*i + alpha + beta) <= 2 = 0
    | otherwise = (2*i' + a' + b' - 1) * (a'*a' - b'*b') / den_jac alpha beta i
  where a' = fromIntegral alpha
        b' = fromIntegral beta
        i' = fromIntegral i

-- c_i coefficient for Jacobi polynomials as defined in the paper by
-- Golub and Welsch.
c_jac :: Int -> Int -> Coeff Double
c_jac alpha beta i
    | (2*i + alpha + beta) <= 2 = 0
    | otherwise = 2 * (i' + a' - 1) * (i' + b' - 1) * (2*i' + a' + b') /
                  den_jac alpha beta i
  where a' = fromIntegral alpha
        b' = fromIntegral beta
        i' = fromIntegral i

-- Common denominator for the coefficient functions of the recurrence relation
-- for the Jacobi integrals.
den_jac :: Int -> Int -> Int -> Double
den_jac alpha beta i =
    fromIntegral (2*i * (i + alpha + beta) * (2*i + alpha + beta - 2))

-- | Evaluate Jacobi Polynomial.
jacobiP :: Int -> Int -> Int -> Double -> Double
jacobiP alpha beta n = orthogonalPolynomial n alpha beta

-- | Evaluate Legendre polynomial of degree n at x.
legendreP :: Int -> Double -> Double
legendreP n = orthogonalPolynomial n 0 0

ext: hs

max_stars_repo_name: Airini/FEECa

max_issues_repo_name: Airini/FEECa

max_forks_repo_name: Airini/FEECa


text:
module Clash.DSP.FFT.Twiddle (
    twiddleFactors,
    halveTwiddles
) where

import Clash.Prelude
import qualified Data.Complex as C
import qualified Prelude as P
import Clash.DSP.Complex

-- | Calculate FFT `twiddle` factors. You probably want to do this with template Haskell to ensure they are calculated at compile time.
twiddleFactors
    :: Int              -- ^ Twiddle factor vector length
    -> [Complex Double] -- ^ Twiddle factors
twiddleFactors num = P.take num $ [fromComplex $ C.cis $ (-1) * P.pi * fromIntegral i / (fromIntegral num) | i <- [0..]]

-- | Take every second element of a vector of twiddle factors.
halveTwiddles
    :: KnownNat n
    => Vec (2 * n) a -- ^ Twiddle factors
    -> Vec n a       -- ^ Halved output twiddle factors
halveTwiddles vec = transpose (unconcat (SNat  @ 2) vec) !! 0

max_stars_repo_name: adamwalker/clash-utils

max_issues_repo_name: adamwalker/clash-utils

max_forks_repo_name: adamwalker/clash-utils


text:
module Loss where

import Numeric.LinearAlgebra

getLoss :: String -> Matrix R -> Matrix R -> Matrix R
getLoss lossType yMat tMat =
  case lossType of
    "mse" -> mse yMat tMat
    otherwise -> yMat -- Warning: Never Used Necessery!

mse :: Matrix R -> Matrix R -> Matrix R
mse yMat tMat =
  let dyMat = yMat - tMat
      r = rows yMat
      c = cols yMat
      halfMat = (r >< c) [0.5 ..]::(Matrix R) in
  halfMat * dyMat * dyMat

max_stars_repo_name: neutronest/vortex

max_issues_repo_name: neutronest/vortex

max_forks_repo_name: neutronest/vortex


text:
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE BangPatterns         #-}

module TestChapter3MDP (
       testChapter3
      )where

import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.State

import           Data.Configurator
import           Data.Configurator.Types
import           Data.Text (Text)
import           Numeric.LinearAlgebra (Vector, Matrix)
import qualified Numeric.LinearAlgebra as LA
import           System.Console.AsciiProgress(Options(..), Stats(..),
                                              displayConsoleRegions, complete,
                                              getProgressStats, def, newProgressBar, tickN)
-- project
import           Utils
import           Chapter3MDP

testChapter3 :: FilePath -> IO ()
testChapter3 configPath = do
  print "Chapter 3 Experiment Starting "
  (config, _) <- autoReload autoConfig [Required configPath]
  (bGridWorld :: Bool) <- require config "enable.bGridWorld"
  when bGridWorld (doGridWorldTest config)

doGridWorldTest :: Config -> IO ()
doGridWorldTest config = do
  (size::Int) <- require config "gridWorld.worldSize"
  (policies::[String]) <- require config "gridWorld.policy"
  (discountGamma::Double) <- require config "gridWorld.discount"
  (learningAccuracy::Double) <- require config "gridWorld.learningAccuracy"
  (specialPositions::[[Int]]) <- require config "gridWorld.specialPositions"
  (specialTransitPos::[[Int]]) <- require config "gridWorld.specialTransitPos"
  (specialRewards::[Double]) <- require config "gridWorld.specialRewards"
  let specials = zipWith3 (\ src dst r -> ((src!!0, src!!1), (dst!!0, dst!!1), r))
                                          specialPositions specialTransitPos specialRewards
  -- do experiments
  mapM_ (goOnePolicyTest size discountGamma learningAccuracy specials) policies
  where
  goOnePolicyTest size discountGamma learningAccuracy specials aPolicy = displayConsoleRegions $ do
    print ("Will do experiment with policy " ++ aPolicy)
    putStrLn ("Special positions: " ++ show specials)
    let thePolicy = read aPolicy
        world = createWorld size thePolicy discountGamma specials
    pg <- newProgressBar def { pgWidth = 80
                             , pgTotal = 100
                             , pgOnCompletion = Just "Done :percent after :elapsed seconds"
                             }
    loop pg world 1
    print "finish chapter3 experiments"
    where
    loop pg world count = do
      let (diff, w') = runState step world
      when (count `mod` 10 == 0)
           (do
            print ("Iteration " ++ show count)
            putStr $ showStateValues (_maxSize w') (_stateValues w')
           )
      case diff < learningAccuracy of
         False -> do
           stat <- getProgressStats pg
           let ticked = stCompleted stat
               percent = floor (100.0 / (diff / learningAccuracy))
           when (ticked < percent) (tickN pg (fromInteger $ percent - ticked))
           loop pg w' (count + 1)
         True -> complete pg >> (putStr $ showStateValues (_maxSize w') (_stateValues w'))

max_stars_repo_name: Xingtao/ReinforceLearningIntro

max_issues_repo_name: Xingtao/ReinforceLearningIntro

max_forks_repo_name: Xingtao/ReinforceLearningIntro


text:
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE IncoherentInstances  #-}
{-# LANGUAGE StandaloneDeriving  #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Data.Vector.Image.Image (
  Image(..)
, Image8
, map
, (!)
, (!?)
, createImg
, createImgI
, splitColor
, mergeColor
, toDouble
, fromDouble
) where

import Prelude hiding(map)
import qualified Prelude as P
import qualified Data.List as L
import Data.Vector.Storable hiding(forM_,map,replicate,fromList,toList,(!?),(!))
import Data.Maybe
import Numeric.LinearAlgebra.Data hiding (fromList,toList,(!))
import Numeric.LinearAlgebra.HMatrix hiding (fromList,toList,(!))
import qualified Data.Vector.Storable as V
import Foreign
import GHC.Real
import Foreign.C.String
import Foreign.C.Types
import qualified Control.Monad as C
import Data.Vector.Image.Color.RGB

data Image a =
  Image {
    img_width :: Int
  , img_height :: Int
  , img_dat :: Vector a
  } deriving (Show,Eq)

type Image8 = Image (RGB Word8)

map :: (Storable a, Storable b) => (a->b) -> Image a -> Image b
map func (Image w h d) = (Image w h (V.map func d))

index :: Storable a => Image a -> (Int,Int) -> a
index (Image w h d) (x,y) = d V.! (w*y+x)

(!?) :: Storable a => Image a -> (Int,Int) -> Maybe a
(!?) img@(Image w h d) (x,y) | x < 0 || x >= w || y <0 || y>= h = Nothing
                             | otherwise = Just (index img (x,y))

(!) :: (Storable a,Integral a) => Image a -> (Int,Int) -> a
(!) img idx = fromMaybe 0 (img !? idx)

-- | Generate Image
createImg :: Int -- ^ Width of image
            -> Int -- ^ Height of image
            -> (Int -> Int -> RGB8) -- ^ Pixel Generator
            -> Image8
createImg w h func = Image w h $ V.fromList $ do
  y <- [0..(h-1)]
  x <- [0..(w-1)]
  return $ func x y

-- | Generate Image
createImgI :: Int -- ^ Width of image
           -> Int -- ^ Height of image
           -> (Int -> Int -> RGB Int) -- ^ Pixel Generator
           -> Image8
createImgI w h func = Image w h $ V.fromList $ do
  y <- [0..(h-1)]
  x <- [0..(w-1)]
  return $ fmap fromIntegral $ fmap (\v -> if v < 0 then 0 else if v > 255 then 255 else v) $ func x y

splitColor :: (ColorSpace c a,Storable (c a),Storable a)
           => Image (c a)
           -> [Image a]
splitColor img@(Image w h d) = flip P.map [0..(num-1)] $ (\idx -> Image w h $ V.map (\v -> toList v !! idx) d)
  where
    num :: Int
    num = dim (dummyColor img)
    dummyColor :: Image (c a) -> c a
    dummyColor = error "do not eval this"

mergeColor :: (ColorSpace c a,Storable (c a),Storable a,Element a)
              => [Image a]
              -> Image (c a)
mergeColor img@((Image w h d):_) = Image w h $ V.fromList $ P.map fromList $ L.transpose $ P.map (V.toList.img_dat) img
mergeColor [] = error "image-list is null."

toDouble :: (Integral a,Storable a) => Image a -> Image Double
toDouble img= map fromIntegral img

fromDouble :: (Integral a,Storable a) => Image Double -> Image a
fromDouble img = map truncate img

max_stars_repo_name: junjihashimoto/img-vector

max_issues_repo_name: junjihashimoto/img-vector

max_forks_repo_name: junjihashimoto/img-vector


text:
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
{-# LANGUAGE FlexibleContexts #-}
module Neural.Network
  ( Network(..)
  , weights
  , biases
  , newNetwork
  , randomNetwork
  , feedforwards
  , feedforward
  )
where

import           System.Random
import           Foreign.Storable               ( Storable )
import           Control.Monad.State
import qualified Data.Semigroup                as Semigroup
import           Numeric.LinearAlgebra
import           GHC.Generics                   ( Generic )
import           Control.DeepSeq

import           Neural.Activation              ( ActivationFunction(..) )
import           Neural.Layer            hiding ( weights
                                                , biases
                                                )
import qualified Neural.Layer                  as Layer

-- | Simple feed-forward network.
newtype Network a = Network [Layer a]
    deriving (Show, Generic, NFData)

-- | Get the weights of the network.
weights :: Network a -> [Matrix a]
weights (Network layers) = map Layer.weights layers

-- | Get the biases of the network.
biases :: Network a -> [Vector a]
biases (Network layers) = map Layer.biases layers

-- | Construct a new network from a list of weigth matricws and bias vectors.
newNetwork :: [Matrix a] -> [Vector a] -> Network a
newNetwork ws bs = Network $ zipWith newLayer ws bs

-- | Construct a new random network given the sizes of the layers
-- Each bias and weight is given a random value normally
-- distributed with mean 0 and standard deviation 1.
randomNetwork
  :: (RandomGen g, Random a, Element a, Floating a)
  => [Int]    -- ^ The sizes of the layers
  -> State g (Network a)
randomNetwork sizes = do
  let sizes' = zip (init sizes) (tail sizes)
  layers <- mapM (uncurry randomLayer) sizes'
  return $ Network layers

-- | Propagate an input through the network and return every intermediate
-- activation and weighted input along the way.
feedforwards
  :: (Numeric a, Num (Vector a))
  => ActivationFunction a   -- ^ The activation function
  -> Vector a               -- ^ The network input
  -> Network a              -- ^ The network
  -> [(Vector a, Vector a)] -- ^ The activations of all the layers
feedforwards σ x (Network layers) = tail $ scanl (feed σ . fst) (x, x) layers

-- | Propagate an input through the network
-- and return the activation and weighted input of the last layer.
feedforward
  :: (Numeric a, Num (Vector a))
  => ActivationFunction a  -- ^ The activation function
  -> Vector a              -- ^ The network input
  -> Network a             -- ^ The network
  -> (Vector a, Vector a)  -- ^ The activations of the last layer
feedforward σ x = last . feedforwards σ x

max_stars_repo_name: cornelius-sevald/nnhd

max_issues_repo_name: cornelius-sevald/nnhd

max_forks_repo_name: cornelius-sevald/nnhd


text:
module HaskfemInternal
    ( basisFuncs
    , rhs
    , sysMatFreeFree
    , slope
    , hatFunc
    ) where

import Numeric.LinearAlgebra

import Grid

-- $setup
-- >>> import Test.QuickCheck
-- >>> import Numeric.LinearAlgebra

-- | The part of the right-hand side corresponding to the free dofs
--
-- Takes a real number as constant right-hand side.
rhs :: Grid
    -> R        -- ^ @f@
    -> Vector R
rhs g f = fromList . replicate n $ f * h
  where n = nElements g - 1
        h = elementSize g

-- | The part of the system matrix corresponding to the free dofs
sysMatFreeFree :: Grid
               -> R        -- ^ the constant parameter @c@ of the left-hand side
               -> Matrix R
sysMatFreeFree g c = subMatrix (1, 1) (n-1, n-1) sysMat
  where sysMat = (scalar c) * hinv * (conv2 ((2><2) [1.0, -1.0, -1.0, 1.0]) (ident n))
        n = nElements g
        hinv = scalar $ 1.0 / elementSize g

-- | List of basis functions for fe-space
basisFuncs :: Grid
           -> [R -> R]
basisFuncs g = fmap (hatFunc h)  . toList $ subVector 1 (nElements g - 1) grid
  where grid = linspace (nElements g + 1) (startOfInterval g, endOfInterval g) :: Vector R
        h = elementSize g

-- | Return a linear hat function around @midpoint@ with @run@
--
-- >>> hatFunc 0.1 2.0 1.0
-- 0.0
--
-- >>> hatFunc 0.1 2.0 2.0
-- 1.0
--
-- >>> hatFunc 0.1 2.0 2.1
-- 0.0
hatFunc :: R        -- ^ @run@
        -> R        -- ^ @midpoint@
        -> (R -> R) -- ^ resulting hat function
hatFunc run midpoint x = (slope (midpoint - run) run x) - (slope midpoint run x)

-- | Return a linear slope from 0.0 to 1.0 on the length of @run@ with left point @start@
--
-- ____/----
--
-- prop> slope (start :: R) (run :: R) start == 0.0
-- /prop> slope (start :: R) (run :: R) (start + run / 2.0) > 0.0
-- /prop> slope (start :: R) (run :: R) (start + run / 2.0) < 1.0
-- prop> slope (start :: R) (run :: R) (start + run) == 1.0
slope :: R        -- ^ @start@
      -> R        -- ^ @run@
      -> (R -> R) -- ^ resulting slope function
slope start run x
  | x <= start = 0.0
  | x >= start + run = 1.0
  | otherwise  = (x - start) * 1.0 / run

max_stars_repo_name: bschwb/haskfem

max_issues_repo_name: bschwb/haskfem

max_forks_repo_name: bschwb/haskfem


text:
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP #-}

module Text.Namelist.Pretty
    ( DString, toString
    , Pretty(..)
    , PrettyConfig(..), Mode(..)
    ) where

import Data.Complex(Complex((:+)))
import Data.CaseInsensitive (CI, original)
import Data.List(intersperse)
import Data.Char(toUpper)

#if !MIN_VERSION_base(4,8,0)
import Data.Monoid(Monoid(..))
#endif

import Data.Monoid((<>))
import Data.Default.Class(Default(def))

import Text.Namelist.Types

newtype DString = DString (String -> String)

instance Monoid DString where
    mempty = DString id
    mappend (DString a) (DString b) = DString (a . b)
    {-# INLINABLE mempty #-}
    {-# INLINABLE mappend #-}

toString :: DString -> String
toString (DString d) = d []

fromString :: String -> DString
fromString s = DString (s ++)

fromShow :: Show a => a -> DString
fromShow = fromString . show

singleton :: Char -> DString
singleton c = DString (c:)

data Mode
    = Compact
    | Large { indent :: Int }

data PrettyConfig = PrettyConfig
    { prettyLogical :: String -> String
    , pairSeparator :: String
    , mode          :: Mode
    }

cfgCompact :: PrettyConfig -> Bool
cfgCompact (PrettyConfig _ _ Compact) = True
cfgCompact _ = False

instance Default PrettyConfig where
    def = PrettyConfig (map toUpper) " = " (Large 2)
    {-# INLINABLE def #-}

class Pretty a where
    ppr :: PrettyConfig -> a -> DString

instance Pretty Index where
    ppr _ (Index i)     = fromShow i
    ppr _ (Range l h s) = opt l <> colon <> opt h <> step
      where
        opt   = maybe mempty fromShow
        colon = singleton ':'
        step  = maybe mempty (\t -> colon <> fromShow t) s
    {-# INLINABLE ppr #-}

surround :: Char -> Char -> DString -> DString
surround a b c = singleton a <> c <> singleton b

instance Pretty [Index] where
    ppr _ = surround '(' ')' . mconcat . intersperse (singleton ',') . map (ppr def)
    {-# INLINABLE ppr #-}

ci :: CI String -> DString
ci = fromString . original

instance Pretty Key where
    ppr _ (Key k)       = ci k
    ppr _ (Indexed k i) = ci k <> ppr def i
    ppr _ (Sub k s)     = ci k <> singleton '%' <> ppr def s
    {-# INLINABLE ppr #-}

instance Pretty Value where
    ppr _   (Integer i) = fromShow i
    ppr _   (Real r)    = fromShow r

    ppr cfg (Complex (r :+ i)) = singleton '(' <> fromShow r <> singleton ',' <> sp <> fromShow i <> singleton ')'
      where
        sp = if cfgCompact cfg then mempty else singleton ' '

    ppr cfg (Logical True)  = fromString . prettyLogical cfg $ if cfgCompact cfg then "T" else ".True."
    ppr cfg (Logical False) = fromString . prettyLogical cfg $ if cfgCompact cfg then "F" else ".False."

    ppr _   (String s)
        | '\'' `notElem` s = singleton '\'' <> fromString s <> singleton '\''
        | '"'  `notElem` s = singleton '"'  <> fromString s <> singleton '"'
        | otherwise = singleton '\'' <> fromString (concatMap escape s) <> singleton '\''
      where
        escape '\'' = "''"
        escape a    = [a]

    ppr cfg (Array a) = mconcat . intersperse sep $ map (ppr cfg) a
      where
        sep = if cfgCompact cfg then singleton ',' else fromString ", "

    ppr cfg (r :* v)  = fromShow r <> singleton '*' <> ppr cfg v

    ppr _   Null = mempty
    {-# INLINABLE ppr #-}

instance Pretty Pair where
    ppr cfg (k := v) = ppr cfg k <> equal <> ppr cfg v
      where
        equal = if cfgCompact cfg then singleton '=' else fromString " = "
    {-# INLINABLE ppr #-}

instance Pretty [Pair] where
    ppr cfg@PrettyConfig{ mode = Compact } =
        mconcat . intersperse (fromString ", ") . map (ppr cfg)

    ppr cfg@PrettyConfig{ mode = Large i } =
        mconcat . intersperse (fromString ",\n") . map (\p -> ind <> ppr cfg p)
      where
        ind = fromString $ replicate i ' '
    {-# INLINABLE ppr #-}

instance Pretty Group where
    ppr cfg (Group g ps) = singleton '&' <> ci g <> gsp <> ppr cfg ps <> ged
      where
        gsp = if cfgCompact cfg then singleton ' ' else singleton '\n'
        ged = if cfgCompact cfg
              then fromString " /"
              else if null ps then singleton '/' else fromString "\n/"
    {-# INLINABLE ppr #-}

instance Pretty [Group] where
    ppr cfg@PrettyConfig{ mode = Compact } =
        mconcat . intersperse (singleton ' ') . map (ppr cfg)

    ppr cfg@PrettyConfig{ mode = Large _ } =
        mconcat . intersperse (singleton '\n') . map (ppr cfg)
    {-# INLINABLE ppr #-}

max_stars_repo_name: philopon/namelist-hs

max_issues_repo_name: philopon/namelist-hs

max_forks_repo_name: philopon/namelist-hs


text:
module Xor where

import Nnaskell
import Numeric.LinearAlgebra.Data

xorNN = do nn <- randomNN [2, 2, 1]
           return $ head $ drop 5000 $ optimizeCost (cost xorTD) nn

xorTD :: [(Vector R, Vector R)]
xorTD = [ (vector [0.0, 0.0], vector [0.0])
        , (vector [1.0, 0.0], vector [1.0])
        , (vector [0.0, 1.0], vector [1.0])
        , (vector [1.0, 1.0], vector [0.0])
        ]

max_stars_repo_name: tsoding/nnaskell

max_issues_repo_name: tsoding/nnaskell

max_forks_repo_name: tsoding/nnaskell


text:
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module      : BenchShow.Analysis
-- Copyright   : (c) 2009-2014 Bryan O'Sullivan
--               (c) 2018 Composewell Technologies
--
-- License     : BSD-style
-- Maintainer  : harendra.kumar@gmail.com
-- Stability   : experimental
-- Portability : GHC

module BenchShow.Analysis
    ( OutlierEffect(..)
    , OutlierVariance(..)
    , countOutliers
    , Estimator(..)
    , AnalyzedField(..)
    , getAnalyzedValue
    , BenchmarkMatrix(..)
    , BenchmarkIterMatrix(..)
    , foldBenchmark
    , filterSamples
    , isMaxField
    ) where

import Control.Applicative
import Data.Char (toLower)
import Data.Data (Data, Typeable)
import Data.Int (Int64)
import Data.List (elemIndex, transpose)
import Data.Maybe (fromMaybe)
import Data.Traversable
import GHC.Generics (Generic)
import Statistics.Function (sort)
import Statistics.Quantile (weightedAvg)
import Statistics.Regression (bootstrapRegress, olsRegress)
import Statistics.Resampling (resample)
import Statistics.Resampling.Bootstrap (bootstrapBCA)
import Statistics.Sample (mean, stdDev)
import Statistics.Sample.KernelDensity (kde)
import Statistics.Types (Sample, Estimate(..), ConfInt(..), cl95, CL)
import System.Random.MWC (GenIO, createSystemRandom)
import Prelude hiding (sequence, mapM)

import qualified Statistics.Resampling as St
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U

-------------------------------------------------------------------------------
-- Outliers
-------------------------------------------------------------------------------

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

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

outliersEmpty :: Outliers
outliersEmpty = Outliers 0 0 0 0 0

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

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

-- | Classify outliers in a data set, using the boxplot technique.
classifyOutliers :: Sample -> Outliers
classifyOutliers sa = U.foldl' ((. outlier) . addOutliers) outliersEmpty ssa
    where outlier e = Outliers
                { samplesSeen = 1
                , lowSevere = if e <= loS && e < hiM then 1 else 0
                , lowMild = if e > loS && e <= loM then 1 else 0
                , highMild = if e >= hiM && e < hiS then 1 else 0
                , highSevere = if e >= hiS && e > loM then 1 else 0
                }
          !loS = q1 - (iqr * 3)
          !loM = q1 - (iqr * 1.5)
          !hiM = q3 + (iqr * 1.5)
          !hiS = q3 + (iqr * 3)
          q1   = weightedAvg 1 4 ssa
          q3   = weightedAvg 3 4 ssa
          ssa  = sort sa
          iqr  = q3 - q1

-- | Compute the extent to which outliers in the sample data affect
-- the sample mean and standard deviation.
outlierVariance
  :: Double -- ^ mean
  -> Double -- ^ standard deviation.
  -> Double -- ^ Number of original iterations.
  -> OutlierVariance
outlierVariance µ σ a = OutlierVariance effect desc varOutMin
    where
    µa    = µ / a
    µgMin = µa / 2
    σg2   = σg * σg where σg = min (µgMin / 4) (σ / sqrt a)
    σ2    = σ * σ
    varOut c  = (ac / a) * (σ2 - ac * σg2) where ac = a - c
    cMax x    = fromIntegral (floor (-2 * k0 / (k1 + sqrt det)) :: Int)
        where
        ad = a * d
            where
            d = k * k
            k = µa - x
        k0    = -a * ad
        k1    = σ2 - a * σg2 + ad
        det   = k1 * k1 - 4 * σg2 * k0

    minBy f q r = min (f q) (f r)
    varOutMin = if σ2 == 0
                then 0
                else (minBy varOut 1 (minBy cMax 0 µgMin)) / σ2

    (effect, desc) | varOutMin < 0.01 = (Unaffected, "no")
                   | varOutMin < 0.1  = (Slight,     "slight")
                   | varOutMin < 0.5  = (Moderate,   "moderate")
                   | otherwise        = (Severe,     "severe")

-- | Count the total number of outliers in a sample.
countOutliers :: Outliers -> Int64
countOutliers (Outliers _ a b c d) = a + b + c + d
{-# INLINE countOutliers #-}

-------------------------------------------------------------------------------
-- Linear regression
-------------------------------------------------------------------------------

useRegression :: Bool
useRegression = True

useBootstrap :: Bool
useBootstrap = True

resampleCount :: Int
resampleCount = 1000

confidence :: CL Double
confidence = cl95

regress
    :: GenIO
    -> Int  -- index of the iters field, we return the coefficient of only the
            -- iters field
    -> [String] -- responder column names
    -> [([Double], [Double])]
    -> IO [Maybe (Estimate ConfInt Double, Estimate ConfInt Double)]
regress randGen i rcols samples = do
    -- perform ordinary least squares regression for each field
    -- the main predictor is the number of iterations
    let predVectors = map U.fromList $ transpose $ map fst samples
        regressWithIters = mapM (bootstrapRegress randGen resampleCount
                                confidence olsRegress predVectors)

    let avoidMaxFields name vec =
            if isMaxField name
            then Nothing
            else Just vec
    let respVectors = map U.fromList $ transpose $ map snd samples
    res <- mapM regressWithIters (zipWith avoidMaxFields rcols respVectors)
    return $ map (fmap (\(v,r2) -> ((G.toList v) !! i, r2))) res

-------------------------------------------------------------------------------
-- Mean and std deviation by boostrap resampling
-------------------------------------------------------------------------------

estimateMeanAndStdDev
    :: GenIO
    -> [U.Vector Double]
    -> IO [(Estimate ConfInt Double, Estimate ConfInt Double)]
estimateMeanAndStdDev randGen vectors = do
    let resamp = resample randGen [St.Mean, St.StdDev] resampleCount
    res <- mapM resamp vectors
    return $ fmap (\[mn,dev] -> (mn, dev))
        $ getZipList
        $ bootstrapBCA confidence
            <$> ZipList vectors
            <*> ZipList res

-------------------------------------------------------------------------------
-- Statistical analysis of benchmark iterations
-------------------------------------------------------------------------------

-- By default the fields are considered "scaled" fields that is
-- they scale by iterations. However in case of maxrss field it is
-- a max value across the experiment and does not scale by
-- iterations, in this case we just need to take a mean or max
-- without scaling.
isMaxField :: String -> Bool
isMaxField fieldName = map toLower fieldName == "maxrss"

rescaleIteration :: Int -> [String] -> ([Double], [Double]) -> [Double]
rescaleIteration idx rcols (pvals, vals) =
    let iter = pvals !! idx
    in zipWith ($) (map ($ iter) foldFields) vals

    where

    getMeanOrMax fname i val =
        if isMaxField fname
        then val
        else val / i

    foldFields = map getMeanOrMax rcols

data AnalyzedField = AnalyzedField
    { analyzedMean       :: !Double
    , analyzedStdDev     :: !Double

    , analyzedMedian     :: !Double
    , analyzedOutliers   :: !Outliers
    , analyzedOutlierVar :: !OutlierVariance
    , analyzedKDE        :: !(U.Vector Double, U.Vector Double)

    , analyzedRegCoeff   :: Maybe (Estimate ConfInt Double)
    , analyzedRegRSq     :: Maybe (Estimate ConfInt Double)
    } deriving Show

-- | The statistical estimator used to arrive at a single value for a
-- benchmark when samples from multiple experiments are available.
--
-- @since 0.2.0
data Estimator =
      Median        -- ^ Report the median, outliers and outlier variance using
                    -- box-plot method. This is the most robust indicator
                    -- with respect to outliers when successive runs of
                    -- benchmarks are compared.
    | Mean          -- ^ Report the mean and the standard deviation from the
                    -- mean. This is less robust than median but more precise.
    | Regression    -- ^ Report the coefficient of regression, discarding the
                    -- constant factor, arrived at by linear regression using
                    -- ordinary least square method.  The R-square
                    -- goodness-of-fit estimate is also reported.  It works
                    -- better when larger number of samples are taken.  This
                    -- cannot be used when the number of samples is less than
                    -- 2, in that case a mean value is reported instead.
    deriving (Eq, Show, Read)

getAnalyzedValue :: Estimator -> AnalyzedField -> Double
getAnalyzedValue estimator AnalyzedField{..} =
    case estimator of
        Median -> analyzedMedian
        Mean -> analyzedMean
        Regression ->
            case analyzedRegCoeff of
                Nothing -> analyzedMean
                Just x -> estPoint x

-- | Perform an analysis of a measurement.
analyzeBenchmark :: GenIO
                 -> [String]
                 -> [String]
                 -> [([Double], [Double])]
                 -> IO [AnalyzedField]
analyzeBenchmark randGen pcols rcols samples = do
    let sampleCnt = length samples
        i = fromMaybe (error "bug") $ elemIndex "iters" pcols
        vectors = map U.fromList
            $ transpose
            $ map (rescaleIteration i rcols) samples

    (coeffs, r2s) <-
        -- olsRegress fails if there are fewer samples than predictors
        if useRegression && length samples >= (length pcols + 1)
        then do
            let f (Just (x, y)) = (Just x, Just y)
                f Nothing = (Nothing, Nothing)
            fmap (unzip . map f) $ regress randGen i rcols samples
        else do
            let n = length rcols
            return (replicate n Nothing, replicate n Nothing)

    (means, devs) <-
        if useBootstrap
        then do
            (ms, ds) <- fmap unzip $ estimateMeanAndStdDev randGen vectors
            return (map estPoint ms, map estPoint ds)
        else do
            -- Even for max fields (e.g. maxrss) we take the mean
            let ms = map mean vectors
                ds = map stdDev vectors
            return (ms, ds)

    let len = U.length $ head vectors
        median v = (sort v) U.! (len `div` 2)
        medians = map median vectors
        outliers = getZipList $ classifyOutliers <$> ZipList vectors
        outlierVars = getZipList
                $ outlierVariance
                    <$> ZipList means
                    <*> ZipList devs
                    <*> pure (fromIntegral sampleCnt)
        kdes = map (kde 128) vectors

    return $ getZipList $ AnalyzedField
        <$> ZipList means
        <*> ZipList devs

        <*> ZipList medians
        <*> ZipList outliers
        <*> ZipList outlierVars
        <*> ZipList kdes

        <*> ZipList coeffs
        <*> ZipList r2s

-- predictor matrix
data BenchmarkIterMatrix = BenchmarkIterMatrix
    { iterPredColNames  :: ![String]  -- predictor column names
    , iterRespColNames  :: ![String]  -- responder column names
    -- (Benchmark, [(predictor columns, responder columns)])
    , iterRowValues :: ![(String, [([Double], [Double])])]
    } deriving Show

-- Stored in row major order
data BenchmarkMatrix = BenchmarkMatrix
    { colNames  :: ![String]
    , rowValues :: ![(String, [AnalyzedField])] -- (Benchmark, columns)
    } deriving Show

foldBenchmark :: BenchmarkIterMatrix -> IO BenchmarkMatrix
foldBenchmark BenchmarkIterMatrix{..} = do
    randGen <- createSystemRandom
    rows <- mapM (foldIters randGen) iterRowValues
    return $ BenchmarkMatrix
        { colNames = iterRespColNames
        , rowValues = rows
        }

    where

    foldIters randGen (name, vals) = do
            vals' <- analyzeBenchmark randGen iterPredColNames
                                      iterRespColNames vals
            return (name, vals')

-- take top samples
-- XXX take equivalent iterations across multiple groups
filterSamples :: BenchmarkIterMatrix -> BenchmarkIterMatrix
filterSamples matrix@BenchmarkIterMatrix{..} =
    matrix
        {-
        {
          iterRowValues = map filterIters iterRowValues
        }

    where

    iterIndex = fromMaybe undefined
        $ elemIndex "iters" (map (map toLower) iterPredColNames)
    nivcswIndex = fromMaybe undefined
        $ elemIndex "nivcsw" (map (map toLower) iterPredColNames)
    filterIters (name, vals) =
        let vals'' = take 50 $ reverse $ sortBy (comparing ((!! iterIndex) .  fst)) vals
        let vals' = filter (\(x,_) -> x !! nivcswIndex < 10) vals
            vals'' =
                if null vals'
                then trace "null after filter" vals
                else vals'
        in (name, vals'')
        -}

max_stars_repo_name: pranaysashank/bench-show

max_issues_repo_name: pranaysashank/bench-show

max_forks_repo_name: pranaysashank/bench-show


text:
module Main where

import Control.Monad (liftM)
import Data.Array (Array (..), listArray)
import Data.Char (toLower)
import Data.Ratio (Rational (..), (%))
import Data.Complex (Complex (..))
import Numeric (readOct, readHex)
import System.Environment
import Text.ParserCombinators.Parsec hiding (spaces)

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

instance Show LispVal where show = showVal

main :: IO ()
main = getArgs >>= print . eval . readExpr . head

readExpr :: String -> LispVal
readExpr input = case parse parseExpr "lisp" input of
         Left err -> String $ "No match: " ++ show err
         Right val -> val

--
-- LispVal Parsers
--

parseExpr :: Parser LispVal
parseExpr = parseAtom
          <|> parseString
          <|> try parseChar
          <|> try parseComplex
          <|> try parseFloat
          <|> try parseRatio
          <|> try parseNumber
          <|> parseBool
          <|> parseQuoted
          <|> parseQuasiquote
          <|> try parseUnquoteSplicing
          <|> parseUnquote
          <|> parseList

parseAtom :: Parser LispVal
parseAtom = do first <- letter <|> symbol
               rest <- many (letter <|> digit <|> symbol)
               (return . Atom) (first:rest)

parseList :: Parser LispVal
parseList = char '(' >> parseList1

parseList1 :: Parser LispVal
parseList1 = (char ')' >> (return . List) [])
               <|> do expr <- parseExpr
                      parseList2 [expr]

parseList2 :: [LispVal] -> Parser LispVal
parseList2 expr = (char ')' >> (return . List) (reverse expr))
                    <|> (spaces >> parseList3 expr)

parseList3 :: [LispVal] -> Parser LispVal
parseList3 expr = do char '.' >> spaces
                     dotted <- parseExpr
                     char ')'
                     return $ DottedList expr dotted
                  <|> do next <- parseExpr
                         parseList2 (next:expr)

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

parseNumber :: Parser LispVal
parseNumber = parsePlainNumber <|> parseRadixNumber

parsePlainNumber :: Parser LispVal
parsePlainNumber = (Number . read) <$> many1 digit

parseRadixNumber :: Parser LispVal
parseRadixNumber = char '#' >>
                   (
                        parseDecimal
                        <|> parseBinary
                        <|> parseOctal
                        <|> parseHex
                   )

parseDecimal :: Parser LispVal
parseDecimal = do char 'd'
                  n <- many1 digit
                  (return . Number . read) n

parseBinary :: Parser LispVal
parseBinary = do char 'b'
                 n <- many $ oneOf "01"
                 (return . Number . bin2int) n

parseOctal :: Parser LispVal
parseOctal = do char 'o'
                n <- many $ oneOf "01234567"
                (return . Number . (readWith readOct)) n

parseHex :: Parser LispVal
parseHex = do char 'x'
              n <- many $ oneOf "0123456789abcdefABCDEF"
              (return . Number . (readWith readHex)) n

parseRatio :: Parser LispVal
parseRatio = do num <- fmap read $ many1 digit
                char '/'
                denom <- fmap read $ many1 digit
                (return . Ratio) (num % denom)

parseFloat :: Parser LispVal
parseFloat = do whole <- many1 digit
                char '.'
                decimal <- many1 digit
                return $ Float (read (whole++"."++decimal))

parseComplex :: Parser LispVal
parseComplex = do r <- fmap toDouble (try parseFloat <|> parsePlainNumber)
                  char '+'
                  i <- fmap toDouble (try parseFloat <|> parsePlainNumber)
                  char 'i'
                  (return . Complex) (r :+ i)
               where toDouble (Float x) = x
                     toDouble (Number x) = fromIntegral x

parseString :: Parser LispVal
parseString = do char '"'
                 s <- many (escapedChars <|> (noneOf ['\\', '"']))
                 char '"'
                 (return . String) s

parseChar :: Parser LispVal
parseChar = do string "#\\"
               s <- many1 letter
               return $ case (map toLower s) of
                      "space" -> Char ' '
                      "newline" -> Char '\n'
                      [x] -> Char x

parseBool :: Parser LispVal
parseBool = do char '#'
               c <- oneOf "tf"
               return $ case c of
                      't' -> Bool True
                      'f' -> Bool False

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

-- Bug: this allows the unquote to appear outside of a quasiquoted list
parseUnquote :: Parser LispVal
parseUnquote = do char ','
                  expr <- parseExpr
                  return $ List [Atom "unquote", expr]

-- Bug: this allows unquote-splicing to appear outside of a quasiquoted list
parseUnquoteSplicing :: Parser LispVal
parseUnquoteSplicing = do string ",@"
                          expr <- parseExpr
                          return $ List [Atom "unquote-splicing", expr]

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

--
-- Show functions
--

showVal :: LispVal -> String
showVal (String s) = "\"" ++ s ++ "\""
showVal (Atom name) = name
showVal (Number n) = show n
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (List xs) = "(" ++ unwordsList xs ++ ")"
showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"

--
-- Evaluator
--

eval :: LispVal -> LispVal
eval val@(String _) = val
eval val@(Number _) = val
eval val@(Bool _) = val
eval (List [Atom "quote", val]) = val
eval (List (Atom func : args)) = apply func $ map eval args

--
-- Primitive functions lookup table
--
primitives :: [(String, [LispVal] -> LispVal)]
primitives = [("+", numericBinop (+)),
              ("-", numericBinop (-)),
              ("*", numericBinop (*)),
              ("/", numericBinop div),
              ("mod", numericBinop mod),
              ("quotient", numericBinop quot),
              ("remainder", numericBinop rem),
              ("not", unaryOp not'),
              ("boolean?", unaryOp boolP),
              ("list?", unaryOp listP),
              ("symbol?", unaryOp symbolP),
              ("char?", unaryOp charP),
              ("string?", unaryOp stringP),
              ("string2symbol", unaryOp string2symbol),
              ("symbol2string?", unaryOp symbol2string)
            ]

-- Unary primitive defs all have type
-- LispVal -> LispVal

unaryOp :: (LispVal -> LispVal) -> [LispVal] -> LispVal
unaryOp f [arg] = f arg

not' (Bool x) = (Bool . not) x
not' _ = Bool False

boolP (Bool _) = Bool True
boolP _ = Bool False

listP (List _) = Bool True
listP (DottedList _ _) = Bool True
listP _ = Bool False

symbolP (Atom _) = Bool True
symbolP _ = Bool False

charP (Char _) = Bool True
charP _ = Bool False

stringP (String _) = Bool True
stringP _ = Bool False

symbol2string (Atom s) = String s
symbol2string _ = error "Expecting an atom"

string2symbol (String s) = Atom s
string2symbol _ = error "Expecting a string"

--
-- Helpers
--

escapedChars :: Parser Char
escapedChars = do
             char '\\'
             c <- oneOf ['\\','"', 'n', 'r', 't']
             return $ case c of
                    '\\' -> c
                    '"'  -> c
                    'n'  -> '\n'
                    'r'  -> '\r'
                    't'  -> '\t'

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

spaces :: Parser ()
spaces = skipMany1 space
bin2int :: String -> Integer
bin2int s = sum $ map (\(i,x) -> i*(2^x)) $ zip [0..] $ map p (reverse s)
          where p '0' = 0
                p '1' = 1

readWith :: (t -> [(a, b)]) -> t -> a
readWith f s = fst $ f s !! 0

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

apply :: String -> [LispVal] -> LispVal
apply func args = maybe (Bool False) ($ args) $ lookup func primitives

numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> LispVal
numericBinop op params = Number $ foldl1 op $ map unpackNum params

unpackNum :: LispVal -> Integer
unpackNum (Number n) = n
unpackNum (List [n]) = unpackNum n
unpackNum _ = 0


text:
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
-- |
-- Module    : Statistics.Distribution.Exponential
-- Copyright : (c) 2009 Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- The exponential distribution.  This is the continuous probability
-- distribution of the times between events in a poisson process, in
-- which events occur continuously and independently at a constant
-- average rate.

module Statistics.Distribution.Exponential
    (
      ExponentialDistribution
    -- * Constructors
    , exponential
    , exponentialE
    -- * Accessors
    , edLambda
    ) where

import Control.Applicative
import Data.Aeson                      (FromJSON(..),ToJSON,Value(..),(.:))
import Data.Binary                     (Binary, put, get)
import Data.Data                       (Data, Typeable)
import GHC.Generics                    (Generic)
import Numeric.SpecFunctions           (log1p)
import Numeric.MathFunctions.Constants (m_neg_inf)
import qualified System.Random.MWC.Distributions as MWC
import qualified Data.Vector.Generic as G

import qualified Statistics.Distribution         as D
import qualified Statistics.Sample               as S
import Statistics.Internal

newtype ExponentialDistribution = ED {
      edLambda :: Double
    } deriving (Eq, Typeable, Data, Generic)

instance Show ExponentialDistribution where
  showsPrec n (ED l) = defaultShow1 "exponential" l n
instance Read ExponentialDistribution where
  readPrec = defaultReadPrecM1 "exponential" exponentialE

instance ToJSON ExponentialDistribution
instance FromJSON ExponentialDistribution where
  parseJSON (Object v) = do
    l <- v .: "edLambda"
    maybe (fail $ errMsg l) return $ exponentialE l
  parseJSON _ = empty

instance Binary ExponentialDistribution where
  put = put . edLambda
  get = do
    l <- get
    maybe (fail $ errMsg l) return $ exponentialE l

instance D.Distribution ExponentialDistribution where
    cumulative      = cumulative
    complCumulative = complCumulative

instance D.ContDistr ExponentialDistribution where
    density (ED l) x
      | x < 0     = 0
      | otherwise = l * exp (-l * x)
    logDensity (ED l) x
      | x < 0     = m_neg_inf
      | otherwise = log l + (-l * x)
    quantile      = quantile
    complQuantile = complQuantile

instance D.Mean ExponentialDistribution where
    mean (ED l) = 1 / l

instance D.Variance ExponentialDistribution where
    variance (ED l) = 1 / (l * l)

instance D.MaybeMean ExponentialDistribution where
    maybeMean = Just . D.mean

instance D.MaybeVariance ExponentialDistribution where
    maybeStdDev   = Just . D.stdDev
    maybeVariance = Just . D.variance

instance D.Entropy ExponentialDistribution where
  entropy (ED l) = 1 - log l

instance D.MaybeEntropy ExponentialDistribution where
  maybeEntropy = Just . D.entropy

instance D.ContGen ExponentialDistribution where
  genContVar = MWC.exponential . edLambda

cumulative :: ExponentialDistribution -> Double -> Double
cumulative (ED l) x | x <= 0    = 0
                    | otherwise = 1 - exp (-l * x)

complCumulative :: ExponentialDistribution -> Double -> Double
complCumulative (ED l) x | x <= 0    = 1
                         | otherwise = exp (-l * x)

quantile :: ExponentialDistribution -> Double -> Double
quantile (ED l) p
  | p >= 0 && p <= 1 = - log1p(-p) / l
  | otherwise        =
    error $ "Statistics.Distribution.Exponential.quantile: p must be in [0,1] range. Got: "++show p

complQuantile :: ExponentialDistribution -> Double -> Double
complQuantile (ED l) p
  | p == 0          = 0
  | p >= 0 && p < 1 = -log p / l
  | otherwise       =
    error $ "Statistics.Distribution.Exponential.quantile: p must be in [0,1] range. Got: "++show p

-- | Create an exponential distribution.
exponential :: Double            -- ^ Rate parameter.
            -> ExponentialDistribution
exponential l = maybe (error $ errMsg l) id $ exponentialE l

-- | Create an exponential distribution.
exponentialE :: Double            -- ^ Rate parameter.
             -> Maybe ExponentialDistribution
exponentialE l
  | l > 0     = Just (ED l)
  | otherwise = Nothing

errMsg :: Double -> String
errMsg l = "Statistics.Distribution.Exponential.exponential: scale parameter must be positive. Got " ++ show l

-- | Create exponential distribution from sample. Returns @Nothing@ if
--   sample is empty or contains negative elements. No other tests are
--   made to check whether it truly is exponential.
instance D.FromSample ExponentialDistribution Double where
  fromSample xs
    | G.null xs       = Nothing
    | G.all (>= 0) xs = Nothing
    | otherwise       = Just $! ED (S.mean xs)

max_stars_repo_name: intricate/statistics

max_issues_repo_name: intricate/statistics

max_forks_repo_name: intricate/statistics


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

Dataset handling functions.

-}
module MachineLearning.Utils.Data (processData) where

import Data.List                             (transpose)
import Data.List.Split                       (splitOn)
import Data.Vector                           (Vector, fromList)
import Numeric.ModalInterval            (Kaucher, (<.<))
import Numeric.LinearAlgebra ((??))
import qualified Numeric.LinearAlgebra as LA
import Numeric.Morpheus.MatrixReduce         (columnPredicate)

-- import Constraints.Shape
import MachineLearning.Utils.Config
import MachineLearning.TIR

-- | A tuple of features columns and target
type DataSplit = (Dataset Double, Column Double)

-- | Reads and loads the data. It returns the training X, y, test X, y, vector of domains and image of the training data,
-- number of variables
processData :: Config -> IO (DataSplit, DataSplit, DataSplit, DataSplit, Vector (Kaucher Double), Kaucher Double, Int)
processData cfg =
  do (trainX, trainY) <- readAndParse (getTrainName cfg)
     (testX , testY ) <- readAndParse (getTestName  cfg)
     let nVars    = LA.cols trainX - 1
         domains  = fromList $ estimateDomains (getDomains cfg) trainX
         image    = estimateImage (getImage cfg) trainY
         xss_all  = toVecOfColumns trainX
         xss_test = toVecOfColumns testX
         (xss_train, y_train, xss_val, y_val) = splitValidation 0.9 trainX trainY
     return ((xss_train, y_train), (xss_val, y_val), (xss_all, trainY), (xss_test, testY), domains, image, nVars)

-- | Parse a numerical csv file into predictors and target variables
parseFile :: String -> (LA.Matrix Double, Column Double)
parseFile css = splitToXY . LA.fromLists $ map (map read) dat
  where
    dat = map (splitOn ",") $ lines css

-- | read and parse the csv file
readAndParse :: FilePath -> IO (LA.Matrix Double, LA.Vector Double)
readAndParse f = do (xss, ys) <- parseFile <$> readFile f
                    return (1.0 LA.||| xss, ys)

toVecOfColumns :: LA.Matrix Double -> Dataset Double
toVecOfColumns = fromList . LA.toColumns

takeNRows, dropNRows :: Int -> LA.Matrix Double -> LA.Matrix Double
takeNRows n xss = xss LA.?? (LA.Take n, LA.All)
dropNRows n xss = xss LA.?? (LA.Drop n, LA.All)

-- | split the training data into training and validation
splitValidation :: Double -> LA.Matrix Double -> LA.Vector Double
                -> (Dataset Double, LA.Vector Double, Dataset Double, LA.Vector Double)
splitValidation ratio xss ys
  | nRows <= 50 = (toVecOfColumns xss, ys, toVecOfColumns xss, ys)
  | otherwise    = (xss_train, y_train, xss_val, y_val)
  where
    nRows      = LA.rows xss
    nRowsTrain = round (fromIntegral nRows * ratio)
    nRowsVal   = nRows - nRowsTrain
    xss_train  = toVecOfColumns $ takeNRows nRowsTrain xss
    xss_val    = toVecOfColumns $ dropNRows nRowsVal xss
    y_train    = LA.subVector 0 nRowsTrain ys
    y_val      = LA.subVector nRowsVal nRowsTrain ys

-- | estimates the target image of the function
estimateImage :: Maybe (Double, Double) -> LA.Vector Double -> Kaucher Double
estimateImage image ys =
  case image of
       Nothing       -> minY <.< maxY
       Just (lo, hi) -> lo <.< hi
  where
    minY = minimum $ LA.toList ys
    maxY = maximum $ LA.toList ys

type Domains = [(Double, Double)]

-- | estimates the target domain of the function
estimateDomains :: Domains -> LA.Matrix Double -> [Kaucher Double]
estimateDomains domains xss =
  case domains of
    [] -> zipWith (<.<) minX maxX
    ds -> map (uncurry (<.<)) ds
  where
    minX = Prelude.tail $ LA.toList $ columnPredicate min xss
    maxX = Prelude.tail $ LA.toList $ columnPredicate max xss

splitToXY :: LA.Matrix Double -> (LA.Matrix Double, LA.Vector Double)
splitToXY mtx = (xss, ys)
  where
    xss = mtx ?? (LA.All, LA.DropLast 1)
    ys  = LA.flatten $ mtx ?? (LA.All, LA.TakeLast 1)

max_stars_repo_name: folivetti/tir

max_issues_repo_name: folivetti/tir

max_forks_repo_name: folivetti/tir


text:
module Proxy.PotentialFields.Internal.SimpleActions where
import Proxy.PotentialFields.Internal.Fields
import Proxy.Command.Commands
import Control.Monad.Reader
import Data.Complex
import Proxy.Types.Game
import Proxy.Server.Messages

type Map = [Location]
type FieldEnvironment = (Map,[UnitData],[UnitData])
type UnitAction = Reader FieldEnvironment Command

---------------------------------------------------------------------------------------------------------------------
--Simple UnitActions for a unit to perform. These are a single step that a unit might take at any given moment, they rely on the information from from potential field being generated.

toward :: UnitData -> Location -> UnitAction
toward ud l = mapReader (rightClickAt uid) field
  where uid = unitId ud
        field = zeta passAvU actAv (Just l) peaApp ud

attackTowards :: UnitData -> Location -> UnitAction
attackTowards ud l = mapReader (attackMove uid) field
 where uid = unitId ud
       field = zeta passAvU actAv (Just l) peaApp ud

-------------------------------------------------------------------------------------------------
--field accumulation zeta returns a computation which will return the resultant location for a unit to move to.

first (a,_,_) = a
second (_,a,_) = a
third (_,_,a) = a

zeta :: PotCalc UnitData -> PotCalc UnitData -> Maybe Location -> PotCalc Location -> UnitData -> Reader FieldEnvironment Location
zeta f h l lc u = do
  mapd <- asks (flip mapData u . first)
  friend <- asks (map (flip f u) . second)
  host <- asks (map (flip h u) . third)
  loc <- case l of
    Just a -> return [lc a u]
    otherwise -> return []
  return ( moveTo (unitLocation u) $ add mapd (vSum.concat $ [friend,host,loc]))

ro :: PotCalc UnitData -> PotCalc UnitData -> UnitData -> Reader FieldEnvironment Location
ro f h = zeta f h Nothing nofield

-----------------------------------------------------------------------------------------------------------
--Conversion from a float vector to a location for the unit to move to.
--NEED TO CONSIDER SPEED AND THE SIZE OF THE VECTOR RETURNED.

moveTo :: Location -> Vector -> Location
moveTo l v
  | magnitude cv == 0 = l
  | otherwise = l `add` xi 1 phi
  where phi = phase cv
        cv = uncurry (:+) v

xi :: (RealFloat a,Integral b) => b -> a -> (b,b)
xi b theta
  | negate ((1/4)*pi) < theta && (1/4)*pi >= theta = (b,chi $ theta)
  | (1/4)*pi < theta && (3/4)*pi >= theta = (chi.ref $ theta ,b)
  | negate ((3/4)*pi) < theta && negate ((1/4)*pi) >= theta = (chi $ theta + ((1/2)*pi),negate b)
  | otherwise = (negate b, chi.prep $ theta)
  where chi = round.(f.fromIntegral $ b)
        prep a = if a > 0
                 then pi - a
                 else negate (a + pi)
        ref a = (1/2)*pi - a

f :: (Floating a) => a -> a -> a
f a theta = (4 * a * theta)  / pi

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

allActions :: [UnitAction] -> FieldEnvironment -> [Command]
allActions ua  = runReader (sequence ua)


text:
{-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Monad (forever)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.State.Strict
  ( MonadState (get, put),
    execStateT,
    forever,
    lift,
    runStateT,
  )
import Data.Complex (Complex (..), magnitude)
import Data.List (foldl')
import qualified Data.Text as T
import System.Random (Random (randomR), newStdGen)
import UI.NCurses
  ( Color (..),
    CursorMode (..),
    defaultWindow,
    drawText,
    moveCursor,
    render,
    runCurses,
    setColor,
    setCursorMode,
    setEcho,
    updateWindow,
  )
import UI.NCurses.HalfHeight
  ( Buffer,
    colorId,
    drawBuffer,
    initHexColors,
    mkBuffer,
    setXY,
  )

-- Set up a 15-color greyscale pallette
greyScale :: [String]
greyScale =
  [ "000000",
    "111111",
    "222222",
    "333333",
    "444444",
    "666666",
    "777777",
    "888888",
    "999999",
    "aaaaaa",
    "bbbbbb",
    "cccccc",
    "dddddd",
    "eeeeee",
    "ffffff"
  ]

-- Calculate the Mandelbrot steps-to-divergence and plot as Color 1 to Color 15
mandelbrot :: (Fractional a, RealFloat a) => a -> a -> Color
mandelbrot x y = Color (16 - ((+) 1 $ steps (0 :+ 0) (x' :+ y') 0))
  where
    x' = (x - 100) * 0.025
    y' = (y - 50) * 0.025
    steps z c i
      | i > 13 || magnitude z' > 2 = i
      | otherwise = steps z' c (i + 1)
      where
        z' = z * z + c

-- Draw the Mandelbrot set to the buffer point by point
drawMandelbrot :: Buffer -> Buffer
drawMandelbrot buffer =
  foldl'
    (\b (x, y) -> setXY x y (mandelbrot (fromIntegral x) (fromIntegral y)) b)
    buffer
    [(x, y) | x <- [0 .. 149], y <- [0 .. 99]]

mandelbrotMain :: IO ()
mandelbrotMain = do
  -- Register the 15 greyscale hex colors as Color 1 through Color 15.
  -- Every combination of these colors (fg and bg) is registered with Curses
  -- with a unique ID, which we return in the colorMap.
  colorMap <- runCurses $ initHexColors nord

  -- Creates a new buffer and draws the Mandelbrot set in each cell using the
  -- greyscale colors 1 through 15
  let buffer = drawMandelbrot $ mkBuffer 150 100 (Color 1)

  runCurses $ do
    -- Hide the cursor
    setEcho False
    setCursorMode CursorInvisible

    -- Enter an infinite drawing loop displaying the buffer.
    forever $ do
      let drawOp = do
            -- First draw the buffer to the screen.
            drawBuffer colorMap 0 0 buffer
            -- Now draw some text in the centre.
            -- We set the color to curses ID corresponding to fg 15 (white) and bg 1 (black)
            let (Just c) = colorId colorMap (Color 15) (Color 1)
            setColor c
            moveCursor 25 50
            drawText "| Text demonstrating that each cell is half the row height |"
      w <- defaultWindow
      updateWindow w drawOp
      render

nord :: [String]
nord =
  [ "3b4252",
    "bf616a",
    "a3be8c",
    --"ebcb8b",
    "81a1c1",
    "b48ead",
    "88c0d0",
    "e5e9f0",
    "4c566a",
    "bf616a",
    "a3be8c",
    "ebcb8b",
    "81a1c1",
    "b48ead",
    "8fbcbb",
    "eceff4"
  ]

performanceMain :: IO ()
performanceMain = do
  colorMap <- runCurses $ initHexColors greyScale
  -- Precompute the buffers
  let buffer = mkBuffer 100 100 (Color 1)
      col x y t =
        let x' = fromIntegral (x - 50)
            y' = fromIntegral (y - 50)
            t' = fromIntegral t
         in abs $ round $ (14 * ((sin $ 0.1 * x') * (cos $ 0.1 * y')) / (sin $ 0.1 * t')) + 1
      nextBuf b t = foldl' (\b (x, y) -> setXY x y (Color $ col x y t) b) b [(x, y) | x <- [0 .. 99], y <- [0 .. 99]]
      bufs = cycle $ scanl nextBuf buffer [0 .. 63]
  runCurses $ do
    _ <- (flip runStateT) (bufs, 0) $ do
      lift $ setEcho False
      lift $ setCursorMode CursorInvisible
      forever $ do
        (bufs, t) <- get
        let b = head bufs
            drawOp = do
              drawBuffer colorMap 0 0 b
              let (Just c) = colorId colorMap (Color 15) (Color 1)
              setColor c
              moveCursor 0 0
              drawText $ T.pack $ show t
        w <- lift defaultWindow
        lift $ updateWindow w drawOp
        lift render
        put (tail bufs, t + 1)
    return ()

main :: IO ()
main = do
  --mandelbrotMain
  performanceMain

max_stars_repo_name: harryaskham/halfheight

max_issues_repo_name: harryaskham/halfheight

max_forks_repo_name: harryaskham/halfheight


text:
{-# LANGUAGE ExistentialQuantification,
             DataKinds #-}
module MVDistributions
where

import Prelude hiding ((<>))

import Control.Arrow (first)
import Control.Monad (replicateM, zipWithM)
import Control.Monad.Bayes.Class (MonadSample, normal, shuffle)
import Data.Aeson (ToJSON (toJSON))
import Data.List (permutations, sortBy, maximumBy)
import Data.Ord (comparing, Down (Down))
import qualified Data.Vector as V
import Data.Proxy (Proxy (Proxy))
import GHC.TypeLits (KnownNat, natVal)

import Numeric.LinearAlgebra.Static
import qualified Numeric.LinearAlgebra.Data as LAD
import Numeric.SpecFunctions (logGamma)

import Distributions (Distr, Distr' (..))

instance KnownNat n => ToJSON (R n) where
  toJSON x = toJSON (extract x :: LAD.Vector Double)

instance (KnownNat m, KnownNat n) => ToJSON (L m n) where
  toJSON x = toJSON (LAD.toLists (extract x :: LAD.Matrix Double))

instance KnownNat n => ToJSON (Sym n) where
  toJSON x = toJSON (unSym x)

eyeSym :: KnownNat n => Sym n
eyeSym = sym eye

sampleNormalDist :: forall n m. MonadSample m => KnownNat n => R n -> Sym n -> m (R n)
sampleNormalDist mu sig = do
  xs <- replicateM (fromInteger (natVal (Proxy :: Proxy n))) (normal 0 1)
  let x = vector xs
  return (mu + chol sig #> x)

log2pi :: Double
log2pi = log (2 * pi)

mvNormal_ll0 :: forall n. KnownNat n => Sym n -> R n -> Double
mvNormal_ll0 s x = -1/2 * (x <.> (sinv #> x) + lndets + fromInteger n * log2pi)
  where
  (sinv, (lndets, _)) = invlndet (unSym s)
  sinv' :: Sym n
  sinv' = sym sinv
  n = natVal (Proxy :: Proxy n)

mvNormal_ll :: KnownNat n => R n -> Sym n -> R n -> Double
mvNormal_ll mu s x = mvNormal_ll0 s (x - mu)

mvNormal :: KnownNat n => R n -> Sym n -> Distr (R n)
mvNormal mu s = Distr (sampleNormalDist mu s) (mvNormal_ll mu s)

uniformNSphere :: forall n. KnownNat n => Distr (R n)
uniformNSphere = Distr (do { x <- sampleNormalDist 0 (sym eye); pure (konst (1 / (norm_2 x)) * x) })
  (\_ -> - logNSphereVolume (natVal (Proxy :: Proxy n)))

-- https://en.wikipedia.org/wiki/N-sphere#Closed_forms
logNSphereVolume :: Integer -> Double
logNSphereVolume n = log (fromIntegral n) + fromIntegral n / 2 * log pi
  - logGamma (fromIntegral n / 2 + 1)

conjugate :: (KnownNat m, KnownNat n) => L m n -> Sym n -> Sym m
conjugate f p = sym (f <> unSym p <> tr f)

conjugate' :: (KnownNat m, KnownNat n) => L n m -> Sym n -> Sym m
conjugate' f p = sym (tr f <> unSym p <> f)

kalmanPredict :: KnownNat n => Sq n -> Sym n -> (R n, Sym n) -> (R n, Sym n)
kalmanPredict f q (x, p) = (f #> x, conjugate f p + q)

symEachSide :: KnownNat n => Sym n -> Sym n -> Sym n
symEachSide p x = sym (p' <> unSym x <> p')
  where p' = unSym p

-- The below is not ideal numerically
kalmanUpdate :: forall m n. (KnownNat m, KnownNat n) => R m -> L m n -> Sym m
  -> (R n, Sym n) -> ((R n, Sym n), Double)
kalmanUpdate z h r (x, p) =
  ((x + k #> ytilde, p - symEachSide p (conjugate' h sinv'))
   , loglike)
  where
  ytilde :: R m
  ytilde = z - h #> x
  trh :: L n m
  trh = tr h
  s :: Sym m
  s = r + conjugate h p
  (sinv, (lndets, _)) = invlndet (unSym s)
  sinv' :: Sym m
  sinv' = sym sinv
  k = unSym p <> trh <> sinv
  n = natVal (Proxy :: Proxy n)
  loglike = -1/2 * (ytilde <.> (sinv #> ytilde) + lndets + fromInteger n * log2pi)

shuffleList :: MonadSample m => [a] ->  m [a]
shuffleList xs = V.toList <$> shuffle (V.fromList xs)

printVector :: KnownNat n => R n -> IO ()
printVector x = print (extract x)

scaleSym :: KnownNat n => Double -> Sym n -> Sym n
scaleSym c m = sym $ konst c * unSym m

max_stars_repo_name: psg-mit/probzelus-haskell

max_issues_repo_name: psg-mit/probzelus-haskell

max_forks_repo_name: psg-mit/probzelus-haskell


text:
{-|
Module: MachineLearning.Optimization.MinibatchGradientDescent
Description: Gradient Descent
Copyright: (c) Alexander Ignatyev, 2017
License: BSD-3
Stability: experimental
Portability: POSIX

Minibatch Gradient Descent
-}

module MachineLearning.Optimization.MinibatchGradientDescent
(
  minibatchGradientDescent
)

where

import MachineLearning.Types (R, Vector, Matrix)
import MachineLearning.Regularization (Regularization)
import qualified Data.Vector.Storable as V
import qualified Numeric.LinearAlgebra as LA
import Numeric.LinearAlgebra ((?))
import qualified Control.Monad.Random as RndM

import qualified MachineLearning.Model as Model

-- | Minibatch Gradient Descent method implementation. See "MachineLearning.Regression" for usage details.
minibatchGradientDescent :: Model.Model a
                            => Int              -- ^ seed
                            -> Int              -- ^ batch size
                            -> R                -- ^ learning rate, alpha
                            -> a                -- ^ model to learn
                            -> R                -- ^ epsilon
                            -> Int              -- ^ max number of iters
                            -> Regularization   -- ^ regularization parameter, lambda
                            -> Matrix           -- ^ matrix of features, X
                            -> Vector           -- ^ output vector, y
                            -> Vector           -- ^ vector of initial weights, theta or w
                            -> (Vector, Matrix) -- ^ vector of weights and learning path
minibatchGradientDescent seed batchSize alpha model eps maxIters lambda x y theta =
  RndM.evalRand (minibatchGradientDescentM batchSize alpha model eps maxIters lambda x y theta) gen
  where gen = RndM.mkStdGen seed

-- | Minibatch Gradient Descent method implementation. See "MachineLearning.Regression" for usage details.
minibatchGradientDescentM :: (Model.Model a, RndM.RandomGen g)
                             => Int              -- ^ batch size
                             -> R                -- ^ learning rate, alpha
                             -> a                -- ^ model to learn
                             -> R                -- ^ epsilon
                             -> Int              -- ^ max number of iters
                             -> Regularization   -- ^ regularization parameter, lambda
                             -> Matrix           -- ^ matrix of features, X
                             -> Vector           -- ^ output vector, y
                             -> Vector           -- ^ vector of initial weights, theta or w
                             -> RndM.Rand g (Vector, Matrix) -- ^ vector of weights and learning path
minibatchGradientDescentM batchSize alpha model eps maxIters lambda x y theta = do
  idxList <- RndM.getRandomRs (0, (LA.rows x) - 1)
  let gradient = Model.gradient model lambda
      cost = Model.cost model lambda
      helper theta nIters optPath =
          let idx = take batchSize idxList
              x' = x ? idx
              y' = LA.flatten $ (LA.asColumn y) ? idx
              theta' = theta - (LA.scale alpha (gradient x' y' theta))
              j = cost x' y' theta'
              gradientTest = LA.norm_2 (theta' - theta) < eps
              optPathRow = V.concat [LA.vector [(fromIntegral $ maxIters - nIters), j], theta']
              optPath' = optPathRow : optPath
          in if gradientTest || nIters <= 1
             then (theta, LA.fromRows $ reverse optPath')
             else helper theta' (nIters - 1) optPath'
  return $ helper theta maxIters []

max_stars_repo_name: aligusnet/mltool

max_issues_repo_name: aligusnet/mltool

max_forks_repo_name: aligusnet/mltool


text:
module Rotation where

import Control.Monad
import Numeric.LinearAlgebra ((<>), (#>), Z, Vector, Matrix)
import qualified Numeric.LinearAlgebra as LA
import qualified Data.List as List
import qualified Data.Maybe as Maybe

import Cube (Cube, cubeToVector, vectorToCube)
import qualified Cube as Cube

type CubeRotation = Cube -> Cube

toCubeRotation :: VectorRotation -> CubeRotation
toCubeRotation rotation = vectorToCube . rotation . cubeToVector

type VectorRotation = Vector Z -> Vector Z

toVectorRotation :: MatrixRotation -> VectorRotation
toVectorRotation = (#>)

rotate :: MatrixRotation -> Cube -> Cube
rotate rotation = toCubeRotation $ toVectorRotation rotation

type MatrixRotation = Matrix Z

showMatrixRotation :: MatrixRotation -> String
showMatrixRotation = show . fmap (go 0 . LA.toList) . LA.toColumns
  where
    go i [] = i
    go i (v:vs)
      | v == 1 = i
      | otherwise = go (i + 1) vs

identity :: MatrixRotation
identity = LA.ident $ 9 * 6

topToFront :: MatrixRotation
topToFront =
  let vs = LA.toColumns identity
      mapping = [  9, 10, 11, 12, 13, 14, 15, 16, 17
                , 45, 46, 47, 48, 49, 50, 51, 52, 53
                , 24, 21, 18, 25, 22, 19, 26, 23, 20
                ,  8,  7,  6,  5,  4,  3,  2,  1,  0
                , 38, 41, 44, 37, 40, 43, 36, 39, 42
                , 35, 34, 33, 32, 31, 30, 29, 28, 27 ]
  in LA.fromColumns $ fmap (vs !!) mapping

topToBack :: MatrixRotation
topToBack = topToFront <> topToFront <> topToFront

topToRight :: MatrixRotation
topToRight =
  let vs = LA.toColumns identity
      mapping = [ 20, 23, 26, 19, 22, 25, 18, 21, 24
                , 11, 14, 17, 10, 13, 16,  9, 12, 15
                , 47, 50, 53, 46, 49, 52, 45, 48, 51
                , 33, 30, 27, 34, 31, 28, 35, 32, 29
                ,  2,  5,  8,  1,  4,  7,  0,  3,  6
                , 38, 41, 44, 37, 40, 43, 36, 39, 42 ]
  in LA.fromColumns $ fmap (vs !!) mapping

topToLeft :: MatrixRotation
topToLeft = topToRight <> topToRight <> topToRight

topTwistRight :: MatrixRotation
topTwistRight = topToBack <> topToRight <> topToFront

topTwistLeft :: MatrixRotation
topTwistLeft = topTwistRight <> topTwistRight <> topTwistRight

rightL :: MatrixRotation
rightL =
  let vs = LA.toColumns identity
      mapping = [  0,  1, 11,  3,  4, 14,  6,  7, 17
                ,  9, 10, 47, 12, 13, 50, 15, 16, 53
                , 24, 21, 18, 25, 22, 19, 26, 23, 20
                ,  8, 28, 29,  5, 31, 32,  2, 34, 35
                , 36, 37, 38, 39, 40, 41, 42, 43, 44
                , 45, 46, 33, 48, 49, 30, 51, 52, 27 ]
  in LA.fromColumns $ fmap (vs !!) mapping

rightR :: MatrixRotation
rightR = rightL <> rightL <> rightL

leftL :: MatrixRotation
leftL =
  let twist = topTwistRight <> topTwistRight
  in twist <> rightL <> twist

leftR :: MatrixRotation
leftR = leftL <> leftL <> leftL

topL :: MatrixRotation
topL = topToLeft <> rightL <> topToRight

topR :: MatrixRotation
topR = topL <> topL <> topL

bottomL :: MatrixRotation
bottomL =
  let twist = topToRight <> topToRight
  in twist <> topL <> twist

bottomR :: MatrixRotation
bottomR = bottomL <> bottomL <> bottomL

frontL :: MatrixRotation
frontL = topTwistRight <> rightL <> topTwistLeft

frontR :: MatrixRotation
frontR = frontL <> frontL <> frontL

backL :: MatrixRotation
backL =
  let twist = topTwistLeft <> topTwistLeft
  in twist <> frontL <> twist

backR :: MatrixRotation
backR = backL <> backL <> backL

rotations :: [(MatrixRotation, String)]
rotations = [
    (identity, "identity")
  , (topToFront, "topToFront")
  , (topToBack, "topToBack")
  , (topToRight, "topToRight")
  , (topToLeft, "topToLeft")
  , (topTwistRight, "topTwistRight")
  , (topTwistLeft, "topTwistLeft")
  , (rightL, "rightL")
  , (rightR, "rightR")
  , (leftL, "leftL")
  , (leftR, "leftR")
  , (topL, "topL")
  , (topR, "topR")
  , (bottomL, "bottomL")
  , (bottomR, "bottomR")
  , (frontL, "frontL")
  , (frontR, "frontR")
  , (backL, "backL")
  , (backR, "backR")
  ]

nameMatrixRotation :: MatrixRotation -> String
nameMatrixRotation = Maybe.fromMaybe "unknown" . flip List.lookup rotations

inverse :: MatrixRotation -> Maybe MatrixRotation
inverse r = Maybe.listToMaybe $ do
  r' <- map fst rotations
  guard $ r <> r' == identity
  return r'

max_stars_repo_name: runjak/hRubiks

max_issues_repo_name: runjak/hRubiks

max_forks_repo_name: runjak/hRubiks


text:
{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | copied from <http://hackage.haskell.org/package/data-default-instances-containers>
--
-- I think the orphan 'Generic' instances are okay, because you can't write manual 'Generic' (or 'Rep'?) instances in modern GHC anyway.
-- however, not sure if this is the best way to do this.
--
-- in the automatic instances, there's a runtime cost from converting between @'Rep' a@ and @a@. for now, I just want to see how it works.
--
module Commands.Generic.Instances where
import Commands.Generic

import Generics.Deriving

import Data.Int
import Data.Word
import Data.Monoid
import Data.Ratio
import Data.Complex

import qualified Data.Set as S
import qualified Data.Map as M
import Data.IntMap (IntMap)
import Data.IntSet (IntSet)
import Data.Sequence (Seq)
import Data.Tree (Tree(..))

deriving instance (Generic a)   => Generic (Tree a)
deriving instance (RealFloat a) => Generic (Complex a)

-- constructors are private
-- deriving instance (Generic k, Generic v)   => Generic (Map k v)
-- deriving instance (Generic v)              => Generic (Set v)

-- automatic instances
instance                                        Default Bool
instance                                        Default Ordering -- should be LT?
instance (Default a)                         => Default [a]
instance (Default a)                         => Default (Maybe a)
instance (Generic a, Default a)              => Default (Tree a)
instance (Generic a, Default a, RealFloat a) => Default (Complex a)

-- manual instances
instance (Default a)              => Default (e -> a)  where def = const def
instance (Default a)              => Default (IO a)    where def = return def

instance Default (S.Set v)   where def = S.empty
instance Default (M.Map k v) where def = M.empty
instance Default (IntMap v)  where def = mempty
instance Default IntSet      where def = mempty
instance Default (Seq a)     where def = mempty

instance Default Int                       where def = 0
instance Default Int8                      where def = 0
instance Default Int16                     where def = 0
instance Default Int32                     where def = 0
instance Default Int64                     where def = 0
instance Default Word                      where def = 0
instance Default Word8                     where def = 0
instance Default Word16                    where def = 0
instance Default Word32                    where def = 0
instance Default Word64                    where def = 0
instance Default Integer                   where def = 0
instance Default Float                     where def = 0
instance Default Double                    where def = 0
instance (Integral a) => Default (Ratio a) where def = 0

instance                                                                                Default ()                    where def = ()
instance (Default a, Default b)                                                        => Default (a, b)                where def = (def, def)
instance (Default a, Default b, Default c)                                             => Default (a, b, c)             where def = (def, def, def)
instance (Default a, Default b, Default c, Default d)                                  => Default (a, b, c, d)          where def = (def, def, def, def)
instance (Default a, Default b, Default c, Default d, Default e)                       => Default (a, b, c, d, e)       where def = (def, def, def, def, def)
instance (Default a, Default b, Default c, Default d, Default e, Default f)            => Default (a, b, c, d, e, f)    where def = (def, def, def, def, def, def)
instance (Default a, Default b, Default c, Default d, Default e, Default f, Default g) => Default (a, b, c, d, e, f, g) where def = (def, def, def, def, def, def, def)