text:
{-# LANGUAGE ScopedTypeVariables #-}

module Statistics.Distribution.Hypergeometric.GenVar.Test where

import Data.Word
import Data.Int

import Statistics.Distribution.Hypergeometric.GenVar

import System.Random.MWC (initialize, GenIO)

import Data.Vector (fromList)

import Test.QuickCheck
import Test.QuickCheck.All
import Test.QuickCheck.Monadic

import Distribution.TestSuite.QuickCheck

testArbitraryRandom :: (GenIO -> IO Bool) -> [Word32] -> Property
testArbitraryRandom f a = monadicIO $ do
  b <- run $ initialize (fromList a) >>= f
  assert b

tests :: IO [Test]
tests = return

  [ testGroup "identities"

    [ testGroup "small"

      [ testProperty "draw nil" $ \p -> testArbitraryRandom $ \g -> do
        let i = (getSmall . getPositive) p :: Int64
        v <- genVar (0, i, i) g
        return $ v == 0

      , testProperty "draw all" $ \p -> testArbitraryRandom $ \g -> do
        let i = (getSmall . getPositive) p :: Int64
        v <- genVar (i, i, i) g
        return $ v == i

      ]

    , testGroup "large"

      [ testProperty "draw nil" $ \p -> testArbitraryRandom $ \g -> do
        let i = (getLarge . getPositive) p :: Int64
        v <- genVar (0, i, i) g
        return $ v == 0

      , testProperty "draw all" $ \p -> testArbitraryRandom $ \g -> do
        let i = (getLarge . getPositive) p :: Int64
        v <- genVar (i, i, i) g
        return $ v == i

      ]

    ]

  ]

max_stars_repo_name: srijs/statistics-hypergeometric-gen

max_issues_repo_name: srijs/statistics-hypergeometric-gen

max_forks_repo_name: srijs/statistics-hypergeometric-gen


text:
{-# Language TypeApplications #-}
module PointSpec where

import Test.Hspec
import Test.QuickCheck hiding (scale)
import Test.Invariant
import Data.Complex
import Geometry
import Geometry.Testing

spec :: Spec
spec = describe "Point" $ do
    describe "Affinity" $ do
      it "1" $ property $ cmp `inverts` Point
      it "2" $ property $ Point `inverts` cmp
      it "3" $ property $ cmp `inverts` (Point . cmp)
      it "4" $ property $ (Point . cmp) `inverts` cmp

    describe "pointOn" $ do
      it "1" $ xy (pointOn (aCircle # scale 2) 0) ~= (2, 0)
      it "2" $ xy (pointOn (aCircle # scale 2) 0.5) ~= (-2, 0)
      it "3" $ property $ \(AnyCircle c) t -> c `isContaining` pointOn c t
      it "4" $ property $ \(AnyLine l) t -> l `isContaining` pointOn l t
      it "5" $ property $ \n t ->
        let p = regularPoly (3 + abs n)
        in p `isContaining` pointOn p t

    describe "aligned" $ do
      it "1" $ property $ \(AnyLine l) xs ->
        length xs > 1 ==> aligned (param l <$> xs)
      it "2" $ property $ \(Position a) (Position b) (Position c) ->
        (aligned [a,b,c] ==> isDegenerate (Triangle [a,b,c])) .&.
        (not (aligned [a,b,c]) ==> not (isDegenerate (Triangle [a,b,c])))

    describe "APoint" $ do
      it "1" $ property $ toPoint `inverts` (asPoint @XY)
      it "2" $ property $ toPoint `inverts` (asPoint @Cmp)
      it "3" $ property $ toPoint `inverts` (asPoint @(Maybe Point))

ext: hs

max_stars_repo_name: MethaHardworker/geometry

max_issues_repo_name: MethaHardworker/geometry

max_forks_repo_name: MethaHardworker/geometry


text:
module Definition
  ( LispVal(..)
  , SchemeNumber(..)
  , LispError(..)
  , SyntaxDef(..)

  , SVector
  , PtrName
  , PtrVal
  , VarName
  , VarBinding
  , Env
  , LFuncName
  , LFunction

  , Evaled
  , IOEvaled
  , EnvEvaled

  , LIOFunction
  , LEnvFunction

  , PatLispVal
  , TemplateLispVal
  , SyntaxRule
  ) where

import Control.Arrow
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Data.Array
import Data.Complex
import Data.IORef
import qualified Data.Map as M
import Data.Ratio
import System.IO
import Text.Parsec.Error

------- Type Synonyms ------

type SVector      = Array Int
type PtrName      = String
type VarName      = String
type VarBinding   = M.Map VarName LispVal
type Env          = IORef VarBinding
type PtrVal       = IORef LispVal
type Evaled       = Except LispError
type IOEvaled     = ExceptT LispError IO
type EnvEvaled    = ReaderT Env IOEvaled
type LFuncName    = String
type LFunction    = [LispVal] -> Evaled LispVal
type LIOFunction  = [LispVal] -> IOEvaled LispVal
type LEnvFunction = [LispVal] -> EnvEvaled LispVal

type PatLispVal      = LispVal
type TemplateLispVal = LispVal

-- TODO: Add pattern contains ellipsis flag per syntax rule
type SyntaxRule      = (PatLispVal, TemplateLispVal)

------- Type Definitions -------

data SyntaxDef = SyntaxDef {
  synClosure    :: Env           -- Environment of the syntax rule; TODO: unecessary?
, synLiterals   :: [String]      -- List of literal identifiers reserved in the rule
, synRules      :: [SyntaxRule]  -- Actual rule value
}

data LispVal = LAtom          String
             | LNumber        SchemeNumber
             | LString        String
             | LBool          Bool
             | LChar          Char

             | LList          [LispVal]
             | LDottedList    [LispVal] LispVal
             | LVector        (SVector LispVal)

             | LPointer       PtrVal
             | LPort          Handle

             | LPrimitiveFunc LFuncName LFunction

             -- Constructor for user defined functions
             | LLambdaFunc    { params  :: [String]     -- parameter names
                              , vararg  :: Maybe String -- variable name of the variable-length list of arguments
                              , body    :: [LispVal]    -- function body, a list of expressions
                              , closure :: Env          -- the environment which the function encloses over
                              }

             | LIOFunc        LFuncName LIOFunction
             | LEnvFunc       LFuncName LEnvFunction

             | LSyntax        SyntaxDef

data SchemeNumber = SInt      Integer
                  | SDouble   Double
                  | SRational Rational
                  | SComplex  (Complex Double)
  deriving Eq

data LispError = NumArgs        Int        [LispVal]
               | TypeMismatch   String     LispVal
               | ParserErr      ParseError
               | BadSpecialForm String     LispVal
               | NotFunction    String     String
               | UnboundVar     String     String
               | InvalidArgs    String     [LispVal]
               | ImmutableArg   String     LispVal
               | InvalidSyntax  String
               | Default        String

------- Instance Implementations -------

instance Show LispVal where
  show = showVal

instance Eq LispVal where
  (==) = equivalent

equivalent :: LispVal -> LispVal -> Bool
equivalent (LBool arg1)       (LBool arg2)       = arg1 == arg2
equivalent (LChar arg1)       (LChar arg2)       = arg1 == arg2
equivalent (LNumber arg1)     (LNumber arg2)     = arg1 == arg2
equivalent (LString arg1)     (LString arg2)     = arg1 == arg2
equivalent (LAtom arg1)       (LAtom arg2)       = arg1 == arg2

equivalent (LPointer p1)      (LPointer p2)      = p1 == p2
equivalent (LPort p1)         (LPort p2)         = p1 == p2

equivalent (LPrimitiveFunc name1 _) (LPrimitiveFunc name2 _)  = name1 == name2
equivalent (LIOFunc        name1 _) (LIOFunc        name2 _)  = name1 == name2
equivalent (LEnvFunc       name1 _) (LEnvFunc       name2 _)  = name1 == name2
equivalent (LLambdaFunc a b c d)    (LLambdaFunc a' b' c' d') =
  a == a' && b == b' && c == c' && d == d'

equivalent (LDottedList xs x) (LDottedList ys y) =
  equivalent x y && equivalent (LList xs) (LList ys)
equivalent (LList arg1)       (LList arg2)
    | length arg1 /= length arg2 = False
    | otherwise                  = all (uncurry equivalent) $ zip arg1 arg2

equivalent _ _                                   = False

showVal :: LispVal -> String
showVal (LString contents)      = "\"" ++ contents ++ "\""
showVal (LChar c)               = [c]
showVal (LAtom name)            = name
showVal (LNumber contents)      = show contents
showVal (LBool bool)            = showLBool bool
  where
    showLBool :: Bool -> String
    showLBool True  = "#t"
    showLBool False = "#f"

showVal (LList contents)        = "(" ++ unwordsList contents ++ ")"
showVal (LDottedList head tail) = "(" ++ unwordsList head ++ " . "
                                      ++ showVal tail     ++ ")"
showVal (LVector vec)           = "#(" ++ unwordsList (elems vec) ++ ")"

showVal (LPrimitiveFunc name _)             = "<procedure:" ++ name ++ ">"
showVal (LIOFunc name _)                    = "<procedure:" ++ name ++ ">"
showVal (LEnvFunc name _)                   = "<procedure:" ++ name ++ ">"
showVal (LLambdaFunc args varargs body env) =
  "(lambda (" ++ unwords (map show args)
              ++ (case varargs of
                    Nothing  -> ""
                    Just arg -> " . " ++ arg)
              ++ ") ...)"

showVal (LPort _)    = "<IO port>"
showVal (LPointer _) = error "TODO: Trying to show pointer value!"
showVal (LSyntax _)  = error "TODO: Trying to show syntax!"

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

instance Show SchemeNumber where
  show (SInt a)      = show a
  show (SDouble a)   = show a
  show (SRational a) = show (numerator a) ++ " / " ++ show (denominator a)
  show (SComplex a)  = show (realPart a)  ++ " + " ++ show (imagPart a) ++ "i"

instance Num SchemeNumber where
  (+)         = addSNum
  (*)         = mulSNum
  abs         = absSNum
  signum      = signSNum
  fromInteger = SInt
  negate      = negSNum

addSNum :: SchemeNumber -> SchemeNumber -> SchemeNumber
addSNum (SInt a) (SInt b)      = SInt      $ a + b
addSNum (SInt a) (SDouble b)   = SDouble   $ fromIntegral a + b
addSNum (SInt a) (SRational b) = SRational $ fromIntegral a + b
addSNum (SInt a) (SComplex b)  = SComplex  $ fromIntegral a + b

addSNum (SDouble a) (SInt b)      = SDouble   $ a + fromIntegral b
addSNum (SDouble a) (SDouble b)   = SDouble   $ a + b
addSNum (SDouble a) (SRational b) = SRational $ fromIntegral (truncate a) + b
addSNum (SDouble a) (SComplex b)  = SComplex  $ (a :+ 0) + b

addSNum (SRational a) (SInt b)      = SRational $ a + fromIntegral b
addSNum (SRational a) (SDouble b)   = SRational $ a + fromIntegral (truncate b)
addSNum (SRational a) (SRational b) = SRational $ a + b
addSNum (SRational a) (SComplex b)  = SComplex  $ calcRatioComplex (+) a b

addSNum (SComplex a) (SInt b)      = SComplex $ a + fromIntegral b
addSNum (SComplex a) (SDouble b)   = SComplex $ a + fromIntegral (truncate b)
addSNum (SComplex a) (SRational b) = SComplex $ calcRatioComplex (+) b a
addSNum (SComplex a) (SComplex b)  = SComplex $ a + b

mulSNum :: SchemeNumber -> SchemeNumber -> SchemeNumber
mulSNum (SInt a) (SInt b)      = SInt      $ a * b
mulSNum (SInt a) (SDouble b)   = SDouble   $ fromIntegral a * b
mulSNum (SInt a) (SRational b) = SRational $ fromIntegral a * b
mulSNum (SInt a) (SComplex b)  = SComplex  $ fromIntegral a * b

mulSNum (SDouble a) (SInt b)      = SDouble   $ a * fromIntegral b
mulSNum (SDouble a) (SDouble b)   = SDouble   $ a * b
mulSNum (SDouble a) (SRational b) = SRational $ fromIntegral (truncate a) * b
mulSNum (SDouble a) (SComplex b)  = SComplex  $ (a :+ 0) * b

mulSNum (SRational a) (SInt b)      = SRational $ a * fromIntegral b
mulSNum (SRational a) (SDouble b)   = SRational $ a * fromIntegral (truncate b)
mulSNum (SRational a) (SRational b) = SRational $ a * b
mulSNum (SRational a) (SComplex b)  = SComplex  $ calcRatioComplex (*) a b

mulSNum (SComplex a) (SInt b)      = SComplex $ a * fromIntegral b
mulSNum (SComplex a) (SDouble b)   = SComplex $ a * fromIntegral (truncate b)
mulSNum (SComplex a) (SRational b) = SComplex $ calcRatioComplex (*) b a
mulSNum (SComplex a) (SComplex b)  = SComplex $ a * b

calcRatioComplex :: Num a
                 => (a -> a -> a)
                 -> Rational
                 -> Complex Double
                 -> Complex Double
calcRatioComplex op ratio complex =
  let fracDbl = rationalToDouble ratio
      rPart   = realPart complex
      iPart   = imagPart complex
  in  rPart * fracDbl :+ iPart * fracDbl

rationalToDouble :: Rational -> Double
rationalToDouble = fromRational

signSNum :: SchemeNumber -> SchemeNumber
signSNum (SComplex a)  = SInt . getSign $ realPart a
signSNum (SInt a)      = SInt $ getSign a
signSNum (SDouble a)   = SInt $ getSign a
signSNum (SRational a) = SInt $ getSign a

getSign :: (Num a, Ord a) => a -> Integer
getSign x
  | x > 0 = 1
  | x < 0 = -1
  | otherwise = 0

absSNum :: SchemeNumber -> SchemeNumber
absSNum (SInt a)      = SInt $ abs a
absSNum (SDouble a)   = SDouble $ abs a
absSNum (SRational a) = SRational $ abs a
absSNum (SComplex a)  = SComplex $ abs a

negSNum :: SchemeNumber -> SchemeNumber
negSNum (SInt a)      = SInt $ negate a
negSNum (SDouble a)   = SDouble $ negate a
negSNum (SRational a) = SRational $ negate a
negSNum (SComplex a)  = SComplex $ negate a

instance Enum SchemeNumber where
  toEnum = SInt . fromIntegral

  fromEnum (SInt a)      = fromIntegral a
  fromEnum (SDouble a)   = truncate a
  fromEnum (SRational a) = truncate a
  fromEnum (SComplex a)  = truncate $ realPart a

instance Real SchemeNumber where
  toRational (SInt a)      = toRational a
  toRational (SDouble a)   = toRational a
  toRational (SRational a) = a
  toRational (SComplex a)  = toRational (realPart a)

instance Ord SchemeNumber where
  compare = cmpSNum

cmpSNum :: SchemeNumber -> SchemeNumber -> Ordering
cmpSNum (SInt a) (SInt b)      = a              `compare` b
cmpSNum (SInt a) (SDouble b)   = fromIntegral a `compare` b
cmpSNum (SInt a) (SRational b) = toRational a   `compare` b
cmpSNum (SInt a) (SComplex b)  = fromIntegral a `compare` realPart b

cmpSNum (SDouble a) (SInt b)      = a            `compare` fromIntegral b
cmpSNum (SDouble a) (SDouble b)   = a            `compare` b
cmpSNum (SDouble a) (SRational b) = toRational a `compare` b
cmpSNum (SDouble a) (SComplex b)  = a            `compare` realPart b

cmpSNum (SRational a) (SInt b)      = a `compare` fromIntegral b
cmpSNum (SRational a) (SDouble b)   = a `compare` toRational b
cmpSNum (SRational a) (SRational b) = a `compare` b
cmpSNum (SRational a) (SComplex b)  = a `compare` toRational (realPart b)

cmpSNum (SComplex a) (SInt b)      = realPart a `compare` fromIntegral b
cmpSNum (SComplex a) (SDouble b)   = realPart a `compare` b
cmpSNum (SComplex a) (SRational b) = toRational (realPart a) `compare` b
cmpSNum (SComplex a) (SComplex b)  = realPart a `compare` realPart b

instance Integral SchemeNumber where
  quotRem = quotRemSNum

  toInteger (SInt a)      = a
  toInteger (SDouble a)   = truncate a
  toInteger (SRational a) = truncate a
  toInteger (SComplex a)  = truncate $ realPart a

quotRemSNum :: SchemeNumber -> SchemeNumber -> (SchemeNumber, SchemeNumber)
quotRemSNum = curry
  $ (toInteger *** toInteger)
  >>> uncurry quotRem
  >>> (SInt *** SInt)

instance Fractional SchemeNumber where
  fromRational = SRational
  (/)          = fracDivSNum

fracDivSNum :: SchemeNumber -> SchemeNumber -> SchemeNumber
fracDivSNum (SInt a) (SInt b)      = SDouble   $ fromIntegral a / fromIntegral b
fracDivSNum (SInt a) (SDouble b)   = SDouble   $ fromIntegral a / b
fracDivSNum (SInt a) (SRational b) = SRational $ fromIntegral a / b
fracDivSNum (SInt a) (SComplex b)  = SComplex  $ fromIntegral a / b

fracDivSNum (SDouble a) (SInt b)      = SDouble   $ a / fromIntegral b
fracDivSNum (SDouble a) (SDouble b)   = SDouble   $ a / b
fracDivSNum (SDouble a) (SRational b) = SRational $ toRational a / b
fracDivSNum (SDouble a) (SComplex b)  = SComplex  $ (a :+ 0) / b

fracDivSNum (SRational a) (SInt b)      = SRational $ a / fromIntegral b
fracDivSNum (SRational a) (SDouble b)   = SRational $ a / toRational b
fracDivSNum (SRational a) (SRational b) = SRational $ a / b
fracDivSNum (SRational a) (SComplex b)  = SComplex  $ fromRational a / b

fracDivSNum (SComplex a) (SInt b)      = SComplex $ a / fromIntegral b
fracDivSNum (SComplex a) (SDouble b)   = SComplex $ a / (b :+ 0)
fracDivSNum (SComplex a) (SRational b) = SComplex $ a / fromRational b
fracDivSNum (SComplex a) (SComplex b)  = SComplex $ a / b

instance Show LispError where
  show = showError

showError :: LispError -> String
showError (UnboundVar     message  varname) = message ++ ": " ++ varname
showError (BadSpecialForm message  form)    = message ++ ": " ++ show form
showError (NotFunction    message  func)    = message ++ ": " ++ show func
showError (NumArgs        expected found)   =
  "Expected " ++ show expected ++ " args: found values [" ++ unwordsList found ++ "]"
showError (TypeMismatch   expected found)   =
  "Invalid type: expected " ++ expected ++ ", found " ++ show found
showError (ParserErr      parseErr)         =
  "Parse error at " ++ show parseErr
showError (InvalidArgs    message  args)    = message ++ ", got: " ++ show args
showError (ImmutableArg   message  arg)     = message ++ ", got constant: " ++ show arg
showError (InvalidSyntax  synId)            = "Cannot use syntax keyword as expression: " ++ synId
showError (Default        message)          = "Error: " ++ message

max_stars_repo_name: comraq/scheme-interpreter

max_issues_repo_name: comraq/scheme-interpreter

max_forks_repo_name: comraq/scheme-interpreter


text:
module RotationPath where

import Control.Monad.Writer (Writer)
import qualified Control.Monad.Writer as Writer
import Data.DList (DList)
import qualified Data.DList as DList
import Numeric.LinearAlgebra ((<>))

import Cube (Cube)
import qualified Cube as Cube
import Rotation (MatrixRotation)
import qualified Rotation as Rotation

type RotationPath a = Writer (DList MatrixRotation) a
type CubeMutation = Cube -> RotationPath Cube

rotate :: MatrixRotation -> CubeMutation
rotate rotation cube = do
  let cube' = Rotation.toCubeRotation (Rotation.toVectorRotation rotation) cube
  Writer.tell $ DList.singleton rotation
  return cube'

between :: MatrixRotation -> MatrixRotation -> CubeMutation -> CubeMutation
between prefix suffix λ cube = do
  let (cube', rotationLog) = Writer.runWriter . λ $ Rotation.rotate prefix cube
  Writer.tell $ DList.map (\r -> suffix <> r <> prefix) rotationLog
  return $ Rotation.rotate suffix cube'

rotations :: [MatrixRotation] -> CubeMutation
rotations [] cube = return cube
rotations (r:rs) cube = rotate r cube >>= rotations rs

max_stars_repo_name: runjak/hRubiks

max_issues_repo_name: runjak/hRubiks

max_forks_repo_name: runjak/hRubiks


text:
{-# LANGUAGE ScopedTypeVariables #-}
--
{-# OPTIONS_GHC -fno-warn-orphans #-}
import Data.Monoid
import Data.Typeable
import Numeric.Sum
import Test.Tasty
import Test.Tasty.QuickCheck

import Statistics.Monoid
import Statistics.Monoid.Extra

data T a = T

p_memptyIsNeutral
  :: forall m. (Monoid m, Arbitrary m, Show m, Eq m)
  => T m -> TestTree
p_memptyIsNeutral _
  = testProperty "mempty is neutral" $ \(m :: m) ->
       (m <> mempty) == m
    && (mempty <> m) == m

p_associativity
  :: forall m. (Monoid m, Arbitrary m, Show m, Eq m)
  => T m -> TestTree
p_associativity _
  = testProperty "associativity" $ \(a :: m) b c ->
    let val1 = (a <> b) <> c
        val2 = a <> (b <> c)
    in counterexample ("left : " ++ show val1)
     $ counterexample ("right: " ++ show val2)
     $ val1 == val2

p_commutativity
  :: forall m. (Monoid m, Arbitrary m, Show m, Eq m)
  => T m -> TestTree
p_commutativity _
  = testProperty "commutativity" $ \(a :: m) b ->
    (a <> b) == (b <> a)

p_addValue1
  :: forall a m. ( StatMonoid m a
                 , Arbitrary m, Show m, Eq m
                 , Arbitrary a, Show a, Eq a)
  => T a -> T m -> TestTree
p_addValue1 _ _
  = testProperty "addValue x mempty == singletonMonoid" $ \(a :: a) ->
    singletonMonoid a == addValue (mempty :: m) a

p_addValue2
  :: forall a m. ( StatMonoid m a
                 , Arbitrary m, Show m, Eq m
                 , Arbitrary a, Show a, Eq a)
  => T a -> T m -> TestTree
p_addValue2 _ _
  = testProperty "addValue law" $ \(x :: a) (y :: a) ->
    let val1 = addValue (addValue mempty y) x
        val2 = (addValue mempty x <> addValue (mempty :: m) y)
    in counterexample ("left : " ++ show val1)
     $ counterexample ("right: " ++ show val2)
     $ val1 == val2

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

testType :: forall m. Typeable m => T m -> [T m -> TestTree] -> TestTree
testType t props = testGroup (show (typeOf (undefined :: m)))
                             (fmap ($ t) props)

main :: IO ()
main = defaultMain $ testGroup "monoid-statistics"
  [ testType (T :: T (CountG Int))
      [ p_memptyIsNeutral
      , p_associativity
      , p_commutativity
      , p_addValue1 (T :: T Int)
      , p_addValue2 (T :: T Int)
      ]
  , testType (T :: T (Min Int))
      [ p_memptyIsNeutral
      , p_associativity
      , p_commutativity
      , p_addValue1 (T :: T Int)
      , p_addValue2 (T :: T Int)
      ]
  , testType (T :: T (Max Int))
      [ p_memptyIsNeutral
      , p_associativity
      , p_commutativity
      , p_addValue1 (T :: T Int)
      , p_addValue2 (T :: T Int)
      ]
  , testType (T :: T MinD)
      [ p_memptyIsNeutral
      , p_associativity
      , p_commutativity
      , p_addValue1 (T :: T Double)
      , p_addValue2 (T :: T Double)
      ]
  , testType (T :: T MaxD)
      [ p_memptyIsNeutral
      , p_associativity
      , p_commutativity
      , p_addValue1 (T :: T Double)
      , p_addValue2 (T :: T Double)
      ]
  , testType (T :: T BinomAcc)
      [ p_memptyIsNeutral
      , p_associativity
      , p_commutativity
      , p_addValue1 (T :: T Bool)
      , p_addValue2 (T :: T Bool)
      ]
  , testType (T :: T WelfordMean)
      [ p_memptyIsNeutral
      -- , p_associativity
      , p_commutativity
      , p_addValue1 (T :: T Double)
      -- , p_addValue2 (T :: T Double)
      ]
  , testType (T :: T MeanKBN)
      [ p_memptyIsNeutral
      -- , p_associativity
      -- , p_commutativity
      , p_addValue1 (T :: T Double)
      , p_addValue2 (T :: T Double)
      ]
  , testType (T :: T MeanKahan)
      [ p_memptyIsNeutral
      -- , p_associativity
      -- , p_commutativity
      , p_addValue1 (T :: T Double)
      -- , p_addValue2 (T :: T Double)
      ]
  , testType (T :: T Variance)
      [ p_memptyIsNeutral
      -- , p_associativity
      , p_commutativity
      , p_addValue1 (T :: T Double)
      , p_addValue2 (T :: T Double)
      ]
  ]

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

instance (Arbitrary a, Num a, Ord a) => Arbitrary (CountG a) where
  arbitrary = do
    NonNegative n <- arbitrary
    return (CountG n)

instance (Arbitrary a) => Arbitrary (Max a) where
  arbitrary = fmap Max arbitrary

instance (Arbitrary a) => Arbitrary (Min a) where
  arbitrary = fmap Min arbitrary

instance Arbitrary MinD where
  arbitrary = frequency [ (1, return mempty)
                        , (4, fmap MinD arbitrary)
                        ]

instance Arbitrary MaxD where
  arbitrary = frequency [ (1, return mempty)
                        , (4, fmap MaxD arbitrary)
                        ]

instance Arbitrary BinomAcc where
  arbitrary = do
    NonNegative nSucc <- arbitrary
    NonNegative nFail <- arbitrary
    return $ BinomAcc nSucc (nFail + nSucc)

instance Arbitrary WelfordMean where
  arbitrary = arbitrary >>= \x -> case x of
    NonNegative 0 -> return mempty
    NonNegative n -> do m <- arbitrary
                        return (WelfordMean n m)

instance Arbitrary Variance where
  arbitrary = arbitrary >>= \x -> case x of
    NonNegative 0 -> return mempty
    NonNegative n -> do
      m             <- arbitrary
      NonNegative s <- arbitrary
      return $ Variance n m s

instance Arbitrary MeanKBN where
  arbitrary = arbitrary >>= \x -> case x of
    NonNegative 0 -> return mempty
    NonNegative n -> do
      x1 <- arbitrary
      x2 <- arbitrary
      x3 <- arbitrary
      return $ MeanKBN n (((zero `add` x1) `add` x2) `add` x3)

instance Arbitrary MeanKahan where
  arbitrary = arbitrary >>= \x -> case x of
    NonNegative 0 -> return mempty
    NonNegative n -> do
      x1 <- arbitrary
      x2 <- arbitrary
      x3 <- arbitrary
      return $ MeanKahan n (((zero `add` x1) `add` x2) `add` x3)


text:
-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Plot.Render.Text
-- Copyright   :  (c) A. V. H. McPhail 2010
-- License     :  BSD3
--
-- Maintainer  :  haskell.vivian.mcphail <at> gmail <dot> com
-- Stability   :  provisional
-- Portability :  portable
--
-- Rendering 'Figure's
--
-----------------------------------------------------------------------------

module Graphics.Rendering.Plot.Render.Text (
                                       -- * Rendering
                                       renderText
                                       , renderTextVertical
                                       -- * Internal
                                       , textSize
                                       , textSizeVertical
                                       , showText
                                       , formatText
                                       ) where

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

--import Data.Either

--import Data.Packed.Vector
--import Numeric.LinearAlgebra.Linear

--import Data.Word

--import Data.Maybe

--import Data.Colour.SRGB
--import Data.Colour.Names

---import qualified Data.Array.IArray as A

import qualified Graphics.Rendering.Cairo as C
import qualified Graphics.Rendering.Pango as P

import Control.Monad.Reader
--import Control.Monad.State
--import Control.Monad.Trans

import Graphics.Rendering.Plot.Types
--import Graphics.Rendering.Plot.Defaults

import Graphics.Rendering.Plot.Figure.Text

import Graphics.Rendering.Plot.Render.Types

--import qualified Text.Printf as Printf

--import Prelude hiding(min,max)
--import qualified Prelude(max)

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

textSize :: P.PangoLayout -> TextXAlign -> TextYAlign -> Double -> Double -> C.Render ((Double,Double),(Double,Double))
textSize l xa ya x y = do
                       (_,P.PangoRectangle _ _ w h) <- pango $ P.layoutGetExtents l
                       return ((xStart xa x w h,yStart ya y w h),(w,h))
    where xStart TLeft   x' w' _  = x' - w'
          xStart Centre  x' w' _  = x' - (w'/2)
          xStart TRight  x' _  _  = x'
          yStart TBottom y' _  h' = y' - h'
          yStart Middle  y' _  h' = y' - (h'/2)
          yStart TTop    y' _  _  = y'

textSizeVertical :: P.PangoLayout -> TextXAlign -> TextYAlign -> Double -> Double -> C.Render ((Double,Double),(Double,Double))
textSizeVertical l xa ya x y = do
                       (_,P.PangoRectangle _ _ w h) <- pango $ P.layoutGetExtents l
                       return ((xStart xa x w h,yStart ya y w h),(w,h))
    where xStart TLeft   x' _  w' = x' - w'
          xStart Centre  x' _  w' = x' - (w'/2)
          xStart TRight  x' _  _  = x'
          yStart TBottom y' _  _  = y'
          yStart Middle  y' h' _  = y' + (h'/2)
          yStart TTop    y' h' _  = y' + (h')

showText :: P.PangoLayout -> Double -> Double -> C.Render ()
showText pl x y = do
                  C.moveTo x y
                  P.showLayout pl

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

formatText :: TextEntry -> Render TextEntry
formatText te@NoText          = return te
formatText (BareText s)       = do
                                to <- asks (_textoptions . _renderoptions)
                                return (FontText to s)
formatText (SizeText fz c s)  = do
                                to <- asks (_textoptions . _renderoptions)
                                return $ (FontText (changeFontSize fz $ changeFontColour c to) s)
formatText te@(FontText _ _)  = return te

{-
getTextSize :: Text -> Render (Double,Double)
getTextSize (Text Nothing s) = do
                               to <- asks _text
                               getTextSize (Text to s)
getTextSize (Text (Just (TextOptions (FontOptions ff fs fw) fz _)) s) = cairo $ do
                               C.selectFontFace ff fs fw
                               C.setFontSize fz
                               te <- C.textExtents s
                               return (C.textExtentsWidth te,C.textExtentsHeight te)
-}
renderText :: TextEntry -> TextXAlign -> TextYAlign -> Double -> Double -> Render (Double,Double)
renderText NoText              _  _  _ _ = return (0,0)
renderText te@(BareText _)     xa ya x y = do
                                           te' <- formatText te
                                           renderText te' xa ya x y
renderText te@(SizeText _ _ _) xa ya x y = do
                                           te' <- formatText te
                                           renderText te' xa ya x y
renderText (FontText to s)     xa ya x y = do
                                           pc <- asks _pangocontext
                                           cairo $ do
                                                   lo <- pango $ P.layoutText pc s
                                                   setTextOptions to lo
                                                   ((x',y'),twh) <- textSize lo xa ya x y
                                                   showText lo x' y'
                                                   return twh

renderTextVertical :: TextEntry -> TextXAlign -> TextYAlign -> Double -> Double -> Render (Double,Double)
renderTextVertical NoText              _  _  _ _ = return (0,0)
renderTextVertical te@(BareText _)     xa ya x y = do
                                                 te' <- formatText te
                                                 renderTextVertical te' xa ya x y
renderTextVertical te@(SizeText _ _ _) xa ya x y = do
                                                   te' <- formatText te
                                                   renderTextVertical te' xa ya x y
renderTextVertical (FontText to s)     xa ya x y = do
                                                   pc <- asks _pangocontext
                                                   cairo $ do
                                                           lo <- pango $ P.layoutText pc s
                                                           setTextOptions to lo
                                                           C.save
                                                           C.rotate (-pi/2)
                                                           P.updateLayout lo
                                                           ((x',y'),twh) <- textSizeVertical lo xa ya x y
                                                           showText lo (-y') (x')
                                                           C.restore
                                                           return twh

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

max_stars_repo_name: JackTheEngineer/plot


text:
#!/usr/bin/env stack
-- stack runghc --package reanimate
{-# LANGUAGE OverloadedStrings #-}
module Main where

import           Codec.Picture.Types
import           Control.Lens                  ()
import           Control.Monad
import           Data.Function
import           Data.List
import           Data.List.NonEmpty            (NonEmpty)
import qualified Data.List.NonEmpty            as NE
import           Data.Maybe
import           Data.Ratio
import qualified Data.Text                     as T
import           Data.Tuple
import qualified Data.Vector                   as V
import           Debug.Trace
import           Linear.Matrix                 hiding (trace)
import           Linear.Metric
import           Linear.V2
import           Linear.V3
import           Linear.Vector
import           Numeric.LinearAlgebra         hiding (polar, scale, (<>))
import qualified Numeric.LinearAlgebra         as Matrix
import           Numeric.LinearAlgebra.HMatrix hiding (polar, scale, (<>))
import           Reanimate
import           Reanimate.Animation
import           Reanimate.Math.Balloon
import           Reanimate.Math.Common
import           Reanimate.Math.Triangulate
import           Reanimate.Math.Polygon
import           Reanimate.Math.EarClip
import           Reanimate.Math.SSSP
import           Reanimate.Math.Render
import           Reanimate.Math.Visibility
import           Reanimate.Math.Compatible
import           Reanimate.Morph.Common
import           Reanimate.PolyShape           (svgToPolygons)

p :: Polygon
p = mkPolygon $ V.fromList [V2 (0 % 1) (0 % 1),V2 (1 % 1) (0 % 1),V2 (1 % 1) (1 % 1),V2 (2 % 1) (1 % 1),V2 (2 % 1) ((-1) % 1),V2 (3 % 1) ((-1) % 1),V2 (3 % 1) (2 % 1),V2 (0 % 1) (2 % 1)]

pCuts' :: Polygon -> [(Int,Int)]
pCuts' p =
  [ (i, j)
  | i <- [0 .. pSize p-1 ]
  , j <- [i+2 .. pSize p-1 ]
  , (j+1) `mod` pSize p /= i
  , trace ("Check: " ++ show (i,j, pSize p)) $ pParent p i j == i ]

-- p :: Polygon
-- p = pScale 6 $ unsafeSVGToPolygon 0.1 $
--   lowerTransformations $ pathify $ center $ latex "$1$"

main :: IO ()
main = reanimate $ sceneAnimation $ do
  bg <- newSpriteSVG $ mkBackground "black"
  spriteZ bg (-1)
  newSpriteSVG_ $ translate 0 1 $ mkGroup
    [ withFillColor "grey" $ polygonShape p
    , polygonNumDots p
    ]
  forM_ (pCuts p) $ \(l,r) -> do
    play $ mkAnimation (1/60) $ \_ -> mkGroup
      [ translate (-3) 0 $ withFillColor "grey" $ polygonShape l
      , translate (-3) 0 $ polygonNumDots l
      , translate (3) 0 $ withFillColor "grey" $ polygonShape r
      , translate (3) 0 $ polygonNumDots r
      ]
  -- wait 1
  -- fork $ play $ drawTriangulation shape1 earCut'
  --   # mapA (translate (-3) 0)
  -- play $ drawTriangulation shape1 earClip'
  --   # mapA (translate (3) 0)
  return ()

max_stars_repo_name: sureyeaah/reanimate

max_issues_repo_name: sureyeaah/reanimate

max_forks_repo_name: sureyeaah/reanimate


text:
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Orphan instances for common data types
module Tests.Orphanage where

import Control.Applicative
import Statistics.Distribution.Beta            (BetaDistribution, betaDistr)
import Statistics.Distribution.Binomial        (BinomialDistribution, binomial)
import Statistics.Distribution.CauchyLorentz
import Statistics.Distribution.ChiSquared      (ChiSquared, chiSquared)
import Statistics.Distribution.Exponential     (ExponentialDistribution, exponential)
import Statistics.Distribution.FDistribution   (FDistribution, fDistribution)
import Statistics.Distribution.Gamma           (GammaDistribution, gammaDistr)
import Statistics.Distribution.Geometric
import Statistics.Distribution.Hypergeometric
import Statistics.Distribution.Laplace         (LaplaceDistribution, laplace)
import Statistics.Distribution.Lognormal       (LognormalDistribution, lognormalDistr)
import Statistics.Distribution.Normal          (NormalDistribution, normalDistr)
import Statistics.Distribution.Poisson         (PoissonDistribution, poisson)
import Statistics.Distribution.StudentT
import Statistics.Distribution.Transform       (LinearTransform, scaleAround)
import Statistics.Distribution.Uniform         (UniformDistribution, uniformDistr)
import Statistics.Distribution.Weibull         (WeibullDistribution, weibullDistr)
import Statistics.Distribution.DiscreteUniform (DiscreteUniform, discreteUniformAB)
import Statistics.Types

import Test.QuickCheck         as QC

----------------------------------------------------------------
-- Arbitrary instances for ditributions
----------------------------------------------------------------

instance QC.Arbitrary BinomialDistribution where
  arbitrary = binomial <$> QC.choose (1,100) <*> QC.choose (0,1)
instance QC.Arbitrary ExponentialDistribution where
  arbitrary = exponential <$> QC.choose (0,100)
instance QC.Arbitrary LaplaceDistribution where
  arbitrary = laplace <$> QC.choose (-10,10) <*> QC.choose (0, 2)
instance QC.Arbitrary GammaDistribution where
  arbitrary = gammaDistr <$> QC.choose (0.1,10) <*> QC.choose (0.1,10)
instance QC.Arbitrary BetaDistribution where
  arbitrary = betaDistr <$> QC.choose (1e-3,10) <*> QC.choose (1e-3,10)
instance QC.Arbitrary GeometricDistribution where
  arbitrary = geometric <$> QC.choose (0,1)
instance QC.Arbitrary GeometricDistribution0 where
  arbitrary = geometric0 <$> QC.choose (0,1)
instance QC.Arbitrary HypergeometricDistribution where
  arbitrary = do l <- QC.choose (1,20)
                 m <- QC.choose (0,l)
                 k <- QC.choose (1,l)
                 return $ hypergeometric m l k
instance QC.Arbitrary LognormalDistribution where
  -- can't choose sigma too big, otherwise goes outside of double-float limit
  arbitrary = lognormalDistr <$> QC.choose (-100,100) <*> QC.choose (1e-10, 20)
instance QC.Arbitrary NormalDistribution where
  arbitrary = normalDistr <$> QC.choose (-100,100) <*> QC.choose (1e-3, 1e3)
instance QC.Arbitrary PoissonDistribution where
  arbitrary = poisson <$> QC.choose (0,1)
instance QC.Arbitrary ChiSquared where
  arbitrary = chiSquared <$> QC.choose (1,100)
instance QC.Arbitrary UniformDistribution where
  arbitrary = do a <- QC.arbitrary
                 b <- QC.arbitrary `suchThat` (/= a)
                 return $ uniformDistr a b
instance QC.Arbitrary WeibullDistribution where
  arbitrary = weibullDistr <$> QC.choose (1e-3,1e3) <*> QC.choose (1e-3, 1e3)
instance QC.Arbitrary CauchyDistribution where
  arbitrary = cauchyDistribution
                <$> arbitrary
                <*> ((abs <$> arbitrary) `suchThat` (> 0))
instance QC.Arbitrary StudentT where
  arbitrary = studentT <$> ((abs <$> arbitrary) `suchThat` (>0))
instance QC.Arbitrary d => QC.Arbitrary (LinearTransform d) where
  arbitrary = do
    m <- QC.choose (-10,10)
    s <- QC.choose (1e-1,1e1)
    d <- arbitrary
    return $ scaleAround m s d
instance QC.Arbitrary FDistribution where
  arbitrary =  fDistribution
           <$> ((abs <$> arbitrary) `suchThat` (>0))
           <*> ((abs <$> arbitrary) `suchThat` (>0))

instance (Arbitrary a, Ord a, RealFrac a) => Arbitrary (PValue a) where
  arbitrary = do
    (_::Int,x) <- properFraction <$> arbitrary
    return $ mkPValue $ abs x

instance (Arbitrary a, Ord a, RealFrac a) => Arbitrary (CL a) where
  arbitrary = do
    (_::Int,x) <- properFraction <$> arbitrary
    return $ mkCLFromSignificance $ abs x

instance Arbitrary a => Arbitrary (NormalErr a) where
  arbitrary = NormalErr <$> arbitrary

instance Arbitrary a => Arbitrary (ConfInt a) where
  arbitrary = liftA3 ConfInt arbitrary arbitrary arbitrary

instance (Arbitrary (e a), Arbitrary a) => Arbitrary (Estimate e a) where
  arbitrary = liftA2 Estimate arbitrary arbitrary

instance (Arbitrary a) => Arbitrary (UpperLimit a) where
  arbitrary = liftA2 UpperLimit arbitrary arbitrary

instance (Arbitrary a) => Arbitrary (LowerLimit a) where
  arbitrary = liftA2 LowerLimit arbitrary arbitrary

instance QC.Arbitrary DiscreteUniform where
  arbitrary = discreteUniformAB <$> QC.choose (1,1000) <*> QC.choose(1,1000)


text:
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wall #-}

-- import FMeme.Funks
-- import Moo.GeneticAlgorithm

-- import Numeric.LinearAlgebra hiding (Range, append)

import Chart
-- import qualified Data.HashMap.Strict as HashMap

import Control.Category (id)
import Control.Lens
import qualified Data.Attoparsec.Text as A
import Data.Biapplicative
import Data.Scientific
import Data.Sv
import qualified Data.Sv.Decode as D
import Lucid hiding (b_)
import Network.JavaScript
import Network.Wai.Middleware.Static ((>->), addBase, noDots, staticPolicy)
import Numeric.Backprop
import Protolude hiding ((<<*>>), Meta, Rep, replace)
import System.IO.Unsafe (unsafePerformIO)
import Web.Page
import Web.Scotty
import qualified Data.Text as Text

data AB a = AB {alpha :: a, beta :: a} deriving (Eq, Show)

fromAB :: AB a -> [a]
fromAB (AB a b) = [a, b]

toAB :: [a] -> Maybe (AB a)
toAB (a : b : _) = Just (AB a b)
toAB _ = Nothing

repAB :: (Monad m) => Int -> AB Double -> AB (Range Double) -> SharedRep m (AB Double)
repAB steps (AB a0 b0) (AB (Range amin amax) (Range bmin bmax)) = do
  a' <- slider (Just "alpha") amin amax ((amax - amin) / fromIntegral steps) a0
  b' <- slider (Just "beta") bmin bmax ((amax - amin) / fromIntegral steps) b0
  pure $ AB a' b'

data Meta a = Meta {maxn :: Int, tol :: a, rate :: a} deriving (Eq, Show, Generic)

repMeta :: (Monad m) => Meta Double -> SharedRep m (Meta Double)
repMeta m = do
  n' <- sliderI (Just "max iterations") 1 10000 100 (m ^. #maxn)
  t' <- slider (Just "tolerance (t)") 0 0.1 0.001 (m ^. #tol)
  r' <- slider (Just "convergence rate (r)") 0 0.1 0.001 (m ^. #rate)
  pure $ Meta n' t' r'

ex1File :: FilePath
ex1File = "app/ex1data1.txt"

opts :: ParseOptions
opts = ParseOptions (fromIntegral $ fromEnum ' ') Unheaded

data Ex1Data = Ex1Data {v1 :: Double, v2 :: Double} deriving (Show, Eq)

toLR :: Ex1Data -> ([Double], Double)
toLR (Ex1Data x y) = ([x], y)

ex1Decoder :: Decode' ByteString Ex1Data
ex1Decoder = Ex1Data <$> D.double <*> D.double

ex1 :: IO [Ex1Data]
ex1 = do
  r <- parseDecodeFromFile ex1Decoder opts ex1File
  pure $ case r of
    Success xs -> xs
    Failure _ -> []

xy :: [([Double], Double)]
{-# NOINLINE xy #-}
xy = unsafePerformIO $ do
  ex1' <- ex1
  pure $ (\(Ex1Data x y) -> ([x], y)) <$> ex1'

repXY :: (Monad m) => [(Double, Double)] -> SharedRep m [Spot Double]
repXY d = do
  a <-
    dropdown
      A.takeText
      show
      (Just "type")
      [ "exercise 1"
      ]
      "exercise 1"
  pure
    ( case a of
        "exercise 1" -> uncurry SP <$> d
        _ -> uncurry SP <$> d
    )

abLine :: Range Double -> AB Double -> [Spot Double]
abLine (Range x0 x1) (AB a b) = [SP x0 (a + b * x0), SP x1 (a + b * x1)]

modelText :: AB Double -> Text
modelText (AB a b) =
  Text.pack $ "y = "
    <> formatScientific Exponent (Just 3) (fromFloatDigits a)
    <> " + "
    <> formatScientific Exponent (Just 3) (fromFloatDigits b)
    <> " * x"

midChart ::
  SharedRep IO Text ->
  Application ->
  Application
midChart sr = midShared sr initChartRender updateChart

initChartRender ::
  Engine ->
  Rep Text ->
  StateT (HashMap Text Text) IO ()
initChartRender e r =
  void $
    oneRep
      r
      ( \(Rep h fa) m -> do
          append e "input" (toText h)
          replace e "output" (either id id . snd $ fa m)
      )

updateChart :: Engine -> Either Text (HashMap Text Text, Either Text Text) -> IO ()
updateChart e (Left err) = append e "log" ("map error: " <> err)
updateChart e (Right (_, Left err)) = append e "log" ("parse error: " <> err)
updateChart e (Right (_, Right c)) = replace e "output" c

repMain ::
  (Monad m) =>
  ChartSvgStyle ->
  GlyphStyle ->
  HudConfig ->
  LineStyle ->
  LineStyle ->
  Meta Double ->
  [Ex1Data] ->
  SharedRep m Text
repMain cscfg gcfg hcfg lcfg gdcfg mcfg xs =
  bimap hmap mmap cs <<*>> gs <<*>> d <<*>> h <<*>> ls <<*>> ls2 <<*>> ab <<*>> meta
  where
    p0 = [0, 0]
    ab = repAB 100 (AB 0 0) (AB (Range -5 5) (Range -2 2))
    h = repHudConfigDefault hcfg
    cs = repChartSvgStyle cscfg
    gs = repGlyphStyle gcfg
    ls = repLineStyle lcfg
    ls2 = repLineStyle gdcfg
    meta = repMeta mcfg
    d = repXY ((\(Ex1Data x y) -> (x, y)) <$> xs)
    xrange = space1 $ v1 <$> xs :: Range Double
    mmap cs' gs' d' h' ls' ls2' ab' meta' =
      renderHudChartWith
        cs'
        h''
        [ Chart (GlyphA gs') d',
          Chart (LineA ls') (abLine xrange ab'),
          Chart (LineA ls2') (gdLine xrange gdp)
        ]
        <> renderChartSvg 400 400 (chartSvg (Rect -1.0 1.0 -1.0 1.0) (pixel'' (toLR <$> xs)))
      where
        gdp = linBatch meta' p0 (toLR <$> xs)
        h'' =
          h'
            & #hudTitles %~ (<> [modelTitle ab'] <> [gdTitle gdp])
    hmap cs' gs' d' h' ls' ls2' ab' meta' =
      accordion_
        "acca"
        (Just "Chart Configuration")
        [ ("Chart Svg Stylings", cs'),
          ( "Chart",
            accordion_
              "accb"
              Nothing
              [ ("Scatter Style", gs'),
                ("Line Style", ls'),
                ("GD Line Style", ls2'),
                ("Data", d')
              ]
          ),
          ("Chart Hud", h'),
          ("Meta", meta'),
          ("Model", ab')
        ]

svgStyle :: ChartSvgStyle
svgStyle =
  defaultChartSvgStyle
    & #sizex .~ 900
    & #sizey .~ 600
    & #chartAspect .~ 1.5
    & #outerPad .~ Nothing
    & #chartFrame .~ Nothing
    & #orig .~ Nothing

hudConfig :: HudConfig
hudConfig =
  defaultHudConfig
    & #hudCanvas .~ Nothing
    & #hudTitles
      .~ [ defaultTitle "Training Data",
           (defaultTitle "Profit in $10,0000s" :: Title Double)
             & #place .~ PlaceRight
             & #style . #size .~ 0.05,
           (defaultTitle "Population of City in 10,000s" :: Title Double)
             & #place .~ PlaceBottom
             & #style . #size .~ 0.05
         ]
    & #hudAxes
      .~ [ defaultAxisConfig
             & #abar .~ Just b,
           defaultAxisConfig
             & #abar .~ Just b'
             & #place .~ PlaceLeft
         ]
  where
    b =
      (defaultBar :: Bar Double)
        & #wid .~ (0.01 :: Double)
        & #buff .~ 0.01
        & #rstyle .~ rs
    b' =
      (defaultBar :: Bar Double)
        & #wid .~ (0.01 :: Double)
        & #buff .~ (0.01 :: Double)
        & #rstyle .~ rs
    rs = RectStyle 0 grey 0 (PixelRGB8 105 48 157) 0.5

glyphStyle :: GlyphStyle
glyphStyle =
  defaultGlyphStyle
    & #color .~ PixelRGB8 217 124 32
    & #borderOpacity .~ 1
    & #shape .~ SquareGlyph
    & #borderSize .~ 0.002

modelStyle :: LineStyle
modelStyle =
  defaultLineStyle
    & #color .~ PixelRGB8 173 33 23
    & #width .~ 0.005

gdStyle :: LineStyle
gdStyle =
  defaultLineStyle
    & #color .~ PixelRGB8 50 33 173
    & #width .~ 0.005

modelTitle :: AB Double -> Title Double
modelTitle ab =
  defaultTitle (modelText ab)
    & (#place .~ PlaceBottom :: Title Double -> Title Double)
    & #anchor .~ AnchorStart
    & #style . #color .~ PixelRGB8 173 33 23
    & #style . #size .~ 0.05

gdTitle :: Converge [Double] -> Title Double
gdTitle ab =
  defaultTitle (gdText ab)
    & #style . #color .~ PixelRGB8 50 33 173
    & #style . #size .~ 0.05
    & (#place .~ PlaceBottom :: Title Double -> Title Double)
    & #anchor .~ AnchorStart

gdLine :: Range Double -> Converge [Double] -> [Spot Double]
gdLine _ Nada = []
gdLine r (Unstable (x : y : _)) = abLine r (AB x y)
gdLine _ (Unstable _) = []
gdLine r (Convergent (x : y : _)) = abLine r (AB x y)
gdLine _ (Convergent _) = []
gdLine _ Divergent = []

gdText :: Converge [Double] -> Text
gdText Nada = "No Data"
gdText Divergent = "Divergent"
gdText (Unstable (x : y : _)) = modelText (AB x y) <> " (Unstable)"
gdText (Unstable _) = "Can't happen"
gdText (Convergent (x : y : _)) = modelText (AB x y) <> " (Converged)"
gdText (Convergent _) = "Can't happen"

testPage :: Text -> [(Text, Html ())] -> Page
testPage title' sections =
  bootstrapPage
    <> bridgePage
    & #htmlHeader .~ title_ "mlh charts"
    & #htmlBody
      .~ b_
        "container"
        ( mconcat
            [ b_ "row" (h1_ (toHtml title')),
              b_ "row" $ mconcat $ (\(t, h) -> b_ "col" (h2_ (toHtml t) <> with div_ [id_ t] h)) <$> sections
            ]
        )

main :: IO ()
main = do
  ex1' <- ex1
  scotty 3000 $ do
    middleware $ staticPolicy (noDots >-> addBase "other")
    middleware
      ( midChart
          ( repMain
              svgStyle
              glyphStyle
              hudConfig
              modelStyle
              gdStyle
              (Meta 1000 0.0001 0.01)
              ex1'
          )
      )
    servePageWith
      "/chart/ex1"
      defaultPageConfig
      ( testPage
          "exercise 1"
          [ ("input", mempty),
            ("output", mempty)
          ]
      )

-- backprop
type Model p a b = p -> a -> b

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

linReg :: ModelG [Double] [Double] Double
linReg bs xs = sum (zipWith (*) (sequenceVar bs) (auto 1 : sequenceVar xs))

sqerr :: (Backprop p, Backprop b, Num b) => ModelG p a b -> a -> b -> p -> p
sqerr f x targ = gradBP $ \p -> (f p (auto x) - auto targ) ^ (2 :: Int)

sqerrb :: (Backprop p, Backprop b, Num b) => ModelG p a b -> a -> b -> p -> (b, p)
sqerrb f x targ = backprop $ \p -> (f p (auto x) - auto targ) ^ (2 :: Int)

sqerre :: (Num b) => ModelG p a b -> a -> b -> p -> b
sqerre f x targ = evalBP $ \p -> (f p (auto x) - auto targ) ^ (2 :: Int)

sqerrs :: (Foldable f, Functor f, Backprop p, Backprop b, Num b, Floating p) => ModelG [p] [a] b -> f ([a], b) -> [p] -> [p]
sqerrs f xs p = (/ fromIntegral (length xs)) <$> foldl' (zipWith (+)) (repeat 0) ((\(x, targ) -> sqerr f x targ p) <$> xs)

sgd :: (Backprop b, Backprop p, Num b, Num p) => [p] -> ModelG [p] [a] b -> [p] -> [([a], b)] -> [p]
sgd r f = foldl' (\p (x, y) -> zipWith (-) p (zipWith (*) r (sqerr f x y p)))

data Converge a = Nada | Unstable a | Convergent a | Divergent deriving (Eq, Show)

converge :: Int -> (a -> a -> Bool) -> (a -> Bool) -> [a] -> Converge a
converge _ _ _ [] = Nada
converge n p d (x : xs) = go 0 p d x xs
  where
    go :: Int -> (a -> a -> Bool) -> (a -> Bool) -> a -> [a] -> Converge a
    go _ _ d' x' [] = bool (Unstable x') Divergent (d' x')
    go k p' d' x0 (x1 : xs')
      | d' x1 = Divergent
      | k > n = Unstable x1
      | p' x0 x1 = Convergent x1
      | otherwise = go (k + 1) p' d' x1 xs'

batchgd ::
  (Backprop b, Backprop p, Num b, Floating p) =>
  Int ->
  ([p] -> [p] -> Bool) ->
  ([p] -> Bool) ->
  p ->
  ModelG [p] [a] b ->
  [p] ->
  [([a], b)] ->
  Converge [p]
batchgd n pr d r f p0 xs' =
  converge n pr d $
    iterate (\ps -> zipWith (-) ps ((r *) <$> sqerrs f xs' ps)) p0

linBatch :: Meta Double -> [Double] -> [([Double], Double)] -> Converge [Double]
linBatch m =
  batchgd
    (m ^. #maxn)
    (\p p' -> (< (m ^. #tol)) $ sum $ zipWith (\x y -> abs (x - y)) p p')
    (any isNaN)
    (m ^. #rate)
    linReg

pixel' :: (Point Double -> Double) -> AB (Range Double) -> [Chart Double]
pixel' f (AB (Range amin amax) (Range bmin bmax)) =
  (\(r, c) -> Chart (RectA (RectStyle 0 black 0 c 1)) [SpotRect r])
    <$> pixelate f (toRect $ SR amin amax bmin bmax) (Point 100 100) blue grey

fsqerr :: [([Double], Double)] -> Point Double -> Double
fsqerr xs (Point a b) = sqrt $ sum $ (\(x, y) -> sqerre linReg x y [a, b]) <$> xs

pixel'' :: [([Double], Double)] -> [Chart Double]
pixel'' xs = pixel' (fsqerr xs) (AB (Range -5 0) (Range 0 2))


text:
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MagicHash             #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UnboxedTuples         #-}
{-# LANGUAGE UndecidableInstances  #-}

module Numeric.Matrix.Bidiagonal
  ( BiDiag (..), biDiag, bidiagonalHouseholder
  ) where

import Control.Monad
import Control.Monad.ST
import Data.Kind
import Numeric.Basics
import Numeric.DataFrame.ST
import Numeric.DataFrame.SubSpace
import Numeric.DataFrame.Type
import Numeric.Dimensions
import Numeric.Matrix.Internal
import Numeric.Scalar.Internal
import Numeric.Subroutine.Householder
import Numeric.Vector.Internal

-- | Put two vectors on the main and first upper diagonal.
biDiag :: forall (t :: Type) (n :: Nat) (m :: Nat)
        . (PrimBytes t, Num t)
       => Dims '[n,m]
       -> Vector t (Min n m)
       -> Vector t (Min n m)
       -> Matrix t n m
biDiag (dn@D :* dm@D :* U) a b = runST $ do
    dnm@D <- pure $ minDim dn dm
    rPtr <- thawDataFrame 0
    forM_ [0 .. dimVal dnm - 1] $ \i -> do
      writeDataFrame rPtr (Idx i :* Idx i :* U) $ a ! i
      when (i+1 < dimVal dm) $
        writeDataFrame rPtr (Idx i :* Idx (i+1) :* U) $ b ! i
    unsafeFreezeDataFrame rPtr

-- | Decomposition of a matrix \( A = U B V^\intercal \) such that
--   \( U \) and \( V \) are orthogonal and \( B \) is bidiagonal.
data BiDiag (t :: Type) (n :: Nat)  (m :: Nat)
  = BiDiag
  { bdU     :: Matrix t n n
    -- ^ \( U \) left orthogonal matrix
  , bdUDet  :: Scalar t
    -- ^ A shortcut for evaluating a determinant of \( |U| = \pm 1 \)
  , bdAlpha :: Vector t (Min n m)
    -- ^ Main diagonal of \( B \)
  , bdBeta  :: Vector t (Min n m)
    -- ^ First upper diagonal of \( B \);
    --   its last element equals zero if \( n \geq m \)
  , bdV     :: Matrix t m m
    -- ^ \( B \) left orthogonal matrix
  , bdVDet  :: Scalar t
    -- ^ A shortcut for evaluating a determinant of \( |V| = \pm 1 \)
  }

deriving instance ( Show t, PrimBytes t
                  , KnownDim n, KnownDim m, KnownDim (Min n m))
                  => Show (BiDiag t n m)
deriving instance ( Eq t, PrimBytes t
                  , KnownDim n, KnownDim m, KnownDim (Min n m)
                  , KnownBackend t '[Min n m])
                  => Eq (BiDiag t n m)

{- |
Decompose a matrix \( A = U B V^\intercal \) such that
\( U \) and \( V \) are orthogonal and \( B \) is bidiagonal.

The first returned number
 -}
bidiagonalHouseholder ::
       forall (t :: Type) (n :: Nat) (m :: Nat)
     . (PrimBytes t, Ord t, Epsilon t, KnownDim n, KnownDim m)
    => Matrix t n m
    -> BiDiag t n m
bidiagonalHouseholder a = runST $ do
      D <- pure $ minDim (dim @n) (dim @m)
      tmpNPtr <- newDataFrame
      tmpMPtr <- newDataFrame
      uPtr <- thawDataFrame eye
      bPtr <- thawDataFrame a
      vPtr <- thawDataFrame eye
      (ud, vd) <-
        let f (ud, vd) i = do
              ud' <- householderReflectionInplaceL tmpNPtr uPtr bPtr
                     (Idx (i - 1) :* Idx (i - 1) :* U)
              vd' <- householderReflectionInplaceR tmpMPtr vPtr bPtr
                     (Idx (i - 1) :* Idx i :* U)
              return (ud /= ud', vd /= vd')
        in foldM f (False, False) [1 .. lim - 1]

      udn <- householderReflectionInplaceL tmpNPtr uPtr bPtr
                     (Idx (lim - 1) :* Idx (lim - 1) :* U)
      vdn <- if (m > lim)
             then householderReflectionInplaceR tmpMPtr vPtr bPtr
                     (Idx (lim - 1) :* Idx lim :* U)
             else pure False
      bdU <- unsafeFreezeDataFrame uPtr
      bdV <- unsafeFreezeDataFrame vPtr
      b <- unsafeFreezeDataFrame bPtr
      let bdAlpha = iwgen @t @'[Min n m]
            (\(Idx i :* U) -> index (Idx i :* Idx i :* U) b)
          bdBeta  = iwgen @t @'[Min n m]
            (\(Idx i :* U) -> if i+1 < m then index (Idx i :* Idx (i+1) :* U) b else 0)
          bdUDet = if ud /= udn then -1 else 1
          bdVDet = if vd /= vdn then -1 else 1
      return BiDiag {..}
  where
    n = dimVal' @n
    m = dimVal' @m
    lim = max 1 (min n m)

max_stars_repo_name: achirkin/fasttensor

max_issues_repo_name: achirkin/fasttensor

max_forks_repo_name: achirkin/fasttensor


text:
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE GADTs                 #-}

module Test.Hedgehog.Hmatrix where

import           Grenade
import           Data.Singletons
import           Data.Singletons.TypeLits

import           Hedgehog (Gen)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

import qualified Numeric.LinearAlgebra.Static as HStatic

randomVector :: forall n. ( KnownNat n ) =>  Gen (HStatic.R n)
randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> Gen.int Range.linearBounded

uniformSample :: forall m n. ( KnownNat m, KnownNat n ) => Gen (HStatic.L m n)
uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> Gen.int Range.linearBounded

-- | Generate random data of the desired shape
genOfShape :: forall x. ( SingI x ) => Gen (S x)
genOfShape =
  case (sing :: Sing x) of
    D1Sing l ->
      withKnownNat l $
        S1D <$> randomVector
    D2Sing r c ->
      withKnownNat r $ withKnownNat c $
        S2D <$> uniformSample
    D3Sing r c d ->
      withKnownNat r $ withKnownNat c $ withKnownNat d $
        S3D <$> uniformSample

nice :: S shape -> String
nice (S1D x) = show . HStatic.extract $ x
nice (S2D x) = show . HStatic.extract $ x
nice (S3D x) = show . HStatic.extract $ x

max_stars_repo_name: koenigmaximilian/grenade

max_issues_repo_name: koenigmaximilian/grenade

max_forks_repo_name: koenigmaximilian/grenade


text:
-- Copyright 2021 Google LLC.
-- SPDX-License-Identifier: Apache-2.0

-- #region language extensions
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE RecordWildCards #-}

-- #endregion

module Main where

-- #region imports

import Control.Lens (each, folded, isn't, traversed, (%~), (&), (.~), (?~), (^.), (^..), (^?))
import Control.Lens.Extras (is)
import qualified Data.Array as A
import qualified Data.Array.Unboxed as UA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBS8
import Data.Generics.Labels ()
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Sequence (Seq (..))
import qualified Data.Sequence as Seq
import Data.Set (Set)
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as UV
import Debug.Trace (trace, traceShow, traceShowId)
import GHC.Generics (Generic)
import Linear (V2 (..))
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P
import qualified Text.Megaparsec.Char.Lexer as L
import Text.Pretty.Simple (pPrint, pShow)
import Text.Regex.PCRE ((=~))
import Util
import qualified Data.Graph.Inductive as G
import Data.Graph.Inductive.PatriciaTree (Gr)
import Safe
import Data.Functor ((<&>))
import Data.MemoTrie
import Data.Complex
import Linear.Vector ((*^))

-- #endregion

type Input = [Instruction]

type Output = Int

type Instruction = (Char, Int)
type ShipState = (V2 Int, V2 Int)

main :: IO ()
main = getContents >>= print . solve . parse

parse :: String -> Input
parse str = map parseEntry (lines str)
 where
  parseEntry [] = error "wrong entry"
  parseEntry (c:cs) = (c, read cs)

move :: Instruction -> ShipState -> ShipState
move ('N', n) (pos, dir) = (pos + V2 0 n, dir)
move ('S', n) (pos, dir) = (pos + V2 0 (-n), dir)
move ('E', n) (pos, dir) = (pos + V2 n 0, dir)
move ('W', n) (pos, dir) = (pos + V2 (-n) 0, dir)
move ('F', n) (pos, dir) = (pos + n *^ dir, dir)
move ('L', n) (pos, dir) = (pos, rotate n dir)
move ('R', n) (pos, dir) = (pos, rotate (-n) dir)
move _ _ = error "unknonw instruction"

rotate 0 dir = dir
rotate 90 (V2 1 0) = V2 0 1
rotate 90 (V2 0 1) = V2 (-1) 0
rotate 90 (V2 (-1) 0) = V2 0 (-1)
rotate 90 (V2 0 (-1)) = V2 1 0
rotate 180 dir = rotate 90 (rotate 90 dir)
rotate 270 dir = rotate 180 (rotate 90 dir)
rotate n dir = rotate (n `mod` 360) dir

solve :: Input -> Output
solve input =
  let (V2 x y, _) = foldl (flip move) (V2 0 0, V2 1 0) input
  in abs x + abs y

max_stars_repo_name: polux/advent-of-code

max_issues_repo_name: polux/advent-of-code

max_forks_repo_name: polux/advent-of-code


text:
{-# OPTIONS_GHC  -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-name-shadowing -fno-warn-missing-signatures #-}
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, FlexibleContexts, TypeSynonymInstances #-}

---------------------------------------------------------------------------------------------------
---------------------------------------------------------------------------------------------------
-- |
-- | Module : Test approx median
-- | Creator: Xiao Ling
-- | Created: 12/14/2015
-- | see    : http://www.serpentine.com/criterion/tutorial.html
-- |
---------------------------------------------------------------------------------------------------
---------------------------------------------------------------------------------------------------

module TapproxMedian where

import Control.Monad.Random.Class
import Control.Monad.Random
import Control.Monad.State
import Control.Monad.Reader

import Data.Conduit
import qualified Data.Conduit.List as Cl

import Core
import Statistics
import ApproxMedian

{-----------------------------------------------------------------------------
  Benchmark  counter vs counter'
------------------------------------------------------------------------------}

main :: IO ()
main = return ()


text:
{-|
Module: TerminalProgress
Description: Learn function with progress bar for terminal.
Copyright: (c) Alexander Ignatyev, 2017
License: BSD-3
Stability: experimental
Portability: POSIX

Learn function with progress bar for terminal.
-}

module MachineLearning.TerminalProgress
(
  learnWithProgressBar
  , learnOneVsAllWithProgressBar
)

where

import Data.List (transpose)
import MachineLearning.Types (Vector, Matrix)
import qualified MachineLearning.Classification.Internal as MLC
import Control.Monad (foldM, mapAndUnzipM)
import Control.DeepSeq (deepseq)
import qualified System.Console.AsciiProgress as AP
import qualified Numeric.LinearAlgebra as LA

-- | Learn the given function displaying progress bar in terminal.
-- It takes function, initial theta and number of iterations to call the function.
-- It returns theta and optimization path (see "MachineLearning.Optimization" for details).
learnWithProgressBar :: (Vector -> (Vector, Matrix)) -> Vector -> Int -> IO (Vector, Matrix)
learnWithProgressBar func initialTheta nIterations = AP.displayConsoleRegions $ do
  pg <- newProgressBar nIterations
  (theta, optPaths) <- foldM (doLoop pg func) (initialTheta, []) [1..nIterations]
  return (theta, buildOptPathMatrix $ reverse optPaths)

-- | Learn the given function displaying progress bar in terminal.
-- It takes function, list of outputs and list of initial thetas and number of iterations to call the function.
-- It returns list of thetas and list of optimization paths (see "MachineLearning.Optimization" for details).
learnOneVsAllWithProgressBar :: (Vector -> Vector -> (Vector, Matrix)) -> Vector -> [Vector] -> Int -> IO ([Vector], [Matrix])
learnOneVsAllWithProgressBar func y initialThetaList nIterations = AP.displayConsoleRegions $ do
    let numLabels = length initialThetaList
        ys = MLC.processOutputOneVsAll numLabels y
    pg <- newProgressBar $ nIterations * (length ys)
    mapAndUnzipM (learnOneClass pg func nIterations) $ zip ys initialThetaList

newProgressBar nIterations = AP.newProgressBar AP.def {
  AP.pgTotal = fromIntegral nIterations
  , AP.pgFormat = "Learning :percent [:bar] (for :elapsed, :eta remaining)"
  }

doLoop pg func (theta, optPaths) _ = do
  let (theta', optPath) = func theta
  theta' `deepseq` AP.tick pg
  return (theta', (optPath : optPaths))

learnOneClass pg func nIterations (y, theta) = do
  (theta, optPaths) <- foldM (doLoop pg $ func y) (theta, []) [1..nIterations]
  return (theta, buildOptPathMatrix $ reverse optPaths)

-- | Build a single optimazation path matrix from list of optimization path matrices.
buildOptPathMatrix :: [Matrix] -> Matrix
buildOptPathMatrix matrices = LA.fromBlocks $ map (\m -> [m]) matrices

max_stars_repo_name: aligusnet/mltool

max_issues_repo_name: aligusnet/mltool

max_forks_repo_name: aligusnet/mltool


text:
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE KindSignatures       #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE PolyKinds            #-}
{-# LANGUAGE QuasiQuotes          #-}
{-# LANGUAGE RankNTypes           #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE TypeInType           #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}

import           Control.Category
import           Control.DeepSeq
import           Control.Exception
import           Control.Monad
import           Data.Foldable
import           Data.Kind
import           Data.List hiding                      ((\\))
import           Data.Maybe
import           Data.Singletons
import           Data.Monoid
import           Data.Singletons.TypeLits
import           Data.Time.Clock
import           Options.Applicative
import           Prelude hiding                        ((.), id)
import           Statistics.Distribution.Uniform
import           System.Random.MWC
import           TensorOps.Backend.BTensor
import           TensorOps.Backend.NTensor
import           TensorOps.Learn.NeuralNet
import           TensorOps.Learn.NeuralNet.FeedForward
import           TensorOps.NatKind
import           TensorOps.Types
import           Text.PrettyPrint.ANSI.Leijen hiding   ((<>),(<$>))
import           Text.Printf
import           Type.Class.Higher.Util
import qualified Data.String.Here                      as H
import qualified TensorOps.Tensor                      as TT

netTest
    :: forall k (t :: [k] -> Type).
     ( Tensor t
     , ElemT t ~ Double
     , NFData1 t
     , NFData (t '[FromNat 1])
     , NFData (t '[FromNat 2])
     )
    => Proxy t
    -> Double
    -> Int
    -> [Integer]
    -> GenIO
    -> IO String
netTest _ rate n hs g = withSingI (sFromNat @k (SNat @1)) $
                        withSingI (sFromNat @k (SNat @2)) $ do
    ((inps,outs),tp) <- time $ do
      inps :: [t '[FromNat 2]] <- replicateM n (genRand (uniformDistr (-1) 1) g)
      let outs :: [t '[FromNat 1]]
          outs = flip map inps $ \v -> TT.konst $
                   if v `inCircle` (TT.konst 0.33, 0.33)
                        || v `inCircle` (TT.konst (-0.33), 0.33)
                     then 1
                     else 0
      evaluate . force $ (inps, outs)
    printf "Generated test points (%s)\n" (show tp)
    net0 :: Network t (FromNat 2) (FromNat 1)
            <- genNet (hs `zip` repeat actLogistic) actLogistic g
    let trained = foldl' trainEach net0 (zip inps outs)
          where
            trainEach :: SingI o
                      => Network t i o
                      -> (t '[i], t '[o])
                      -> Network t i o
            trainEach nt (i, o) = nt `deepseq` trainNetwork squaredError rate i o nt
    (trained', tn) <- time $ return trained
    printf "Network trained (%s)\n" (show tn)
    let outMat = [ [ render . TT.unScalar . join TT.dot . runNetwork trained' $
                       fromJust (TT.fromList [x / 25 - 1,y / 10 - 1])
                   | x <- [0..50] ]
                 | y <- [0..20] ]
        render r | r <= 0.2  = ' '
                 | r <= 0.4  = '.'
                 | r <= 0.6  = '-'
                 | r <= 0.8  = '='
                 | otherwise = '#'
    return $ unlines outMat
  where
    inCircle
        :: SingI n
        => t '[n]
        -> (t '[n], Double)
        -> Bool
    v `inCircle` (o, r) = let d = TT.zip (-) v o
                          in  TT.unScalar (d `TT.dot` d) <= r**2

data Opts = O { oRate    :: Double
              , oSamples :: Int
              , oNetwork :: [Integer]
              , oTests   :: [TestT]
              }

opts :: Parser Opts
opts = O <$> option auto
               ( long "rate" <> short 'r' <> metavar "STEP"
              <> help "Neural network learning rate"
              <> value 1 <> showDefault
               )
         <*> option auto
               ( long "samps" <> short 's' <> metavar "COUNT"
              <> help "Number of samples to train the network on"
              <> value 50000 <> showDefault
               )
         <*> option auto
               ( long "layers" <> short 'l' <> metavar "LIST"
              <> help "List of hidden layer sizes"
              <> value [12,8] <> showDefault
               )
         <*> (nub <$> (some (argument readBackend (metavar "BACKEND")))
               <|> pure [TTBLAS TBHMat]
             )

main :: IO ()
main = withSystemRandom $ \g -> do
    O{..} <- execParser $ info (helper <*> opts)
        ( fullDesc
       <> header "tensor-ops-dots - train neural nets with tensor-ops"
       <> progDescDoc (Just d)
        )

    printf "rate: %f | samps: %d | layers: %s\n" oRate oSamples (show oNetwork)

    forM_ oTests $ \t -> do
      printf "Training %s network ...\n" (ttLong t)
      let tester :: Double -> Int -> [Integer] -> GenIO -> IO String
          tester = case t of
            TTNested TVList -> netTest (Proxy @NTensorL)
            TTNested TVVect -> netTest (Proxy @NTensorV)
            TTBLAS   TBHMat -> netTest (Proxy @(BTensorV (HMat Double)))
      putStrLn =<< tester oRate oSamples oNetwork g
  where
    d :: Doc
    d = string [H.here|
Trains a feed-forward neural network on a 2D classifier using tensor-ops
machinery, with the given backends.  (If none provided, backend defaults to 'b')
|]
     <$$> mempty
     <$$> string "Backends:"
     <$$> vsep [ string $ printf "- %s: %s" (ttShort t) (ttLong t)
               | t <- allTests ]

time
    :: NFData a
    => IO a
    -> IO (a, NominalDiffTime)
time x = do
    t1 <- getCurrentTime
    y  <- evaluate . force =<< x
    t2 <- getCurrentTime
    return (y, t2 `diffUTCTime` t1)

data TestT = TTNested TestV
           | TTBLAS   TestB
           deriving (Show, Eq, Ord)
data TestV = TVList
           | TVVect
           deriving (Show, Eq, Ord)
data TestB = TBHMat
           deriving (Show, Eq, Ord)

allTests :: [TestT]
allTests = ([TTNested] <*> [TVList, TVVect]) ++ [TTBLAS TBHMat]

readBackend :: ReadM TestT
readBackend = eitherReader $ \s -> case s of
    "nl" -> Right $ TTNested TVList
    "nv" -> Right $ TTNested TVVect
    "b"  -> Right $ TTBLAS   TBHMat
    o    -> Left  $ "Unknown backend: " ++ o

ttShort
    :: TestT
    -> String
ttShort = \case
    TTNested v -> 'n' : tvShort v
    TTBLAS   b -> 'b' : tbShort b
  where
    tvShort = \case
      TVList -> "l"
      TVVect -> "v"
    tbShort = \case
      TBHMat -> ""

ttLong
    :: TestT
    -> String
ttLong = \case
    TTNested v -> printf "Nested (%s)" (tvLong v)
    TTBLAS   b -> printf "BLAS (%s)" (tbLong b)
  where
    tvLong = \case
      TVList -> "List"
      TVVect -> "Vector"
    tbLong = \case
      TBHMat -> "HMatrix"

max_stars_repo_name: mstksg/tensor-ops

max_issues_repo_name: mstksg/tensor-ops

max_forks_repo_name: mstksg/tensor-ops


text:
-- |
-- Module         : Eris.Compute.Similarity
-- Copyright      : (c) 2018 Emmett H. Ng
-- License        : BSD3
--
-- Maintainer     : emmettng@gmail.com
-- Stability      : experimental & educational
-- Portability    : portable
--
-- Functions of computing pairwise similarity and similarity matrix.
-- Documents:
-- 1. https://numerics.mathdotnet.com/Distance.html
module Eris.Compute.Similarity
  ( sumAbsoluteDifference
  , manhattanDistance
  , taxicab
  , meanAbsoluteDifference
  , euclideanDistance
  , sumSquaredDifference
  , meanSquaredDistance
  , minkowskiDistance
  , chebyshevDistance
  , canberraDistance
  , cosineDistance
  , cosineSimilarity
  , angularDistance
  , angularSimilarity
  , pearsonCC
  , pearsonCC'
  , pairWiseSimilarity
  ) where

import qualified Data.HashMap.Strict as Map
import Data.Maybe
import Numeric.LinearAlgebra

import Eris.Meta.DataStructure

-- | Manhattan Distance is Absolute Value Norm(L1) of (v1-v2)
manhattanDistance :: RankMetric
manhattanDistance = sumAbsoluteDifference

-- | Taxicab metric is Absolute Value Norm (L1) of (v1 - v2)
taxicab :: RankMetric
taxicab = sumAbsoluteDifference

-- | SAD is Absolute Value Norm(L1) of (v1 - v2)
sumAbsoluteDifference :: RankMetric
sumAbsoluteDifference l1 l2 = norm_1 (v1 - v2)
  where
    v1 = vector l1
    v2 = vector l2

-- | Mean absolute Difference (MAD)
-- | SAD average on all dimensions
meanAbsoluteDifference :: RankMetric
meanAbsoluteDifference l1 l2 = l1norm / n
  where
    l1norm = sumAbsoluteDifference l1 l2
    n = fromIntegral . length $ l1

-- | L2-normal
euclideanDistance :: RankMetric
euclideanDistance l1 l2 = norm_2 v
  where
    v = vector l1 - vector l2

-- | Squared L2-norm (SSD)
sumSquaredDifference :: RankMetric
sumSquaredDifference l1 l2 = v <.> v
  where
    v = vector l1 - vector l2

-- | Mean Sqaured Error (MSE)
meanSquaredDistance :: RankMetric
meanSquaredDistance l1 l2 = squaredL2 / n
  where
    squaredL2 = sumSquaredDifference l1 l2
    n = fromIntegral . length $ l1

-- | Root mean squared Error (rmse)
rootMeanSquaredError :: RankMetric
rootMeanSquaredError xs1 xs2 = euclideanDistance xs1 xs2 / sqrtN
  where
    sqrtN = sqrt . fromIntegral $ length xs1

-- | Minkowski Distance
-- This is a degenerate case of Minkowski distance
-- in this case p is an Integral number for sure.
minkowskiDistance :: Int -> RankMetric
minkowskiDistance p l1 l2 =
  let ld = zipWith (-) l1 l2
      absV = vector $! abs <$> ld
  in nroot p $ norm_1 $ pow p absV
  where
    pow :: Int -> Vector Rank -> Vector Rank
    pow 0 cv = 1
    pow 1 cv = cv
    pow n cv = pow (n - 1) $! cv * cv
    nroot
      :: (Integral a, Floating b)
      => a -> b -> b
    nroot 0 _ = 1
    nroot n f = f ** (1 / fromIntegral n)

-- | Chebyshev Distance
--
chebyshevDistance :: RankMetric
chebyshevDistance l1 l2 =
  let ld = abs <$> zipWith (-) l1 l2
  in maximum ld

-- | Hanmming Distance is minkowskiDistance with p=0
hammingDistance :: RankMetric
hammingDistance = minkowskiDistance 0

-- | Canberra Distance
-- weighted L1 norm
canberraDistance :: RankMetric
canberraDistance l1 l2 = l1norm / (l1s + l2s)
  where
    l1norm = sumAbsoluteDifference l1 l2
    l1s = sum $ abs <$> l1
    l2s = sum $ abs <$> l2

-- | Measure of similairty between two NON-ZERO vectors
-- See note/similarities.md for more information.
-- cosine similarity and cosine distance are not metric function.
cosineSimilarity :: RankMetric
cosineSimilarity l1 l2 = v1 <.> v2 / (norm_2 v1 * norm_2 v2)
  where
    v1 = vector l1
    v2 = vector l2

-- | Cosine Distance is not metric function
-- as it does not have the triangle inequality property
-- see angular similarity and angular distance (valid metric function) below.
cosineDistance :: RankMetric
cosineDistance l1 l2 = 1 - cosineSimilarity l1 l2

-- | angular distance represent the radians between two vector
-- it satisfies the triangle inequality
-- in a recommendation system, it is assumed that all vectors are  positive.
angularDistance :: RankMetric
angularDistance l1 l2 =
  let sim = cosineSimilarity l1 l2
      inverSim = acos sim
  in 2 * inverSim / pi

angularSimilarity :: RankMetric
angularSimilarity l1 l2 = 1 - angularSimilarity l1 l2

-- quickcheckout doc
-- pearsonCC and zscore relation doc
-- | Pearson Correlation Coefficient
-- It is cosine similarity between centered vectors.
-- reference to : https://stats.stackexchange.com/questions/235673/is-there-any-relationship-among-cosine-similarity-pearson-correlation-and-z-sc
-- necessity of centering : https://www.theanalysisfactor.com/center-on-the-mean/
pearsonCC :: RankMetric
pearsonCC l1 l2 = v1 <.> v2 / (norm_2 v1 * norm_2 v2)
  where
    len = fromIntegral . length $ l1
    tv1 = vector l1
    tv2 = vector l2
    m1 = sumElements tv1 / len
    m2 = sumElements tv2 / len
    v1 = tv1 - vector [m1]
    v2 = tv2 - vector [m2]

-- | Test shows that this implementation is supresingly better than above.
pearsonCC' :: RankMetric
pearsonCC' l1 l2 = z1 <.> z2 / d
  where
    z1 = zScore l1
    z2 = zScore l2
    d = fromIntegral . length $ l1

-- | a little bit involove actuallec
-- n : vector
-- std: popultaion standard deviation
-- z-score = v / std
zScore :: [Rank] -> Vector Rank
zScore xs = scale (recip std) v
  where
    x = vector xs
    n = fromIntegral . length $ xs
    meanX = sumElements x / n
    v = x - vector [meanX]
    std = norm_2 v / sqrt n

-- | A common operation is to subtracte mean
-- For performance reason, this function may not be exported.
centering :: [Rank] -> Vector Rank
centering xs = v - vector [vmean]
  where
    v = vector xs
    n = fromIntegral . length $ xs
    vmean = sumElements v / n

-- | merge two sorted list
--sortH :: Ord a => [a] -> [a] -> [a]
--sortH l1@(x:xs) l2@(y:ys)
--    | x <= y = x : sortH xs l2
--    | otherwise = y : sortH l1 ys
--sortH [] l2 = l2
--sortH l1 [] = l1
pairWiseSimilarity
  :: Threshold
  -> SimilarityMatrix -- fold cum
  -> RankMetric -- distance func
  -> ECount -- rating records
  -> SimilarityMatrix
pairWiseSimilarity bar cumSM sfn ecount =
  let target = head . Map.toList $ ecount
      items = tail . Map.toList $ ecount
      sVector = pairwiseAuxil target <$> items
      sMatrix = composeMatrix target items sVector
  in if null items
       then Map.union cumSM sMatrix
       else pairWiseSimilarity
              bar
              (Map.union cumSM sMatrix)
              sfn
              (Map.fromList items)
  where
    pairwiseAuxil :: (EID, ESMap) -> (EID, ESMap) -> Double
    pairwiseAuxil (_, tMap) (_, iMap) = esmapSFN tMap iMap
    esmapSFN :: ESMap -> ESMap -> Double
    esmapSFN t i =
      let intersect = Map.toList $ Map.intersection t i
          tv =
            [ snd v
            | v <- intersect ]
          iv =
            catMaybes
              [ Map.lookup (fst v) i
              | v <- intersect ]
      in if null intersect
           then 0
           else sfn tv iv
    composeMatrix :: (EID, ESMap) -> [(EID, ESMap)] -> [Double] -> SimilarityMatrix
    composeMatrix tt ilist slist =
      let tid = fst tt
          idList =
            [ fst v
            | v <- ilist ]
          tidSelf = Map.fromList [(tid, 1)]
          tmpDict = Map.union tidSelf $ Map.fromList $ zip idList slist
      in Map.fromList [(tid, tmpDict)]

max_stars_repo_name: emmettng/eris

max_issues_repo_name: emmettng/eris

max_forks_repo_name: emmettng/eris


text:
{-# LANGUAGE FlexibleContexts #-}
-- |
-- Module    : Statistics.Quantile
-- Copyright : (c) 2009 Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- Functions for approximating quantiles, i.e. points taken at regular
-- intervals from the cumulative distribution function of a random
-- variable.
--
-- The number of quantiles is described below by the variable /q/, so
-- with /q/=4, a 4-quantile (also known as a /quartile/) has 4
-- intervals, and contains 5 points.  The parameter /k/ describes the
-- desired point, where 0 ≤ /k/ ≤ /q/.

module Statistics.Quantile
    (
    -- * Quantile estimation functions
      weightedAvg
    , ContParam(..)
    , continuousBy
    , midspread

    -- * Parameters for the continuous sample method
    , cadpw
    , hazen
    , s
    , spss
    , medianUnbiased
    , normalUnbiased

    -- * References
    -- $references
    ) where

import Data.Vector.Generic ((!))
import Numeric.MathFunctions.Constants (m_epsilon)
import Statistics.Function (partialSort)
import qualified Data.Vector as V
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U

-- | O(/n/ log /n/). Estimate the /k/th /q/-quantile of a sample,
-- using the weighted average method.
weightedAvg :: G.Vector v Double =>
               Int        -- ^ /k/, the desired quantile.
            -> Int        -- ^ /q/, the number of quantiles.
            -> v Double   -- ^ /x/, the sample data.
            -> Double
weightedAvg k q x
  | G.any isNaN x   = modErr "weightedAvg" "Sample contains NaNs"
  | n == 1          = G.head x
  | q < 2           = modErr "weightedAvg" "At least 2 quantiles is needed"
  | k < 0 || k >= q = modErr "weightedAvg" "Wrong quantile number"
  | otherwise       = xj + g * (xj1 - xj)
  where
    j   = floor idx
    idx = fromIntegral (n - 1) * fromIntegral k / fromIntegral q
    g   = idx - fromIntegral j
    xj  = sx ! j
    xj1 = sx ! (j+1)
    sx  = partialSort (j+2) x
    n   = G.length x
{-# SPECIALIZE weightedAvg :: Int -> Int -> U.Vector Double -> Double #-}
{-# SPECIALIZE weightedAvg :: Int -> Int -> V.Vector Double -> Double #-}

-- | Parameters /a/ and /b/ to the 'continuousBy' function.
data ContParam = ContParam {-# UNPACK #-} !Double {-# UNPACK #-} !Double

-- | O(/n/ log /n/). Estimate the /k/th /q/-quantile of a sample /x/,
-- using the continuous sample method with the given parameters.  This
-- is the method used by most statistical software, such as R,
-- Mathematica, SPSS, and S.
continuousBy :: G.Vector v Double =>
                ContParam  -- ^ Parameters /a/ and /b/.
             -> Int        -- ^ /k/, the desired quantile.
             -> Int        -- ^ /q/, the number of quantiles.
             -> v Double   -- ^ /x/, the sample data.
             -> Double
continuousBy (ContParam a b) k q x
  | q < 2          = modErr "continuousBy" "At least 2 quantiles is needed"
  | k < 0 || k > q = modErr "continuousBy" "Wrong quantile number"
  | G.any isNaN x  = modErr "continuousBy" "Sample contains NaNs"
  | otherwise      = (1-h) * item (j-1) + h * item j
  where
    j               = floor (t + eps)
    t               = a + p * (fromIntegral n + 1 - a - b)
    p               = fromIntegral k / fromIntegral q
    h | abs r < eps = 0
      | otherwise   = r
      where r       = t - fromIntegral j
    eps             = m_epsilon * 4
    n               = G.length x
    item            = (sx !) . bracket
    sx              = partialSort (bracket j + 1) x
    bracket m       = min (max m 0) (n - 1)
{-# SPECIALIZE
    continuousBy :: ContParam -> Int -> Int -> U.Vector Double -> Double #-}
{-# SPECIALIZE
    continuousBy :: ContParam -> Int -> Int -> V.Vector Double -> Double #-}

-- | O(/n/ log /n/). Estimate the range between /q/-quantiles 1 and
-- /q/-1 of a sample /x/, using the continuous sample method with the
-- given parameters.
--
-- For instance, the interquartile range (IQR) can be estimated as
-- follows:
--
-- > midspread medianUnbiased 4 (U.fromList [1,1,2,2,3])
-- > ==> 1.333333
midspread :: G.Vector v Double =>
             ContParam  -- ^ Parameters /a/ and /b/.
          -> Int        -- ^ /q/, the number of quantiles.
          -> v Double   -- ^ /x/, the sample data.
          -> Double
midspread (ContParam a b) k x
  | G.any isNaN x = modErr "midspread" "Sample contains NaNs"
  | k <= 0        = modErr "midspread" "Nonpositive number of quantiles"
  | otherwise     = quantile (1-frac) - quantile frac
  where
    quantile i        = (1-h i) * item (j i-1) + h i * item (j i)
    j i               = floor (t i + eps) :: Int
    t i               = a + i * (fromIntegral n + 1 - a - b)
    h i | abs r < eps = 0
        | otherwise   = r
        where r       = t i - fromIntegral (j i)
    eps               = m_epsilon * 4
    n                 = G.length x
    item              = (sx !) . bracket
    sx                = partialSort (bracket (j (1-frac)) + 1) x
    bracket m         = min (max m 0) (n - 1)
    frac              = 1 / fromIntegral k
{-# SPECIALIZE midspread :: ContParam -> Int -> U.Vector Double -> Double #-}
{-# SPECIALIZE midspread :: ContParam -> Int -> V.Vector Double -> Double #-}

-- | California Department of Public Works definition, /a/=0, /b/=1.
-- Gives a linear interpolation of the empirical CDF.  This
-- corresponds to method 4 in R and Mathematica.
cadpw :: ContParam
cadpw = ContParam 0 1

-- | Hazen's definition, /a/=0.5, /b/=0.5.  This is claimed to be
-- popular among hydrologists.  This corresponds to method 5 in R and
-- Mathematica.
hazen :: ContParam
hazen = ContParam 0.5 0.5

-- | Definition used by the SPSS statistics application, with /a/=0,
-- /b/=0 (also known as Weibull's definition).  This corresponds to
-- method 6 in R and Mathematica.
spss :: ContParam
spss = ContParam 0 0

-- | Definition used by the S statistics application, with /a/=1,
-- /b/=1.  The interpolation points divide the sample range into @n-1@
-- intervals.  This corresponds to method 7 in R and Mathematica.
s :: ContParam
s = ContParam 1 1

-- | Median unbiased definition, /a/=1\/3, /b/=1\/3. The resulting
-- quantile estimates are approximately median unbiased regardless of
-- the distribution of /x/.  This corresponds to method 8 in R and
-- Mathematica.
medianUnbiased :: ContParam
medianUnbiased = ContParam third third
    where third = 1/3

-- | Normal unbiased definition, /a/=3\/8, /b/=3\/8.  An approximately
-- unbiased estimate if the empirical distribution approximates the
-- normal distribution.  This corresponds to method 9 in R and
-- Mathematica.
normalUnbiased :: ContParam
normalUnbiased = ContParam ta ta
    where ta = 3/8

modErr :: String -> String -> a
modErr f err = error $ "Statistics.Quantile." ++ f ++ ": " ++ err

-- $references
--
-- * Weisstein, E.W. Quantile. /MathWorld/.
--   <http://mathworld.wolfram.com/Quantile.html>
--
-- * Hyndman, R.J.; Fan, Y. (1996) Sample quantiles in statistical
--   packages. /American Statistician/
--   50(4):361–365. <http://www.jstor.org/stable/2684934>

max_stars_repo_name: StefanHubner/statistics

max_issues_repo_name: StefanHubner/statistics

max_forks_repo_name: StefanHubner/statistics


text:
{-# LANGUAGE CPP #-}
-- |
-- This module reexports most of the definitions from the \"base\" package,
-- which are meant to be imported unqualified.
--
-- For details check out the source.
module Lazy.Prelude
(
  module Exports,
  -- * Reimplementations of functions presented in versions of \"base\" newer than 4.6
  -- ** Data.Bool
  bool,
  -- ** Data.Function
  (&),
  -- ** Data.Functor
  ($>),
  -- ** Data.List
  isSubsequenceOf,
  sortOn,
  uncons,
  -- ** Debug.Trace
  traceShowId,
  traceM,
  traceShowM,
)
where

-- Reexports
-------------------------

import Control.Applicative as Exports
import Control.Arrow as Exports hiding (first, second)
import Control.Category as Exports
import Control.Concurrent as Exports
import Control.Comonad as Exports hiding (($>))
import Control.Exception as Exports
import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)
import Control.Monad.Fix as Exports hiding (fix)
import Control.Monad.ST as Exports
import Data.Bits as Exports
import Data.Bool as Exports hiding (bool)
import Data.Char as Exports
import Data.Complex as Exports
import Data.Data as Exports
import Data.Dynamic as Exports
import Data.Either as Exports
import Data.Fixed as Exports
import Data.Foldable as Exports
import Data.Functor as Exports hiding (($>))
import Data.Function as Exports hiding ((.), id, (&))
import Data.Int as Exports
import Data.IORef as Exports
import Data.Ix as Exports
import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')
import Data.Maybe as Exports
import Data.Monoid as Exports
import Data.Ord as Exports
import Data.Ratio as Exports
import Data.STRef as Exports
import Data.String as Exports
import Data.Traversable as Exports
import Data.Tuple as Exports
import Data.Unique as Exports
import Data.Version as Exports
import Data.Word as Exports
import Debug.Trace as Exports hiding (traceShowId, traceM, traceShowM)
import Foreign.Storable as Exports
import Foreign.Ptr as Exports
import Foreign.ForeignPtr as Exports
import Foreign.StablePtr as Exports
import GHC.Conc as Exports hiding (withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)
import GHC.Exts as Exports (lazy, inline, sortWith, groupWith)
import GHC.Generics as Exports (Generic)
import GHC.IO.Exception as Exports
import Numeric as Exports
import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.))
import System.Environment as Exports
import System.Exit as Exports
import System.IO as Exports (Handle, hClose)
import System.IO.Error as Exports
import System.IO.Unsafe as Exports
import System.Mem as Exports
import System.Mem.StableName as Exports
import System.Timeout as Exports
import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)
import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)
import Text.Printf as Exports (printf, hPrintf)
import Text.Read as Exports (Read(..), readMaybe, readEither)
import Unsafe.Coerce as Exports

-- Conditional imports for newer bases
#if MIN_VERSION_base(4,7,0)
import Data.Coerce as Exports
import Data.Proxy as Exports
#endif
#if MIN_VERSION_base(4,8,0)
import Data.Bifunctor as Exports
import Data.Functor.Identity as Exports
import Data.Void as Exports
import Numeric.Natural as Exports
#endif
#if MIN_VERSION_base(4,9,0)
import Control.Monad.Fail as Exports (MonadFail)
import Control.Monad.IO.Class as Exports
import Data.Functor.Classes as Exports
import Data.Functor.Compose as Exports
import Data.List.NonEmpty as Exports (NonEmpty(..))
import Data.Semigroup as Exports hiding ((<>), First(..), Last(..))
#endif

-- Conditional imports for reimplementations
#if MIN_VERSION_base(4,7,0)
import Data.Bool (bool)
import Debug.Trace (traceShowId, traceM, traceShowM)
import Data.Functor (($>))
#endif
#if MIN_VERSION_base(4,8,0)
import Data.Function ((&))
import Data.List (isSubsequenceOf, sortOn, uncons)
#endif

---------------------------------
-- Reimplementations for base-4.7
---------------------------------

#if !MIN_VERSION_base(4,7,0)

-- | Case analysis for the 'Bool' type.
-- @bool a b p@ evaluates to @a@ when @p@ is @False@, and evaluates to @b@
-- when @p@ is @True@.
bool :: a -> a -> Bool -> a
bool f t b = if b then t else f

{-|
Like 'traceShow' but returns the shown value instead of a third value.
-}
traceShowId :: (Show a) => a -> a
traceShowId a = trace (show a) a

{-|
Like 'trace' but returning unit in an arbitrary monad. Allows for convenient
use in do-notation. Note that the application of 'trace' is not an action in the
monad, as 'traceIO' is in the 'IO' monad.

> ... = do
>   x <- ...
>   traceM $ "x: " ++ show x
>   y <- ...
>   traceM $ "y: " ++ show y
-}
traceM :: (Monad m) => String -> m ()
traceM string = trace string $ return ()

{-|
Like 'traceM', but uses 'show' on the argument to convert it to a 'String'.

> ... = do
>   x <- ...
>   traceShowM $ x
>   y <- ...
>   traceShowM $ x + y
-}
traceShowM :: (Show a, Monad m) => a -> m ()
traceShowM = traceM . show

infixl 4 $>

-- | Flipped version of '<$'.
($>) :: Functor f => f a -> b -> f b
($>) = flip (<$)

#endif

---------------------------------
-- Reimplementations for base-4.8
---------------------------------

#if !MIN_VERSION_base(4,8,0)

infixl 1 &

-- | '&' is a reverse application operator.  This provides notational
-- convenience.  Its precedence is one higher than that of the forward
-- application operator '$', which allows '&' to be nested in '$'.
(&) :: a -> (a -> b) -> b
x & f = f x

-- | The 'isSubsequenceOf' function takes two lists and returns 'True' if the
-- first list is a subsequence of the second list.
--
-- @'isSubsequenceOf' x y@ is equivalent to @'elem' x ('subsequences' y)@.
--
-- ==== __Examples__
--
-- >>> isSubsequenceOf "GHC" "The Glorious Haskell Compiler"
-- True
-- >>> isSubsequenceOf ['a','d'..'z'] ['a'..'z']
-- True
-- >>> isSubsequenceOf [1..10] [10,9..0]
-- False
isSubsequenceOf :: (Eq a) => [a] -> [a] -> Bool
isSubsequenceOf []    _                    = True
isSubsequenceOf _     []                   = False
isSubsequenceOf a@(x:a') (y:b) | x == y    = isSubsequenceOf a' b
                               | otherwise = isSubsequenceOf a b

-- | Decompose a list into its head and tail. If the list is empty,
-- returns 'Nothing'. If the list is non-empty, returns @'Just' (x, xs)@,
-- where @x@ is the head of the list and @xs@ its tail.
uncons        :: [a] -> Maybe (a, [a])
uncons []     = Nothing
uncons (x:xs) = Just (x, xs)

-- | Sort a list by comparing the results of a key function applied to each
-- element.  @sortOn f@ is equivalent to @sortBy . comparing f@, but has the
-- performance advantage of only evaluating @f@ once for each element in the
-- input list.  This is called the decorate-sort-undecorate paradigm, or
-- Schwartzian transform.
sortOn :: Ord b => (a -> b) -> [a] -> [a]
sortOn f =
  map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))

#endif

max_stars_repo_name: nikita-volkov/lazy

max_issues_repo_name: nikita-volkov/lazy

max_forks_repo_name: nikita-volkov/lazy


text:
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

module NeuralNetwork where

import Control.Lens
import Numeric.LinearAlgebra

stepFunction :: Double -> Double
stepFunction x | x > 0 = 1.0
               | otherwise = 0.0

sigmoidFunction :: Double -> Double
sigmoidFunction x = 1 / (1 + (exp (-x)))

reluFunction :: Double -> Double
reluFunction = max 0

-- |
-- >>> :set -XOverloadedLists
-- >>> softmax [1010, 1000, 990]
-- [0.999954600070331,4.539786860886666e-5,2.061060046209062e-9]
-- >>> softmax [0.3, 2.9, 4.0]
-- [1.821127329554753e-2,0.24519181293507392,0.7365969137693786]
-- >>> sumElements $ softmax [0.3, 2.9, 4.0]
-- 1.0
softmax :: Vector R -> Vector R
softmax xs = cmap (/denom) ys
  where ys = cmap calc xs
        calc x = exp (x - c)
        c = maxElement xs
        denom = sumElements ys

-- |
-- >>> :set -XOverloadedLists
-- >>> meanSquaredError [0, 0, 1, 0, 0, 0, 0, 0, 0, 0] [0.1, 0.05, 0.6, 0, 0.05, 0.1, 0, 0.1, 0, 0]
-- 9.750000000000003e-2
-- >>> meanSquaredError [0, 0, 1, 0, 0, 0, 0, 0, 0, 0] [0.1, 0.05, 0.1, 0, 0.05, 0.1, 0, 0.6, 0.5, 0]
-- 0.7224999999999999
meanSquaredError :: Vector R -> Vector R -> Double
meanSquaredError t y = (/2) $ sumElements $ cmap (^2) $ t - y

-- |
-- >>> :set -XOverloadedLists
-- >>> crossEntropyError [0, 0, 1, 0, 0, 0, 0, 0, 0, 0] [0.1, 0.05, 0.6, 0, 0.05, 0.1, 0, 0.1, 0, 0]
-- 0.510825457099338
-- >>> crossEntropyError [0, 0, 1, 0, 0, 0, 0, 0, 0, 0] [0.1, 0.05, 0.1, 0, 0.05, 0.1, 0, 0.6, 0.5, 0]
-- 2.302584092994546
crossEntropyError :: Vector R -> Vector R -> Double
crossEntropyError t y = negate $ dot t $ cmap (log . (+delta)) y
  where delta = 1e-7 :: Double

-- |
-- >>> function1 x = 0.01 * x * x + 0.1 * x
-- >>> numericalDiff function1 5
-- 0.1999999999990898
-- >>> numericalDiff function1 10
-- 0.2999999999997449
-- >>> function2 x y = x * x + y * y
-- >>> numericalDiff (flip function2 4) 3
-- 6.00000000000378
-- >>> numericalDiff (function2 3) 4
-- 7.999999999999119
numericalDiff :: (Double -> Double) -> Double -> Double
numericalDiff f x = (f (x + h) - f (x - h)) / (2 * h)
  where h = 1e-4 :: Double

-- |
-- >>> function2 v = dot v v
-- >>> numericalGradient function2 $ vector [3.0, 4.0]
-- [6.00000000000378,7.999999999999119]
-- >>> numericalGradient function2 $ vector [0.0, 2.0]
-- [0.0,4.000000000004]
-- >>> numericalGradient function2 $ vector [3.0, 0.0]
-- [6.000000000012662,0.0]
numericalGradient
  :: (Gradible c)
  => ((c R) -> R) -> c R -> c R
numericalGradient f v = assoc (size v) 0 xs
  where
    h = 1e-4 :: R
    size' = size v
    xs = do
      idx <- indicesOf v
      let v1 = v - assoc size' 0 [(idx, h)]
          v2 = v + assoc size' 0 [(idx, h)]
          x' = f v2 - f v1
      return (idx, x' / (2 * h))

-- |
-- >>> function2 v = dot v v
-- >>> gradientDescent function2 (vector [-3.0, 4.0]) 0.1 100
-- [-6.111107928998789e-10,8.148143905314271e-10]
gradientDescent :: ((Vector R) -> Double) -> Vector R -> Double -> Int -> Vector R
gradientDescent f v lr steps = gradientDescents f lr v !! steps

-- |
-- >>> function2 v = dot v v
-- >>> take 3 $ gradientDescents function2 0.1 (vector [-3.0, 4.0])
-- [[-3.0,4.0],[-2.399999999999622,3.200000000000088],[-1.9199999999982538,2.5599999999976717]]
gradientDescents :: ((Vector R) -> Double) -> Double -> Vector R -> [Vector R]
gradientDescents f lr v = iterate desc v
  where desc v = v - cmap (* lr) (numericalGradient f v)

class (Container c R, Num (c R)) => Gradible c where
  indicesOf :: c R -> [IndexOf c]

instance Gradible Vector where
  indicesOf v = take (size v) [0..]

instance Gradible Matrix where
  indicesOf w = (,) <$> (take (rows w) [0..]) <*> (take (cols w) [0..])

max_stars_repo_name: kayhide/deep-learning-from-scratch

max_issues_repo_name: kayhide/zero-to-deep-learning

max_forks_repo_name: kayhide/zero-to-deep-learning