text:
{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE KindSignatures             #-}

module Main where

import Control.Monad
import Control.Monad.Random
import Data.List
import Data.Maybe
import Numeric.LinearAlgebra
import System.Environment
import Text.Read

{-
 Weights, Network & neural net implementation by Justin Le (not mine!)

 Tutorial by Justin Le:

 https://blog.jle.im/entry/practical-dependent-types-in-haskell-1.html
-}
data Weights = W { wBiases :: !(Vector Double)  -- n
                 , wNodes  :: !(Matrix Double)  -- n x m
                 }                              -- "m to n" layer
 deriving Show

data Network :: * where
    O     :: !Weights
          -> Network
    (:&~) :: !Weights
          -> !Network
          -> Network
  deriving Show -- ?

infixr 5 :&~

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

logistic' :: Floating a => a -> a
logistic' x = logix * (1 - logix)
  where
    logix = logistic x

runLayer :: Weights -> Vector Double -> Vector Double
runLayer (W wB wN) v = wB + wN #> v

runNet :: Network -> Vector Double -> Vector Double
runNet (O w)      !v = logistic (runLayer w v)
runNet (w :&~ n') !v = let v' = logistic (runLayer w v)
                       in  runNet n' v'

randomWeights :: MonadRandom m => Int -> Int -> m Weights
randomWeights i o = do
    seed1 :: Int <- getRandom
    seed2 :: Int <- getRandom
    let wB = randomVector  seed1 Uniform o * 2 - 1
        wN = uniformSample seed2 o (replicate i (-1, 1))
    return $ W wB wN

randomNet :: MonadRandom m => Int -> [Int] -> Int -> m Network
randomNet i []     o =     O <$> randomWeights i o
randomNet i (h:hs) o = (:&~) <$> randomWeights i h <*> randomNet h hs o

train :: Double           -- ^ learning rate
      -> Vector Double    -- ^ input vector
      -> Vector Double    -- ^ target vector
      -> Network          -- ^ network to train
      -> Network
train rate x0 target = fst . go x0
  where
    go :: Vector Double    -- ^ input vector
       -> Network          -- ^ network to train
       -> (Network, Vector Double)
    -- handle the output layer
    go !x (O w@(W wB wN))
        = let y    = runLayer w x
              o    = logistic y
              -- the gradient (how much y affects the error)
              --   (logistic' is the derivative of logistic)
              -- Here, E := (o - target) ^ 2 is implied
              dEdy = logistic' y * (o - target)
              -- new bias weights and node weights
              wB'  = wB - scale rate dEdy
              wN'  = wN - scale rate (dEdy `outer` x)
              w'   = W wB' wN'
              -- bundle of derivatives for next step
              dWs  = tr wN #> dEdy
          in  (O w', dWs)
    -- handle the inner layers
    go !x (w@(W wB wN) :&~ n)
        = let y          = runLayer w x
              o          = logistic y
              -- get dWs', bundle of derivatives from rest of the net
              (n', dWs') = go o n
              -- the gradient (how much y affects the error)
              dEdy       = logistic' y * dWs'
              -- new bias weights and node weights
              wB'  = wB - scale rate dEdy
              wN'  = wN - scale rate (dEdy `outer` x)
              w'   = W wB' wN'
              -- bundle of derivatives for next step
              dWs  = tr wN #> dEdy
          in  (w' :&~ n', dWs)

{-
 Inserting my own training exercise here.
 This is inspired by the language-model task of predicting the following
 element in a 4-gram, based upon the last three elements available.
 The task: train a randomly generated system of weights to recognize
 the following pattern & predict the following item according to it:

 0 1 2 0 1 2 0 1 2 ..
-}

inf_pattern :: [Int]
inf_pattern = cycle [0..2]

fin_pttrn_len :: Int
fin_pttrn_len = 99999

{-
 Forming training data from the inf_pattern.
 The training data will be a list of pairs, each pair containing
 * a training input, 3-element vector;
 * a target output, 1-element vector.
-}
training_data :: [(Vector Double,  -- 3 * 1
                   Vector Double)] -- 1 * 1
training_data =
  let fin_pattern = take fin_pttrn_len inf_pattern
      list_pairs =
        [ (take 3 sub_pattern, [sub_pattern !! 3])
            | j <- [0..(length fin_pattern - 4)],
              let sub_pattern = drop j fin_pattern ]
  in map (\(inp, out) -> (vector $ fromIntegral <$> inp,
                          vector $ fromIntegral <$> out))
         list_pairs

-- Actually, if we were really being realistic about this then we would
-- make our inputs and outputs work according to some sort of one-hot encoding.
-- But never mind.

-- 1. Get an initial random network. We'll pick a basic enough size:
myRandNet :: MonadRandom m => m Network
myRandNet = randomNet 3 [4, 5] 1

-- 2. How can I get a pre-training prediction, then iteratively
--    train on the next available sample, followed by getting the
--    revised prediction?

-- An auxiliary function for "sequencing together"
-- training a network & printing info about it.
foldTraining :: Double              -- training rate
             -> Network             -- untrained network
             -> [(Vector Double,    -- pairs of training input
                  Vector Double)]   --          and training target output
             -> IO Network          -- train steps & print steps alternate in IO
foldTraining rate net pairs =
  foldl (\io_net sample@(inp, tgt) -> do
            n <- io_net
            putStrLn $ "Will train on: " ++ show inp
            let prediction = runNet n inp
            putStrLn $ "Predicted following item: " ++ show prediction
            -- now trying 10 rounds each per data sample
            let n' = last $
                     take 10 $
                     iterate (train rate inp tgt) n
                          -- ^ :: Network -> Network
            return n')
        (return net)
        pairs

-- We can come back later & modify this to give back the resulting
-- trained network, for use elsewhere (i.e. recurrent NN's!)
displayTraining :: Double              -- training rate
                -> [(Vector Double,    -- pairs of training input
                     Vector Double)]   --          and training target output
                -> IO ()
displayTraining rate pairs = do
  -- pluck out a random net
  randNet <- evalRandIO myRandNet
  -- show what it predicts for 1st sample *before* any training is done
  let inp_0 = fst $ head training_data
  let tgt_0 = snd $ head training_data
  let predict_0 = runNet randNet inp_0
  putStrLn $ "The untrained network predicts that following: "
             ++ show inp_0 ++ ", we will get: " ++ show predict_0
  -- now, alternate showing predictions & performing training on some input
  foldTraining rate randNet pairs
  return ()

{-
 Remark.
 The network is obviously learning *something*, because early predictions
 (which are basically noise) eventually give way to predicting minuscule
 numbers to follow every instance of "2", and numbers infinitesimally
 less than "1" following every instance of "0". But learning that every
 instance of "1" is followed by a "2" seems to take much longer! I haven't
 witnessed it yet despite using up to 10K training sample, with 1 learning
 round per sample.

 What if I try more rounds? It doesn't seem to help as far as training the
  network to detect the "2 is followed by 0" part of the pattern.
-}

{-
 RECURRENT NEURAL NETWORKS.
 We study a simple case of these, Elman network a.k.a. simple RNN.
 * for ea. training sample, we simply take *one element* of the training
   data at a particular point in the sequence (rather than the window-base
   n-gram approach of before.)
 * for the training step at current time t, we rely upon:
    a) the training input at current time t, AND
    b) the activation from previous time (t-1)
        (so we have to initialize a "blank activation" for use
         at the very first step, t := 1; this is h := the zero vector.)
    c) therefore, in a simple model with just *two* sets of weights
       (besides the one which handles the previous activation), the
       back-propagation due to comparing current output vs. current target
       will back-propagate a bundle of "nudges" dh_t given what W2_t
       is at the current time;
       this in turn must back-prop *weight deltas* to
       BOTH U_t (which applies to the previous activation)
       AND W1_t (which applies to the current training input.)
-}

-- RNN ~ Weights x Network.
-- We will model this using a separate collection of weights,
-- U, that we simply carry along while remembering to train.
data RNN = MkRNN {
  wts :: Weights,   -- <- U: h-to-h
  net :: Network }  -- <- (W: i-to-h) :&~ (V: h-to-o)

runRNN :: RNN
       -> Vector Double -- input vector
       -> Vector Double -- previous-step activation
       -> Vector Double -- prediction
runRNN rnn@(MkRNN
  u@(W uB uN)
  n@(
    w@(W wB wN) :&~
    O v@(W vB vN))) x_t h_t_1 =
    let z_u   = (uB + uN #> h_t_1) + -- weighted previous activation
                (wB + wN #> x_t)     -- weighted current training input
        h_t   = logistic z_u         -- current activation.
                                     -- *Need to include somewhere in output!*
        z_h   = (vB + vN #> h_t)     -- next layer of weights
        y_t   = logistic z_h         -- current final activation i.e. output
    in  y_t  -- ^ softmax usually, for tagging problems & similar
             --   (multiple way classification)

{-
 The below is *not* actually a full implementation of the simple RNN
 described at the beginning of Jurafsky Ch. 9, because it does not
 perform the overall training in the two-pass algorithm which is
 explained there.
 In particular, the first pass is more or less all here, but the
 second pass (Backpropgataion Through Time) is *not* taking place right now.
 The idea is actually to *wait* (I think?) until all of y_1, ..., y_l have been
 attempted, *then* (in phase #2) work backwards & successive apply gradient
 terms to V, U, W, U, W, U, W ... (? sequence of matrices being adjusted),
 propagating error back through h_l, h_(l-1), h_(l-2) ... , h_1 *all in one phase*!

 The idea is that, instead of just nudging the matrix entries of U (the recurrent
 part) once per training sample, you would actually wait until the end, and *then*
 have steps iteratively unfolding along the lines of:

 dh_t       = tr vN #> dEdz
 dh_(t-1)   = tr uN #> dEdh_t
 dh_(t-2)   = tr uN #> dEdh_(t-1)
 dh_(t-3)   = tr uN #> dEdh_(t-2)
 ...

-}

trainRNN :: RNN -- ~ U x (W :&~ O V) :
                -- the  graph for this neural network is
                -- as follows:
                {-
                  h_t-1 -> U -> h_t -> V -> y_t
                              ^
                  x     -> W /
                -}
          -> Double        -- training rate
          -> Vector Double -- activation, h_t-1
          -> Vector Double -- training input, x_t
          -> Vector Double -- training target output, tgt_t
          -> (Vector Double, RNN) -- the new activation, h_t, and
                                  -- all three weight-sets of the RNN trained
-- -- don't write recursions, just do everything by hand
trainRNN rnn@(MkRNN
  u@(W uB uN)
  n@(
    w@(W wB wN) :&~
    O v@(W vB vN))) rate h_t_1 x_t tgt_t =
  -- compute the model output
  let z_u   = (uB + uN #> h_t_1) + -- weighted previous activation
              (wB + wN #> x_t)     -- weighted current training input
      h_t   = logistic z_u         -- current activation.
                                   -- *Need to include somewhere in output!*
      z_h   = (vB + vN #> h_t)     -- next layer of weights
      y_t   = logistic z_h         -- current final activation i.e. output
      -- Here, E = (y_t - tgt_t) ^ 2 is implied.
      dEdz = logistic' z_h * (y_t - tgt_t) -- this vector reports, for each
                                            -- component of the final activation (y_t)_j,
                                            -- how much a unit "bump" to it will impact the
                                            -- matching component (E_t)_j of the error,
                                            -- which is not explicitly calculated here.
      -- Bump the preceding-weights bias-vector vB in the opposite direction
      -- of dEdy, & (per component) in proportion with the impact that its change
      -- has on the error E. This is (- scale rate dEdy) (we scale by learning rate)
      vB'   = vB - scale rate dEdz
      -- Bump every matrix entry in vN by the appropriate amount.
      -- Row #1's matrix-entry bumps are given by transposing the layer input (h_t)'s
      -- entries by (- scale rate dEdy)_1, then transposing (so that connections from the
      -- 1st component of h_t will be reinforced appropriately.)
      -- Do this for all entries of "d_vB / d_y = -scale rate dEdy", and you will get
      vN'   = vN + ((- scale rate dEdz) `outer` h_t)
      -- The above two terms vB', vN' specified how to "bump" the entries of the V-layer
      -- bias & weights matrix, given what the layer input h_t currently is.
      -- Now, figure out how to "bump" the entries of the V-layer input h_t,
      -- given what the current V-layer weights vB / vN are.
      -- In fact, only vN will play any role.
      dh_t  = tr vN #> dEdz -- should it be (- scale rate dEdy)?
      -- I think that the learning rate factor is omitted when back-propagating
      -- a new error to the preceding layer, because otherwise the n-th layer back
      -- would get a factor of (rate ^ n) -> 0 as n increases, causing only the
      -- very few final layers to really be modified.

      -- Now, backpropagate this desired change in h_t to train the wts in U, W.
      -- Just as we previously had      "dy := - scale rate dEdy"
      -- so also will we now have       "dEdh := logistic' h_t * dh_t"
      --                                "dh := - scale rate dEdh"
      -- Train both U (whose input was h_t_1) and W (whose input was x_t).
      -- The activation, h_t, on these linear maps' composite result is now
      -- the vector being nudged, because it was the input of the final layer.
      dEdh  = logistic' h_t * dh_t

      uB'   = uB - scale rate dEdh
      uN'   = uN + ((- scale rate dEdh) `outer` h_t_1)
      wB'   = wB - scale rate dEdh
      wN'   = wN + ((- scale rate dEdh) `outer` x_t)  -- x_t *not* h_t / h_t_1
  in  ( h_t,                  -- the new activation
        MkRNN                 -- the new RNN
          (W uB' uN')
          ((W wB' wN') :&~
            O (W vB' vN')))

-- Sample function for using trainRNN one time.
f = do
    rnn_0 <- evalRandIO (randRNN 1 2 5)
    let h_rnn' =
          trainRNN rnn_0 0.25
                   (vector $ fromIntegral <$> [0,0,0,0,0])
                   (vector $ fromIntegral <$> [0])
                   (vector $ fromIntegral <$> [1,4])
    return h_rnn'

-- Need function to product a random RNN.
-- The relevant dimensions need to be:

{-
h_t-1 -> U -> h_t -> V -> y_t
            ^
x     -> W /

For x (input vector)  - dim(x): m
    h (activation)    - dim(h): h
    y (output vector) - dim(y): n
we have that the matrix sizes should be
  W:  h * m
  U:  h * h
  V:  n * h

rnn@(MkRNN
  u@(W uB uN)
  n@(
    w@(W wB wN) :&~
    O v@(W vB vN)))
-}
randRNN :: MonadRandom m => Int   -- input vector dim
                         -> Int   -- output vector dim
                         -> Int   -- hidden vector dim
                         -> m RNN
randRNN i o h = do
  u <- randomWeights h h
  w <- randomWeights i h
  v <- randomWeights h o
  return $ MkRNN u (w :&~ O v)

{-
 A typical form of training data to take will be
 a list [(inp, outp)] with inp  :: Vector Double
                           outp :: Vector Double
-}

foldRNNTraining :: Double
                -> (Vector Double, RNN)    -- initial hidden state & RNN
                -> [(Vector Double,        -- training data
                     Vector Double)]
                -> IO (Vector Double, RNN) -- final hidden state & trained RNN
foldRNNTraining rate (h_0, rnn_0) pairs =
  foldl (\io p@(x, tgt) -> do
              (h, rnn) <- io
              putStrLn $ "Current prediction given: " ++ show x
                         ++ " is: " ++ show (runRNN rnn x h)
              let h_rnn' = trainRNN rnn rate h x tgt
              return h_rnn')
          (return (h_0, rnn_0))
          pairs

displayRNNTraining :: Double            -- training rate
                   -- -> Vector Double     -- initial activation vector h_0
                   -> [(Vector Double,  -- lists of training inputs
                        Vector Double)] -- paired with target outputs
                   -> IO ()
displayRNNTraining rate pairs = do
  -- get a random RNN
  randRNN <- evalRandIO (randRNN 1 1 5)
  -- we will always use an initial activation h_0 of zeroes
  let h_0 = vector $ fromIntegral <$> (take 5 $ repeat 0)
  foldRNNTraining rate (h_0, randRNN) pairs
  return ()

-- no n-gram window this time, just inputs & outputs one at a time each.
rnn_training_data :: [(Vector Double,  -- 1 * 1
                       Vector Double)] -- 1 * 1
rnn_training_data =
  let fin_pattern = take fin_pttrn_len inf_pattern
      list_pairs =
        [ (take 1 sub_pattern, [sub_pattern !! 1])
            | j <- [0..(length fin_pattern - 2)],
              let sub_pattern = drop j fin_pattern ]
  in map (\(inp, out) -> (vector $ fromIntegral <$> inp,
                          vector $ fromIntegral <$> out))
         list_pairs

-- Retry the simple RNN training using softmax.
-- But at the same time, the 1-vectors in the training data
-- [(inp, out)] pairs should become one-hot encoding 3-vectors.
-- Likewise, we will want 'randRNN 3 3 5' (5 the size of the hidden layer.)
softmax :: Vector Double -> Vector Double
softmax v =
  let vexp = exp v :: Vector Double
  in  vexp / (scalar $ sumElements vexp)

-- Note that the derivative of (vector) softmax is matrix-valued
softmax' :: Vector Double -> Matrix Double
softmax' v =
  let s = softmax v
  in  diag s - s `outer` s

runRNN_softmax :: RNN
               -> Vector Double -- input vector
               -> Vector Double -- previous-step activation
               -> Vector Double -- prediction
runRNN_softmax rnn@(MkRNN
  u@(W uB uN)
  n@(
    w@(W wB wN) :&~
    O v@(W vB vN))) x_t h_t_1 =
    let z_u   = (uB + uN #> h_t_1) +
                (wB + wN #> x_t)
        h_t   = logistic z_u
        z_h   = (vB + vN #> h_t)
        y_t   = softmax z_h
    in  y_t  -- ^ softmax usually, for tagging problems & similar
             --   (multiple way classification)

trainRNN_softmax  :: RNN
                  -> Double
                  -> Vector Double
                  -> Vector Double
                  -> Vector Double
                  -> (Vector Double, RNN)
trainRNN_softmax rnn@(MkRNN
  u@(W uB uN)
  n@(
    w@(W wB wN) :&~
    O v@(W vB vN))) rate h_t_1 x_t tgt_t =
  let z_u   = (uB + uN #> h_t_1) +
              (wB + wN #> x_t)
      h_t   = logistic z_u
      z_h   = (vB + vN #> h_t)
      y_t   = softmax z_h                   -- <-
      dEdz  = softmax' z_h #> (y_t - tgt_t)  -- <-
      vB'   = vB - scale rate dEdz
      vN'   = vN + ((- scale rate dEdz) `outer` h_t)
      dh_t  = tr vN #> dEdz
      dEdh  = logistic' h_t * dh_t

      uB'   = uB - scale rate dEdh
      uN'   = uN + ((- scale rate dEdh) `outer` h_t_1)
      wB'   = wB - scale rate dEdh
      wN'   = wN + ((- scale rate dEdh) `outer` x_t)
  in  ( h_t,
        MkRNN
          (W uB' uN')
          ((W wB' wN') :&~
            O (W vB' vN')))

foldRNNTraining_softmax :: Double
                        -> (Vector Double, RNN)    -- initial hidden state & RNN
                        -> [(Vector Double,        -- training data
                             Vector Double)]
                        -> IO (Vector Double, RNN) -- final hidden state & trained RNN
foldRNNTraining_softmax rate (h_0, rnn_0) pairs =
  foldl (\io p@(x, tgt) -> do
              (h, rnn) <- io
              putStrLn $ "Current prediction given: " ++ show x
                         ++ " is: " ++ show (runRNN_softmax rnn x h)
              let h_rnn' = trainRNN_softmax rnn rate h x tgt
              return h_rnn')
          (return (h_0, rnn_0))
          pairs

displayRNNTraining_softmax :: Double
                           -> [(Vector Double,  -- lists of training inputs
                                Vector Double)] -- paired with target outputs
                           -> IO ()
displayRNNTraining_softmax rate pairs = do
  -- get a random RNN
  randRNN <- evalRandIO (randRNN 3 3 7)
  -- we will always use an initial activation h_0 of zeroes
  let h_0 = vector $ fromIntegral <$> (take 7 $ repeat 0)
  foldRNNTraining_softmax rate (h_0, randRNN) pairs
  return ()

--
to_onehot :: [Int] -> Vector Double
to_onehot m = case m of
  [0] -> vector $ fromIntegral <$> [1, 0, 0]
  [1] -> vector $ fromIntegral <$> [0, 1, 0]
  [2] -> vector $ fromIntegral <$> [0, 0, 1]
  -- so that to_onehot won't be partial. Not using this branch
  _   -> vector $ fromIntegral <$> [0, 0, 0]

rnn_training_data_onehot :: [(Vector Double,  -- 3 * 1
                              Vector Double)] -- 3 * 1
rnn_training_data_onehot =
  let fin_pattern = take fin_pttrn_len inf_pattern
      list_pairs =
        [ (take 1 sub_pattern, [sub_pattern !! 1])
            | j <- [0..(length fin_pattern - 2)],
              let sub_pattern = drop j fin_pattern ]
  in map (\(inp, out) -> (to_onehot inp, to_onehot out))
         list_pairs

{-
 To see these examples in action:

 > displayTraining 0.25 training_data
 > displayRNNTraining 0.25 rnn_training_data
 > displayRNNTraining_softmax 0.25 rnn_training_data_onehot

-}

(!!?) :: [a] -> Int -> Maybe a
xs !!? i = listToMaybe (drop i xs)

main :: IO ()
main = return ()

max_stars_repo_name: enlambdment/ffnn-vs-rnn

max_issues_repo_name: enlambdment/ffnn-vs-rnn

max_forks_repo_name: enlambdment/ffnn-vs-rnn


text:
module Mandelbrot where

import Data.Complex
import qualified Data.Set as Set
import Data.Set (Set)
import Data.Function (on)
import Data.List (partition)
--import Data.Ratio

c = 0 :+ 0
man :: RealFloat a => Complex a -> Complex a -> Complex a
man c z = z*z + c

pixelSize
	:: (Int, Int)
	-> Double
	-> Double
	-> (Int, Int)
pixelSize maxSize w h =
	if (w/h) < (divInt mw mh)
		then (ceiling $ (fromIntegral mh)*w/h , mh)
		else (mw , ceiling $ (fromIntegral mw)*h/w)
	where
		(mw, mh) = maxSize

-- size = (px,py)
points
	:: (Int, Int)
	-> (Double, Double, Double, Double)
	-> ([((Int, Int), (Complex Double, Complex Double))], Int)
points size bounds =
	([
		(
			(x,(y+offset)) ,
			(\z -> (z,z))
			(
				( w * (divInt x (px-1)) + lB)
				:+
				(-h * (divInt y (py-1)) + uB)
			)
		)
		| y <- ys , x <- [0..(px-1)]
	], py) where
		ys = [0..(py-1)]
		rys = reverse ys
		(l, r, u, d) = bounds
		(lB, rB, uB, dB, offset) =
			if (u > 0.0) && (d < 0.0)
				then
					if u > -d
						then (l, r, u, 0, 0)
						else (l, r, 0, d, ((snd size) - py))
				else (l,r,u,d,0)
		(w, h) = (rB - lB, uB - dB)
		(px,py) = pixelSize size w h

divInt = (/) `on` fromIntegral

reduce = partition (\(x,(c,z)) -> magnitude z <= 2)
apply = map (\(x,(c,z)) -> (x,(c, man c z)))

ext: hs

max_stars_repo_name: dorobouNeko/haskell-mandelbrot

max_issues_repo_name: dorobouNeko/haskell-mandelbrot

max_forks_repo_name: dorobouNeko/haskell-mandelbrot


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

module Models where

import Foreign.Storable (Storable)
import Numeric.LinearAlgebra ((<.>), (<>), (#>), inv, sumElements, Container)
import Numeric.LinearAlgebra.Data (vector, matrix, Matrix, (><), Vector, tr'
                                  ,cmap, ident, size, fromRows)

class Trainable m a b where
  train :: m a b -> [(a,b)] -> m a b

class Predictive m where
  predict :: m a b -> a -> b

type LBWeights = Matrix Double
type LBFuncs a = [a -> Double]

data LBReg a b = LBReg { lbFuncs   :: LBFuncs a
                       , lbWeights :: LBWeights
                       , lbError   :: Double
                       , lbReg     :: Double
                       , lbPredict :: LBWeights
                                   -> LBFuncs a
                                   -> a
                                   -> b
                       }

instance Trainable LBReg [a] (Vector Double) where
  train = trainLBReg

instance Predictive LBReg where
  predict m = lbPredict m (lbWeights m) (lbFuncs m)

updateWeights x w e = x { lbWeights = w, lbError = e }

trainLBReg :: LBReg [a] (Vector Double) -> [([a], Vector Double)] -> LBReg [a] (Vector Double)
trainLBReg m d = updateWeights m w e where
  t    = fromRows (fmap snd d)
  fs   = lbFuncs m
  dps  = fmap fst d
  p    = lbPredict m
  reg  = lbReg m
  iden = ident $ 1 + (length . head) dps :: Matrix Double
  dm   = tr' $ (length fs >< length dps) $ fs <*> dps
  w    = (inv (cmap (reg*) iden + (tr' dm <> dm)) <>  tr' dm) <> t
  e    = 2--sosError t pr where pr = vector $ fmap (p w fs) dps

sosError :: Vector Double -> Vector Double -> Double
sosError t pr = 0--sumElements $ cmap ((/2) . (**2)) $ t - pr

lbEval :: LBWeights -> LBFuncs a -> a -> Vector Double
lbEval w fs d = tr' w #> vector (zipWith ($) fs $ replicate (length fs) d)

mkLBId :: Int -> LBFuncs [Double]
mkLBId n = const 1 : [(!!x) | x <- [0 .. n-1]]

mkSLBReg :: Double -> [([Double], Vector Double)] -> LBReg [Double] (Vector Double)
mkSLBReg reg ds = train LBReg { lbFuncs   = mkLBId n
                              , lbWeights = (n><k) [1 .. ]
                              , lbPredict = lbEval
                              , lbError   = fromIntegral (maxBound :: Int)
                              , lbReg     = reg
                              } ds where n = length $ fst $ head ds
                                         k = size $ snd $ head ds

max_stars_repo_name: sahabi/machinelearning

max_issues_repo_name: sahabi/machinelearning

max_forks_repo_name: sahabi/machinelearning


text:
{-|
Module : Mnist
|-}
module Mnist
  ( Image(..)
  , readTrainingData
  , readTestData
  , getData
  ) where

import qualified Codec.Compression.GZip as GZip
import qualified Data.ByteString.Lazy as BL
import Data.Binary.Get
import Data.Word
import qualified Data.List.Split as S
import Numeric.LinearAlgebra

-- | data representing an image
data Image = Image {
      iRows :: Int -- ^ Number of rows
    , iColumns :: Int -- ^ Number of columns
    , iPixels :: [Word8] -- ^ Pixels
    } deriving (Eq, Show)

-- | Create column vector of Image pixels
toColVector :: Image
         -> Matrix Double
toColVector image = (rc><1) p :: Matrix Double
  where rc = iRows image * iColumns image
        p = normalisedData image

-- | Normalise Image pixels
normalisedData :: Image -> [Double]
normalisedData image = normalisePixel <$> iPixels image

-- | Normalise pixel
normalisePixel :: Word8 -> Double
normalisePixel p = fromIntegral p / 255.0

{-
[offset] [type]          [value]          [description]
0000     32 bit integer  0x00000801(2049) magic number (MSB first)
0004     32 bit integer  60000            number of items
0008     unsigned byte   ??               label
0009     unsigned byte   ??               label
 ........
xxxx     unsigned byte   ??               label
The labels values are 0 to 9.
-}

-- | Extract information from labels file
deserialiseLabels :: Get (Word32, Word32, [Word8])
deserialiseLabels = do
  magicNumber <- getWord32be
  count <- getWord32be
  labelData <- getRemainingLazyByteString
  let labels = BL.unpack labelData
  return (magicNumber, count, labels)

-- | Read labels from file
readLabels :: FilePath -> IO [Int]
readLabels filename = do
  content <- GZip.decompress <$> BL.readFile filename
  let (_, _, labels) = runGet deserialiseLabels content
  return (fromIntegral <$> labels)

{-
[offset] [type]          [value]          [description]
0000     32 bit integer  0x00000803(2051) magic number
0004     32 bit integer  60000            number of images
0008     32 bit integer  28               number of rows
0012     32 bit integer  28               number of columns
0016     unsigned byte   ??               pixel
0017     unsigned byte   ??               pixel
 ........
xxxx     unsigned byte   ??               pixel
Pixels are organized row-wise. Pixel values are 0 to 255. 0 means background (white), 255 means foreground (black).
-}

-- | Extract information from image file
deserialiseHeader :: Get (Word32, Word32, Word32, Word32, [[Word8]])
deserialiseHeader = do
  magicNumber <- getWord32be
  imageCount <- getWord32be
  r <- getWord32be
  c <- getWord32be
  packedData <- getRemainingLazyByteString
  let len = fromIntegral (r * c)
  let unpackedData = S.chunksOf len (BL.unpack packedData)
  return (magicNumber, imageCount, r, c, unpackedData)

-- | Read Images form file
readImages :: FilePath -> IO [Image]
readImages filename = do
  content <- GZip.decompress <$> BL.readFile filename
  let (_, _, r, c, unpackedData) = runGet deserialiseHeader content
  return (Image (fromIntegral r) (fromIntegral c) <$> unpackedData)

-- | Create column vector of label
vectorizedLabels :: Int -> Matrix Double
vectorizedLabels x = (10><1) p :: Matrix Double
  where p = [i | j <- [0 .. 9], let i = if j == x then 1.0 else 0.0]

-- | Get training data
readTrainingData :: IO [(Matrix Double, Matrix Double)]
readTrainingData = do
  trainingLabels <- readLabels "train-labels-idx1-ubyte.gz"
  trainingImages <- readImages "train-images-idx3-ubyte.gz"
  return (zip (map toColVector trainingImages) (vectorizedLabels <$> trainingLabels))

-- | Get test data
readTestData :: IO [(Matrix Double, Int)]
readTestData = do
  testLabels <- readLabels "t10k-labels-idx1-ubyte.gz"
  testImages <- readImages "t10k-images-idx3-ubyte.gz"
  return (zip (map toColVector testImages) testLabels)

-- | Get training and test data
getData :: IO ([(Matrix Double, Matrix Double)], [(Matrix Double, Int)])
getData = do
  trainingData <- readTrainingData
  testData <- readTestData
  return (trainingData, testData)

max_stars_repo_name: Malenczuk/HuskNet

max_issues_repo_name: Malenczuk/HuskNet

max_forks_repo_name: Malenczuk/HuskNet


text:
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MagicHash             #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms       #-}
{-# LANGUAGE RebindableSyntax      #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeSynonymInstances  #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE ViewPatterns          #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module      : Data.Array.Accelerate.Data.Complex
-- Copyright   : [2015..2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--
-- Complex numbers, stored in the usual C-style array-of-struct representation,
-- for easy interoperability.
--
module Data.Array.Accelerate.Data.Complex (

  -- * Rectangular from
  Complex(..), pattern (::+),
  real,
  imag,

  -- * Polar form
  mkPolar,
  cis,
  polar,
  magnitude, magnitude',
  phase,

  -- * Conjugate
  conjugate,

) where

import Data.Array.Accelerate.Classes.Eq
import Data.Array.Accelerate.Classes.Floating
import Data.Array.Accelerate.Classes.Fractional
import Data.Array.Accelerate.Classes.FromIntegral
import Data.Array.Accelerate.Classes.Num
import Data.Array.Accelerate.Classes.Ord
import Data.Array.Accelerate.Classes.RealFloat
import Data.Array.Accelerate.Data.Functor
import Data.Array.Accelerate.Pattern
import Data.Array.Accelerate.Prelude
import Data.Array.Accelerate.Representation.Tag
import Data.Array.Accelerate.Representation.Type
import Data.Array.Accelerate.Representation.Vec
import Data.Array.Accelerate.Smart
import Data.Array.Accelerate.Sugar.Elt
import Data.Array.Accelerate.Sugar.Vec
import Data.Array.Accelerate.Type
import Data.Primitive.Vec

import Data.Complex                                                 ( Complex(..) )
import Prelude                                                      ( ($) )
import qualified Data.Complex                                       as C
import qualified Prelude                                            as P

infix 6 ::+
pattern (::+) :: Elt a => Exp a -> Exp a -> Exp (Complex a)
pattern r ::+ i <- (deconstructComplex -> (r, i))
  where (::+) = constructComplex
{-# COMPLETE (::+) #-}

-- Use an array-of-structs representation for complex numbers if possible.
-- This matches the standard C-style layout, but we can use this representation only at
-- specific types (not for any type 'a') as we can only have vectors of primitive type.
-- For other types, we use a structure-of-arrays representation. This is handled by the
-- ComplexR. We use the GADT ComplexR and function complexR to reconstruct
-- information on how the elements are represented.
--
instance Elt a => Elt (Complex a) where
  type EltR (Complex a) = ComplexR (EltR a)
  eltR = let tR = eltR @a
          in case complexR tR of
               ComplexVec s -> TupRsingle $ VectorScalarType $ VectorType 2 s
               ComplexTup   -> TupRunit `TupRpair` tR `TupRpair` tR

  tagsR = let tR = eltR @a
           in case complexR tR of
               ComplexVec s -> [ TagRsingle (VectorScalarType (VectorType 2 s)) ]
               ComplexTup   -> let go :: TypeR t -> [TagR t]
                                   go TupRunit         = [TagRunit]
                                   go (TupRsingle s)   = [TagRsingle s]
                                   go (TupRpair ta tb) = [TagRpair a b | a <- go ta, b <- go tb]
                                in
                                [ TagRunit `TagRpair` ta `TagRpair` tb | ta <- go tR, tb <- go tR ]

  toElt = case complexR $ eltR @a of
    ComplexVec _ -> \(Vec2 r i)   -> toElt r :+ toElt i
    ComplexTup   -> \(((), r), i) -> toElt r :+ toElt i

  fromElt (r :+ i) = case complexR $ eltR @a of
    ComplexVec _ -> Vec2 (fromElt r) (fromElt i)
    ComplexTup   -> (((), fromElt r), fromElt i)

type family ComplexR a where
  ComplexR Half   = Vec2 Half
  ComplexR Float  = Vec2 Float
  ComplexR Double = Vec2 Double
  ComplexR Int    = Vec2 Int
  ComplexR Int8   = Vec2 Int8
  ComplexR Int16  = Vec2 Int16
  ComplexR Int32  = Vec2 Int32
  ComplexR Int64  = Vec2 Int64
  ComplexR Word   = Vec2 Word
  ComplexR Word8  = Vec2 Word8
  ComplexR Word16 = Vec2 Word16
  ComplexR Word32 = Vec2 Word32
  ComplexR Word64 = Vec2 Word64
  ComplexR a      = (((), a), a)

-- This isn't ideal because we gather the evidence based on the
-- representation type, so we really get the evidence (VecElt (EltR a)),
-- which is not very useful...
--    - TLM 2020-07-16
data ComplexType a c where
  ComplexVec :: VecElt a => SingleType a -> ComplexType a (Vec2 a)
  ComplexTup ::                             ComplexType a (((), a), a)

complexR :: TypeR a -> ComplexType a (ComplexR a)
complexR = tuple
  where
    tuple :: TypeR a -> ComplexType a (ComplexR a)
    tuple TupRunit       = ComplexTup
    tuple TupRpair{}     = ComplexTup
    tuple (TupRsingle s) = scalar s

    scalar :: ScalarType a -> ComplexType a (ComplexR a)
    scalar (SingleScalarType t) = single t
    scalar VectorScalarType{}   = ComplexTup

    single :: SingleType a -> ComplexType a (ComplexR a)
    single (NumSingleType t) = num t

    num :: NumType a -> ComplexType a (ComplexR a)
    num (IntegralNumType t) = integral t
    num (FloatingNumType t) = floating t

    integral :: IntegralType a -> ComplexType a (ComplexR a)
    integral TypeInt    = ComplexVec singleType
    integral TypeInt8   = ComplexVec singleType
    integral TypeInt16  = ComplexVec singleType
    integral TypeInt32  = ComplexVec singleType
    integral TypeInt64  = ComplexVec singleType
    integral TypeWord   = ComplexVec singleType
    integral TypeWord8  = ComplexVec singleType
    integral TypeWord16 = ComplexVec singleType
    integral TypeWord32 = ComplexVec singleType
    integral TypeWord64 = ComplexVec singleType

    floating :: FloatingType a -> ComplexType a (ComplexR a)
    floating TypeHalf   = ComplexVec singleType
    floating TypeFloat  = ComplexVec singleType
    floating TypeDouble = ComplexVec singleType

constructComplex :: forall a. Elt a => Exp a -> Exp a -> Exp (Complex a)
constructComplex r i =
  case complexR (eltR @a) of
    ComplexTup   -> coerce $ T2 r i
    ComplexVec _ -> V2 (coerce @a @(EltR a) r) (coerce @a @(EltR a) i)

deconstructComplex :: forall a. Elt a => Exp (Complex a) -> (Exp a, Exp a)
deconstructComplex c@(Exp c') =
  case complexR (eltR @a) of
    ComplexTup   -> let T2 r i = coerce c in (r, i)
    ComplexVec t -> let T2 r i = Exp (SmartExp (VecUnpack (VecRsucc (VecRsucc (VecRnil t))) c'))
                     in (r, i)

coerce :: EltR a ~ EltR b => Exp a -> Exp b
coerce (Exp e) = Exp e

instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Complex a) where
  type Plain (Complex a) = Complex (Plain a)
  lift (r :+ i) = lift r ::+ lift i

instance Elt a => Unlift Exp (Complex (Exp a)) where
  unlift (r ::+ i) = r :+ i

instance Eq a => Eq (Complex a) where
  r1 ::+ c1 == r2 ::+ c2 = r1 == r2 && c1 == c2
  r1 ::+ c1 /= r2 ::+ c2 = r1 /= r2 || c1 /= c2

instance RealFloat a => P.Num (Exp (Complex a)) where
  (+)    = lift2 ((+) :: Complex (Exp a) -> Complex (Exp a) -> Complex (Exp a))
  (-)    = lift2 ((-) :: Complex (Exp a) -> Complex (Exp a) -> Complex (Exp a))
  (*)    = lift2 ((*) :: Complex (Exp a) -> Complex (Exp a) -> Complex (Exp a))
  negate = lift1 (negate :: Complex (Exp a) -> Complex (Exp a))
  signum z@(x ::+ y) =
    if z == 0
       then z
       else let r = magnitude z
             in x/r ::+ y/r
  abs z         = magnitude z ::+ 0
  fromInteger n = fromInteger n ::+ 0

instance RealFloat a => P.Fractional (Exp (Complex a)) where
  fromRational x  = fromRational x ::+ 0
  z / z'          = (x*x''+y*y'') / d ::+ (y*x''-x*y'') / d
    where
      x  :+ y   = unlift z
      x' :+ y'  = unlift z'
      --
      x'' = scaleFloat k x'
      y'' = scaleFloat k y'
      k   = - max (exponent x') (exponent y')
      d   = x'*x'' + y'*y''

instance RealFloat a => P.Floating (Exp (Complex a)) where
  pi                = pi ::+ 0
  exp (x ::+ y)     = let expx = exp x
                       in expx * cos y ::+ expx * sin y
  log z             = log (magnitude z) ::+ phase z
  sqrt z@(x ::+ y)  =
    if z == 0
      then 0
      else u ::+ (y < 0 ? (-v, v))
    where
      T2 u v = x < 0 ? (T2 v' u', T2 u' v')
      v'     = abs y / (u'*2)
      u'     = sqrt ((magnitude z + abs x) / 2)

  x ** y =
    if y == 0 then 1 else
    if x == 0 then if exp_r > 0 then 0 else
                   if exp_r < 0 then inf ::+ 0
                                else nan ::+ nan
              else if isInfinite r || isInfinite i
                     then if exp_r > 0 then inf ::+ 0 else
                          if exp_r < 0 then 0
                                       else nan ::+ nan
                     else exp (log x * y)
    where
      r     ::+ i  = x
      exp_r ::+ _  = y
      --
      inf = 1 / 0
      nan = 0 / 0

  sin (x ::+ y)  = sin x * cosh y ::+ cos x * sinh y
  cos (x ::+ y)  = cos x * cosh y ::+ (- sin x * sinh y)
  tan (x ::+ y)  = (sinx*coshy ::+ cosx*sinhy) / (cosx*coshy ::+ (-sinx*sinhy))
    where
      sinx  = sin x
      cosx  = cos x
      sinhy = sinh y
      coshy = cosh y

  sinh (x ::+ y) = cos y * sinh x ::+ sin  y * cosh x
  cosh (x ::+ y) = cos y * cosh x ::+ sin y * sinh x
  tanh (x ::+ y) = (cosy*sinhx ::+ siny*coshx) / (cosy*coshx ::+ siny*sinhx)
    where
      siny  = sin y
      cosy  = cos y
      sinhx = sinh x
      coshx = cosh x

  asin z@(x ::+ y) = y' ::+ (-x')
    where
      x' ::+ y' = log (((-y) ::+ x) + sqrt (1 - z*z))

  acos z                    = y'' ::+ (-x'')
    where
      x'' ::+ y''  = log (z + ((-y') ::+ x'))
      x'  ::+ y'   = sqrt (1 - z*z)

  atan z@(x ::+ y) = y' ::+ (-x')
    where
      x' ::+ y' = log (((1-y) ::+ x) / sqrt (1+z*z))

  asinh z =  log (z + sqrt (1+z*z))
  acosh z =  log (z + (z+1) * sqrt ((z-1)/(z+1)))
  atanh z =  0.5 * log ((1.0+z) / (1.0-z))

instance (FromIntegral a b, Num b, Elt (Complex b)) => FromIntegral a (Complex b) where
  fromIntegral x = fromIntegral x ::+ 0

-- | @since 1.2.0.0
--
instance Functor Complex where
  fmap f (r ::+ i) = f r ::+ f i

-- | The non-negative magnitude of a complex number
--
magnitude :: RealFloat a => Exp (Complex a) -> Exp a
magnitude (r ::+ i) = scaleFloat k (sqrt (sqr (scaleFloat mk r) + sqr (scaleFloat mk i)))
  where
    k     = max (exponent r) (exponent i)
    mk    = -k
    sqr z = z * z

-- | As 'magnitude', but ignore floating point rounding and use the traditional
-- (simpler to evaluate) definition.
--
-- @since 1.3.0.0
--
magnitude' :: RealFloat a => Exp (Complex a) -> Exp a
magnitude' (r ::+ i) = sqrt (r*r + i*i)

-- | The phase of a complex number, in the range @(-'pi', 'pi']@. If the
-- magnitude is zero, then so is the phase.
--
phase :: RealFloat a => Exp (Complex a) -> Exp a
phase z@(r ::+ i) =
  if z == 0
    then 0
    else atan2 i r

-- | The function 'polar' takes a complex number and returns a (magnitude,
-- phase) pair in canonical form: the magnitude is non-negative, and the phase
-- in the range @(-'pi', 'pi']@; if the magnitude is zero, then so is the phase.
--
polar :: RealFloat a => Exp (Complex a) -> Exp (a,a)
polar z =  T2 (magnitude z) (phase z)

-- | Form a complex number from polar components of magnitude and phase.
--
mkPolar :: forall a. Floating a => Exp a -> Exp a -> Exp (Complex a)
mkPolar = lift2 (C.mkPolar :: Exp a -> Exp a -> Complex (Exp a))

-- | @'cis' t@ is a complex value with magnitude @1@ and phase @t@ (modulo
-- @2*'pi'@).
--
cis :: forall a. Floating a => Exp a -> Exp (Complex a)
cis = lift1 (C.cis :: Exp a -> Complex (Exp a))

-- | Return the real part of a complex number
--
real :: Elt a => Exp (Complex a) -> Exp a
real (r ::+ _) = r

-- | Return the imaginary part of a complex number
--
imag :: Elt a => Exp (Complex a) -> Exp a
imag (_ ::+ i) = i

-- | Return the complex conjugate of a complex number, defined as
--
-- > conjugate(Z) = X - iY
--
conjugate :: Num a => Exp (Complex a) -> Exp (Complex a)
conjugate z = real z ::+ (- imag z)

max_stars_repo_name: jippiedoe/accelerate

max_issues_repo_name: jippiedoe/accelerate

max_forks_repo_name: jippiedoe/accelerate


text:
module Data.TestComplex where

import           Domains.Field
import           Domains.Ring
import           Prelude       hiding (Rational, gcd, negate, (*), (+), (-), (/), (^))

import           Data.Complex
import           Data.Rational

import           TestUtil

c :: Complex (Rational Int)
c = Rational 1 2 :+ Rational 5 7

--c :: Complex Double
--c = 0.5 :+ 0.25
run :: IO ()
run = do
  putStrLn ("c = " ++ show c)
  test "c + c" (Rational 1 1 :+ Rational 10 7) (c + c)
  test "c - c" (Rational 0 1 :+ Rational 0 1) (c - c)
  test "c * c" (Rational (-51) 196 :+ Rational 5 7) (c * c)
  test "c / c" (Rational 1 1 :+ Rational 0 1) (c / c)

max_stars_repo_name: pmilne/algebra

max_issues_repo_name: pmilne/algebra

max_forks_repo_name: pmilne/algebra


text:
{-# LANGUAGE FlexibleContexts #-}
---------------------------------------------------------------------------------
-- |
-- Module       : Amby.Numeric
-- Copyright    : (C) 2016 Justin Sermeno
-- License      : BSD3
-- Maintainer   : Justin Sermeno
--
-- Functions for working with numerical ranges and statistics.
---------------------------------------------------------------------------------
module Amby.Numeric
  ( -- * Ranges
    contDistrDomain
  , contDistrRange
  , linspace
  , arange
  , random

  -- * Frequencies
  , scoreAtPercentile
  , interquartileRange
  , freedmanDiaconisBins

  ) where

import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector as V

import Statistics.Distribution
import qualified Statistics.Quantile as Stats
import System.Random.MWC (withSystemRandom, asGenST)

-- $setup
-- >>> let demoData = V.fromList $ concat $ zipWith replicate [5, 4, 3, 7] [0..3]

---------------------
-- Ranges
---------------------

-- | @contDistrDomain d n@ generates a domain of 'n' evenly spaced points
-- for the continuous distribution 'd'.
contDistrDomain :: (ContDistr d) => d -> Int -> U.Vector Double
contDistrDomain d num = linspace (quantile d 0.0001) (quantile d 0.9999) num

-- | @contDistrRange d xs@ generates the pdf value of the continious distribution
-- 'd' for each value in 'xs'.
contDistrRange :: (ContDistr d) => d -> U.Vector Double -> U.Vector Double
contDistrRange d x = U.map (density d) x

-- | @linspace s e n@ generates 'n' evenly spaced values between ['s', 'e'].
linspace :: Double -> Double -> Int -> U.Vector Double
linspace start stop num
  | num < 0 = error ("Number of samples, " ++ show num ++ ", must be non-negative.")
  | num == 0 || num == 1 = addStart $ U.generate num ((* delta) . fromIntegral)
  | otherwise = addStart $ U.generate num ((* step) . fromIntegral)
  where
    delta = stop - start
    step = delta / fromIntegral (num - 1)
    addStart = U.map (realToFrac . (+ start))

-- | @arange s e i@ generates numbers between ['s', 'e'] spaced by amount 'i'.
-- 'arange' is the equivalent of haskell's range notation except that it generates
-- a 'Vector'. As a result, the last element may be greater than less than, or
-- greater than the stop point.
arange :: Double -> Double -> Double -> U.Vector Double
arange start stop step = U.fromList [start,(start + step)..stop]

-- | Generates an unboxed vectors of random numbers from a distribution
-- that is an instance of 'ContGen'. This function is meant for ease of use
-- and is expensive.
random :: (ContGen d) => d -> Int -> IO (U.Vector Double)
random d n = withSystemRandom . asGenST $ \gen ->
  U.replicateM n $ genContVar d gen

---------------------
-- Frequencies
---------------------

-- | @scoreAtPercentile xs p@ calculates the score at percentile 'p'.
--
-- Examples:
--
-- >>> let a = arange 0 99 1
--
-- >>> scoreAtPercentile a 50
-- 49.5
scoreAtPercentile :: (G.Vector v Double) => v Double -> Int -> Double
scoreAtPercentile xs p
  | G.length xs == 0 =
    modErr "scoreAtPercentile" "Cannot find percentile of empyt list"
  | otherwise = Stats.weightedAvg p 100 xs

-- | Calculate the interquartile range.
--
-- Examples:
--
-- >>> interquartileRange demoData
-- 2.5
interquartileRange :: (G.Vector v Double) => v Double -> Double
interquartileRange xs = scoreAtPercentile xs 75 - scoreAtPercentile xs 25
{-# SPECIALIZE interquartileRange :: U.Vector Double -> Double #-}
{-# SPECIALIZE interquartileRange :: V.Vector Double -> Double #-}

-- | Estimate a good default bin size.
--
-- Examples:
--
-- >>> freedmanDiaconisBins demoData
-- 2
freedmanDiaconisBins :: (G.Vector v Double) => v Double -> Int
freedmanDiaconisBins xs =
    if h == 0
      then floor $ sqrt $ (fromIntegral n :: Double)
      else ceiling $ (G.maximum xs - G.minimum xs) / h
  where
    n = G.length xs
    h = 2 * interquartileRange xs / fromIntegral n ** (1 / 3)

modErr :: String -> String -> a
modErr f err = error
  $ showString "Amby.Numeric."
  $ showString f
  $ showString ": " err

max_stars_repo_name: jsermeno/amby

max_issues_repo_name: jsermeno/amby

max_forks_repo_name: jsermeno/amby


text:
module Grenade.Dynamic.Recurrent.Layers.LSTM where

import           GHC.TypeLits

import           Numeric.LinearAlgebra.Static

import           Grenade.Dynamic.Specification
import           Grenade.Recurrent.Layers.LSTM

-------------------- GNum instances --------------------

instance (KnownNat i, KnownNat o) => GNum (LSTM i o) where
  n |* (LSTM w m) = LSTM (n |* w) (n |* m)
  (LSTM w1 m1) |+ (LSTM w2 m2) = LSTM (w1 |+ w2) (m1 |+ m2)
  gFromRational r = LSTM (gFromRational r) (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)
    where
      v0 = konst 0
      w0 = konst 0
      u0 = konst 0

instance (KnownNat i, KnownNat o) => GNum (LSTMWeights i o) where
  n |* (LSTMWeights wf uf bf wi ui bi wo uo bo wc bc) =
    LSTMWeights
      (fromRational n * wf)
      (fromRational n * uf)
      (fromRational n * bf)
      (fromRational n * wi)
      (fromRational n * ui)
      (fromRational n * bi)
      (fromRational n * wo)
      (fromRational n * uo)
      (fromRational n * bo)
      (fromRational n * wc)
      (fromRational n * bc)
  (LSTMWeights wf1 uf1 bf1 wi1 ui1 bi1 wo1 uo1 bo1 wc1 bc1) |+ (LSTMWeights wf2 uf2 bf2 wi2 ui2 bi2 wo2 uo2 bo2 wc2 bc2) =
    LSTMWeights (wf1 + wf2) (uf1 + uf2) (bf1 + bf2) (wi1 + wi2) (ui1 + ui2) (bi1 + bi2) (wo1 + wo2) (uo1 + uo2) (bo1 + bo2) (wc1 + wc2) (bc1 + bc2)
  gFromRational r = LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0
    where
      v0 = fromRational r
      w0 = fromRational r
      u0 = fromRational r

max_stars_repo_name: th-char/grenade

max_issues_repo_name: th-char/grenade

max_forks_repo_name: th-char/grenade


text:
-- {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds, GADTs, TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}

module UnitBLAS.Level3(unitTestLevel3BLAS) where

import Test.HUnit
--import Numerical.Array.Shape as S
import Prelude as P
import Test.Tasty
import Test.Tasty.HUnit

import qualified Data.Vector.Storable as SV
import qualified Data.Vector.Storable.Mutable as SMV

import Data.Complex

import  Numerical.HBLAS.MatrixTypes as Matrix
import  Numerical.HBLAS.BLAS as BLAS

matmatTest1SGEMM:: IO ()
matmatTest1SGEMM = do
    left  <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const (1.0 :: Float))
    right <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const (1.0 :: Float))
    res   <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const (0.0 :: Float))
    BLAS.sgemm Matrix.NoTranspose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= [2,2,2,2]

matmatTest1DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest1DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (2,2) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (2,2) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (2,2) (const 0.0)
    BLAS.dgemm Matrix.NoTranspose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= [2.0,2.0,2.0,2.0]

matmatTest2DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest2DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (3,2) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (5,3) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (5,2) (const 0.0)
    BLAS.dgemm Matrix.NoTranspose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= replicate 10 3

matmatTest3DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest3DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (2,3) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (5,3) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (5,2) (const 0.0)
    BLAS.dgemm Matrix.Transpose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= replicate 10 3

matmatTest3aDGEMM :: Matrix.SOrientation x -> IO ()
matmatTest3aDGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (2,3) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (2,3) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (3,3) (const 0.0)
    BLAS.dgemm Matrix.NoTranspose Matrix.Transpose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= replicate 9 2

matmatTest4DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest4DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (3,2) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (3,5) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (5,2) (const 0.0)
    BLAS.dgemm Matrix.NoTranspose Matrix.Transpose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= replicate 10 3

matmatTest5DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest5DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or  (2,3) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or  (3,5) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or  (5,2) (const 0.0)
    BLAS.dgemm Matrix.Transpose Matrix.Transpose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= replicate 10 3

matmatTest6DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest6DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (3,2) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (3,2) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (3,3) (const 0.0)
    BLAS.dgemm Matrix.Transpose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= replicate 9 2

matmatTest7DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest7DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (2,64) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (2,64) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (2,2) (const 0.0)
    BLAS.dgemm Matrix.Transpose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= replicate 4 64

matmatTest8DGEMM :: Matrix.SOrientation x -> IO ()
matmatTest8DGEMM or = do
    left  <- Matrix.generateMutableDenseMatrix or (2,9) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix or (2,9) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix or (2,2) (const 0.0)
    BLAS.dgemm Matrix.Transpose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= replicate 4 9

matmatTest1CGEMM:: IO ()
matmatTest1CGEMM = do
    left  <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 0.0)
    BLAS.cgemm Matrix.NoTranspose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= [2.0,2.0,2.0,2.0]

matmatTest1ZGEMM:: IO ()
matmatTest1ZGEMM = do
    left  <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 1.0)
    right <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 1.0)
    res   <- Matrix.generateMutableDenseMatrix (Matrix.SRow)  (2,2) (const 0.0)
    BLAS.zgemm Matrix.NoTranspose Matrix.NoTranspose 1.0 1.0 left right res
    resList <- Matrix.mutableVectorToList $ _bufferDenMutMat res
    resList @?= [2.0,2.0,2.0,2.0]

unitTestLevel3BLAS = testGroup "BLAS Level 3 tests " [
    testCase "sgemm on 2x2 all 1s"    matmatTest1SGEMM
    ,testCase "dgemm on 2x2 all 1s" $ matmatTest1DGEMM Matrix.SRow
    ,testCase "dgemm on 3x2 and 5x3 all 1s" $ matmatTest2DGEMM Matrix.SRow
    ,testCase "dgemm on 2x3^T and 5x3 all 1s" $ matmatTest3DGEMM Matrix.SRow
    ,testCase "dgemm on 2x3 and 2x3^T all 1s" $ matmatTest3aDGEMM Matrix.SRow
    ,testCase "dgemm on 3x2 and 3x5^T all 1s" $ matmatTest4DGEMM Matrix.SRow
    ,testCase "dgemm on 2x3^T and 3x5^T all 1s" $ matmatTest5DGEMM Matrix.SRow
    ,testCase "dgemm on 3x2^T and 3x2 all 1s" $ matmatTest6DGEMM Matrix.SRow
    ,testCase "dgemm on 2x64^T and 2x64 all 1s" $ matmatTest7DGEMM Matrix.SRow
    ,testCase "dgemm on 2x9^T and 2x9 all 1s" $ matmatTest8DGEMM Matrix.SRow
    ,testCase "dgemm on 2x2 all 1s (column oriented)" $ matmatTest1DGEMM Matrix.SColumn
    ,testCase "dgemm on 3x2 and 5x3 all 1s (column oriented)" $ matmatTest2DGEMM Matrix.SColumn
    ,testCase "dgemm on 2x3^T and 5x3 all 1s (column oriented)" $ matmatTest3DGEMM Matrix.SColumn
    ,testCase "dgemm on 2x3 and 2x3^T all 1s (column oriented)" $ matmatTest3aDGEMM Matrix.SColumn
    ,testCase "dgemm on 3x2 and 3x5^T all 1s (column oriented)" $ matmatTest4DGEMM Matrix.SColumn
    ,testCase "dgemm on 2x3^T and 3x5^T all 1s (column oriented)" $ matmatTest5DGEMM Matrix.SColumn
    ,testCase "dgemm on 3x2^T and 3x2 all 1s (column oriented)" $ matmatTest6DGEMM Matrix.SColumn
    ,testCase "dgemm on 2x64^T and 2x64 all 1s (column oriented)" $ matmatTest7DGEMM Matrix.SColumn
    ,testCase "dgemm on 2x9^T and 2x9 all 1s (column oriented)" $ matmatTest8DGEMM Matrix.SColumn
    ,testCase "cgemm on 2x2 all 1s" matmatTest1CGEMM
    ,testCase "zgemm on 2x2 all 1s" matmatTest1ZGEMM
    ]

----unitTestShape = testGroup "Shape Unit tests"
----    [ testCase "foldl on shape" $ ( S.foldl (+) 0 (1:* 2:* 3 :* Nil )  @?=  ( P.foldl   (+) 0  [1,2,3])  )
----    , testCase "foldr on shape" $ ( S.foldr (+) 0 (1:* 2:* 3 :* Nil )  @?=  ( P.foldr  (+) 0  [1,2,3])  )
----    , testCase "scanr1 on shape" (S.scanr1 (+) 0 (1:* 1 :* 1:* Nil )   @?=  (3:* 2:* 1 :* Nil ) )
----    , testCase "scanl1 on shape" (S.scanl1 (+) 0 (1:* 1 :* 1:* Nil )   @?=  (1:* 2:* 3:* Nil ) )
----    ]

--turn the following into the first level 2 test

---- {-# LANGUAGE ScopedTypeVariables, DataKinds, CPP #- }
--import Numerical.HBLAS.BLAS.FFI
--import Numerical.HBLAS.BLAS
--import Numerical.HBLAS.MatrixTypes
--import Data.Vector.Storable.Mutable as M
--import qualified Data.Vector.Storable as S

--main :: IO ()
--main = do
--  -- Just test that the symbol resolves
--  --openblas_set_num_threads_unsafe 7
--  v  :: IOVector Double <- M.replicate 10 1.0
-- #if defined(__GLASGOW_HASKELL_) && (__GLASGOW_HASKELL__ <= 704)
--  --this makes 7.4 panic!
--  (leftMat :: IODenseMatrix Row Float) <-  generateMutableDenseMatrix SRow (5,5) (const 1.0 ::Float )
--  (rightMat :: IODenseMatrix Row Float) <-  generateMutableDenseMatrix SRow (5,5) (const 1.0 ::Float )
--  (resMat :: IODenseMatrix Row Float) <-  generateMutableDenseMatrix SRow (5,5) (const 1.0 ::Float )
--  sgemm NoTranspose NoTranspose 1.0 1.0 leftMat rightMat resMat
--  --(MutableDenseMatrix _ _ _ _ buff) <- return resMat
--  theRestMat <- unsafeFreezeDenseMatrix resMat
--  putStrLn $ show theRestMat
-- #endif
----DenseMatrix SRow  5 5 5(fromList [11.0,11.0,11.0,11.0,11.0,11.0,11.0,11.0,11.0,11.0,51.0,51.0,51.0,51.0,51.0,51.0,51.0,51.0,51.0,51.0,251.0,251.0,251.0,251.0,251.0])
---- THAT IS WRONG
----Need to figure what whats going on here

--  putStrLn $ show res
--  putStrLn "it works!"

max_stars_repo_name: archblob/hblas

max_issues_repo_name: archblob/hblas

max_forks_repo_name: archblob/hblas


text:
{-# LANGUAGE BangPatterns #-}
module Polestar.Eval
  (termShift
  ,termTypeSubst
  ,termSubstD
  ,termSubst
  ,ValueBinding(..)
  ,getValueFromContext
  ,eval1
  ,eval
  ) where
import Polestar.Type
import Polestar.TypeCheck
import Data.Complex
import GHC.Float (expm1, log1p)

termSubstD :: Int -> Term -> Int -> Term -> Term
termSubstD !depth s !i t = case t of
  TmAbs name ty body -> TmAbs name (typeShift (-1) i ty) (termSubstD depth s (i + 1) body)
  TmTyAbs name bound body -> TmTyAbs name (typeShift (-1) i <$> bound) (termSubstD depth s (i + 1) body)
  TmRef j | j == i -> termShift depth 0 s
          | j > i -> TmRef (j - 1)
          | otherwise -> t
  TmApp u v -> TmApp (termSubstD depth s i u) (termSubstD depth s i v)
  TmTyApp u t -> TmTyApp (termSubstD depth s i u) (typeShift (-1) i t)
  TmLet name def body -> TmLet name (termSubstD depth s i def) (termSubstD depth s (i + 1) body) -- ?
  TmIf cond then_ else_ -> TmIf (termSubstD depth s i cond) (termSubstD depth s i then_) (termSubstD depth s i else_)
  TmPrim _ -> t
  TmCoerce x ty  -> TmCoerce (termSubstD depth s i x) (typeShift (-1) i ty)
  TmAlt name tys body -> TmAlt name (map (typeShift (-1) i) tys) (termSubstD depth s (i + 1) body)
  TmTuple components -> TmTuple $ termSubstD depth s i <$> components
  TmProj tuple j -> TmProj (termSubstD depth s i tuple) j
  TmCoherentTuple components -> TmCoherentTuple $ termSubstD depth s i <$> components

-- replaces occurrences of TRef j (j > i) with TRef (j-1), and TRef i with the given term
termSubst = termSubstD 0

natFromValue :: Term -> Either String Integer
natFromValue (TmPrim (PVZero)) = return 0
natFromValue (TmPrim (PVInt x)) | x >= 0 = return x
natFromValue _ = Left "type error (expected a natural number)"

intFromValue :: Term -> Either String Integer
intFromValue (TmPrim (PVZero)) = return 0
intFromValue (TmPrim (PVInt x)) = return x
intFromValue _ = Left "type error (expected an integer)"

nnrealFromValue :: Term -> Either String Double
nnrealFromValue (TmPrim (PVZero)) = return 0
nnrealFromValue (TmPrim (PVInt x)) | x >= 0 = return (fromIntegral x)
nnrealFromValue (TmPrim (PVReal x)) | x >= 0 = return x
nnrealFromValue _ = Left "type error (expected a non-negative real number)"

realFromValue :: Term -> Either String Double
realFromValue (TmPrim (PVZero)) = return 0
realFromValue (TmPrim (PVInt x)) = return (fromIntegral x)
realFromValue (TmPrim (PVReal x)) = return x
realFromValue _ = Left "type error (expected a real number)"

imaginaryFromValue :: Term -> Either String Double
imaginaryFromValue (TmPrim (PVZero)) = return 0
imaginaryFromValue (TmPrim (PVImaginary x)) = return x
imaginaryFromValue _ = Left "type error (expected an imaginary number)"

complexFromValue :: Term -> Either String (Complex Double)
complexFromValue (TmPrim (PVZero)) = return 0
complexFromValue (TmPrim (PVInt x)) = return (fromIntegral x)
complexFromValue (TmPrim (PVReal x)) = return (x:+0)
complexFromValue (TmPrim (PVImaginary x)) = return (0:+x)
complexFromValue (TmPrim (PVComplex z)) = return z
complexFromValue _ = Left "type error (expected a complex number)"

boolFromValue :: Term -> Either String Bool
boolFromValue (TmPrim (PVBool x)) = return x
boolFromValue _ = Left "type error (expected a boolean)"

applyBuiltinUnary :: Builtin -> Term -> Either String Term
applyBuiltinUnary f v = case f of
  BNegate -> case v of
    TmPrim PVZero -> return v
    TmPrim (PVInt x) -> return (TmPrim $ PVInt $ negate x)
    TmPrim (PVReal x) -> return (TmPrim $ PVReal $ negate x)
    TmPrim (PVImaginary x) -> return (TmPrim $ PVImaginary $ negate x)
    TmPrim (PVComplex x) -> return (TmPrim $ PVComplex $ negate x)
    _ -> Left "type error (expected an integer or a real number)"
  BLogicalNot -> (TmPrim . PVBool . not) <$> boolFromValue v
  BNatToInt -> (TmPrim . PVInt) <$> natFromValue v
  BNatToNNReal -> (TmPrim . PVReal . fromIntegral) <$> natFromValue v
  BIntToNat -> (\x -> if x >= 0 then TmPrim (PVInt x) else TmPrim PVZero) <$> intFromValue v
  BIntToReal -> (TmPrim . PVReal . fromIntegral) <$> intFromValue v
  BNNRealToReal -> (TmPrim . PVReal) <$> realFromValue v
  BRealToComplex -> (TmPrim . PVComplex . (:+0)) <$> realFromValue v
  BMkImaginary -> (TmPrim . PVImaginary) <$> realFromValue v
  BImaginaryToComplex -> (TmPrim . PVComplex . (0:+)) <$> imaginaryFromValue v
  BRealPart -> case v of
    TmPrim PVZero -> return v
    TmPrim (PVInt _) -> return v
    TmPrim (PVReal _) -> return v
    TmPrim (PVImaginary _) -> return $ TmPrim PVZero
    TmPrim (PVComplex z) -> return $ TmPrim (PVReal (realPart z))
    _ -> Left "type error (expected a complex number)"
  BImagPart -> case v of
    TmPrim PVZero -> return $ TmPrim PVZero
    TmPrim (PVInt _) -> return $ TmPrim PVZero
    TmPrim (PVReal _) -> return $ TmPrim PVZero
    TmPrim (PVImaginary x) -> return $ TmPrim (PVReal x)
    TmPrim (PVComplex z) -> return $ TmPrim (PVReal (imagPart z))
    _ -> Left "type error (expected a complex number)"
  BAbs -> case v of
    TmPrim PVZero -> return $ TmPrim PVZero
    TmPrim (PVInt x) -> return $ TmPrim (PVInt (abs x))
    TmPrim (PVReal x) -> return $ TmPrim (PVReal (abs x))
    TmPrim (PVImaginary x) -> return $ TmPrim (PVReal (abs x))
    TmPrim (PVComplex z) -> return $ TmPrim (PVReal (magnitude z))
    _ -> Left "type error (expected a complex number)"
  BSqrt -> case v of
    TmPrim PVZero -> return $ TmPrim PVZero
    TmPrim (PVInt x) | x >= 0 -> return $ TmPrim (PVReal (sqrt $ fromIntegral x))
    TmPrim (PVReal x) | x >= 0 -> return $ TmPrim (PVReal (sqrt x))
    TmPrim (PVImaginary x) -> return $ TmPrim (PVComplex (sqrt (0:+x)))
    TmPrim (PVComplex z) -> return $ TmPrim (PVComplex (sqrt z))
    _ -> Left "type error (expected a complex number)"
  BExp -> makeOverloadedFn [(TmPrim . PVReal . exp) <$> realFromValue v
                           ,(TmPrim . PVComplex . exp) <$> complexFromValue v
                           ]
  BExpm1 -> makeOverloadedFn [(TmPrim . PVReal . expm1) <$> realFromValue v
                             ,(TmPrim . PVComplex . expm1) <$> complexFromValue v
                             ]
  BLog -> makeOverloadedFn [(TmPrim . PVReal . log) <$> nnrealFromValue v
                           ,(TmPrim . PVComplex . log) <$> complexFromValue v
                           ]
  BLog1p -> makeOverloadedFn [(TmPrim . PVReal . log1p) <$> nnrealFromValue v
                             ,(TmPrim . PVComplex . log1p) <$> complexFromValue v
                             ]
  BSin -> makeOverloadedFn [(TmPrim . PVReal . sin) <$> realFromValue v
                           ,(TmPrim . PVImaginary . sinh) <$> imaginaryFromValue v
                           ,(TmPrim . PVComplex . sin) <$> complexFromValue v
                           ]
  BCos -> makeOverloadedFn [(TmPrim . PVReal . cos) <$> realFromValue v
                           ,(TmPrim . PVReal . cosh) <$> imaginaryFromValue v
                           ,(TmPrim . PVComplex . cos) <$> complexFromValue v
                           ]
  BTan -> makeOverloadedFn [(TmPrim . PVReal . tan) <$> realFromValue v
                           ,(TmPrim . PVComplex . tan) <$> complexFromValue v
                           ]
  BSinh -> makeOverloadedFn [(TmPrim . PVReal . sinh) <$> realFromValue v
                           ,(TmPrim . PVImaginary . sin) <$> imaginaryFromValue v
                           ,(TmPrim . PVComplex . sinh) <$> complexFromValue v
                           ]
  BCosh -> makeOverloadedFn [(TmPrim . PVReal . cosh) <$> realFromValue v
                           ,(TmPrim . PVReal . cos) <$> imaginaryFromValue v
                           ,(TmPrim . PVComplex . cosh) <$> complexFromValue v
                           ]
  BTanh -> makeOverloadedFn [(TmPrim . PVReal . tan) <$> realFromValue v
                            ,(TmPrim . PVImaginary . tanh) <$> imaginaryFromValue v
                            ,(TmPrim . PVComplex . tan) <$> complexFromValue v
                            ]
  BAsin -> makeOverloadedFn [(TmPrim . PVImaginary . asinh) <$> imaginaryFromValue v
                            ,(TmPrim . PVComplex . asin) <$> complexFromValue v
                            ]
  BAcos -> makeOverloadedFn [(TmPrim . PVComplex . acos) <$> complexFromValue v
                            ]
  BAtan -> makeOverloadedFn [(TmPrim . PVReal . atan) <$> realFromValue v
                            ,(TmPrim . PVComplex . atan) <$> complexFromValue v
                            ]
  BAsinh -> makeOverloadedFn [(TmPrim . PVReal . asinh) <$> realFromValue v
                             ,(TmPrim . PVComplex . asinh) <$> complexFromValue v
                             ]
  BAcosh -> makeOverloadedFn [(TmPrim . PVReal . acosh) <$> realFromValue v
                             ]
  BAtanh -> makeOverloadedFn [(TmPrim . PVImaginary . atan) <$> imaginaryFromValue v
                             ,(TmPrim . PVComplex . atanh) <$> complexFromValue v
                             ]
  _ -> Left "applyBuiltinUnary: not unary"

makeOverloadedFn :: [Either String Term] -> Either String Term
makeOverloadedFn [] = Left "no overload"
makeOverloadedFn [x] = x
makeOverloadedFn (Left _ : xs) = makeOverloadedFn xs
makeOverloadedFn (Right x : xs) = Right x

isZero :: Term -> Bool
isZero (TmPrim PVZero) = True
isZero _ = False

isNonNegative :: Term -> Bool
isNonNegative (TmPrim PVZero) = True
isNonNegative (TmPrim (PVInt x)) = x >= 0
isNonNegative (TmPrim (PVReal x)) = x >= 0
isNonNegative _ = False

applyBuiltinBinary :: Builtin -> Term -> Term -> Either String Term
applyBuiltinBinary f u v = case f of
  BAdd -> makeOverloadedFn [if isZero u && isZero v then return (TmPrim PVZero) else Left "not zero"
                           ,(TmPrim . PVInt) <$> ((+) <$> intFromValue u <*> intFromValue v)
                           ,(TmPrim . PVReal) <$> ((+) <$> realFromValue u <*> realFromValue v)
                           ,(TmPrim . PVImaginary) <$> ((+) <$> imaginaryFromValue u <*> imaginaryFromValue v)
                           ,(TmPrim . PVComplex) <$> ((+) <$> complexFromValue u <*> complexFromValue v)
                           ]
  BSub -> makeOverloadedFn [if isZero u && isZero v then return (TmPrim PVZero) else Left "not zero"
                           ,(TmPrim . PVInt) <$> ((-) <$> intFromValue u <*> intFromValue v)
                           ,(TmPrim . PVReal) <$> ((-) <$> realFromValue u <*> realFromValue v)
                           ,(TmPrim . PVImaginary) <$> ((-) <$> imaginaryFromValue u <*> imaginaryFromValue v)
                           ,(TmPrim . PVComplex) <$> ((-) <$> complexFromValue u <*> complexFromValue v)
                           ]
  BMul -> makeOverloadedFn [if isZero u || isZero v then return (TmPrim PVZero) else Left "not zero"
                           ,(TmPrim . PVInt) <$> ((*) <$> intFromValue u <*> intFromValue v)
                           ,(TmPrim . PVReal) <$> ((*) <$> realFromValue u <*> realFromValue v)
                           ,(TmPrim . PVImaginary) <$> ((*) <$> realFromValue u <*> imaginaryFromValue v)
                           ,(TmPrim . PVImaginary) <$> ((*) <$> imaginaryFromValue u <*> realFromValue v)
                           ,(TmPrim . PVReal . negate) <$> ((*) <$> imaginaryFromValue u <*> imaginaryFromValue v)
                           ,(TmPrim . PVComplex) <$> ((*) <$> complexFromValue u <*> complexFromValue v)
                           ]
  BDiv -> makeOverloadedFn [(TmPrim . PVReal) <$> ((/) <$> realFromValue u <*> realFromValue v)
                           ,(TmPrim . PVImaginary) <$> ((/) <$> imaginaryFromValue u <*> realFromValue v)
                           ,(TmPrim . PVImaginary . negate) <$> ((/) <$> realFromValue u <*> imaginaryFromValue v)
                           ,(TmPrim . PVReal) <$> ((/) <$> imaginaryFromValue u <*> imaginaryFromValue v)
                           ,(TmPrim . PVComplex) <$> ((/) <$> complexFromValue u <*> complexFromValue v)
                           ]
  BPow -> makeOverloadedFn [if isZero v then return (TmPrim (PVInt 1)) else Left "not zero"
                           ,(TmPrim . PVInt) <$> ((^) <$> intFromValue u <*> natFromValue v)
                           ,(TmPrim . PVReal) <$> ((**) <$> nnrealFromValue u <*> realFromValue v)
                           ,(TmPrim . PVReal) <$> ((^^) <$> realFromValue u <*> intFromValue v)
                           ,(TmPrim . PVComplex) <$> ((**) <$> complexFromValue u <*> complexFromValue v)
                           ]
  BTSubNat -> do u' <- natFromValue u
                 v' <- natFromValue v
                 let w | u' >= v' = u' - v'
                       | otherwise = 0
                 return (TmPrim (PVInt w))
  BLt -> (TmPrim . PVBool) <$> ((<) <$> realFromValue u <*> realFromValue v)
  BLe -> (TmPrim . PVBool) <$> ((<=) <$> realFromValue u <*> realFromValue v)
  BEqual -> (TmPrim . PVBool) <$> ((==) <$> complexFromValue u <*> complexFromValue v)
  BMax -> makeOverloadedFn [(TmPrim . PVInt) <$> (max <$> intFromValue u <*> intFromValue v)
                           ,(TmPrim . PVReal) <$> (max <$> realFromValue u <*> realFromValue v)
                           ]
  BMin -> makeOverloadedFn [if (isZero u && isNonNegative v) || (isZero v && isNonNegative u) then return (TmPrim PVZero) else Left "not zero"
                           ,(TmPrim . PVInt) <$> (min <$> intFromValue u <*> intFromValue v)
                           ,(TmPrim . PVReal) <$> (min <$> realFromValue u <*> realFromValue v)
                           ]
  BIntDiv -> (TmPrim . PVInt) <$> (div <$> intFromValue u <*> intFromValue v)
  BIntMod -> (TmPrim . PVInt) <$> (mod <$> intFromValue u <*> intFromValue v)
  BGcd -> (TmPrim . PVInt) <$> (gcd <$> intFromValue u <*> intFromValue v)
  BLcm -> (TmPrim . PVInt) <$> (lcm <$> intFromValue u <*> intFromValue v)
  BLogicalAnd -> (TmPrim . PVBool) <$> ((&&) <$> boolFromValue u <*> boolFromValue v)
  BLogicalOr -> (TmPrim . PVBool) <$> ((||) <$> boolFromValue u <*> boolFromValue v)
  _ -> Left "not implemented yet; sorry"

data ValueBinding = ValueBind !Term
                  | TypeBind
                  deriving (Eq,Show)

getValueFromContext :: [ValueBinding] -> Int -> Term
getValueFromContext ctx i
  | i < length ctx = case ctx !! i of
                       ValueBind x -> x
                       b -> error ("TRef: expected a variable binding, found " ++ show b)
  | otherwise = error "TRef: index out of bounds"

eval1 :: [ValueBinding] -> Term -> Either String Term
eval1 ctx t = case t of
  TmPrim _ -> return t
  TmAbs _ _ _ -> return t
  TmTyAbs _ _ _ -> return t
  TmRef i -> return $ getValueFromContext ctx i
  TmApp u v
    | isValue u && isValue v -> case u of
        TmAbs _name _ty body -> return $ termSubst v 0 body -- no type checking here
        TmPrim (PVBuiltin f) | isUnary f -> applyBuiltinUnary f v
        TmPrim (PVBuiltin _) -> return t -- partial application
        TmApp (TmPrim (PVBuiltin f)) u' | isBinary f -> applyBuiltinBinary f u' v
        TmApp (TmApp (TmTyApp (TmPrim (PVBuiltin BIterate)) ty) n) z -> do
          n' <- natFromValue n
          if n' == 0
            then return $ z
            else return $ TmApp (TmApp (TmApp (TmTyApp (TmPrim (PVBuiltin BIterate)) ty) (TmPrim (PVInt (n' - 1)))) (TmApp v z)) v
        _ -> Left "invalid function application (expected function type)"
    | isValue u -> TmApp u <$> (eval1 ctx v)
    | otherwise -> TmApp <$> (eval1 ctx u) <*> pure v
  TmTyApp u ty
    | isValue u -> case u of
        TmTyAbs _name _bound body -> return $ termTypeSubst ty 0 body
        _ -> Left "invalid type application (expected forall type)"
    | otherwise -> TmTyApp <$> eval1 ctx u <*> pure ty
  TmLet name def body
    | isValue def -> return $ termSubst def 0 body
    | otherwise -> TmLet name <$> eval1 ctx def <*> pure body
  TmIf cond then_ else_
    | isValue cond -> case cond of
        TmPrim (PVBool True) -> return then_  -- no type checking here
        TmPrim (PVBool False) -> return else_ -- no type checking here
        _ -> Left "if-then-else: condition must be boolean"
    | otherwise -> TmIf <$> (eval1 ctx cond) <*> pure then_ <*> pure else_
  TmCoerce x ty
    | isValue x -> return x
    | otherwise -> TmCoerce <$> eval1 ctx x <*> pure ty
  TmAlt name tys x
    | isValue x -> return $ termTypeSubst TyUnit 0 x -- dummy type
    | otherwise -> TmAlt name tys <$> eval1 ctx x
  TmTuple components -> case span isValue components of
    (_,[]) -> return t
    (v,w:ws) -> eval1 ctx w >>= \w' -> return (TmTuple (v ++ (w':ws)))
  TmProj tuple j
    | isValue tuple -> case tuple of
        TmTuple components | length components > j -> return $ components !! j
                           | otherwise -> Left "tuple too short"
        _ -> Left "projection: not a tuple"
    | otherwise -> TmProj <$> eval1 ctx tuple <*> pure j
  TmCoherentTuple components -> Left "coherenet tuple: not supported yet"

eval :: [ValueBinding] -> Term -> Either String Term
eval ctx t | isValue t = return t
           | otherwise = eval1 ctx t >>= eval ctx

max_stars_repo_name: minoki/polestar

max_issues_repo_name: minoki/polestar

max_forks_repo_name: minoki/polestar


text:
{-# LANGUAGE FlexibleContexts #-}

module Numeric.Trainee.Data.Common (
	CsvM, runCsvM, col_, read_, single_, enum_, class_, sample_
	) where

import Prelude.Unicode

import Control.DeepSeq
import Control.Monad.Except
import Control.Monad.Reader
import Data.List
import qualified Data.Vector as V
import qualified Data.Text as T
import Numeric.LinearAlgebra
import Text.Read

import Numeric.Trainee.Types

type CsvM a = ReaderT (V.Vector T.Text) (Either String) a

runCsvM ∷ CsvM a → V.Vector T.Text → Either String a
runCsvM = runReaderT

col_ ∷ Int → CsvM String
col_ idx = ReaderT $ \r → maybe (throwError $ "invalid column index: " ++ show idx) (return ∘ T.unpack) (r V.!? idx)

read_ ∷ Read a ⇒ String → CsvM a
read_ s = maybe (throwError $ "can't parse: " ++ s) return ∘ readMaybe $ s

single_ ∷ a → CsvM [a]
single_ = return ∘ return

enum_ ∷ Fractional a ⇒ [String] → String → CsvM a
enum_ names name = case findIndex (≡ name) names of
	Nothing → throwError $ "invalid enum value: " ++ name ++ ", expected " ++ intercalate ", " names
	Just idx → return (fromIntegral idx / fromIntegral (length names - 1))

class_ ∷ Num a ⇒ [String] → String → CsvM [a]
class_ names name = case findIndex (≡ name) names of
	Nothing → throwError $ "invalid class value: " ++ name ++ ", expected " ++ intercalate ", " names
	Just idx → return $ replicate idx 0 ++ [1] ++ replicate (length names - idx - 1) 0

sample_ ∷ Container Vector a ⇒ [a] → [a] → CsvM (Sample (Vector a) (Vector a))
sample_ is os = return $!! Sample (fromList is) (fromList os)

max_stars_repo_name: mvoidex/trainee

max_issues_repo_name: mvoidex/trainee

max_forks_repo_name: mvoidex/trainee


text:
module Wyas.Types where

import Data.Complex (Complex)
import Data.Vector (Vector)

data LispVal = Nil ()
             | Atom String
             | List [LispVal]
             | DottedList [LispVal] LispVal
             | Vector (Vector LispVal)
             | Number Integer
             | String String
             | Bool Bool
             | Character Char
             | Float Double
             | Ratio Rational
             | Complex (Complex Double)
             deriving (Eq)

instance Show LispVal where show = showVal

showVal :: LispVal -> String
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Atom name) = name
showVal (Number contents) = show contents
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (List contents) = "(" ++ unwordsList contents ++ ")"
showVal (DottedList h t) = "(" ++ unwordsList h ++ " . " ++ showVal t ++ ")"

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

max_stars_repo_name: grtlr/wyas

max_issues_repo_name: grtlr/wyas

max_forks_repo_name: grtlr/wyas


text:
{-# LANGUAGE MultiWayIf #-}
module Test.BigOh.Fit.Hakaru
  ( -- * Complexity defs
    Coefficient
  , Order(..)
  , Fit(..)
  , knownOrders
  , exponential
  , constant
  , linear
  , quadratic
  , cubic
  , nlogn
  , poly1d

  -- * Fitting curves
  , bestFit
  , fit
  ) where

import           Control.Arrow
import           Control.Monad
import           Data.Dynamic
import           Data.List
import           Data.Monoid
import           Data.Ord
import qualified Data.Vector                  as V
import           Language.Hakaru.Distribution
import           Language.Hakaru.Metropolis
import           Language.Hakaru.Types
import qualified Statistics.Sample            as S

import           Test.BigOh.Fit.Base

data Fit
  = Fit { xVals :: [Double]
        , yVals :: [Double]
        , burnN :: Int
        , takeN :: Int
        }

-- | Given a complexity order and some data,
--   determine if the order best describes the data.
fit :: (Order -> Bool) -> [Order] -> [Double] -> [Double] -> IO Bool
fit predi orders xs ys
  = go (50 :: Int) burnStart takeStart
  where
   burnStart = 10000
   takeStart = 1000
   go try b t
    = do ranked    <- bestFit' orders (Fit xs ys b t)
         putStrLn ("ranked: " <> show (fmap (first name) ranked))
         let order' = fst $ head ranked
         if | predi order'              -> return True
            | try        == 0           -> return False
            | otherwise                 -> go (try - 1) (b * 2) (t * 2)

-- | Find the complexity order that best fits the data.
--
bestFit :: [Order] -> Fit ->  IO Order
bestFit orders f
  = fst . head <$> bestFit' orders f

bestFit' :: [Order] -> Fit ->  IO [(Order, Double)]
bestFit' orders f@(Fit xs ys _ _)
  = do fits   <- mapM (`curveFit` f) orders
       let fs  = fmap (<$> xs) fits
           rs  = fmap (rSquared ys) fs
           rs' = zip orders rs
           rs''= sortBy (comparing snd) rs'
       return rs''

-- | Given a complexity order and some data, generate a curve of
--   that order that fit the data.
--
curveFit :: Order -> Fit -> IO (Double -> Double)
curveFit thing (Fit xs ys dropn taken)
 = do l <- mcmc (measureForOrder thing xs ys)
                (map (Just . toDyn . Lebesgue) ys)
      let means = expectations $ take taken $ drop dropn l
      return $ mkCurve thing means

-- | Create a sampler for a class of curves with some x values.
--   e.g. sample @y = a*x^2 + b*x +c@
--
measureForOrder :: Order -> [Double] -> [Double] -> Measure [Double]
measureForOrder order xs ys
  = measureForOrder' 0 (maximum $ fmap abs ys) (sd ys) order xs

measureForOrder' :: Double -> Double -> Double -> Order -> [Double] -> Measure [Double]
measureForOrder' mean range sdev (Order _ n func) xs
  = do w <- replicateM n $ unconditioned (normal mean range)
       y <- mapM (conditioned . withinNormal w) xs
       return w
  where
   withinNormal w x
     = normal (func w x) sdev

-- | Given a bunch of possible coefficient sets, return the
--   expected value of each coeffient.
--   e.g. for @a*x^2 + b^x + c@,some possible coffients might be:
--        @[[a=0,b=1,c=4], [a=3,b=4,c=2]]@, @expectations@ returns
--        the expected values for @a, b, c@.
--
expectations :: [[Double]] -> [Double]
expectations l = map (S.mean . V.fromList) (transpose l)

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

type Coefficient = Double

-- | A complexity order, e.g. exponential, quadratic.
data Order
  = Order
    { name      :: String
    , numCoeffs :: Int
    , mkCurve   :: [Coefficient] -> Double -> Double
    }

knownOrders :: [Order]
knownOrders = [exponential, constant, linear, quadratic, cubic, nlogn]

exponential :: Order
exponential
  = Order "exp" 4 $ \[a, b, c, d] x -> a * (2 ** (b * x + c)) + d

constant :: Order
constant
  = Order "constant" 1 poly1d

linear :: Order
linear
  = Order "linear" 2 poly1d

quadratic :: Order
quadratic
  = Order "quadratic" 3 poly1d

cubic :: Order
cubic
  = Order "cubic" 4 poly1d

nlogn :: Order
nlogn
  = Order "nlogn" 2
  $ \[a, b] n -> a * n * log  n + b

poly1d :: [Double] -> Double -> Double
poly1d weights a = poly weights a 1
   where
     poly [] _ _ = 0
     poly (w:ws) x acc = w*acc + (poly ws x acc*x)

square :: Num a => a -> a
square x = x * x

rSquared
  :: [Double] -- ^ data set y1..yn
  -> [Double] -- ^ model f1..fn
  -> Double   -- ^ r squared
rSquared ys fs
 = let yBar  = sum ys / fromIntegral (length ys)
       ssTot = sum (fmap (square . subtract yBar) ys)
       ssRes = sum (fmap square (zipWith (-) ys fs))
   in  (ssTot - ssRes) / ssTot

max_stars_repo_name: tranma/shitty-complexity

max_issues_repo_name: tranma/shitty-complexity

max_forks_repo_name: tranma/shitty-complexity


text:
-----------------------------------------------------------------------------
-- |
-- Module      : Berp.Base.StdTypes.Complex
-- Copyright   : (c) 2010 Bernie Pope
-- License     : BSD-style
-- Maintainer  : florbitous@gmail.com
-- Stability   : experimental
-- Portability : ghc
--
-- The standard floating point type.
--
-----------------------------------------------------------------------------

module Berp.Base.StdTypes.Complex (complex, complexClass) where

import Data.Complex (Complex (..), realPart, imagPart)
import Berp.Base.Monad (constantIO)
import Berp.Base.Prims (primitive, raise)
import Berp.Base.SemanticTypes (Object (..), Eval)
import Berp.Base.Identity (newIdentity)
import Berp.Base.Attributes (mkAttributesList)
import Berp.Base.StdNames
import Berp.Base.Builtins (notImplementedError)
import Berp.Base.Operators
   ( addComplexComplexComplex
   , addComplexIntComplex
   , addComplexFloatComplex
   , subComplexComplexComplex
   , subComplexIntComplex
   , subComplexFloatComplex
   , mulComplexComplexComplex
   , mulComplexIntComplex
   , mulComplexFloatComplex
   , divComplexComplexComplex
   , divComplexIntComplex
   , divComplexFloatComplex
   , eqComplexComplexBool
   , eqComplexIntBool
   , eqComplexFloatBool )
import {-# SOURCE #-} Berp.Base.StdTypes.Type (newType)
import Berp.Base.StdTypes.ObjectBase (objectBase)
import Berp.Base.StdTypes.String (string)

{-# NOINLINE complex #-}
complex :: Complex Double -> Object
complex c = constantIO $ do
   identity <- newIdentity
   return $ Complex { object_identity = identity, object_complex = c }

{-# NOINLINE complexClass #-}
complexClass :: Object
complexClass = constantIO $ do
   dict <- attributes
   newType [string "complex", objectBase, dict]

attributes :: IO Object
attributes = mkAttributesList
   [ (specialAddName, add)
   , (specialSubName, sub)
   , (specialMulName, mul)
   , (specialDivName, divide)
   , (specialEqName, eq)
   , (specialStrName, str)
   ]

mkOp :: (Object -> Object -> Eval Object) ->
        (Object -> Object -> Eval Object) ->
        (Object -> Object -> Eval Object) ->
        Object
mkOp opComplex opFloat opInt = primitive 2 fun
   where
   fun (x:y:_) =
      case y of
         Complex {} -> opComplex x y
         Float {} -> opFloat x y
         Integer {} -> opInt x y
         _other -> raise notImplementedError
   fun _other = error "operator on Complex applied to wrong number of arguments"

add :: Object
add = mkOp addComplexComplexComplex addComplexFloatComplex addComplexIntComplex

sub :: Object
sub = mkOp subComplexComplexComplex subComplexFloatComplex subComplexIntComplex

mul :: Object
mul = mkOp mulComplexComplexComplex mulComplexFloatComplex mulComplexIntComplex

divide :: Object
divide = mkOp divComplexComplexComplex divComplexFloatComplex divComplexIntComplex

eq :: Object
eq = mkOp eqComplexComplexBool eqComplexFloatBool eqComplexIntBool

str :: Object
str = primitive 1 fun
   where
   fun (x:_) = return $ string $ showComplex x
   fun _other = error "str method on Complex applied to wrong number of arguments"

showComplex :: Object -> String
showComplex obj
   | r == 0 = if i < 0 then "-" ++ showImg else showImg
   | i < 0 = "(" ++ showR ++ "-" ++ showImg ++ ")"
   | otherwise = "(" ++ showR ++ "+" ++ showImg ++ ")"
   where
   showImg = showI ++ "j"
   showI = showNum $ abs i
   showR = showNum r
   c = object_complex obj
   i = imagPart c
   r = realPart c
   showNum :: Double -> String
   showNum n
      | fracPart == 0 = show intPart
      | otherwise = show n
      where
      (intPart, fracPart) = properFraction n :: (Integer, Double)

max_stars_repo_name: ppelleti/berp

max_issues_repo_name: ppelleti/berp

max_forks_repo_name: bjpop/berp