text:
module Main where

import Data.Monoid
import Options.Applicative.Simple

import Statistics
import Convert

-- | Helper for lifting pure parsing functions into ReadM monad
readMPure :: String -- ^ Name of argument for pretty error message
  -> (String -> Maybe a) -- ^ Function that parses the argument
  -> ReadM a -- ^ Optparse parser monad
readMPure desc f = do
  s <- str
  case f s of
    Nothing -> fail $ "Unknown " ++ desc ++ " " ++ s
    Just v -> return v

-- | How to parse ConvertFormat
convertFormatR :: ReadM ConvertFormat
convertFormatR = readMPure "format" readConvertFormat

-- | How to parse BlpFormat
blpFormatR :: ReadM BlpFormat
blpFormatR = readMPure "blp format" readBlpFormat

main :: IO ()
main = do
  (_,runCmd) <- simpleOptions ver headerDesc desc (pure ()) $ do
    addCommand "convert" "Converts given blp or folder with blps to PNG" convertFiles $ (<*>) helper $ ConvertOptions
      <$> strArgument (metavar "INPUT_PATH" <> help "input file or directory (batch mode)")
      <*> strArgument (metavar "OUTPUT_PATH" <> help "output file name or directory (need explicit format option)")
      <*> option convertFormatR (long "input-format" <> short 'i' <> value UnspecifiedFormat <> help "Input file format, if not specified tries to infer from input file name. Values: blp png jpg tiff gif bmp.")
      <*> option convertFormatR (long "format" <> short 'f' <> value UnspecifiedFormat <> help "Output file format, if not specified tries to infer from output file name. Values: blp png jpg tiff gif bmp.")
      <*> option auto (long "quality" <> short 'q' <> value 90 <> help "Quality level for formats with lossy compression (default 90)")
      <*> fmap not (switch (long "notPreserveStructure" <> short 'p' <> help "Will not produce subfolders while batch converting" ))
      <*> switch (long "shallow" <> short 's' <> help "Not look into subfolders while batch converting")
      <*> option blpFormatR (long "blpFormat" <> short 'b' <> value BlpJpeg <> help "Specifies what BLP internal format to use when converting to BLP. Values: jpg uncompressedWithAlpha uncompressedWithoutAlpha")
      <*> option auto (long "min-mipmap-size" <> value 1 <> help "Minimum size of mimmap side to include in resulted BLP file")
    addCommand "stats" "Collects statistics about BLP images in folder and saves examples of BLP's for each sample" (uncurry collectStatistics) $ (<*>) helper $ (,)
      <$> strArgument (metavar "DIRECTORY" <> help "Input folder that stores blps (subfolders are processed)")
      <*> strArgument (metavar "OUTPUT_PATH" <> help "Here blp samples would be stored")
  runCmd
  where
    ver = "0.1.0.0"
    headerDesc = ""
    desc = "Converting BLP1 Warcraft III format to/from PNG, JPEG, TGA, TIFF, BMP, GIF"

max_stars_repo_name: NCrashed/JuicyPixels-blp

max_issues_repo_name: NCrashed/JuicyPixels-blp

max_forks_repo_name: NCrashed/JuicyPixels-blp


