text:
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module DerivingViaCompile where

import Data.Void
import Data.Complex
import Data.Functor.Const
import Data.Functor.Identity
import Data.Ratio
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Control.Applicative hiding (WrappedMonad(..))

import Data.Bifunctor
import Data.Monoid
import Data.Kind

type f ~> g = forall xx. f xx -> g xx

-----
-- Simple example
-----

data Foo a = MkFoo a a
  deriving Show
       via (Identity (Foo a))

-----
-- Eta reduction at work
-----

newtype Flip p a b = Flip { runFlip :: p b a }

instance Bifunctor p => Bifunctor (Flip p) where
  bimap f g = Flip . bimap g f . runFlip

instance Bifunctor p => Functor (Flip p a) where
  fmap f = Flip . first f . runFlip

newtype Bar a = MkBar (Either a Int)
  deriving Functor
       via (Flip Either Int)

-----
-- Monad transformers
-----

type MTrans = (Type -> Type) -> (Type -> Type)

-- From `constraints'
data Dict c where
  Dict :: c => Dict c

newtype a :- b = Sub (a => Dict b)

infixl 1 \\
(\\) :: a => (b => r) -> (a :- b) -> r
r \\ Sub Dict = r

-- With `-XQuantifiedConstraints' this just becomes
--
--    type Lifting cls  trans = forall mm. cls mm => cls (trans mm)
--
--    type LiftingMonad trans = Lifting Monad trans
--
class LiftingMonad (trans :: MTrans) where
  proof :: Monad m :- Monad (trans m)

instance LiftingMonad (StateT s :: MTrans) where
  proof :: Monad m :- Monad (StateT s m)
  proof = Sub Dict

instance Monoid w => LiftingMonad (WriterT w :: MTrans) where
  proof :: Monad m :- Monad (WriterT w m)
  proof = Sub Dict

