text:
{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleInstances,
             GeneralizedNewtypeDeriving, MultiParamTypeClasses,
             TypeFamilies #-}
-- | Several implementations of the monad in which our dual numbers live
-- and implementations of calculating gradient, derivative and value
-- of an objective function defined on dual numbers.
module HordeAd.Core.Engine
  ( DualMonadValue, primalValueGeneral, primalValue
  , DualMonadGradient, dReverseGeneral, dReverse, dForwardGeneral, dForward, prettyPrintDf
  , DualMonadForward, dFastForwardGeneral, dFastForward
  , generateDeltaVars, initializerFixed
  ) where

import Prelude

import           Control.Monad.Trans.State.Strict
import qualified Data.Array.DynamicS as OT
import           Data.Functor.Identity
import qualified Data.Strict.Vector as Data.Vector
import qualified Data.Vector.Generic as V
import           Numeric.LinearAlgebra (Matrix, Numeric, Vector)
import qualified Numeric.LinearAlgebra as HM

import HordeAd.Core.DualClass
  (Dual, IsPrimal (..), IsPrimalWithScalar, bindInState, dVar)
import HordeAd.Core.DualNumber
import HordeAd.Core.PairOfVectors (DualNumberVariables, makeDualNumberVariables)
import HordeAd.Internal.Delta
  ( CodeOut (..)
  , DeltaState (..)
  , derivativeFromDelta
  , gradientFromDelta
  , ppBindings
  , toDeltaId
  )

-- * The dummy monad implementation that does not collect deltas.
-- It's intended for efficiently calculating the value of the function only.

-- An overcomplicated
-- @type DualMonadValue r = Identity@
-- to avoid @-Wno-orphans@ and @UndecidableInstances@.
newtype DualMonadValue r a = DualMonadValue
  { runDualMonadValue :: Identity a }
  deriving (Monad, Functor, Applicative)

instance IsScalar 'DModeGradient r
         => DualMonad 'DModeGradient r (DualMonadValue r) where
  returnLet (D u _u') = DualMonadValue $ Identity $ D u dZero

-- The general case, needed for old, hacky tests using only scalars.
primalValueGeneral
  :: forall r a. IsScalar 'DModeGradient r
  => (DualNumberVariables 'DModeGradient r
      -> DualMonadValue r a)
  -> Domains r
  -> a
-- Small enough that inline won't hurt.
{-# INLINE primalValueGeneral #-}
primalValueGeneral f (params0, params1, params2, paramsX) =
  let replicateZeros p = V.replicate (V.length p) dZero
      variables = makeDualNumberVariables
                    (params0, params1, params2, paramsX)
                    ( replicateZeros params0  -- dummy
                    , replicateZeros params1
                    , replicateZeros params2
                    , replicateZeros paramsX )
  in runIdentity $ runDualMonadValue $ f variables

primalValue
  :: forall r a. IsScalar 'DModeGradient r
  => (DualNumberVariables 'DModeGradient r
      -> DualMonadValue r (DualNumber 'DModeGradient a))
  -> Domains r
  -> a
-- Small enough that inline won't hurt.
{-# INLINE primalValue #-}
primalValue f parameters =
  let D value _ = primalValueGeneral f parameters
  in value

-- * The fully-fledged monad implementation for gradients
-- and the code that uses it to compute gradients and also derivatives.

newtype DualMonadGradient r a = DualMonadGradient
  { runDualMonadGradient :: State (DeltaState r) a }
  deriving (Monad, Functor, Applicative)

instance IsScalar 'DModeGradient r
         => DualMonad 'DModeGradient
                      r (DualMonadGradient r) where
  returnLet (D u u') = DualMonadGradient $ do
    st <- get
    let (!stNew, !dId) = bindInState u' st
    put stNew
    return $! D u (dVar dId)

initializeState :: forall r. IsScalar 'DModeGradient r
                => Domains r -> DeltaState r
initializeState (params0, params1, params2, paramsX) =
  DeltaState { deltaCounter0 = toDeltaId (V.length params0)
             , deltaCounter1 = toDeltaId (V.length params1)
             , deltaCounter2 = toDeltaId (V.length params2)
             , deltaCounterX = toDeltaId (V.length paramsX)
             , deltaBindings = []
             }

dReverseGeneral
  :: forall r. HasDelta r
  => r
  -> DualNumberVariables 'DModeGradient r
  -> (DualNumberVariables 'DModeGradient r
      -> DualMonadGradient r (DualNumber 'DModeGradient r))
  -> (Domains r, r)
-- The functions in which @dReverseGeneral@ inlines are not inlined themselves
-- in client code, so the bloat is limited.
{-# INLINE dReverseGeneral #-}
dReverseGeneral dt
                variables@(params0, _, params1, _, params2, _, paramsX, _)
                f =
  let dim0 = V.length params0
      dim1 = V.length params1
      dim2 = V.length params2
      dimX = V.length paramsX
      initialState = initializeState (params0, params1, params2, paramsX)
      (D value d, st) = runState (runDualMonadGradient (f variables))
                                 initialState
      inlineDerivative primCode primalArgs dualArgs =
        let D _ u' = outDualNumber primCode primalArgs dualArgs
        in u'
      gradient =
        gradientFromDelta inlineDerivative inlineDerivative inlineDerivative
                          inlineDerivative inlineDerivative
                          dim0 dim1 dim2 dimX st d dt
  in (gradient, value)

dReverse :: HasDelta r
   => r
   -> (DualNumberVariables 'DModeGradient r
       -> DualMonadGradient r (DualNumber 'DModeGradient r))
   -> Domains r
   -> (Domains r, r)
dReverse dt f parameters =
  let varDeltas = generateDeltaVars parameters
      variables = makeDualNumberVariables parameters varDeltas
  in dReverseGeneral dt variables f

-- This function uses @DualMonadGradient@ for an inefficient computation
-- of forward derivaties. See @dFastForwardGeneral@ for an efficient variant.
dForwardGeneral
  :: forall r. HasDelta r
  => DualNumberVariables 'DModeGradient r
  -> (DualNumberVariables 'DModeGradient r
      -> DualMonadGradient r (DualNumber 'DModeGradient r))
  -> Domains r
  -> (r, r)
{-# INLINE dForwardGeneral #-}
dForwardGeneral variables@(params0, _, params1, _, params2, _, paramsX, _)
                f ds =
  let initialState = initializeState (params0, params1, params2, paramsX)
      (D value d, st) = runState (runDualMonadGradient (f variables))
                                 initialState
      inlineDerivative primCode primalArgs dualArgs =
        let D _ u' = outDualNumber primCode primalArgs dualArgs
        in u'
  in ( derivativeFromDelta inlineDerivative inlineDerivative inlineDerivative
                           inlineDerivative inlineDerivative
                           st d ds
     , value )

-- The direction vector ds is taken as an extra argument.
dForward
  :: HasDelta r
  => (DualNumberVariables 'DModeGradient r
      -> DualMonadGradient r (DualNumber 'DModeGradient r))
  -> Domains r
  -> Domains r
  -> (r, r)
dForward f parameters ds =
  let varDeltas = generateDeltaVars parameters
      variables = makeDualNumberVariables parameters varDeltas
  in dForwardGeneral variables f ds

-- * A monad for efficiently computing forward derivatives.

newtype DualMonadForward r a = DualMonadForward
  { runDualMonadForward :: Identity a }
  deriving (Monad, Functor, Applicative)

instance IsScalar 'DModeDerivative r
         => DualMonad 'DModeDerivative
                      r (DualMonadForward r) where
  returnLet (D u u') = DualMonadForward $ Identity $ D u u'

-- This the efficient variant of forward derivative computation.
dFastForwardGeneral
  :: Dual 'DModeDerivative r ~ r
  => DualNumberVariables 'DModeDerivative r
  -> (DualNumberVariables 'DModeDerivative r
      -> DualMonadForward r (DualNumber 'DModeDerivative r))
  -> (r, r)
{-# INLINE dFastForwardGeneral #-}
dFastForwardGeneral variables f =
  let D value d = runIdentity $ runDualMonadForward $ f variables
  in (d, value)

-- The direction vector ds is taken as an extra argument.
dFastForward
  :: forall r. (Numeric r, Dual 'DModeDerivative r ~ r)
  => (DualNumberVariables 'DModeDerivative r
      -> DualMonadForward r (DualNumber 'DModeDerivative r))
  -> Domains r
  -> Domains r
  -> (r, r)
dFastForward f parameters (params0, params1, params2, paramsX) =
  let variables =
        makeDualNumberVariables
          parameters
          (V.convert params0, params1, params2, paramsX)  -- ds
      (derivative, value) = dFastForwardGeneral variables f
  in (derivative, value)

-- * Additional mechanisms

prettyPrintDf
  :: forall r. HasDelta r
  => Bool
  -> (DualNumberVariables 'DModeGradient r
      -> DualMonadGradient r (DualNumber 'DModeGradient r))
  -> Domains r
  -> String
prettyPrintDf reversed f parameters =
  let varDeltas = generateDeltaVars parameters
      variables = makeDualNumberVariables parameters varDeltas
      initialState = initializeState parameters
      (D _ deltaTopLevel, st) = runState (runDualMonadGradient (f variables))
                                         initialState
  in ppBindings reversed st deltaTopLevel

generateDeltaVars
  :: forall r. IsScalar 'DModeGradient r
  => Domains r
  -> ( Data.Vector.Vector (Dual 'DModeGradient r)
     , Data.Vector.Vector (Dual 'DModeGradient (Vector r))
     , Data.Vector.Vector (Dual 'DModeGradient (Matrix r))
     , Data.Vector.Vector (Dual 'DModeGradient (OT.Array r)) )
generateDeltaVars (params0, params1, params2, paramsX) =
  let vVar :: forall a v. (IsPrimalWithScalar 'DModeGradient a r, V.Vector v a)
           => v a -> Data.Vector.Vector (Dual 'DModeGradient a)
      vVar p = V.generate (V.length p) (dVar . toDeltaId)
      !v0 = vVar params0
      !v1 = vVar params1
      !v2 = vVar params2
      !vX = vVar paramsX
  in (v0, v1, v2, vX)

-- | Initialize parameters using a uniform distribution with a fixed range
-- taken from an argument.
--
-- Must be Double, because @randomVector@ only works on that.
--
-- This only works fine for nets with levels that have similar size and use
-- the same activation function. Otherwise, the range should vary per level.
-- A rule of thumb range for weights is @sqrt(6 / (F_in + F_out)@,
-- where @F_in + F_out@ is the sum of inputs and outputs of the largest level.
-- See https://github.com/pytorch/pytorch/issues/15314 and their newer code.
initializerFixed :: Int -> Double -> (Int, [Int], [(Int, Int)], [OT.ShapeL])
                 -> ((Int, Int, Int, Int), Int, Double, Domains Double)
initializerFixed seed range (nParams0, lParams1, lParams2, lParamsX) =
  let vParams1 = V.fromList lParams1
      vParams2 = V.fromList lParams2
      vParamsX = V.fromList lParamsX
      createRandomVector n seedV =
        HM.scale (2 * range)
        $ HM.randomVector seedV HM.Uniform n - HM.scalar 0.5
      params0Init = createRandomVector nParams0 seed
      params1Init =
        V.imap (\i nPV -> createRandomVector nPV (seed + nPV + i)) vParams1
      params2Init =
        V.imap (\i (rows, cols) ->
                 HM.reshape cols
                 $ createRandomVector (rows * cols) (seed + rows + i)) vParams2
      paramsXInit =
        V.imap (\i sh ->
                 let sz = product sh
                 in OT.fromVector sh
                    $ createRandomVector sz (seed + sz + i)) vParamsX
      totalParams = nParams0
                    + V.sum vParams1
                    + V.sum (V.map (uncurry (*)) vParams2)
                    + V.sum (V.map product vParamsX)
  in ( (nParams0, V.length vParams1, V.length vParams2, V.length vParamsX)
     , totalParams
     , range
     , (params0Init, params1Init, params2Init, paramsXInit) )

outDualNumber :: (IsPrimal d a, RealFloat a, Show a, Show (Dual d a))
              => CodeOut -> [a] -> [Dual d a]
              -> DualNumber d a
outDualNumber PlusOut [u, v] [u', v'] = D u u' + D v v'
outDualNumber MinusOut [u, v] [u', v'] = D u u' - D v v'
outDualNumber TimesOut [u, v] [u', v'] = D u u' * D v v'
outDualNumber NegateOut [u] [u'] = negate $ D u u'
outDualNumber AbsOut [u] [u'] = abs $ D u u'
outDualNumber SignumOut [u] [u'] = signum $ D u u'
outDualNumber DivideOut [u, v] [u', v'] = D u u' / D v v'
outDualNumber RecipOut [u] [u'] = recip $ D u u'
outDualNumber ExpOut [u] [u'] = exp $ D u u'
outDualNumber LogOut [u] [u'] = log $ D u u'
outDualNumber SqrtOut [u] [u'] = sqrt $ D u u'
outDualNumber PowerOut [u, v] [u', v'] = D u u' ** D v v'
outDualNumber LogBaseOut [u, v] [u', v'] = logBase (D u u') (D v v')
outDualNumber SinOut [u] [u'] = sin $ D u u'
outDualNumber CosOut [u] [u'] = cos $ D u u'
outDualNumber TanOut [u] [u'] = tan $ D u u'
outDualNumber AsinOut [u] [u'] = asin $ D u u'
outDualNumber AcosOut [u] [u'] = acos $ D u u'
outDualNumber AtanOut [u] [u'] = atan $ D u u'
outDualNumber SinhOut [u] [u'] = sinh $ D u u'
outDualNumber CoshOut [u] [u'] = cosh $ D u u'
outDualNumber TanhOut [u] [u'] = tanh $ D u u'
outDualNumber AsinhOut [u] [u'] = asinh $ D u u'
outDualNumber AcoshOut [u] [u'] = acosh $ D u u'
outDualNumber AtanhOut [u] [u'] = atanh $ D u u'
outDualNumber Atan2Out [u, v] [u', v'] = atan2 (D u u') (D v v')
outDualNumber primCode primalArgs dualArgs =
  error $ "outDualNumber: wrong number of arguments"
          ++ show (primCode, primalArgs, dualArgs)


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

module School.App.CSVReader
( csvToBinary
, csvToMatrixDouble
, parseDoubles
, readCSV
) where

import Conduit ((.|), ConduitM, mapC, mapMC, sourceFileBS)
import qualified Data.ByteString as BS
import Data.ByteString.Conversion (fromByteString)
import Data.Void (Void)
import qualified Data.Conduit.Binary as CB
import School.FileIO.AppIO (AppIO, maybeToAppIO)
import School.FileIO.FileType (FileType(..))
import School.FileIO.FileHeader (FileHeader(..))
import School.FileIO.MatrixSink (matrixDoubleSink)
import School.Utils.Constants (binComma)
import Numeric.LinearAlgebra ((><), Matrix)

parseDoubles :: [BS.ByteString] -> Maybe [Double]
parseDoubles = mapM fromByteString

readCSV :: FilePath -> ConduitM ()
                                [BS.ByteString]
                                AppIO
                                ()
readCSV path = sourceFileBS path
            .| CB.lines
            .| mapC (BS.split binComma)

csvToMatrixDouble :: FileHeader
                  -> ConduitM [BS.ByteString]
                              (Matrix Double)
                              AppIO
                              ()
csvToMatrixDouble FileHeader { cols } =
    mapC parseDoubles
 .| mapMC (maybeToAppIO "Could not parse doubles")
 .| mapC (1 >< cols)

csvToBinary :: FilePath
            -> FilePath
            -> FileHeader
            -> ConduitM () Void AppIO ()
csvToBinary inPath outPath header  =
    readCSV inPath
 .| csvToMatrixDouble header
 .| matrixDoubleSink SM header outPath

ext: hs

max_stars_repo_name: jfulseca/School

max_issues_repo_name: jfulseca/School

max_forks_repo_name: jfulseca/School


text:
--------------------------------------------------------------------------------
-- |
-- Module    :  Datasets.Iris
-- Copyright :  (c) Sam Stites 2017
-- License   :  BSD3
-- Maintainer:  sam@stites.io
-- Stability :  experimental
-- Portability: non-portable
--
-- === Iris Data Set
--
-- Data Set Characteristics  :  Multivariate
-- Number of Instances       : 150
-- Area                      : Life
-- Attribute Characteristics : Real
-- Number of Attributes      : 4
-- Date Donated              : 1988-07-01
-- Associated Tasks          : Classification
-- Missing Values?           : No
-- Creator                   : R. A. Fisher
-- Source                    : https://archive.ics.uci.edu/ml/datasets/Iris
--
-- === Data Set Information
--
-- This is perhaps the best known database to be found in the pattern
-- recognition literature. Fisher's paper is a classic in the field and is
-- referenced frequently to this day. (See Duda & Hart, for example.) The data
-- set contains 3 classes of 50 instances each, where each class refers to a
-- type of iris plant. One class is linearly separable from the other 2; the
-- latter are NOT linearly separable from each other.
--
-- Predicted attribute: class of iris plant.
--
-- This is an exceedingly simple domain.
--
-- This data differs from the data presented in Fishers article (identified by
-- Steve Chadwick, spchadwick '@' espeedaz.net ). The 35th sample should be:
-- 4.9,3.1,1.5,0.2,"Iris-setosa" where the error is in the fourth feature. The
-- 38th sample: 4.9,3.6,1.4,0.1,"Iris-setosa" where the errors are in the second
-- and third features.
--
--
-- === Attribute Information
--
-- 1. Sepal length in cm
-- 2. Sepal width in cm
-- 3. Petal length in cm
-- 4. Petal width in cm
-- 5. Class: Iris Setosa | Iris Versicolour | Iris Virginica
--
-- === Summary Statistics:
--
--               Min  Max   Mean    SD   Class Correlation
-- sepal length: 4.3  7.9   5.84  0.83    0.7826
-- sepal width : 2.0  4.4   3.05  0.43   -0.4194
-- petal length: 1.0  6.9   3.76  1.76    0.9490  (high!)
-- petal width : 0.1  2.5   1.20  0.76    0.9565  (high!)
--
-- === Class Distribution
--
-- 33.3% for each of 3 classes.
--------------------------------------------------------------------------------
{-# LANGUAGE DeriveGeneric #-}
module Datasets.Iris where

import Prelude hiding (readFile)
import Data.Csv
import Control.Arrow
import GHC.Generics
import Data.ByteString.Lazy (readFile)
import Control.Monad.IO.Class
import Control.Exception.Safe

import Data.Vector (Vector, toList, fromList)
import qualified Data.Vector as V
import Numeric.LinearAlgebra (Matrix, fromLists)
import Numeric.LinearAlgebra.Data ((??), Extractor(..))

data Datum = Datum
  { sepalLength :: Double
  , sepalWidth  :: Double
  , petalLength :: Double
  , petalWidth  :: Double
  , irisClass   :: IrisClass
  } deriving (Eq, Show, Generic)

instance FromRecord Datum

toDoubles :: Datum -> [Double]
toDoubles (Datum a b c d e) = [a, b, c, d, fromIntegral $ fromEnum e]
-- ========================================================================= --

data IrisClass
  = Setosa
  | Versicolour
  | Virginica
  deriving (Eq, Bounded, Enum, Generic)

instance FromRecord IrisClass
instance FromField  IrisClass where
  parseField s
    | s == "Iris-setosa"     = pure Setosa
    | s == "Iris-versicolor" = pure Versicolour
    | s == "Iris-virginica"  = pure Virginica

instance Show IrisClass where
  show Setosa      = "Iris Setosa"
  show Versicolour = "Iris Versicolour"
  show Virginica   = "Iris Virginica"

-- ========================================================================= --

loadIrisRaw :: (MonadThrow m, MonadIO m) => m (Vector Datum)
loadIrisRaw = do
  iris <- liftIO $ readFile "data/Datasets/Iris.csv"
  Right xs <- pure $ decode NoHeader iris
  return xs

loadIris :: (MonadThrow m, MonadIO m) => m (Matrix Double, Vector IrisClass)
loadIris = featureLabelSplit <$> loadIrisRaw
  where
    featureLabelSplit :: Vector Datum -> (Matrix Double, Vector IrisClass)
    featureLabelSplit v = foo $ fmap ((init . toDoubles) &&& irisClass) v

    foo :: Vector ([Double], IrisClass) -> (Matrix Double, Vector IrisClass)
    foo vs = (fromLists $ toList (fmap fst vs), fmap snd vs)

type Dataset = (Matrix Double, Vector IrisClass)

splitCV :: Float -> Dataset -> (Dataset, Dataset)
splitCV percent (features, labels) =
  ( (features ?? (Take splitpoint, All), V.take splitpoint labels)
  , (features ?? (Drop splitpoint, All), V.drop splitpoint labels)
  )

  where
    splitpoint :: Int
    splitpoint = truncate (fromIntegral (length labels) * percent) :: Int

max_stars_repo_name: stites/hasklearn

max_issues_repo_name: stites/hasklearn

max_forks_repo_name: stites/hasklearn


text:
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}

module Main where

import Control.Monad (forM, forM_)
import Data.List (intercalate)
import Statistics.Sample (mean, stdDev)
import Turtle
import qualified Data.Text as T
import qualified Data.Vector as V

data Platform = PlatformLinux | PlatformMacOS deriving (Eq)

main :: IO ()
main = do
    uname <- strict $ inshell "uname" empty
    platform <-
        if "Linux" `T.isInfixOf` uname then return PlatformLinux
        else if "Darwin" `T.isInfixOf` uname then return PlatformMacOS
        else failWithMsg "Currently only Linux and macOS are supported."

    -- Required for pcregrep on Linux.
    when (platform == PlatformLinux) $ export "LC_ALL" "en_US.UTF-8"

    let logFile :: (IsString a) => a
        logFile = "./tmp/bench.sh.log"

    export "logfile" (fromString logFile)
    testfile logFile >>= flip when (rm logFile)

    procs "echo" ["Compiling C program... "] empty
    shells "mkdir -p ./tmp" empty
    shells "gcc -O2 -Wall bench-lmdb.c -llmdb -o bench-lmdb >> $logfile 2>&1" empty

    procs "echo" ["Compiling Haskell programs... "] empty
    shells "stack build >> $logfile 2>&1" empty

    let c_executable = "./bench-lmdb"
    hs_plain_executable <- T.strip <$> strict (inshell "stack exec -- which bench-lmdb-plain 2> /dev/null" empty)
    hs_streamly_executable <- T.strip <$> strict (inshell "stack exec -- which bench-lmdb-streamly 2> /dev/null" empty)

    echoHrule
    answerIsYes "Perform read benchmarks?" >>= flip when (do
        echo "Creating databases using C program (unless they already exist)..."
        let tmpDir :: (IsString a) => a
            tmpDir = "./tmp/read"
        mktree tmpDir

        let mb = 1000000.0 :: Double
        let pairCounts = [31250000 :: Int, 62500000, 125000000]
        let kvFactors = [1 :: Int, 2, 4]
        forM_ pairCounts $ \pairCount -> forM_ kvFactors $ \kvFactor -> do
            let dbPath = format (""%fp%"/test_"%d%"_"%d%"") tmpDir pairCount kvFactor
            (_, existingDbPairCount) <-
                shellStrict (format ("mdb_stat -e "%s%" 2> /dev/null | pcregrep -o1 'Entries: (.+)$'") dbPath) empty
            if T.strip existingDbPairCount == format (""%d%"") pairCount then
                procs "echo" [format ("    Database "%s%" already exists.") dbPath] empty
            else do
                procs "echo" ["-n", format ("    Creating database "%s%"... ") dbPath] empty
                testdir (fromText dbPath) >>= flip when (shells (format ("rm -r "%s%" 2> /dev/null") dbPath) empty)
                let chunkSize :: Int = round $ mb / (8 * fromIntegral kvFactor + 8 * fromIntegral kvFactor)
                shells (format (""%s%" write "%s%" "%d%" "%d%" "%d%" "%d%"")
                    c_executable dbPath kvFactor kvFactor pairCount chunkSize) empty
                echo "success."

        echo "Measuring read-cursor..."

        let csvFile :: (IsString a) => a
            csvFile = "./tmp/read/read-cursor.csv"
        shells (format ("rm -f "%fp%"") csvFile) empty

        output csvFile . return . unsafeTextToLine . T.pack $
            "pairCount,kvFactor,"
            ++ "c_mean,c_std,"
            ++ "hsPlain_mean,hsPlain_std,"
            ++ "hsStreamly_mean,hsStreamly_std,"
            ++ "hsStreamlySafe_mean,hsStreamlySafe_std,"
            ++ "hsPlain_diff_c_mean,hsPlain_diff_c_std,"
            ++ "hsStreamly_diff_hsPlain_mean,hsStreamly_diff_hsPlain_std,"
            ++ "hsStreamlySafe_diff_hsStreamly_mean,hsStreamlySafe_diff_hsStreamly_std"

        forM_ pairCounts $ \pairCount -> forM_ kvFactors $ \kvFactor -> do
            let dbPath = format (""%fp%"/test_"%d%"_"%d%"") tmpDir pairCount kvFactor
            let expectedInOutput = format ("Pair count:       "%d%"") pairCount
            let args = format ("read-cursor "%s%"") dbPath
            let warmCount = 2
            let timeCount = 5

            -- Mean and standard deviation of nanoseconds per pair.
            let toStats :: [NominalDiffTime] -> (Double, Double)
                toStats secs =
                    let  nsPerPair = V.fromList $ map (realToFrac . (/fromIntegral pairCount) . (*1e9)) secs
                    in (mean nsPerPair, stdDev nsPerPair)

            procs "echo" [format ("    Timing database "%s%" with C...") dbPath] empty
            (cMean, cStd) <-
                toStats <$>
                timeCommand Nothing (format (""%s%" "%s%"") c_executable args)
                    [expectedInOutput] warmCount timeCount

            procs "echo" [format ("    Timing database "%s%" with Haskell (plain)...") dbPath] empty
            (hsPlainMean, hsPlainStd) <-
                toStats <$>
                timeCommand Nothing (format (""%s%" "%s%"") hs_plain_executable args)
                    [expectedInOutput] warmCount timeCount

            procs "echo" [format ("    Timing database "%s%" with Haskell (streamly)...") dbPath] empty
            (hsStreamlyMean, hsStreamlyStd) <-
                toStats <$>
                timeCommand Nothing (format (""%s%" "%s%"") hs_streamly_executable args)
                    [expectedInOutput] warmCount timeCount

            procs "echo" [format ("    Timing database "%s%" with Haskell (streamly, safe)...") dbPath] empty
            (hsStreamlySafeMean, hsStreamlySafeStd) <-
                toStats <$>
                timeCommand Nothing (format (""%s%" read-cursor-safe "%s%"") hs_streamly_executable dbPath)
                    [expectedInOutput] warmCount timeCount

            let diffStd :: Double -> Double -> Double
                diffStd std1 std2 =
                    let two = 2 :: Int
                    in sqrt $ std1^two + std2^two

            let line = intercalate "," $ [show pairCount, show kvFactor] ++ map show [cMean, cStd,
                    hsPlainMean, hsPlainStd, hsStreamlyMean, hsStreamlyStd, hsStreamlySafeMean, hsStreamlySafeStd,
                    hsPlainMean - cMean, diffStd hsPlainStd cStd,
                    hsStreamlyMean - hsPlainMean, diffStd hsStreamlyStd hsPlainStd,
                    hsStreamlySafeMean - hsStreamlyMean, diffStd hsStreamlySafeStd hsStreamlyStd]
            append csvFile . return . unsafeTextToLine . T.pack $ line
            procs "echo" [format ("    Appended results to "%s%"") csvFile] empty
        )

    echoHrule
    answerIsYes "Perform write benchmarks?" >>= flip when (do
        let tmpDir :: (IsString a) => a
            tmpDir = "./tmp/write"
        shells (format ("rm -rf "%fp%"") tmpDir) empty
        mktree tmpDir
        let csvFile :: (IsString a) => a
            csvFile = "./tmp/write/write.csv"
        output csvFile . return . unsafeTextToLine . T.pack $
            "pairCount,kvFactor,"
            ++ "c_mean,c_std,"
            ++ "hsPlain_mean,hsPlain_std,"
            ++ "hsStreamly_mean,hsStreamly_std,"
            ++ "hsPlain_div_c_mean,hsPlain_div_c_std,"
            ++ "hsStreamly_div_c_mean,hsStreamly_div_c_std,"
            ++ "hsStreamly_div_hsPlain_mean,hsStreamly_div_hsPlain_std"

        let mb = 1000000.0 :: Double
        let pairCounts = [1000000 :: Int, 10000000]
        let kvFactors = [1 :: Int, 2]
        forM_ pairCounts $ \pairCount -> forM_ kvFactors $ \kvFactor -> do
            let dbPath = format (""%fp%"/test_"%d%"_"%d%"") tmpDir pairCount kvFactor
            let chunkSize :: Int = round $ mb / (8 * fromIntegral kvFactor + 8 * fromIntegral kvFactor)
            let args  = format ("write "%s%" "%d%" "%d%" "%d%" "%d%"") dbPath kvFactor kvFactor pairCount chunkSize
            let warmCount = 1
            let timeCount = 5
            procs "echo" [format ("    Writing database "%s%" with C...") dbPath] empty
            cTimes <- timeCommand (Just dbPath) (format (""%s%" "%s%"") c_executable args)
                        [] warmCount timeCount
            procs "echo" [format ("    Writing database "%s%" with Haskell (plain)...") dbPath] empty
            hsPlainTimes <- timeCommand (Just dbPath) (format (""%s%" "%s%"") hs_plain_executable args)
                        [] warmCount timeCount
            procs "echo" [format ("    Writing database "%s%" with Haskell (streamly)...") dbPath] empty
            hsStreamlyTimes <- timeCommand (Just dbPath) (format (""%s%" "%s%"") hs_streamly_executable args)
                        [] warmCount timeCount

            let hsPlainDivCTimes = [a / b | a <- hsPlainTimes, b <- cTimes]
            let hsStreamlyDivCTimes = [a / b | a <- hsStreamlyTimes, b <- cTimes]
            let hsStreamlyDivHsPlainTimes = [a / b | a <- hsStreamlyTimes, b <- hsPlainTimes]

            let mean' :: [NominalDiffTime] -> Double
                mean' xs = mean . V.fromList $ map realToFrac xs

            let std' :: [NominalDiffTime] -> Double
                std' xs = stdDev . V.fromList $ map realToFrac xs

            let line = intercalate "," $ [show pairCount, show kvFactor] ++ map show [
                    mean' cTimes, std' cTimes,
                    mean' hsPlainTimes, std' hsPlainTimes,
                    mean' hsStreamlyTimes, std' hsStreamlyTimes,
                    mean' hsPlainDivCTimes, std' hsPlainDivCTimes,
                    mean' hsStreamlyDivCTimes, std' hsStreamlyDivCTimes,
                    mean' hsStreamlyDivHsPlainTimes, std' hsStreamlyDivHsPlainTimes ]
            append csvFile . return . unsafeTextToLine . T.pack $ line
            procs "echo" [format ("    Appended results to "%s%"") csvFile] empty
        )

failWithMsg :: Line -> IO a
failWithMsg msg = echo msg >> exit (ExitFailure 1)

echoHrule :: IO ()
echoHrule = echo "----------------------------------------"

answerIsYes :: String -> IO Bool
answerIsYes question = do
    procs "echo" ["-n", T.pack $ question ++ " (y/N) "] empty
    line <- readline
    case line of
        Just answer | answer == "y" -> return True
        _ -> return False

timeCommand' :: Text -> [Text] -> IO NominalDiffTime
timeCommand' cmdAndArgs expectedInOut = do
    (out, t) <- time . strict $ inshell cmdAndArgs empty
    if all (`T.isInfixOf` out) expectedInOut then
        return t
    else
        error $ "all of " ++ show expectedInOut ++ " were not found in output "
            ++ show out ++ " of command " ++ show cmdAndArgs

timeCommand :: Maybe T.Text -> Text -> [Text] -> Int -> Int -> IO [NominalDiffTime]
timeCommand forceRemovalPath cmdAndArgs expectedInOut warmCount timeCount = do
    let removePath = maybe (return ()) (\fp' -> shells (format ("rm -rf "%s%"") fp') empty) forceRemovalPath
    let echoCount c = procs "echo" ["-n", format (""%d%" ") c] empty
    when (warmCount > 0) $ do
        procs "echo" ["-n", "        Warming up... "] empty
        forM_ [1..warmCount] $ \c ->
            echoCount c >> removePath >> timeCommand' cmdAndArgs expectedInOut
        echo "done."
    procs "echo" ["-n", "        Timing... "] empty
    times <- forM [1..timeCount] $ \c ->
        echoCount c >> removePath >> timeCommand' cmdAndArgs expectedInOut
    removePath
    echo "done."
    return times

max_stars_repo_name: shlok/streamly-lmdb

max_issues_repo_name: shlok/streamly-lmdb

max_forks_repo_name: shlok/streamly-lmdb


text:
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE FlexibleContexts #-}

module CPVO.Numeric (
  integrateAll,
  sumRow,
  getY0,
  delta,
  integrateToZero,
  integrateAtomicPDOS
  ) where

import Numeric.LinearAlgebra
import Data.List (findIndex,groupBy)
import Data.Maybe (fromJust)

integrateToZero :: Matrix Double -> Double
integrateToZero mP = integrateAll 0
  $ (++ ([toList $ getY0 $ takeColumns 2 mP]))
  $ takeWhile (\(a:_) -> a <= 0)
  $ toLists $ takeColumns 2 mP

integrateAll :: Double -> [[Double]] -> Double
integrateAll res [] = res
integrateAll res ([enA,nA]:b@[enB,nB]:as)
  | as == [] = integrateAll (res + (enB - enA)*(nA+nB)*0.5) []
  | otherwise = integrateAll (res + (enB - enA)*(nA+nB)*0.5) (b:as)
integrateAll _ _ = 99

sumRow :: Matrix Double -> Vector Double
sumRow a = a #> konst 1 (cols a)

getY0 :: Matrix Double -> Vector Double
getY0 dos = getY0' lowPos higNeg
  where
    rTDOS = toRows $ dos
    highestNeg = (+) (-1) $ fromJust $ findIndex (\a -> (atIndex a 0) >= 0) rTDOS
    lowestPos = highestNeg + 1
    higNeg = rTDOS !! highestNeg
    lowPos = rTDOS !! lowestPos

getY0' :: Vector Double -> Vector Double -> Vector Double
getY0' a b = a + (scale m v)
  where
    v = b - a
    m = ((*) (-1) $ a ! 0) / ((b ! 0) - (a ! 0))

delta :: Bool -> b -> b -> b
delta x y z = if x then y else z

integrateAtomicPDOS :: [(Matrix Double, (Int, (String, (Int, String))))]
                    -> [(Double, Double, (Int, (String, (Int, String))))]
integrateAtomicPDOS pdosAtomicPilihan =
          (\[us,ds] -> zipWith (\(iu,b) (idown,_) -> (iu,idown,b)) us ds )
          $ groupBy (\(_,(s,_)) (_,(s',_)) -> s == s') -- [[(spin,label,iup)]]
          $ map (\(mp,b) -> (integrateToZero mp,b)) $ pdosAtomicPilihan

max_stars_repo_name: hasanalrasyid/cpvoh

max_issues_repo_name: hasanalrasyid/cpvoh

max_forks_repo_name: hasanalrasyid/cpvoh


text:
-- program: S.A.R.A.H. jam simulator
-- author: Maurício C. Antunes
-- e-mail: mauricio.antunes@gmail.com
-- license: public domain

module Main where

import Control.Applicative
import Prelude

import Data.Maybe
import Graphics.UI.Gtk
import Graphics.Rendering.Cairo
import Control.Monad
import Data.IORef
import Data.List
import Data.Time
import Data.Complex

-- Constants

accelerator = 0.7*carSize :: Double
brake = 10*accelerator:: Double
carSize = 2*pi/59 :: Double
responseTime = 0.24 :: Double
drawSide = 5/2 :: Double

-- A few conveniences

eventWindowSize = do
    dr <- eventWindow
    w <- liftIO $ drawWindowGetWidth dr
    h <- liftIO $ drawWindowGetHeight dr
    return $ if w*h > 1
        then (fromIntegral w, fromIntegral h)
        else (1,1)

eventPolarCoordinates = do
    (w,h) <- eventWindowSize
    (x,y) <- eventCoordinates
    let (origX, origY) = (w/2, h/2)
    let (scaleX, scaleY) = (drawSide/w, drawSide/h)
    let (x',y') = (scaleX*(x-origX), scaleY*(y-origY))
    let (radius,theta) = polar $ x' :+ y'
    return $ (radius,theta)

getAndSet :: a -> IO (IO a, a -> IO ())
getAndSet a = do
    ior <- newIORef a
    let get = readIORef ior
    let set = writeIORef ior
    return (get,set)

diffTime :: UTCTime -> UTCTime -> Double
diffTime = (realToFrac .) . diffUTCTime

moveToLineTo :: Double -> Double
 -> Double -> Double -> Render ()
moveToLineTo a b c d = moveTo a b >> lineTo c d

-- Car list handling

-- Each car is represented by a pair of Doubles. The first
-- Double is its position in a circular road, represented by
-- an angle. The second is its angular velocity. The general
-- idea behind the simulation is that in a list of cars each
-- one will try to keep a safe speed to avoid a crash in the
-- event of a sudden brake of the next car.

newCarList nCars = take nCars $ zip [0,2*pi/nCars'..] (repeat 0)
    where nCars' = fromIntegral nCars

-- This resizes car lists by copying or keeping those
-- at lower speeds.

newCarListFromList nCars [] = newCarListFromList nCars [(0,0)]
newCarListFromList nCars list = sortBy ((. fst).(compare . fst)) $
    take nCars $ cycle $ sortBy ((. snd).(compare . snd)) list

-- Safe speed for car, given data from itself and the next
-- and, possibly, a forced (by the user) jam. Speed changes
-- are limited by accelerator and brake maxima.

newSpeed dt jam (p1,s1) (p2,s2) = min cv $ max bv $ ds - br
    where
        pd = (p2-p1-carSize) - responseTime*(s2-s1)
        pj = maybe pd ((subtract $ carSize/2)
         . (until (>0) (+2*pi)) . (subtract p1)) jam
        dd = brake*(max 0 $ min pd pj)
        br = brake*responseTime
        ds = sqrt $ br^2 + 2*dd
        cv = s1 + accelerator*dt
        bv = s1 - brake*dt

-- Update positions and speeds based on a timestep and maybe
-- taking a forced congestion into account

updateCarList _ _ [] = []
updateCarList timestep jam list = zip newPositions' newSpeeds
    where
        fakeCar = (p+2*pi,s) where (p,s) = head list
        newSpeeds = zipWith ns list (tail list ++ [fakeCar])
            where ns = newSpeed timestep jam
        newPositions = zipWith3 mean fsts snds newSpeeds
            where
                mean a b c = a + timestep*(b+c)/2
                fsts = map fst list
                snds = map snd list
        newPositions' = map (subtract base) newPositions
        base = (*(2*pi)) $ fromIntegral $ floor $ (/ (2*pi)) $
            head newPositions

about = do
    ad <- aboutDialogNew
    set ad [ aboutDialogName := "S.A.R.A.H."
           , aboutDialogVersion := "1.0"
           , aboutDialogAuthors := ["Maurício C. Antunes "
                                ++ "<mauricio.antunes@gmail.com>"]
           , aboutDialogComments := "Software Automation of "
                                ++ "Road Automobile Headache"]
    dialogRun ad
    widgetDestroy ad

main :: IO ()
main = do

    initGUI

    mainWindow <- windowNew
    drawingArea <- drawingAreaNew

    (getTimeStamp,setTimeStamp) <- getCurrentTime >>= getAndSet
    (getCars,setCars) <- getAndSet $ newCarList 20
    (getJam,setJam) <- getAndSet Nothing
    (getTimeoutId,setTimeoutId) <- getAndSet Nothing

    -- If 'resume' is called, 'step' will be called at small
    -- timesteps to update car data. If 'pause' is called, 'step'
    -- calls are stoped.  'resume' is called at program startup,
    -- and then the pause button alternates 'resume' and 'pause'.

    let step = do
         time <- getCurrentTime
         dt <- getTimeStamp >>= return . (diffTime time)
         setTimeStamp time
         liftM2 (updateCarList dt) getJam getCars >>= setCars
    let pause = do
         maybe (return ()) timeoutRemove =<< getTimeoutId
         setTimeoutId Nothing
    let resume = do
         setTimeoutId . Just =<< flip timeoutAdd 33
          (step >> widgetQueueDraw drawingArea >> return True)
         getCurrentTime >>= setTimeStamp

    -- The elements of the graphic interface are the set of
    -- buttons, the scale to set the number of cars and the
    -- car track. They are named as 'buttons', 'howMany' and
    -- 'track'. Each of them contains other widgets inside, but
    -- there's no reason to expose their names to the main IO.

    buttons <- do

        qr <- buttonNewFromStock stockClear
        on qr buttonActivated $ do
            (liftM length) getCars >>= setCars . newCarList
            getCurrentTime >>= setTimeStamp
            widgetQueueDraw drawingArea

        qp <- toggleButtonNewWithLabel stockMediaPause
        buttonSetUseStock qp True
        on qp toggled $ do
            p <- toggleButtonGetActive qp
            case p of
                True -> pause
                False -> resume

        qa <- buttonNewFromStock stockAbout
        on qa buttonActivated $ about

        qq <- buttonNewFromStock stockQuit
        on qq buttonActivated (do
                       widgetDestroy mainWindow
                       mainQuit)

        bb <- hButtonBoxNew
        containerAdd bb qr
        containerAdd bb qp
        containerAdd bb qa
        containerAdd bb qq
        return bb

    howMany <- do

        sc <- vScaleNewWithRange 1 40 1
        after sc valueChanged $ do
            v <- liftM floor $ rangeGetValue sc
            c <- getCars
            setCars $ newCarListFromList v c
            widgetQueueDraw drawingArea

        scaleSetValuePos sc PosTop
        scaleSetDigits sc 0
--        rangeSetUpdatePolicy sc UpdateDiscontinuous
        rangeSetValue sc =<< liftM (fromIntegral . length) getCars

        al <- alignmentNew 0.5 0.5 0 1
        alignmentSetPadding al 15 15 15 15
        containerAdd al sc
        return al

    track <- do

        let dr = drawingArea
        widgetAddEvents dr [PointerMotionMask]

        on dr motionNotifyEvent $ do
            (r,t) <- eventPolarCoordinates
            liftIO $ if (0.8<r && r<1.2)
                then setJam (Just t)
                else setJam Nothing
            liftIO $ widgetQueueDraw dr
            return True

        on dr leaveNotifyEvent $ liftIO $
            setJam Nothing >> return True

        on dr draw $ do
            w <- liftIO $ (fromIntegral <$> widgetGetAllocatedWidth dr)
            h <- liftIO $ (fromIntegral <$> widgetGetAllocatedHeight dr)
            jam <- liftIO getJam
            cars <- liftIO getCars
            translate (w/2) (h/2)
            scale (w/drawSide) (h/drawSide)
            road2render jam cars
            -- return True

        af <- aspectFrameNew 0.5 0.5 (Just 1)
        frameSetShadowType af ShadowNone
        containerAdd af dr
        return af

    -- 'layout' is a widget that contains all interface elements
    -- properly arranged.

    layout <- do
        vb <- vBoxNew False 0
        hb <- hBoxNew False 0
        boxPackStart vb track PackGrow 0
        boxPackStart vb buttons PackNatural 0
        boxPackStart hb howMany PackNatural 0
        boxPackStart hb vb PackGrow 0
        return hb

    set mainWindow [ windowTitle := "S.A.R.A.H."
                   , windowDefaultWidth := 400
                   , windowDefaultHeight := 400 ]
    on mainWindow objectDestroy mainQuit
    containerAdd mainWindow layout
    widgetShowAll mainWindow

    resume

    mainGUI

-- As the name says, this takes road info, in the form of a
-- possible jam and a list of cars, and make it into a Cairo
-- render.  Road will have radius 1.

road2render :: Maybe Double -> [(Double,Double)] -> Render ()
road2render jam cars = do
    newPath
    setSourceRGB 0 0 0
    drawRoad
    when (isJust jam) drawJam
    setSourceRGBA 0 0 0 0.55
    let cars' = map fst cars
    let rotations = zipWith subtract (0:cars') cars'
    sequence_ $ map ((>> drawCar) . rotate) rotations
 where
    drawRoad = setLineWidth 0.01 >> setDash [2*pi/34,2*pi/34]
     (pi/34) >> arc 0.0 0.0 1.0 0.0 (2*pi) >> stroke
    drawJam = setLineWidth 0.005 >> setDash [0.03,0.02] 0.04 >>
     save >> rotate (fromJust jam) >> moveToLineTo 0.8 0 1.2
     0 >> stroke >> setDash [] 0 >> moveToLineTo 0.8 (-0.015)
     0.8 0.015 >> moveToLineTo 1.2 (-0.015) 1.2 0.015 >> stroke
     >> restore
    drawCar = arc 1 0 (carSize/2) 0 (2*pi) >> fill

max_stars_repo_name: SwiftsNamesake/Leopardy

max_issues_repo_name: SwiftsNamesake/Leopardy

max_forks_repo_name: SwiftsNamesake/Leopardy


text:
{-# LANGUAGE CPP #-}

#ifndef MIN_VERSION_transformers
#define MIN_VERSION_transformers(a,b,c) 1
#endif

#ifndef HASKELL98
# if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
# elif __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
# endif
# if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
# endif
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Functor.Classes
-- Copyright   :  (c) Ross Paterson 2013, Edward Kmett 2014
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  R.Paterson@city.ac.uk
-- Stability   :  experimental
-- Portability :  portable
--
-- Liftings of the Prelude classes 'Eq', 'Ord', 'Read' and 'Show' to
-- unary and binary type constructors.
--
-- These classes are needed to express the constraints on arguments of
-- transformers in portable Haskell.  Thus for a new transformer @T@,
-- one might write instances like
--
-- > instance (Eq1 f) => Eq1 (T f) where ...
-- > instance (Ord1 f) => Ord1 (T f) where ...
-- > instance (Read1 f) => Read1 (T f) where ...
-- > instance (Show1 f) => Show1 (T f) where ...
--
-- If these instances can be defined, defining instances of the base
-- classes is mechanical:
--
-- > instance (Eq1 f, Eq a) => Eq (T f a) where (==) = eq1
-- > instance (Ord1 f, Ord a) => Ord (T f a) where compare = compare1
-- > instance (Read1 f, Read a) => Read (T f a) where readsPrec = readsPrec1
-- > instance (Show1 f, Show a) => Show (T f a) where showsPrec = showsPrec1
--
-----------------------------------------------------------------------------

module Data.Functor.Classes (
    -- * Liftings of Prelude classes
    -- ** For unary constructors
    Eq1(..), eq1,
    Ord1(..), compare1,
    Read1(..), readsPrec1,
    Show1(..), showsPrec1,
    -- ** For binary constructors
    Eq2(..), eq2,
    Ord2(..), compare2,
    Read2(..), readsPrec2,
    Show2(..), showsPrec2,
    -- * Helper functions
    -- $example
    readsData,
    readsUnaryWith,
    readsBinaryWith,
    showsUnaryWith,
    showsBinaryWith,
    -- ** Obsolete helpers
    readsUnary,
    readsUnary1,
    readsBinary1,
    showsUnary,
    showsUnary1,
    showsBinary1,
  ) where

import Control.Applicative (Const(Const))
import Data.Functor.Identity (Identity(Identity))
import Data.Monoid (mappend)
#if MIN_VERSION_base(4,7,0)
import Data.Proxy (Proxy(Proxy))
#endif
import Text.Show (showListWith)

import Control.Monad.Trans.Error
import Control.Monad.Trans.Identity
import Control.Monad.Trans.List
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Writer.Lazy as Lazy
import Control.Monad.Trans.Writer.Strict as Strict
import Data.Functor.Compose
import Data.Functor.Constant
import Data.Functor.Product
import Data.Complex (Complex (..))

#if MIN_VERSION_transformers(0,3,0)
import Control.Applicative.Lift
import Control.Applicative.Backwards
import Data.Functor.Reverse
#endif

#ifndef HASKELL98
# if __GLASGOW_HASKELL__ >= 708
import Data.Typeable
# endif
#endif

-- | Lifting of the 'Eq' class to unary type constructors.
class Eq1 f where
    -- | Lift an equality test through the type constructor.
    --
    -- The function will usually be applied to an equality function,
    -- but the more general type ensures that the implementation uses
    -- it to compare elements of the first container with elements of
    -- the second.
    liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool

-- | Lift the standard @('==')@ function through the type constructor.
eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool
eq1 = liftEq (==)

-- | Lifting of the 'Ord' class to unary type constructors.
class (Eq1 f) => Ord1 f where
    -- | Lift a 'compare' function through the type constructor.
    --
    -- The function will usually be applied to a comparison function,
    -- but the more general type ensures that the implementation uses
    -- it to compare elements of the first container with elements of
    -- the second.
    liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering

-- | Lift the standard 'compare' function through the type constructor.
compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1 = liftCompare compare

-- | Lifting of the 'Read' class to unary type constructors.
class Read1 f where
    -- | 'readsPrec' function for an application of the type constructor
    -- based on 'readsPrec' and 'readList' functions for the argument type.
    liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)

    -- | 'readList' function for an application of the type constructor
    -- based on 'readsPrec' and 'readList' functions for the argument type.
    -- The default implementation using standard list syntax is correct
    -- for most types.
    liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
    liftReadList rp rl = readListWith (liftReadsPrec rp rl 0)

-- | Read a list (using square brackets and commas), given a function
-- for reading elements.
readListWith :: ReadS a -> ReadS [a]
readListWith rp =
    readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s])
  where
    readl s = [([],t) | ("]",t) <- lex s] ++
        [(x:xs,u) | (x,t) <- rp s, (xs,u) <- readl' t]
    readl' s = [([],t) | ("]",t) <- lex s] ++
        [(x:xs,v) | (",",t) <- lex s, (x,u) <- rp t, (xs,v) <- readl' u]

-- | Lift the standard 'readsPrec' and 'readList' functions through the
-- type constructor.
readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a)
readsPrec1 = liftReadsPrec readsPrec readList

-- | Lifting of the 'Show' class to unary type constructors.
class Show1 f where
    -- | 'showsPrec' function for an application of the type constructor
    -- based on 'showsPrec' and 'showList' functions for the argument type.
    liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
        Int -> f a -> ShowS

    -- | 'showList' function for an application of the type constructor
    -- based on 'showsPrec' and 'showList' functions for the argument type.
    -- The default implementation using standard list syntax is correct
    -- for most types.
    liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
        [f a] -> ShowS
    liftShowList sp sl = showListWith (liftShowsPrec sp sl 0)

-- | Lift the standard 'showsPrec' and 'showList' functions through the
-- type constructor.
showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1 = liftShowsPrec showsPrec showList

-- | Lifting of the 'Eq' class to binary type constructors.
class Eq2 f where
    -- | Lift equality tests through the type constructor.
    --
    -- The function will usually be applied to equality functions,
    -- but the more general type ensures that the implementation uses
    -- them to compare elements of the first container with elements of
    -- the second.
    liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool

-- | Lift the standard @('==')@ function through the type constructor.
eq2 :: (Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool
eq2 = liftEq2 (==) (==)

-- | Lifting of the 'Ord' class to binary type constructors.
class (Eq2 f) => Ord2 f where
    -- | Lift 'compare' functions through the type constructor.
    --
    -- The function will usually be applied to comparison functions,
    -- but the more general type ensures that the implementation uses
    -- them to compare elements of the first container with elements of
    -- the second.
    liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) ->
        f a c -> f b d -> Ordering

-- | Lift the standard 'compare' function through the type constructor.
compare2 :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Ordering
compare2 = liftCompare2 compare compare

-- | Lifting of the 'Read' class to binary type constructors.
class Read2 f where
    -- | 'readsPrec' function for an application of the type constructor
    -- based on 'readsPrec' and 'readList' functions for the argument types.
    liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] ->
        (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b)

    -- | 'readList' function for an application of the type constructor
    -- based on 'readsPrec' and 'readList' functions for the argument types.
    -- The default implementation using standard list syntax is correct
    -- for most types.
    liftReadList2 :: (Int -> ReadS a) -> ReadS [a] ->
        (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b]
    liftReadList2 rp1 rl1 rp2 rl2 =
        readListWith (liftReadsPrec2 rp1 rl1 rp2 rl2 0)

-- | Lift the standard 'readsPrec' function through the type constructor.
readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b)
readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList

-- | Lifting of the 'Show' class to binary type constructors.
class Show2 f where
    -- | 'showsPrec' function for an application of the type constructor
    -- based on 'showsPrec' and 'showList' functions for the argument types.
    liftShowsPrec2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
        (Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> f a b -> ShowS

    -- | 'showList' function for an application of the type constructor
    -- based on 'showsPrec' and 'showList' functions for the argument types.
    -- The default implementation using standard list syntax is correct
    -- for most types.
    liftShowList2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
        (Int -> b -> ShowS) -> ([b] -> ShowS) -> [f a b] -> ShowS
    liftShowList2 sp1 sl1 sp2 sl2 =
        showListWith (liftShowsPrec2 sp1 sl1 sp2 sl2 0)

-- | Lift the standard 'showsPrec' function through the type constructor.
showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS
showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList

-- Instances for Prelude type constructors

instance Eq1 Maybe where
    liftEq _ Nothing Nothing = True
    liftEq _ Nothing (Just _) = False
    liftEq _ (Just _) Nothing = False
    liftEq eq (Just x) (Just y) = eq x y

instance Ord1 Maybe where
    liftCompare _ Nothing Nothing = EQ
    liftCompare _ Nothing (Just _) = LT
    liftCompare _ (Just _) Nothing = GT
    liftCompare comp (Just x) (Just y) = comp x y

instance Read1 Maybe where
    liftReadsPrec rp _ d =
         readParen False (\ r -> [(Nothing,s) | ("Nothing",s) <- lex r])
         `mappend`
         readsData (readsUnaryWith rp "Just" Just) d

instance Show1 Maybe where
    liftShowsPrec _ _ _ Nothing = showString "Nothing"
    liftShowsPrec sp _ d (Just x) = showsUnaryWith sp "Just" d x

instance Eq1 [] where
    liftEq _ [] [] = True
    liftEq _ [] (_:_) = False
    liftEq _ (_:_) [] = False
    liftEq eq (x:xs) (y:ys) = eq x y && liftEq eq xs ys

instance Ord1 [] where
    liftCompare _ [] [] = EQ
    liftCompare _ [] (_:_) = LT
    liftCompare _ (_:_) [] = GT
    liftCompare comp (x:xs) (y:ys) = comp x y `mappend` liftCompare comp xs ys

instance Read1 [] where
    liftReadsPrec _ rl _ = rl

instance Show1 [] where
    liftShowsPrec _ sl _ = sl

instance Eq2 (,) where
    liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2

instance Ord2 (,) where
    liftCompare2 comp1 comp2 (x1, y1) (x2, y2) =
        comp1 x1 x2 `mappend` comp2 y1 y2

instance Read2 (,) where
    liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r ->
        [((x,y), w) | ("(",s) <- lex r,
                      (x,t)   <- rp1 0 s,
                      (",",u) <- lex t,
                      (y,v)   <- rp2 0 u,
                      (")",w) <- lex v]

instance Show2 (,) where
    liftShowsPrec2 sp1 _ sp2 _ _ (x, y) =
        showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')'

instance (Eq a) => Eq1 ((,) a) where
    liftEq = liftEq2 (==)

instance (Ord a) => Ord1 ((,) a) where
    liftCompare = liftCompare2 compare

instance (Read a) => Read1 ((,) a) where
    liftReadsPrec = liftReadsPrec2 readsPrec readList

instance (Show a) => Show1 ((,) a) where
    liftShowsPrec = liftShowsPrec2 showsPrec showList

instance Eq2 Either where
    liftEq2 e1 _ (Left x) (Left y) = e1 x y
    liftEq2 _ _ (Left _) (Right _) = False
    liftEq2 _ _ (Right _) (Left _) = False
    liftEq2 _ e2 (Right x) (Right y) = e2 x y

instance Ord2 Either where
    liftCompare2 comp1 _ (Left x) (Left y) = comp1 x y
    liftCompare2 _ _ (Left _) (Right _) = LT
    liftCompare2 _ _ (Right _) (Left _) = GT
    liftCompare2 _ comp2 (Right x) (Right y) = comp2 x y

instance Read2 Either where
    liftReadsPrec2 rp1 _ rp2 _ = readsData $
         readsUnaryWith rp1 "Left" Left `mappend`
         readsUnaryWith rp2 "Right" Right

instance Show2 Either where
    liftShowsPrec2 sp1 _ _ _ d (Left x) = showsUnaryWith sp1 "Left" d x
    liftShowsPrec2 _ _ sp2 _ d (Right x) = showsUnaryWith sp2 "Right" d x

instance (Eq a) => Eq1 (Either a) where
    liftEq = liftEq2 (==)

instance (Ord a) => Ord1 (Either a) where
    liftCompare = liftCompare2 compare

instance (Read a) => Read1 (Either a) where
    liftReadsPrec = liftReadsPrec2 readsPrec readList

instance (Show a) => Show1 (Either a) where
    liftShowsPrec = liftShowsPrec2 showsPrec showList

-- Instances for other functors defined in the base package

instance Eq1 Identity where
    liftEq eq (Identity x) (Identity y) = eq x y

instance Ord1 Identity where
    liftCompare comp (Identity x) (Identity y) = comp x y

instance Read1 Identity where
    liftReadsPrec rp _ = readsData $
         readsUnaryWith rp "Identity" Identity

instance Show1 Identity where
    liftShowsPrec sp _ d (Identity x) = showsUnaryWith sp "Identity" d x

instance Eq2 Const where
    liftEq2 eq _ (Const x) (Const y) = eq x y

instance Ord2 Const where
    liftCompare2 comp _ (Const x) (Const y) = comp x y

instance Read2 Const where
    liftReadsPrec2 rp _ _ _ = readsData $
         readsUnaryWith rp "Const" Const

instance Show2 Const where
    liftShowsPrec2 sp _ _ _ d (Const x) = showsUnaryWith sp "Const" d x

instance (Eq a) => Eq1 (Const a) where
    liftEq = liftEq2 (==)
instance (Ord a) => Ord1 (Const a) where
    liftCompare = liftCompare2 compare
instance (Read a) => Read1 (Const a) where
    liftReadsPrec = liftReadsPrec2 readsPrec readList
instance (Show a) => Show1 (Const a) where
    liftShowsPrec = liftShowsPrec2 showsPrec showList

#if MIN_VERSION_base(4,7,0)
instance Eq1 Proxy where
    liftEq _ _ _ = True

instance Ord1 Proxy where
    liftCompare _ _ _ = EQ

instance Show1 Proxy where
    liftShowsPrec _ _ _ _ = showString "Proxy"

instance Read1 Proxy where
    liftReadsPrec _ _ d =
        readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ])
#endif

-- Building blocks

-- | @'readsData' p d@ is a parser for datatypes where each alternative
-- begins with a data constructor.  It parses the constructor and
-- passes it to @p@.  Parsers for various constructors can be constructed
-- with 'readsUnary', 'readsUnary1' and 'readsBinary1', and combined with
-- @mappend@ from the @Monoid@ class.
readsData :: (String -> ReadS a) -> Int -> ReadS a
readsData reader d =
    readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s]

-- | @'readsUnaryWith' rp n c n'@ matches the name of a unary data constructor
-- and then parses its argument using @rp@.
readsUnaryWith :: (Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith rp name cons kw s =
    [(cons x,t) | kw == name, (x,t) <- rp 11 s]

-- | @'readsBinaryWith' rp1 rp2 n c n'@ matches the name of a binary
-- data constructor and then parses its arguments using @rp1@ and @rp2@
-- respectively.
readsBinaryWith :: (Int -> ReadS a) -> (Int -> ReadS b) ->
    String -> (a -> b -> t) -> String -> ReadS t
readsBinaryWith rp1 rp2 name cons kw s =
    [(cons x y,u) | kw == name, (x,t) <- rp1 11 s, (y,u) <- rp2 11 t]

-- | @'showsUnaryWith' sp n d x@ produces the string representation of a
-- unary data constructor with name @n@ and argument @x@, in precedence
-- context @d@.
showsUnaryWith :: (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith sp name d x = showParen (d > 10) $
    showString name . showChar ' ' . sp 11 x

-- | @'showsBinaryWith' sp1 sp2 n d x y@ produces the string
-- representation of a binary data constructor with name @n@ and arguments
-- @x@ and @y@, in precedence context @d@.
showsBinaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) ->
    String -> Int -> a -> b -> ShowS
showsBinaryWith sp1 sp2 name d x y = showParen (d > 10) $
    showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y

-- Obsolete building blocks

-- | @'readsUnary' n c n'@ matches the name of a unary data constructor
-- and then parses its argument using 'readsPrec'.
{-# DEPRECATED readsUnary "Use readsUnaryWith to define liftReadsPrec" #-}
readsUnary :: (Read a) => String -> (a -> t) -> String -> ReadS t
readsUnary name cons kw s =
    [(cons x,t) | kw == name, (x,t) <- readsPrec 11 s]

-- | @'readsUnary1' n c n'@ matches the name of a unary data constructor
-- and then parses its argument using 'readsPrec1'.
{-# DEPRECATED readsUnary1 "Use readsUnaryWith to define liftReadsPrec" #-}
readsUnary1 :: (Read1 f, Read a) => String -> (f a -> t) -> String -> ReadS t
readsUnary1 name cons kw s =
    [(cons x,t) | kw == name, (x,t) <- readsPrec1 11 s]

-- | @'readsBinary1' n c n'@ matches the name of a binary data constructor
-- and then parses its arguments using 'readsPrec1'.
{-# DEPRECATED readsBinary1 "Use readsBinaryWith to define liftReadsPrec" #-}
readsBinary1 :: (Read1 f, Read1 g, Read a) =>
    String -> (f a -> g a -> t) -> String -> ReadS t
readsBinary1 name cons kw s =
    [(cons x y,u) | kw == name,
        (x,t) <- readsPrec1 11 s, (y,u) <- readsPrec1 11 t]

-- | @'showsUnary' n d x@ produces the string representation of a unary data
-- constructor with name @n@ and argument @x@, in precedence context @d@.
{-# DEPRECATED showsUnary "Use showsUnaryWith to define liftShowsPrec" #-}
showsUnary :: (Show a) => String -> Int -> a -> ShowS
showsUnary name d x = showParen (d > 10) $
    showString name . showChar ' ' . showsPrec 11 x

-- | @'showsUnary1' n d x@ produces the string representation of a unary data
-- constructor with name @n@ and argument @x@, in precedence context @d@.
{-# DEPRECATED showsUnary1 "Use showsUnaryWith to define liftShowsPrec" #-}
showsUnary1 :: (Show1 f, Show a) => String -> Int -> f a -> ShowS
showsUnary1 name d x = showParen (d > 10) $
    showString name . showChar ' ' . showsPrec1 11 x

-- | @'showsBinary1' n d x y@ produces the string representation of a binary
-- data constructor with name @n@ and arguments @x@ and @y@, in precedence
-- context @d@.
{-# DEPRECATED showsBinary1 "Use showsBinaryWith to define liftShowsPrec" #-}
showsBinary1 :: (Show1 f, Show1 g, Show a) =>
    String -> Int -> f a -> g a -> ShowS
showsBinary1 name d x y = showParen (d > 10) $
    showString name . showChar ' ' . showsPrec1 11 x .
        showChar ' ' . showsPrec1 11 y

instance (Eq e, Eq1 m) => Eq1 (ErrorT e m) where
    liftEq eq (ErrorT x) (ErrorT y) = liftEq (liftEq eq) x y

instance (Ord e, Ord1 m) => Ord1 (ErrorT e m) where
    liftCompare comp (ErrorT x) (ErrorT y) = liftCompare (liftCompare comp) x y

instance (Read e, Read1 m) => Read1 (ErrorT e m) where
    liftReadsPrec rp rl = readsData $
        readsUnaryWith (liftReadsPrec rp' rl') "ErrorT" ErrorT
      where
        rp' = liftReadsPrec rp rl
        rl' = liftReadList rp rl

instance (Show e, Show1 m) => Show1 (ErrorT e m) where
    liftShowsPrec sp sl d (ErrorT m) =
        showsUnaryWith (liftShowsPrec sp' sl') "ErrorT" d m
      where
        sp' = liftShowsPrec sp sl
        sl' = liftShowList sp sl

instance (Eq e, Eq1 m, Eq a) => Eq (ErrorT e m a) where (==) = eq1
instance (Ord e, Ord1 m, Ord a) => Ord (ErrorT e m a) where compare = compare1
instance (Read e, Read1 m, Read a) => Read (ErrorT e m a) where
    readsPrec = readsPrec1
instance (Show e, Show1 m, Show a) => Show (ErrorT e m a) where
    showsPrec = showsPrec1

instance (Eq1 f) => Eq1 (IdentityT f) where
    liftEq eq (IdentityT x) (IdentityT y) = liftEq eq x y

instance (Ord1 f) => Ord1 (IdentityT f) where
    liftCompare comp (IdentityT x) (IdentityT y) = liftCompare comp x y

instance (Read1 f) => Read1 (IdentityT f) where
    liftReadsPrec rp rl = readsData $
        readsUnaryWith (liftReadsPrec rp rl) "IdentityT" IdentityT

instance (Show1 f) => Show1 (IdentityT f) where
    liftShowsPrec sp sl d (IdentityT m) =
        showsUnaryWith (liftShowsPrec sp sl) "IdentityT" d m

instance (Eq1 f, Eq a) => Eq (IdentityT f a) where (==) = eq1
instance (Ord1 f, Ord a) => Ord (IdentityT f a) where compare = compare1
instance (Read1 f, Read a) => Read (IdentityT f a) where readsPrec = readsPrec1
instance (Show1 f, Show a) => Show (IdentityT f a) where showsPrec = showsPrec1

instance (Eq1 m) => Eq1 (ListT m) where
    liftEq eq (ListT x) (ListT y) = liftEq (liftEq eq) x y

instance (Ord1 m) => Ord1 (ListT m) where
    liftCompare comp (ListT x) (ListT y) = liftCompare (liftCompare comp) x y

instance (Read1 m) => Read1 (ListT m) where
    liftReadsPrec rp rl = readsData $
        readsUnaryWith (liftReadsPrec rp' rl') "ListT" ListT
      where
        rp' = liftReadsPrec rp rl
        rl' = liftReadList rp rl

instance (Show1 m) => Show1 (ListT m) where
    liftShowsPrec sp sl d (ListT m) =
        showsUnaryWith (liftShowsPrec sp' sl') "ListT" d m
      where
        sp' = liftShowsPrec sp sl
        sl' = liftShowList sp sl

instance (Eq1 m, Eq a) => Eq (ListT m a) where (==) = eq1
instance (Ord1 m, Ord a) => Ord (ListT m a) where compare = compare1
instance (Read1 m, Read a) => Read (ListT m a) where readsPrec = readsPrec1
instance (Show1 m, Show a) => Show (ListT m a) where showsPrec = showsPrec1

instance (Eq1 m) => Eq1 (MaybeT m) where
    liftEq eq (MaybeT x) (MaybeT y) = liftEq (liftEq eq) x y

instance (Ord1 m) => Ord1 (MaybeT m) where
    liftCompare comp (MaybeT x) (MaybeT y) = liftCompare (liftCompare comp) x y

instance (Read1 m) => Read1 (MaybeT m) where
    liftReadsPrec rp rl = readsData $
        readsUnaryWith (liftReadsPrec rp' rl') "MaybeT" MaybeT
      where
        rp' = liftReadsPrec rp rl
        rl' = liftReadList rp rl

instance (Show1 m) => Show1 (MaybeT m) where
    liftShowsPrec sp sl d (MaybeT m) =
        showsUnaryWith (liftShowsPrec sp' sl') "MaybeT" d m
      where
        sp' = liftShowsPrec sp sl
        sl' = liftShowList sp sl

instance (Eq1 m, Eq a) => Eq (MaybeT m a) where (==) = eq1
instance (Ord1 m, Ord a) => Ord (MaybeT m a) where compare = compare1
instance (Read1 m, Read a) => Read (MaybeT m a) where readsPrec = readsPrec1
instance (Show1 m, Show a) => Show (MaybeT m a) where showsPrec = showsPrec1

instance (Eq w, Eq1 m) => Eq1 (Lazy.WriterT w m) where
    liftEq eq (Lazy.WriterT m1) (Lazy.WriterT m2) =
        liftEq (liftEq2 eq (==)) m1 m2

instance (Ord w, Ord1 m) => Ord1 (Lazy.WriterT w m) where
    liftCompare comp (Lazy.WriterT m1) (Lazy.WriterT m2) =
        liftCompare (liftCompare2 comp compare) m1 m2

instance (Read w, Read1 m) => Read1 (Lazy.WriterT w m) where
    liftReadsPrec rp rl = readsData $
        readsUnaryWith (liftReadsPrec rp' rl') "WriterT" Lazy.WriterT
      where
        rp' = liftReadsPrec2 rp rl readsPrec readList
        rl' = liftReadList2 rp rl readsPrec readList

instance (Show w, Show1 m) => Show1 (Lazy.WriterT w m) where
    liftShowsPrec sp sl d (Lazy.WriterT m) =
        showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m
      where
        sp' = liftShowsPrec2 sp sl showsPrec showList
        sl' = liftShowList2 sp sl showsPrec showList

instance (Eq w, Eq1 m, Eq a) => Eq (Lazy.WriterT w m a) where
    (==) = eq1
instance (Ord w, Ord1 m, Ord a) => Ord (Lazy.WriterT w m a) where
    compare = compare1
instance (Read w, Read1 m, Read a) => Read (Lazy.WriterT w m a) where
    readsPrec = readsPrec1
instance (Show w, Show1 m, Show a) => Show (Lazy.WriterT w m a) where
    showsPrec = showsPrec1

instance (Eq w, Eq1 m) => Eq1 (Strict.WriterT w m) where
    liftEq eq (Strict.WriterT m1) (Strict.WriterT m2) =
        liftEq (liftEq2 eq (==)) m1 m2

instance (Ord w, Ord1 m) => Ord1 (Strict.WriterT w m) where
    liftCompare comp (Strict.WriterT m1) (Strict.WriterT m2) =
        liftCompare (liftCompare2 comp compare) m1 m2

instance (Read w, Read1 m) => Read1 (Strict.WriterT w m) where
    liftReadsPrec rp rl = readsData $
        readsUnaryWith (liftReadsPrec rp' rl') "WriterT" Strict.WriterT
      where
        rp' = liftReadsPrec2 rp rl readsPrec readList
        rl' = liftReadList2 rp rl readsPrec readList

instance (Show w, Show1 m) => Show1 (Strict.WriterT w m) where
    liftShowsPrec sp sl d (Strict.WriterT m) =
        showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m
      where
        sp' = liftShowsPrec2 sp sl showsPrec showList
        sl' = liftShowList2 sp sl showsPrec showList

instance (Eq w, Eq1 m, Eq a) => Eq (Strict.WriterT w m a) where
    (==) = eq1
instance (Ord w, Ord1 m, Ord a) => Ord (Strict.WriterT w m a) where
    compare = compare1
instance (Read w, Read1 m, Read a) => Read (Strict.WriterT w m a) where
    readsPrec = readsPrec1
instance (Show w, Show1 m, Show a) => Show (Strict.WriterT w m a) where
    showsPrec = showsPrec1

instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where
    liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y

instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where
    liftCompare comp (Compose x) (Compose y) =
        liftCompare (liftCompare comp) x y

instance (Read1 f, Read1 g) => Read1 (Compose f g) where
    liftReadsPrec rp rl = readsData $
        readsUnaryWith (liftReadsPrec rp' rl') "Compose" Compose
      where
        rp' = liftReadsPrec rp rl
        rl' = liftReadList rp rl

instance (Show1 f, Show1 g) => Show1 (Compose f g) where
    liftShowsPrec sp sl d (Compose x) =
        showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x
      where
        sp' = liftShowsPrec sp sl
        sl' = liftShowList sp sl

instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where
    (==) = eq1
instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where
    compare = compare1
instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where
    readsPrec = readsPrec1
instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where
    showsPrec = showsPrec1

instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where
    liftEq eq (Pair x1 y1) (Pair x2 y2) = liftEq eq x1 x2 && liftEq eq y1 y2

instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where
    liftCompare comp (Pair x1 y1) (Pair x2 y2) =
        liftCompare comp x1 x2 `mappend` liftCompare comp y1 y2

instance (Read1 f, Read1 g) => Read1 (Product f g) where
    liftReadsPrec rp rl = readsData $
        readsBinaryWith (liftReadsPrec rp rl) (liftReadsPrec rp rl) "Pair" Pair

instance (Show1 f, Show1 g) => Show1 (Product f g) where
    liftShowsPrec sp sl d (Pair x y) =
        showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Pair" d x y

instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a)
    where (==) = eq1
instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where
    compare = compare1
instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where
    readsPrec = readsPrec1
instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where
    showsPrec = showsPrec1

instance Eq2 Constant where
    liftEq2 eq _ (Constant x) (Constant y) = eq x y
instance Ord2 Constant where
    liftCompare2 comp _ (Constant x) (Constant y) = comp x y
instance Read2 Constant where
    liftReadsPrec2 rp _ _ _ = readsData $
         readsUnaryWith rp "Constant" Constant
instance Show2 Constant where
    liftShowsPrec2 sp _ _ _ d (Constant x) = showsUnaryWith sp "Constant" d x

instance (Eq a) => Eq1 (Constant a) where
    liftEq = liftEq2 (==)
instance (Ord a) => Ord1 (Constant a) where
    liftCompare = liftCompare2 compare
instance (Read a) => Read1 (Constant a) where
    liftReadsPrec = liftReadsPrec2 readsPrec readList
instance (Show a) => Show1 (Constant a) where
    liftShowsPrec = liftShowsPrec2 showsPrec showList

instance Eq a => Eq (Constant a b) where
    Constant a == Constant b = a == b
instance Ord a => Ord (Constant a b) where
    compare (Constant a) (Constant b) = compare a b
instance (Read a) => Read (Constant a b) where
    readsPrec = readsData $
         readsUnaryWith readsPrec "Constant" Constant
instance (Show a) => Show (Constant a b) where
    showsPrec d (Constant x) = showsUnaryWith showsPrec "Constant" d x

instance Show a => Show (Identity a) where
  showsPrec d (Identity a) = showParen (d > 10) $
    showString "Identity " . showsPrec 11 a
instance Read a => Read (Identity a) where
  readsPrec d = readParen (d > 10) (\r -> [(Identity m,t) | ("Identity",s) <- lex r, (m,t) <- readsPrec 11 s])
instance Eq a   => Eq (Identity a) where
  Identity a == Identity b = a == b
instance Ord a  => Ord (Identity a) where
  compare (Identity a) (Identity b) = compare a b

#if MIN_VERSION_transformers(0,3,0)
instance (Eq1 f) => Eq1 (Lift f) where
    liftEq eq (Pure x1) (Pure x2) = eq x1 x2
    liftEq _ (Pure _) (Other _) = False
    liftEq _ (Other _) (Pure _) = False
    liftEq eq (Other y1) (Other y2) = liftEq eq y1 y2

instance (Ord1 f) => Ord1 (Lift f) where
    liftCompare comp (Pure x1) (Pure x2) = comp x1 x2
    liftCompare _ (Pure _) (Other _) = LT
    liftCompare _ (Other _) (Pure _) = GT
    liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2

instance (Read1 f) => Read1 (Lift f) where
    liftReadsPrec rp rl = readsData $
        readsUnaryWith rp "Pure" Pure `mappend`
        readsUnaryWith (liftReadsPrec rp rl) "Other" Other

instance (Show1 f) => Show1 (Lift f) where
    liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x
    liftShowsPrec sp sl d (Other y) =
        showsUnaryWith (liftShowsPrec sp sl) "Other" d y

instance (Eq1 f, Eq a) => Eq (Lift f a) where (==) = eq1
instance (Ord1 f, Ord a) => Ord (Lift f a) where compare = compare1
instance (Read1 f, Read a) => Read (Lift f a) where readsPrec = readsPrec1
instance (Show1 f, Show a) => Show (Lift f a) where showsPrec = showsPrec1

instance (Eq1 f) => Eq1 (Backwards f) where
    liftEq eq (Backwards x) (Backwards y) = liftEq eq x y

instance (Ord1 f) => Ord1 (Backwards f) where
    liftCompare comp (Backwards x) (Backwards y) = liftCompare comp x y

instance (Read1 f) => Read1 (Backwards f) where
    liftReadsPrec rp rl = readsData $
        readsUnaryWith (liftReadsPrec rp rl) "Backwards" Backwards

instance (Show1 f) => Show1 (Backwards f) where
    liftShowsPrec sp sl d (Backwards x) =
        showsUnaryWith (liftShowsPrec sp sl) "Backwards" d x

instance (Eq1 f, Eq a) => Eq (Backwards f a) where (==) = eq1
instance (Ord1 f, Ord a) => Ord (Backwards f a) where compare = compare1
instance (Read1 f, Read a) => Read (Backwards f a) where readsPrec = readsPrec1
instance (Show1 f, Show a) => Show (Backwards f a) where showsPrec = showsPrec1

instance (Eq1 f) => Eq1 (Reverse f) where
    liftEq eq (Reverse x) (Reverse y) = liftEq eq x y

instance (Ord1 f) => Ord1 (Reverse f) where
    liftCompare comp (Reverse x) (Reverse y) = liftCompare comp x y

instance (Read1 f) => Read1 (Reverse f) where
    liftReadsPrec rp rl = readsData $
        readsUnaryWith (liftReadsPrec rp rl) "Reverse" Reverse

instance (Show1 f) => Show1 (Reverse f) where
    liftShowsPrec sp sl d (Reverse x) =
        showsUnaryWith (liftShowsPrec sp sl) "Reverse" d x

instance (Eq1 f, Eq a) => Eq (Reverse f a) where (==) = eq1
instance (Ord1 f, Ord a) => Ord (Reverse f a) where compare = compare1
instance (Read1 f, Read a) => Read (Reverse f a) where readsPrec = readsPrec1
instance (Show1 f, Show a) => Show (Reverse f a) where showsPrec = showsPrec1
#endif

#ifndef HASKELL98
# if __GLASGOW_HASKELL__ >= 708
deriving instance Typeable Eq1
deriving instance Typeable Eq2
deriving instance Typeable Ord1
deriving instance Typeable Ord2
deriving instance Typeable Read1
deriving instance Typeable Read2
deriving instance Typeable Show1
deriving instance Typeable Show2
# endif
#endif

#if MIN_VERSION_base(4,4,0)
instance Eq1 Complex where
    liftEq eq (x :+ y) (u :+ v) = eq x u && eq y v

instance Read1 Complex where
    liftReadsPrec rdP _ p s = readParen (p > complexPrec) (\s' -> do
      (x, s'')     <- rdP (complexPrec+1) s'
      (":+", s''') <- lex s''
      (y, s'''')   <- rdP (complexPrec+1) s'''
      return (x :+ y, s'''')) s
      where
        complexPrec = 6

instance Show1 Complex where
    liftShowsPrec sp _ d (x :+ y) = showParen (d > complexPrec) $
        sp (complexPrec+1) x . showString " :+ " . sp (complexPrec+1) y
      where
        complexPrec = 6
#endif

instance Eq a => Eq2 ((,,) a) where
    liftEq2 e1 e2 (u1, x1, y1) (v1, x2, y2) =
        u1 == v1 &&
        e1 x1 x2 && e2 y1 y2

instance Ord a => Ord2 ((,,) a) where
    liftCompare2 comp1 comp2 (u1, x1, y1) (v1, x2, y2) =
        compare u1 v1 `mappend`
        comp1 x1 x2 `mappend` comp2 y1 y2

instance Read a => Read2 ((,,) a) where
    liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r ->
        [((e1,e2,e3), y) | ("(",s) <- lex r,
                           (e1,t)  <- readsPrec 0 s,
                           (",",u) <- lex t,
                           (e2,v)  <- rp1 0 u,
                           (",",w) <- lex v,
                           (e3,x)  <- rp2 0 w,
                           (")",y) <- lex x]

instance Show a => Show2 ((,,) a) where
    liftShowsPrec2 sp1 _ sp2 _ _ (x1,y1,y2)
        = showChar '(' . showsPrec 0 x1
        . showChar ',' . sp1 0 y1
        . showChar ',' . sp2 0 y2
        . showChar ')'

instance (Eq a, Eq b) => Eq1 ((,,) a b) where
    liftEq = liftEq2 (==)

instance (Ord a, Ord b) => Ord1 ((,,) a b) where
    liftCompare = liftCompare2 compare

instance (Read a, Read b) => Read1 ((,,) a b) where
    liftReadsPrec = liftReadsPrec2 readsPrec readList

instance (Show a, Show b) => Show1 ((,,) a b) where
    liftShowsPrec = liftShowsPrec2 showsPrec showList

instance (Eq a, Eq b) => Eq2 ((,,,) a b) where
    liftEq2 e1 e2 (u1, u2, x1, y1) (v1, v2, x2, y2) =
        u1 == v1 &&
        u2 == v2 &&
        e1 x1 x2 && e2 y1 y2

instance (Ord a, Ord b) => Ord2 ((,,,) a b) where
    liftCompare2 comp1 comp2 (u1, u2, x1, y1) (v1, v2, x2, y2) =
        compare u1 v1 `mappend`
        compare u2 v2 `mappend`
        comp1 x1 x2 `mappend` comp2 y1 y2

instance (Read a, Read b) => Read2 ((,,,) a b) where
    liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r ->
        [((e1,e2,e3,e4), s9) | ("(",s1) <- lex r,
                               (e1,s2)  <- readsPrec 0 s1,
                               (",",s3) <- lex s2,
                               (e2,s4)  <- readsPrec 0 s3,
                               (",",s5) <- lex s4,
                               (e3,s6)  <- rp1 0 s5,
                               (",",s7) <- lex s6,
                               (e4,s8)  <- rp2 0 s7,
                               (")",s9) <- lex s8]

instance (Show a, Show b) => Show2 ((,,,) a b) where
    liftShowsPrec2 sp1 _ sp2 _ _ (x1,x2,y1,y2)
        = showChar '(' . showsPrec 0 x1
        . showChar ',' . showsPrec 0 x2
        . showChar ',' . sp1 0 y1
        . showChar ',' . sp2 0 y2
        . showChar ')'

instance (Eq a, Eq b, Eq c) => Eq1 ((,,,) a b c) where
    liftEq = liftEq2 (==)

instance (Ord a, Ord b, Ord c) => Ord1 ((,,,) a b c) where
    liftCompare = liftCompare2 compare

instance (Read a, Read b, Read c) => Read1 ((,,,) a b c) where
    liftReadsPrec = liftReadsPrec2 readsPrec readList

instance (Show a, Show b, Show c) => Show1 ((,,,) a b c) where
    liftShowsPrec = liftShowsPrec2 showsPrec showList

{- $example
These functions can be used to assemble 'Read' and 'Show' instances for
new algebraic types.  For example, given the definition

> data T f a = Zero a | One (f a) | Two a (f a)

a standard 'Read1' instance may be defined as

> instance (Read1 f) => Read1 (T f) where
>     liftReadsPrec rp rl = readsData $
>         readsUnaryWith rp "Zero" Zero `mappend`
>         readsUnaryWith (liftReadsPrec rp rl) "One" One `mappend`
>         readsBinaryWith rp (liftReadsPrec rp rl) "Two" Two

and the corresponding 'Show1' instance as

> instance (Show1 f) => Show1 (T f) where
>     liftShowsPrec sp _ d (Zero x) =
>         showsUnaryWith sp "Zero" d x
>     liftShowsPrec sp sl d (One x) =
>         showsUnaryWith (liftShowsPrec sp sl) "One" d x
>     liftShowsPrec sp sl d (Two x y) =
>         showsBinaryWith sp (liftShowsPrec sp sl) "Two" d x y

-}

max_stars_repo_name: ekmett/transformers-compat

max_issues_repo_name: ekmett/transformers-compat

max_forks_repo_name: ekmett/transformers-compat


text:
module AutomatedReviewAnalyzerSpec where

import Numeric.LinearAlgebra as LA
import AutomatedReviewAnalyzer
import SentimentAnalysis
import Test.Hspec

theta :: Vector R
theta = LA.vector [1.0, 1.0]

spec :: Spec
spec = do
  describe "Classify" $ do

    it "Classify 1" $ do
      let x = (3><2) [1.0, 1.0, 1.0, 1.0, 1.0, 1.0]
          theta0 = 0
          m = classify x theta theta0
      m `shouldBe` LA.vector [1.0, 1.0, 1.0]

    it "Classify 2" $ do
      let x = (1><2) [-1.0, 1.0]
          theta = LA.vector [1.0, 1.0]
          theta0 = 0
          m = classify x theta theta0
      m `shouldBe` LA.vector [-1.0]

  describe "Classifier Accuracy 1" $ do

    it "Accuracy 1" $ do
      let x1 = (3><2) [1.0, 0, 1.0, -1.0, 2.0, 3.0]
          x1' = (2><2) [1.0, 1.0, 2.0, -1.0]
          y1 = LA.vector [1.0, -1.0, 1.0]
          y1' = LA.vector [-1.0, 1.0]
          t1 = 1
          m =  classifierAccuracy perceptron x1 x1' y1 y1' t1 [1, 2, 0]
      m `shouldBe` (1.0, 0.0)

    it "Accuracy 2" $ do
      let x2 = (3><2) [1.0, 0, 1.0, -1.0, 2.0, 3.0]
          x2' = (2><2) [1.0, 1.0, 2.0, -1.0]
          y2 = LA.vector [1.0, -1.0, 1.0]
          y2' = LA.vector [-1.0, 1.0]
          t2 = 1
          lambda = 0.2
          m =  classifierAccuracy' pegasos x2 x2' y2 y2' t2 lambda [1, 2, 0]
      m `shouldBe` (1.0, 0.0)


text:
module Math.FROG.Types
( Nonlinearity(..)
, ComplexSignal
, Trace
) where

import qualified Numeric.LinearAlgebra as LA

type ComplexSignal = LA.Vector (LA.Complex Double)
type Trace = LA.Matrix Double

data Nonlinearity = PG | SHG | SD | THG

max_stars_repo_name: leroix/haskell-spsa-frog

max_issues_repo_name: leroix/haskell-spsa-frog

max_forks_repo_name: leroix/haskell-spsa-frog


text:
{- |
Module      :  Numeric.Information.Model.IT
Description :  Information quantities on models
Copyright   :  (c) Malte Harder
License     :  MIT

Maintainer  :  malte.harder@gmail.com
Stability   :  experimental
Portability :  portable

-}

module Numeric.Information.Model.IT
       (
         -- * Entropy & Mutual Information
         nodeEntropy
       , nodeCondEntropy
       , nodeMutualInfo
       , nodeCondMutualInfo
         -- * Specific Information
       , nodeSpecificInformation
       , nodeMinimalInformation
         -- * Partial Information Decomposition
         -- ** Data Types
       , PINode (..)
       , PILattice
         -- ** Functions
       , piDecomp
         -- ** Helper Functions
       , piLattice
       , piSet
       , (-<<)
       , (-<=)
       , subset
         -- * Information Flow
       , nodeInformationFlow
       ) where

import Numeric.Information.Model

import Numeric.Information.Distribution
import Numeric.Information.IT

import Data.Graph.Inductive
import Data.List

--import Statistics.Math hiding(log2)
import Numeric.SpecFunctions hiding(log2)

nodeEntropy :: (Floating prob, Ord prob, Ord a)
               => [String]
               -> ModelDistribution prob a
               -> prob
nodeEntropy v m = (entropy . extract) (marginalize v m)

nodeCondEntropy :: (Floating prob, Ord prob, Ord a)
                   => [String]
                   -> [String]
                   -> ModelDistribution prob a
                   -> prob
nodeCondEntropy yv xv m =
  let p_ygx = extractC $ conditionalize yv xv m
      p_x = extract $ marginalize xv m
  in condEntropy p_ygx p_x

nodeMutualInfo :: (Floating prob, Ord prob, Ord a)
                   => [String]
                   -> [String]
                   -> ModelDistribution prob a
                   -> prob
nodeMutualInfo yv xv m =
  let p_ygx = extractC $ conditionalize yv xv m
      p_x = extract $ marginalize xv m
  in mutualInfo p_ygx p_x

nodeCondMutualInfo :: (Floating prob, Ord prob, Ord a)
                      => [String]
                      -> [String]
                      -> [String]
                      -> ModelDistribution prob a
                      -> prob
nodeCondMutualInfo yv xv zv m =
  let p_xgz = extractC $ conditionalize xv zv m
      p_xgyz = \(y,z) -> (extractC $ conditionalize xv (yv++zv) m) $ y ++ z
      p_z = extract $ marginalize zv m
      p_ygz = extractC $ conditionalize yv zv m
  in condMutualInfo p_xgz p_xgyz p_z (p_ygz -|- p_z)

nodeSpecificInformation :: (Floating prob, Ord prob, Ord a)
                           => [String]
                           -> [a]
                           -> [String]
                           -> ModelDistribution prob a
                           -> prob
nodeSpecificInformation sv s av m =
  let p_s = (extract $ marginalize sv m) ?= s
      p_ags = (extractC $ conditionalize av sv m) s
      p_sga = (extractC $ conditionalize sv av m)
  in expected p_ags (\a-> log2 ((p_sga a) ?= s / p_s))

nodeMinimalInformation :: (Floating prob, Ord prob, Ord a)
                           => [String]
                           -> [[String]]
                           -> ModelDistribution prob a
                           -> prob
nodeMinimalInformation  sv avs m =
  let p_s = (extract $ marginalize sv m)
  in expected p_s (\s -> minimum $
                         map (\av -> nodeSpecificInformation sv s av m) avs)

nodeMaxMinimalInformation :: (Floating prob, Ord prob, Ord a)
                           => [String]
                           -> [[[String]]]
                           -> ModelDistribution prob a
                           -> prob
nodeMaxMinimalInformation sv avss m =
  let p_s = (extract $ marginalize sv m)
  in expected p_s (\s -> maximum' $
                         map (\avs -> minimum $
                                      map (\av -> nodeSpecificInformation sv s av m)
                                      avs) avss)

nodeInformationFlow :: (Floating prob, Ord prob, Ord a)
                       => [String]
                       -> [String]
                       -> Model prob a
                       -> prob
nodeInformationFlow as bs m = undefined

maximum' [] = 0
maximum' xs = maximum xs

data PINode prob a = PINode { partial :: [[a]]
                            , value :: prob
                            } deriving (Eq)

instance (Show a, Show prob) => Show (PINode prob a) where
  show n = (intercalate "," $
            map (\xs -> (intercalate " & " (map (trim . show . show) xs))) $ partial n)
           ++ " = "++ (show $ value n)

trim = reverse . tail . reverse . tail

type PILattice prob a = Gr (PINode prob a) ()

piDecomp :: (Floating prob, Ord prob, Ord a)
            => [String]
            -> [String]
            -> ModelDistribution prob a
            -> PILattice prob String
piDecomp s as m =
  let g  = piLattice as
      g' = nmap minimalInformation g
  in gmap (subtractLower g') g'
  where minimalInformation piN =
          piN { value = (nodeMinimalInformation s (partial piN) m)}
        subtractLower g' (inA, n, piN, outA) =
          (inA,
           n,
           piN { value = (value piN) -
                         (nodeMaxMinimalInformation s
                          (map (partial . snd) $ filter
                          (\(n',piN') -> (n',n) `elem` (edges g') ) $ labNodes g')
                          m )} ,
           outA)

piLattice :: (Eq a, Fractional prob) => [a] -> PILattice prob a
piLattice modelNodes =
  let nodes = autoLabel $ map (\n -> PINode { partial = n, value = 0 })
              $ piSet modelNodes
      size = (length nodes)-1
      edges = [ (i,j,()) | i <- [0..size], j <- [0..size],
                i /= j && -- Reflexive reduction
                (partial $ snd $ nodes !! i) -<= (partial $ snd $ nodes !! j) ]
      compositionEdges = [ (i,k,()) | (i,j,()) <- edges, k <- [0..size],
                               (j,k,()) `elem` edges]
      reducedEdges = edges \\ compositionEdges
  in mkGraph nodes reducedEdges

piSet :: (Eq a) => [a] -> [[[a]]]
piSet r = [ a | a <- (powerset' . powerset') r,
          (null [ a | x <- a, y <- a,
                  x /= y &&
                  (length x <= length y) && (subset x y)])]

muSet :: (Eq a) => Int -> [a] -> [([[a]], Double)]
muSet k ls =
  let r = piSet ls
      p = powerset' ls
      n = length ls
  in map (\beta -> (beta, (fromIntegral n)/(fromIntegral k) * (esoohc n k) * (fromIntegral $ length $
                           filter (\a -> length a == k && beta -<= [a]) p) - 1 ) ) r

muSet' :: (Eq a) => [a] -> [([[a]], Double)]
muSet' ls =
  let r = piSet ls
      p = powerset' ls
      n = length ls
  in map (\beta ->
           (beta,
            (sum [ (esoohc n k)  * ( fromIntegral
                    $ (length $ filter
                   (\a -> length a == k && beta -<= [a]) p)) - (fromIntegral k)/(fromIntegral n)
                 | k <- [1 .. (n-1)] ] ) ) ) r

esoohc :: Int -> Int -> Double
esoohc n k = 1.0 / (n `choose` k)

(-<<) :: (Eq a) => [[a]] -> [[a]] -> Bool
(-<<) a b = (a -<= b) && (a /= b)

(-<=) :: (Eq a) => [[a]] -> [[a]] -> Bool
(-<=) a b = foldr q True b
  where q bel cur = cur && (not . null $ filter (\ael -> subset ael bel)  a )

subset :: (Eq a) => [a] -> [a] -> Bool
subset a b = foldr q True a
  where q el cur = cur && (elem el b)

powerset' :: [a] -> [[a]]
powerset' = tail . powerset

powerset       :: [a] -> [[a]]
powerset []     = [[]]
powerset (x:xs) = xss /\/ map (x:) xss
  where xss = powerset xs

(/\/)        :: [a] -> [a] -> [a]
[]     /\/ ys = ys
(x:xs) /\/ ys = x : (ys /\/ xs)


text:
module Ray where

import Numeric.Vector
import Numeric.Scalar
import Types
import Object.Tri (asList)

createHit :: Object -> Tri -> Ray -> Double -> (Double, Double, Double) -> Vec3d -> RayHit
createHit obj tri ray dist (a, b, c) pos = let abc3 = map (fromScalar . scalar) [a, b, c] :: [Vec3d]
                                               abc2 = map (fromScalar . scalar) [a, b, c] :: [Vec2d]
                                               tex = sum $ zipWith (*) abc2 $ map v_getTexCoord $ asList tri
                                               normal = sum $ zipWith (*) abc3 $ map v_getNormal $ asList tri
                                               tangent = sum $ zipWith (*) abc3 $ map v_getTangent $ asList tri
                                               bitangent = tangent × normal
                                               color = sum $ zipWith (*) abc3 $ map v_getColor $ asList tri

                                           in  RayHit { rh_getPos = pos
                                                      , rh_getRay = ray
                                                      , rh_getDistance = dist
                                                      , rh_getTri = tri
                                                      , rh_getObj = obj
                                                      , rh_getShader = o_getShader obj
                                                      , rh_getTexCoord = tex
                                                      , rh_getNormal = normal
                                                      , rh_getTangent = tangent
                                                      , rh_getBitangent = bitangent
                                                      , rh_getColor = color
                                                      }


text:
module Typed(
    typed,

    testPropertyI,
    testPropertyD,
    testPropertyZ,
    testPropertyDZ,

    immutableVector,
    immutableMatrix,
    ) where

import Data.Complex( Complex )
import Test.Framework
import Test.Framework.Providers.QuickCheck2
import Test.QuickCheck

import Numeric.LinearAlgebra.Vector( Vector )
import Numeric.LinearAlgebra.Matrix( Matrix )

typed :: e -> a e -> a e
typed _ = id

immutableVector :: Vector e -> Vector e
immutableVector = id

immutableMatrix :: Matrix e -> Matrix e
immutableMatrix = id

testPropertyI :: (Testable a)
              => TestName
              -> (Int -> a)
              -> Test
testPropertyI str prop =
    testProperty str $ prop undefined

testPropertyDZ :: (Testable a, Testable b)
               => TestName
               -> (Double -> a)
               -> (Complex Double -> b)
               -> Test
testPropertyDZ str propd propz =
    testGroup str
        [ testProperty "Double" $ propd undefined
        , testProperty "Complex Double" $ propz undefined
        ]

testPropertyD :: (Testable a)
              => TestName
              -> (Double -> a)
              -> Test
testPropertyD str prop =
    testProperty str $ prop undefined

testPropertyZ :: (Testable a)
              => TestName
              -> (Complex Double -> a)
              -> Test
testPropertyZ str prop =
    testProperty str $ prop undefined

max_stars_repo_name: patperry/hs-linear-algebra

max_issues_repo_name: cartazio/hs-cblas

max_forks_repo_name: cartazio/hs-cblas


text:
module AI.Learning.CrossValidation where

import Control.Monad.Random
import Foreign.Storable (Storable)
import Numeric.LinearAlgebra
import qualified Data.List as L

import AI.Util.Matrix
import AI.Util.Util

----------------------
-- Cross Validation --
----------------------

class Indexable c where
    index :: c -> Index -> c
    nobs :: c -> Int

instance Storable a => Indexable (Vector a) where
    index = subRefVec
    nobs = dim

instance Element a => Indexable (Matrix a) where
    index = subRefRows
    nobs = rows

instance Indexable [a] where
    index = map . (!!)
    nobs = length

-- |Indexes are lists of 'Int'. Should refactor this to use something more
--  efficient.
type Index  = [Int]

-- |Type for cross-validation partition.
data CVPartition = CVPartition [(Index, Index)]

-- |Specify what type of cross-validation you want to do.
data CVType = LeaveOneOut
            | KFold Int

-- |Prediction function. A prediction function should take a training and a test
--  set, and use the training set to build a model whose performance is
--  evaluated on the test set, returning a final score as a 'Double'.
type PredFun a b = a        -- Training set predictors
                -> b        -- Training set target
                -> a        -- Test set predictors
                -> b        -- Test set target
                -> Double   -- Performance score

-- |Create a partition into test and training sets.
cvPartition :: RandomGen g => Int -> CVType -> Rand g CVPartition
cvPartition sz cvtype = case cvtype of
    KFold i     -> cvp sz i
    LeaveOneOut -> cvp sz sz

-- |Helper function for 'cvPartition'.
cvp :: RandomGen g => Int -> Int -> Rand g CVPartition
cvp n k = do
    is <- go i (k - i) idx
    return . CVPartition $ map (\i -> (idx L.\\ i, i)) is
    where
        go 0 0 idx = return []

        go 0 j idx = do
            (is, idx') <- selectMany' s idx
            iss        <- go 0 (j-1) idx'
            return (is:iss)

        go i j idx = do
            (is, idx') <- selectMany' (s+1) idx
            iss        <- go (i-1) j idx'
            return (is:iss)

        s   = n `div` k
        i   = n `mod` k
        idx = [0 .. n-1]

-- |Perform k-fold cross-validation. Given a 'CVPartition' containing a list
--  of training and test sets, we repeatedly fit a model on the training set
--  and test its performance on the test set/
kFoldCV_ :: (Indexable a, Indexable b) =>
            CVPartition
         -> PredFun a b
         -> a
         -> b
         -> [Double]
kFoldCV_ (CVPartition partition) predfun x y = map go partition
    where
        go (trainIdx,testIdx) = predfun xTrain yTrain xTest yTest
            where
                xTrain = x `index` trainIdx
                yTrain = y `index` trainIdx
                xTest  = x `index` testIdx
                yTest  = y `index` testIdx

-- |Perform k-fold cross-validation, randomly generating the training and
--  test sets first.
kFoldCV :: (RandomGen g, Indexable a, Indexable b) =>
           CVType           -- What type of cross-validation?
        -> PredFun a b      -- Prediction function
        -> a                -- Predictors
        -> b                -- Targets
        -> Rand g [Double]  -- List of scores
kFoldCV cvtype predfun x y = if nobs x /= nobs y
    then error "Inconsistent dimensions -- KFOLDCV"
    else do
        cp <- cvPartition (nobs x) cvtype
        return (kFoldCV_ cp predfun x y)

---------------
-- Old Stuff --
---------------

-- |Model builder. A model builder takes a training set of regressors and
--  targets, and constructs a function that makes predictions from an out-
--  of-sample set of regressors.
type ModelBuilder = Matrix Double   -- Training set regressors
                 -> Vector Double   -- Training set target
                 -> Matrix Double   -- Out-of-sample regressors
                 -> Vector Double   -- Predictions

-- |Evaluation function. An evaluation function takes a vector of targets and
--  a vector of predictions, and returns a score corresponding to how closely
--  the predictions match the target.
type EvalFun = Vector Double    -- Target
            -> Vector Double    -- Predictions
            -> Double           -- Score (e.g. MSE, MCR, likelihood)

max_stars_repo_name: cagix/aima-haskell


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

Various helpful utilities.
-}

module MachineLearning.Utils
(
  reduceByRowsV
  , reduceByColumnsV
  , reduceByRows
  , reduceByColumns
  , sumByRows
  , sumByColumns
  , listOfTuplesToList
)

where

import MachineLearning.Types (R, Vector, Matrix)
import qualified Data.Vector.Storable as V
import qualified Numeric.LinearAlgebra as LA

reduceByRowsV :: (Vector -> R) -> Matrix -> Vector
reduceByRowsV f = LA.vector . map f . LA.toRows

reduceByColumnsV :: (Vector -> R) -> Matrix -> Vector
reduceByColumnsV f = LA.vector . map f . LA.toColumns

reduceByRows :: (Vector -> R) -> Matrix -> Matrix
reduceByRows f = LA.asColumn . reduceByRowsV f

reduceByColumns :: (Vector -> R) -> Matrix -> Matrix
reduceByColumns f = LA.asRow . reduceByColumnsV f

sumByColumns :: Matrix -> Matrix
sumByColumns = reduceByColumns V.sum

sumByRows :: Matrix -> Matrix
sumByRows = reduceByRows V.sum

-- | Converts list of tuples into list.
listOfTuplesToList :: [(a, a)] -> [a]
listOfTuplesToList [] = []
listOfTuplesToList ((a, b):xs) = a : b : listOfTuplesToList xs

max_stars_repo_name: aligusnet/mltool

max_issues_repo_name: aligusnet/mltool

max_forks_repo_name: aligusnet/mltool