text:
{-# LANGUAGE ConstraintKinds #-}

module HashedExpression.Internal.Expression
  ( R,
    C,
    Covector,
    ET (..),
    Node (..),
    Internal,
    NodeID,
    ExpressionMap,
    Expression (..),
    Scalar,
    Dimension,
    ToShape (..),
    DimensionType,
    ElementType,
    NumType,
    VectorSpace,
    InnerProductSpace,
    PowerOp (..),
    PiecewiseOp (..),
    VectorSpaceOp (..),
    FTOp (..),
    ComplexRealOp (..),
    RotateOp (..),
    Shape,
    RotateAmount,
    Arg,
    Args,
    BranchArg,
    ConditionArg,
    InnerProductSpaceOp (..),
  )
where

import Data.Array
import qualified Data.Complex as DC
import Data.IntMap (IntMap)
import qualified Data.IntMap.Strict as IM
import Data.Proxy (Proxy (..))
import Data.Typeable (Typeable, typeRep)
import GHC.TypeLits (KnownNat, Nat, natVal)
import Prelude hiding ((^))

-- | Type representation of elements in the 1D, 2D, 3D, ... grid
data R
  deriving (NumType, ElementType, Typeable)

data C
  deriving (NumType, ElementType, Typeable)

data Covector
  deriving (ElementType, Typeable)

-- | Type representation of vector dimension
data Scalar
  deriving (Dimension, Typeable)

-- |
instance (KnownNat n) => Dimension n

instance (KnownNat m, KnownNat n) => Dimension '(m, n)

instance (KnownNat m, KnownNat n, KnownNat p) => Dimension '(m, n, p)

-- | Classes as constraints
class ElementType et

class ElementType et => NumType et

-------------------------------------------------------------------------------
class
  (Dimension d) =>
  ToShape d where
  toShape :: Proxy d -> Shape

instance ToShape Scalar where
  toShape _ = []

instance (KnownNat n) => ToShape n where
  toShape _ = [nat @n]

instance (KnownNat m, KnownNat n) => ToShape '(m, n) where
  toShape _ = [nat @m, nat @n]

instance (KnownNat m, KnownNat n, KnownNat p) => ToShape '(m, n, p) where
  toShape _ = [nat @m, nat @n, nat @p]

type DimensionType d = (Dimension d, ToShape d)

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

-- |
nat :: forall n. (KnownNat n) => Int
nat = fromIntegral $ natVal (Proxy :: Proxy n)

-------------------------------------------------------------------------------
class Dimension d

class VectorSpace d et s

class VectorSpace d s s => InnerProductSpace d s

instance (DimensionType d, ElementType et) => VectorSpace d et R

instance (DimensionType d) => VectorSpace d C C

instance VectorSpace d s s => InnerProductSpace d s

-- | Classes for operations so that both Expression and Pattern (in HashedPattern) can implement
class PowerOp a b | a -> b where
  (^) :: a -> b -> a

class VectorSpaceOp a b where
  scale :: a -> b -> b
  (*.) :: a -> b -> b
  (*.) = scale

class ComplexRealOp r c | r -> c, c -> r where
  (+:) :: r -> r -> c
  xRe :: c -> r
  xIm :: c -> r

class InnerProductSpaceOp a b c | a b -> c where
  (<.>) :: a -> b -> c

class RotateOp k a | a -> k where
  rotate :: k -> a -> a

class PiecewiseOp a b where
  piecewise :: [Double] -> a -> [b] -> b

class FTOp a b | a -> b where
  ft :: a -> b

infixl 6 +:

infixl 8 *., `scale`, <.>

infixl 8 ^

-- | Shape type:
-- []        --> scalar
-- [n]       --> 1D with size n
-- [n, m]    --> 2D with size n × m
-- [n, m, p] --> 3D with size n × m × p
type Shape = [Int]

-- | Args - list of indices of arguments in the ExpressionMap
type Args = [NodeID]

type Arg = NodeID

type ConditionArg = NodeID

type BranchArg = NodeID

-- | Rotation in each dimension.
-- | Property:  the length of this must match the dimension of the data
type RotateAmount = [Int]

-- | Data representation of element type
data ET
  = R
  | C
  | Covector
  deriving (Show, Eq, Ord)

-- | Internal
-- Shape: Shape of the expression
-- we can reconstruct the type of the Expression
type Internal = (Shape, Node)

-- | Hash map of all subexpressions
type ExpressionMap = IntMap Internal

-- | The index/key to look for the node on the hash table
type NodeID = Int

-- | Expression with 2 phantom types (dimension and num type)
data Expression d et
  = Expression
      { exRootID :: Int, -- the index this expression
        exMap :: ExpressionMap -- all subexpressions
      }
  deriving (Show, Eq, Ord, Typeable)

type role Expression nominal nominal -- So the users cannot use Data.Coerce.coerce to convert between expression types

-- | Node type
data Node
  = Var String
  | DVar String -- only contained in **Expression d Covector (1-form)**
  | Const Double -- only all elements the same
      -- MARK: Basics
  | Sum ET Args -- element-wise sum
  | Mul ET Args -- multiply --> have different meanings (scale in vector space, multiplication, ...)
  | Power Int Arg
  | Neg ET Arg
  | Scale ET Arg Arg
  | -- MARK: only apply to R
    Div Arg Arg -- TODO: Delete?
  | Sqrt Arg
  | Sin Arg
  | Cos Arg
  | Tan Arg
  | Exp Arg
  | Log Arg
  | Sinh Arg
  | Cosh Arg
  | Tanh Arg
  | Asin Arg
  | Acos Arg
  | Atan Arg
  | Asinh Arg
  | Acosh Arg
  | Atanh Arg
  | -- MARK: Complex related
    RealImag Arg Arg -- from real and imagine
  | RealPart Arg -- extract real part
  | ImagPart Arg -- extract imaginary part
      -- MARK: Inner product Space
  | InnerProd ET Arg Arg
  | -- MARK: Piecewise
    Piecewise [Double] ConditionArg [BranchArg]
  | Rotate RotateAmount Arg
  | -- MARK: Discrete Fourier Transform
    ReFT Arg
  | ImFT Arg
  | -- Need these inside because taking real of FT twice can be very fast
    TwiceReFT Arg
  | TwiceImFT Arg
  deriving (Show, Eq, Ord)

ext: hs

max_stars_repo_name: Turboscient/HashedExpression

max_issues_repo_name: Turboscient/HashedExpression

max_forks_repo_name: Turboscient/HashedExpression


text:
module Main where

import RayLib
import Numeric.LinearAlgebra
import qualified Graphics.Image as G

main :: IO ()
main = do let screen = Screen 256 256
          let ka = MatParam (fromList [0,1,1])
          let ks = MatParam (fromList [1,1,0])
          let kd = MatParam (fromList [0.4,0.4,0])
          let ke = MatParam (fromList [0,0,0])
          let kr = MatParam (fromList [0,0,0])
          let kt = MatParam (fromList [0,0,0])
          let shininess = 64
          let material = Material ka ks kd ke kr kt shininess
          let sphere1 = Sphere (fromList [0,0,0]) 1.5 material
          let scene = Scene [] [sphere1] (fromList [1,0,0.1])
          putStrLn . show $ scene
          let camera = Camera (fromList [0,0,-4]) (fromList [0,0,1]) (fromList [0,1,0]) 1 90
          putStrLn . show $ camera
          putStrLn . show $ screen
          let image = traceImage scene screen camera
          let toWrite = render image
          G.writeImage "test.png" toWrite


text:
{-# LANGUAGE FlexibleInstances #-}
import Data.Complex
import Data.Numeric.Function
import Graphics.Gnuplot.Simple

-- the physical constant are too small and creates rounding errors
l=1.0e-11
h=6.62606957e-34
m=9.10938188e-31
ts = [0.00,0.01e-19..0.60e-19]

e :: Complex Double -> Complex Double
e n = n^2 * h^2 * pi^2 / (2 * m * l^2)

k :: Complex Double -> Complex Double
k n = n*pi/l

w :: Complex Double -> Complex Double
w n = (e n)/h

a :: Complex Double
a = sqrt(2/l)

img :: Complex Double
img = 0 :+ 1

eexp :: Complex Double -> Complex Double
eexp c = (mkComp (2.7182818**(realPart c))) * ((cos (imagPart c)) :+ (sin (imagPart c)))

psi :: Complex Double -> Double -> Complex Double -> Complex Double
psi n t x = a * sin((k n) * x) * (eexp (-img*(w n)*(t:+0)))

nums = map (\x -> x :+ 0) [1..3]

psis = (1/(sqrt . fromIntegral $ (length nums))) * sum $ map psi nums

sans = (^2) . psis

mkComp x = x :+ 0

y :: [[[Double]]]
y = map (\gress -> [map magnitude gress, map realPart gress, map imagPart gress]) funcs
  where xs = map mkComp (linearScale 300 (0, realPart l))
        funcs :: [[Complex Double]]
        funcs = map (\t -> map (sans t) xs) ts

-- | dirty string format
gress :: Int -> String
gress i
  | i < 10 = "00" ++ show i
  | i < 100 = "0" ++ show i
  | otherwise = show i

onePlot :: [[Double]] -> Int -> IO ()
--onePlot ys i = plotLists ([PNG ("/tmp/kvantePNG" ++ gress i ++ ".png")]) ys
onePlot ys i = plotLists ([YRange (-5.0e11,5.0e11), PNG ("/tmp/kvantePNG" ++ gress i ++ ".png")]) ys
--onePlot ys i = plotLists ([YRange (-3,3), PNG ("/tmp/kvantePNG" ++ gress i ++ ".png")]) ys

fun :: (Int, [[Double]]) -> IO ()
fun (i,ys) = onePlot ys i

jazz :: [(Int, [[Double]])]
jazz = zip [1..] y

main = mapM fun jazz

max_stars_repo_name: molysgaard/kvante

max_issues_repo_name: molysgaard/kvante

max_forks_repo_name: molysgaard/kvante


text:
{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE TypeFamilies        #-}

--
-- Note: Input files can be downloaded at https://www.kaggle.com/scolianni/mnistasjpg
--
--
-- This is a simple generative adversarial network to make pictures
-- of numbers similar to those in MNIST.
--
-- It demonstrates a different usage of the library. Within about 15
-- minutes it was producing examples like this:
--
--               --.
--     .=-.--..#=###
--     -##==#########.
--     #############-
--   -###-.=..-.-==
--   ###-
--   .###-
--   .####...==-.
--   -####=--.=##=
--   -##=-     -##
--             =##
--           -##=
--           -###-
--         .####.
--         .#####.
-- ...---=#####-
-- .=#########.         .
--   .#######=.          .
--     . =-.
--
-- It's a 5!
--
import           Control.Applicative
import           Control.DeepSeq
import           Control.Monad
import           Control.Monad.Random
import           Control.Monad.Trans.Except

import qualified Data.Attoparsec.Text         as A
import qualified Data.ByteString              as B
import           Data.List                    (foldl')
import           Data.Serialize
import qualified Data.Text                    as T
import qualified Data.Text.IO                 as T
import qualified Data.Vector.Storable         as V

import           Numeric.LinearAlgebra.Data   (toLists)
import qualified Numeric.LinearAlgebra.Static as SA

import           Options.Applicative

import           Grenade
import           Grenade.Utils.OneHot

type Discriminator =
  Network
    '[ Convolution 'WithoutBias 'NoPadding 1 10 5 5 1 1, Pooling 2 2 2 2, Relu
     , Convolution 'WithoutBias 'NoPadding 10 16 5 5 1 1, Pooling 2 2 2 2, Relu
     , Reshape, FullyConnected 256 80, Logit, FullyConnected 80 1, Logit]
    '[ 'D2 28 28
     , 'D3 24 24 10, 'D3 12 12 10, 'D3 12 12 10
     , 'D3 8 8 16, 'D3 4 4 16, 'D3 4 4 16
     , 'D1 256, 'D1 80, 'D1 80, 'D1 1, 'D1 1]

type Generator =
  Network
    '[ FullyConnected 80 256, Relu, Reshape
     , Deconvolution 16 10 5 5 2 2, Relu
     , Deconvolution 10 1 8 8 2 2, Logit]
    '[ 'D1 80
     , 'D1 256, 'D1 256, 'D3 4 4 16
     , 'D3 11 11 10, 'D3 11 11 10
     , 'D2 28 28, 'D2 28 28 ]

randomDiscriminator :: IO Discriminator
randomDiscriminator = randomNetwork

randomGenerator :: IO Generator
randomGenerator = randomNetwork

trainExample :: Optimizer opt -> Discriminator -> Generator -> S ('D2 28 28) -> S ('D1 80) -> ( Discriminator, Generator )
trainExample opt discriminator generator realExample noiseSource
 = let (generatorTape, fakeExample)       = runNetwork generator noiseSource

       (discriminatorTapeReal, guessReal) = runNetwork discriminator realExample
       (discriminatorTapeFake, guessFake) = runNetwork discriminator fakeExample

       (discriminator'real, _)            = runGradient discriminator discriminatorTapeReal ( guessReal - 1 )
       (discriminator'fake, _)            = runGradient discriminator discriminatorTapeFake guessFake
       (_, push)                          = runGradient discriminator discriminatorTapeFake ( guessFake - 1)

       (generator', _)                    = runGradient generator generatorTape push

       !newDiscriminator                   = force $ foldl' (applyUpdate $ sgdUpdateLearningParamters opt) discriminator [ discriminator'real, discriminator'fake ]
       !newGenerator                       = force $ applyUpdate opt generator generator'
   in ( newDiscriminator, newGenerator )
  where sgdUpdateLearningParamters :: Optimizer opt -> Optimizer opt
        sgdUpdateLearningParamters (OptSGD rate mom reg) = OptSGD rate mom (reg * 10)
        sgdUpdateLearningParamters o                     = o

ganTest :: (Discriminator, Generator) -> Int -> FilePath -> Optimizer opt -> ExceptT String IO (Discriminator, Generator)
ganTest (discriminator0, generator0) iterations trainFile opt = do
  !trainData      <- fmap fst <$> readMNIST trainFile

  lift $ foldM (runIteration trainData) ( discriminator0, generator0 ) [1..iterations]

    where

  showShape' :: S ('D2 a b) -> IO ()
  showShape' (S2D mm) = putStrLn $
    let m  = SA.extract mm
        ms = toLists m
        render n'  | n' <= 0.2  = ' '
                   | n' <= 0.4  = '.'
                   | n' <= 0.6  = '-'
                   | n' <= 0.8  = '='
                   | otherwise =  '#'

        px = (fmap . fmap) render ms
    in unlines px

  runIteration :: [S ('D2 28 28)] -> (Discriminator, Generator) -> Int -> IO (Discriminator, Generator)
  runIteration trainData ( !discriminator, !generator ) _ = do
    trained'    <- foldM ( \(!discriminatorX, !generatorX ) realExample -> do
                      trainExample opt discriminatorX generatorX realExample <$> randomOfShape
                     ) ( discriminator, generator ) trainData

    showShape' . snd . runNetwork (snd trained') =<< randomOfShape

    return trained'

data GanOpts = GanOpts FilePath Int Bool (Optimizer 'SGD) (Optimizer 'Adam) (Maybe FilePath) (Maybe FilePath)

mnist' :: Parser GanOpts
mnist' = GanOpts <$> argument str (metavar "TRAIN")
                 <*> option auto (long "iterations" <> short 'i' <> value 15)
                 <*> flag False True (long "use-adam" <> short 'a')
                 <*> (OptSGD
                       <$> option auto (long "train_rate" <> short 'r' <> value 0.01)
                       <*> option auto (long "momentum" <> value 0.9)
                       <*> option auto (long "l2" <> value 0.0005)
                       )
                 <*> (OptAdam
                       <$> option auto (long "alpha" <> short 'r' <> value 0.001)
                       <*> option auto (long "beta1" <> value 0.9)
                       <*> option auto (long "beta2" <> value 0.999)
                       <*> option auto (long "epsilon" <> value 1e-4)
                       <*> option auto (long "lambda" <> value 1e-3)
                      )
                 <*> optional (strOption (long "load"))
                 <*> optional (strOption (long "save"))

main :: IO ()
main = do
  GanOpts mnist iter useAdam sgd adam load save <- execParser (info (mnist' <**> helper) idm)
  putStrLn "Training stupidly simply GAN"
  nets0 <-
    case load of
      Just loadFile -> netLoad loadFile
      Nothing       -> (,) <$> randomDiscriminator <*> randomGenerator
  res <-
    if useAdam
      then runExceptT $ ganTest nets0 iter mnist adam
      else runExceptT $ ganTest nets0 iter mnist sgd
  case res of
    Right nets1 ->
      case save of
        Just saveFile -> B.writeFile saveFile $ runPut (put nets1)
        Nothing       -> return ()
    Left err -> putStrLn err

readMNIST :: FilePath -> ExceptT String IO [(S ('D2 28 28), S ('D1 10))]
readMNIST mnist = ExceptT $ do
  mnistdata <- T.readFile mnist
  return $ traverse (A.parseOnly parseMNIST) (tail $ T.lines mnistdata)

parseMNIST :: A.Parser (S ('D2 28 28), S ('D1 10))
parseMNIST = do
  Just lab <- oneHot <$> A.decimal
  pixels   <- many (A.char ',' >> A.double)
  image    <- maybe (fail "Parsed row was of an incorrect size") pure (fromStorable . V.fromList $ fmap realToFrac pixels)
  return (image, lab)

netLoad :: FilePath -> IO (Discriminator, Generator)
netLoad modelPath = do
  modelData <- B.readFile modelPath
  either fail return $ runGet (get :: Get (Discriminator, Generator)) modelData

max_stars_repo_name: th-char/grenade

max_issues_repo_name: th-char/grenade

max_forks_repo_name: th-char/grenade


text:
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}
module Data.GameObject where

import qualified Data.Vector.Storable as VS
import           Numeric.LinearAlgebra (Vector, Matrix, flatten, (<>), tr,(#>),(><))
import           Control.Lens      hiding (indices)
import           Number.Quaternion ((+::))
import qualified Graphics.Rendering.OpenGL.GL as GL
import           Graphics.Rendering.OpenGL.GL (($=))
import qualified Graphics.GL as GLRaw
import qualified Data.HashMap               as HM
import           Foreign.Ptr (intPtrToPtr, IntPtr(..))
import           Control.Arrow
import           Data.Maybe
import Data.Vector.Strategies
import GHC.Generics

import           Data.Mesh
import           Data.PhysicsData
import           Utils.Quaternions
import           Data.Shaders
import           Physics.Collision

import           Utils (posToMat,posToMatV,glTexture,pointAt)

data GameObject = GameObject {
  _mesh     :: Mesh,
  _location :: Vector Float,
  _physics  :: Maybe PhysicsData,
  _children :: [GameObject],
  _primitive:: Primitive
  }

instance Show GameObject where
  show (GameObject m l p _ pr) = show l ++ "\n" ++ show p ++ "\n" ++ show (m^.quaternion) ++ "\n" ++ show pr ++ "\n"

makeLenses ''GameObject

modelMat :: GameObject -> Matrix Float
modelMat =
  view location &&& view (mesh.quaternion)  >>>
  posToMat *** quatToMat >>>
  uncurry (<>) --- >>> tr

translatePoint :: GameObject -> Vector Float -> Vector Float
translatePoint obj =
  let rot = (#>) . tr . quatToMat3 $ obj^.mesh.quaternion
      tra = (obj^.location +)
  in tra . rot

prepareCPrim :: GameObject -> PrimitiveComputation
prepareCPrim =
  modelMat &&& view primitive >>>
  uncurry preparePrimitive

initializePhysics :: Float -> GameObject -> GameObject
initializePhysics mInv obj =
  let quat = obj^.mesh.quaternion
  in set physics (Just $ startPhysics mInv quat) obj

turnQuatZ :: Float -> GameObject -> GameObject
turnQuatZ = over (mesh.quaternion) . quatConcat . rotQuatZ
  where
    rotQuatZ t = cos (t/2) +:: (0,sin $ t / 2,0)

getInertiaInv :: GameObject -> Matrix Float
getInertiaInv =
  fromMaybe ((3><3) $ replicate 9 0) .
  preview (physics._Just.inertiaInv)

drawObject2 cam proj obj = do
  GL.currentProgram $= Just (obj^.mesh.shaders.program)
  GL.bindVertexArrayObject $= Just (obj^.mesh.vao)

  passMatrix "camera" $ flatten cam
  passMatrix "proj" proj
  mapM_ (passMatrix "rot" . pointAt . view speed) $ obj^.physics
  passMatrix "pos" . posToMatV $ obj^.location

  passTexture "texSampler" 0 $ obj^.mesh.texture
  passTexture "normSampler" 1 $ obj^.mesh.normalMap

  GL.drawElements GL.Triangles indLen GL.UnsignedInt (intPtrToPtr $ IntPtr 0)

  GL.bindVertexArrayObject $= Nothing
  where
    indLen    = fromIntegral . VS.length $ obj^.mesh.indices
    passMatrix = passMatrixToProg $ obj^.mesh.shaders
    passTexture = passTextureToProg GL.Texture2D $ obj^.mesh.shaders

passTextureToProg tp shaders name pos mtex = do
  GL.activeTexture $= GL.TextureUnit pos
  GL.textureBinding tp $= mtex
  GL.uniform (GL.UniformLocation $ uniformName shaders name) $= GL.TextureUnit pos
  return ()

passMatrixToProg shaders name mat =
  VS.unsafeWith mat $
     GLRaw.glUniformMatrix4fv (uniformName shaders name) 1 0

drawObject mskyTex cam proj obj = do
  GL.blend $= GL.Enabled
  -- GL.depthFunc $= Nothing

  GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
  GL.currentProgram $= Just (obj^.mesh.shaders.program)
  GL.bindVertexArrayObject $= Just (obj^.mesh.vao)

  passMatrix "camera" $ flatten cam
  passMatrix "proj" proj
  passMatrix "rot" . quatToMatV $ obj^.mesh.quaternion
  passMatrix "pos" . posToMatV $ obj^.location

  passTexture "texSampler" 1 $ obj^.mesh.texture
  passTexture "normSampler" 2 $ obj^.mesh.normalMap
  passTexture "skytex" 1 mskyTex

  GL.drawElements GL.Triangles indLen GL.UnsignedInt (intPtrToPtr $ IntPtr 0)
  GL.blend $= GL.Disabled
  -- GL.depthFunc $= Just GL.Less

  GL.bindVertexArrayObject $= Nothing
  where
    indLen    = fromIntegral . VS.length $ obj^.mesh.indices
    passMatrix = passMatrixToProg $ obj^.mesh.shaders
    passTexture = passTextureToProg GL.Texture2D $ obj^.mesh.shaders

max_stars_repo_name: Antystenes/CPG

max_issues_repo_name: Antystenes/CPG

max_forks_repo_name: Antystenes/CPG


text:
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{- |
This module provides a simple way to train
the transition matrix and initial probability vector
using simple patterns of state sequences.

You may create a trained model using semigroup combinators like this:

> let a = atom $ HMM.state 0
>     b = atom $ HMM.state 1
>     distr =
>        Distr.DiscreteTrained $ Map.fromList $
>        ('a', Vector.fromList [1,2]) :
>        ('b', Vector.fromList [4,3]) :
>        ('c', Vector.fromList [0,1]) :
>        []
> in  finish 2 distr $ replicate 5 $ replicate 10 a <> replicate 20 b
-}
module Math.HiddenMarkovModel.Pattern (
   T,
   atom,
   append,
   replicate,
   finish,
   ) where

import qualified Math.HiddenMarkovModel.Distribution as Distr
import qualified Math.HiddenMarkovModel as HMM
import Math.HiddenMarkovModel.Private (Trained(..))
import Math.HiddenMarkovModel.Distribution (State(State))

import qualified Numeric.LinearAlgebra.Algorithms as Algo
import qualified Numeric.Container as NC
import qualified Data.Packed.Vector as Vector
import Data.Packed.Matrix (Matrix)
import Data.Packed.Vector (Vector)

import qualified Data.Map as Map
import Data.Semigroup (Semigroup, (<>), stimes)

import Prelude hiding (replicate)

newtype T prob = Cons (Int -> (State, Matrix prob, State))

atom ::
   (NC.Container Vector prob) =>
   State -> T prob
atom s = Cons $ \n -> (s, NC.konst 0 (n,n), s)

instance (Algo.Field prob) => Semigroup (T prob) where
   (<>) = append
   stimes k = replicate $ fromIntegral k

infixl 5 `append`

append ::
   (NC.Container Vector prob) =>
   T prob -> T prob -> T prob
append (Cons f) (Cons g) =
   Cons $ \n ->
      case (f n, g n) of
         ((sai, ma, sao), (sbi, mb, sbo)) ->
            (sai, increment (sbi,sao) 1 $ NC.add ma mb, sbo)

replicate ::
   (NC.Container Vector prob) =>
   Int -> T prob -> T prob
replicate ki (Cons f) =
   Cons $ \n ->
      case f n of
         (si, m, so) ->
            let k = fromIntegral ki
            in  (si, increment (si,so) (k-1) $ NC.scale k m, so)

increment ::
   (NC.Container Vector a) =>
   (State, State) -> a -> Matrix a -> Matrix a
increment (State i, State j) x m  =  NC.accum m (+) [((i,j), x)]

finish ::
   (NC.Container Vector prob) =>
   Int -> tdistr -> T prob -> Trained tdistr prob
finish n tdistr (Cons f) =
   case f n of
      (State si, m, _so) ->
         Trained {
            trainedInitial = NC.assoc n 0 [(si,1)],
            trainedTransition = m,
            trainedDistribution = tdistr
         }

_example :: HMM.DiscreteTrained Double Char
_example =
   let a = atom $ HMM.state 0
       b = atom $ HMM.state 1
       distr =
          Distr.DiscreteTrained $ Map.fromList $
          ('a', Vector.fromList [1,2]) :
          ('b', Vector.fromList [4,3]) :
          ('c', Vector.fromList [0,1]) :
          []
   in  finish 2 distr $ replicate 5 $ replicate 10 a <> replicate 20 b

max_stars_repo_name: rybern/hmm-hmatrix

max_issues_repo_name: rybern/hmm-hmatrix

max_forks_repo_name: rybern/hmm-hmatrix


text:
{-# LANGUAGE FlexibleInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Foreign.VMath.VFractional
-- Copyright  : Copyright (c) 2010, Patrick Perry <patperry@gmail.com>
-- License    : BSD3
-- Maintainer : Patrick Perry <patperry@gmail.com>
-- Stability  : experimental
--
-- Vector Fractional operations.
--

module Foreign.VMath.VFractional
    where

import Foreign( Ptr )
import Data.Complex( Complex(..) )

import Foreign.VMath.VNum
import Foreign.VMath.Double
import Foreign.VMath.Zomplex

-- | Types with vectorized 'Fractional' operations.
class (VNum a, Fractional a) => VFractional a where
    vInv :: Int -> Ptr a -> Ptr a -> IO ()
    vDiv :: Int -> Ptr a -> Ptr a -> Ptr a -> IO ()

instance VFractional Double where
    vInv = vdInv
    {-# INLINE vInv #-}
    vDiv = vdDiv
    {-# INLINE vDiv #-}

instance VFractional (Complex Double) where
    vInv = vzInv
    {-# INLINE vInv #-}
    vDiv = vzDiv
    {-# INLINE vDiv #-}

max_stars_repo_name: patperry/hs-linear-algebra

max_issues_repo_name: cartazio/hs-cblas

max_forks_repo_name: cartazio/hs-cblas


text:
--
-- ConvLayer : convolution layer
--

module CNN.ConvLayer (
  initFilterC
, convolve
, deconvolve
, reverseConvFilter
, updateConvFilter
) where

import Control.Monad hiding (msum)
import Data.List hiding (transpose)
import Data.Maybe
import Debug.Trace
import Numeric.LinearAlgebra
import System.Random.Mersenne as MT

import CNN.Algebra
import CNN.Image
import CNN.LayerType

{- |
initFilterC

  IN : #kernel
       #channel
       input size (x * y)
       kernel size (n * n)
       pool size (m * m)

  OUT: filter of convolution layer

-}

initFilterC :: Int -> Int -> Int -> Int -> Int -> Int -> IO [FilterC]
initFilterC k c x y n m = do
  f <- forM [1..k] $ \i -> do
    w <- initKernel c n
    return (w, 0.0)
  return f
  where
    ri = fromIntegral (n * n * c)   -- resolution (input)
    ro = fromIntegral (n * n * k) / (fromIntegral (m * m))
    a = sqrt (6.0 / (ri + ro))
    initKernel :: Int -> Int -> IO Kernel
    initKernel c n = do
      let
        sz = n * n
      w <- forM [1..c] $ \i -> do
        w' <- forM [1..sz] $ \j -> do
          r <- MT.randomIO :: IO Double
          return ((r * 2.0 - 1.0) * a)
        return w'
      return $ fromLists w

--

{- |
convolve

  IN: kernel size
      filter
      image

test: filter k=3, c=2, s=2
>>> let filter = [(fromLists [[1.0,2.0,3.0,4.0],[5.0,6.0,7.0,8.0]],0.25),(fromLists [[3.0,4.0,5.0,6.0],[7.0,8.0,1.0,2.0]],0.5),(fromLists [[5.0,6.0,7.0,8.0],[1.0,2.0,3.0,4.0]],0.75)] :: [FilterC]
>>> let img1 = [fromLists [[1.0,2.0,3.0],[4.0,5.0,6.0],[7.0,8.0,9.0]], fromLists [[4.0,5.0,6.0],[7.0,8.0,9.0],[1.0,2.0,3.0]]] :: Image
>>> let img2 = [fromLists [[1.0,2.0,3.0,4.0],[4.0,5.0,6.0,7.0],[7.0,8.0,9.0,10.0],[10.0,11.0,12.0,13.0]],fromLists [[4.0,5.0,6.0,7.0],[7.0,8.0,9.0,10.0],[1.0,2.0,3.0,4.0],[4.0,5.0,6.0,7.0]]] :: Image
>>> convolve 2 filter img1
[(2><2)
 [ 200.25, 236.25
 , 173.25, 209.25 ],(2><2)
 [ 152.5, 188.5
 , 233.5, 269.5 ],(2><2)
 [ 152.75, 188.75
 , 197.75, 233.75 ]]
>>> convolve 2 filter img2
[(3><3)
 [ 200.25, 236.25, 272.25
 , 173.25, 209.25, 245.25
 , 182.25, 218.25, 254.25 ],(3><3)
 [ 152.5, 188.5, 224.5
 , 233.5, 269.5, 305.5
 , 206.5, 242.5, 278.5 ],(3><3)
 [ 152.75, 188.75, 224.75
 , 197.75, 233.75, 269.75
 , 278.75, 314.75, 350.75 ]]

-}

--
-- USE corr2 ??
--

convolve :: Int -> [FilterC] -> Image -> Image
convolve s fs im = map (convolveImage x iss) fs
  where
    pl = head im
    x  = cols pl - (s - 1)
    y  = rows pl - (s - 1)
    ps = [(i, j) | i <- [0..(x-1)], j <- [0..(y-1)]]
    iss = map subImage im
    subImage :: Plain -> Matrix R
    subImage i = fromColumns $ map (\p -> flatten $ subMatrix p (s, s) i) ps

convolveImage :: Int -> [Matrix R] -> FilterC -> Plain
convolveImage x iss (k, b) = reshape x $ cmap (+ b) $ vsum vs
  where
    vs = zipWith (<#) (toRows k) iss

-- back prop

deconvolve :: Int -> [FilterC] -> Image -> Delta -> (Delta, Maybe Layer)
deconvolve s fs im d = (delta, Just (ConvLayer s dw))
  where
    delta = convolve s fs $ addBorder s d
    sim = slideImage s im
    dw = map (hadamard sim) d

{- |
addBorder

  IN : kernel size
       delta (Image)
  OUT: delta (Image)

>>> let s = [fromLists [[1.0, 2.0],[3.0,4.0]], fromLists [[5.0,6.0],[7.0,8.0]]]
>>> addBorder 2 s
[(4><4)
 [ 0.0, 0.0, 0.0, 0.0
 , 0.0, 1.0, 2.0, 0.0
 , 0.0, 3.0, 4.0, 0.0
 , 0.0, 0.0, 0.0, 0.0 ],(4><4)
 [ 0.0, 0.0, 0.0, 0.0
 , 0.0, 5.0, 6.0, 0.0
 , 0.0, 7.0, 8.0, 0.0
 , 0.0, 0.0, 0.0, 0.0 ]]

-}

addBorder :: Int -> Delta -> Delta
addBorder s d = map ab d
  where
    s' = s - 1
    ab :: Plain -> Plain
    ab p = yb ||| ((xb === (p === xb)) ||| yb)
      where
        x = cols p
        y = rows p
        xb = (s'><x) $ repeat 0.0
        yb = ((y + 2 * s')><s') $ repeat 0.0

{- |
slideImage

>>> let p = [fromLists [[1.0,2.0,3.0,4.0],[5.0,6.0,7.0,8.0],[9.0,10.0,11.0,12.0],[13.0,14.0,15.0,16.0]]] :: Image
>>> slideImage 2 p
[[(3><3)
 [ 1.0,  2.0,  3.0
 , 5.0,  6.0,  7.0
 , 9.0, 10.0, 11.0 ],(3><3)
 [  2.0,  3.0,  4.0
 ,  6.0,  7.0,  8.0
 , 10.0, 11.0, 12.0 ],(3><3)
 [  5.0,  6.0,  7.0
 ,  9.0, 10.0, 11.0
 , 13.0, 14.0, 15.0 ],(3><3)
 [  6.0,  7.0,  8.0
 , 10.0, 11.0, 12.0
 , 14.0, 15.0, 16.0 ]]]

-}

slideImage :: Int -> Image -> [[Plain]]
slideImage s im = map (slidePlain s) im

{- |
slidePlain

>>> let p = fromLists [[1.0,2.0,3.0,4.0],[5.0,6.0,7.0,8.0],[9.0,10.0,11.0,12.0],[13.0,14.0,15.0,16.0]] :: Plain
>>> slidePlain 2 p
[(3><3)
 [ 1.0,  2.0,  3.0
 , 5.0,  6.0,  7.0
 , 9.0, 10.0, 11.0 ],(3><3)
 [  2.0,  3.0,  4.0
 ,  6.0,  7.0,  8.0
 , 10.0, 11.0, 12.0 ],(3><3)
 [  5.0,  6.0,  7.0
 ,  9.0, 10.0, 11.0
 , 13.0, 14.0, 15.0 ],(3><3)
 [  6.0,  7.0,  8.0
 , 10.0, 11.0, 12.0
 , 14.0, 15.0, 16.0 ]]

>>> slidePlain 3 p
[(2><2)
 [ 1.0, 2.0
 , 5.0, 6.0 ],(2><2)
 [ 2.0, 3.0
 , 6.0, 7.0 ],(2><2)
 [ 3.0, 4.0
 , 7.0, 8.0 ],(2><2)
 [ 5.0,  6.0
 , 9.0, 10.0 ],(2><2)
 [  6.0,  7.0
 , 10.0, 11.0 ],(2><2)
 [  7.0,  8.0
 , 11.0, 12.0 ],(2><2)
 [  9.0, 10.0
 , 13.0, 14.0 ],(2><2)
 [ 10.0, 11.0
 , 14.0, 15.0 ],(2><2)
 [ 11.0, 12.0
 , 15.0, 16.0 ]]

-}

slidePlain :: Int -> Plain -> [Plain]
slidePlain s m
  | s < 1     = []
  | s == 1    = [m]
  | otherwise = map (\p -> subMatrix p (x, y) m) ps
  where
    x = cols m - (s - 1)
    y = rows m - (s - 1)
    ps = [(i, j) | i <- [0..s-1], j <- [0..s-1]]

{- |
hadamard

  IN : slided images
       delta
  OUT: (Kernel, Bias)

>>> let p = [fromLists [[1.0,2.0,3.0,4.0],[5.0,6.0,7.0,8.0],[9.0,10.0,11.0,12.0],[13.0,14.0,15.0,16.0]], fromLists [[16.0,15.0,14.0,13.0],[12.0,11.0,10.0,9.0],[8.0,7.0,6.0,5.0],[4.0,3.0,2.0,1.0]]] :: Image
>>> let ds = fromLists [[0.1,0.2,0.3],[0.4,0.5,0.6],[0.7,0.8,0.9]]
>>> hadamard (slideImage 2 p) ds
((2><4)
 [ 34.800000000000004, 39.3, 52.800000000000004, 57.3
 ,               41.7, 37.2, 23.700000000000006, 19.2 ],4.5)

-}

hadamard :: [[Plain]] -> Plain -> FilterC
hadamard sim ds = (w, b)
  where
    b = sumElements ds
    d' = flatten ds
    w = fromLists $ map (map ((<.>) d' . flatten)) sim

{- |
reverseConvFilter

  IN : kernel size
       original filter
  OUT: reversed filter

>>> let fs = [(fromLists [[0.1,0.2,0.3,0.4],[0.5,0.6,0.7,0.8]],1.0),(fromLists [[0.1,0.3,0.5,0.7],[0.2,0.4,0.6,0.8]],2.0),(fromLists [[0.1,0.2,0.5,0.6],[0.3,0.4,0.7,0.8]],3.0)] :: [FilterC]
>>> let ConvLayer s fs' = reverseConvFilter 2 fs
>>> s
2
>>> fs'
[((3><4)
 [ 0.4, 0.3, 0.2, 0.1
 , 0.7, 0.5, 0.3, 0.1
 , 0.6, 0.5, 0.2, 0.1 ],0.0),((3><4)
 [ 0.8, 0.7, 0.6, 0.5
 , 0.8, 0.6, 0.4, 0.2
 , 0.8, 0.7, 0.4, 0.3 ],0.0)]

-}

reverseConvFilter :: Int -> [FilterC] -> Layer
reverseConvFilter s fs = ConvLayer s (zip rv (repeat 0.0))
  where
    (k, _) = unzip fs
    k'     = map (toLists . fliprl) k
    --r      = transpose $ map (map reverse) k'
    r      = transpose k'
    rv     = map fromLists r

-- update

updateConvFilter :: Int -> [FilterC] -> Double -> [Maybe Layer] -> Layer
updateConvFilter s fs lr dl
  | dl' == [] = ConvLayer s fs
  | otherwise = ConvLayer s $ zip ks' (toList bs')
  where
    dl' = catMaybes dl
    sc = lr / fromIntegral (length dl')
    (ks , bs ) = unzip fs
    (kss, bss) = unzip $ map unzip $ strip dl'
    dbs = vsum $ map fromList bss
    dks = map (mscale sc . msum) $ transpose kss
    bs' = (fromList bs) - (vscale sc dbs)
    ks' = zipWith (-) ks dks

strip :: [Layer] -> [[FilterC]]
strip [] = []
strip (ConvLayer s fs:ds) = fs:strip ds
strip (_:ds) = strip ds  -- if not ConvLayer

max_stars_repo_name: eijian/deeplearning

max_issues_repo_name: eijian/deeplearning

max_forks_repo_name: eijian/deeplearning


text:
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module AI.Singularity.Data.Matrix where
import GHC.TypeLits
import qualified Numeric.LinearAlgebra.Data as LD
import qualified Numeric.LinearAlgebra.Devel as LDev
import qualified Numeric.LinearAlgebra as LA
import Control.Lens
import Data.Proxy
import Control.Monad.ST
import AI.Singularity.Utils
import System.Random
import Control.Monad

data GeneralMatrix :: (* -> *) -> Nat -> Nat -> * where
  Mat :: mat Float -> GeneralMatrix mat m n

deriving instance Show (mat Float) => Show (GeneralMatrix mat m n)

type Matrix = GeneralMatrix LD.Matrix

type MutMatrix s = GeneralMatrix (LDev.STMatrix s)

matr :: Lens' (GeneralMatrix mat m n) (mat Float)
{-# INLINE matr #-}
matr f (Mat m) = Mat <$> f m

data GeneralInTrainingMat mat m n =
  GeneralInTrainingMat (GeneralMatrix mat m n) (GeneralMatrix mat m n) (GeneralMatrix mat m n)

type InTrainMat m n = GeneralInTrainingMat LD.Matrix m n

type STInTrainMat s = GeneralInTrainingMat (LDev.STMatrix s)

deriving instance Show (mat Float) => Show (GeneralInTrainingMat mat m n)

trMatr :: Lens' (GeneralInTrainingMat mat m n) (GeneralMatrix mat m n)
{-# INLINE trMatr #-}
trMatr f (GeneralInTrainingMat m g h) = (\x -> GeneralInTrainingMat x g h) <$> f m

trGrad :: Lens' (GeneralInTrainingMat mat m n) (GeneralMatrix mat m n)
{-# INLINE trGrad #-}
trGrad f (GeneralInTrainingMat m g h) = (\x -> GeneralInTrainingMat m x h) <$> f g

hGrad :: Lens' (GeneralInTrainingMat mat m n) (GeneralMatrix mat m n)
{-# INLINE hGrad #-}
hGrad f (GeneralInTrainingMat m g h) = GeneralInTrainingMat m g <$> f h

matSlice,gradSlice :: forall s m n. (KnownNat m, KnownNat n) => STInTrainMat s m n -> LDev.Slice s Float
matSlice  m = LDev.Slice (m^.trMatr.matr) 0 0 (fromIntegral . natVal $ Proxy @ n) (fromIntegral . natVal $ Proxy @ m)
gradSlice m = LDev.Slice (m^.trGrad.matr) 0 0 (fromIntegral . natVal $ Proxy @ n) (fromIntegral . natVal $ Proxy @ m)

thawM :: Matrix m n -> ST s (MutMatrix s m n)
thawM = Mat <$< LDev.thawMatrix . view matr

toSTInTrainM :: (KnownNat m, KnownNat n) => Matrix m n -> ST s (STInTrainMat s m n)
toSTInTrainM m = GeneralInTrainingMat <$> thawM m <*> thawM 0 <*> thawM 0

matHeight :: forall m n mat. KnownNat n => GeneralMatrix mat m n -> Int
matHeight _ = natToInt @ n

matWidth :: forall m n mat. KnownNat m => GeneralMatrix mat m n -> Int
matWidth _ = natToInt @ m

mat :: forall m n. (KnownNat m, KnownNat n) => [Float] -> Matrix m n
mat = Mat . (valm LD.>< valn) . take (valm * valn) . cycle
    where valm = matHeight ( undefined :: Matrix m n)
          valn = matWidth ( undefined :: Matrix m n)

randomMat :: forall m n. (KnownNat m, KnownNat n) => IO (Matrix m n)
randomMat = Mat . (valm LD.>< valn) <$> replicateM (valm * valn) (randomRIO (0.001, 0.1))
    where valm = matHeight ( undefined :: Matrix m n)
          valn = matWidth ( undefined :: Matrix m n)

zeroMat :: forall m n. (KnownNat m, KnownNat n) => Matrix m n
zeroMat = 0

ident :: forall n. (KnownNat n) => Matrix n n
ident = Mat $ LD.ident valn
  where valn = matHeight ( undefined :: Matrix n n)

transposeM :: forall m n. (KnownNat m, KnownNat n) => Matrix m n -> Matrix n m
transposeM = Mat . LA.tr . view matr

instance (KnownNat n, KnownNat m) => Num (Matrix m n) where
  (+) (Mat m1) (Mat m2) = Mat (m1 + m2)
  (*) (Mat m1) (Mat m2) = Mat (m1 * m2)
  negate (Mat m1)       = Mat $ LD.cmap negate m1
  fromInteger i         = mat [fromInteger i]
  abs (Mat m1)          = Mat $ LD.cmap abs m1
  signum (Mat m1)       = Mat $ LD.cmap signum m1

instance (KnownNat n, KnownNat m) => Fractional (Matrix m n) where
  (/) (Mat m1) (Mat m2) = Mat $ m1 / m2
  fromRational          = mat . (:[]) . fromRational

instance (KnownNat n, KnownNat m, n ~ m) => Monoid (Matrix n m) where
  mempty                    = Mat $ LA.ident $ fromInteger $ natVal (Proxy :: Proxy n)
  mappend (Mat m1) (Mat m2) = Mat $ (LA.<>) m1 m2

mmap :: (KnownNat n, KnownNat m) => (Float -> Float) -> Matrix m n -> Matrix m n
mmap f (Mat m) = Mat $ LD.cmap f m

checkNan :: forall m n. Matrix m n -> Matrix m n
checkNan (Mat x) = Mat (LD.cmap nancheck x)

max_stars_repo_name: Antystenes/Memetic-Predictor

max_issues_repo_name: Antystenes/Memetic-Predictor

max_forks_repo_name: Antystenes/Memetic-Predictor


text:
module Main where

import qualified Numeric.LinearAlgebra as LA
import qualified MachineLearning.Types as T
import qualified MachineLearning as ML
import qualified MachineLearning.Classification.OneVsAll as OVA
import qualified MachineLearning.PCA as PCA
import qualified MachineLearning.LogisticModel as LM

processFeatures :: T.Matrix -> T.Matrix
processFeatures = ML.addBiasDimension . (ML.mapFeatures 2)

calcAccuracy :: T.Matrix -> T.Vector -> [T.Vector] -> Double
calcAccuracy x y thetas = OVA.calcAccuracy y yPredicted
  where yPredicted = OVA.predict x thetas

printOptPath x optPath =
  let thetas = optPath LA.?? (LA.All, LA.Drop 2)
      thetas_norm = LA.col $ map (LA.norm_2) $ LA.toRows . log $ 1 - LM.sigmoid (thetas LA.<> LA.tr x)
  in LA.disp 3 $ (optPath LA.?? (LA.All, LA.Take 2)) LA.||| thetas_norm

printInfinities x thetaList =
  let thetas = LA.fromColumns thetaList
      y :: T.Matrix
      y = log $ 1-LM.sigmoid (x LA.<> thetas)
      inf = 1/0
      xList = LA.toRows x
      x' = LA.fromRows $ map (\(xi, _) -> xList !! xi) $ LA.find (<=(-inf)) y
      z = x' LA.<> thetas
      h = LM.sigmoid z
      h' = 1 - h
      logh = log h
      logh' = log h'
  in do
    putStrLn "X"
    LA.disp 3 x'
    putStrLn "Z = X * Theta"
    LA.disp 3 z
    putStrLn "h(Theta) = sigmoid(Z)"
    LA.disp 3 h
    putStrLn "1 - h(Theta)"
    LA.disp 3 h'
    putStrLn "log (h(Theta))"
    LA.disp 3 logh
    putStrLn "log (1-h(Theta))"
    LA.disp 3 logh'

main = do
  -- Step 1. Data loading.
  -- Step 1.1 Training Data loading.
  (x, y) <- pure ML.splitToXY <*> LA.loadMatrix "samples/digits_classification/optdigits.tra"
  -- Step 1.1 Testing Data loading.
  (xTest, yTest) <- pure ML.splitToXY <*> LA.loadMatrix "samples/digits_classification/optdigits.tes"

  -- Step 2. Outputs and features preprocessing.
  let numLabels = 10
      x' = processFeatures x
      (reduceDims, reducedDimensions, x1) = PCA.getDimReducer x' 10
      initialTheta = LA.konst 0 (LA.cols x1)
      initialThetaList = replicate numLabels initialTheta
  -- Step 3. Learning.
      (thetaList, optPath) = OVA.learn (OVA.BFGS2 0.1 0.5) 0.0001 30 (OVA.L2 30) numLabels x1 y initialThetaList
  -- Step 4. Prediction and checking accuracy
      accuracyTrain = calcAccuracy x1 y thetaList
      accuracyTest = calcAccuracy (reduceDims $ processFeatures xTest) yTest thetaList

  -- Step 5. Printing results.
  putStrLn "\n=== Numerical Issues Demonstration ==="

  putStrLn $ "\nNumber of iterations to learn: " ++ show (map LA.rows optPath)

  putStrLn $ "\nReduced from " ++ show (LA.cols x') ++ " to " ++ show (LA.cols x1) ++ " dimensions"

  putStrLn "\nOptimization Paths (# iter, J(Theta), norm_2(Theta))"
  mapM_ (printOptPath x1) optPath

  print "\nDisplay numerical issues"
  printInfinities x1 thetaList

  putStrLn $ "\nAccuracy on train set (%): " ++ show (accuracyTrain*100)
  putStrLn $ "Accuracy on test set (%): " ++ show (accuracyTest*100)

max_stars_repo_name: aligusnet/mltool

max_issues_repo_name: aligusnet/mltool

max_forks_repo_name: aligusnet/mltool


text:
{-# LANGUAGE DataKinds
           , GADTs
           , TypeOperators #-}
module Aqua
    (
      module Aqua
    ) where

import Control.Arrow
import Data.Complex
import GHC.TypeLits

import QBasis
import Vect

type QReg n = Vect C (QBasis n)
type QCirc n = Vect C (QBasis n) -> Vect C (QBasis n)

runCircuit :: KnownNat n => QCirc n -> QReg n
runCircuit = ($ unit)

tensor :: QReg m -> QReg n -> QReg (m + n)
tensor vec1 vec2 = vec1 `te` vec2

(⊗) :: KnownNat m => QCirc m -> QCirc n -> QCirc (m + n)
c1 ⊗ c2 = c1 `tf` c2

unit :: KnownNat n => QReg n
unit = V [(unit', 1)]

idGate :: QCirc n
idGate = id

notGate :: QCirc 1
notGate = linear n
    where n :: QBasis 1 -> QReg 1
          n (Cons False Nil) = V [(Cons True Nil, 1)]
          n (Cons True Nil) = V [(Cons False Nil, 1)]

hGate :: QCirc 1
hGate = linear h
    where h :: QBasis 1 -> QReg 1
          h (Cons False Nil) = V [(Cons False Nil, 1 / sqrt 2)
                                 ,(Cons True Nil, 1 / sqrt 2)]
          h (Cons True Nil) = V [(Cons False Nil, 1 / sqrt 2)
                                ,(Cons True Nil, -1 / sqrt 2)]

rotGate :: Double -> QCirc 1
rotGate t = linear r
    where r :: QBasis 1 -> QReg 1
          r (Cons False Nil) = V [(Cons False Nil, 1)]
          r (Cons True Nil) = V [(Cons True Nil, cis t)]

cnotGate :: QCirc 2
cnotGate = linear n
    where n :: QBasis 2 -> QReg 2
          n (Cons False (Cons False Nil)) = V [(Cons False (Cons False Nil), 1)]
          n (Cons False (Cons True Nil)) = V [(Cons False (Cons True Nil), 1)]
          n (Cons True (Cons False Nil)) = V [(Cons True (Cons True Nil), 1)]
          n (Cons True (Cons True Nil)) = V [(Cons True (Cons False Nil), 1)]

swapGate :: QCirc 2
swapGate = linear s
    where s :: QBasis 2 -> QReg 2
          s (Cons False (Cons False Nil)) = V [(Cons False (Cons False Nil), 1)]
          s (Cons False (Cons True Nil)) = V [(Cons True (Cons False Nil), 1)]
          s (Cons True (Cons False Nil)) = V [(Cons False (Cons True Nil), 1)]
          s (Cons True (Cons True Nil)) = V [(Cons True (Cons True Nil), 1)]

max_stars_repo_name: caldwellwg/Aqua

max_issues_repo_name: caldwellwg/Aqua

max_forks_repo_name: caldwellwg/Aqua


text:
{-# LANGUAGE OverloadedStrings #-}
module Lisp.PrintSpec (spec) where

import Data.Complex
import Data.Ratio
import Data.Text
import Test.Hspec
import Test.QuickCheck

import Lisp

spec :: Spec

spec = do
  let foo = Symbol "foo"
  let bar = Symbol "bar"

  describe "LispVal.pp" $ do
    it "prints symbols as its own value" $
      pp foo `shouldBe` "foo"

    it "QuickCheck symbols print as their own value" $
      property $ \s -> let t = pack s in pp (Symbol t) == t

    it "prints integers as their own value" $
      pp (Int 5) `shouldBe` "5"

    it "prints decimals as thier own value" $
      pp (Real 3.14) `shouldBe` "3.14"

    it "prints rationals as their own value, lisp-style" $
      pp (Rational (3%4)) `shouldBe` "3/4"

    it "prints rationals reduced" $
      pp (Rational (4%8)) `shouldBe` "1/2"

    it "prints complex number as their own value, lisp-style" $
      pp (Complex (3:+4)) `shouldBe` "3.0+4.0i"

    it "prints strings in quotes" $
      pp (String "foo") `shouldBe` "\"foo\""

    it "prints true as #t" $
      pp (Bool True) `shouldBe` "#t"

    it "prints false as #f" $
      pp (Bool False) `shouldBe` "#f"

    it "prints nils/empty lists as ()" $
      pp Nil `shouldBe` "()"

    it "prints pairs as dotted pairs" $
      pp (Pair foo bar) `shouldBe` "(foo . bar)"

    it "prints pairs with Nil cdr as singleton lists" $
      pp (Pair foo Nil) `shouldBe` "(foo)"

    it "prints lists as lists" $
      pp (Pair foo
           (Pair bar
            (Pair (Int 5)
             (Pair (Bool False) Nil)))) `shouldBe` "(foo bar 5 #f)"

    it "prints dotted lists with dots" $
      pp (Pair foo
           (Pair bar
            (Pair (Int 5)
             (Pair (Bool False) (Bool True))))) `shouldBe` "(foo bar 5 #f . #t)"

max_stars_repo_name: blaisepascal/Haskell-LiSP

max_issues_repo_name: blaisepascal/Haskell-LiSP

max_forks_repo_name: blaisepascal/Haskell-LiSP


text:
module View
  ( view
  ) where

import           Data.Maybe
import           Graphics.Rendering.OpenGL    (($=))
import qualified Graphics.Rendering.OpenGL    as GL
import qualified Graphics.UI.GLFW             as GLFW
import           Lens.Micro.Platform          ((^.))

--import           Numeric.LinearAlgebra
import           Numeric.LinearAlgebra.Static

import           Drawable
import           Matrix
import           MyState
import           Rotation
import           Shaders
import           Uniform

getColor Red   = GL.Color3 1.0 0.0 (0.0 :: GL.GLfloat)
getColor Green = GL.Color3 0.0 1.0 (0.0 :: GL.GLfloat)
getColor Blue  = GL.Color3 0.0 0.0 (1.0 :: GL.GLfloat)

--View
setColor program color = setUniform program "color" $ getColor color

viewMatrix :: Camera -> Matrix4
viewMatrix camera = rot <> translation
  where
    translation = translate . (* (-1)) $ camera ^. cameraPosition
    rot = rotationMatrix $ mkXYRotationCamera (-x) (-y)
    (x, y) = camera ^. cameraRotation

model :: Vector3 -> Matrix4
model = translate

lightPosition = GL.Vertex3 (-0.0) 100.0 0.0 :: GL.Vertex3 GL.GLfloat

reset =
  GL.clearColor $= GL.Color4 0 0 0 1 >>
  GL.clear [GL.ColorBuffer, GL.DepthBuffer]

drawCube mU pU state pos = do
  let m = model pos
  seq m $ return ()
  setUniform4fv m mU
  draw . head $ state ^. cubes

grid space =
  map
    (* realToFrac space)
    (vec3 <$> [-5 .. 5] <*> [-5 .. 5] <*> [-5 .. 5])

drawCubes shaders state = do
  program <- activateProgram shaders Normal
  setColor program $ state ^. color
  setUniform program "useVertexColor" (1 :: GL.GLuint)
  setUniform program "LightPosition_worldspace" lightPosition
  let m = model $ state ^. cubePos
      v = viewMatrix $ state ^. camera
      p = projection $ state ^. aspectRatio
      vp = p <> v <> m
  mU <- getUniform program "M"
  vU <- getUniform program "V"
  pU <- getUniform program "P"
  setUniform4fv v vU
  setUniform4fv p pU
  mapM_ (drawCube mU pU state) (grid $ state ^. spacing)

drawTerrain state program = do
  setColor program $ state ^. color
  setUniform program "useVertexColor" (1 :: GL.GLuint)
  setUniform program "LightPosition_worldspace" lightPosition
  let m = model $ state ^. cubePos
      v = viewMatrix $ state ^. camera
      p = projection $ state ^. aspectRatio
      vp = p <> v <> m
  getUniform program "V" >>= setUniform4fv v
  getUniform program "P" >>= setUniform4fv p
  getUniform program "M" >>= setUniform4fv m
  draw . head $ state ^. terrain

view :: Shaders -> MyState -> IO ()
view shaders state = do
  startTime <- GLFW.getTime
  reset
  drawCubes shaders state
  activateProgram shaders Normal >>= drawTerrain state
  activateProgram shaders Wireframe >>= drawTerrain state
  endTime <- GLFW.getTime
  let fps = ((1 /) . fromJust) ((-) <$> endTime <*> startTime)
  putStrLn $ "FPS: " ++ show fps
  putStrLn $
    "Triangles per second: " ++ show (fromIntegral (length (grid 3)) * 12 * fps)

max_stars_repo_name: aelg/haskell-render

max_issues_repo_name: aelg/haskell-render

max_forks_repo_name: aelg/haskell-render


text:
{-# LANGUAGE ScopedTypeVariables #-}

import           Control.Monad.Primitive
import           Data.Complex
import           Control.Monad

import qualified Data.Vector.Generic               as VG
import qualified Data.Vector.Generic.Mutable       as VGM
import qualified Data.Vector.Storable              as VS
import qualified Data.Vector.Storable.Mutable      as VSM

import           Test.QuickCheck
import           Test.QuickCheck.Monadic
import           Test.Framework (defaultMain, testGroup)
import           Test.Framework.Providers.QuickCheck2 (testProperty)

import           SDR.FilterInternal
import           SDR.Util
import           SDR.CPUID

sameResultM :: Monad m => (a -> a -> Bool) -> [m a] -> m Bool
sameResultM _  []     = return True
sameResultM eq (x:xs) = do
    res  <- x
    ress <- sequence xs
    return $ all (eq res) ress

sameResult :: (a -> a -> Bool) -> [a] -> Bool
sameResult _ [] = True
sameResult eq (x:xs) = all (eq x) xs

tests info = [
        testGroup "filters" [
            testProperty "real"    propFiltersReal,
            testProperty "complex" propFiltersComplex
        ],
        testGroup "decimators" [
            testProperty "real"    propDecimationReal,
            testProperty "complex" propDecimationComplex
        ],
        testGroup "resamplers" [
            testProperty "real" propResamplingReal,
            testProperty "complex" propResamplingComplex
        ],
        testGroup "conversion" [
            testProperty "rtlsdr"  propConversionRTLSDR,
            testProperty "BladeRF" propConversionBladeRF
        ],
        testProperty "scaling"    propScaleReal
    ]
    where
    hasFeatures :: [(CPUInfo -> Bool, a)] -> [a]
    hasFeatures = map snd . filter (($ info) . fst)

    sizes           = elements [1024, 2048, 4096, 8192, 16384, 32768, 65536]
    numCoeffs       = elements [32, 64, 128, 256, 512]
    factors'        = [1, 2, 3, 5, 7, 11, 13, 17, 23]
    factors         = elements factors'

    propFiltersReal =
        forAll sizes $ \size ->
            forAll (vectorOf size (choose (-10, 10))) $ \inBuf ->
                forAll numCoeffs $ \numCoeffs ->
                    forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs ->
                        testFiltersReal size numCoeffs coeffs inBuf

    testFiltersReal :: Int -> Int -> [Float] -> [Float] -> Property
    testFiltersReal size numCoeffs coeffs inBuf = monadicIO $ do
        let vCoeffsHalf = VS.fromList coeffs
            vCoeffs     = VS.fromList $ coeffs ++ reverse coeffs
            vInput      = VS.fromList inBuf
            num         = size - numCoeffs*2 + 1

        res <- run $ sameResultM eqDelta $ map (getResult num) $ hasFeatures [
                (const True, filterHighLevel       vCoeffs     num vInput),
                (const True, filterImperative1     vCoeffs     num vInput),
                (const True, filterImperative2     vCoeffs     num vInput),
                (const True, filterCRR             vCoeffs     num vInput),
                (hasSSE42,   filterCSSERR          vCoeffs     num vInput),
                (hasAVX,     filterCAVXRR          vCoeffs     num vInput),
                (hasSSE42,   filterCSSESymmetricRR vCoeffsHalf num vInput),
                (hasAVX,     filterCAVXSymmetricRR vCoeffsHalf num vInput)
            ]
        assert res

    propFiltersComplex =
        forAll sizes $ \size ->
            forAll (vectorOf size (choose (-10, 10))) $ \inBufR ->
                forAll (vectorOf size (choose (-10, 10))) $ \inBufI ->
                    forAll numCoeffs $ \numCoeffs ->
                        forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs ->
                            testFiltersComplex size numCoeffs coeffs $ zipWith (:+) inBufR inBufI

    testFiltersComplex :: Int -> Int -> [Float] -> [Complex Float] -> Property
    testFiltersComplex size numCoeffs coeffs inBuf = monadicIO $ do
        let vCoeffsHalf = VS.fromList coeffs
            vCoeffs     = VS.fromList $ coeffs ++ reverse coeffs
            vInput      = VS.fromList inBuf
            num         = size - numCoeffs*2 + 1
            vCoeffs2    = VG.fromList $ duplicate $ coeffs ++ reverse coeffs

        res <- run $ sameResultM eqDeltaC $ map (getResult num) $ hasFeatures [
                (const True, filterHighLevel       vCoeffs  num vInput),
                (const True, filterCRC             vCoeffs  num vInput),
                (hasSSE42,   filterCSSERC          vCoeffs2 num vInput),
                (hasSSE42,   filterCSSERC2         vCoeffs  num vInput),
                (hasAVX,     filterCAVXRC          vCoeffs2 num vInput),
                (hasSSE42,   filterCSSESymmetricRC vCoeffsHalf num vInput),
                (hasAVX,     filterCAVXSymmetricRC vCoeffsHalf num vInput)
            ]
        assert res

    propDecimationReal =
        forAll sizes $ \size ->
            forAll (vectorOf size (choose (-10, 10))) $ \inBuf ->
                forAll numCoeffs $ \numCoeffs ->
                    forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs ->
                       forAll factors $ \factor ->
                            testDecimationReal size numCoeffs factor coeffs inBuf

    testDecimationReal :: Int -> Int -> Int -> [Float] -> [Float] -> Property
    testDecimationReal size numCoeffs factor coeffs inBuf = monadicIO $ do
        let vCoeffsHalf = VS.fromList coeffs
            vCoeffs     = VS.fromList $ coeffs ++ reverse coeffs
            vInput      = VS.fromList inBuf
            num         = (size - numCoeffs*2 + 1) `quot` factor

        res <- run $ sameResultM eqDelta $ map (getResult num) $ hasFeatures [
                (const True, decimateHighLevel       factor vCoeffs     num vInput),
                (const True, decimateCRR             factor vCoeffs     num vInput),
                (hasSSE42,   decimateCSSERR          factor vCoeffs     num vInput),
                (hasAVX,     decimateCAVXRR          factor vCoeffs     num vInput),
                (hasSSE42,   decimateCSSESymmetricRR factor vCoeffsHalf num vInput),
                (hasAVX,     decimateCAVXSymmetricRR factor vCoeffsHalf num vInput)
            ]
        assert res

    propDecimationComplex =
        forAll sizes $ \size ->
            forAll (vectorOf size (choose (-10, 10))) $ \inBufR ->
                forAll (vectorOf size (choose (-10, 10))) $ \inBufI ->
                    forAll numCoeffs $ \numCoeffs ->
                        forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs ->
                            forAll factors $ \factor ->
                                testDecimationComplex size numCoeffs factor coeffs $ zipWith (:+) inBufR inBufI

    testDecimationComplex :: Int -> Int -> Int -> [Float] -> [Complex Float] -> Property
    testDecimationComplex size numCoeffs factor coeffs inBuf = monadicIO $ do
        let vCoeffsHalf = VS.fromList coeffs
            vCoeffs     = VS.fromList $ coeffs ++ reverse coeffs
            vInput      = VS.fromList inBuf
            num         = (size - numCoeffs*2 + 1) `quot` factor
            vCoeffs2    = VG.fromList $ duplicate $ coeffs ++ reverse coeffs

        res <- run $ sameResultM eqDeltaC $ map (getResult num) $ hasFeatures [
                (const True, decimateHighLevel       factor vCoeffs  num vInput),
                (const True, decimateCRC             factor vCoeffs  num vInput),
                (hasSSE42,   decimateCSSERC          factor vCoeffs2 num vInput),
                (hasSSE42,   decimateCSSERC2         factor vCoeffs  num vInput),
                (hasAVX,     decimateCAVXRC          factor vCoeffs2 num vInput),
                (hasSSE42,   decimateCSSESymmetricRC factor vCoeffsHalf  num vInput),
                (hasAVX,     decimateCAVXRC2         factor vCoeffs  num vInput),
                (hasAVX,     decimateCAVXSymmetricRC factor vCoeffsHalf  num vInput)
            ]
        assert res

    propResamplingReal =
        forAll sizes $ \size ->
            forAll (vectorOf size (choose (-10, 10))) $ \inBuf ->
                forAll (elements [32 .. 512]) $ \numCoeffs ->
                    forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs ->
                       forAll (elements $ tail factors') $ \decimation ->
                           forAll (elements $ filter (< decimation) factors') $ \interpolation ->
                               forAll (elements [0..interpolation - 1]) $ \group ->
                                   testResamplingReal size group numCoeffs interpolation decimation coeffs inBuf

    testResamplingReal :: Int -> Int -> Int -> Int -> Int -> [Float] -> [Float] -> Property
    testResamplingReal size group numCoeffs interpolation decimation coeffs inBuf = monadicIO $ do
        let vCoeffsHalf = VS.fromList coeffs
            vCoeffs     = VS.fromList $ coeffs ++ reverse coeffs
            vInput      = VS.fromList inBuf
            num         = (size - numCoeffs*2 + 1) `quot` decimation
            offset       = interpolation - 1 - ((interpolation + group * decimation - 1) `mod` interpolation)

        resampler3 <- run $ resampleCRR2   interpolation decimation (coeffs ++ reverse coeffs)
        resampler4 <- run $ resampleCSSERR interpolation decimation (coeffs ++ reverse coeffs)
        resampler5 <- run $ resampleCAVXRR interpolation decimation (coeffs ++ reverse coeffs)

        res <- run $ sameResultM eqDelta $ map (getResult num) $ hasFeatures [
                (const True, void . resampleHighLevel       interpolation decimation vCoeffs offset num vInput),
                (const True, void . resampleCRR             num interpolation decimation offset vCoeffs vInput),
                (const True, void . resampler3              group num vInput),
                (hasSSE42,   void . resampler4              group num vInput),
                (hasAVX,     void . resampler5              group num vInput)
            ]
        assert res

    propResamplingComplex =
        forAll sizes $ \size ->
            forAll (vectorOf size (choose (-10, 10))) $ \inBufR ->
                forAll (vectorOf size (choose (-10, 10))) $ \inBufI ->
                    forAll (elements [32 .. 512]) $ \numCoeffs ->
                        forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs ->
                           forAll (elements $ tail factors') $ \decimation ->
                               forAll (elements $ filter (< decimation) factors') $ \interpolation ->
                                   forAll (elements [0..interpolation - 1]) $ \group ->
                                       testResamplingComplex size group numCoeffs interpolation decimation coeffs $ zipWith (:+) inBufR inBufI

    testResamplingComplex :: Int -> Int -> Int -> Int -> Int -> [Float] -> [Complex Float] -> Property
    testResamplingComplex size group numCoeffs interpolation decimation coeffs inBuf = monadicIO $ do
        let vCoeffsHalf = VS.fromList coeffs
            vCoeffs     = VS.fromList $ coeffs ++ reverse coeffs
            vInput      = VS.fromList inBuf
            num         = (size - numCoeffs*2 + 1) `quot` decimation
            offset       = interpolation - 1 - ((interpolation + group * decimation - 1) `mod` interpolation)

        resampler3 <- run $ resampleCRC    interpolation decimation (coeffs ++ reverse coeffs)
        resampler4 <- run $ resampleCSSERC interpolation decimation (coeffs ++ reverse coeffs)
        resampler5 <- run $ resampleCAVXRC interpolation decimation (coeffs ++ reverse coeffs)

        res <- run $ sameResultM eqDeltaC $ map (getResult num) $ hasFeatures [
                (const True, void . resampleHighLevel       interpolation decimation vCoeffs offset num vInput),
                (const True, void . resampler3              group num vInput),
                (hasSSE42,   void . resampler4              group num vInput),
                (hasAVX,     void . resampler5              group num vInput)
            ]
        assert res

    propConversionRTLSDR =
        forAll sizes $ \size ->
            forAll (vectorOf (2 * size) (choose (-10, 10))) $ \inBuf ->
                testConversionRTLSDR size inBuf
    testConversionRTLSDR :: Int -> [Int] -> Property
    testConversionRTLSDR size inBuf = monadicIO $ do
        let vInput = VS.fromList $ map fromIntegral inBuf

        let res = sameResult eqDeltaC $ map VG.toList $ hasFeatures [
                (const True, (interleavedIQUnsigned256ToFloat    vInput :: VS.Vector (Complex Float))),
                (const True, interleavedIQUnsignedByteToFloat    vInput),
                (hasSSE42,   interleavedIQUnsignedByteToFloatSSE vInput),
                (hasAVX2,    interleavedIQUnsignedByteToFloatAVX vInput)
                ]
        assert res

    propConversionBladeRF =
        forAll sizes $ \size ->
            forAll (vectorOf (2 * size) (choose (-10, 10))) $ \inBuf ->
                testConversionBladeRF size inBuf
    testConversionBladeRF :: Int -> [Int] -> Property
    testConversionBladeRF size inBuf = monadicIO $ do
        let vInput = VS.fromList $ map fromIntegral inBuf

        let res = sameResult eqDeltaC $ map VG.toList $ hasFeatures [
                (const True, (interleavedIQSigned2048ToFloat   vInput :: VS.Vector (Complex Float))),
                (const True, interleavedIQSignedWordToFloat    vInput),
                (hasSSE42,   interleavedIQSignedWordToFloatSSE vInput),
                (hasAVX2,    interleavedIQSignedWordToFloatAVX vInput)
                ]
        assert res

    scales        = elements [0.1, 0.5, 1, 2, 10]
    propScaleReal =
        forAll sizes $ \size ->
            forAll (vectorOf size (choose (-10, 10))) $ \inBuf ->
                forAll scales $ \factor ->
                    testScaleReal size inBuf factor
    testScaleReal :: Int -> [Float] -> Float -> Property
    testScaleReal size inBuf factor = monadicIO $ do
        let vInput = VS.fromList inBuf

        res <- run $ sameResultM eqDelta $ map (getResult size) $ hasFeatures [
                (const True, scaleC    factor vInput),
                (hasSSE42,   scaleCSSE factor vInput),
                (hasAVX,     scaleCAVX factor vInput)
            ]
        assert res

    getResult :: (VSM.Storable a) => Int -> (VS.MVector RealWorld a -> IO b) -> IO [a]
    getResult size func = do
        outBuf <- VGM.new size
        func outBuf
        out :: VS.Vector a <- VG.freeze outBuf
        return $ VG.toList out
    eqDelta x y = all (uncurry eqDelta') $ zip x y
        where
        eqDelta' x y = abs (x - y) < 0.01
    eqDeltaC x y = all (uncurry eqDelta') $ zip x y
        where
        eqDelta' x y = magnitude (x - y) < 0.01
    duplicate :: [a] -> [a]
    duplicate = concatMap func
        where func x = [x, x]

main = do
    info <- getCPUInfo
    defaultMain $ tests info

max_stars_repo_name: adamwalker/sdr

max_issues_repo_name: peixian/sdr

max_forks_repo_name: adamwalker/sdr