instance (LiftingMonad trans, LiftingMonad trans') => LiftingMonad (ComposeT trans trans' :: MTrans) where
  proof :: forall m. Monad m :- Monad (ComposeT trans trans' m)
  proof = Sub (Dict \\ proof @trans @(trans' m) \\ proof @trans' @m)

newtype Stack :: MTrans where
  Stack :: ReaderT Int (StateT Bool (WriterT String m)) a -> Stack m a
  deriving newtype
    ( Functor
    , Applicative
    , Monad
    , MonadReader Int
    , MonadState Bool
    , MonadWriter String
    )
  deriving (MonadTrans, MFunctor)
       via (ReaderT Int `ComposeT` StateT Bool `ComposeT` WriterT String)

class MFunctor (trans :: MTrans) where
  hoist :: Monad m => (m ~> m') -> (trans m ~> trans m')

instance MFunctor (ReaderT r :: MTrans) where
  hoist :: Monad m => (m ~> m') -> (ReaderT r m ~> ReaderT r m')
  hoist nat = ReaderT . fmap nat . runReaderT

instance MFunctor (StateT s :: MTrans) where
  hoist :: Monad m => (m ~> m') -> (StateT s m ~> StateT s m')
  hoist nat = StateT . fmap nat . runStateT

instance MFunctor (WriterT w :: MTrans) where
  hoist :: Monad m => (m ~> m') -> (WriterT w m ~> WriterT w m')
  hoist nat = WriterT . nat . runWriterT

infixr 9 `ComposeT`
newtype ComposeT :: MTrans -> MTrans -> MTrans where
  ComposeT :: { getComposeT :: f (g m) a } -> ComposeT f g m a
  deriving newtype (Functor, Applicative, Monad)

instance (MonadTrans f, MonadTrans g, LiftingMonad g) => MonadTrans (ComposeT f g) where
  lift :: forall m. Monad m => m ~> ComposeT f g m
  lift = ComposeT . lift . lift
    \\ proof @g @m

instance (MFunctor f, MFunctor g, LiftingMonad g) => MFunctor (ComposeT f g) where
  hoist :: forall m m'. Monad m => (m ~> m') -> (ComposeT f g m ~> ComposeT f g m')
  hoist f = ComposeT . hoist (hoist f) . getComposeT
    \\ proof @g @m

-----
-- Using tuples in a `via` type
-----

newtype X a = X (a, a)
  deriving (Semigroup, Monoid)
       via (Product a, Sum a)

  deriving (Show, Eq)
       via (a, a)

-----
-- Abstract data types
-----

class C f where
  c :: f a -> Int

newtype X2 f a = X2 (f a)

instance C (X2 f) where
  c = const 0

deriving via (X2 IO) instance C IO

----
-- Testing parser
----

newtype P0 a = P0 a             deriving Show via a
newtype P1 a = P1 [a]           deriving Show via [a]
newtype P2 a = P2 (a, a)        deriving Show via (a, a)
newtype P3 a = P3 (Maybe a)     deriving Show via (First a)
newtype P4 a = P4 (Maybe a)     deriving Show via (First $ a)
newtype P5 a = P5 a             deriving Show via (Identity $ a)
newtype P6 a = P6 [a]           deriving Show via ([] $ a)
newtype P7 a = P7 (a, a)        deriving Show via (Identity $ (a, a))
newtype P8 a = P8 (Either () a) deriving Functor via (($) (Either ()))

newtype f $ a = APP (f a) deriving newtype Show deriving newtype Functor

----
-- From Baldur's notes
----

----
-- 1
----
newtype WrapApplicative f a = WrappedApplicative (f a)
  deriving (Functor, Applicative)

instance (Applicative f, Num a) => Num (WrapApplicative f a) where
  (+)         = liftA2 (+)
  (*)         = liftA2 (*)
  negate      = fmap negate
  fromInteger = pure . fromInteger
  abs         = fmap abs
  signum      = fmap signum

instance (Applicative f, Fractional a) => Fractional (WrapApplicative f a) where
  recip        = fmap recip
  fromRational = pure . fromRational

instance (Applicative f, Floating a) => Floating (WrapApplicative f a) where
  pi    = pure pi
  sqrt  = fmap sqrt
  exp   = fmap exp
  log   = fmap log
  sin   = fmap sin
  cos   = fmap cos
  asin  = fmap asin
  atan  = fmap atan
  acos  = fmap acos
  sinh  = fmap sinh
  cosh  = fmap cosh
  asinh = fmap asinh
  atanh = fmap atanh
  acosh = fmap acosh

instance (Applicative f, Semigroup s) => Semigroup (WrapApplicative f s) where
  (<>) = liftA2 (<>)

instance (Applicative f, Monoid m) => Monoid (WrapApplicative f m) where
  mempty = pure mempty

----
-- 2
----
class Pointed p where
  pointed :: a -> p a

newtype WrapMonad f a = WrappedMonad (f a)
  deriving newtype (Pointed, Monad)

instance (Monad m, Pointed m) => Functor (WrapMonad m) where
  fmap = liftM

instance (Monad m, Pointed m) => Applicative (WrapMonad m) where
  pure  = pointed
  (<*>) = ap

-- data
data Sorted a = Sorted a a a
  deriving (Functor, Applicative)
    via (WrapMonad Sorted)
  deriving (Num, Fractional, Floating, Semigroup, Monoid)
    via (WrapApplicative Sorted a)

instance Monad Sorted where
  (>>=) :: Sorted a -> (a -> Sorted b) -> Sorted b
  Sorted a b c >>= f = Sorted a' b' c' where
    Sorted a' _  _  = f a
    Sorted _  b' _  = f b
    Sorted _  _  c' = f c

instance Pointed Sorted where
  pointed :: a -> Sorted a
  pointed a = Sorted a a a

----
-- 3
----
class IsZero a where
  isZero :: a -> Bool

newtype WrappedNumEq  a = WrappedNumEq a
newtype WrappedShow   a = WrappedShow  a
newtype WrappedNumEq2 a = WrappedNumEq2 a

instance (Num a, Eq a) => IsZero (WrappedNumEq a) where
  isZero :: WrappedNumEq a -> Bool
  isZero (WrappedNumEq a) = 0 == a

instance Show a => IsZero (WrappedShow a) where
  isZero :: WrappedShow a -> Bool
  isZero (WrappedShow a) = "0" == show a

instance (Num a, Eq a) => IsZero (WrappedNumEq2 a) where
  isZero :: WrappedNumEq2 a -> Bool
  isZero (WrappedNumEq2 a) = a + a == a

newtype INT = INT Int
  deriving newtype Show
  deriving IsZero via (WrappedNumEq Int)

newtype VOID = VOID Void deriving IsZero via (WrappedShow Void)

----
-- 4
----
class Bifunctor p => Biapplicative p where
  bipure :: a -> b -> p a b

  biliftA2
    :: (a  -> b  -> c)
    -> (a' -> b' -> c')
    -> p a a'
    -> p b b'
    -> p c c'

instance Biapplicative (,) where
  bipure = (,)

  biliftA2 f f' (a, a') (b, b') =
    (f a b, f' a' b')

newtype WrapBiapp p a b = WrapBiap (p a b)
  deriving newtype (Bifunctor, Biapplicative, Eq)

instance (Biapplicative p, Num a, Num b) => Num (WrapBiapp p a b) where
  (+) = biliftA2 (+) (+)
  (-) = biliftA2 (*) (*)
  (*) = biliftA2 (*) (*)
  negate = bimap negate negate
  abs = bimap abs abs
  signum = bimap signum signum
  fromInteger n = fromInteger n `bipure` fromInteger n

newtype INT2 = INT2 (Int, Int)
  deriving IsZero via (WrappedNumEq2 (WrapBiapp (,) Int Int))

----
-- 5
----
class Monoid a => MonoidNull a where
  null :: a -> Bool

newtype WrpMonNull a = WRM a deriving (Eq, Semigroup, Monoid)

instance (Eq a, Monoid a) => MonoidNull (WrpMonNull a) where
  null :: WrpMonNull a -> Bool
  null = (== mempty)

deriving via (WrpMonNull Any) instance MonoidNull Any
deriving via ()               instance MonoidNull ()
deriving via Ordering         instance MonoidNull Ordering

----
-- 6
----
-- https://github.com/mikeizbicki/subhask/blob/f53fd8f465747681c88276c7dabe3646fbdf7d50/src/SubHask/Algebra.hs#L635

class Lattice a where
  sup   :: a -> a -> a
  (.>=) :: a -> a -> Bool
  (.>)  :: a -> a -> Bool

newtype WrapOrd a = WrappedOrd a
  deriving newtype (Eq, Ord)

instance Ord a => Lattice (WrapOrd a) where
  sup   = max
  (.>=) = (>=)
  (.>)  = (>)

deriving via [a]    instance Ord a          => Lattice [a]
deriving via (a, b) instance (Ord a, Ord b) => Lattice (a, b)
--mkLattice_(Bool)
deriving via Bool instance Lattice Bool
--mkLattice_(Char)
deriving via Char instance Lattice Char
--mkLattice_(Int)
deriving via Int instance Lattice Int
--mkLattice_(Integer)
deriving via Integer instance Lattice Integer
--mkLattice_(Float)
deriving via Float instance Lattice Float
--mkLattice_(Double)
deriving via Double instance Lattice Double
--mkLattice_(Rational)
deriving via Rational instance Lattice Rational

----
-- 7
----
-- https://hackage.haskell.org/package/linear-1.20.7/docs/src/Linear-Affine.html

class Functor f => Additive f where
  zero :: Num a => f a
  (^+^) :: Num a => f a -> f a -> f a
  (^+^) = liftU2 (+)
  (^-^) :: Num a => f a -> f a -> f a
  x ^-^ y = x ^+^ fmap negate y
  liftU2 :: (a -> a -> a) -> f a -> f a -> f a

instance Additive [] where
  zero = []
  liftU2 f = go where
    go (x:xs) (y:ys) = f x y : go xs ys
    go [] ys = ys
    go xs [] = xs

instance Additive Maybe where
  zero = Nothing
  liftU2 f (Just a) (Just b) = Just (f a b)
  liftU2 _ Nothing ys = ys
  liftU2 _ xs Nothing = xs

instance Applicative f => Additive (WrapApplicative f) where
  zero   = pure 0
  liftU2 = liftA2

deriving via (WrapApplicative ((->) a)) instance Additive ((->) a)
deriving via (WrapApplicative Complex)  instance Additive Complex
deriving via (WrapApplicative Identity) instance Additive Identity

instance Additive ZipList where
  zero = ZipList []
  liftU2 f (ZipList xs) (ZipList ys) = ZipList (liftU2 f xs ys)

class Additive (Diff p) => Affine p where
  type Diff p :: Type -> Type

  (.-.) :: Num a => p a -> p a -> Diff p a
  (.+^) :: Num a => p a -> Diff p a -> p a
  (.-^) :: Num a => p a -> Diff p a -> p a
  p .-^ v = p .+^ fmap negate v

-- #define ADDITIVEC(CTX,T) instance CTX => Affine T where type Diff T = T ; \
--   (.-.) = (^-^) ; {-# INLINE (.-.) #-} ; (.+^) = (^+^) ; {-# INLINE (.+^) #-} ; \
--   (.-^) = (^-^) ; {-# INLINE (.-^) #-}
-- #define ADDITIVE(T) ADDITIVEC((), T)
newtype WrapAdditive f a = WrappedAdditive (f a)

instance Additive f => Affine (WrapAdditive f) where
  type Diff (WrapAdditive f) = f

  WrappedAdditive a .-. WrappedAdditive b = a ^-^ b
  WrappedAdditive a .+^ b = WrappedAdditive (a ^+^ b)
  WrappedAdditive a .-^ b = WrappedAdditive (a ^-^ b)

-- ADDITIVE(((->) a))
deriving via (WrapAdditive ((->) a)) instance Affine ((->) a)
-- ADDITIVE([])
deriving via (WrapAdditive [])       instance Affine []
-- ADDITIVE(Complex)
deriving via (WrapAdditive Complex)  instance Affine Complex
-- ADDITIVE(Maybe)
deriving via (WrapAdditive Maybe)    instance Affine Maybe
-- ADDITIVE(ZipList)
deriving via (WrapAdditive ZipList)  instance Affine ZipList
-- ADDITIVE(Identity)
deriving via (WrapAdditive Identity) instance Affine Identity

----
-- 8
----

class C2 a b c where
  c2 :: a -> b -> c

instance C2 a b (Const a b) where
  c2 x _ = Const x

newtype Fweemp a = Fweemp a
  deriving (C2 a b)
       via (Const a (b :: Type))


text:
module ML.Gym.Util
    ( python
    ) where

import qualified Control.Exception        as E
import           Control.Monad            (void)
import qualified CPython                  as Py
import qualified CPython.Constants        as Py
import qualified CPython.Protocols.Object as Py
import qualified CPython.Types            as Py
import qualified CPython.Types.Exception  as Py
import qualified CPython.Types.Module     as Py
import qualified Data.ByteString          as BS
import           Data.Complex             (Complex)
import           Data.Maybe               (fromMaybe)
import qualified Data.Text                as T
import           System.Environment       (getArgs, getProgName)
import           System.Exit
import           System.IO
import           System.Random            (randomRIO)

onException :: Py.Exception -> IO a
onException exc = Py.print (Py.exceptionValue exc) stdout >> exitFailure

python :: IO a -> IO a
python = E.handle onException

ext: hs

max_stars_repo_name: schnecki/gym-haskell

max_issues_repo_name: schnecki/gym-haskell

max_forks_repo_name: schnecki/gym-haskell


text:
{-# LANGUAGE OverloadedStrings #-}

module Main (main) where

import Types
import Parsing

-- import qualified Data.Text as T
import Data.Array
import Data.Ratio
import Data.Complex

import Test.Hspec
-- import System.IO.Unsafe

main :: IO ()
main = do
  hspec $ describe "src/Parser.hs" $ do

    it "Atom" $
      readExpr "bb-8?" `shouldBe` Right (Atom "bb-8?")

    it "Num Negative" $
      readExpr "-2187" `shouldBe` Right (Number (-2187))

    it "Num Positive" $
      readExpr "112233" `shouldBe` Right (Number 112233)

    it "Num Positive with Sign" $
      readExpr "+12345" `shouldBe` Right (Number 12345)

    it "Float Negative" $
      readExpr "-2187.1" `shouldBe` Right (Float (-2187.1))

    it "Float Positive" $
      readExpr "112233.1" `shouldBe` Right (Float 112233.1)

    it "Float Positive with Sign" $
      readExpr "+12345.3" `shouldBe` Right (Float 12345.3)

    it "Ratio Negative" $
      readExpr "-2187/3" `shouldBe` Right (Ratio (-2187 % 3))

    it "Ratio Positive" $
      readExpr "187/3" `shouldBe` Right (Ratio (187 % 3))

    it "Ratio Positive with Sign" $
      readExpr "+2187/3" `shouldBe` Right (Ratio (2187 % 3))

    it "Float Positive" $
      readExpr "112233.1" `shouldBe` Right (Float 112233.1)

    it "Float Positive with Sign" $
      readExpr "+12345.3" `shouldBe` Right (Float 12345.3)

    it "Complex Num with Sign" $
      readExpr "12345+3i" `shouldBe` Right (Complex (12345 :+ 3))

    it "Complex Num Positive with Sign" $
      readExpr "+12345+3i" `shouldBe` Right (Complex (12345 :+ 3))

    it "Complex Num Negative" $
      readExpr "-12345+3i" `shouldBe` Right (Complex ((-12345) :+ 3))

    it "Complex Num Negative" $
      readExpr "-12345+(-3)i" `shouldBe` Right (Complex ((-12345) :+ (-3)))

    it "String" $
      readExpr "\"Gen L Organa\"" `shouldBe` Right (String "Gen L Organa")

    it "Bool True" $
      readExpr "#t" `shouldBe` Right (Bool True)

    it "Bool False" $
      readExpr "#f" `shouldBe` Right (Bool False)

    it "S-Expr: homogenous list" $
      readExpr "(2 1 87)" `shouldBe`
      Right (List [Number 2, Number 1,Number 87])

    it "S-Expr: homogenous list quoted" $
      readExpr "'(2 1 87)" `shouldBe`
      Right (List [Atom "quote",List [Number 2, Number 1,Number 87]])

    it "S-Expr: heterogenous list" $
      readExpr "(stromTrooper \"Fn\" 2 1 87)" `shouldBe`
      Right (List [Atom "stromTrooper", String "Fn", Number 2, Number 1,Number 87])

    it "S-Expr: heterogenous list quoted" $
      readExpr "'(stromTrooper \"Fn\" 2 1 87)" `shouldBe`
      Right (List [Atom "quote", List [Atom "stromTrooper", String "Fn", Number 2, Number 1,Number 87]])

    it "S-Expr: vector" $
      readExpr "#(stromTrooper \"Fn\" 2 1 87)" `shouldBe`
      Right (Vector (listArray (0, 4) [Atom "stromTrooper", String "Fn", Number 2, Number 1,Number 87]))

    it "S-Expr: char space" $
      readExpr "(#\\space)" `shouldBe` Right (List [Char ' '])

    it "S-Expr: char newline" $
      readExpr "(#\\newline)" `shouldBe` Right (List [Char '\n'])

    it "S-Expr: char letter" $
      readExpr "(#\\y)" `shouldBe` Right (List [Char 'y'])

    it "S-Expr: single negative" $
      readExpr "(-42)" `shouldBe` Right (List [Number (-42)])

    it "S-Expr: (- num)" $
      readExpr "(- 42)" `shouldBe` Right (List [Atom "-", Number 42])

    it "S-Expr: prim call: numbers" $
      readExpr "(+ 1 2)" `shouldBe`
      Right (List [Atom "+", Number 1, Number 2])

    it "S-Expr: prim call: neg nums" $
      readExpr "(- -42 -42)" `shouldBe`
      Right (List [Atom "-", Number (-42), Number (-42)])

    it "S-Expr: prim call: atoms" $
      readExpr "(- rogue squadron)" `shouldBe`
      Right (List [Atom "-", Atom "rogue", Atom "squadron"])

    it "S-Expr: nested list" $
      readExpr "(lambda (x x) (+ x x))" `shouldBe`
      Right (List [Atom "lambda", List [Atom "x", Atom "x"], List [Atom "+", Atom "x", Atom "x"]])

    it "Comment: end-of/single line" $
      readExpr ";skip\nartoodetoo ;extra will throw\n;skip" `shouldBe` Right (Atom "artoodetoo")

    it "Comment: multi-line comment in single line" $
      readExpr "(c3 #|Hello how are you|# po)" `shouldBe` Right (List [Atom "c3",Atom "po"])

    it "Comment: multi-line line" $
      readExpr "#|Han\nShot\nFirst\n|#(c3 #| these are not the droids you're looking for|# po)\n #|Jar Jar Binks =?= Sith Lord |#" `shouldBe` Right (List [Atom "c3",Atom "po"])

    it "S-Expr: braces/brackets" $
      readExpr "(lambda {x x} [+ x x])" `shouldBe`
      Right (List [Atom "lambda", List [Atom "x", Atom "x"], List [Atom "+", Atom "x", Atom "x"]])

    it "S-Expr: bars" $
      readExpr "(lambda |x x| [+ x x])" `shouldBe`
      Right (List [Atom "lambda", List [Atom "x", Atom "x"], List [Atom "+", Atom "x", Atom "x"]])

  -- hspec $ describe "src/Eval.hs" $ do
  --   wStd "test/add.scm"              $ Number 3
  --   wStd "test/if_alt.scm"           $ Number 2
  --   wStd "test/let.scm"              $ Number 321
  --   wStd "test/eval_boolean.scm"     $ Bool True
  --   wStd "test/eval_boolean_ops.scm" $ Bool True
  --   wStd "test/eval_lambda.scm"      $ Number 5
  --   wStd "test/test_quote.scm"       $ List [Atom "xNotFound", Atom "yNotFound"]
  --   wStd "test/test_car.scm"         $ Number 1
  --   wStd "test/test_cdr.scm"         $ List [Number 2]
  --   wStd "test/test_cadadr.scm"      $ Number 42
  --   wStd "test/test_gt.scm"          $ List [ Bool True, Bool False]
  --   wStd "test/test_scope1.scm"      $ Number 413281
  --   wStd "test/test_scope2.scm"      $ Number 11
  --   wStd "test/test_args.scm"        $ Number 105065
  --   wStd "test/test_fold.scm"        $ Number 42
  --   runExpr Nothing "test/define.scm"        $ Number 4
  --   runExpr Nothing "test/define_order.scm"  $ Number 42
  --   runExpr Nothing "test/define_lambda.scm" $ String "smalltalk"
  --   runExpr Nothing "test/test_evalargs.scm" $ Number 1558
    --runExpr Nothing "test/test_fix.scm"      $ Number 3628800
    --runExpr Nothing "test/test_fix2.scm"      $ Number 5040

-- helper functions
-- run file w/ stdlib
-- wStd :: T.Text -> LispVal -> SpecWith ()
-- wStd = runExpr (Just "test/stdlib_mod.scm")

-- -- run expr w/o stdLib
-- tExpr :: T.Text -> T.Text -> LispVal -> SpecWith ()
-- tExpr note expr val =
--     it (T.unpack note) $ evalVal `shouldBe` val
--     where evalVal = (unsafePerformIO $ runASTinEnv basicEnv $ fileToEvalForm "" expr)

-- runExpr :: Maybe T.Text -> T.Text -> LispVal -> SpecWith ()
-- runExpr  std file val =
--     it (T.unpack file) $ evalVal  `shouldBe` val
--     where evalVal = unsafePerformIO $ evalTextTest std file

-- evalTextTest :: Maybe T.Text -> T.Text -> IO LispVal --REPL
-- evalTextTest (Just stdlib) file= do
--   stdlib <- getFileContents $ T.unpack  stdlib
--   f      <- getFileContents $ T.unpack file
--   runASTinEnv basicEnv $ textToEvalForm stdlib  f

-- evalTextTest Nothing file = do
--   f <- getFileContents $ T.unpack file
--   runASTinEnv basicEnv $ fileToEvalForm (T.unpack file) f

-- -- run text expr w/ file
-- tExprStd :: T.Text -> T.Text -> LispVal -> SpecWith ()
-- tExprStd note  expr  val =
--     it (T.unpack note ) $ evalVal `shouldBe` val
--     where evalVal = unsafePerformIO $ evalExprTest expr

-- evalExprTest ::  T.Text -> IO LispVal --REPL
-- evalExprTest expr = do
--   stdlib <- getFileContents $ T.unpack  "test/stdlib_mod.scm"
--   runASTinEnv basicEnv $ textToEvalForm stdlib  expr

max_stars_repo_name: guimcaballero/scheme-hs

max_issues_repo_name: guimcaballero/scheme-hs

max_forks_repo_name: guimcaballero/scheme-hs


text:
-- Utilities for Machine learning
module Util where

import qualified Data.Vector.Storable as V
import qualified Graphics.Gnuplot.Plot.ThreeDimensional as Plot3D
import qualified Graphics.Gnuplot.Graph.ThreeDimensional as Graph3D

import qualified Graphics.Gnuplot.Plot.TwoDimensional as Plot2D
import qualified Graphics.Gnuplot.Graph.TwoDimensional as Graph2D

import Graphics.Gnuplot.Simple
import Numeric.LinearAlgebra

import qualified Statistics.Sample as Stats

nums :: Int -> Int -> Double -> Matrix Double
nums m n i = reshape n ((m * n) |> repeat i)

zeros, ones :: Int -> Int -> Matrix Double
zeros m n = nums m n 0
ones  m n = nums m n 1

columnWise :: (V.Vector Double -> Double) -> Matrix Double -> Matrix Double
columnWise f x = row $ map f (toColumns x)

mean, std :: Matrix Double -> Matrix Double
mean = columnWise Stats.mean
std = columnWise Stats.stdDev

plot :: [Attribute] -> Vector Double -> Vector Double -> IO ()
plot attr x y = plotPathsStyle attr [(defaultStyle {plotType = Points, lineSpec = CustomStyle [LineType 2]}, zip (toList x) (toList y))]

plotPoints :: [Double] -> [Double] -> Plot2D.T Double Double
plotPoints x y = Plot2D.function Graph2D.points x lookupValue
  where lookupValue v = maybe 0 id (lookup v (zip x y))

plotLine :: [Double] -> [Double] -> Plot2D.T Double Double
plotLine x y = Plot2D.function Graph2D.lines x lookupValue
  where lookupValue v = maybe 0 id (lookup v (zip x y))

plotFunction :: [Double] -> (Double -> Double) -> Plot2D.T Double Double
plotFunction x f = Plot2D.function Graph2D.lines x f

broadcast :: (Double -> Double) -> Matrix Double -> Matrix Double
broadcast f m = fromRows $ map (cmap f) (toRows m)

-- Type synonym for a cost function.
type Cost =  Matrix Double            -- Parameters
          -> Matrix Double            -- Features
          -> Matrix Double            -- Labels
          -> (Double, Matrix Double)  -- (Cost, Optimal theta)

-- Stochastic gradient descent.
sgd :: Matrix Double -- Features
    -> Matrix Double -- Labels
    -> Matrix Double -- Parameters
    -> Cost          -- Cost function
    -> Double        -- Learning Rate
    -> Int           -- Number of Iterations
    -> (Double, Matrix Double)
sgd x y theta f alpha iterations
  | iterations > 0   = sgd x y theta' f alpha (iterations - 1)
  | otherwise        = (cost , theta)
    where (cost, grad) = f theta x y
          theta' = theta - (scalar alpha * (tr grad))

max_stars_repo_name: mchav/CourseraMachineLearning

max_issues_repo_name: mchav/CourseraMachineLearning

max_forks_repo_name: mchav/CourseraMachineLearning


text:
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
-- |
-- Module    : Statistics.Distribution.Binomial
-- Copyright : (c) 2009 Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- The binomial distribution.  This is the discrete probability
-- distribution of the number of successes in a sequence of /n/
-- independent yes\/no experiments, each of which yields success with
-- probability /p/.

module Statistics.Distribution.Binomial
    (
      BinomialDistribution
    -- * Constructors
    , binomial
    -- * Accessors
    , bdTrials
    , bdProbability
    ) where

import Data.Aeson (FromJSON, ToJSON)
import Data.Binary (Binary)
import Data.Data (Data, Typeable)
import GHC.Generics (Generic)
import qualified Statistics.Distribution as D
import qualified Statistics.Distribution.Poisson.Internal as I
import Numeric.SpecFunctions (choose,incompleteBeta)
import Numeric.MathFunctions.Constants (m_epsilon)
import Data.Binary (put, get)
import Control.Applicative ((<$>), (<*>))

-- | The binomial distribution.
data BinomialDistribution = BD {
      bdTrials      :: {-# UNPACK #-} !Int
    -- ^ Number of trials.
    , bdProbability :: {-# UNPACK #-} !Double
    -- ^ Probability.
    } deriving (Eq, Read, Show, Typeable, Data, Generic)

instance FromJSON BinomialDistribution
instance ToJSON BinomialDistribution

instance Binary BinomialDistribution where
    put (BD x y) = put x >> put y
    get = BD <$> get <*> get

instance D.Distribution BinomialDistribution where
    cumulative = cumulative

instance D.DiscreteDistr BinomialDistribution where
    probability = probability

instance D.Mean BinomialDistribution where
    mean = mean

instance D.Variance BinomialDistribution where
    variance = variance

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

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

instance D.Entropy BinomialDistribution where
  entropy (BD n p)
    | n == 0 = 0
    | n <= 100 = directEntropy (BD n p)
    | otherwise = I.poissonEntropy (fromIntegral n * p)

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

-- This could be slow for big n
probability :: BinomialDistribution -> Int -> Double
probability (BD n p) k
  | k < 0 || k > n = 0
  | n == 0         = 1
  | otherwise      = choose n k * p^k * (1-p)^(n-k)

-- Summation from different sides required to reduce roundoff errors
cumulative :: BinomialDistribution -> Double -> Double
cumulative (BD n p) x
  | isNaN x      = error "Statistics.Distribution.Binomial.cumulative: NaN input"
  | isInfinite x = if x > 0 then 1 else 0
  | k <  0       = 0
  | k >= n       = 1
  | otherwise    = incompleteBeta (fromIntegral (n-k)) (fromIntegral (k+1)) (1 - p)
  where
    k = floor x

mean :: BinomialDistribution -> Double
mean (BD n p) = fromIntegral n * p

variance :: BinomialDistribution -> Double
variance (BD n p) = fromIntegral n * p * (1 - p)

directEntropy :: BinomialDistribution -> Double
directEntropy d@(BD n _) =
  negate . sum $
  takeWhile (< negate m_epsilon) $
  dropWhile (not . (< negate m_epsilon)) $
  [ let x = probability d k in x * log x | k <- [0..n]]

-- | Construct binomial distribution. Number of trials must be
--   non-negative and probability must be in [0,1] range
binomial :: Int                 -- ^ Number of trials.
         -> Double              -- ^ Probability.
         -> BinomialDistribution
binomial n p
  | n < 0          =
    error $ msg ++ "number of trials must be non-negative. Got " ++ show n
  | p < 0 || p > 1 =
    error $ msg++"probability must be in [0,1] range. Got " ++ show p
  | otherwise      = BD n p
    where msg = "Statistics.Distribution.Binomial.binomial: "

max_stars_repo_name: StefanHubner/statistics

max_issues_repo_name: StefanHubner/statistics

max_forks_repo_name: StefanHubner/statistics


text:
module Complex (
    Complex((:+)), realPart, imagPart, conjugate,
    mkPolar, cis, polar, magnitude, phase
  ) where

import Data.Complex

max_stars_repo_name: alekar/hugs

max_issues_repo_name: alekar/hugs

max_forks_repo_name: alekar/hugs


text:
module Main (main) where

import Autoencoder

import Control.Applicative
import Control.Monad
import Control.Monad.ST
import Data.Array.ST
import Data.Char
import Data.Classifier (Classifier)
import Data.Classifier.NaiveBayes (NaiveBayes)
import Data.Counter (Counter)
import Data.Maybe
import Data.Monoid
import Data.STRef
import Data.Text (Text)
import Data.Time.Clock
import Numeric.LinearAlgebra.HMatrix (Vector)
import Prelude
import System.Environment (getArgs)
import System.Exit (exitFailure)
import System.Random (randomR, getStdRandom, RandomGen)
import Text.Read (readMaybe)
import qualified AI.HNN.FF.Network as Neural
import qualified Data.Classifier as Classifier
import qualified Data.Classifier.NaiveBayes as NaiveBayes
import qualified Data.Counter as Counter
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Numeric.LinearAlgebra.HMatrix as Vector
import qualified System.IO as IO

main :: IO ()
main = getArgs >>= \case
  ["bayes", filename] ->
    void $ evaluateBayes filename
  ["neural", filename, readMaybe -> Just trainTimes, readMaybe -> Just layers] ->
    neural filename trainTimes layers
  ["generate_autoencoder", filename] -> do
    IO.hSetBuffering IO.stdout IO.NoBuffering
    t <- getCurrentTime
    autoencoder filename >>= print
    getCurrentTime >>= print . (`diffUTCTime` t)
  ["apply_autoencoder", encoder, filename] -> do
    (v, (e, _)) <- read <$> readFile encoder :: IO (Counter Text, Autoencoder)
    applyAutoencoder v e filename 10 []
  ["everything", filename] -> do
    void $ evaluateBayes filename
    neural filename 10 []
    neural filename 100 []
    neural filename 1000 []
    neural filename 10 [10]
    neural filename 100 [10]
    neural filename 1000 [10]
    neural filename 10 [100]
    neural filename 100 [100]
    neural filename 1000 [100]
    neural filename 10000 [10]
    neural filename 10 [100, 50]
    neural filename 100 [100, 50]
    neural filename 1000 [100, 50]
  _ -> do
    putStrLn "Invalid arguments"
    exitFailure

applyAutoencoder :: Counter Text -> Encoder -> FilePath -> Int -> [Int] -> IO ()
applyAutoencoder vocab encoder path times layers = do
  shuffled <- readFile path >>= getStdRandom . shuffle . extractData
  let (train, test) = splitAt (length shuffled `div` 2) shuffled
  let trainVectors = map (\(x, y) -> (encode encoder x, y)) $ classifierToVector boolToVector vocab $ mconcat $ map rowToClassifier train
  let testVectors = map (\(x, y) -> (encode encoder x, y)) $ classifierToVector boolToVector vocab $ mconcat $ map rowToClassifier test
  case trainVectors of
    [] -> putStrLn "No data"
    (v, _) : _ -> do
      startTime <- getCurrentTime
      network <- Neural.createNetwork (Vector.size v) layers 1
      IO.hSetBuffering IO.stdout IO.NoBuffering
      void $ iterateM 9 (0 :: Int, network, 0) $ \(n, net, timeTakenEvaluating) -> do
        let newNet = trainNet net trainVectors
        print layers
        print (n + times)
        print newNet
        endTime <- getCurrentTime
        print $ (endTime `diffUTCTime` startTime) - timeTakenEvaluating
        evalStartTime <- getCurrentTime
        print $ Counter.fromList $ map (\(x, y) -> (y, Vector.cmap r $ Neural.output newNet tanh x)) testVectors
        evalEndTime <- getCurrentTime
        print $ evalEndTime `diffUTCTime` evalStartTime
        return (n + times, newNet, timeTakenEvaluating + (evalEndTime `diffUTCTime` evalStartTime))
  where r = (fromIntegral :: Int -> Double) . (round :: Double -> Int)
        trainNet = Neural.trainNTimes times 0.8 Neural.tanh Neural.tanh'

autoencoder :: FilePath -> IO (Counter Text, Autoencoder)
autoencoder path = do
  shuffled <- readFile path >>= getStdRandom . shuffle . extractData
  let (train, test) = splitAt (length shuffled `div` 2) shuffled
  let trainClassifier = mconcat $ map rowToClassifier train
  let vocab = vocabulary trainClassifier
  let trainVectors = classifierToVector boolToVector vocab trainClassifier
  let testVectors = classifierToVector boolToVector vocab $ mconcat $ map rowToClassifier test
  case trainVectors of
    [] -> error "no data"
    v -> do
      res <- generateAutoencoderIO (map fst v) 1000 1000
      return (vocab, res)

evaluateBayes :: FilePath -> IO (Counter (Bool, Maybe Bool))
evaluateBayes fp = do
  file <- readFile fp
  startTime <- getCurrentTime
  let res = extractData file
  let classifier = createClassifier res
  print classifier
  printTimeDiff startTime
  evalStartTime <- getCurrentTime
  let counted = Counter.fromList $ applyNaiveBayes classifier res
  print counted
  printTimeDiff evalStartTime
  return counted

printTimeDiff :: UTCTime -> IO ()
printTimeDiff s = do
  e <- getCurrentTime
  print $ e `diffUTCTime` s

bayes :: String -> Counter (Bool, Maybe Bool)
bayes file = Counter.fromList results
  where res = extractData file
        results = applyNaiveBayes (createClassifier res) res

neural :: FilePath -> Int -> [Int] -> IO ()
neural path times layers = do
  shuffled <- readFile path >>= getStdRandom . shuffle . extractData
  let (train, test) = splitAt (length shuffled `div` 2) shuffled
  let trainClassifier = mconcat $ map rowToClassifier train
  let vocab = vocabulary trainClassifier
  let trainVectors = classifierToVector boolToVector vocab trainClassifier
  let testVectors = classifierToVector boolToVector vocab $ mconcat $ map rowToClassifier test
  case trainVectors of
    [] -> putStrLn "No data"
    (v, _) : _ -> do
      startTime <- getCurrentTime
      network <- Neural.createNetwork (Vector.size v) layers 1
      IO.hSetBuffering IO.stdout IO.NoBuffering
      void $ iterateM 9 (0 :: Int, network, 0) $ \(n, net, timeTakenEvaluating) -> do
        let newNet = trainNet net trainVectors
        print layers
        print (n + times)
        print newNet
        endTime <- getCurrentTime
        print $ (endTime `diffUTCTime` startTime) - timeTakenEvaluating
        evalStartTime <- getCurrentTime
        print $ Counter.fromList $ map (\(x, y) -> (y, Vector.cmap r $ Neural.output newNet tanh x)) testVectors
        evalEndTime <- getCurrentTime
        print $ evalEndTime `diffUTCTime` evalStartTime
        return (n + times, newNet, timeTakenEvaluating + (evalEndTime `diffUTCTime` evalStartTime))
  where r = (fromIntegral :: Int -> Double) . (round :: Double -> Int)
        trainNet = Neural.trainNTimes times 0.8 Neural.tanh Neural.tanh'

iterateM :: Monad m => Int -> a -> (a -> m a) -> m [a]
iterateM 0 _ _ = return []
iterateM n a f = do
  v <- f a
  next <- iterateM (n - 1) v f
  return $ v : next

boolToVector :: Bool -> Vector Double
boolToVector True = 1
boolToVector False = -1

vocabulary :: Ord b => Classifier a b -> Counter b
vocabulary = Map.foldr (mappend . mconcat) mempty . Classifier.toMap

counterToVector :: Ord a => Counter a -> Counter a -> Vector Double
counterToVector (Counter.toMap -> vocab) (Counter.toMap -> m) =
  Vector.vector $ map snd $ Map.toAscList $ Map.mergeWithKey (\_ v _ -> Just $ fromIntegral v) (const mempty) (fmap (const 0)) m vocab

classifierToVector :: (Ord a, Ord b) => (a -> Vector Double) -> Counter b -> Classifier a b -> [(Vector Double, Vector Double)]
classifierToVector f vocab (Classifier.toMap -> m) =
  Map.foldrWithKey (\k v a -> fmap ((,) <$> counterToVector vocab <*> pure (f k)) v <> a) [] m

applyNaiveBayes :: NaiveBayes Bool Text -> [Row] -> [(Bool, Maybe Bool)]
applyNaiveBayes classifier rows =
  foldl (\ a t -> collect (NaiveBayes.remove (rowToClassifier t) classifier) a t) [] rows

collect :: NaiveBayes Bool Text -> [(Bool, Maybe Bool)] -> Row -> [(Bool, Maybe Bool)]
collect cls acc (b, _, _, _, c) =
  (b, tested) : acc
  where tested = NaiveBayes.test cls $ Counter.fromList $ process c

type Row = (Bool, Text, Text, Text, Text)

extractData :: String -> [Row]
extractData = mapMaybe readMaybe . lines

createClassifier :: [Row] -> NaiveBayes Bool Text
createClassifier = mconcat . map (NaiveBayes.fromClassifier . rowToClassifier)

rowToClassifier :: Row -> Classifier Bool Text
rowToClassifier (b, _, _, _, c) = Classifier.singleton b $ Counter.fromList $ process c

process :: Text -> [Text]
process = filter (not . Text.null) .
          map (Text.map toLower . Text.filter isAlpha) .
          concatMap (Text.splitOn ".") .
          Text.splitOn " " .
          Text.filter (not . (== '-'))

-- shuffle from the haskell wiki @ https://wiki.haskell.org/Random_shuffle
shuffle :: RandomGen g => [a] -> g -> ([a], g)
shuffle xs gen = runST $ do
    g <- newSTRef gen
    ar <- newListArray' xs
    xs' <- forM [1..n] $ \i -> do
            j <- randomRST (i,n) g
            vi <- readArray ar i
            vj <- readArray ar j
            writeArray ar j vi
            return vj
    gen' <- readSTRef g
    return (xs', gen')
  where
    n = length xs
    newListArray' :: [a] -> ST s (STArray s Int a)
    newListArray' = newListArray (1, n)
    randomRST lohi g = do
      (a, s') <- randomR lohi <$> readSTRef g
      writeSTRef g s'
      return a

max_stars_repo_name: intolerable/project-utilities

max_issues_repo_name: intolerable/project-utilities

max_forks_repo_name: intolerable/project-utilities


text:
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif

---------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2012-2015 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Simple matrix operation for low-dimensional primitives.
---------------------------------------------------------------------------
module Linear.Matrix
  ( (!*!), (!+!), (!-!), (!*), (*!), (!!*), (*!!), (!!/)
  , column
  , adjoint
  , M22, M23, M24, M32, M33, M34, M42, M43, M44
  , m33_to_m44, m43_to_m44
  , det22, det33, det44, inv22, inv33, inv44
  , identity
  , Trace(..)
  , translation
  , transpose
  , fromQuaternion
  , mkTransformation
  , mkTransformationMat
  , _m22, _m23, _m24
  , _m32, _m33, _m34
  , _m42, _m43, _m44
#if MIN_VERSION_base(4,8,0)
  , lu
  , luFinite
  , forwardSub
  , forwardSubFinite
  , backwardSub
  , backwardSubFinite
  , luSolve
  , luSolveFinite
  , luInv
  , luInvFinite
  , luDet
  , luDetFinite
#endif
  ) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Lens hiding (index)
import Control.Lens.Internal.Context
import Data.Distributive
import Data.Foldable as Foldable
import Data.Functor.Rep
import Linear.Quaternion
import Linear.V2
import Linear.V3
import Linear.V4
import Linear.Vector
import Linear.Conjugate
import Linear.Trace

#if MIN_VERSION_base(4,8,0)
import GHC.TypeLits
import Linear.V
#endif

-- $setup
-- >>> import Control.Lens hiding (index)
-- >>> import Data.Complex (Complex (..))
-- >>> import Linear.V2
-- >>> import Linear.V3
-- >>> import Linear.V
-- >>> import Data.IntMap
-- >>> import Debug.SimpleReflect.Vars

-- | This is a generalization of 'Control.Lens.inside' to work over any corepresentable 'Functor'.
--
-- @
-- 'column' :: 'Representable' f => 'Lens' s t a b -> 'Lens' (f s) (f t) (f a) (f b)
-- @
--
-- In practice it is used to access a column of a matrix.
--
-- >>> V2 (V3 1 2 3) (V3 4 5 6) ^._x
-- V3 1 2 3
--
-- >>> V2 (V3 1 2 3) (V3 4 5 6) ^.column _x
-- V2 1 4
column :: Representable f => LensLike (Context a b) s t a b -> Lens (f s) (f t) (f a) (f b)
column l f es = o <$> f i where
   go = l (Context id)
   i = tabulate $ \ e -> ipos $ go (index es e)
   o eb = tabulate $ \ e -> ipeek (index eb e) (go (index es e))

infixl 7 !*!
-- | Matrix product. This can compute any combination of sparse and dense multiplication.
--
-- >>> V2 (V3 1 2 3) (V3 4 5 6) !*! V3 (V2 1 2) (V2 3 4) (V2 4 5)
-- V2 (V2 19 25) (V2 43 58)
--
-- >>> V2 (fromList [(1,2)]) (fromList [(2,3)]) !*! fromList [(1,V3 0 0 1), (2, V3 0 0 5)]
-- V2 (V3 0 0 2) (V3 0 0 15)
(!*!) :: (Functor m, Foldable t, Additive t, Additive n, Num a) => m (t a) -> t (n a) -> m (n a)
f !*! g = fmap (\ f' -> Foldable.foldl' (^+^) zero $ liftI2 (*^) f' g) f

infixl 6 !+!
-- | Entry-wise matrix addition.
--
-- >>> V2 (V3 1 2 3) (V3 4 5 6) !+! V2 (V3 7 8 9) (V3 1 2 3)
-- V2 (V3 8 10 12) (V3 5 7 9)
(!+!) :: (Additive m, Additive n, Num a) => m (n a) -> m (n a) -> m (n a)
as !+! bs = liftU2 (^+^) as bs

infixl 6 !-!
-- | Entry-wise matrix subtraction.
--
-- >>> V2 (V3 1 2 3) (V3 4 5 6) !-! V2 (V3 7 8 9) (V3 1 2 3)
-- V2 (V3 (-6) (-6) (-6)) (V3 3 3 3)
(!-!) :: (Additive m, Additive n, Num a) => m (n a) -> m (n a) -> m (n a)
as !-! bs = liftU2 (^-^) as bs

infixl 7 !*
-- | Matrix * column vector
--
-- >>> V2 (V3 1 2 3) (V3 4 5 6) !* V3 7 8 9
-- V2 50 122
(!*) :: (Functor m, Foldable r, Additive r, Num a) => m (r a) -> r a -> m a
m !* v = fmap (\r -> Foldable.sum $ liftI2 (*) r v) m

infixl 7 *!
-- | Row vector * matrix
--
-- >>> V2 1 2 *! V2 (V3 3 4 5) (V3 6 7 8)
-- V3 15 18 21

-- (*!) :: (Metric r, Additive n, Num a) => r a -> r (n a) -> n a
-- f *! g = dot f <$> distribute g

(*!) :: (Num a, Foldable t, Additive f, Additive t) => t a -> t (f a) -> f a
f *! g = sumV $ liftI2 (*^) f g

infixl 7 *!!
-- | Scalar-matrix product
--
-- >>> 5 *!! V2 (V2 1 2) (V2 3 4)
-- V2 (V2 5 10) (V2 15 20)
(*!!) :: (Functor m, Functor r, Num a) => a -> m (r a) -> m (r a)
s *!! m = fmap (s *^) m
{-# INLINE (*!!) #-}

infixl 7 !!*
-- | Matrix-scalar product
--
-- >>> V2 (V2 1 2) (V2 3 4) !!* 5
-- V2 (V2 5 10) (V2 15 20)
(!!*) :: (Functor m, Functor r, Num a) => m (r a) -> a -> m (r a)
(!!*) = flip (*!!)
{-# INLINE (!!*) #-}

infixl 7 !!/
-- | Matrix-scalar division
(!!/) :: (Functor m, Functor r, Fractional a) => m (r a) -> a -> m (r a)
m !!/ s = fmap (^/ s) m
{-# INLINE (!!/) #-}

-- | Hermitian conjugate or conjugate transpose
--
-- >>> adjoint (V2 (V2 (1 :+ 2) (3 :+ 4)) (V2 (5 :+ 6) (7 :+ 8)))
-- V2 (V2 (1.0 :+ (-2.0)) (5.0 :+ (-6.0))) (V2 (3.0 :+ (-4.0)) (7.0 :+ (-8.0)))
adjoint :: (Functor m, Distributive n, Conjugate a) => m (n a) -> n (m a)
adjoint = collect (fmap conjugate)
{-# INLINE adjoint #-}

-- * Matrices
--
-- Matrices use a row-major representation.

-- | A 2x2 matrix with row-major representation
type M22 a = V2 (V2 a)
-- | A 2x3 matrix with row-major representation
type M23 a = V2 (V3 a)
-- | A 2x4 matrix with row-major representation
type M24 a = V2 (V4 a)
-- | A 3x2 matrix with row-major representation
type M32 a = V3 (V2 a)
-- | A 3x3 matrix with row-major representation
type M33 a = V3 (V3 a)
-- | A 3x4 matrix with row-major representation
type M34 a = V3 (V4 a)
-- | A 4x2 matrix with row-major representation
type M42 a = V4 (V2 a)
-- | A 4x3 matrix with row-major representation
type M43 a = V4 (V3 a)
-- | A 4x4 matrix with row-major representation
type M44 a = V4 (V4 a)

-- | Build a rotation matrix from a unit 'Quaternion'.
fromQuaternion :: Num a => Quaternion a -> M33 a
fromQuaternion (Quaternion w (V3 x y z)) =
  V3 (V3 (1-2*(y2+z2)) (2*(xy-zw)) (2*(xz+yw)))
     (V3 (2*(xy+zw)) (1-2*(x2+z2)) (2*(yz-xw)))
     (V3 (2*(xz-yw)) (2*(yz+xw)) (1-2*(x2+y2)))
  where x2 = x*x
        y2 = y*y
        z2 = z*z
        xy = x*y
        xz = x*z
        xw = x*w
        yz = y*z
        yw = y*w
        zw = z*w
{-# INLINE fromQuaternion #-}

-- | Build a transformation matrix from a rotation matrix and a
-- translation vector.
mkTransformationMat :: Num a => M33 a -> V3 a -> M44 a
mkTransformationMat (V3 r1 r2 r3) (V3 tx ty tz) =
  V4 (snoc3 r1 tx) (snoc3 r2 ty) (snoc3 r3 tz) (V4 0 0 0 1)
  where snoc3 (V3 x y z) = V4 x y z
{-# INLINE mkTransformationMat #-}

-- |Build a transformation matrix from a rotation expressed as a
-- 'Quaternion' and a translation vector.
mkTransformation :: Num a => Quaternion a -> V3 a -> M44 a
mkTransformation = mkTransformationMat . fromQuaternion
{-# INLINE mkTransformation #-}

-- | Convert from a 4x3 matrix to a 4x4 matrix, extending it with the @[ 0 0 0 1 ]@ column vector
m43_to_m44 :: Num a => M43 a -> M44 a
m43_to_m44
  (V4 (V3 a b c)
      (V3 d e f)
      (V3 g h i)
      (V3 j k l)) =
  V4 (V4 a b c 0)
     (V4 d e f 0)
     (V4 g h i 0)
     (V4 j k l 1)

-- | Convert a 3x3 matrix to a 4x4 matrix extending it with 0's in the new row and column.
m33_to_m44 :: Num a => M33 a -> M44 a
m33_to_m44 (V3 r1 r2 r3) = V4 (vector r1) (vector r2) (vector r3) (point 0)

-- |The identity matrix for any dimension vector.
--
-- >>> identity :: M44 Int
-- V4 (V4 1 0 0 0) (V4 0 1 0 0) (V4 0 0 1 0) (V4 0 0 0 1)
-- >>> identity :: V3 (V3 Int)
-- V3 (V3 1 0 0) (V3 0 1 0) (V3 0 0 1)
identity :: (Num a, Traversable t, Applicative t) => t (t a)
identity = scaled (pure 1)

-- |Extract the translation vector (first three entries of the last
-- column) from a 3x4 or 4x4 matrix.
translation :: (Representable t, R3 t, R4 v) => Lens' (t (v a)) (V3 a)
translation = column _w._xyz
{-
translation f rs = aux <$> f (view _w <$> view _xyz rs)
 where aux (V3 x y z) = (_x._w .~ x) . (_y._w .~ y) . (_z._w .~ z) $ rs

-- translation :: (R3 t, R4 v, Functor f, Functor t) => (V3 a -> f (V3 a)) -> t (v a) -> f (t a)
-- translation = (. fmap (^._w)) . _xyz where
--   x ^. l = getConst (l Const x)
-}

-- |Extract a 2x2 matrix from a matrix of higher dimensions by dropping excess
-- rows and columns.
_m22 :: (Representable t, R2 t, R2 v) => Lens' (t (v a)) (M22 a)
_m22 = column _xy._xy

-- |Extract a 2x3 matrix from a matrix of higher dimensions by dropping excess
-- rows and columns.
_m23 :: (Representable t, R2 t, R3 v) => Lens' (t (v a)) (M23 a)
_m23 = column _xyz._xy

-- |Extract a 2x4 matrix from a matrix of higher dimensions by dropping excess
-- rows and columns.
_m24 :: (Representable t, R2 t, R4 v) => Lens' (t (v a)) (M24 a)
_m24 = column _xyzw._xy

-- |Extract a 3x2 matrix from a matrix of higher dimensions by dropping excess
-- rows and columns.
_m32 :: (Representable t, R3 t, R2 v) => Lens' (t (v a)) (M32 a)
_m32 = column _xy._xyz

-- |Extract a 3x3 matrix from a matrix of higher dimensions by dropping excess
-- rows and columns.
_m33 :: (Representable t, R3 t, R3 v) => Lens' (t (v a)) (M33 a)
_m33 = column _xyz._xyz

-- |Extract a 3x4 matrix from a matrix of higher dimensions by dropping excess
-- rows and columns.
_m34 :: (Representable t, R3 t, R4 v) => Lens' (t (v a)) (M34 a)
_m34 = column _xyzw._xyz

-- |Extract a 4x2 matrix from a matrix of higher dimensions by dropping excess
-- rows and columns.
_m42 :: (Representable t, R4 t, R2 v) => Lens' (t (v a)) (M42 a)
_m42 = column _xy._xyzw

-- |Extract a 4x3 matrix from a matrix of higher dimensions by dropping excess
-- rows and columns.
_m43 :: (Representable t, R4 t, R3 v) => Lens' (t (v a)) (M43 a)
_m43 = column _xyz._xyzw

-- |Extract a 4x4 matrix from a matrix of higher dimensions by dropping excess
-- rows and columns.
_m44 :: (Representable t, R4 t, R4 v) => Lens' (t (v a)) (M44 a)
_m44 = column _xyzw._xyzw

-- |2x2 matrix determinant.
--
-- >>> det22 (V2 (V2 a b) (V2 c d))
-- a * d - b * c
det22 :: Num a => M22 a -> a
det22 (V2 (V2 a b) (V2 c d)) = a * d - b * c
{-# INLINE det22 #-}

-- |3x3 matrix determinant.
--
-- >>> det33 (V3 (V3 a b c) (V3 d e f) (V3 g h i))
-- a * (e * i - f * h) - d * (b * i - c * h) + g * (b * f - c * e)
det33 :: Num a => M33 a -> a
det33 (V3 (V3 a b c)
          (V3 d e f)
          (V3 g h i)) = a * (e*i-f*h) - d * (b*i-c*h) + g * (b*f-c*e)
{-# INLINE det33 #-}

-- |4x4 matrix determinant.
det44 :: Num a => M44 a -> a
det44 (V4 (V4 i00 i01 i02 i03)
          (V4 i10 i11 i12 i13)
          (V4 i20 i21 i22 i23)
          (V4 i30 i31 i32 i33)) =
  let
    s0 = i00 * i11 - i10 * i01
    s1 = i00 * i12 - i10 * i02
    s2 = i00 * i13 - i10 * i03
    s3 = i01 * i12 - i11 * i02
    s4 = i01 * i13 - i11 * i03
    s5 = i02 * i13 - i12 * i03

    c5 = i22 * i33 - i32 * i23
    c4 = i21 * i33 - i31 * i23
    c3 = i21 * i32 - i31 * i22
    c2 = i20 * i33 - i30 * i23
    c1 = i20 * i32 - i30 * i22
    c0 = i20 * i31 - i30 * i21
  in s0 * c5 - s1 * c4 + s2 * c3 + s3 * c2 - s4 * c1 + s5 * c0
{-# INLINE det44 #-}

-- |2x2 matrix inverse.
--
-- >>> inv22 $ V2 (V2 1 2) (V2 3 4)
-- V2 (V2 (-2.0) 1.0) (V2 1.5 (-0.5))
inv22 :: Fractional a => M22 a -> M22 a
inv22 m@(V2 (V2 a b) (V2 c d)) = (1 / det) *!! V2 (V2 d (-b)) (V2 (-c) a)
  where det = det22 m
{-# INLINE inv22 #-}

-- |3x3 matrix inverse.
--
-- >>> inv33 $ V3 (V3 1 2 4) (V3 4 2 2) (V3 1 1 1)
-- V3 (V3 0.0 0.5 (-1.0)) (V3 (-0.5) (-0.75) 3.5) (V3 0.5 0.25 (-1.5))
inv33 :: Fractional a => M33 a -> M33 a
inv33 m@(V3 (V3 a b c)
            (V3 d e f)
            (V3 g h i))
  = (1 / det) *!! V3 (V3 a' b' c')
                     (V3 d' e' f')
                     (V3 g' h' i')
  where a' = cofactor (e,f,h,i)
        b' = cofactor (c,b,i,h)
        c' = cofactor (b,c,e,f)
        d' = cofactor (f,d,i,g)
        e' = cofactor (a,c,g,i)
        f' = cofactor (c,a,f,d)
        g' = cofactor (d,e,g,h)
        h' = cofactor (b,a,h,g)
        i' = cofactor (a,b,d,e)
        cofactor (q,r,s,t) = det22 (V2 (V2 q r) (V2 s t))
        det = det33 m
{-# INLINE inv33 #-}

-- | 'transpose' is just an alias for 'distribute'
--
-- > transpose (V3 (V2 1 2) (V2 3 4) (V2 5 6))
-- V2 (V3 1 3 5) (V3 2 4 6)
transpose :: (Distributive g, Functor f) => f (g a) -> g (f a)
transpose = distribute
{-# INLINE transpose #-}

-- |4x4 matrix inverse.
inv44 :: Fractional a => M44 a -> M44 a
inv44 (V4 (V4 i00 i01 i02 i03)
          (V4 i10 i11 i12 i13)
          (V4 i20 i21 i22 i23)
          (V4 i30 i31 i32 i33)) =
  let s0 = i00 * i11 - i10 * i01
      s1 = i00 * i12 - i10 * i02
      s2 = i00 * i13 - i10 * i03
      s3 = i01 * i12 - i11 * i02
      s4 = i01 * i13 - i11 * i03
      s5 = i02 * i13 - i12 * i03
      c5 = i22 * i33 - i32 * i23
      c4 = i21 * i33 - i31 * i23
      c3 = i21 * i32 - i31 * i22
      c2 = i20 * i33 - i30 * i23
      c1 = i20 * i32 - i30 * i22
      c0 = i20 * i31 - i30 * i21
      det = s0 * c5 - s1 * c4 + s2 * c3 + s3 * c2 - s4 * c1 + s5 * c0
      invDet = recip det
  in invDet *!! V4 (V4 (i11 * c5 - i12 * c4 + i13 * c3)
                       (-i01 * c5 + i02 * c4 - i03 * c3)
                       (i31 * s5 - i32 * s4 + i33 * s3)
                       (-i21 * s5 + i22 * s4 - i23 * s3))
                   (V4 (-i10 * c5 + i12 * c2 - i13 * c1)
                       (i00 * c5 - i02 * c2 + i03 * c1)
                       (-i30 * s5 + i32 * s2 - i33 * s1)
                       (i20 * s5 - i22 * s2 + i23 * s1))
                   (V4 (i10 * c4 - i11 * c2 + i13 * c0)
                       (-i00 * c4 + i01 * c2 - i03 * c0)
                       (i30 * s4 - i31 * s2 + i33 * s0)
                       (-i20 * s4 + i21 * s2 - i23 * s0))
                   (V4 (-i10 * c3 + i11 * c1 - i12 * c0)
                       (i00 * c3 - i01 * c1 + i02 * c0)
                       (-i30 * s3 + i31 * s1 - i32 * s0)
                       (i20 * s3 - i21 * s1 + i22 * s0))
{-# INLINE inv44 #-}

#if MIN_VERSION_base(4,8,0)
-- | Compute the (L, U) decomposition of a square matrix using Crout's
--   algorithm. The 'Index' of the vectors must be 'Integral'.
lu :: ( Num a
      , Fractional a
      , Foldable m
      , Traversable m
      , Applicative m
      , Additive m
      , Ixed (m a)
      , Ixed (m (m a))
      , i ~ Index (m a)
      , i ~ Index (m (m a))
      , Eq i
      , Integral i
      , a ~ IxValue (m a)
      , m a ~ IxValue (m (m a))
      , Num (m a)
      )
   => m (m a)
   -> (m (m a), m (m a))
lu a =
    let n = fromIntegral (length a)
        initU = identity
        initL = zero
        buildLVal !i !j !l !u =
            let go !k !s
                    | k == j = s
                    | otherwise = go (k+1)
                                     ( s
                                      + ( (l ^?! ix i ^?! ix k)
                                        * (u ^?! ix k ^?! ix j)
                                        )
                                      )
                s' = go 0 0
            in l & (ix i . ix j) .~ ((a ^?! ix i ^?! ix j) - s')
        buildL !i !j !l !u
            | i == n = l
            | otherwise = buildL (i+1) j (buildLVal i j l u) u
        buildUVal !i !j !l !u =
            let go !k !s
                    | k == j = s
                    | otherwise = go (k+1)
                                     ( s
                                     + ( (l ^?! ix j ^?! ix k)
                                       * (u ^?! ix k ^?! ix i)
                                       )
                                     )
                s' = go 0 0
            in u & (ix j . ix i) .~ ( ((a ^?! ix j ^?! ix i) - s')
                                    / (l ^?! ix j ^?! ix j)
                                    )
        buildU !i !j !l !u
            | i == n = u
            | otherwise = buildU (i+1) j l (buildUVal i j l u)
        buildLU !j !l !u
            | j == n = (l, u)
            | otherwise =
                let l' = buildL j j l u
                    u' = buildU j j l' u
                in buildLU (j+1) l' u'
    in buildLU 0 initL initU

-- | Compute the (L, U) decomposition of a square matrix using Crout's
--   algorithm, using the vector's 'Finite' instance to provide an index.
luFinite :: ( Num a
            , Fractional a
            , Functor m
            , Finite m
            , n ~ Size m
            , KnownNat n
            , Num (m a)
            )
         => m (m a)
         -> (m (m a), m (m a))
luFinite a =
    bimap (fmap fromV . fromV)
          (fmap fromV . fromV)
          (lu (fmap toV (toV a)))

-- | Solve a linear system with a lower-triangular matrix of coefficients with
--   forwards substitution.
forwardSub :: ( Num a
              , Fractional a
              , Foldable m
              , Additive m
              , Ixed (m a)
              , Ixed (m (m a))
              , i ~ Index (m a)
              , i ~ Index (m (m a))
              , Eq i
              , Ord i
              , Integral i
              , a ~ IxValue (m a)
              , m a ~ IxValue (m (m a))
              )
           => m (m a)
           -> m a
           -> m a
forwardSub a b =
    let n = fromIntegral (length b)
        initX = zero
        coeff !i !j !s !x
            | j == i = s
            | otherwise = coeff i (j+1) (s + ((a ^?! ix i ^?! ix j) * (x ^?! ix j))) x
        go !i !x
            | i == n = x
            | otherwise = go (i + 1) (x & ix i .~ ( ((b ^?! ix i) - coeff i 0 0 x)
                                                  / (a ^?! ix i ^?! ix i)
                                                  ))
    in go 0 initX

-- | Solve a linear system with a lower-triangular matrix of coefficients with
--   forwards substitution, using the vector's 'Finite' instance to provide an
--   index.
forwardSubFinite :: ( Num a
                    , Fractional a
                    , Foldable m
                    , n ~ Size m
                    , KnownNat n
                    , Additive m
                    , Finite m
                    )
                 => m (m a)
                 -> m a
                 -> m a
forwardSubFinite a b = fromV (forwardSub (fmap toV (toV a)) (toV b))

-- | Solve a linear system with an upper-triangular matrix of coefficients with
--   backwards substitution.
backwardSub :: ( Num a
               , Fractional a
               , Foldable m
               , Additive m
               , Ixed (m a)
               , Ixed (m (m a))
               , i ~ Index (m a)
               , i ~ Index (m (m a))
               , Eq i
               , Ord i
               , Integral i
               , a ~ IxValue (m a)
               , m a ~ IxValue (m (m a))
               )
            => m (m a)
            -> m a
            -> m a
backwardSub a b =
    let n = fromIntegral (length b)
        initX = zero
        coeff !i !j !s !x
            | j == n = s
            | otherwise = coeff i
                                (j+1)
                                (s + ((a ^?! ix i ^?! ix j) * (x ^?! ix j)))
                                x
        go !i !x
            | i < 0 = x
            | otherwise = go (i-1)
                             (x & ix i .~ ( ((b ^?! ix i) - coeff i (i+1) 0 x)
                                          / (a ^?! ix i ^?! ix i)
                                          ))
    in go (n-1) initX

-- | Solve a linear system with an upper-triangular matrix of coefficients with
--   backwards substitution, using the vector's 'Finite' instance to provide an
--   index.
backwardSubFinite :: ( Num a
                     , Fractional a
                     , Foldable m
                     , n ~ Size m
                     , KnownNat n
                     , Additive m
                     , Finite m
                     )
                  => m (m a)
                  -> m a
                  -> m a
backwardSubFinite a b = fromV (backwardSub (fmap toV (toV a)) (toV b))

-- | Solve a linear system with LU decomposition.
luSolve :: ( Num a
           , Fractional a
           , Foldable m
           , Traversable m
           , Applicative m
           , Additive m
           , Ixed (m a)
           , Ixed (m (m a))
           , i ~ Index (m a)
           , i ~ Index (m (m a))
           , Eq i
           , Integral i
           , a ~ IxValue (m a)
           , m a ~ IxValue (m (m a))
           , Num (m a)
           )
        => m (m a)
        -> m a
        -> m a
luSolve a b =
    let (l, u) = lu a
    in backwardSub u (forwardSub l b)

-- | Solve a linear system with LU decomposition, using the vector's 'Finite'
--   instance to provide an index.
luSolveFinite :: ( Num a
                 , Fractional a
                 , Functor m
                 , Finite m
                 , n ~ Size m
                 , KnownNat n
                 , Num (m a)
                 )
              => m (m a)
              -> m a
              -> m a
luSolveFinite a b = fromV (luSolve (fmap toV (toV a)) (toV b))

-- | Invert a matrix with LU decomposition.
luInv :: ( Num a
         , Fractional a
         , Foldable m
         , Traversable m
         , Applicative m
         , Additive m
         , Distributive m
         , Ixed (m a)
         , Ixed (m (m a))
         , i ~ Index (m a)
         , i ~ Index (m (m a))
         , Eq i
         , Integral i
         , a ~ IxValue (m a)
         , m a ~ IxValue (m (m a))
         , Num (m a)
         )
      => m (m a)
      -> m (m a)
luInv a =
    let n = fromIntegral (length a)
        initA' = zero
        (l, u) = lu a
        go !i !a'
            | i == n = a'
            | otherwise = let e   = zero & ix i .~ 1
                              a'r = backwardSub u (forwardSub l e)
                          in go (i+1) (a' & ix i .~ a'r)
    in transpose (go 0 initA')

-- | Invert a matrix with LU decomposition, using the vector's 'Finite' instance
--   to provide an index.
luInvFinite :: ( Num a
               , Fractional a
               , Functor m
               , Finite m
               , n ~ Size m
               , KnownNat n
               , Num (m a)
               )
            => m (m a)
            -> m (m a)
luInvFinite a = fmap fromV (fromV (luInv (fmap toV (toV a))))

-- | Compute the determinant of a matrix using LU decomposition.
luDet :: ( Num a
         , Fractional a
         , Foldable m
         , Traversable m
         , Applicative m
         , Additive m
         , Trace m
         , Ixed (m a)
         , Ixed (m (m a))
         , i ~ Index (m a)
         , i ~ Index (m (m a))
         , Eq i
         , Integral i
         , a ~ IxValue (m a)
         , m a ~ IxValue (m (m a))
         , Num (m a)
         )
      => m (m a)
      -> a
luDet a =
    let (l, u) = lu a
        p      = Foldable.foldl (*) 1
    in (p (diagonal l)) * (p (diagonal u))

-- | Compute the determinant of a matrix using LU decomposition, using the
--   vector's 'Finite' instance to provide an index.
luDetFinite :: ( Num a
               , Fractional a
               , Functor m
               , Finite m
               , n ~ Size m
               , KnownNat n
               , Num (m a)
               )
            => m (m a)
            -> a
luDetFinite = luDet . fmap toV . toV
#endif

max_stars_repo_name: TravisWhitaker/linear

max_issues_repo_name: TravisWhitaker/linear

max_forks_repo_name: TravisWhitaker/linear


text:
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE ScopedTypeVariables  #-}

module Genetic where

import           Numeric.LinearAlgebra
import           System.Random.Shuffle    (shuffleM)
import           System.Random
import           System.ProgressBar
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Concurrent.Async (mapConcurrently)
import qualified Data.Vector as V
import           Data.List
import           Data.Maybe

class (Ord a, Eq a, Show a) => Individual a where
    fitness :: a -> IO (Maybe Double)
    mutateIndividual :: a -> IO a
    crossover :: (a, a) -> IO a

runGeneticAlgorithm :: Individual a
                    => Double      -- Goal
                    -> Int         -- maxNumIterations
                    -> Int         -- eliteSize
                    -> [a]         -- Initial (random) genetation
                    -> ProgressRef -- Progress Bar
                    -> IO a
runGeneticAlgorithm threshold
                    maxNumIterations
                    eliteSize
                    population
                    progRef   = do
    finalGroup <- foldM (makeGeneration threshold eliteSize progRef)
                        initialGeneration
                        [1..maxNumIterations]
    best finalGroup
    where
        initialGeneration = population

makeGeneration :: Individual a
               => Double      -- Goal
               -> Int         -- eliteSize
               -> ProgressRef
               -> [a]         -- population
               -> Int         -- generation number
               -> IO [a]
makeGeneration goal eliteSize progRef population _ = do
    cleanPop <- filterM (fmap isJust . fitness) population
    mFitness <- fitness =<< best cleanPop
    let bestFitness = fromMaybe (error "Invalid Fitness") mFitness
    if bestFitness < goal
    then return cleanPop
    else do incProgress progRef 1
            nextGeneration cleanPop eliteSize

nextGeneration :: Individual a
               => [a]    -- population
               -> Int    -- elite size
               -> IO [a]
nextGeneration population eliteSize = do
    children    <- makeChildren population eliteSize
    elita <- elite population eliteSize
    return (elita ++ children)

best :: Individual a
     => [a]
     -> IO a
best pop = do
    fitnesses <- mapConcurrently fitness pop
    let combined = filter (isJust . fst) $ zip fitnesses pop
    --             [(fitness, individual)]
        chosen   = minimumBy (\x y -> compare (fst x) (fst y)) combined
    return $ snd chosen

mutate :: Individual a => [a] -> IO [a]
mutate = mapConcurrently mutateIndividual

elite :: Individual a
      => [a]
      -> Int
      -> IO [a]
elite individuals nElit = do
    fitnesses <- mapConcurrently fitness individuals
    let combined   = zip fitnesses individuals
        results    = map snd . take nElit . sortOn fst $ combined
        mFitnesses = map fst . take nElit . sortOn fst $ combined
    return results

selectCouples :: Individual a
           => [a] -- population
           -> Int -- number of couples
           -> IO [(a, a)]
selectCouples population numOfCouples =
    sequence . take numOfCouples $ repeat $ selectCouple population

selectCouple :: Individual a
             => [a]
             -> IO (a, a)
selectCouple population = do
    fitnesses <- mapConcurrently fitness population
    let combined    = filter (isJust . fst) $ zip fitnesses population
        population_ = map snd . sortOn (fromJust . fst) $ combined
        indexList   = [0..(length population_ - 1)]
        duplicated  = duplicateByValue indexList
    [index1, index2] <- take 2
                      . nub
                    <$> shuffleM duplicated
    return ( population_ !! index1
           , population_ !! index2
           )

duplicateByValue :: [Int]
                 -> [Int]
duplicateByValue = foldr (\ x -> (++) (replicate x x)) []

makeChildren :: Individual a
             => [a]    -- population
             -> Int    -- nElit
             -> IO [a]
makeChildren population nElit = do
    parents   <- selectCouples population $ length population - nElit
    children  <- mapConcurrently crossover parents
    fitnesses <- mapConcurrently fitness children
    mutate $ map fst $ filter (isJust . snd) $ zip children fitnesses

bestFit :: Individual a
        => [a]
        -> IO Double
bestFit pop = minimum . catMaybes <$> mapConcurrently fitness pop


text:
{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
module CNC.Declarative(module CNC.Figure,
                       mirrorX, mirrorY, rotate, scale, posToExpr, renderPath) where

import CNC.Figure
import CNC.Geometry(RealT, eps)
import CNC.HCode(HCode, frame, g, x, y,
                 Expr, toExpr)

import Data.Complex

-- mirrors around the X axis
mirrorX :: Path -> Path
mirrorX = mapPath (\(x :+ y) -> (x :+ negate y))

-- mirrors around the Y axis
mirrorY :: Path -> Path
mirrorY = mapPath (\(x :+ y) -> (negate x :+ y))

-- rotates around (0,0) point counter-clockwise on a given angle
rotate :: RealT -> Path -> Path
rotate a = mapPath (* exp (0 :+ a))

-- scales the path
scale :: RealT -> Path -> Path
scale k = mapPath (* (k :+ 0))

posToExpr :: Pos -> (Expr RealT, Expr RealT)
posToExpr (x :+ y) = (toExpr x, toExpr y)

-- renders a path in HCode monad
renderPath :: (Expr RealT, Expr RealT) -> Path -> HCode ()
renderPath (x0, y0) path = do
  frame [g 0, x x0, y y0]
  mapPathM_ (\(xi :+ yi) -> frame [g 1, x $ toExpr xi + x0, y $ toExpr yi + y0]) path

max_stars_repo_name: akamaus/gcodec

max_issues_repo_name: akamaus/gcodec

max_forks_repo_name: akamaus/gcodec


text:
module Main where

import qualified  Statistics.Matrix as M
-- import            Data.Vector
import            System.Random
import            Control.Monad.Random

import NeuralNetwork

inputX :: M.Matrix
inputX = M.fromList 3 2 [ 3 , 5
                        , 5 , 1
                        , 10, 2
                        ]

inputY :: M.Matrix
inputY = M.fromList 3 1 [ 75
                        , 82
                        , 93
                        ]

inputXN :: M.Matrix
inputXN = M.map (\x -> x / 24) inputX

inputYN :: M.Matrix
inputYN = M.map (\x -> x / 100) inputY

main :: IO ()
main = do
    let g  = mkStdGen 123123123123
        nn = flip evalRand g $ initNetwork 2 1 3
    print $ costFunction nn inputXN inputYN

main' :: IO ()
main' = do
    let g  = mkStdGen 123123123123123
        nn = flip evalRand g $ initNetwork 2 1 3
        (dJdW1, dJdW2) = costFunctionPrime nn inputX inputY

        scalarW1 = M.fromList 2 3 (replicate 6 3)
        scalarW2 = M.fromList 3 1 (replicate 3 3)

        nn' = nn { weight1Matrix = weight1Matrix nn + (scalarW1 `pointMultiply` dJdW1)
                 , weight2Matrix = weight2Matrix nn + (scalarW2 `pointMultiply` dJdW2) }

    print $ costFunctionPrime nn' inputXN inputYN

g  = mkStdGen 123123123123123
nn = flip evalRand g $ initNetwork 2 1 3
(dJdW1, dJdW2) = costFunctionPrime nn inputXN inputYN

scalarW1 = M.fromList 2 3 (replicate 6 3)
scalarW2 = M.fromList 3 1 (replicate 3 3)

nn' = nn { weight1Matrix = weight1Matrix nn + (scalarW1 `pointMultiply` dJdW1)
         , weight2Matrix = weight2Matrix nn + (scalarW2 `pointMultiply` dJdW2)
         }

max_stars_repo_name: cirquit/nn-playground

max_issues_repo_name: cirquit/nn-playground

max_forks_repo_name: cirquit/nn-playground


text:
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}

-- |
-- Module      :  Pact.Repl.Lib
-- Copyright   :  (C) 2016 Stuart Popejoy
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Stuart Popejoy <stuart@kadena.io>
--
-- Built-ins for repl functionality. Not part of standard library
-- for blockchain execution, but instead for testing and dev.
--

module Pact.Repl.Lib where

import Control.Arrow ((&&&))
import Data.Default
import Data.Semigroup
import qualified Data.HashMap.Strict as HM
import qualified Data.Map as M
import Control.Monad.Reader
import Control.Monad.Catch
import Control.Monad.State.Strict (get)
import Control.Lens
import qualified Data.Set as S
import qualified Data.ByteString.Lazy as BSL
import Control.Concurrent.MVar
import Data.Aeson (eitherDecode,toJSON)
import qualified Data.Text as Text
import Data.Text.Encoding
import Data.Maybe
#if !defined(ghcjs_HOST_OS)
import Criterion
import Criterion.Types
import Pact.Analyze.Check
#if MIN_VERSION_statistics(0,14,0)
import Statistics.Types (Estimate(..))
#else
import Statistics.Resampling.Bootstrap
#endif
#endif
import Pact.Typechecker
import Pact.Types.Typecheck
-- intentionally hidden unused functions to prevent lib functions from consuming gas
import Pact.Native.Internal hiding (defRNative,defGasRNative,defNative)
import qualified Pact.Native.Internal as Native
import Pact.Types.Runtime
import Pact.Eval
import Pact.Persist.Pure
import Pact.PersistPactDb
import Pact.Types.Logger
import Pact.Repl.Types

initLibState :: Loggers -> IO LibState
initLibState loggers = do
  m <- newMVar (DbEnv def persister
                (newLogger loggers "Repl")
                def def)
  createSchema m
  return (LibState m Noop def def)

-- | Native function with no gas consumption.
type ZNativeFun e = FunApp -> [Term Ref] -> Eval e (Term Name)

zeroGas :: Eval e a -> Eval e (Gas,a)
zeroGas = fmap (0,)

defZNative :: NativeDefName -> ZNativeFun e -> FunTypes (Term Name) -> Text -> NativeDef
defZNative name fun = Native.defNative name $ \fi as -> zeroGas $ fun fi as

defZRNative :: NativeDefName -> RNativeFun e -> FunTypes (Term Name) -> Text -> NativeDef
defZRNative name fun = Native.defNative name (reduced fun)
    where reduced f fi as = mapM reduce as >>= zeroGas . f fi

replDefs :: NativeModule
replDefs = ("Repl",
     [
      defZRNative "load" load (funType tTyString [("file",tTyString)] <>
                              funType tTyString [("file",tTyString),("reset",tTyBool)]) $
      "Load and evaluate FILE, resetting repl state beforehand if optional NO-RESET is true. " <>
      "`$(load \"accounts.repl\")`"
     ,defZRNative "env-keys" setsigs (funType tTyString [("keys",TyList tTyString)])
      "Set transaction signature KEYS. `(env-keys [\"my-key\" \"admin-key\"])`"
     ,defZRNative "env-data" setmsg (funType tTyString [("json",json)]) $
      "Set transaction JSON data, either as encoded string, or as pact types coerced to JSON. " <>
      "`(env-data { \"keyset\": { \"keys\": [\"my-key\" \"admin-key\"], \"pred\": \"keys-any\" } })`"
     ,defZRNative "env-step"
      setstep (funType tTyString [] <>
               funType tTyString [("step-idx",tTyInteger)] <>
               funType tTyString [("step-idx",tTyInteger),("rollback",tTyBool)] <>
               funType tTyString [("step-idx",tTyInteger),("rollback",tTyBool),("resume",TySchema TyObject (mkSchemaVar "y"))])
      ("Set pact step state. With no arguments, unset step. With STEP-IDX, set step index to execute. " <>
       "ROLLBACK instructs to execute rollback expression, if any. RESUME sets a value to be read via 'resume'." <>
       "Clears any previous pact execution state. `$(env-step 1)` `$(env-step 0 true)`")
     ,defZRNative "pact-state" pactState (funType (tTyObject TyAny) [])
      ("Inspect state from previous pact execution. Returns object with fields " <>
      "'yield': yield result or 'false' if none; 'step': executed step; " <>
      "'executed': indicates if step was skipped because entity did not match. `$(pact-state)`")
     ,defZRNative "env-entity" setentity
      (funType tTyString [] <> funType tTyString [("entity",tTyString)])
      ("Set environment confidential ENTITY id, or unset with no argument. " <>
      "Clears any previous pact execution state. `$(env-entity \"my-org\")` `$(env-entity)`")
     ,defZRNative "begin-tx" (tx Begin) (funType tTyString [] <>
                                        funType tTyString [("name",tTyString)])
       "Begin transaction with optional NAME. `$(begin-tx \"load module\")`"
     ,defZRNative "commit-tx" (tx Commit) (funType tTyString []) "Commit transaction. `$(commit-tx)`"
     ,defZRNative "rollback-tx" (tx Rollback) (funType tTyString []) "Rollback transaction. `$(rollback-tx)`"
     ,defZRNative "expect" expect (funType tTyString [("doc",tTyString),("expected",a),("actual",a)])
      "Evaluate ACTUAL and verify that it equals EXPECTED. `(expect \"Sanity prevails.\" 4 (+ 2 2))`"
     ,defZNative "expect-failure" expectFail (funType tTyString [("doc",tTyString),("exp",a)]) $
      "Evaluate EXP and succeed only if it throws an error. " <>
      "`(expect-failure \"Enforce fails on false\" (enforce false \"Expected error\"))`"
     ,defZNative "bench" bench' (funType tTyString [("exprs",TyAny)])
      "Benchmark execution of EXPRS. `$(bench (+ 1 2))`"
     ,defZRNative "typecheck" tc (funType tTyString [("module",tTyString)] <>
                                 funType tTyString [("module",tTyString),("debug",tTyBool)])
       "Typecheck MODULE, optionally enabling DEBUG output."
     ,defZRNative "env-gaslimit" setGasLimit (funType tTyString [("limit",tTyInteger)])
       "Set environment gas limit to LIMIT"
     ,defZRNative "env-gas" envGas (funType tTyInteger [] <> funType tTyString [("gas",tTyInteger)])
       "Query gas state, or set it to GAS"
     ,defZRNative "env-gasprice" setGasPrice (funType tTyString [("price",tTyDecimal)])
       "Set environment gas price to PRICE"
     ,defZRNative "env-gasrate" setGasRate (funType tTyString [("rate",tTyInteger)])
       "Update gas model to charge constant RATE"
#if !defined(ghcjs_HOST_OS)
     ,defZRNative "verify" verify (funType tTyString [("module",tTyString)]) "Verify MODULE, checking that all properties hold."
#endif

     ,defZRNative "json" json' (funType tTyValue [("exp",a)]) $
      "Encode pact expression EXP as a JSON value. " <>
      "This is only needed for tests, as Pact values are automatically represented as JSON in API output. " <>
      "`(json [{ \"name\": \"joe\", \"age\": 10 } {\"name\": \"mary\", \"age\": 25 }])`"
     ,defZRNative "sig-keyset" sigKeyset (funType tTyKeySet [])
     "Convenience to build a keyset from keys present in message signatures, using 'keys-all' as the predicate."
     ,defZRNative "print" print' (funType tTyString [("value",a)])
     "Print a string, mainly to format newlines correctly"
     ,defZRNative "env-hash" envHash (funType tTyString [("hash",tTyString)])
     "Set current transaction hash. HASH must be a valid BLAKE2b 512-bit hash. `(env-hash (hash \"hello\"))`"
     ])
     where
       json = mkTyVar "a" [tTyInteger,tTyString,tTyTime,tTyDecimal,tTyBool,
                         TyList (mkTyVar "l" []),TySchema TyObject (mkSchemaVar "o"),tTyKeySet,tTyValue]
       a = mkTyVar "a" []

invokeEnv :: (MVar (DbEnv PureDb) -> IO b) -> MVar LibState -> IO b
invokeEnv f e = withMVar e $ \ls -> f $! _rlsPure ls
{-# INLINE invokeEnv #-}

repldb :: PactDb LibState
repldb = PactDb {

    _readRow = \d k -> invokeEnv $ _readRow pactdb d k
  , _writeRow = \wt d k v -> invokeEnv $ _writeRow pactdb wt d k v
  , _keys = \t -> invokeEnv $ _keys pactdb t
  , _txids = \t tid -> invokeEnv $ _txids pactdb t tid
  , _createUserTable = \t m k -> invokeEnv $ _createUserTable pactdb t m k
  , _getUserTableInfo = \t -> invokeEnv $ _getUserTableInfo pactdb t
  , _beginTx = \tid -> invokeEnv $ _beginTx pactdb tid
  , _commitTx = invokeEnv $ _commitTx pactdb
  , _rollbackTx = invokeEnv $ _rollbackTx pactdb
  , _getTxLog = \d t -> invokeEnv $ _getTxLog pactdb d t

}

load :: RNativeFun LibState
load _ [TLitString fn] = setop (Load (unpack fn) False) >> return (tStr $ "Loading " <> fn <> "...")
load _ [TLitString fn, TLiteral (LBool r) _] = setop (Load (unpack fn) r) >> return (tStr $ "Loading " <> fn <> "...")
load i as = argsError i as

modifyLibState :: (LibState -> (LibState,a)) -> Eval LibState a
modifyLibState f = view eePactDbVar >>= \m -> liftIO $ modifyMVar m (return . f)

setLibState :: (LibState -> LibState) -> Eval LibState ()
setLibState f = modifyLibState (f &&& const ())

viewLibState :: (LibState -> a) -> Eval LibState a
viewLibState f = modifyLibState (id &&& f)

setop :: LibOp -> Eval LibState ()
setop v = setLibState $ set rlsOp v

setenv :: Show a => Setter' (EvalEnv LibState) a -> a -> Eval LibState ()
setenv l v = setop $ UpdateEnv $ Endo (set l v)

setsigs :: RNativeFun LibState
setsigs i [TList ts _ _] = do
  ks <- forM ts $ \t -> case t of
          (TLitString s) -> return s
          _ -> argsError i ts
  setenv eeMsgSigs (S.fromList (map (PublicKey . encodeUtf8) ks))
  return $ tStr "Setting transaction keys"
setsigs i as = argsError i as

setmsg :: RNativeFun LibState
setmsg i [TLitString j] =
  case eitherDecode (BSL.fromStrict $ encodeUtf8 j) of
    Left f -> evalError' i ("Invalid JSON: " ++ show f)
    Right v -> setenv eeMsgBody v >> return (tStr "Setting transaction data")
setmsg _ [a] = setenv eeMsgBody (toJSON a) >> return (tStr "Setting transaction data")
setmsg i as = argsError i as

setstep :: RNativeFun LibState
setstep i as = case as of
  [] -> setstep' Nothing >> return (tStr "Un-setting step")
  [TLitInteger j] -> do
    setstep' (Just $ PactStep (fromIntegral j) False def def)
    return $ tStr "Setting step"
  [TLitInteger j,TLiteral (LBool b) _] -> do
    setstep' (Just $ PactStep (fromIntegral j) b def def)
    return $ tStr "Setting step and rollback"
  [TLitInteger j,TLiteral (LBool b) _,o@TObject{}] -> do
    setstep' (Just $ PactStep (fromIntegral j) b def (Just o))
    return $ tStr "Setting step, rollback, and resume value"
  _ -> argsError i as
  where
    setstep' s = do
      setenv eePactStep s
      evalPactExec .= Nothing

setentity :: RNativeFun LibState
setentity i as = case as of
  [TLitString s] -> do
    setenv eeEntity $ Just (EntityName s)
    evalPactExec .= Nothing
    return (tStr $ "Set entity to " <> s)
  [] -> do
    setenv eeEntity Nothing
    evalPactExec .= Nothing
    return (tStr "Unset entity")
  _ -> argsError i as

pactState :: RNativeFun LibState
pactState i [] = do
  e <- use evalPactExec
  case e of
    Nothing -> evalError' i "pact-state: no pact exec in context"
    Just PactExec{..} -> return $ (\o -> TObject o TyAny def)
      [(tStr "yield",fromMaybe (toTerm False) _peYield)
      ,(tStr "executed",toTerm _peExecuted)
      ,(tStr "step",toTerm _peStep)]
pactState i as = argsError i as

txmsg :: Maybe Text -> Maybe TxId -> Text -> Term Name
txmsg n tid s = tStr $ s <> " Tx " <> pack (show tid) <> maybe "" (": " <>) n

tx :: Tx -> RNativeFun LibState
tx Begin i as = do
  tname <- case as of
             [TLitString n] -> return $ Just n
             [] -> return Nothing
             _ -> argsError i as
  setop $ Tx (_faInfo i) Begin tname
  setLibState $ set rlsTxName tname
  return (tStr "")
tx t i [] = do
  tname <- modifyLibState (set rlsTxName Nothing &&& view rlsTxName)
  setop (Tx (_faInfo i) t tname)
  return (tStr "")
tx _ i as = argsError i as

recordTest :: Text -> Maybe (FunApp,Text) -> Eval LibState ()
recordTest name failure = setLibState $ over rlsTests (++ [TestResult name failure])

testSuccess :: Text -> Text -> Eval LibState (Term Name)
testSuccess name msg = recordTest name Nothing >> return (tStr msg)

testFailure :: FunApp -> Text -> Text -> Eval LibState (Term Name)
testFailure i name msg = recordTest name (Just (i,msg)) >> return (tStr msg)

expect :: RNativeFun LibState
expect i [TLitString a,b,c] =
  if b `termEq` c
  then testSuccess a $ "Expect: success: " <> a
  else testFailure i a $ "FAILURE: " <> a <> ": expected " <> pack (show b) <> ", received " <> pack (show c)
expect i as = argsError i as

expectFail :: ZNativeFun LibState
expectFail i as@[a,b] = do
  a' <- reduce a
  case a' of
    TLitString msg -> do
      r <- catch (Right <$> reduce b) (\(_ :: SomeException) -> return $ Left ())
      case r of
        Right v -> testFailure i msg $ "FAILURE: " <> msg <> ": expected failure, got result = " <> pack (show v)
        Left _ -> testSuccess msg $ "Expect failure: success: " <> msg
    _ -> argsError' i as
expectFail i as = argsError' i as

bench' :: ZNativeFun LibState
#if !defined(ghcjs_HOST_OS)
bench' i as = do
  e <- ask
  s <- get
  (r :: Either SomeException Report) <-
      try $ liftIO $ benchmark' $ whnfIO $ runEval s e $ do
                !ts <- mapM reduce as
                return $! toTerm (length ts)
  case r of
    Left ex -> evalError' i (show ex)
    Right rpt -> do
           let mean = estPoint (anMean (reportAnalysis rpt))
               sd = estPoint (anStdDev (reportAnalysis rpt))
               (reg,_) = splitAt 1 $ anRegress (reportAnalysis rpt)
               val = case reg of
                       [] -> mean
                       (r':_) -> case M.lookup "iters" (regCoeffs r') of
                                  Nothing -> mean
                                  Just t -> estPoint t
               tps = 1/val
               tperr = (1/(val - (sd/2))) - (1/(val + (sd/2)))
           liftIO $ putStrLn $ show (round tps :: Integer) ++ "/s, +-" ++ show (round tperr :: Integer) ++ "/s"
           return (tStr "Done")
#else
bench' i _ = evalError' i "Benchmarking not supported in GHCJS"
#endif

tc :: RNativeFun LibState
tc i as = case as of
  [TLitString s] -> go s False
  [TLitString s,TLiteral (LBool d) _] -> go s d
  _ -> argsError i as
  where
    go modname dbg = do
      mdm <- HM.lookup (ModuleName modname) <$> view (eeRefStore . rsModules)
      case mdm of
        Nothing -> evalError' i $ "No such module: " ++ show modname
        Just md -> do
          r :: Either CheckerException ([TopLevel Node],[Failure]) <-
            try $ liftIO $ typecheckModule dbg md
          case r of
            Left (CheckerException ei e) -> evalError ei ("Typechecker Internal Error: " ++ e)
            Right (_,fails) -> case fails of
              [] -> return $ tStr $ "Typecheck " <> modname <> ": success"
              _ -> do
                setop $ TcErrors $ map (\(Failure ti s) -> renderInfo (_tiInfo ti) ++ ":Warning: " ++ s) fails
                return $ tStr $ "Typecheck " <> modname <> ": Unable to resolve all types"

#if !defined(ghcjs_HOST_OS)
verify :: RNativeFun LibState
verify i as = case as of
  [TLitString modName] -> do
    modules <- view (eeRefStore . rsModules)
    let mdm = HM.lookup (ModuleName modName) modules
    case mdm of
      Nothing -> evalError' i $ "No such module: " ++ show modName
      Just md -> do
        results <- liftIO $ verifyModule modules md
        setop $ TcErrors $ fmap (Text.unpack . describeCheckResult) $
          toListOf (traverse . each) results

        return (tStr "")

  _ -> argsError i as
#endif

json' :: RNativeFun LibState
json' _ [a] = return $ TValue (toJSON a) def
json' i as = argsError i as

sigKeyset :: RNativeFun LibState
sigKeyset _ _ = view eeMsgSigs >>= \ss -> return $ toTerm $ KeySet (S.toList ss) (Name (asString KeysAll) def)

print' :: RNativeFun LibState
print' _ [v] = setop (Print v) >> return (tStr "")
print' i as = argsError i as

envHash :: RNativeFun LibState
envHash i [TLitString s] = case fromText' s of
  Left err -> evalError' i $ "Bad hash value: " ++ show s ++ ": " ++ err
  Right h -> do
    setenv eeHash h
    return $ tStr $ "Set tx hash to " <> s
envHash i as = argsError i as

setGasLimit :: RNativeFun LibState
setGasLimit _ [TLitInteger l] = do
  setenv (eeGasEnv . geGasLimit) (fromIntegral l)
  return $ tStr $ "Set gas limit to " <> tShow l
setGasLimit i as = argsError i as

envGas :: RNativeFun LibState
envGas _ [] = use evalGas >>= \g -> return (tLit $ LInteger $ fromIntegral g)
envGas _ [TLitInteger g] = do
  evalGas .= fromIntegral g
  return $ tStr $ "Set gas to " <> tShow g
envGas i as = argsError i as

setGasPrice :: RNativeFun LibState
setGasPrice _ [TLiteral (LDecimal d) _] = do
  setenv (eeGasEnv . geGasPrice) (GasPrice d)
  return $ tStr $ "Set gas price to " <> tShow d
setGasPrice i as = argsError i as

setGasRate :: RNativeFun LibState
setGasRate _ [TLitInteger r] = do
    setenv (eeGasEnv . geGasModel) (constGasModel $ fromIntegral r)
    return $ tStr $ "Set gas rate to " <> tShow r

setGasRate i as = argsError i as

max_stars_repo_name: gitter-badger/pact

max_issues_repo_name: gitter-badger/pact

max_forks_repo_name: gitter-badger/pact


text:
import Criterion.Main
import Numeric.LinearAlgebra

n = 10 :: Int
main = defaultMain [
         bench "eigenvalues" $ w (\_ -> eigenvalues sampleDiag),
         bench "singularValues" $ w (\_ -> singularValues sampleDiag),

         bench "svd" $ w (\_ -> svd sampleDiag),
         bench "thin svd" $ w (\_ -> thinSVD sampleDiag),

         bench "nullspace" $ w (\_ -> nullspace sampleDiag),
         bench "orthogonal" $ w (\_ -> orth sampleDiag),

         bench "determinant" $ w (\_ -> det sampleDiag)
       ]
  where
    w f = f `whnf` 0
    sampleList = replicate n $ replicate n 1
    sampleDiag = diagl [1..fromIntegral n]

max_stars_repo_name: DataHaskell/numeric-libs-benchmarks

max_issues_repo_name: mdibaiee/numeric-libs-overview

max_forks_repo_name: DataHaskell/numeric-libs-benchmarks


text:
{-# LANGUAGE RecordWildCards #-}
import           Linear.V2 (V2(V2), perp)
import           Polynomial.Roots
import           Data.Complex
import           Text.Printf (printf)
import qualified Physics.Light as Light
import           Helm
import           Helm.Color
import           Helm.Engine.SDL (SDLEngine)
import           Helm.Graphics2D
import qualified Helm.Graphics2D.Text as Text
import qualified Helm.Cmd as Cmd
import qualified Helm.Mouse as Mouse
import qualified Helm.Keyboard as Keyboard
import qualified Helm.Sub as Sub
import qualified Helm.Time as Time
import           Helm.Time (Time, second)
import qualified Helm.Engine.SDL as SDL

data Action
  = Idle
  | Animate Double
  | Player1Left
  | Player1Right
  | Player1Jump
  | Player2Left
  | Player2Right
  | Player2Jump
  | Stop1Vel
  | Stop2Vel
  | BeginGame
  | ResetGame

data GameStatus
  = Playing
  | Paused
  | Waiting
  | Dead
  deriving (Eq, Ord, Show)

data Model = Model
  { player1Pos    :: V2 Double
  , player1Vel    :: V2 Double
  , player2Pos    :: V2 Double
  , player2Vel    :: V2 Double
  , ballPos       :: V2 Double
  , ballVel       :: V2 Double
  , gameStatus    :: GameStatus
  , player1Score  :: Integer
  , player2Score  :: Integer
  , player1Chance :: Integer
  , player2Chance :: Integer
  , lastWin       :: Integer
  , lastCollide   :: Integer
  }

xof :: V2 Double -> Double
xof (V2 x y) = x

yof :: V2 Double -> Double
yof (V2 x y) = y

gravity :: V2 Double
gravity = V2 0 30

screenWidth :: Double
screenWidth = 1920

screenHeight :: Double
screenHeight = 900

groundHeight :: Double
groundHeight = 180

netWidth :: Double
netWidth = 10

netHeight :: Double
netHeight = screenHeight*0.5

playerRadius :: Double
playerRadius = 50

ballRadius :: Double
ballRadius = 30

baseline :: Double
baseline = screenHeight - playerRadius

dampX :: V2 Double -> V2 Double
dampX (V2 x y) = (V2 0 y)

dampY :: V2 Double -> V2 Double
dampY (V2 x y) = (V2 x 0)

getCollisionTime :: V2 Double -> V2 Double -> V2 Double -> V2 Double -> Double
getCollisionTime (V2 x' y') (V2 vx' vy') (V2 px py) (V2 pvx pvy) = minimum $ map realPart $ filter (\x -> (imagPart x == 0) && (realPart x >= 0)) $ roots 1.0e-6 300 $ map (\x -> x :+ 0)
    [ (x^2) + (y^2) - ((ballRadius + playerRadius)^2),
      (2*x*vx) + (2*y*vy),
      (vx^2) + (vy^2) + (y*g),
      vy*g,
      (g^2)/4]
    where x = x' - px
          y = y' - py
          vx = vx' - pvx
          vy = vy' - pvy
          g = if py < baseline then 0 else yof gravity

initial :: (Model, Cmd SDLEngine Action)
initial =
  ( Model
      { player1Pos    = V2 200 baseline
      , player1Vel    = V2 0 0
      , player2Pos    = V2 (screenWidth - 200) baseline
      , player2Vel    = V2 0 0
      , ballPos       = V2 300 100
      , ballVel       = V2 0 0
      , gameStatus    = Waiting
      , player1Score  = 0
      , player2Score  = 0
      , player1Chance = 3
      , player2Chance = 3
      , lastWin       = 0
      , lastCollide   = 0
      }
  , Cmd.none
  )

update :: Model -> Action -> (Model, Cmd SDLEngine Action)
update model@Model { .. } Idle = (model, Cmd.none)

update model@Model { .. } BeginGame =
  if gameStatus == Playing then (model, Cmd.none)
  else
    ( model
      { gameStatus = Playing
      , player1Pos    = V2 200 baseline
      , player1Vel    = V2 0 0
      , player2Pos    = V2 (screenWidth - 200) baseline
      , player2Vel    = V2 0 0
      , ballPos       = V2 (if lastWin /= 2 then 300 else screenWidth - 300) 100
      , ballVel       = V2 0 0
      }
    , Cmd.none
    )

update model@Model { .. } ResetGame =
  if gameStatus == Playing then (model, Cmd.none)
  else
    ( model
      { player1Pos    = V2 200 baseline
      , player1Vel    = V2 0 0
      , player2Pos    = V2 (screenWidth - 200) baseline
      , player2Vel    = V2 0 0
      , lastWin       = 0
      , ballPos       = V2 300 100
      , ballVel       = V2 0 0
      , player1Score  = 0
      , player2Score  = 0
      }
    , Cmd.none
    )

update model@Model { .. } (Animate dt) =
  if gameStatus /= Playing then (model, Cmd.none)
  else
    ( model
      { ballPos       = ballFinalPos
      , ballVel       = ballFinalVel
      , player1Pos    = player1FinalPos
      , player1Vel    = player1FinalVel
      , player2Pos    = player2FinalPos
      , player2Vel    = player2FinalVel
      , player1Score  = score1
      , player2Score  = score2
      , player1Chance = chance1
      , player2Chance = chance2
      , gameStatus    = status
      , lastWin       = lw
      , lastCollide   = lc
      }
    , Cmd.none
    )
  where
    t = pure $ dt * 0.005
    fvel vel dt' = vel + (gravity * dt')
    fpos pos vel dt' = pos + (vel * dt') + (0.5 * gravity * dt' * dt')
    magn v = sqrt $ sum $ v * v
    distance a b = magn $ a - b
    dot a b = sum $ a * b
    c2c a b = (a - b) * (pure (1 / (distance a b)))
    pc2c a b = perp $ c2c a b

    reflect ppos bpos bvel = ((pure (dot bvel y)) * y) - ((pure (dot bvel x)) * x)
      where x = c2c bpos ppos
            y = pc2c bpos ppos

    playerUpdate pos vel leftLimit rightLimit
      | (yof finalPos < baseline) && (xof finalPos >= leftLimit) && (xof finalPos <= rightLimit) = (finalPos, finalVel)
      | yof finalPos < baseline = (pos + (dampX (vel * t)) + (gravity*0.5*t*t), dampX finalVel)
      | (xof finalPos >= leftLimit) && (xof finalPos <= rightLimit) = ((\(V2 x y) -> (V2 x baseline)) finalPos, dampY finalVel)
      | otherwise = ((\(V2 x y) -> (V2 x baseline)) pos, (V2 0 0))
      where
        finalPos = fpos pos vel t
        finalVel = fvel vel t

    (player1FinalPos, player1FinalVel) = playerUpdate player1Pos player1Vel playerRadius (((screenWidth - netWidth)/2) - playerRadius)

    (player2FinalPos, player2FinalVel) = playerUpdate player2Pos player2Vel (((screenWidth + netWidth)/2) + playerRadius) (screenWidth - playerRadius)

    doesCollide ppos
      | (distance ballTempPos ppos) <= (ballRadius + playerRadius) = True
      | otherwise = False
      where
        ballTempPos = fpos ballPos ballVel t
        ballTempVel = fvel ballVel t

    ballAfterCollision ppos pvel = let
        tcol = pure $ getCollisionTime ballPos ballVel ppos pvel
        (x, y) = (fpos ballPos ballVel tcol, fvel ballVel tcol)
        v = reflect ppos x y
        tf = t - tcol
        in (fpos x v tf, fvel v tf)

    (ballFinalPos, ballFinalVel)
      | doesCollide player1FinalPos = ballAfterCollision player1Pos player1Vel
      | doesCollide player2FinalPos = ballAfterCollision player2Pos player2Vel
      | (xof expBallPos <= ballRadius) || (xof expBallPos >= (screenWidth - ballRadius)) = (ballPos, reverseXVel ballVel)
      | (xof expBallPos >= (screenWidth - netWidth)/2 - ballRadius) && (xof expBallPos <= (screenWidth + netWidth)/2 + ballRadius) && (yof expBallPos >= screenHeight - netHeight) = (ballPos, reverseXVel ballVel)
      | (xof expBallPos >= (screenWidth - netWidth)/2 - ballRadius) && (xof expBallPos <= (screenWidth + netWidth)/2 + ballRadius) && (yof expBallPos <= screenHeight - netHeight) && (yof expBallPos >= screenHeight - netHeight - ballRadius) = (ballPos, reverseYVel ballVel)
      | yof expBallPos >= (screenHeight - ballRadius) = (ballPos, (V2 0 0))
      | otherwise = (expBallPos, expBallVel)
      where
        expBallPos = fpos ballPos ballVel t
        expBallVel = fvel ballVel t
        reverseXVel (V2 x y) = (V2 (-x) y)
        reverseYVel (V2 x y) = (V2 x (-y))

    (score1, score2, chance1, chance2, status, lc, lw)
      | touchGround =
        if ballInLeft then (player1Score, player2Score + 1, 3, 3, Waiting, 0, 2)
        else (player1Score + 1, player2Score, 3, 3, Waiting, 0, 1)
      | chance1' < 0 = (player1Score, player2Score + 1, 3, 3, Waiting, 0, 2)
      | chance2' < 0 = (player1Score + 1, player2Score, 3, 3, Waiting, 0, 1)
      | otherwise = (player1Score, player2Score, chance1', chance2', Playing, lc', lastWin)
      where
        touchGround = yof (fpos ballPos ballVel t) >= (screenHeight - ballRadius)
        ballInLeft = (xof (fpos ballPos ballVel t) > ballRadius) && (xof (fpos ballPos ballVel t) < ((screenWidth - netWidth) / 2 - ballRadius))
        (chance1', chance2', lc')
          | doesCollide player1FinalPos = (player1Chance - 1, player2Chance, 1)
          | doesCollide player2FinalPos = (player1Chance, player2Chance - 1, 2)
          | otherwise = (player1Chance, player2Chance, lastCollide)

update model@Model { .. } Player1Left
  | gameStatus == Playing =
    if False then (model, Cmd.none) else
      ( model
        { player1Vel = if (xof player1Vel) /= (-100) then player1Vel - (V2 100 0)
                       else player1Vel
        }
      , Cmd.none
      )
  | otherwise = (model, Cmd.none)

update model@Model { .. } Player2Left
  | gameStatus == Playing =
    if False then (model, Cmd.none) else
      ( model
        { player2Vel = if (xof player2Vel) /= (-100) then player2Vel - (V2 100 0)
                       else player2Vel
        }
      , Cmd.none
      )
  | otherwise = (model, Cmd.none)

update model@Model { .. } Player1Right
  | gameStatus == Playing =
    if False then (model, Cmd.none) else
      ( model
        { player1Vel = if (xof player1Vel) /= 100 then player1Vel + (V2 100 0)
                       else player1Vel
        }
      , Cmd.none
      )
  | otherwise = (model, Cmd.none)

update model@Model { .. } Player2Right
  | gameStatus == Playing =
    if False then (model, Cmd.none) else
      ( model
        { player2Vel = if (xof player2Vel) /= 100 then player2Vel + (V2 100 0)
                       else player2Vel
        }
      , Cmd.none
      )
  | otherwise = (model, Cmd.none)

update model@Model { .. } Player1Jump
  | gameStatus == Playing =
    if False then (model, Cmd.none) else
      ( model
        { player1Vel = if (yof player1Pos) < baseline then player1Vel else player1Vel - (V2 0 150)
        }
      , Cmd.none
      )
  | otherwise = (model, Cmd.none)

update model@Model { .. } Player2Jump
  | gameStatus == Playing =
    if False then (model, Cmd.none) else
      ( model
        { player2Vel = if (yof player2Pos) < baseline then player2Vel else player2Vel - (V2 0 150)
        }
      , Cmd.none
      )
  | otherwise = (model, Cmd.none)

update model@Model { .. } Stop1Vel
  | gameStatus == Playing =
    if False then (model, Cmd.none) else
      ( model
        { player1Vel = dampX player1Vel
        }
      , Cmd.none
      )
  | otherwise = (model, Cmd.none)

update model@Model { .. } Stop2Vel
  | gameStatus == Playing =
    if False then (model, Cmd.none) else
      ( model
        { player2Vel = dampX player2Vel
        }
      , Cmd.none
      )
  | otherwise = (model, Cmd.none)

subscriptions :: Sub SDLEngine Action
subscriptions = Sub.batch
  [ Keyboard.downs $ \key -> (case key of
      Keyboard.AKey -> Player1Left
      Keyboard.DKey -> Player1Right
      Keyboard.WKey -> Player1Jump
      Keyboard.LeftKey -> Player2Left
      Keyboard.RightKey -> Player2Right
      Keyboard.UpKey -> Player2Jump
      Keyboard.SpaceKey -> BeginGame
      Keyboard.RKey -> ResetGame
      _ -> Idle)
  , Keyboard.ups $ \key -> (case key of
      Keyboard.AKey -> Stop1Vel
      Keyboard.DKey -> Stop1Vel
      Keyboard.LeftKey -> Stop2Vel
      Keyboard.RightKey -> Stop2Vel
      _ -> Idle)
  , Time.fps 600 Animate
  ]

playingOverlay :: Color -> Model -> Form SDLEngine
playingOverlay color Model { .. } =
  group $
    [
      move (V2 (screenWidth / 2) 25) $ text $ Text.height 30 $
                                         Text.color color $
                                         Text.toText score
    ] ++
    (if gameStatus == Waiting then [centerNotice "Press Spacebar to resume", centerNotice "\n\nPress R to reset score"] else [])

  where
    score = printf "%d:%d" player1Score player2Score
    centerNotice msg = move (V2 (screenWidth / 2) 60) $ text $
                       Text.height 16 $ Text.color color $ Text.toText msg

view :: Model -> Graphics SDLEngine
view  model@Model { .. } =
  Graphics2D $ collage [backdrop, ground, player1, player2, ball, net, overlay model]
  where
    backdrop = move (V2 (screenWidth/2) (screenHeight/2)) $ filled (rgb 0.85 0.85 1.0) $ rect (V2 screenWidth screenHeight)
    ground = move (V2 (screenWidth/2) (screenHeight + (groundHeight/2))) $ filled (rgb 0.05 1.0 0.05) $ rect (V2 screenWidth groundHeight)
    player1 = move player1Pos $ filled (rgb 0.95 0.05 0.05) $ circle playerRadius
    player2 = move player2Pos $ filled (rgb 0.05 0.05 0.95) $ circle playerRadius
    ball = move ballPos $ filled (rgb 0.95 0.05 0.95) $ circle ballRadius
    net = move (V2 (screenWidth/2) (screenHeight - (netHeight/2))) $ filled (rgb 0.2 0.2 0.2) $ rect (V2 netWidth netHeight)
    overlay model = playingOverlay (rgb 1 1 1) model

main :: IO ()
main = do
  engine <- SDL.startup

  run engine GameConfig
    { initialFn       = initial
    , updateFn        = update
    , subscriptionsFn = subscriptions
    , viewFn          = view
    }

max_stars_repo_name: AdiGajbhiye/volleyball

max_issues_repo_name: AdiGajbhiye/volleyball

max_forks_repo_name: AdiGajbhiye/volleyball