text:
-- | https://en.wikibooks.org/wiki/Write_Yourself_a_Scheme_in_48_Hours/Parsing

module Main where

import           Control.Monad
import           Control.Monad.Error
import           Data.Char                     (digitToInt, isDigit)
import           Data.Complex
import           Data.Ratio                    (denominator, numerator, (%))
import           Numeric                       (readDec, readFloat, readHex,
                                                readInt, readOct)
import           System.Environment
import           Text.ParserCombinators.Parsec hiding (spaces)

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

-- readExpr :: String -> Either ParseError LispVal
-- readExpr = parse parseExpr "lisp"

-- Whitespace
spaces :: Parser ()
spaces = skipMany1 space

-- Return Values
data LispVal = Atom String
             | List [LispVal]
             | DottedList [LispVal] LispVal
             | Number Integer
             | Float Double
             | Ratio Rational
             | Complex (Complex Double)
             | Character Char
             | String String
             | Bool Bool

parseString :: Parser LispVal
parseString = do
  char '"'
  str <- many (parseHelper <|> noneOf "\\\"")
  char '"'
  return $ String str
  <?> "a string for parseString"
  where parseHelper :: Parser Char
        parseHelper = do
          char '\\'
          x <- oneOf "\\\"nrt"
          return $ case x of
            '\\' -> x
            '"'  -> x
            'n'  -> '\n'
            'r'  -> '\r'
            't'  -> '\t'

parseAtom :: Parser LispVal
parseAtom = do
  first <- letter <|> symbol
  rest <- many $ letter <|> symbol <|> digit
  return $ Atom (first : rest)
  <?> "a atom for parseAtom"

parseBool :: Parser LispVal
parseBool = do
  x <- try (string "#t") <|> string "#f"
  return $ if x == "#t"
           then Bool True
           else Bool False

parseNumber :: Parser LispVal
parseNumber = parseDigit <|> try parseOct <|> try parseDec <|> try parseHex <|> parseBin
  where parseOct = do
          char '#' >> oneOf "oO"
          str <- many1 octDigit
          let [(n, _)] = readOct str
          return $ Number n
        parseDec = do
          char '#' >> oneOf "dD"
          str <- many1 digit
          let [(n, _)] = readDec str
          return $ Number n
        parseHex = do
          char '#' >> oneOf "xX"
          str <- many1 hexDigit
          let [(n, _)] = readHex str
          return $ Number n
        parseBin = do
          char '#' >> oneOf "bB"
          str <- many1 $ oneOf "01"
          let [(n, _)] = readInt 2 (`elem` "01") digitToInt str
          return $ Number n
        parseDigit = do
          str <- many1 digit
          return $ (Number . read) str

parseChar :: Parser LispVal
parseChar = do
  string "#\\"
  x <- many $ letter <|> digit
  return $ case length x of
    0 -> Character '\n'
    1 -> Character $ head x
    _ -> case x of
      "newline" -> Character '\n'
      "tab"     -> Character '\t'
      "space"   -> Character ' '

parseFloat :: Parser LispVal
parseFloat = do
  x <- many1 digit
  char '.'
  y <- many1 digit
  return $ let [(n, _)] = readFloat (x ++ '.' : y) in Float n

parseRatio :: Parser LispVal
parseRatio = do
  x <- many1 digit
  char '/'
  y <- many1 digit
  return $ Ratio (read x % read y)

parseComplex :: Parser LispVal
parseComplex = do
  x <- try parseFloat <|> parseNumber
  char '+'
  y <- try parseFloat <|> parseNumber
  char 'i'
  return $ Complex (toDouble x :+ toDouble y)
  where toDouble :: LispVal -> Double
        toDouble (Float f) = f
        toDouble (Number n) = fromIntegral n

-- Recursive Parsers: Adding lists, dotted lists, and quoted datums

parseList :: Parser LispVal
parseList = do
  char '('
  x <- sepBy parseExpr spaces
  char ')'
  return $ List x

parseDottedList :: Parser LispVal
parseDottedList = do
  char '('
  x <- endBy parseExpr spaces
  y <- char '.' >> spaces >> parseExpr
  char ')'
  return $ DottedList x y

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

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

parseUnquote :: Parser LispVal
parseUnquote = do
  char ','
  y <- parseExpr
  return $ List [Atom "unquote", y]

parseUnquoteSplicing :: Parser LispVal
parseUnquoteSplicing = do
  char ',' >> char '@'
  y <- parseExpr
  return $ List [Atom "unquote-splicing", y]

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

-- Beginning the Evaluator
showVal :: LispVal -> String
showVal (Atom x) = x
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (Ratio x) = show (numerator x) ++ ('/' : show (denominator x))
showVal (Complex x) = show (realPart x) ++ ('+' : show (imagPart x) ++ "i")
showVal (Float x) = show x
showVal (Number x) = show x
showVal (Character x) = "#\\" ++ show x
showVal (String x) = "\"" ++ x ++ "\""
showVal (List x) = "(" ++ unwordsList x ++ ")"
showVal (DottedList first rest)= "(" ++ unwordsList first ++ " . " ++ showVal rest ++ ")"

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

instance Show LispVal where
  show = showVal

readExpr :: String -> ThrowsError LispVal
readExpr input = case parse parseExpr "lisp" input of
  Left err -> throwError $ Parser err
  Right val -> return val

-- Beginnings of an evaluator: Primitives
-- main :: IO ()
-- main = getArgs >>= print . eval . readExpr . head
main :: IO ()
main = do
  args <- getArgs
  evaled <- return $ liftM show $ readExpr (head args) >>= eval
  putStrLn $ extractValue $ trapError evaled

eval :: LispVal -> ThrowsError LispVal
eval val@(String _) = return val
eval val@(Bool _) = return val
eval val@(Ratio _) = return val
eval val@(Complex _) = return val
eval val@(Float _) = return val
eval val@(Number _) = return val
eval val@(Character _) = return val
eval (List [Atom "quote", val]) = return val

-- Adding basic primitives
eval (List (Atom func : args)) = mapM eval args >>= apply func

apply :: String -> [LispVal] -> ThrowsError LispVal
apply func args = maybe (throwError $ NotFunction "No such function: " func)
                  ($ args)
                  (lookup func primitives)

primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
primitives = [("+", numericBinop (+)),
              ("-", numericBinop (-)),
              ("*", numericBinop (*)),
              ("/", numericBinop div),
              ("mod", numericBinop mod),
              ("quotient", numericBinop quot),
              ("remainder", numericBinop rem),
              ("symbol?", unaryOp symbolp),
              ("string?", unaryOp stringp),
              ("number?", unaryOp numberp),
              ("bool?", unaryOp boolp),
              ("list?", unaryOp listp),
              ("pair?", unaryOp pairp),
              ("symbol->string", unaryOp symbol2String),
              ("string->symbol", unaryOp string2Symbol)]

numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
numericBinop _ [] = throwError $ NumArgs 2 []
numericBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal
numericBinop op args = mapM unpackNum args >>= return . Number . foldl1 op
  where unpackNum :: LispVal -> ThrowsError Integer
        unpackNum (Number n) = return n
        -- unpackNum (String n) = let parsed = readDec n in
          -- if null parsed
          -- then 0
          -- else fst $ head parsed
        -- unpackNum (List [n]) = unpackNum n
        unpackNum notNum = throwError $ TypeMismatch "number" notNum

unaryOp :: (LispVal -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal
unaryOp op [x] = op x
unaryOp _ wrongArg = throwError $ NumArgs 1 wrongArg

symbolp :: LispVal -> ThrowsError LispVal
symbolp (Atom _) = return $ Bool True
symbolp _ = return $ Bool False

stringp :: LispVal -> ThrowsError LispVal
stringp (String _) = return $ Bool True
stringp _ = return $ Bool False

numberp :: LispVal -> ThrowsError LispVal
numberp (Number _) = return $ Bool True
numberp _ = return $ Bool False

boolp :: LispVal -> ThrowsError LispVal
boolp (Bool _) = return $ Bool True
boolp _ = return $ Bool False

listp :: LispVal -> ThrowsError LispVal
listp (List _) = return $ Bool True
listp _ = return $ Bool False

pairp :: LispVal -> ThrowsError LispVal
pairp (List _) = return $ Bool True
pairp (DottedList _ _) = return $ Bool True
pairp _ = return $ Bool False

symbol2String :: LispVal -> ThrowsError LispVal
symbol2String (Atom x) = return $ String x
symbol2String mismatch = throwError $ TypeMismatch "atom" mismatch

string2Symbol :: LispVal -> ThrowsError LispVal
string2Symbol (String x) = return $ Atom x
string2Symbol mismatch = throwError $ TypeMismatch "string" mismatch

-- Error Checking and Exceptions
data LispError = NumArgs Integer [LispVal]
               | TypeMismatch String LispVal
               | Parser ParseError
               | BadSpecialForm String LispVal
               | NotFunction String String
               | UnboundVar String String
               | Default String

showError :: LispError -> String
showError (UnboundVar message varname)  = message ++ ": " ++ varname
showError (BadSpecialForm message form) = message ++ ": " ++ show form
showError (NotFunction message func)    = message ++ ": " ++ show func
showError (NumArgs expected found)      = "Expected " ++ show expected
                                          ++ " args; found values " ++ unwordsList found
showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected
                                          ++ ", found " ++ show found
showError (Parser parseErr)             = "Parse error at " ++ show parseErr

instance Show LispError where show = showError

instance Error LispError where
  noMsg = Default "An error has occurred"
  strMsg = Default

type ThrowsError = Either LispError

trapError :: (MonadError e m, Show e) => m String -> m String
trapError action = catchError action (return . show)

extractValue :: ThrowsError a -> a
extractValue (Right val) = val

max_stars_repo_name: zeqing-guo/Haskell-Exercises

max_issues_repo_name: zeqing-guo/Haskell-Exercises

max_forks_repo_name: zeqing-guo/Haskell-Exercises


text:
{-# LANGUAGE OverloadedStrings #-}

module Main where

import Prelude hiding (readFile, drop)
import Control.Monad
import Control.Monad.IO.Class
import Control.Exception
import Foreign.C.Types
import System.Random
import Numeric.LinearAlgebra
import Numeric.LinearAlgebra.Data
import SDL
import Debug.Trace
import qualified Linear
import Data.List.Split (chunksOf)

import Neural
import MNIST

-- Generates a layer with a given number of neurons with inputCount weights.
-- Weights are randomised between 0 and 1.
genLayer :: Int -> Int -> IO Layer
genLayer neurons inputCount = do
  weights <- replicateM (neurons * inputCount) (randomRIO (-0.2, 0.2) :: IO R)
  biases <- replicateM (neurons) (randomRIO (-0.2, 0.2) :: IO R)
  return $ Layer (matrix inputCount weights) (vector biases)

-- Generates a network with the specified number of neurons in each layer,
-- and the number of inputs to the network.
-- Initialised with random weights and biases as in genLayer.
genNetwork :: [Int] -> Int -> IO Network
genNetwork layers inputCount = sequence . map (uncurry genLayer) $ layerDefs
  where
    -- Layer definitions in the form (neuronCount, inputCount)
    layerDefs = zip layers (inputCount:layers)

-- A test network
testNetwork :: IO Network
testNetwork = do
  l1 <- genLayer 5 3
  l2 <- genLayer 5 5
  l3 <- genLayer 1 5
  return [l1, l2, l3]

-- Another test network
testNetwork2 :: Network
testNetwork2 = [hiddenLayer, outputLayer]
  where
    hiddenLayer = Layer (matrix 2 [0.15, 0.2, 0.25, 0.3]) (vector [0.35, 0.35])
    outputLayer = Layer (matrix 2 [0.4, 0.45, 0.5, 0.55]) (vector [0.6, 0.6])

-- Test inputs for testNetwork2
testInputs = vector [0.05, 0.1]

-- Training data for testInputs
trainingData = vector [0.01, 0.99]

-- Train neural network
trainNet = do
  (imageCount, width, height, imageData) <- readMNISTImages "train-images-idx3-ubyte"
  (labelCount, labels) <- readMNISTLabels "train-labels-idx1-ubyte"

  let image = head imageData
  let input = vector (map fromIntegral image)
  let correctNumber = fromIntegral . head $ labels
  let training = vector $ map (\i -> if i == correctNumber then 1.0 else 0.0) [1..10]

  hiddenLayer <- genLayer 20 (width * height)
  outputLayer <- genLayer 10 20

  let initialNetwork = [hiddenLayer, outputLayer]

  let loop net i err =
        case i > 1000 || err < 0.1 of
          True  -> net
          False -> trace (show $ sumElements (last error)) $ loop nextNet (i+1) (sumElements (last error))
            where
              output = evalNetwork net input
              error = evalNetworkError net output input training
              nextNet = gradientDescent net input (map fst output) error 0.1

  let trainedNet = loop initialNetwork 0 1000

  return (input, initialNetwork, trainedNet, training)

-- Train neural network
trainNetM = do
  (imageCount, width, height, imageData) <- readMNISTImages "train-images-idx3-ubyte"
  (labelCount, labels) <- readMNISTLabels "train-labels-idx1-ubyte"

  let image = head imageData
  let input = fromRows [vector (map fromIntegral image)]
  let correctNumber = fromIntegral . head $ labels
  let training = fromRows [vector $ map (\i -> if i == correctNumber then 1.0 else 0.0) [1..10]]

  hiddenLayer <- genLayer 20 (width * height)
  outputLayer <- genLayer 10 20

  let initialNetwork = [hiddenLayer, outputLayer]

  let loop net i err =
        case i > 100000 || err < 0.1 of
          True  -> net
          False -> trace (show $ sumElements (last error)) $ loop nextNet (i+1) (sumElements (last error))
            where
              output = evalNetworkM net input
              error = evalNetworkErrorM net output input training
              nextNet = gradientDescentM net input (map fst output) error 0.1

  let trainedNet = loop initialNetwork 0 1000

  return (input, initialNetwork, trainedNet, training)

-- Make a window and show MNIST image
window image width height = do
  initializeAll

  window <- createWindow "SDL Application" defaultWindow
  renderer <- createRenderer window (-1) defaultRenderer

  -- Convert to sdl texture
  texture <- loadTextureMNIST renderer width height image

  SDL.rendererDrawColor renderer $= Linear.V4 255 255 255 255
  SDL.clear renderer

  copy renderer texture Nothing Nothing

  present renderer

  let loop = do
        pollEvents

        keyState <- getKeyboardState

        case keyState ScancodeEscape of
          True -> (return ()) :: IO ()
          False -> loop

  loop

  destroyTexture texture
  destroyRenderer renderer
  destroyWindow window

-- Train a network using a given set of inputs and training values for the given
-- number of epochs using the given learning rate.
trainNetwork :: Network -> [Vector R] -> [Vector R] -> Int -> Int -> R -> Network
trainNetwork initialNet input trainingValues epochs batchSize learnRate =
  train initialNet 0
    where
      train net epoch = case epoch >= epochs of
        True  -> net
        False -> train nextNet (epoch + 1)
          where
            --inputBatch = fromRows input
            --trainingBatch = fromRows trainingValues
            inputBatches = map fromRows . chunksOf batchSize $ input
            trainingBatches = map fromRows . chunksOf batchSize $ trainingValues
            nextNet = foldl runBatch net (zip inputBatches trainingBatches)
            --nextNet = net
            runBatch network (inputBatch, trainingBatch) =
              gradientDescentM net inputBatch (map fst output) error learnRate
                where
                  output = evalNetworkM net inputBatch
                  error = evalNetworkErrorM net output inputBatch trainingBatch

toOutput = \n -> vector . map (\x -> if n == x then 1.0 else 0.0) $ [0..9]

fromOutput :: Vector R -> Int
fromOutput v = guess
  where
    list = zip [0..] . toList $ v
    possibles = filter ((>=0.5) . snd) list
    guess = case length possibles of
              0 -> -1
              1 -> fst . head $ possibles
              _ -> -2

runTest :: Network -> ([CUChar], Int) -> Bool
runTest network (image, label) = guess == label
  where output = fst . last $ evalNetwork network $ vector . map fromIntegral $ image
        guess = fromOutput output

--runTest :: Network -> ([CUChar], Int) -> IO ()
--runTest network (image, label) = do
--  let output = fst . last $ evalNetwork network $ vector . map fromIntegral $ image
--  let guess = fromOutput output
--  let expected = label
--  putStr "Guess: "
--  putStr . show $ guess
--  putStr ",\tExpected: "
--  putStr . show $ label
--  putStr $ if guess == expected then ".\tCorrect! " else ".\tINCORRECT!"
--  putStrLn ""

main = do

  (trainingImageCount, trainingWidth,
   trainingHeight, trainingImageData)  <- readMNISTImages "train-images-idx3-ubyte"
  (trainingLabelCount, trainingLabels) <- readMNISTLabels "train-labels-idx1-ubyte"

  (testImageCount, testWidth,
   testHeight, testImageData)  <- readMNISTImages "t10k-images-idx3-ubyte"
  (testLabelCount, testLabels) <- readMNISTLabels "t10k-labels-idx1-ubyte"

  assert (trainingWidth == testWidth && trainingHeight == testHeight) (return ())

  let input = take 60000 . map (vector . map fromIntegral) $ trainingImageData
  let trainingData = take 60000 . map toOutput $ trainingLabels

  initialNetwork <- genNetwork [20,10] (trainingWidth * trainingHeight)

  let trainedNetwork = trainNetwork initialNetwork input trainingData 2 10 3.0

  let testImage = head testImageData
  let testInput = vector . map fromIntegral $ testImage
  let testOutput = head testLabels --toOutput $ head testLabels

  --window testImage testWidth testHeight

  --let output = fst . last $ evalNetwork trainedNetwork testInput
  --let filteredOutput = map (>=0.5) . toList $ output

  --print $ fromOutput output
  --print $ testOutput

  let tests = map (runTest trainedNetwork) $ zip testImageData testLabels

  let success = length . filter (==True) $ tests
  let total = length tests

  putStr . show $ success
  putStr "/"
  putStrLn . show $ total

  --flip mapM_ (take 100 $ zip testImageData testLabels) runTest
  --  where
  --    runTest (imageData, label) = output
  --      where
  --        output2 = evalNetwork trainedNetwork
  --        output = putStrLn "test"
  --      --let output = evalNetwork trainedNetwork (vector . map fromIntegral $ imageData)
  --      --in do
  --      --  putStr "Guess: "
  --      --  putStr . show . fromOutput $ output

ext: hs

max_stars_repo_name: Catchouli/neuron

max_issues_repo_name: Catchouli/neuron

max_forks_repo_name: Catchouli/neuron


text:
module Scene.Object.Plane where

import Scene.Base
import Math.Color
import Math.Ray
import Numeric.LinearAlgebra

-- Sphere
plane' :: Material -> Ray -> Object
plane' mat r = Object (plane_intercept r) mat

plane mat ray = [plane' mat ray]

plane_intercept :: Ray -> Ray -> Maybe (Double,Ray)
plane_intercept (Ray p normal) incidence@(Ray q v) =
    let
        v_orth = v <.> normal
        pq_orth = (p-q) <.> normal
        lambda = pq_orth / v_orth
    in if lambda > 0
        then Just (lambda, Ray (parametric incidence lambda) (scale (-signum (v_orth)) normal))
        else Nothing

max_stars_repo_name: danrocag/raytracer

max_issues_repo_name: danrocag/raytracer

max_forks_repo_name: danrocag/raytracer


text:
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators   #-}
module GenerateInParallel where

import Data.Complex
import Control.Monad
import Codec.Picture
import Data.Array.Repa
import Data.Word

import Mand

generateInParallel = do
  mapM_ (\ x-> (computeUnboxedP $ repaMandArray x (-2) (-2) (0.0025) 1600 1600) >>= (savePngImage ("./repatestcol" Prelude.++ show x Prelude.++ ".png") . ImageRGB8 . toImage)  ) [2..3]

  --img <- computeUnboxedP $ repaMandArray (-2) (-2) (0.0005) 8000 8000
  --(savePngImage "./repatest1.png" . ImageRGB8 . toImage) img

repaMandArray :: Int -> Double -> Double -> Double -> Int -> Int -> Array D DIM2 Word16
repaMandArray pow start_re start_im step width height = fromFunction (Z :. width :. height) (arrayToMand pow start_re start_im step)

arrayToMand :: Int -> Double -> Double -> Double ->  Z :. Int :. Int -> Word16
arrayToMand pow start_re start_im step (Z :. x :. y) =  fromIntegral $ general (mand_pow_iteration pow) Nothing ((start_re + (fromIntegral x) * step ) :+(start_im + step * (fromIntegral y) ) ) 32767

toImage :: Array U DIM2 Word16 -> Image PixelRGB8
toImage a = generateImage gen width height
  where
    Z :. width :. height = extent a
    gen x y =
      let d = a ! (Z :. x :. y)
      in PixelRGB8 (fromIntegral $ 2 * mod d 128) (fromIntegral $ 2* mod (div d 128) 128) ( fromIntegral $ 2 * div d 16384)

max_stars_repo_name: AlwinHughes/fractal

max_issues_repo_name: AlwinHughes/fractal

max_forks_repo_name: AlwinHughes/fractal


text:
module Fuml.Base.LinearRegression where

import Numeric.LinearAlgebra

-- | Ordinary least squares
ols :: [(Vector Double, Double)] -> Vector Double
ols xys =
  let x = fromRows $ map fst xys
      y = col $ map snd xys
      betaMat = inv (tr' x <> x) <> tr' x <> y
  in tr' betaMat ! 0

-- | Weighted ordinary least squares
wols :: Vector Double -> [(Vector Double, Double)] -> Vector Double
wols wvs xys =
  let w = diag wvs
      x = fromRows $ map fst xys
      y = col $ map snd xys
      betaMat = inv (tr' x <> w <> x) <> tr' x <> w <> y
  in tr' betaMat ! 0

-- | Ridge regression
ridge :: Matrix Double -> [(Vector Double, Double)] -> Vector Double
ridge gamma xys =
  let x = fromRows $ map fst xys
      y = col $ map snd xys
      betaMat = inv (tr' x <> x + tr' gamma <> gamma) <> tr' x <> y
  in tr' betaMat ! 0

max_stars_repo_name: ekalosak/open

max_issues_repo_name: ekalosak/open

max_forks_repo_name: ekalosak/open


text:
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE IncoherentInstances #-}

module Test.Utils where

import Test.Tasty.QuickCheck
import Data.Complex
import Data.Matrix.Static.LinearAlgebra
import Data.Singletons
import qualified Data.Matrix.Static.Dense as D
import qualified Data.Matrix.Static.Sparse as S
import Data.Vector.Storable (Storable)
import Data.List.Ordered
import qualified Data.Vector as V
import Data.Ord
import qualified Data.Vector.Generic as G
import Data.AEq
import Control.Monad

class Approx a where
    (~=) :: a -> a -> Bool
    infixl 4 ~=

instance Approx Double where
    a ~= b = abs (a - b) < 1e-10

instance Approx Float where
    a ~= b = abs (a - b) < 1e-3

instance Approx (Complex Double) where
    a ~= b = r1 ~= r2 && i1 ~= i2
      where
        (r1, i1) = polar a
        (r2, i2) = polar b

instance (SingI m, SingI n, G.Vector v Bool, G.Vector v a, Approx a) =>
    Approx (D.Matrix m n v a) where
        m1 ~= m2 = D.all id $ D.zipWith (~=) m1 m2

instance (G.Vector v a, Arbitrary a, SingI m, SingI n)
    => Arbitrary (D.Matrix m n v a) where
        arbitrary = D.fromList <$> vector (m*n)
          where
            m = fromIntegral $ fromSing (sing :: Sing m)
            n = fromIntegral $ fromSing (sing :: Sing n)
        shrink _v = []

instance (G.Vector v a, Arbitrary a, SingI m, SingI n, S.Zero a)
    => Arbitrary (S.SparseMatrix m n v a) where
        arbitrary = do
            vals <- filter (/=S.zero) <$> vector p
            xs <- fmap (nubSortBy (comparing fst)) $ forM vals $ \v -> do
                i <- choose (0, m-1)
                j <- choose (0, n-1)
                return ((i,j),v)
            return $ S.fromTriplet $ V.fromList $ map (\((a,b),c) -> (a,b,c)) xs
          where
            p = (m * n) `div` 10
            m = fromIntegral $ fromSing (sing :: Sing m)
            n = fromIntegral $ fromSing (sing :: Sing n)
        shrink _v = []

max_stars_repo_name: kaizhang/matrix-sized

max_issues_repo_name: kaizhang/matrix-sized

max_forks_repo_name: kaizhang/matrix-sized


text:
{-# LANGUAGE RankNTypes,
             ScopedTypeVariables,
             ViewPatterns,
             TypeFamilies,
             TypeOperators,
             RankNTypes,
             MultiWayIf,
             DataKinds,
             LambdaCase,
             ConstraintKinds,
             FlexibleContexts #-}

module Networks where

import Optimierung
import Tuple
import Numeric.LinearAlgebra.Static.Backprop
import Numeric.Backprop
import GHC.TypeNats
import qualified Numeric.LinearAlgebra.Static as H
import qualified Control.Foldl as L
import qualified Data.Vector.Storable as V

type KN i o = (KnownNat i, KnownNat o)
type Fehler a b = forall z. Reifies z W => BVar z a -> BVar z a -> BVar z b
type Res p a b c = forall z. Reifies z W => BVar z (a :& b) -> BVar z p -> BVar z c

type Modell p a b =
       forall z. Reifies z W
    => BVar z p
    -> BVar z a
    -> BVar z b

withScalarActivation :: (Reifies z W, KnownNat i)
                     => (BVar z Double -> BVar z Double)
                     -> BVar z (R i :& Double)
                     -> BVar z (R i)
                     -> BVar z Double
withScalarActivation f (w :&& b) v = f $ w <.> v + b

withActivation :: (Reifies z W, KN i o)
               => (BVar z (R o) -> BVar z (R o))
               -> BVar z (L o i :& R o)
               -> BVar z (R i)
               -> BVar z (R o)
withActivation f (w :&& b) v = f $ w #> v + b

logistic :: Floating a => a -> a
logistic x = 1 / (1 + exp (-x))

linear :: KnownNat i => Modell (R i :& Double) (R i) Double
linear = withScalarActivation id

linear2 :: KnownNat i => Modell (R i :& Double) (R i) Double
linear2 (w :&& b) x = w <.> x + b

sigmoid :: KN i o => Modell (L o i :& R o) (R i) (R o)
sigmoid = withActivation logistic

--todo: dvmap isn't actually made differentiable, manually make Op
leakyReLU :: KN i o => Modell (L o i :& R o) (R i) (R o)
leakyReLU = withActivation $ dvmap $ \x -> if (x < 0) then 0.01*x
                                                      else x

sigmoidNoBias :: KN i o => Modell (L o i) (R i) (R o)
sigmoidNoBias w v = logistic $ w #> v

sigmoid' :: KnownNat i => Modell (R i :& Double) (R i) Double
sigmoid' = withScalarActivation logistic

se :: Fehler Double Double
se x a = (x - a)^2

se' :: (KnownNat n, 1 <= n) => Fehler (R n) Double
se' a e = (d <.> d) / 2
    where d = e - a

crossentropy' :: (KnownNat n, 1 <= n) => Fehler (R n) Double
crossentropy' a y = vsum . nanToNum . negate $ entropy y a + entropy (1-y) (1-a)
    where entropy x y = x * log y

crossentropyUnsafe' :: (KnownNat n, 1 <= n) => Fehler (R n) Double
crossentropyUnsafe' a y = vsum . negate $ entropy y a + entropy (1-y) (1-a)
    where entropy x y = x * log y

crossentropy :: (KnownNat n, 1 <= n) => R n -> R n -> Double
crossentropy a y = (H.konst 1) H.<.> (entropy (-y) a - entropy (1-y) (1-a))
    where entropy x y = x * log y

logisticSample :: KN i o => (L o i :& R o) -> Int -> R i -> R o
logisticSample (w :& b) s v = H.zipWithVector (\x p -> if x < p then 1 else 0) r probs
    where probs = logistic $ w H.#> v + b
          r     = H.randomVector s H.Uniform

nonModelLogistic :: KN i o => (L o i :& R o) -> R i -> R o
nonModelLogistic (w :& b) v = logistic $ w H.#> v + b

vsum :: (Reifies z W, KnownNat n) => BVar z (R n) -> BVar z Double
vsum x = (konst 1) <.> x

rbmcd1 :: KN d h => Int -> (L d h :& R d :& R h) -> R d -> (L d h :& R d :& R h)
rbmcd1 s (w :& b :& c) v1 = (H.outer v1 h1 - H.outer v2 h2) :& (v1 - v2) :& (h1 - h2)
    where h1 = (logisticSample (H.tr w :& c) s v1)
          v2 = (nonModelLogistic (w :& b) h1)
          h2 = (nonModelLogistic (H.tr w :& c) v2)

gradientStep :: (Backprop p, Backprop b, Backprop c)
             => Modell p a b  -- ^ Modell zum Trainieren
             -> Fehler b c    -- ^ Fehlerfunktion
             -> p             -- ^ Parameter am Anfang des Schrittes
             -> (a, b)        -- ^ (Eingabedatum, erwartete Antwort)
             -> p             -- ^ Gradient des Parameters
gradientStep mod err param (vec, trg) = gradBP (\p -> err (mod p (auto vec)) (auto trg)) param

makeFoldAll :: Optimierung d p
         => d p
         -> (p -> a -> p)
         -> p
         -> L.Fold a p
makeFoldAll d f p0 = L.Fold (\x a -> regel d x (f (aus x) a)) (start p0) aus

uberwachtesFold :: (Optimierung d p, Backprop p, Backprop b, Backprop c)
                => d p
                -> Modell p a b
                -> Fehler b c
                -> p
                -> L.Fold (a, b) p
uberwachtesFold op mod err p0 = makeFoldAll op (gradientStep mod err) p0

isVecNaN :: KnownNat n => R n -> Bool
isVecNaN = V.foldl (\acc x -> acc || isNaN x) False . H.extract

nanToNum :: (KnownNat n, Reifies z W) => BVar z (R n) -> BVar z (R n)
nanToNum = vmap bvToNum

bvToNum :: Reifies z W => BVar z Double -> BVar z Double
bvToNum = liftOp1 . op1 $ \x -> ((if
                            | isNaN x      -> 0.0
                            | isInfinite x -> if x < 0 then -1.7976931348623157e+308
                                                       else  1.7976931348623157e+308
                            | otherwise    -> x), id)

supervised :: (Backprop a, Backprop p, Backprop b, Backprop c)
           => Fehler b c
           -> Modell p a b
           -> Res p a b c
supervised err mod (a :&& y) ps = err (mod ps a) y

class Optimizable m where
    type Params m
    type In     m
    gradient :: m -> Params m -> In m -> Params m

makeFoldOptimizable :: (Optimizable m, Optimierung d (Params m))
                    => m
                    -> d (Params m)
                    -> Params m
                    -> L.Fold (In m) (Params m)
makeFoldOptimizable m d p0 = L.Fold (\x a -> regel d x (step (aus x) a)) (start p0) aus
    where step = gradient m

(<~) :: (Backprop p, Backprop q)
     => Modell  p       b c
     -> Modell      q  a b
     -> Modell (p :& q) a c
(f <~ g) (p :&& q) = f p . g q

infixr 8 <~

max_stars_repo_name: QQMBR/BLL-FP-NN

max_issues_repo_name: QQMBR/BLL-FP-NN

max_forks_repo_name: QQMBR/BLL-FP-NN


text:
{-# LANGUAGE TypeOperators   #-}

module Main where

import Data.Complex
import Data.Word8
import Codec.Picture
import qualified Data.Array.Repa as R
import Data.Array.Repa (Array, DIM1, DIM2, U, D, Z (..), (:.)(..), (!))

-- Type that represents a single Pixel that will be used by Repa
type RGB8 = (Pixel8, Pixel8, Pixel8)

maxIterations :: Int
maxIterations = 255

imgWidth :: Int
imgWidth = 1920

imgHeight :: Int
imgHeight = 1080

imgPath :: String
imgPath = "./mandel.png"

f :: RealFloat a => Complex a -> Complex a -> Complex a
f c z = z^2 + c

fractal :: RealFloat a => Complex a -> Complex a -> Int
fractal c init = length . takeWhile (\x -> magnitude x <= 2) . take maxIterations $ iterated
    where iterated = iterate (f c) init

scaleInterval :: Fractional a => (a, a) -> (a, a) -> a -> a
scaleInterval (a, b) (c, d) t = c + (((d - c) * (t - a)) / (b - a))

main :: IO ()
main = do
    putStrLn $ "Writing mandelbrot set in " ++ imgPath ++ ", please wait."
    repaVectorImage <- R.computeUnboxedP generateImgRepa
    let mandelbrotImage = repaArrayToImage repaVectorImage
    writePng imgPath mandelbrotImage
    putStrLn "Image successfully written."

generatePixel :: (Z :. Int :. Int) -> RGB8
generatePixel (Z :. x :. y) = (iters, iters, iters)
    where
        iters = fromIntegral $ fractal (scX :+ scY) (0 :+ 0)
        scY = scaleInterval (0.0, fromIntegral imgHeight) (-1.0, 1.0) $ fromIntegral y
        scX = scaleInterval (0.0, fromIntegral imgWidth) (-2.0, 0.5) $ fromIntegral x

generateImgRepa :: Array D DIM2 RGB8
generateImgRepa = R.fromFunction (Z :. imgWidth :. imgHeight) generatePixel

repaArrayToImage :: Array U DIM2 RGB8 -> Image PixelRGB8
repaArrayToImage a = generateImage gen imgWidth imgHeight
  where
    gen x y =
      let (r, g, b) = a ! (Z :. x :. y)
      in PixelRGB8 r g b

max_stars_repo_name: ollenurb/mandelbrot

max_issues_repo_name: ollenurb/mandelbrot

max_forks_repo_name: ollenurb/mandelbrot


text:
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}

module Game
  ( runGame
  ) where

import           Apecs
import           ApecsExts
import           Apecs.Experimental.Reactive
import           Data.Maybe
import           Data.List (union, (\\))
import qualified Data.Vector.Storable as V
import           Control.Concurrent
import           Control.Lens hiding (Level, set)
import           Control.Monad
import           Control.Monad.Random
import           Graphics.UI.GLFW   (Key, KeyState)
import qualified Graphics.UI.GLFW   as GLFW
import           Linear.V2             (V2 (..), _x, _y)
import           Linear.Metric (distance)
import qualified Math.Geometry.Grid           as Grid
import           Math.Geometry.Grid.Octagonal (RectOctGrid, rectOctGrid)
import qualified Math.Geometry.GridMap        as GridMap
import           Numeric.Vector
import           Safe                         (headMay)

import Configuration
import qualified Dungeon
import ViewModel

newtype Position = Position Vec2i deriving (Eq, Ord, Show)
instance Component Position where type Storage Position = Reactive (OrdMap Position) (Map Position)

-- | Get list of entities that have the given Position
{-# INLINE whatsAt #-}
-- stupid ordLookup drags in MonadIO
whatsAt :: (MonadIO m, Has w m Position) => Vec2i -> SystemT w m [Entity]
whatsAt = withReactive . ordLookup . Position

{-# INLINE cmapAt #-}
cmapAt :: forall w m cx cy. (MonadIO m, Has w m Position, Get w m cx, Set w m cy)
       => Vec2i -> (cx -> cy) -> SystemT w m ()
cmapAt pos f = whatsAt pos >>= flip cmapOver f

{-# INLINE cmapMAt #-}
cmapMAt :: forall w m cx cy. (MonadIO m, Has w m Position, Get w m cx, Set w m cy)
        => Vec2i -> (cx -> SystemT w m cy) -> SystemT w m ()
cmapMAt pos sys = whatsAt pos >>= flip cmapMOver sys

{-# INLINE cfoldAt #-}
cfoldAt :: forall w m c a. (MonadIO m, Has w m Position, Get w m c)
        => Vec2i -> (a -> c -> a) -> a -> SystemT w m a
cfoldAt pos f a0 = whatsAt pos >>= \es -> cfoldOver es f a0

{-# INLINE extractAt #-}
extractAt :: forall w m c a. (MonadIO m, Has w m Position, Get w m c)
          => Vec2i -> (c -> a) -> SystemT w m (Maybe a)
extractAt pos selector = whatsAt pos >>= flip extractOver selector

{-# INLINE extractAllAt #-}
extractAllAt :: forall w m c a. (MonadIO m, Has w m Position, Get w m c)
             => Vec2i -> (c -> a) -> SystemT w m [a]
extractAllAt pos selector = whatsAt pos >>= flip extractAllOver selector

{-# INLINE existsAt #-}
existsAt :: forall w m c. (MonadIO m, Has w m Position, Get w m c) => Vec2i -> Proxy c -> SystemT w m Bool
existsAt pos p = whatsAt pos >>= \es -> existsOver es p

data Wall = Wall deriving Show
instance Component Wall where type Storage Wall = Map Wall

data Player = Player deriving Show
instance Component Player where type Storage Player = Unique Player

data Enemy = Enemy deriving Show
instance Component Enemy where type Storage Enemy = Map Enemy

newtype Time = Time Double deriving (Show, Num)
instance Semigroup Time where (<>) = error "unexpected use of Semigroup Time <>"
instance Monoid Time where mempty = 0
instance Component Time where type Storage Time = Global Time

newtype Grid = Grid RectOctGrid
instance Component Grid where type Storage Grid = Global Grid
instance Monoid Grid where mempty = Grid $ rectOctGrid 0 0
instance Semigroup Grid where (<>) = error "unexpected use of Semigroup Grid <>"

newtype KeysDown = KeysDown [Key]
instance Component KeysDown where type Storage KeysDown = Global KeysDown
deriving instance Monoid KeysDown
deriving instance Semigroup KeysDown

newtype Direction = Direction (V2 Int)
instance Component Direction where type Storage Direction = Global Direction
instance Monoid Direction where mempty = Direction $ V2 0 1
instance Semigroup Direction where (<>) = error "unexpected use of Semigroup Direction <>"

-- what about ''Camera? see Apecs.Gloss

-- creates type World and function initWorld :: IO World
makeWorld "World" [''Position, ''Wall, ''Player, ''Enemy,
                   ''Time, ''Grid, ''KeysDown,
                   ''Direction]

type System' a = System World a

initialize :: System' ()
initialize = do
  let rows = 100
      columns = 100
  level <- liftIO $ Dungeon.execLevelGen columns rows (Dungeon.rndLvl 3 20 0.7)
  let walls = map fst $ filter (isNothing . snd) $ Dungeon.allCells level
  forM_ walls $ \pos ->
    newEntity (Wall, Position pos)
  let (spawnX, spawnY) = head $ GridMap.keys . GridMap.filter isJust $ level
  _ <- newEntity (Player, Position (vec2 spawnX spawnY))
  replicateM_ 100 $ do
    place <- liftIO $ evalRandIO $ Dungeon.findRandomCell level isJust
    void $ newEntity (Enemy, Position (fst place))
  set global $ Grid $ rectOctGrid rows columns

keyToMotion :: Key -> Maybe (V2 Int)
keyToMotion key =
  case key of
    GLFW.Key'Left  -> Just $ V2 (-1) 0
    GLFW.Key'Right -> Just $ V2 1 0
    GLFW.Key'Up    -> Just $ V2 0 (-1)
    GLFW.Key'Down  -> Just $ V2 0 1
    _              -> Nothing

handleEvent :: Event -> System' ()
handleEvent (KeyEvent key keyState)
  | keyState `elem` [GLFW.KeyState'Pressed, GLFW.KeyState'Repeating]
  = do
      KeysDown keysDown <- get global
      let keysDown' = keysDown `union` [key]
      set global $ KeysDown keysDown'
      Direction dir <- get global
      forM_ (keyToMotion key) $ \motion -> do
        let dir' = signum $ dir + motion
            dir''
              -- opposite motion => opposite dir
              | dir' == 0
              = motion
              -- stuck on diagonal => motion turns dir to horiz/vert
              | dir' == dir
              = motion
              | otherwise
              = dir'
        set global $ Direction dir''
  | keyState == GLFW.KeyState'Released
  = do
      KeysDown keysDown <- get global
      let keysDown' = keysDown \\ [key]
      set global $ KeysDown keysDown'
      Direction (V2 x y) <- get global
      when (null keysDown' && keysDown == [GLFW.Key'Space]) $ do
        step (Vec2 x y)
        worldStep
handleEvent Begin
  = return ()

allows :: RectOctGrid -> Vec2i -> Bool
allows grid (Vec2 x y) = grid `Grid.contains` (x, y)

gridAllows :: Vec2i -> System' Bool
gridAllows pos = do
  Grid grid <- get global
  return $ grid `allows` pos

step :: Vec2i -> System' ()
step motion = cmapM $ \(Player, Position pos) -> do
  let pos' = pos + motion
  there <- whatsAt pos'
  ok <- gridAllows pos'
  return $ if ok && null there
    then Right $ Position pos'
    else Left ()

worldStep :: System' ()
worldStep = cmapM $ \(Player, Position playerPos, Grid grid) -> do
  cmapM $ \(Enemy, Position enemyPos) -> do
    let deltaPos@(Vec2 dx dy) = playerPos - enemyPos
        dist :: Float = sqrt (realToFrac $ dx*dx + dy*dy)
    if dist < 5
      then do
        let pos' = enemyPos + signum deltaPos
        there <- whatsAt pos'
        return $ if grid `allows` pos' && null there
          then Right $ Position pos'
          else Left ()
      else return $ Left ()
  return ()

runGame :: Chan Event -> MVar ViewModel -> MVar ViewState -> IO ()
runGame eventChan vmVar vsVar = do
  w <- initWorld
  writeChan eventChan Begin
  runWith w $ do
    initialize
    forever $ do
      event <- liftIO $ readChan eventChan
      handleEvent event
      oldVm <- liftIO $ readMVar vmVar
      vs <- liftIO $ readMVar vsVar
      newVm <- viewModelUpdate oldVm vs
      void $ liftIO $ swapMVar vmVar newVm

viewModelUpdate :: ViewModel -> ViewState -> System' ViewModel
viewModelUpdate ViewModel{ camHeight } ViewState{ aspectRatio, camPos } = do
  mayPos <- extract $ \(Player, Position pos) -> pos
  let Vec2 x y = case mayPos of
        Just pl -> pl
        Nothing -> error "player entity doesn't exist"
      playerPos = fromIntegral <$> V2 x y
      camStep = makeCamStep playerPos
      cam@(V2 camX camY) = fromMaybe playerPos camPos
      camWidth = aspectRatio * camHeight
      margin = 1 + distance playerPos cam
      left = camX - 0.5 * camWidth - margin
      right = camX + 0.5 * camWidth + margin
      top = camY - 0.5 * camHeight - margin
      bottom = camY + 0.5 * camHeight + margin
      -- rounding away from zero
      bound x =
        let x' = ceiling (abs x)
        in if x < 0 then - x' else x'
      idxs = [Vec2 x y | y <- [bound top..bound bottom], x <- [bound left..bound right]]
  Grid grid <- get global
  walls <- (V.fromList <$>) . fmap catMaybes . forM idxs $ \idx -> do
    isWall <- existsAt idx $ Proxy @Wall
    return $ if isWall then Just idx else Nothing
  enemies <- extractAll $ \(Enemy, Position pos) -> pos
  Direction (V2 dx dy) <- get global
  return ViewModel
    { camStep
    , camHeight
    , playerPos = Vec2 x y
    , dirIndicator = Vec2 dx dy
    , walls
    , enemies
    }

makeCamStep :: V2 Float -> Float -> Maybe (V2 Float) -> V2 Float
makeCamStep playerPos _ Nothing = playerPos
makeCamStep playerPos deltaT (Just camPos) = camPos''
  where
    baseSpeed = 2.5 -- approach speed in cells per second at distance 1
    minSpeed = 1.5
    dist :: V2 Float = playerPos - camPos
    vel :: V2 Float = pure baseSpeed * dist -- inherits sign of dist
    vel' = fmap (max minSpeed . abs) vel * signum vel
    step = vel' * pure deltaT
    camAt' = camPos + step
    -- now prevent overshoot
    dist' = playerPos - camAt'
    snap _ax = if signum (dist'^._ax) == signum (dist^._ax) then camAt'^._ax else playerPos^._ax
    camPos'' = V2 (snap _x) (snap _y)

max_stars_repo_name: cjay/some-roguelike

max_issues_repo_name: cjay/some-roguelike

max_forks_repo_name: cjay/some-roguelike


text:
module MachineLearning.RegressionTest
(
  tests
)

where

import Test.Framework (testGroup)
import Test.Framework.Providers.HUnit
import Test.HUnit
import Test.HUnit.Approx
import Test.HUnit.Plus

import qualified Numeric.LinearAlgebra as LA

import MachineLearning.DataSets (dataset1)

import qualified MachineLearning as ML
import MachineLearning.Regression

(x, y) = ML.splitToXY dataset1

muSigma = ML.meanStddev x
xNorm = ML.featureNormalization muSigma x
x1 = ML.addBiasDimension xNorm
zeroTheta = LA.konst 0 (LA.cols x1)

xPredict = LA.matrix 2 [1650, 3]
xPredict1 = ML.addBiasDimension $ ML.featureNormalization muSigma xPredict

theta = normalEquation (ML.addBiasDimension x) y
yExpected = hypothesis LeastSquares (ML.addBiasDimension xPredict) theta

eps = 0.0001
thetaNE = normalEquation x1 y
thetaNE_p = normalEquation_p x1 y
(thetaGD, _) = minimize (GradientDescent 0.01) LeastSquares eps 5000 RegNone x1 y zeroTheta
(thetaMBGD, _) = minimize (MinibatchGradientDescent 11711 64 0.05) LeastSquares eps 5000 RegNone x1 y zeroTheta
(thetaCGFR, _) = minimize (ConjugateGradientFR 0.1 0.1) LeastSquares eps 1500 RegNone x1 y zeroTheta
(thetaCGPR, _) = minimize (ConjugateGradientPR 0.1 0.1) LeastSquares eps 1500 RegNone x1 y zeroTheta
(thetaBFGS, _) = minimize (BFGS2 0.1 0.1) LeastSquares eps 1500 RegNone x1 y zeroTheta

tests = [ testGroup "minimize" [
            testCase "Normal Equation" $ assertVector "" 0.01 yExpected (hypothesis LeastSquares xPredict1 thetaNE)
            , testCase "Normal Equation using pseudo inverse" $ assertVector "" 0.01 yExpected (hypothesis LeastSquares xPredict1 thetaNE_p)
            , testCase "Gradient Descent" $ assertVector "" 0.01 yExpected (hypothesis LeastSquares xPredict1 thetaGD)
            , testCase "Minibatch Gradient Descent" $ assertVector "" 1100 yExpected (hypothesis LeastSquares xPredict1 thetaMBGD)
            , testCase "BFGS" $ assertVector "" 0.01 yExpected (hypothesis LeastSquares xPredict1 thetaBFGS)
            , testCase "Conjugate Gradient FR" $ assertVector "" 0.01 yExpected (hypothesis LeastSquares xPredict1 thetaCGFR)
            , testCase "Conjugate Gradient PR" $ assertVector "" 0.01 yExpected (hypothesis LeastSquares xPredict1 thetaCGPR)
            ]
        ]

max_stars_repo_name: aligusnet/mltool

max_issues_repo_name: aligusnet/mltool

max_forks_repo_name: aligusnet/mltool


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

module Cas.Internal.Def where

import           PreludeCustom
import           Data.Complex.Generic

type F = Complex Rational

instance Ord F where
   (x0:+y0) <= (x1:+y1) = x0 < x1 || x0==x1 && y0 < y1

data C      = Pi  | E               deriving (Eq, Ord, Show)
newtype X   = X    { xI    :: Int } deriving (Eq,Ord)
newtype Add = Add  { addTs :: [T] } deriving (Eq,Ord)
newtype Mul = Mul  { mulTs :: [T] } deriving (Eq,Ord)

data T   = TF   { tF    :: F    }
         | TX   { tX    :: X    }
         | TC   { tC    :: C    }
         | TAdd { tAdd  :: Add  }
         | TMul { tMul  :: Mul  }
         | TPow { tPowB :: T
                , tPowE :: T    }
         | TLn  { tLnT  :: T    }
         deriving (Eq,Ord)

data Equ    = Equ    { equT       :: T     }  deriving (Eq,Ord)
data LinSys = LinSys { linSysEqus :: [Equ] }  deriving (Eq,Ord)

data Rule   = Rule {ruleX::X, ruleT::T}
(-->) :: X -> T -> Rule
(-->) = Rule

data LinSysSolution = LinSysSolution { solutionRules :: [Rule]
                                     , constraints   :: [Equ]  }

max_stars_repo_name: vcanadi/cas

max_issues_repo_name: vcanadi/cas

max_forks_repo_name: vcanadi/cas


text:
module XAlg.Languages.Arithmetic.Expr (
-- * Core data types
  Expr (..),
  Expr_ (..),

-- * Parsing
  lit,
  term,
  expr,

-- * Evaluation
  eval

) where

import XAlg.Languages.Arithmetic.Number
import XAlg.Foundation.Recursion
import XAlg.Foundation.Core
import XAlg.Foundation.Parsing

import Data.Set
import Data.Data
import qualified Data.Map as M

import Text.Megaparsec
import Text.Megaparsec.String
import Text.Megaparsec.Expr
import Text.Megaparsec.Lexer (float)
import qualified Data.Complex as C

-- | Arithmetical expression.
data Expr = Lit Number
          | Var String
          | Plus Expr Expr
          | Minus Expr Expr
          | Mult Expr Expr
          | Div Expr Expr
          | Power Expr Expr
          | Neg Expr
          deriving (Show, Eq, Ord, Data)

infixl 6 `Plus`
infixl 6 `Minus`
infixl 8 `Mult`
infixl 8 `Div`
infixl 9 `Power`

instance Num Expr where
  (*) = Mult
  (+) = Plus
  negate = Neg
  abs = undefined
  signum = undefined
  fromInteger = Lit . Int

instance RecursiveData Expr where
  nodeEquality (Lit x)     (Lit y)     = x == x
  nodeEquality (Var x)     (Var y)     = x == x
  nodeEquality (Plus _ _)  (Plus _ _)  = True
  nodeEquality (Minus _ _) (Minus _ _) = True
  nodeEquality (Mult _ _)  (Mult _ _)  = True
  nodeEquality (Div _ _)   (Div _ _)   = True
  nodeEquality (Power _ _) (Power _ _) = True
  nodeEquality (Neg _)     (Neg _)     = True
  nodeEquality _           _           = False

  children (Lit x)       = []
  children (Var x)       = []
  children (Plus x1 x2)  = [x1,x2]
  children (Minus x1 x2) = [x1,x2]
  children (Mult x1 x2)  = [x1,x2]
  children (Div x1 x2)   = [x1,x2]
  children (Power x1 x2) = [x1,x2]
  children (Neg x)       = [x]

  mapChildren f (Lit x)       = Lit x
  mapChildren f (Var x)       = Var x
  mapChildren f (Plus x1 x2)  = recursively f x1 `Plus` recursively f x2
  mapChildren f (Minus x1 x2) = recursively f x1 `Minus` recursively f x2
  mapChildren f (Mult x1 x2)  = recursively f x1 `Mult` recursively f x2
  mapChildren f (Div x1 x2)   = recursively f x1 `Div` recursively f x2
  mapChildren f (Power x1 x2) = recursively f x1 `Power` recursively f x2
  mapChildren f (Neg x)       = Neg (recursively f x)

instance SymbolicLang Expr Number where
  variable = Var
  isVariable (Var v) = Just v
  isVariable _       = Nothing
  literal = Lit
  isLiteral (Lit x) = Just x
  isLiteral _       = Nothing
  evaluate = eval

-----------------------------------------------------------------------------
--    Functorial data type
-----------------------------------------------------------------------------

data Expr_ a = Lit_ Number
             | Var_ String
             | Plus_ a a
             | Minus_ a a
             | Mult_ a a
             | Div_ a a
             | Power_ a a
             | Neg_ a
             deriving (Functor, Foldable, Traversable, Data)

instance Fixable Expr_ Expr where
  foldFix (Lit_ x) = Lit x
  foldFix (Var_ x) = Var x
  foldFix (Plus_ x1 x2) = Plus x1 x2
  foldFix (Minus_ x1 x2) = Minus x1 x2
  foldFix (Mult_ x1 x2) = Mult x1 x2
  foldFix (Div_ x1 x2) = Div x1 x2
  foldFix (Power_ x1 x2) = Power x1 x2
  foldFix (Neg_ x) = Neg x

  unfoldFix (Lit x) = Lit_ x
  unfoldFix (Var x) = Var_ x
  unfoldFix (Plus x1 x2) = Plus_ x1 x2
  unfoldFix (Minus x1 x2) = Minus_ x1 x2
  unfoldFix (Mult x1 x2) = Mult_ x1 x2
  unfoldFix (Div x1 x2) = Div_ x1 x2
  unfoldFix (Power x1 x2) = Power_ x1 x2
  unfoldFix (Neg x) = Neg_ x

instance ParaSymb Expr_ where
  isVariable_ (Var_ v) = Just v
  isVariable_ _        = Nothing
  variable_ = Var_

deriving instance Show a => Show (Expr_ a)
deriving instance Show (Fix Expr_)

deriving instance Eq a => Eq (Expr_ a)
deriving instance Eq (Fix Expr_)

-----------------------------------------------------------------------------
--    Parsing
-----------------------------------------------------------------------------

imaginaryFloat :: Parser (C.Complex Double)
imaginaryFloat = fmap (0 C.:+)
  $ char 'i' *> float <|> float <* char 'i'

imaginaryInt :: Parser (C.Complex Double)
imaginaryInt = fmap ((0 C.:+) . fromInteger)
  $ char 'i' *> integ <|> integ <* char 'i'

imaginary :: Parser (C.Complex Double)
imaginary = imaginaryInt <|> imaginaryFloat <?> "imaginary number"

-- | Parse a numeric literal.
lit :: Parser Number
lit = try (Complex <$> imaginary)
  <|> try (Real <$> float)
  <|> Int <$> integ

-- | Parser an arithmetic expression term.
term :: Parser Expr
term = parens expr <|> var <|> Lit <$> lit <?> "term"

-- | Parse an arithmetic expression.
expr :: Parser Expr
expr = makeExprParser term table <?> "expression"

-- Must be a better way to get spaces:
table :: [[Operator Parser Expr]]
table = [ prefix "-" Neg
        , binary "^" Power
        , binary "*" Mult ++ binary "/" Div
        , binary "+" Plus ++ binary "-" Minus
        ]

instance Parsable Expr where
  exprParser = expr

-----------------------------------------------------------------------------
--    Pretty printing
-----------------------------------------------------------------------------

-- Only Minus is special, second argument has higher precedence.
showNodes :: Algebra Expr_ (Int, String)
showNodes (Lit_ x)       = (5, show x)
showNodes (Var_ x)       = (5, x)
showNodes (Plus_ x1 x2)  = (1, applyParens 1 x1 ++ " + " ++ applyParens 1 x2)
showNodes (Mult_ x1 x2)  = (3, applyParens 3 x1 ++ "*" ++ applyParens 3 x2)
showNodes (Neg_ x)       = (5, "-" ++ applyParens 5 x)
showNodes (Minus_ x1 x2) = (1, applyParens 1 x1 ++ " - " ++ applyParens 2 x2)
showNodes (Div_ x1 x2)   = (3, applyParens 3 x1 ++ "/" ++ applyParens 3 x2)
showNodes (Power_ x1 x2) = (4, applyParens 4 x1 ++ "^" ++ applyParens 4 x2)

-- target prec, (node prec, shown term) -> apply parens if necessary
applyParens :: Int -> (Int,String) -> String
applyParens t (n,str) = if n < t then parenthesize str else str

parenthesize :: String -> String
parenthesize s = "(" ++ s ++ ")"

instance Renderable Expr where
  render = snd . catamap showNodes

instance Transcribe Expr

instance XAlgLang Expr Expr_ Number

-------

countNode :: Algebra Expr_ Int
countNode (Lit_ x)       = 1
countNode (Var_ x)       = 1
countNode (Plus_ x1 x2)  = x1 + x2
countNode (Mult_ x1 x2)  = x1 + x2
countNode (Minus_ x1 x2) = x1 + x2
countNode (Div_ x1 x2)   = x1 + x2
countNode (Power_ x1 x2) = x1 + x2
countNode (Neg_ x)       = succ x

countNodes :: Expr -> Int
countNodes = catamap countNode

-------

data Mode = IntMode
          | RealMode
          | ComplexMode deriving (Eq,Ord)

instance Show Mode where
  show IntMode     = "ℤ"
  show RealMode    = "ℝ"
  show ComplexMode = "ℂ"

litMode :: Number -> Mode
litMode (Real _)   = RealMode
litMode (Int   _)   = IntMode
litMode (Complex _) = ComplexMode

modeNodes :: Algebra Expr_ Mode
modeNodes (Lit_ x)       = litMode x
modeNodes (Var_ x)       = IntMode
modeNodes (Plus_ x1 x2)  = x1 `max` x2
modeNodes (Minus_ x1 x2) = x1 `max` x2
modeNodes (Mult_ x1 x2)  = x1 `max` x2
modeNodes (Div_ x1 x2)   = x1 `max` x2
modeNodes (Power_ x1 x2) = x1 `max` x2
modeNodes (Neg_ x)       = x

---------

evalNode :: Algebra Expr_ (EvalResult Expr Number)
evalNode (Lit_ x)       = ValueResult x
evalNode (Var_ x)       = FunctionResult (singleton x) (Var x)
evalNode (Plus_ x1 x2)  = combineWith Plus (+) x1 x2
evalNode (Minus_ x1 x2) = combineWith Minus (-) x1 x2
evalNode (Mult_ x1 x2)  = combineWith Mult (*) x1 x2
evalNode (Div_ x1 x2)   = combineWith Div (/) x1 x2
evalNode (Power_ x1 x2) = combineWith Power (**) x1 x2
evalNode (Neg_ x)       = applyWith Neg negate x

evalNodeCtx :: Env Expr -> Algebra Expr_ (EvalResult Expr Number)
evalNodeCtx m (Var_ s) = case M.lookup s m of
  Just x  -> catamap (evalNodeCtx m) x
  Nothing -> FunctionResult (singleton s) (Var s)
evalNodeCtx _ x = evalNode x

eval :: Expr -> EvalResult Expr Number
eval = catamap evalNode

-- helpers

type BinaryOp a = a -> a -> a
type UnaryOp a = a -> a

combineWith :: SymbolicLang x s => BinaryOp x -> BinaryOp s -> BinaryOp (EvalResult x s)
combineWith f g (FunctionResult vs x) (FunctionResult ws y) = FunctionResult (union vs ws) (f x y)
combineWith f g (FunctionResult vs x) (ValueResult t)       = FunctionResult vs $ f x $ literal t
combineWith f g (ValueResult s)       (FunctionResult ws y) = FunctionResult ws $ f (literal s) y
combineWith f g (ValueResult s)       (ValueResult t)       = ValueResult $ g s t

applyWith :: SymbolicLang x s => UnaryOp x -> UnaryOp s -> UnaryOp (EvalResult x s)
applyWith f g (FunctionResult s x) = FunctionResult s (f x)
applyWith f g (ValueResult r)      = ValueResult (g r)

max_stars_repo_name: BlackBrane/xalg

max_issues_repo_name: BlackBrane/xalg

max_forks_repo_name: BlackBrane/xalg


text:
-- |
-- Module      :  SysmonHints
-- Copyright   :  (c) Vitaliy Rukavishnikov 2011
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  virukav@gmail.com
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Generate the Sysmon hints (suggestions) by comparing the data from sysmon
-- report to the corresponding data from the configuration.

module Database.Sybase.Sysmon.SysmonHints where
import Database.Sybase.Sysmon.Log
import Database.Sybase.Sysmon.LogTypes
import Database.Sybase.Sysmon.SysmonTypes
import Text.Printf
import Statistics.Sample
import Control.Monad.Reader
import Data.Vector (fromList)
import Data.ConfigFile
import Data.Either.Utils (forceEither)

type HintEnv a = Reader HConfig a

-- | Default configuration. To override the default configuration item
-- use ConfigFile package API.
defConfig = forceEither $ do
  let cp = emptyCP

  cp <- set cp "DEFAULT" "hiCPU" (show 85.0)
  cp <- set cp "DEFAULT" "hiIO" (show 50.0)
  cp <- set cp "DEFAULT" "hiIdle" (show 30.0)
  cp <- set cp "DEFAULT" "hiCheckDiskIO" (show 50.0)
  cp <- set cp "DEFAULT" "loCacheHits" (show 90.0)
  cp <- set cp "DEFAULT" "hiCacheWash" (show 5.0)
  cp <- set cp "DEFAULT" "loLargeIO" (show 90.0)
  cp <- set cp "DEFAULT" "loAvgDiskIO" (show 0.005)
  cp <- set cp "DEFAULT" "hiStdDeviation" (show 30.0)
  cp <- set cp "DEFAULT" "hiSwitchPerTransaction" (show 60.0)
  cp <- set cp "DEFAULT" "hiContextSwitchDue" (show 10.0)
  cp <- set cp "DEFAULT" "hiDirtyBuffers" (show 3.0)
  cp <- set cp "DEFAULT" "hiUlcSemRequests" (show 10.0)
  cp <- set cp "DEFAULT" "hiLogSemRequests" (show 10.0)
  cp <- set cp "DEFAULT" "hiAvgLogWrites" (show 1.0)
  cp <- set cp "DEFAULT" "hiCommitedTrans" (show 50)
  cp <- set cp "DEFAULT" "hiPageSplits" (show 10)
  cp <- set cp "DEFAULT" "hiLockSummary" (show 10.0)
  cp <- set cp "DEFAULT" "hiDeadlock" (show 10.0)
  cp <- set cp "DEFAULT" "hiLastPageLock" (show 10.0)
  cp <- set cp "DEFAULT" "hiLockPromotions" (show 20)
  cp <- set cp "DEFAULT" "loCacheSpinContention" (show 10.0)
  cp <- set cp "DEFAULT" "ioDelayBy" "Disk"
  return cp

-- | Create Sysmon configuration from ConfigParser
mkConfig :: ConfigParser -> HConfig
mkConfig c = let cp = Data.ConfigFile.merge defConfig c in
  HConfig {
    hiCPU = forceEither $ get cp "Sysmon" "hiCPU",
    hiIO = forceEither $ get cp "Sysmon" "hiIO",
    hiIdle = forceEither $ get cp "Sysmon" "hiIdle",
    hiCheckDiskIO = forceEither $ get cp "Sysmon" "hiCheckDiskIO",
    loCacheHits = forceEither $ get cp "Sysmon" "loCacheHits",
    hiCacheWash = forceEither $ get cp "Sysmon" "hiCacheWash",
    loLargeIO = forceEither $ get cp "Sysmon" "loLargeIO",
    loAvgDiskIO = forceEither $ get cp "Sysmon" "loAvgDiskIO",
    hiStdDeviation = forceEither $ get cp "Sysmon" "hiStdDeviation",
    hiSwitchPerTransaction = forceEither $ get cp "Sysmon" "hiSwitchPerTransaction",
    hiContextSwitchDue = forceEither $ get cp "Sysmon" "hiContextSwitchDue",
    hiDirtyBuffers = forceEither $ get cp "Sysmon" "hiDirtyBuffers",
    hiUlcSemRequests = forceEither $ get cp "Sysmon" "hiUlcSemRequests",
    hiLogSemRequests = forceEither $ get cp "Sysmon" "hiLogSemRequests",
    hiAvgLogWrites = forceEither $ get cp "Sysmon" "hiAvgLogWrites",
    hiCommitedTrans = forceEither $ get cp "Sysmon" "hiCommitedTrans",
    hiPageSplits = forceEither $ get cp "Sysmon" "hiPageSplits",
    hiLockSummary = forceEither $ get cp "Sysmon" "hiLockSummary",
    hiDeadlock = forceEither $ get cp "Sysmon" "hiDeadlock",
    hiLastPageLock = forceEither $ get cp "Sysmon" "hiLastPageLock",
    hiLockPromotions = forceEither $ get cp "Sysmon" "hiLockPromotions",
    loCacheSpinContention = forceEither $ get cp "Sysmon" "loCacheSpinContention",
    ioDelayBy = forceEither $ get cp "Sysmon" "ioDelayBy"
  }

eval :: Sysmon -> HintEnv [Hint]
eval s = do
   e <- ask
   let results = [(id, foldResult [r s e | r <- rs] (&&), action) |
                  (id, rs, action) <- fs
                 ]
   return [(id,action,facts) | (id, (b, facts), action) <- results, b]

sysmonHints :: ConfigParser -> Sysmon -> [Hint]
sysmonHints cnf s = runReader (eval s) (mkConfig cnf)

percent i t = fromIntegral i / fromIntegral t * 100.0

result :: (LogShow a) => Bool -> [String] -> [a] -> Result
result b fs ys = (b, [f ++ " = " ++ lshow y | (f,y) <- zip fs ys, b])

foldResult :: [Result] -> (Bool -> Bool -> Bool) -> Result
foldResult ds cond = foldr1 f ds where
    f (b, s) (b', s') = (cond b b', if b then s ++ s' else s')

-- | Kernel contention
checkCpuBusy s e =
     let busy = avgCpuBusy $ kernel s
         b = busy >= hiCPU e in
       result b ["CPU Busy"] [busy]

checkCpuIdle s e =
     let busy = avgCpuBusy $ kernel s
         b = busy <= 100.0 - hiCPU e in
       result b ["CPU Idle"] [100.0 - busy]

checkIOEngine s e =
     let iobusy = avgIOBusy $ kernel s
         cpubusy = avgCpuBusy $ kernel s
         b = iobusy >= hiIO e && cpubusy <= (100.0 - hiCPU e) in
       result b ["Engine IO Busy", "Engine CPU Busy"] [iobusy, cpubusy]

checkIODisk s e =
    let checkIO = checkDiskIO $ kernel s
        avgIO = avgDiskIO $ kernel s
        b = checkIO >= hiCheckDiskIO e && avgIO <= loAvgDiskIO e in
     result b ["Check Disk IO", "Average Disk IO"] [checkIO, avgIO]

-- | Task contention
checkEngineBalance s e =
    let ts = taskSwitch $ task s
        sd = stdDev $ fromList $ map (fromIntegral.numSwitch) ts
        b = sd >= hiStdDeviation e in
     result b ["Standard deviation"] [sd]

checkSwitchesPerTran s e =
    let ts = totSwitch $ task s
        tr = commited $ transaction s
        pt = if tr == 0 then 0
               else fromIntegral ts / fromIntegral tr
        b = pt >= hiSwitchPerTransaction e in
      result b ["Context switches per transaction"] [pt]

checkContextSwitches s e =
     let sw = taskSwitchDue $ task s
         cs = [(cacheSearchMiss, "Cache Search Misses"),
               (diskWrites, "System Disk Writes"),
               (batchSize, "Exceeding I/O batch size"),
               (logicLockCont, "Logical Lock Contention"),
               (addrLockCont, "Address Lock Contention"),
               (latchCont, "Latch Contention"),
               (semCont, "Log Semaphore Contention"),
               (plcLockCont, "PLC Lock Contention"),
               (lastLogPage, "Last Log Page Writes"),
               (conflicts, "Modify Conflicts"),
               (deviceCont, "I/O Device Contention"),
               (netSent, "Network Packet Sent"),
               (netServices, "Network services"),
               (other, "Other Causes")
              ]

         conv (f, x) = let res = percent (f sw) (totSwitchDue sw) in (x, res)
         rs = unzip $ filter (\(_,res) -> res >= hiContextSwitchDue e) $
                               map conv cs
         b = not $ null $ fst rs in
       uncurry (result b) rs

-- | Transaction contention
checkUlcCont s e =
     let req = ulsSemReqs $ transaction s
         cont = percent (waited req) (totReq req)
         b = cont >= hiUlcSemRequests e in
      result b ["ULC Semaphore Contention"] [cont]

checkLogCont s e =
     let req = logSemReqs $ transaction s
         cont = percent (waited req) (totReq req)
         b = cont >= hiLogSemRequests e in
      result b ["Log Semaphore Contention"] [cont]

checkAvgLogWrites s e =
     let trans = commited $ transaction s
         avgWrites = avgLogWrites $ transaction s
         b = trans >= hiCommitedTrans e && avgWrites >= hiAvgLogWrites e in
      result b ["Avg # Writes per Log Page"] [avgWrites]

-- | Index contention
checkPageCont s e =
     let cont = splits $ index s
         b = cont >= hiPageSplits e in
      result b ["Page Splits"] [cont]

-- | Lock contention
checkLockCont s e =
     let cont = percent (lockCont $ lock s) (lockReqs $ lock s)
         b = cont >= hiLockSummary e in
      result b ["Average Lock Contention"] [cont]

checkDeadlocks s e =
     let cont = percent (deadlocks $ lock s) (lockReqs $ lock s)
         b = cont >= hiDeadlock e in
       result b ["Deadlock Percentage"] [cont]

checkLastPageLocks s e =
      let cont = percent (waited $ lpLock $ lock s) (totReq $ lpLock $ lock s)
          b = cont >= hiLastPageLock e in
       result b ["Last Page Lock"] [cont]

checkLockPromotion s e =
      let b = promotions (lock s) >= hiLockPromotions e in
       result b ["Lock Promotions"] [promotions $ lock s]

-- | Cache contention
verifyNamedCache cache field valid msg  =
     let res c = (cacheName c, field c)
         ps = map res (caches cache)
         cs = unzip $ filter (\(_, val) -> valid val) ps
         b = not $ null $ fst cs in
       result b (map (++ msg) $ fst cs) (snd cs)

checkCacheTurnover s e =
      let db = (dirtyBuffers.cache) s
          b = db >= hiDirtyBuffers e in
        result b ["Buffers Grabbed Dirty"] [db]

checkSpinCont s e =
      let valid val = val > 0 && val <= loCacheSpinContention e in
        verifyNamedCache (cache s) spinContention valid ".Spinlock contention"

checkCacheHits s e =
      let valid val = val > 0 && val <= loCacheHits e
          field c = percent (hits c) (totHitsMiss c) in
         verifyNamedCache (cache s) field valid ".Hits"

checkCacheWash s e =
      let valid val = val >= hiCacheWash e
          field c = percent (wash c) (totHitsMiss c) in
         verifyNamedCache (cache s) field valid ".Wash"

checkCacheLargeIO s e =
       let valid val = val <= loLargeIO e
           field c = percent (largeIO c) (largeIOTotal c) in
         verifyNamedCache (cache s) field valid ".Large IO"

-- | Group checks
checkIOBusy s e =
     let checkset = [checkIOEngine, checkIODisk] in
       foldResult [r s e | r <- checkset] (&&)

checkResourceCont s e =
      let checkset = [checkContextSwitches, checkSpinCont, checkUlcCont,
                     checkLogCont, checkPageCont, checkLockCont] in
       foldResult [r s e | r <- checkset] (||)

-- | Sysmon rules
fs =
   [
   ("ruleMoreEngines",
     [checkCpuBusy, checkResourceCont],
     "Consider to increase the number of engines"),
   ("ruleLessEngines",
     [checkCpuIdle],
     "Consider to decrease the number of engines"),
   ("rulesEnginesBalance",
     [checkEngineBalance],
     "Engines are unbalanced regarding task context switches"),
   ("ruleSwitchPerTransaction",
     [checkSwitchesPerTran],
     "The increasing number of the context switches  per transaction"),
   ("ruleContextSwitchDue",
     [checkContextSwitches],
     "Consider resources tuning to decrease the context switches due to"),
   ("ruleIOBusy",
     [checkIOBusy],
     "The job is IO bound"),
   ("ruleCacheContention",
    [checkCacheTurnover,
     checkSpinCont,
     checkCacheHits,
     checkCacheWash,
     checkCacheLargeIO],
    "Cache contention"),
   ("ruleLockContention",
     [checkLockCont,
      checkDeadlocks,
      checkLastPageLocks,
      checkLockPromotion],
     "Lock contention")
   ]

max_stars_repo_name: rukav/Sysmon

max_issues_repo_name: rukav/Sysmon

max_forks_repo_name: rukav/Sysmon


text:
-- -------------------------------------------------------------------------
-- 　　　　　　ﾊ,,ﾊ
-- 　　　　　（ ﾟωﾟ )　　WAお断りします
-- 　　　　／　　 　＼
-- 　 ((⊂ 　） 　 ﾉ＼つ))
-- 　　　　　（＿⌒ヽ
-- 　　　　　　ヽ ﾍ　}
-- 　　　ε≡Ξ　ﾉノ ｀J
-- ------------------------------------------------------------------------
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
-- {-# LANGUAGE NegativeLiterals #-}
-- {-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TupleSections #-}

{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -O0 #-}
{-# OPTIONS_GHC -O2 #-}
{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
{-# OPTIONS_GHC -Wno-missing-import-lists #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
{-# LANGUAGE BlockArguments      #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE UndecidableInstances#-}

module Main where
import Data.Bool
import Control.Applicative
import Data.Ord
import Control.Monad.State
import qualified Control.Monad                 as CM
import qualified Control.Monad.Primitive       as Prim
import qualified Control.Monad.ST              as ST
import qualified Data.Array             as A
import qualified Data.Array.IO                 as AIO
import qualified Data.Array.ST                 as AST
import qualified Data.Array.Unboxed            as AU
import qualified Data.Bits                     as Bits
import qualified Data.ByteString.Char8         as BS
import qualified Data.ByteString.Builder       as BI
import qualified Data.Char                     as Char
import qualified Data.Complex                  as Comp
import qualified Data.Foldable                 as Foldable
import qualified Data.Function                 as Func
import qualified Data.Heap                     as Heap
import qualified Data.IORef                    as IO
import qualified Data.IntPSQ                   as PSQ
import qualified Data.Ix                       as Ix
import qualified Data.List                     as L
import qualified Data.Map.Strict               as Map
import qualified Data.IntMap                   as MI
import qualified Data.Maybe                    as May
import qualified Data.Primitive.MutVar         as MutVar
import qualified Data.Proxy                    as Proxy
import qualified Data.Ratio                    as Ratio
import qualified Data.STRef                    as STRef
import qualified Data.Sequence                 as Seq
import qualified Data.Set                      as Set
import qualified Data.Tree                     as Tree
import qualified Data.Vector                   as V
import qualified Data.Vector.Algorithms.Merge  as VAM
import qualified Data.Vector.Algorithms.Radix  as VAR
import qualified Data.Vector.Algorithms.Search as VAS
import qualified Data.Vector.Algorithms.Intro  as VAI
import           Data.Vector.Generic           ((!))
import qualified Data.Vector.Generic           as VG
import qualified Data.Vector.Generic.Mutable   as VGM
import qualified Data.Vector.Mutable           as VM
import qualified Data.Vector.Unboxed.Base      as VUB
import qualified Data.Vector.Unboxing          as VU
import qualified Data.Vector.Unboxing.Mutable  as VUM
import qualified Debug.Trace                   as Trace
import qualified GHC.TypeNats                  as TypeNats
import qualified Test.QuickCheck               as QC
import qualified Data.Vector.Fusion.Bundle     as VFB
import System.IO

mod' = 1000000007

readInt = BS.readInt . BS.dropWhile Char.isSpace
readIntList = map readInt . BS.words
-- getInt = readInt <$> BS.getLine
getIntList = readIntList <$> BS.getLine

getIntLists n = CM.replicateM n getIntList

getIntVec n = VU.unfoldrN n (BS.readInt . BS.dropWhile Char.isSpace) <$> BS.getLine

getIntVecs n m = CM.replicateM m (getIntVec n)

getVecStr =VU.fromList<$>getLine
getInt = readLn @Int
getIntsPair n = map (\[a,b] -> (a,b)) <$> CM.replicateM n getIntList

getVector f = VU.unfoldr f <$> BS.getLine

getIntVector = getVector readInt
getBSVector = getVector BS.uncons
getInt2Tuple = (\vec -> (vec VU.! 0, vec VU.! 1)) <$> getIntVector
getInt3Tuple = (\vec -> (vec VU.! 0, vec VU.! 1, vec VU.! 2)) <$> getIntVector

ggg s= May.fromJust$L.uncons s

gs :: IO String
gs=getLine

gn=map (read . BS.unpack) . BS.words <$> BS.getLine ::IO[Int]

gg :: Int -> IO (V.Vector (LV Int))
gg n=V.replicateM n (g @(LV Int))

-- | ex) getLn @Int @VU.Vector n, getLn @[Int] @V.Vector n
gl :: (ReadBS a, VG.Vector v a) => Int -> IO (v a)
gl n = VG.replicateM n g

-- | ex) get @Int, get @(VU.Vector) ..
g:: ReadBS a => IO a
g = readBS <$> BS.getLine

fix :: (a -> a) -> a
fix f = let x = f x in x

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

main = do
  putStr "yeah"
---------------------------------------------------------

each :: (t1 -> a) -> (t2 -> b) -> (t1, t2) -> (a, b)
each f g (x,y)=(f x,g y)
digSum k=sum[read[c]|c<-k]

replaceAt :: Int -> a -> [a] -> [a]
replaceAt _ _ []     = []
replaceAt 0 y (_:xs) = y : xs
replaceAt n y (x:xs) = x : replaceAt (n - 1) y xs

{-# INLINE vLength #-}
vLength :: (VG.Vector v e) => v e -> Int
vLength = VFB.length . VG.stream

type Moji = BS.ByteString
type LV   = V.Vector
type SV   = VU.Vector

---------------
-- Read/Show --
---------------

class ReadBS a where
  readBS :: BS.ByteString -> a

  {-# MINIMAL readBS #-}
-- ^ ByteString版Read

class ShowBS a where
  showBS :: a -> BS.ByteString

  {-# MINIMAL showBS #-}

instance ReadBS Int where
  readBS s = case BS.readInt s of
    Just (x, _) -> x
    Nothing     -> error "readBS :: ByteString -> Int"

instance ReadBS Integer where
  readBS = fromInteger . readBS

instance ReadBS Double where
  readBS = read . BS.unpack

instance ReadBS BS.ByteString where
  readBS = id

instance (ReadBS a, VU.Unboxable a) => ReadBS (VU.Vector a) where
  readBS s = VG.fromList . map readBS . BS.words $ s

instance (ReadBS a) => ReadBS (V.Vector a) where
  readBS s = VG.fromList . map readBS . BS.words $ s

instance ReadBS a => ReadBS [a] where
  readBS s = map readBS . BS.words $ s

instance (ReadBS a, ReadBS b) => ReadBS (a, b) where
  readBS (BS.words -> [a, b]) = (readBS a, readBS b)
  readBS _ = error "Invalid Format :: readBS :: ByteString -> (a, b)"

instance (ReadBS a, ReadBS b, ReadBS c) => ReadBS (a, b, c) where
  readBS (BS.words -> [a, b, c]) = (readBS a, readBS b, readBS c)
  readBS _ = error "Invalid Format :: readBS :: ByteString -> (a, b)"

instance ShowBS Int where
  showBS = BS.pack . show

instance ShowBS Integer where
  showBS = BS.pack . show

instance ShowBS Double where
  showBS = BS.pack . show

instance ShowBS BS.ByteString where
  showBS = id

instance (ShowBS a, VU.Unboxable a) => ShowBS (VU.Vector a) where
  showBS = showVec

instance (ShowBS a) => ShowBS (V.Vector a) where
  showBS = showVec

instance ShowBS a => ShowBS [a] where
  showBS = BS.pack . unwords . map (BS.unpack . showBS)

instance (ShowBS a, ShowBS b) => ShowBS (a, b) where
  showBS (a, b) = showBS a `BS.append` " " `BS.append` showBS b

instance (ShowBS a, ShowBS b, ShowBS c) => ShowBS (a, b, c) where
  showBS (a, b, c) = showBS a `BS.append` " " `BS.append` showBS b
    `BS.append` showBS c

showVec :: (VG.Vector v a, ShowBS a) => v a -> BS.ByteString
showVec xs
  | VG.null xs = ""
  | otherwise = BS.concat [f i | i <- [0 .. 2 * VG.length xs - 2]]
  where
  f i
    | even i = showBS $ xs ! (i `div` 2)
    | otherwise = " "

while :: Monad m => m Bool -> m ()
while f = f >>= \frag -> CM.when frag $ while f


text:
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Module      : PSO.Heisenberg
-- Description : Heisenberg Hamiltonian
-- Copyright   : (c) Tom Westerhout, 2017
-- License     : BSD3
-- Maintainer  : t.westerhout@student.ru.nl
-- Stability   : experimental
module PSO.Heisenberg
  ( -- * Introduction
    --
    -- | Let's start with a 1D chain of \(N\) spin-1/2 particles. Each of them
    -- is described by a state \(|\alpha_i\rangle\in\mathbb{C}^2\). Hilbert
    -- space of the whole system is then \(\bigotimes_{i=0}^{N-1}\mathbb{C}^2\).
    --
    -- We use the following Hamiltonian to describe this system:
    -- \[
    -- \hat{\mathcal{H}} = \sum_{i=0}^{N-2}
    --    \hat{\boldsymbol\sigma}_i \cdot \hat{\boldsymbol\sigma}_{i+1}
    --    = \sum_{i=0}^{N-2}
    --          \hat{\sigma}_i^{(x)}\hat{\sigma}_{i+1}^{(x)}
    --        + \hat{\sigma}_i^{(y)}\hat{\sigma}_{i+1}^{(y)}
    --        + \hat{\sigma}_i^{(z)}\hat{\sigma}_{i+1}^{(z)} \;.
    -- \]
    -- Only the nearest neighbours are connected. The boundary conditions used
    -- are called /open/ because the zeroth and N-1st spins don't interact.
    one2D
  , pauliX
  , pauliY
  , pauliZ
  , heisenberg1DOpen
    -- * Quantities of interest
    --
    -- | The quantity we're actually interested in is
    -- \[
    -- \frac{\langle\sigma| \hat{\mathcal{H}} |\psi\rangle}{%
    --   \langle\sigma|\psi\rangle} \;,
    -- \]
    -- where \(|\psi\rangle\) is described by the RBM \(\mathcal{W}\) and
    -- \(|\sigma\rangle\in\{\downarrow,\uparrow\}^N\) is a spin configuration.
    -- We call this quantity /local energy/ \(E_{loc}(\sigma;\mathcal{W})\).
    -- \[
    -- E_{loc}(\sigma;\mathcal{W}) = \sum_i \frac{\langle\sigma|
    --    \hat{\boldsymbol\sigma}_i\cdot\hat{\boldsymbol\sigma}_{i+1}
    --    |\psi\rangle}{\langle\sigma|\psi\rangle}
    -- \]
    -- Now
    -- \[
    -- \begin{aligned}
    -- &\hat{\boldsymbol\sigma}_1\cdot\hat{\boldsymbol\sigma}_2
    --    |\uparrow\uparrow\rangle = |\uparrow\uparrow\rangle \;,\\
    -- &\hat{\boldsymbol\sigma}_1\cdot\hat{\boldsymbol\sigma}_2
    --    |\downarrow\downarrow\rangle = |\downarrow\downarrow\rangle \;,\\
    -- &\hat{\boldsymbol\sigma}_1\cdot\hat{\boldsymbol\sigma}_2
    --    |\uparrow\downarrow\rangle = |\uparrow\downarrow\rangle
    --      - 2|\downarrow\uparrow\rangle \;,\\
    -- &\hat{\boldsymbol\sigma}_1\cdot\hat{\boldsymbol\sigma}_2
    --    |\downarrow\uparrow\rangle = |\downarrow\uparrow\rangle
    --      - 2|\uparrow\downarrow\rangle \;.
    -- \end{aligned}
    -- \]
  -- , locEnergyHH1DOpen
  ) where

import Data.Complex(Complex(..))
import Numeric.LinearAlgebra(C, Matrix, Herm, (><), trustSym, kronecker)
import qualified Numeric.LinearAlgebra as LA
import qualified Data.Vector.Storable as V

-- import PSO.Internal.Spin

one2D :: Matrix C
one2D = (2><2)
    [ 1.0,        0.0
    , 0.0,        1.0 ]

pauliX :: Matrix C
pauliX = (2><2)
    [ 0.0,        1.0
    , 1.0,        0.0 ]

pauliY :: Matrix C
pauliY = (2><2)
    [ 0.0,        0.0 :+ (-1.0)
    , 0.0 :+ 1.0, 0.0 ]

pauliZ :: Matrix C
pauliZ = (2><2)
    [ 1.0,        0.0
    , 0.0,        (-1.0) ]

rotate :: Int -> [a] -> [a]
rotate n xs = zipWith const (drop n (cycle xs)) xs

heisenberg1DOpen :: Int -> Herm C
heisenberg1DOpen n
  | n > 2 = trustSym $ heisenberg1DOpenImpl n pauliX
          + heisenberg1DOpenImpl n pauliY
          + heisenberg1DOpenImpl n pauliZ
  | n == 2 = trustSym $ pauliX `kronecker` pauliX
                      + pauliY `kronecker` pauliY
                      + pauliZ `kronecker` pauliZ
  | otherwise = undefined

heisenberg1DOpenImpl :: Int -> Matrix C -> Matrix C
heisenberg1DOpenImpl n pauli =
  let xs = (replicate (n-2) one2D) ++ (replicate 2 pauli)
      rotations = take (n-1) . iterate (rotate 1) $ xs
   in sum . map (foldr1 kronecker) $ rotations

-- locEnergyHH1DOpen ::
--      (Floating α, Eq α, Num (V.Vector α), LA.Numeric α)
--   => RBM α -> V.Vector α -> α
-- locEnergyHH1DOpen machine σ =
--   let θ = mkTheta machine σ
--       zipper i x y
--         | x == y    = 1
--         | otherwise = -1 + 2 * exp (logPoP2 machine θ σ (i, i + 1))
--    in V.sum $ V.izipWith zipper σ (V.tail σ)

max_stars_repo_name: twesterhout/tcm-swarm

max_issues_repo_name: twesterhout/tcm-swarm

max_forks_repo_name: twesterhout/tcm-swarm


text:
module Validation
  ( trainValAndTest
  , valTrainAndTest
  , solution1_2
  , solution3_4
  ) where

import           Data.Maybe                    (fromMaybe)
import           LinearRegression
import           NonlinearTransform
import           Numeric.LinearAlgebra.Data
import           Numeric.LinearAlgebra.HMatrix as HMatrix
import           WeightDecay

-- | Make a nonlinear Transformation of the first n data points of the input data
makeTransformedFirstN k n inputdata = fmap (fmap makeMatrixX) inputdata
  where
    makeMatrixX lists =
      createTransformedXk k $
      map (fromMaybe (0, 0) . listToTuple') $ take n lists

-- | Make a nonlinear Transformation of the rest of the data points after the first n
makeTransformedLastN k n inputdata = fmap (fmap makeMatrixX) inputdata
  where
    makeMatrixX lists =
      createTransformedXk k $
      map (fromMaybe (0, 0) . listToTuple') $ drop n lists

trainXFirstn k n = makeTransformedFirstN k n traindata

trainXLastn k n = makeTransformedLastN k n traindata

testXTransformedk k = makeTransformedMatrix k testdata

trainYFirstn n = fmap (fmap makeVectorY) traindata
  where
    makeVectorY lists = vector $ take n $ map last lists

trainYLastn n = fmap (fmap makeVectorY) traindata
  where
    makeVectorY lists = vector $ drop n $ map last lists

-- | Trains and validate linear Regression from the data on the course website, using the first n points for training and the rest for validation, performing non-linear transformation with k-dimensional features
trainVal k n = do
  matrixXTrain <- trainXFirstn k n
  matrixXVal <- trainXLastn k n
  vectorYTrain <- trainYFirstn n
  vectorYVal <- trainYLastn n
  let weights = linearRegressionWeight <$> matrixXTrain <*> vectorYTrain
  let inSampleError =
        linRegClassificationError <$> matrixXTrain <*> vectorYTrain <*> weights
  let validationError =
        linRegClassificationError <$> matrixXVal <*> vectorYVal <*> weights
  return (weights, validationError, inSampleError)

-- | same as trainVal, but the first n points are used for validation and the rest for training
valTrain k n = do
  matrixXVal <- trainXFirstn k n
  matrixXTrain <- trainXLastn k n
  vectorYVal <- trainYFirstn n
  vectorYTrain <- trainYLastn n
  let weights = linearRegressionWeight <$> matrixXTrain <*> vectorYTrain
  let inSampleError =
        linRegClassificationError <$> matrixXTrain <*> vectorYTrain <*> weights
  let validationError =
        linRegClassificationError <$> matrixXVal <*> vectorYVal <*> weights
  return (weights, validationError, inSampleError)

-- | Tests linear Regression from the data on the course website
testLinRegTransformedk k weights = do
  matrixXTest <- testXTransformedk k
  vectorYTest <- testY
  let outOfSampleError =
        linRegClassificationError <$> matrixXTest <*> vectorYTest <*> weights
  return outOfSampleError

-- | train, validate and test with given data, with nonlinear transformation to k-dimensional feature space, with n triaining points and max-n validation points
trainValAndTest :: Int -> Int -> IO ()
trainValAndTest k n = do
  (weights, validationError, inSampleError) <- trainVal k n
  outOfSampleError <- testLinRegTransformedk k weights
  putStr "In Sample Error: "
  print inSampleError
  putStr "Validation Error: "
  print validationError
  putStr "Out of Sample Error: "
  print outOfSampleError

-- | same as trainValAndTest, but the first n points are used for validation and the rest for training
valTrainAndTest :: Int -> Int -> IO ()
valTrainAndTest k n = do
  (weights, validationError, inSampleError) <- valTrain k n
  outOfSampleError <- testLinRegTransformedk k weights
  putStr "In Sample Error: "
  print inSampleError
  putStr "Validation Error: "
  print validationError
  putStr "Out of Sample Error: "
  print outOfSampleError

-- | solution to problems 1 and 2
solution1_2 :: IO ()
solution1_2 =
  mapM_
    (\k -> do
       putStr " k ="
       print k
       trainValAndTest k 25)
    [3, 4, 5, 6, 7]

-- | solution to problems 3 and 4
solution3_4 :: IO ()
solution3_4 =
  mapM_
    (\k -> do
       putStr " k ="
       print k
       valTrainAndTest k 25)
    [3, 4, 5, 6, 7]


text:
{-# LANGUAGE RankNTypes #-}
module Main where

import Codec.Picture (PixelRGBA8 (..), writePng)
import Control.Monad
import Data.Array.Accelerate
  ( Acc,
    All (..),
    Any (..),
    Array,
    DIM2,
    Elt,
    Exp,
    Generic,
    Lift (..),
    Matrix,
    Plain,
    Unlift,
    Vector,
    Z (..),
    (:.) (..),
  )
import qualified Data.Array.Accelerate as A
import Data.Array.Accelerate.Data.Complex
import Data.Array.Accelerate.LLVM.PTX
import Data.Array.Accelerate.Representation.Type
import Data.Array.Accelerate.Smart
import Data.Array.Accelerate.Sugar.Elt
import qualified Data.Complex as C
-- import Graphics.Amusing
import Graphics.Rasterific hiding (Vector)
import Graphics.Rasterific.Texture
import Prelude.Unicode
import Text.Printf

type Pendulum a b = (a, b)

zs :: Pendulum a b -> a
zs (zs,  _) = zs

ps :: Pendulum a b -> b
ps (_, ps) = ps

type Pair a = (a, a)

g :: (RealFrac a, A.RealFloat a, Elt a) => Exp a
g = 9.81

origin ::
  (RealFrac a, A.RealFloat a, Elt a) =>
  Exp (Pair (Complex a))
origin = A.constant (0 :+ 0, 0 :+ 0)

zero ::
  (RealFrac a, A.RealFloat a, Elt a) =>
  Exp (Pair a)
zero = A.constant (0, 0)

one ::
  (RealFrac a, A.RealFloat a, Elt a) =>
  Exp (Pair (Complex a))
one = A.constant (1 :+ 0, 1 :+ 0)

calc ::
  forall a.
  (RealFrac a, A.RealFloat a, Elt a) =>
  Exp a ->
  Exp a ->
  Exp a ->
  Exp (Pendulum (Pair (Complex a)) (Pair a)) ->
  Exp (Pendulum (Pair (Complex a)) (Pair a))
calc m1 m2 dt pendulum =
  let (zs, ps) = A.unlift pendulum
      zs :: Exp (Pair (Complex a))
      ps :: Exp (Pair a)
      (z1 :: Exp (Complex a), z3 :: Exp (Complex a)) = A.unlift zs
      (p1 :: Exp a, p3 :: Exp a) = A.unlift ps
      i1 = inertia z1 m1
      i3 = inertia z3 m2
      angleDiff = phase z1 - phase z3
      commonFactor = (magnitude z3 / i1)/(18 * i3 * cos angleDiff**2 -
                        8 * absSquared z3 * (3 * m2 + m1))
      ω1 = commonFactor * m1 *
             (3 * magnitude z1 * p3 * cos angleDiff - 2 * magnitude z3 * p1)
      ω3 = commonFactor/i3 *
             (3 * m1 * magnitude z1 * i3 * p1 * cos angleDiff - 2 * i1 * magnitude z3 * p3 * (3 * m2 + m1))
      v1 = cis(ω1 * dt)
      v3 = cis(ω3 * dt)
      pCommonFactor = 6 * magnitude (z1 / z3) * i3 * ω1 * ω3 * sin angleDiff
      p1' = (-pCommonFactor) - g * (m1/2 + m2) * magnitude z1 * cos(phase z1)
      p3' = pCommonFactor - g * m2 * magnitude z3 / 2 * cos(phase z3)
   in A.lift
        ( (z1 * v1, z3 * v3),
          (p1 + p1' * dt, p3 + p3' * dt)
        )
  where
    absSquared z = real (z * conjugate z)
    inertia z m = m * absSquared z / 12

inited ::
  (RealFrac a, A.RealFloat a, Elt a) =>
  Int ->
  Exp (Pair (Complex a)) ->
  Acc (Vector (Pendulum (Pair (Complex a)) (Pair a)))
inited frames zs = A.fill (A.constant $ Z :. 1) $ A.lift (zs, zero)

compute ::
  (RealFrac a, A.RealFloat a, Elt a) =>
  ( Exp (Pendulum (Pair (Complex a)) (Pair a)) ->
    Exp (Pendulum (Pair (Complex a)) (Pair a))
  ) ->
  Acc (Vector (Pendulum (Pair (Complex a)) (Pair a))) ->
  Acc (Vector (Pendulum (Pair (Complex a)) (Pair a)))
compute calc mat =
  let n = indexHead $ A.shape mat
      last = A.replicate (A.constant $ Z :. 1 :: Exp (Z :. Int)) $ A.slice mat (A.lift $ Z :. n - 1)
      new = A.map calc last
   in mat A.++ new

computation ::
  forall a.
  (RealFrac a, A.RealFloat a, Elt a) =>
  Int ->
  Acc (Vector (Pendulum (Pair (Complex a)) (Pair a))) ->
  ( Acc (Vector (Pendulum (Pair (Complex a)) (Pair a))) ->
    Acc (Vector (Pendulum (Pair (Complex a)) (Pair a)))
  ) ->
  Exp (Pair (Complex a)) ->
  Acc (Vector (Pair (Complex a)))
computation frames inited compute zs =
  A.map mapper ran
  where
    pred mat =
      let (A.unlift -> Z :. i :: Z :. Exp Int) = A.shape mat
          in A.unit $ i A.< A.constant frames

    mapper :: Exp (Pendulum (Pair (Complex a)) (Pair a)) -> Exp (Pair (Complex a))
    mapper (A.unlift -> pendulum :: Pendulum (Exp (Pair (Complex a))) (Exp (Pair a))) =
      let (z, _) = pendulum
       in z

    ran :: Acc (Vector (Pendulum (Pair (Complex a)) (Pair a)))
    ran = A.awhile pred compute inited

simulatePendulums ::
  (RealFrac a, A.RealFloat a, Elt a) =>
  (C.Complex a, a) ->
  (C.Complex a, a) ->
  a ->
  a ->
  [Pair (C.Complex a)]
simulatePendulums (z1, m1) (z2, m2) t dt = A.toList $ run computation'
  where
    frames = ceiling $ t / dt
    zs = A.constant (z1, z2)
    calc' = calc (A.constant m1) (A.constant m2) (A.constant dt)
    inited' = inited frames zs
    compute' = compute calc'
    computation' = computation frames inited' compute' zs

skip :: Int
skip = 2

paint :: Double -> (Int, Pair (Complex Double)) -> IO ()
paint m (i, (z1@(x1 C.:+ y1), z2@(x2 C.:+ y2))) =
  when (mod i skip == 0) $ do
    putStrLn $ "z1 = " ++ show z1
    putStrLn $ "z2 = " ++ show z2
    let side = 2000 :: Int
        width = 15
        x1' = realToFrac $ (fromIntegral side / 2) * (1 + x1 / m)
        y1' = realToFrac $ (fromIntegral side / 2) * (1 - y1 / m)
        x2' = realToFrac $ (fromIntegral side / 2) * (1 + (x2 + x1) / m)
        y2' = realToFrac $ (fromIntegral side / 2) * (1 - (y2 + y1) / m)
        bg = PixelRGBA8 0x0c 0x0a 0x20 255
        lineColor = PixelRGBA8 0xdf 0x85 0xff 255
        img = renderDrawing side side bg $
          withTexture (uniformTexture lineColor) $ do
            stroke width JoinRound (CapRound, CapRound) $
              line
                (V2 (fromIntegral side / 2) (fromIntegral side / 2))
                (V2 x1' y1')
                ++ line (V2 x1' y1') (V2 x2' y2')
    writePng (printf "results/double-pendulum-%05v.png" $ div i skip) img

main :: IO ()
main = do
  let z1 = C.cis (pi/4) :: Complex Double
      z2 = C.cis (pi/4) :: Complex Double
      list = zip [0 ..] $ simulatePendulums
                            (z1, 1) (z2, 1)
                            (50 * fromIntegral skip) (1 / (60 * fromIntegral skip))
  forM_ list $ paint $ C.magnitude z1 + C.magnitude z2

max_stars_repo_name: LuigiPiucco/mnc-ifsc

max_issues_repo_name: LuigiPiucco/mnc-ifsc

max_forks_repo_name: LuigiPiucco/mnc-ifsc


text:
module SongId
( chunkIdentifier
, findMaxFreq
, mapChunk2Freqs
, ft
) where

import Debug.Trace

import Data.Array.Unboxed (elems, assocs, UArray)
import Data.Array.IArray (Array(..), listArray, array)
import Data.Array.CArray (CArray)

import Data.Complex (Complex(..), magnitude)
import Data.Int (Int64, Int32, Int16, Int8)
import Math.FFT (dft)

import Data.List (sort)

import Common (importantFrequencies, breakChunks, slice)

chunkIdentifier :: [(Int, Int)] -> ([Float], [Complex Float]) -> [Float]
chunkIdentifier freqRanges (freqs, amps) =
    let breakFreqs chunk = map (flip slice chunk) freqRanges
        unzippedChunksInFrequencyRanges = map unzip $ breakFreqs $ zip freqs amps
        maxFreqsInRanges = map findMaxFreq $ unzippedChunksInFrequencyRanges
    in map fst maxFreqsInRanges

findMaxFreq :: ([Float], [Complex Float]) -> (Float, Complex Float)
findMaxFreq (xs, ys) = foldl (\max@(_, maxamp) new@(_, amp) ->
        if (magnitude amp) > (magnitude maxamp)
        then new
        else max)
    (0,0) $ zip xs ys

mapChunk2Freqs :: (Fractional a, Fractional b) => [a] -> ([b], [a])
mapChunk2Freqs chunk =
    let l = length chunk
        halfOfChunk = slice (0, l `quot` 2) chunk
        amps = map (/ fromIntegral l) halfOfChunk

        xs1 = map fromIntegral $ [0,1..l]
        xs2 = replicate l (44100 / fromIntegral l)
        freqs = map (\(x1,x2) -> x1 * x2) $ zip xs1 xs2
    in (freqs, amps)

ft :: Int -> UArray Int Int32 -> [CArray Int (Complex Float)]
ft chunkSize samples = map dft chunks
    where chunks = map (listArray (0, chunkSize - 1)) $ breakChunks chunkSize elements -- enumerate the samples in each chunk
          elements = map convertToComplex $ elems samples
          convertToComplex v = (fromIntegral v) :+ 0


text:
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK show-extensions #-}

-- {-# LANGUAGE OverlappingInstances   #-}
-- |
-- Module      : Energy
-- Description : Particle Swarm Optimisation
-- Copyright   : (c) Tom Westerhout, 2017
-- License     : BSD3
-- Maintainer  : t.westerhout@student.ru.nl
-- Stability   : experimental
module PSO.Energy
  ( writeEnergies2TSV
  , writeVariances2TSV
  ) where

import Lens.Micro
import Lens.Micro.Extras
import Data.Monoid
import Data.List(intersperse)
import qualified Data.List as List
import qualified Numeric.LinearAlgebra as LA
import qualified Data.ByteString.Lazy as LB
import Data.ByteString.Builder

import PSO.Swarm

class EncodableAsDecimal a where
  encodeAsDecimal :: a -> Builder

instance EncodableAsDecimal Float where
  encodeAsDecimal = floatDec

instance EncodableAsDecimal Double where
  encodeAsDecimal = doubleDec

energies2TSV :: (EncodableAsDecimal t)
             => (Bee α β r -> t) -> [Swarm m γ β α r] -> LB.ByteString
energies2TSV func =
  let encodeSwarm = mconcat . intersperse (charUtf8 '\t')
        . map (encodeAsDecimal . func) . view bees
   in toLazyByteString . mconcat . intersperse (charUtf8 '\n')
        . map encodeSwarm

variances2TSV :: (EncodableAsDecimal r, HasVar γ r)
              => [Swarm m γ β α r] -> LB.ByteString
variances2TSV = toLazyByteString . mconcat . intersperse (charUtf8 '\n')
                . map (encodeAsDecimal . view (guide . var))

writeEnergies2TSV :: (EncodableAsDecimal t)
                  => FilePath -> (Bee α β r -> t) -> [Swarm m γ β α r] -> IO ()
writeEnergies2TSV file func = LB.writeFile file . energies2TSV func

writeVariances2TSV :: (EncodableAsDecimal r, HasVar γ r)
                   => FilePath -> [Swarm m γ β α r] -> IO ()
writeVariances2TSV file = LB.writeFile file . variances2TSV


text:
-- figure 2.1

import qualified Data.Vector as V

import Statistics.Sample
import Statistics.Sample.Histogram (histogram)

dice :: V.Vector Double
dice = V.fromList [1,2,3,4,5,6]

main = do
  putStrLn $ "the range: " ++ show (range dice)
  putStrLn $ "the mean:  " ++ show (mean dice)
  putStrLn $ "the harmonic mean, which is defined by 6 / (sum $ map (1/) [1..6]): " ++ show (harmonicMean dice)
  putStrLn $ "the standard deviation: " ++ show (stdDev dice)

  let (bs,hs) = histogram 6 dice
  putStrLn $ "the histogram is of course uniform: " ++ show (hs :: V.Vector Int)
  putStrLn $ "the (lower) boundaries: " ++ show bs

max_stars_repo_name: raydsameshima/Stat

max_issues_repo_name: raydsameshima/Stat

max_forks_repo_name: raydsameshima/Stat